Hallo miteinander,

ich habe hier: http://www.vbaexpress.com/forum/showthread.php?56645-QR-Code-in-Word-2010&s=a94c6e8875e3103443475a41cd9cab4f&p=346548&viewfull=1#post346548 einen funktionierenden VBA-Code gefunden, mit dem man QR-Codes in Word-Dokumenten einsetzen kann. Als Quelle des Codes wird https://chart.apis.google.com/ verwendet, das aber wohl "veraltet" ist (https://developers.google.com/chart/infographics/docs/qr_codes).

Da ich befürchte, dass etwas veraltetes auch abgeschaltet wird, habe ich den Code wie folgt geändert, um als Quelle des QR-Codes http://goqr.me/api/ zu verwenden.

Sub QR_Code_01_goqr_me()
    Dim TMRange As Range
    With ActiveDocument
        Set TMRange = .Bookmarks("Textmarke01").Range
        URL_QRCode_SERIES_goqr_me "12345678", TMRange
    End With
End Sub

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 Variant

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 sFormatParameter As String = "format=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 & _
            sFormatParameter & _
            sJoinCHR & _
            sMarginParameter & _
            sJoinCHR & _
            sDataParameter & UTF8_URL_Encode(VBA.Replace(QR_Value, " ", "+"))
          
    MsgBox (sURL)
    
    Set oPic = ActiveDocument.InlineShapes.AddPicture(sURL, False, True, oRng)
lbl_Exit:
    Exit Function
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

Zu meinem Bedauern erhalte ich aber bei dieser Codezeile

Set oPic = ActiveDocument.InlineShapes.AddPicture(sURL, False, True, oRng)

der Funktion "URL_QRCode_SERIES_goqr_me" die Fehlermeldung: