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
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)
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