Ich möchte mehrere QR Codes auf einmal generieren. Doch mein Problem ist Internetlink haben Sonderzeichen die nicht im Namen für PNG gespeichert werden können. Wie kann jedem PNG einen anderen Namen geben ohne das dieser Name der Link ist?
Sub InsertQR()
Dim xHttp: Set xHttp = CreateObject("Microsoft.XMLHTTP")
Dim bStrm: Set bStrm = CreateObject("Adodb.Stream")
Dim Size: Size = 250 'dalam Pixels
Dim QR, Name, val
Dim Invalid: Invalid = "\/:*?" & """" & "<>|"
For Each val In Selection
Name = val.Value
For intChar = 1 To Len(Name)
If InStr(Invalid, LCase(Mid(Name, intChar, 1))) > 0 Then
MsgBox "The file: " & vbCrLf & """" & Name & """" & vbCrLf & vbCrLf & " is invalid!"
Exit Sub
End If
Next
QR = "http://chart.googleapis.com/chart?chs=" & Size & "x" & Size & "&cht=qr&chl=" & Name
xHttp.Open "GET", QR, False
xHttp.Send
With bStrm
.Type = 1 '//binary
.Open
.write xHttp.responseBody
.savetofile ThisWorkbook.Path & Application.PathSeparator & Name & ".png", 2 '//overwrite
.Close
End With
Next
End Sub
Function ShowPic(PicFile As String) As String
Dim AC As Range
On Error GoTo Done
Set AC = Application.Caller
ActiveSheet.Shapes.AddPicture(ThisWorkbook.Path & Application.PathSeparator & PicFile, False, True, AC.Left, AC.Top, 30, 30).Name = "QR"
ShowPic = ""
Exit Function
Done:
ShowPic = "Error"
End Function
Sub PutTheQR()
Dim val As String
val = ActiveCell.Offset(0, -1).Value
Do While val <> ""
ActiveCell.FormulaR1C1 = "=ShowPic(RC[-1])"
ActiveCell.ClearContents
ActiveCell.Offset(1, 0).Activate
val = ActiveCell.Offset(0, -1).Value
Loop
End Sub
|