使用Excel VBA生成2D(PDF417或QR)条形码

时间:2013-04-22 09:12:02

标签: excel vba fonts barcode

我想使用宏在Excel单元格中生成二维条码(PDF417或QR码)。只是想知道有没有免费的付费图书馆替代方案呢?

我知道certain tools可以完成这项任务,但对我们来说相对昂贵。

2 个答案:

答案 0 :(得分:13)

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

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

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

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

用法如下:

  1. 保留CELL("SHEET)CELL("ADDRESS")原样,因为它是 只需参考您拥有的工作表和单元格地址 式
    • A2是您要编码的字符串的单元格。在我的情况下,它是单元格A2你可以传递带有引号的“文本”来做同样的事情。 拥有单元格使其更具动态性
    • 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酒吧空间?
  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
    

答案 1 :(得分:8)

我知道这是一个相当陈旧且完善的帖子(虽然现有的答案尚未被接受),但我想分享我为StackOverflow in Portuguese中的类似帖子准备的替代方案。使用免费的online API from QR Code Generator

代码如下:

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创建图像来完成工作。当然,用户必须连接到Internet。

例如(工作表,包含巴西葡萄牙语的内容,可以下载from 4Shared):

enter image description here