AW: Bild Speicher Ort festlegen
22.11.2020 15:10:43
Dieter
Hallo Olaf,
wenn ich deine Frage richtig verstehe, dann kannst du das mit deinem etwas abgeänderten Programm machen:
Sub InsertQR()
'Sub erstellt einen QR-Code und fügt ihn in das Blatt ein
Dim rZelle As Range, AC As Range, xHttp As Object
Dim iSize As Integer, i As Integer, bDone As Boolean
Dim sPicFilename As String, sQR As String, sBild As String, sPfad As String
If Not TypeName(Selection) Like "Range" Then Exit Sub 'Keine korrekte Markierung
sPfad = ThisWorkbook.Path & "\"
Set xHttp = CreateObject("Microsoft.XMLHTTP")
iSize = 250 'dalam Pixels
For Each rZelle In Selection 'Alle Zellen in Selektion durchgehen
With rZelle
If .Column = 3 And .Value "" Then 'Nur Spalte C und vorhandenem Wert
'Datei auf Fehler untersuchen
bDone = True
For i = 1 To Len(.Value)
If InStr(Chr(34) & "\/:*?|=;", Mid(.Value, i, 1)) > 0 Then
MsgBox "Die Datei " & vbCrLf & "'" & .Value & "'" _
& vbCrLf & vbCrLf & " enthält fehlerhafte Zeichen!"
Exit Sub
End If
Next
'Url zusammenbauen
sQR = "http://chart.googleapis.com/chart?chs=" _
& iSize & "x" & iSize & "&cht=qr&chl=" & .Value
xHttp.Open "GET", sQR, False
xHttp.Send
'Picnamen/Pfad zusammenbauen
sBild = .Value
If Not sBild Like "*.png" Then sBild = sBild & ".png"
sPicFilename = Environ("TEMP") & "\" & sBild 'Datei ins Temp-Verzeichnis
With CreateObject("Adodb.Stream")
.Type = 1 '//binary
.Open
.write xHttp.responseBody
.savetofile sPicFilename, 2 'überschreiben
.savetofile sPfad & sBild, 2 'überschreiben
.Close
End With
'Bild wird an Zelle in Spalte D angepasst
Set AC = .Offset(0, 1)
ActiveSheet.Shapes.AddPicture(sPicFilename, False, True, _
AC.Left + 1, AC.Top + 1, _
AC.Width - 2, AC.Height - 2).Name = "QR_" & .Value
If Dir(sPicFilename) "" Then Kill sPicFilename 'Datei löschen
End If
End With
Next rZelle
If bDone = False Then
MsgBox "Es wurde kein gültiges Feld in Spalte 'C' markiert und daher kein QR-Code erstellt!", _
vbExclamation, "QR-Code erstellen"
End If
Set xHttp = Nothing
End Sub
https://www.herber.de/bbs/user/141768.xlsm
Viele Grüße
Dieter