使用Excel VBA生成2D（PDF417或QR）条形码 [英] Generating 2D (PDF417 or QR) barcodes using Excel VBA

问题描述

我想在Excel单元格中使用宏生成2D条形码（PDF417或QR码）。只是想知道付费图书馆是否有免费的替代方法？

我知道某些工具可以做这项工作，但对我们来说比较贵。

解决方案

VBA模块 barcode-vba-macro-only

代码不完全简单易懂，但很多意见已经从捷克语翻译成英文版本，链接到上面。

要在工作表中使用它，只需复制或导入 barcody.bas 插入到一个模块中的VBA中。在工作表中，输入如下功能：

  = EncodeBarcode（CELL（SHEET），CELL（ADDRESS ），A2,51,1,0,2）
  

使用方法如下：

1. 保留 CELL（SHEET）和 CELL（ADDRESS ）因为它是
   只是引用工作表和单元格地址，你有
   公式
   
   
   
   
   • A2是您的字符串要编码的单元格，在我的情况下，它是单元格A2您可以使用引号将Text传递给相同的
     使单元格使其更加动态
   
   
   • 51是QR码的选项，其他选项为1 = EAN8 / 13 / UPCA / UPCE，2 =五个交错中的两个，3 = Code39,50 =数据
     矩阵，51 = QRCode
     
     
     
     
     • 1用于图形模式，条形码绘制在Shape对象上，字体模式为0，假设您需要安装字体类型。
       没有用。
     
     
     • 0是特定条形码类型的参数。对于QR_Code，0 =低误差校正，1 =中等误差校正，2 =四分位错误
       校正，3 =高纠错。
     
     
     • 2仅适用于1D代码。这是缓冲区。我不确定它是做什么，但可能与
       1D条形空间有关？
     
     
   
   

我添加了包装函数，使其成为纯VBA函数调用，而不是将其用作工作表中的公式：

  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 ）
调用DrawQRCode（s_encoded，workSheetName，cellLocation）
 
设置xSheet =工作表（workSheetName）
 QRShapeName =BC& $&左（cellLocation，1）_ 
& $& Right（cellLocation，Len（cellLocation） -  1）& #GR
 
 QRLabelName = QRShapeName& _Label
 
带有xSheet.Shapes（QRShapeName）
 .Width = 30 
 .Height = 30 
结束
 
打开错误Resume Next 
如果没有（xSheet.Shapes（QRLabelName）不是）然后
 xSheet.Shapes（QRLabelName）.Delete 
如果
 
 xSheet.Shapes.AddTextbox （msoTextOrientationHorizo​​ntal，_ 
 xSheet.Shapes（QRShapeName）.Left + 35，_ 
 xSheet.Shapes（QRShapeName）.Top，_ 
 Len（textValue）* 6，30）_ 
 .Name = QRLabelName 
 
 
带有xSheet.Shapes（QRLabelName）
 .Line.Visible = msoFalse 
 .TextFrame2.TextRange.Font.Name =Arial 
 .TextFrame2.TextRange.Font.Size = 9 
 .TextFrame.Characters.Text = textValue 
 .TextFrame2.VerticalAnchor = msoAnchorMiddle 
结束
 End Sub 
 
 Sub DrawQRCode（xBC As String，workSheetName As String，rangeName As String，可选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％
 
设置xSheet =工作表（workSheetName）
设置xRange =工作表（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）
对于n = 1 To b 
w = AscL（Mid（p，n，1））Mod 256 
 If（w> = 97 And w < = 112）然后
a = a + dm 
 ElseIf w = 10或n = b然后
如果x < a然后x = a 
y = y + dm 
a = 0＃
结束如果
下一个n 
如果x <= 0＃然后退出Sub 
 On Error Resume Next 
设置xShape = xSheet.Shapes 
错误GoTo 0 
如果没有（xShape不是）然后
 xPosOldX = xShape.Left 
 xPosOldY = xShape.Top 
 xSizeOldW = xShape.Width 
 xSizeOldH = xShape.Height 
 xShape.Delete 
如果
结束如果错误恢复Next 
 xSheet。形状（BC& xAddr&#BK）。删除
错误GoTo 0 
设置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
设置xShape = Nothing 
x = 0＃
y = 0＃
g = 0 
对于n = 1到b 
w = AscL （p，n，1））Mod 256 
如果w = 10然后
y = y + dm 
x = 0＃
 ElseIf（w> = 97 And w < 112）然后
