26.05 Visual Basic Macro

Adds a QR code to the bottom of every table, with the contents of the rest of the table in json. 24.00 Microsoft word scripting.

It’s not perfect, the encoding to url has some errors. But that is about it.

Sub FileSave()
    ' Save the document
    ActiveDocument.Save
    ' Access the table and retrieve data
    Dim tblCount As Integer
    tblCount = ActiveDocument.Tables.Count
    Debug.Print tblCount
    ' Assuming the table is the first one in the document
 
    Dim i As Integer
    For i = 2 To tblCount
        Dim tbl As Table
        Set tbl = ActiveDocument.Tables(i)
        tblColumns = tbl.Columns.Count
        tblRows = tbl.Rows.Count
 
        ' MsgBox "Table "& i &" has " & tblColumns & " columns and " & tblRows & " rows."
        Dim json As String
        json = "{"
        Dim j As Integer
    
        For j = 1 To tblRows - 1
 
            Dim Data As String
            Data = tbl.Cell(j, 1).Range.Text
            If j < tblRows - 1 Then
                json = json & """Data" & j & """: """ & Data & """, "
            End If
            If j = tblRows - 1 Then
                json = json & """Data" & j & """: """ & Data & """"
            End If
 
        Next j
 
        json = json & "}"
        Debug.Print json
        ' Generate QR code
        Dim qrCodePath As String
        qrCodePath = GenerateQRCodeImage(json)
        Debug.Print qrCodePath
        
        ' Insert QR code image into the document
        Dim qrCodeShape As InlineShape
        On Error Resume Next
        Set qrCodeShape = ActiveDocument.InlineShapes.AddPicture(qrCodePath)
        On Error GoTo 0
        
        ' Check if qrCodeShape is successfully created
        If qrCodeShape Is Nothing Then
            MsgBox "Failed to create QR code shape"
            Exit Sub
        End If
        
        ' Ensure qrCodeShape is not deleted
        If qrCodeShape.Type <> wdInlineShapePicture Then
            MsgBox "QR code shape is not valid"
            Exit Sub
        End If
        
        ' You can position the QR code shape as needed
        ' For example, set its position relative to a specific range or selection
        qrCodeShape.Width = 100
        qrCodeShape.Height = 100
        qrCodeShape.Range.Cut
        tbl.Cell(tblRows, 1).Range.Paste
 
    Next i
 
    ' Save the document
    ActiveDocument.Save
End Sub
 
Function GenerateQRCodeImage(Data As String) As String
    ' Encode data for the URL
    Dim encodedData As String
    encodedData = URLEncode(Data)
    ' encodeData = data
    
    ' Construct the URL for Google Charts API
    Dim url As String
    url = "https://qrcode.tec-it.com/API/QRCode?data=" & encodedData
    
    ' Download the image and save it to a temporary file
    Dim httpRequest As Object
    Set httpRequest = CreateObject("MSXML2.XMLHTTP")
    httpRequest.Open "GET", url, False
    httpRequest.send
    
    Dim tempFilePath As String
    tempFilePath = Environ$("temp") & "\qrcode.png"
    
    Dim oStream As Object
    Set oStream = CreateObject("ADODB.Stream")
    oStream.Open
    oStream.Type = 1 ' Binary
    oStream.Write httpRequest.responseBody
    oStream.SaveToFile tempFilePath, 2 ' Overwrite existing file
    oStream.Close
    
    ' Return the path to the temporary image file
    GenerateQRCodeImage = tempFilePath
End Function
 
Function URLEncode(StringVal As String) As String
    Dim i As Integer
    Dim CharCode As Integer
    Dim Char As String
    
    URLEncode = ""
    
    For i = 1 To Len(StringVal)
        Char = Mid$(StringVal, i, 1)
        CharCode = Asc(Char)
        Select Case CharCode
            Case 48 To 57, 65 To 90, 97 To 122
                URLEncode = URLEncode & Char
            Case 32
                URLEncode = URLEncode & "+"
            Case Else
                URLEncode = URLEncode & "%" & Hex(CharCode)
        End Select
    Next i
End Function