Generazione di codici a barre 2D (PDF417 o QR) mediante Excel VBA

Question

Vorrei creare un codice a barre 2d (codici PDF417 o QR) in una cella di Excel utilizzando le macro. Mi chiedo solo se esistono alternative gratuite alle biblioteche pagate per fare questo?

Lo so certain tools può fare il lavoro ma è relativamente costoso per noi.

Answer 1

La VBA modulo barcode-vba-macro-only (citato da Sébastien Ferry nei commenti) è un/2D generatore di codice puro VBA 1D creato da Jiri Gabriel sotto licenza MIT nel 2013.

Il codice non è del tutto semplice da capire, ma molti commenti sono stati tradotti dal ceco in inglese nella versione collegata sopra.

Per utilizzarlo in un foglio di lavoro, è sufficiente copiare o importare barcody.bas nel VBA in un modulo. In un foglio di lavoro, messo in funzione come questa:

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

L'uso è il seguente:

1. Lasciare la CELL("SHEET) e CELL("ADDRESS") come sono dal momento che è solo dando riferimento all'indirizzo foglio di lavoro e delle cellule si ha la formula
   • A2 è la cella in cui si ha la stringa da codificare. Nel mio caso è la cella A2 Puoi passare "Testo" con le virgolette per fare lo stesso. Avere la cella lo rende più dinamico
   • 51 è l'opzione per il codice QR. Altre opzioni sono 1 = EAN8/13/UPCA/UPCE, 2 = due dei cinque Interleaved, 3 = Code39, 50 = Dati Matrix, 51 = QRCode
     • 1 è per la modalità grafica. Il codice a barre viene disegnato su un oggetto Shape. 0 per la modalità font. Presumo che è necessario avere il tipo di carattere installato. Non altrettanto utile.
     • 0 è il parametro per il particolare tipo di codice a barre. Per QR_Code, 0 = correzione errore bassa, 1 = correzione errore medio, 2 = correzione quadratica errore , 3 = correzione errori elevata.
     • 2 si applica solo ai codici 1D. Sono le zone tampone. Non sono sicuro di cosa faccia esattamente, ma probabilmente ha qualcosa a che fare con gli spazi barra 1D?

ho aggiunto funzioni wrapper per renderlo un puro chiamata di funzione VBA invece di usarlo come una formula in un foglio di lavoro:

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 

Con questo involucro, è ora possibile semplicemente chiama per rendere QRCode chiamando questo in VBA:

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

Basta inserire il nome del foglio di lavoro, cella posizione e il valore QR_. La forma QR verrà disegnata nella posizione specificata.

È possibile giocare con questa sezione del codice per modificare le dimensioni del QR

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

Answer 2

So che questo è piuttosto un vecchio e ben consolidata-post (anche se la risposta molto buona esistente non è stata accettato ancora), ma mi piacerebbe condividere un'alternativa che ho preparato per un post simile in StackOverflow in Portuguese utilizzando il gratuito online API from QR Code Generator.

Il codice è il seguente:

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 

ottiene il lavoro fatto semplicemente (ri) creazione di un'immagine dal URL costruita dai parametri nelle cellule. Naturalmente, l'utente deve essere connesso a Internet.

Per esempio (il foglio di lavoro, con contenuti in portoghese brasiliano, possono essere scaricati from 4Shared):