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

Question

マクロを使用してExcelセルに2dバーコード（PDF417またはQRコード）を生成したいとします。これを行うには有料ライブラリの無料の代替手段はありますか？

私はcertain toolsが仕事をすることができますが、私たちにとっては比較的高価です。

Answer 1

VBAモジュールbarcode-vba-macro-only（コメントでセバスチャンフェリー言及）コードを理解し、完全に単純ではない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コードのオプションです。他のオプションは= QRコード
     • 1は、グラフィカルモードのためのものである1 = EAN8/13/UPCA/UPCE、2 =インターリーブ5、3 = Code39の二、50 =データ マトリックス、51です。バーコードは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 

このラッパーを使用すると、することができます今、単に

Call RenderQRCode("Sheet1", "A13", "QR Value") 

ワークシート名cellを入力するだけで、QRコードをレンダリングすることができます。ロケーション、およびQR_valueが含まれます。 QR形状は、指定した場所に描画されます。

あなたは、私は、これは非常に良い、既存の答えがされていないもののかなり古いとよく確立されたポスト（知っているQR

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

Answer 2

のサイズを変更するには、コードのこのセクションで遊ぶことができますまだ受け入れられていませんが、私は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から画像を生成（再）単にによって仕事を得ます。もちろん、ユーザーはインターネットに接続する必要があります。例えば

（ワークシートは、ポルトガル語（ブラジル）での内容で、from 4Sharedをダウンロードすることができます）：