QR-Code aus Internet in Word-Dokument einsetzen

Option Explicit

Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" _  
    Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, _  
    ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long

Sub QR_Code_01_goqr_me()
On Error GoTo Errorhandler

Dim bolError As Boolean
bolError = False

Dim TMRange As Range

    With ActiveDocument
        Set TMRange = .Bookmarks("Textmarke01").Range  
        URL_QRCode_SERIES_goqr_me "P-12345-DE-1", TMRange  
        If Fkt_GetAndSet_QR_Codes("P-12345-DE-1", TMRange) = False Then  
           bolError = True
        End If
    End With
    
    ActiveDocument.Saved = True
        
    Dim result As VbMsgBoxResult
    If bolError = True Then
        result = MsgBox("Beim Abrufen und/oder EInfügen eines QR-Codes trat ein Fehler auf." & vbCrLf & _  
        "Das Dokument wird geschlossen", vbOKOnly, "Fehler --> Abbruch")  
        GoTo Errorhandler
    End If

    Exit Sub

Errorhandler:

    ActiveDocument.Saved = True
    Application.Quit SaveChanges:=wdDoNotSaveChanges

End Sub

Function Fkt_GetAndSet_QR_Codes(ByVal strTextmarke As String, ByVal strQRInhalt As String) As Boolean
    
    Fkt_GetAndSet_QR_Codes = True
    
    Dim TMRange As Range
    
    On Error GoTo ErrHandling
    
    With ActiveDocument
        If .Bookmarks.Exists(strTextmarke) Then
            Set TMRange = .Bookmarks(strTextmarke).Range
                         
            'yy_URL_QRCode_SERIES strQRInhalt, TMRange  
            If URL_QRCode_SERIES_goqr_me(strQRInhalt, TMRange) = False Then
                GoTo ErrHandling
            End If
                 
            .Bookmarks.Add strTextmarke, TMRange
            Fkt_GetAndSet_QR_Codes = True
        End If
    End With

Exit Function

ErrHandling:
    Fkt_GetAndSet_QR_Codes = False

End Function


Function URL_QRCode_SERIES_goqr_me( _
         ByVal QR_Value As String, _
         oRng As Range, _
         Optional ByVal PictureSize As Long = 150, _
         Optional ByVal Updateable As Boolean = True) As Boolean


URL_QRCode_SERIES_goqr_me = False
On Error GoTo lbl_Exit


Dim oPic As InlineShape
Dim vLeft As Variant, vTop As Variant
Dim sURL As String

    'https://api.qrserver.com/v1/create-qr-code/?size=150x150&data=Example  
Const sRootURL As String = "http://api.qrserver.com/v1/create-qr-code/?"  
Const sSizeParameter As String = "size="  
Const sDataParameter As String = "data="  
Const sMarginParameter As String = "margin=20"  
Const sFormatParameter1 As String = "format="  
Const sFormatParameter2 As String = "gif"  
Const sJoinCHR As String = "&"  

    If Updateable = False Then
        URL_QRCode_SERIES_goqr_me = "outdated"  
        GoTo lbl_Exit
    End If

    If Len(QR_Value) = 0 Then
        GoTo lbl_Exit
    End If
    
    sURL = sRootURL & _
            sSizeParameter & PictureSize & "x" & PictureSize & _  
            sJoinCHR & _
            sMarginParameter & _
            sJoinCHR & _
            sFormatParameter1 & sFormatParameter2 & _
            sJoinCHR & _
            sDataParameter & UTF8_URL_Encode(VBA.Replace(QR_Value, " ", "+"))  
          
    'MsgBox (sURL)  
    
        
    Dim pfad_T1 As String
    pfad_T1 = "C:\temp\QR\"  
    Dim pfad_T2 As String
    pfad_T2 = QR_Value & "." & sFormatParameter2  
    Dim pfad As String
    pfad = pfad_T1 & pfad_T2
    
    If Dir(pfad_T1, vbDirectory) = "" Then  
        'directory doesn't exist  
        MkDir Path:=pfad_T1
    Else
        'directory does exist  
    End If

    
    If GURoL(sURL, pfad) = True Then
        Set oPic = ActiveDocument.InlineShapes.AddPicture(pfad, False, True, oRng)
        URL_QRCode_SERIES_goqr_me = True
    Else
        'MsgBox ("MIST...!")  
        URL_QRCode_SERIES_goqr_me = False
    End If

    Exit Function

lbl_Exit:
    URL_QRCode_SERIES_goqr_me = False
    Exit Function
End Function


Public Function GURoL(url As String, FileName As String) As Boolean
    GURoL = False
    Dim lngRetVal As Long
    lngRetVal = URLDownloadToFile(0, url, FileName, 0, 0)
    If lngRetVal <> 0 Then
        'MsgBox "GURol godo: Can't download from " & url & " to " & FileName  
        GURoL = False
    Else
        GURoL = True
    End If
End Function

Function UTF8_URL_Encode(ByVal sStr As String)
'http://www.nonhostile.com/howto-convert-byte-array-utf8-string-vb6.asp (link no longer valid)  
Dim i As Long
Dim a As Long
Dim res As String
Dim code As String

    res = ""  
    For i = 1 To Len(sStr)
        a = AscW(Mid(sStr, i, 1))
        If a < 128 Then
            code = Mid(sStr, i, 1)
        ElseIf ((a > 127) And (a < 2048)) Then
            code = URLEncodeByte(((a \ 64) Or 192))
            code = code & URLEncodeByte(((a And 63) Or 128))
        Else
            code = URLEncodeByte(((a \ 144) Or 234))
            code = code & URLEncodeByte((((a \ 64) And 63) Or 128))
            code = code & URLEncodeByte(((a And 63) Or 128))
        End If
        res = res & code
    Next i
    UTF8_URL_Encode = res
lbl_Exit:
Exit Function
End Function

Private Function URLEncodeByte(val As Integer) As String
Dim res As String
    res = "%" & Right("0" & Hex(val), 2)  
    URLEncodeByte = res
lbl_Exit:
    Exit Function
End Function