excel - 使用 Excel VBA 生成二维（PDF417 或 QR）条码

Question

我想使用宏在 Excel 单元格中生成二维条码（PDF417 或 QR 码）。只是想知道是否有任何免费的替代付费图书馆可以做到这一点？

我知道某些工具可以完成这项工作，但对我们来说相对昂贵。

score 20 · Accepted Answer

VBA 模块barcode-vba-macro-only（Sébastien Ferry 在评论中提到）是 Jiri Gabriel 在 2013 年在 MIT 许可下创建的纯 VBA 1D/2D 代码生成器。

该代码并不完全易于理解，但在上面链接的版本中，许多评论已从捷克语翻译成英语。

要在工作表中使用它，只需将barcody.bas复制或导入到模块中的 VBA 中。在工作表中，输入如下函数：

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

用法如下：

保留CELL("SHEET)和CELL("ADDRESS")原样，因为它只是参考工作表和单元格地址，您有公式
- A2 是您要对字符串进行编码的单元格。在我的情况下，它是单元格 A2 你可以传递带有引号的“文本”来做同样的事情。拥有细胞使其更具活力
- 51 是 QR 码的选项。其他选项为 1=EAN8/13/UPCA/UPCE、2=五个交错的两个、3=Code39、50=Data Matrix、51=QRCode
  - 1 用于图形模式。条形码绘制在 Shape 对象上。0 表示字体模式。我假设您需要安装字体类型。没那么有用。
  - 0 是特定条形码类型的参数。对于 QR_Code，0=低纠错，1=中纠错，2=四分位纠错，3=高纠错。
  - 2 仅适用于一维代码。是缓冲区。我不确定它到底做了什么，但可能与一维条形空间有关？

我添加了包装函数以使其成为纯 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)
   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：

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

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

您可以使用这部分代码来更改 QR 的大小

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

score 11 · Accepted Answer

我知道这是一个相当古老且成熟的帖子（尽管尚未接受非常好的现有答案），但我想分享一个替代方案，我使用免费的在线 API 为葡萄牙语的 StackOverflow 中的类似帖子做准备来自二维码生成器。

代码如下：

Sub GenQRCode(ByVal data As String, ByVal color As String, ByVal bgcolor As String, ByVal size As Integer)
On Error Resume Next

    For i = 1 To ActiveSheet.Pictures.Count
        If ActiveSheet.Pictures(i).Name = "QRCode" Then
            ActiveSheet.Pictures(i).Delete
            Exit For
        End If
    Next i

    sURL = "https://api.qrserver.com/v1/create-qr-code/?" + "size=" + Trim(Str(size)) + "x" + Trim(Str(size)) + "&color=" + color + "&bgcolor=" + bgcolor + "&data=" + data
    Debug.Print sURL

    Set pic = ActiveSheet.Pictures.Insert(sURL + sParameters)
    Set cell = Range("D9")

    With pic
        .Name = "QRCode"
        .Left = cell.Left
        .Top = cell.Top
    End With

End Sub

它通过简单地（重新）从根据单元格中的参数构建的 URL 创建图像来完成工作。自然，用户必须连接到互联网。

例如（可以从 4Shared下载包含巴西葡萄牙语内容的工作表）：

excel - 使用 Excel VBA 生成二维（PDF417 或 QR）条码

2 回答 2

Related

Reference