Lokale Speicherung eines per Google API erstellten QR-Codes
22.12.2023 13:52:48
Ingo101
mit mehreren Vorlagen aus dem Internet habe ich ein Makro (zusammen)gebastelt, dass aus einer Tabelle QR Codes für Visitenkarten erzeugen kann. Das ganze passiert über die Google API. Ziel ist ein QR-Code, der auf eine Visitenkarte soll und dann gescannt werden kann.
Der Code an sich funktioniert. Der QR wird erstellt und ist lesbar. Aber ich weiß nicht, wie ich ihm lokal speichern kann. Die Datei soll als PNG mit einem einmaligem Namen aus der Tabelle, z.B. aus Spalte Q gespeichert werden.
Ist das möglich? Und wenn ja, wie kann man das umsetzen?
Vielen Dank für Eure Hilfe!
lg
Ingo
Sub generateQRCode()
strURL = "https://chart.googleapis.com/chart?cht=qr"
For intRow = 2 To 10
' NEU
strTitel = Trim(ThisWorkbook.Sheets("Contact_Info").Range("A" & intRow).Text)
strFname = Trim(ThisWorkbook.Sheets("Contact_Info").Range("B" & intRow).Text)
strLname = Trim(ThisWorkbook.Sheets("Contact_Info").Range("C" & intRow).Text)
strRole = Trim(ThisWorkbook.Sheets("Contact_Info").Range("D" & intRow).Text)
strJobTitle = Trim(ThisWorkbook.Sheets("Contact_Info").Range("E" & intRow).Text)
strAdresse = Trim(ThisWorkbook.Sheets("Contact_Info").Range("i" & intRow).Text)
strEmail = Trim(ThisWorkbook.Sheets("Contact_Info").Range("k" & intRow).Text)
strFestnetz = Trim(ThisWorkbook.Sheets("Contact_Info").Range("l" & intRow).Text)
strCellPhone = Trim(ThisWorkbook.Sheets("Contact_Info").Range("n" & intRow).Text)
strFax = Trim(ThisWorkbook.Sheets("Contact_Info").Range("m" & intRow).Text)
strVCF = ""
strVCF = strVCF & "BEGIN:VCARD" & Chr(10)
strVCF = strVCF & "VERSION:4.0" & Chr(10)
strVCF = strVCF & "N;charset=utf-8:" & strLname & ";" & strFname & ";" & strTitel & Chr(10)
strVCF = strVCF & "FN:" & strTitel & " " & strFname & " " & strLname & Chr(10)
strVCF = strVCF & "TITLE:" & strJobTitle & Chr(10)
strVCF = strVCF & "ORG:" & "xxxxx" & Chr(10)
strVCF = strVCF & "EMAIL;WORK:" & strEmail & Chr(10)
strVCF = strVCF & "ADR;WORK:" & strAdresse & Chr(10)
strVCF = strVCF & "TEL;TYPE=CELL,WORK:" & strCellPhone & Chr(10)
strVCF = strVCF & "TEL;WORK:" & strFestnetz & Chr(10)
strVCF = strVCF & "TEL;TYPE=FAX,WORK:" & strFax & Chr(10)
strVCF = strVCF & "ROLE:" & strRole & Chr(10)
strVCF = strVCF & "END:VCARD"
ThisWorkbook.Sheets("Contact_Info").Range("O" & intRow) = strVCF
strChs = "&chs=174" & "x" & "174"
strChl = "&chl="
strFinalURL = strURL & strChs & strChl & strVCF
Dim pic As Object, sh As Shape
ActiveSheet.Range("J" & intRow).Select
Set pic = ActiveSheet.Pictures.Insert(strFinalURL)
pic.Top = ActiveSheet.Range("J" & intRow).Top
pic.Left = ActiveSheet.Range("J" & intRow).Left
Next
End Sub