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

问题描述

我想使用宏在 Excel 单元格中生成二维条码(PDF417 或 QR 码).只是想知道有没有免费的替代付费图书馆来做到这一点?

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.

推荐答案

VBA 模块 barcode-vba-macro-only(由 Sébastien Ferry 在评论中提到)是由 Jiri Gabriel 在 2013 年根据 MIT 许可创建的纯 VBA 1D/2D 代码生成器.

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.

要在工作表中使用它，只需复制或导入 barcody.bas 到您的 VBA 模块中.在工作表中，像这样输入函数:

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)

用法如下:

1. 将 CELL("SHEET) 和 CELL("ADDRESS") 保持原样，因为它是只需参考您拥有的工作表和单元格地址公式
   • A2 是您要编码字符串的单元格.在我的情况下，它是单元格 A2 您可以通过带引号的文本"来执行相同的操作.拥有细胞让它更有活力
   • 51 是二维码的选项.其他选项是 1=EAN8/13/UPCA/UPCE，2=五个交错中的两个，3=Code39，50=Data矩阵，51=二维码
     • 1 用于图形模式.条码绘制在 Shape 对象上.0 表示字体模式.我假设您需要安装字体类型.没那么有用.
     • 0 是特定条码类型的参数.对于 QR_Code，0=低误差校正，1=中等误差校正，2=四分位误差更正，3=高纠错.
     • 2 仅适用于一维代码.这是缓冲区.我不确定它究竟做了什么，但可能与一维条形空间?

1. 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?

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

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

使用此包装器，您现在可以通过在 VBA 中调用它来简单地调用以呈现 QRCode:

With this wrapper, you can now simply call to render QRCode by calling this in VBA:

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

只需输入工作表名称、单元格位置和 QR_value.QR 形状将在您指定的位置绘制.

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 生成二维(PDF417 或 QR)条码的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！