Génération de codes à barres 2D (PDF417 ou QR) en utilisant Excel VBA

Génération de codes à barres 2D (PDF417 ou QR) en utilisant Excel VBA

Laisser un commentaire / Graveur Laser Bois / Par

Le module VBA Barcode-VBA-Macro-Only (mentionné par Sébastien Ferry dans les commentaires) est un pur générateur de code VBA 1D / 2D créé par Jiri Gabriel sous licence MIT en 2013.

Le code n'est pas complètement simple à comprendre, mais de nombreux commentaires ont été traduits du tchèque en anglais dans la version liée ci-dessus.

Découpe Laser Bois Banner | R3V Laser

Pour l'utiliser dans une feuille de calcul, copiez ou importez simplement BarCody.bas dans votre VBA dans un module. Dans une feuille de travail, placez la fonction comme celle-ci:

=EncodeBarcode(CELL("SHEET"),CELL("ADDRESS"),A2,51,1,0,2)

L'utilisation est la suivante:

  1. Laisser le CELL("SHEET) et CELL("ADDRESS") Comme ils le sont, car il ne fait que faire référence à la feuille de travail et à l'adresse cellulaire, vous avez la formule
    • A2 est la cellule que vous avez votre chaîne à coder. Dans mon cas, c'est la cellule A2, vous pouvez passer « texte » avec des citations pour faire de même. Avoir la cellule le rend plus dynamique
    • 51 est l'option pour le code QR. Les autres options sont 1 = EAN8 / 13 / UPCA / UPCE, 2 = deux des cinq entrelacés, 3 = Code39, 50 = Matrice de données, 51 = QRCODE
      • 1 est pour le mode graphique. Le code-barres est dessiné sur un objet de forme. 0 pour le mode de police. Je suppose que vous devez installer le type de police. Pas aussi utile.
      • 0 est le paramètre du type de code-barres particulier. Pour qr_code, 0 = correction d'erreur faible, 1 = correction d'erreur moyenne, 2 = correction d'erreur en quartile, 3 = correction d'erreur élevée.
      • 2 ne s'applique qu'aux codes 1D. Ce sont les zones tampons. Je ne suis pas certain de ce qu'il fait exactement mais probablement quelque chose à voir avec les espaces de barre 1D?

J'ai ajouté des fonctions de wrapper pour en faire un appel de fonction VBA pur plutôt que de l'utiliser comme formule dans une feuille de calcul:

Public Sub RenderQRCode(workSheetName As String, cellLocation As String, textValue As String)
   Dim s_param As String
   Dim s_encoded As String
   Dim xSheet As Worksheet
   Dim QRShapeName As String
   Dim QRLabelName As String

   s_param = "mode=Q"
   s_encoded = qr_gen(textValue, s_param)
   Call DrawQRCode(s_encoded, workSheetName, cellLocation)

   Set xSheet = Worksheets(workSheetName)
   QRShapeName = "BC" & "$" & Left(cellLocation, 1) _
       & "$" & Right(cellLocation, Len(cellLocation) - 1) & "#GR"

   QRLabelName = QRShapeName & "_Label"

   With xSheet.Shapes(QRShapeName)
       .Width = 30
       .Height = 30
   End With

   On Error Resume Next
   If Not (xSheet.Shapes(QRLabelName) Is Nothing) Then
       xSheet.Shapes(QRLabelName).Delete
   End If

   xSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, _
       xSheet.Shapes(QRShapeName).Left+35, _
       xSheet.Shapes(QRShapeName).Top, _                          
       Len(textValue) * 6, 30) _
       .Name = QRLabelName


   With xSheet.Shapes(QRLabelName)
       .Line.Visible = msoFalse
       .TextFrame2.TextRange.Font.Name = "Arial"
       .TextFrame2.TextRange.Font.Size = 9
       .TextFrame.Characters.Text = textValue
       .TextFrame2.VerticalAnchor = msoAnchorMiddle
   End With
End Sub

Sub DrawQRCode(xBC As String, workSheetName As String, rangeName As String, Optional xNam As String)
 Dim xShape As Shape, xBkgr As Shape
 Dim xSheet As Worksheet
 Dim xRange As Range, xCell As Range
 Dim xAddr As String
 Dim xPosOldX As Double, xPosOldY As Double
 Dim xSizeOldW As Double, xSizeOldH As Double
 Dim x, y, m, dm, a As Double
 Dim b%, n%, w%, p$, s$, h%, g%

