使用Excel VBA生成二维（PDF417或QR）条形码
我想使用macros在Excel单元格中生成2d条形码（PDF417或QR码）。 只是想知道有没有免费的替代品付费图书馆做到这一点？
我知道某些工具可以完成这项工作，但对我们来说相对昂贵。
VBA模块barcode-vba-macro-only （由SébastienFerry在评论中提到）是由Jiri Gabriel根据MIT许可在2013年创build的纯VBA 1D / 2D代码生成器。
代码不是完全简单易懂的，但许多评论已经从上面链接的版本从捷克语翻译成英语。
要在工作表中使用它，只需将barcody.bas复制或导入模块中的VBA。 在工作表中，像这样放入函数：
=EncodeBarcode(CELL("SHEET"),CELL("ADDRESS"),A2,51,1,0,2) 用法如下：
- 离开
CELL("SHEET)和CELL("ADDRESS")，因为它只是提供工作表和单元格地址，- A2是你有你的string进行编码的单元格。 在我的情况下，它是单元格A2您可以通过“文本”引号做同样的事情。 让细胞变得更加dynamic
- QR代码为51。 其他选项有1 = EAN8 / 13 / UPCA / UPCE，2 =五个交错中的两个，3 = Code39,50 = Data Matrix，51 = QRCode
- 1是用于graphics模式。 条形码绘制在Shape对象上。 0为字体模式。 我假设你需要安装字体types。 没有那么有用。
- 0是特定条形码types的参数。 对于QR_Code，0 =低误差校正，1 =中等误差校正，2 =四分位误差校正，3 =高误差校正。
- 2仅适用于一维码。 这是缓冲区。 我不确定它究竟做了什么，但可能与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) 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")
只需input工作表名称，单元格位置和QR_value。 QR形状将在您指定的位置绘制。
你可以使用这段代码来改变QR的大小
With xSheet.Shapes(QRShapeName) .Width = 30 'change your size .Height = 30 'change your size End With
我知道这是一个相当古老和完善的职位（虽然很好的现有答案尚未被接受），但我想分享一个替代scheme，我准备在葡萄牙的StackOverflow中使用免费的在线API来自QR码发生器 。
代码如下：
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
它通过简单地（重新）从单元中的参数构build的URL创build图像来完成工作。 当然，用户必须连接到互联网。
例如（工作表，包含巴西葡萄牙语的内容，可以从4Shared下载）：
