01
02
03
04
05
06
07
08
09
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55 |
|
Option Explicit
Sub CreateQR()
' Sub erstellt einen QR-Code und fügt ihn in das Blatt ein
Dim xHttp As Object, oShape As Object, rZiel As Range
Dim iSize As Integer
Dim sPicFilename As String, sQR As String, T As String
Set xHttp = CreateObject("Microsoft.XMLHTTP")
iSize = 250 ' Pixels
Set rZiel = Range("B2") ' Zielzelle setzen
' Vorhandenes QR-Bild löschen
For Each oShape In ActiveSheet.Shapes
If oShape.TopLeftCell.Address = rZiel.Address Then
oShape.Delete: Exit For
End If
Next oShape
With Range("A1") ' Quellzelle
' Url zusammenbauen
T = Replace(.Value, "ß", "ß")
T = Replace(Replace(Replace(T, "ä", "ä"), "ü", "ü"), "ö", "ö")
T = Replace(Replace(Replace(T, "Ä", "Ä"), "Ü", "Uuml;"), "Ö", "&Ounml;")
sQR = "http://chart.googleapis.com/chart?" _
& "chs=" & iSize & "x" & iSize _
& "&choe=UTF-8" _
& "&cht=qr&chl=" & T
xHttp.Open "GET", sQR, False
xHttp.Send
' Picnamen/Pfad zusammenbauen
sPicFilename = Environ("TEMP") & "\" & .Value ' Datei ins Temp-Verzeichnis
If Not sPicFilename Like "*.png" Then sPicFilename = sPicFilename & ".png"
With CreateObject("Adodb.Stream")
.Type = 1 ' //binary
.Open
.Write xHttp.responseBody
.SaveToFile sPicFilename, 2 ' überschreiben
.Close
End With
' Bild wird an Zelle in Spalte D angepasst
With rZiel ' Ziel Zelle B2
ActiveSheet.Shapes.AddPicture(sPicFilename, False, True, _
.Left + 1, .Top + 1, _
.Width - 2, .Height - 2).Name = "QR_" & .Value
End With
If Dir(sPicFilename) <> "" Then Kill sPicFilename ' Datei löschen
End With
Set xHttp = Nothing
End Sub
|