excel - Excel VBA を使用して 2D (PDF417 または QR) バーコードを生成する

Question

マクロを使用して Excel セルに 2 次元バーコード (PDF417 または QR コード) を生成したいと考えています。これを行うための有料ライブラリに代わる無料の代替手段はありますか?

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

score 20 · Accepted Answer

VBAモジュールbarcode-vba-macro-only（コメントでSébastien Ferryが言及）は、2013年にMITライセンスの下でJiri Gabrielによって作成された純粋なVBA 1D / 2Dコードジェネレーターです.

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

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

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

使用方法は次のとおりです。

式を持っているワークシートとセルアドレスを参照しているだけなので、 CELL("SHEET)andはそのままにしておきます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

excel - Excel VBA を使用して 2D (PDF417 または QR) バーコードを生成する

2 に答える 2

Related

Reference