Set xSheet = Worksheets(workSheetName)
Set xRange = Worksheets(workSheetName).Range(rangeName)
xAddr = xRange.Address
xPosOldX = xRange.Left
xPosOldY = xRange.Top

 xSizeOldW = 0
 xSizeOldH = 0
 s = "BC" & xAddr & "#GR"
 x = 0#
 y = 0#
 m = 2.5
 dm = m * 2#
 a = 0#
 p = Trim(xBC)
 b = Len(p)
 For n = 1 To b
   w = AscL(Mid(p, n, 1)) Mod 256
   If (w >= 97 And w <= 112) Then
     a = a + dm
   ElseIf w = 10 Or n = b Then
     If x < a Then x = a
     y = y + dm
     a = 0#
   End If
 Next n
 If x <= 0# Then Exit Sub
 On Error Resume Next
 Set xShape = xSheet.Shapes(s)
 On Error GoTo 0
 If Not (xShape Is Nothing) Then
   xPosOldX = xShape.Left
   xPosOldY = xShape.Top
   xSizeOldW = xShape.Width
   xSizeOldH = xShape.Height
   xShape.Delete
 End If
 On Error Resume Next
 xSheet.Shapes("BC" & xAddr & "#BK").Delete
 On Error GoTo 0
 Set xBkgr = xSheet.Shapes.AddShape(msoShapeRectangle, 0, 0, x, y)
 xBkgr.Line.Visible = msoFalse
 xBkgr.Line.Weight = 0#
 xBkgr.Line.ForeColor.RGB = RGB(255, 255, 255)
 xBkgr.Fill.Solid
 xBkgr.Fill.ForeColor.RGB = RGB(255, 255, 255)
 xBkgr.Name = "BC" & xAddr & "#BK"
 Set xShape = Nothing
 x = 0#
 y = 0#
 g = 0
 For n = 1 To b
   w = AscL(Mid(p, n, 1)) Mod 256
   If w = 10 Then
     y = y + dm
     x = 0#
   ElseIf (w >= 97 And w <= 112) Then
     w = w - 97
     With xSheet.Shapes
     Select Case w
       Case 1: Set xShape = .AddShape(msoShapeRectangle, x, y, m, m): GoSub fmtxshape
       Case 2: Set xShape = .AddShape(msoShapeRectangle, x + m, y, m, m): GoSub fmtxshape
       Case 3: Set xShape = .AddShape(msoShapeRectangle, x, y, dm, m): GoSub fmtxshape
       Case 4: Set xShape = .AddShape(msoShapeRectangle, x, y + m, m, m): GoSub fmtxshape
       Case 5: Set xShape = .AddShape(msoShapeRectangle, x, y, m, dm): GoSub fmtxshape
       Case 6: Set xShape = .AddShape(msoShapeRectangle, x + m, y, m, m): GoSub fmtxshape
               Set xShape = .AddShape(msoShapeRectangle, x, y + m, m, m): GoSub fmtxshape
       Case 7: Set xShape = .AddShape(msoShapeRectangle, x, y, dm, m): GoSub fmtxshape
               Set xShape = .AddShape(msoShapeRectangle, x, y + m, m, m): GoSub fmtxshape
       Case 8: Set xShape = .AddShape(msoShapeRectangle, x + m, y + m, m, m): GoSub fmtxshape
       Case 9: Set xShape = .AddShape(msoShapeRectangle, x, y, m, m): GoSub fmtxshape
               Set xShape = .AddShape(msoShapeRectangle, x + m, y + m, m, m): GoSub fmtxshape
       Case 10: Set xShape = .AddShape(msoShapeRectangle, x + m, y, m, dm): GoSub fmtxshape
       Case 11: Set xShape = .AddShape(msoShapeRectangle, x, y, dm, m): GoSub fmtxshape
                Set xShape = .AddShape(msoShapeRectangle, x + m, y + m, m, m): GoSub fmtxshape
       Case 12: Set xShape = .AddShape(msoShapeRectangle, x, y + m, dm, m): GoSub fmtxshape
       Case 13: Set xShape = .AddShape(msoShapeRectangle, x, y, m, m): GoSub fmtxshape
                Set xShape = .AddShape(msoShapeRectangle, x, y + m, dm, m): GoSub fmtxshape
       Case 14: Set xShape = .AddShape(msoShapeRectangle, x + m, y, m, m): GoSub fmtxshape
                Set xShape = .AddShape(msoShapeRectangle, x, y + m, dm, m): GoSub fmtxshape
       Case 15: Set xShape = .AddShape(msoShapeRectangle, x, y, dm, dm): GoSub fmtxshape
     End Select
     End With
     x = x + dm
   End If
 Next n
 On Error Resume Next
 Set xShape = xSheet.Shapes(s)
 On Error GoTo 0
 If Not (xShape Is Nothing) Then
   xShape.Left = xPosOldX
   xShape.Top = xPosOldY
   If xSizeOldW > 0 Then
     xShape.Width = xSizeOldW
     xShape.Height = xSizeOldH
   End If
 Else
   If Not (xBkgr Is Nothing) Then xBkgr.Delete
 End If
 Exit Sub
fmtxshape:
  xShape.Line.Visible = msoFalse
  xShape.Line.Weight = 0#
  xShape.Fill.Solid
  xShape.Fill.ForeColor.RGB = RGB(0, 0, 0)
  g = g + 1
  xShape.Name = "BC" & xAddr & "#BR" & g
  If g = 1 Then
    xSheet.Shapes.Range(Array(xBkgr.Name, xShape.Name)).Group.Name = s
  Else
    xSheet.Shapes.Range(Array(s, xShape.Name)).Group.Name = s
  End If
  Return

End Sub

Avec ce wrapper, vous pouvez maintenant simplement appeler pour rendre QRCode en appelant cela dans VBA:

Call RenderQRCode("Sheet1", "A13", "QR Value")

Entrez simplement le nom de la feuille de travail, l'emplacement des cellules et le QR_VALUE. La forme QR sera dessinée à l'emplacement que vous avez spécifié.

Vous pouvez jouer avec cette section du code pour modifier la taille du QR

With xSheet.Shapes(QRShapeName)
       .Width = 30  'change your size
       .Height = 30  'change your size
   End With

Source link

Articles liés

Laisser un commentaire

Votre adresse e-mail ne sera pas publiée. Les champs obligatoires sont indiqués avec *

Panier
Retour en haut
découpe laser pub