Excel VBAを使用した2D（PDF417またはQR）バーコードの生成

Question

マクロを使用してExcelセルに2Dバーコード（PDF417またはQRコード）を生成したいと思います。これを行うために有料ライブラリに代わる無料の代替品はあるのでしょうか。

私は知っています 特定のツール は仕事をすることができますが、それは私たちにとって比較的高価です。

Answer 1

VBAモジュール barcode-vba-macro-only （セバスチャンフェリーのコメントで言及）は、Jiri GabrielがMITの下で作成した純粋なVBA 1D/2Dコードジェネレーターです2013年のライセンス。

コードは完全に理解するのは簡単ではありませんが、多くのコメントは上記のリンクされたバージョンでチェコ語から英語に翻訳されています。

これをワークシートで使用するには、モジュールのVBAに barcody.bas をコピーまたはインポートするだけです。ワークシートに、次のような関数を入れます。

_=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 = 5つのインターリーブのうちの2つ、3 = Code39、50 = Data Matrix、51 = QRCode です。
     • 1はグラフィカルモード用です。バーコードはShapeオブジェクト上に描画されます。フォントモードの場合は0。フォントタイプをインストールする必要があると思います。それほど役に立たない。
     • 0は特定のバーコードタイプのパラメーターです。 QR_Codeの場合、0 =低エラー修正、1 =中エラー修正、2 =四分位エラー修正、3 =高エラー修正。
     • 2は1Dコードにのみ適用されます。それは緩衝地帯です。私はそれが正確に何をしているのかわかりませんが、おそらく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")
_

ワークシート名、セルの場所、QR_valueを入力するだけです。指定した場所にQRシェイプが描画されます。

コードのこのセクションをいじってQRのサイズを変更できます

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

Answer 2

私はこれがかなり古く確立された投稿であることを知っています（ただし、非常に優れた既存の回答はまだ受け入れられていません）。 で同様の投稿のために準備した代替案を共有したいと思います。 /ポルトガル語での/ StackOverflow QRコードジェネレーターからの無料の online APIの使用 。

コードは次のとおりです。

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 からダウンロードできます）：