w = w  -  97 
使用xSheet.Shapes 
选择案例w 
案例1：设置xShape = .AddShape（msoShapeRectangle，x，y，m，m）： GoSub fmtxshape 
情况2：设置xShape = .AddShape（msoShapeRectangle，x + m，y，m，m）：GoSub fmtxshape 
情况3：设置xShape = .AddShape（msoShapeRectangle，x，y，dm ，m）：GoSub fmtxshape 
案例4：设置xShape = .AddShape（msoShapeRectangle，x，y + m，m，m）：GoSub fmtxshape 
案例5：设置xShape = .AddShape（msoShapeRectangle，x ，y，m，dm）：GoSub fmtxshape 
案例6：设置xShape = .AddShape（msoShapeRectangle，x + m，y，m，m）：GoSub fmtxshape 
设置xShape = .AddShape（msoShapeRectangle， x，y + m，m，m）：GoSub fmtxshape 
案例7：设置xShape = .AddShape（msoShapeRectangle，x，y，dm，m）：GoSub fmtxshape 
设置xShape = .AddShape（msoShapeRectangle，x，y + m，m，m）：GoSub fmtxshape 
案例8：设置xShape = .AddShape（msoShapeRectangle，x + m，y + m，m，m）：GoSub fmtxshape 
案例9：设置xShape = .AddShape（msoShapeRectangle，x，y，m，m）：GoSub fmtxshape 
设置xShape = .AddShape（msoShapeRectangle，x + m，y + m，m，m）：GoSub fmtxshape 
案例10：设置xShape = .AddShape（msoShapeRectangle，x + m，y，m，dm） ：GoSub fmtxshape 
案例11：设置xShape = .AddShape（msoShapeRectangle，x，y，dm，m）：GoSub fmtxshape 
设置xShape = .AddShape（msoShapeRectangle，x + m，y + m，m ，m）：GoSub fmtxshape 
案例12：设置xShape = .AddShape（msoShapeRectangle，x，y + m，dm，m）：GoSub fmtxshape 
案例13：设置xShape = .AddShape（msoShapeRectangle，x ，y，m，m）：GoSub fmtxshape 
设置xShape = .AddShape（msoShapeRectangle，x，y + m，dm ，m）：GoSub fmtxshape 
案例14：设置xShape = .AddShape（msoShapeRectangle，x + m，y，m，m）：GoSub fmtxshape 
设置xShape = .AddShape（msoShapeRectangle，x，y + m，dm，m）：GoSub fmtxshape 
案例15：设置xShape = .AddShape（msoShapeRectangle，x，y，dm，dm）：GoSub fmtxshape 
结束选择
结束
x = x + dm 
结束如果
下一步n 
错误恢复下一步
设置xShape = xSheet.Shapes $ s 
错误GoTo 0 
如果没有（xShape不是）然后
 xShape.Left = xPosOldX 
 xShape.Top = xPosOldY 
如果xSizeOldW> 0然后
 xShape.Width = xSizeOldW 
 xShape.Height = xSizeOldH 
结束如果
 Else 
如果不是（xBkgr不是）然后xBkgr.Delete 
如果
退出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 
如果g = 1然后
 xSheet.Shapes.Range（Array（xBkgr.Name，xShape.Name））。Group.Name = s 
 Else 
 xSheet.Shapes。 Range（Array（s，xShape.Name））Group.Name = s 
如果
返回
 
 End Sub 
  / pre> 
 
 
使用这个包装器，现在可以通过在VBA中调用此方法来简单地调用渲染QRCode：
  Call RenderQRCode（Sheet1，A13，QR Value）
  
只需输入工作表名称，单元格位置和QR_value。 QR形状将在您指定的位置绘制。
 
 
 
您可以使用本节代码来更改QR的大小。
 使用xSheet.Shapes（QRShapeName）
 .Width = 30'更改大小
 .Height = 30'更改大小
结束
  
 
I would like to generate a 2d barcode (PDF417 or QR codes) in an Excel cell using macros. Just wondering is there any free alternatives to paid libraries to do this?

I know certain tools can do the job but it is relatively expensive to us.
解决方案
The VBA module barcode-vba-macro-only (mentioned by Sébastien Ferry in the comments) is a pure VBA 1D/2D code generator created by Jiri Gabriel under MIT License in 2013.

The code isn't completely simple to understand, but many comments have been translated from Czech to English in the version linked above.

To use it in a worksheet, just copy or import barcody.bas into your VBA in a module. In a worksheet, put in the function like this:
=EncodeBarcode(CELL("SHEET"),CELL("ADDRESS"),A2,51,1,0,2)
The usage is as follows:

Leave the CELL("SHEET) and CELL("ADDRESS") as they are since it's
just giving reference to the worksheet and cell address you have the
formula


A2 is the cell that you have your string to be encoded. In my case it's cell A2  You can pass "Text" with quotes to do the same. 
Having the cell makes it more dynamic
51 is the option for QR Code. Other options are 1=EAN8/13/UPCA/UPCE, 2=two of five interleaved, 3=Code39, 50=Data
Matrix, 51=QRCode


1 is for graphical mode.  The barcode is drawn on a Shape object.  0 for font mode.  I assume you need to have the font type installed.
Not as useful.
0 is the parameter for the particular barcode type.  For QR_Code, 0=Low Error Correction, 1=Medium Error Correction, 2=Quartile error
correction, 3=high error correction.
2 only applies to 1D codes.  It's the buffer zones. I'm not certain what it does exactly but probably something to do with the
1D bar spaces?


I added wrapper functions to make it a pure VBA function call rather than using it as a formula in a worksheet:
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
With this wrapper, you can now simply call to render QRCode by calling this in VBA:
Call RenderQRCode("Sheet1", "A13", "QR Value")
Just input the worksheet name, cell location, and the QR_value. The QR shape will get drawn at the location you specified.

You can play around with this section of the code to change the size of the QR
With xSheet.Shapes(QRShapeName)
       .Width = 30  'change your size
       .Height = 30  'change your size
   End With


                        
这篇关于使用Excel VBA生成2D（PDF417或QR）条形码的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！