Bild per Link in eine Zelle anzeigen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Olaf,
ich habe mir das spannende Thema mal für mich aufbereitet.
Wenn Du möchtest, kannst Du es gerne übernehmen und in Dein Tool einbauen.
Es ist jetzt nur noch eine Sub und die temporäre Zwischendatei wird gleich nach dem Einfügen wieder gelöscht.

Code:
 
Option Explicit

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

 Dim sPicFilename As String, sQR As String

 If Not TypeName(Selection) Like "Range" Then Exit Sub    'Keine korrekte Markierung

 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

        For i = 1 To Len(.Value)

            If InStr(Chr(34) & "&bsol;/:*?<>"=,;", 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

        sPicFilename = Environ("TEMP") & "&bsol;" & .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

        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

 Set xHttp = Nothing

End Sub

____________________

viele Grüße aus Freigericht
Karl-Heinz

Beliebteste Forumthreads (12 Monate)

Bild per Link in eine Zelle anzeigen

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

332 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Bild per Link in eine Zelle anzeigen

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

332 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread