使用 Excel VBA 生成二维（PDF417 或 QR）条码
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/16143331/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Generating 2D (PDF417 or QR) barcodes using Excel VBA
提问by user2306468
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?
我想使用宏在 Excel 单元格中生成二维条码（PDF417 或 QR 码）。只是想知道有没有付费图书馆的免费替代品来做到这一点？
I know certain toolscan do the job but it is relatively expensive to us.
我知道某些工具可以完成这项工作，但对我们来说相对昂贵。
回答by Patratacus
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.
VBA 模块barcode-vba-macro-only（由Sébastien Ferry 在评论中提到）是由Jiri Gabriel 在2013 年根据MIT 许可证创建的纯VBA 一维/二维代码生成器。
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.basinto your VBA in a module. In a worksheet, put in the function like this:
要在工作表中使用它，只需将barcody.bas复制或导入模块中的 VBA。在工作表中，像这样输入函数：
=EncodeBarcode(CELL("SHEET"),CELL("ADDRESS"),A2,51,1,0,2)
The usage is as follows:
用法如下：
- Leave the
CELL("SHEET)andCELL("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?
- 保留
CELL("SHEET)和CELL("ADDRESS")原样，因为它只是参考您拥有公式的工作表和单元格地址- A2 是您要编码字符串的单元格。在我的情况下，它是单元格 A2 您可以通过带引号的“文本”来执行相同的操作。拥有细胞使其更具活力
- 51 是二维码的选项。其他选项是 1=EAN8/13/UPCA/UPCE，2=五个交错中的两个，3=Code39，50=Data Matrix，51=QRCode
- 1 用于图形模式。条码绘制在 Shape 对象上。0 表示字体模式。我假设您需要安装字体类型。没那么好用。
- 0 是特定条码类型的参数。对于QR_Code，0=低纠错，1=中等纠错，2=四分位纠错，3=高纠错。
- 2 仅适用于一维代码。这是缓冲区。我不确定它到底做了什么，但可能与一维条形空间有关？
I added wrapper functions to make it a pure VBA function call rather than using it as a formula in a worksheet:
我添加了包装函数以使其成为纯 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
With this wrapper, you can now simply call to render QRCode by calling this in VBA:
使用此包装器，您现在可以通过在 VBA 中调用它来简单地调用以呈现 QRCode：
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.
只需输入工作表名称、单元格位置和 QR_value。QR 形状将在您指定的位置绘制。
You can play around with this section of the code to change the size of the QR
您可以使用此部分代码来更改 QR 的大小
With xSheet.Shapes(QRShapeName)
.Width = 30 'change your size
.Height = 30 'change your size
End With
回答by Luiz Vieira
I know this is quite an old and well-established post (though the very good existing answer has not been accepted yet), but I would like to share an alternative that I prepared for a similar post in StackOverflow in Portugueseusing the free online API from QR Code Generator.
我知道这是一个相当古老且完善的帖子（尽管尚未接受非常好的现有答案），但我想分享一个替代方案，我使用免费的在线 API在葡萄牙语的 StackOverflow 中为类似的帖子准备来自二维码生成器。
The code is the following:
代码如下：
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
It gets the job done by simply (re)creating an image from the URL built from the parameters in the cells. Naturally, the user must be connected to the Internet.
它通过简单地（重新）从根据单元格中的参数构建的 URL 创建图像来完成工作。当然，用户必须连接到 Internet。
For example (the worksheet, with contents in Brazilian Portuguese, can be downloaded from 4Shared):
例如（包含巴西葡萄牙语内容的工作表可从 4Shared下载）：
