Thumbnail zur Bilder-URL anzeigen lassen

Juergen · 2016-04-15T10:56:22+00:00

Hallo zusammen, es hat mir Rudi ja diesen genialen Code aufgezeigt aber schon muss ich was hinter her fragen: • Private Sub cmdBild_einfuegen_Click() 'Bild suchen und einfügen With Application.FileDialog(msoFileDialogFilePicker) .AllowMultiSelect = False .InitialFileName = "c:\tmp\" .Filters.Add "Bilder", "*.jpg" .FilterIndex = .Filters.Count If .Show = -1 Then ActiveSheet.Hyperlinks.Add _ Anchor:=Cells(Rows.Count, 1).End(xlUp).Offset(, 6), _ Address:=.SelectedItems(1) End If End With End Sub Es wird der URL-Link in die 7. Zelle der Zeile vom Bild geschrieben. Es stellte sich nun heraus, dass einen Vorabschau eines kleinen Thumbnails das Arbeiten mit der Tabelle erleichtern würde. Könnte man den Code dahin erweitern, dass zusätzlich in der Zelle 8 zur URL ergänzend ein kleines Bildchen angezeigt werden würde? Es sind jedoch die Bilder in unterschiedlichen Abmessungen vorhanden. So sollten die Thumb's gleich alle auf einheitliche Höhe reduziert und an die Zeilenhöhe angepasst werden. Vielleicht hat jemand eine Code-Erweiterungs-Idee :) Oder, es ist ganz einfach über einen Formel in Referenz zur URL Zelle zu handhaben? Denke aber nicht, da keine Anpassungen erfolgen bezügl. der Größe des Bildes, oder? Danke im voraus! Gruss, Juergen

hallo Jürgen,
du könntest zB. das jpg als Bild in einen Kommentar der Zelle einfügen.
Dabei:
musst du zunächst die Höhe und Breite des Bildes ermitteln, damit es im Kommentar nicht verzerrt wird.
Höhe und Breite erhältst du durch Analyse der Bytes oder durch Auslesen der EXIF-Daten oder ...
Code: siehe unten
Nachteil:
Das Bild wird zwar kleiner dargestellt, in der Datei wird das Bild aber in nahezu voller Größe gespeichert. Somit wächst die XLS-Datei mit jedem Bild und bei zB. 100 Bildern à 2MB biste dann bei gut 200MB. Dateien dieser Größe kann man nicht mehr vernünftig handhaben.
Alternativ-1:
temporär das jpg in ein Diagramm importieren. Dieses Diagramm als Bild exportieren und speichern. Dieses jpg mit dem so verkleinerten Bild wie oben in einen Kommentar einfügen
Alternativ-2:
alle Bilder zunächste mit externen Tools (zB. Irfanview) verkleinern und in einem entspr. Ordner speichern und wie oben in einen Kommentar einfügen
Alternativ-3:
Nutzung diverser DLL's ....

Option Explicit
Sub Bildvorschau()
' - einfügen von Hyperlink zur gewählten JPG-Datei
' - einfügen JPG-Datei als Vorschau im Kommentar
Dim wks As Worksheet
Dim rng As Range
Dim strFile As String
Dim dblWdth As Double
Dim dblHhgt As Double
Dim cmt As Comment
Dim sh As Shape
Set wks = ActiveSheet
Set rng = wks.Cells(wks.Rows.Count, 1).End(xlUp).Offset(, 6)
rng.Comment.Delete
rng.Value = ""
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
.InitialFileName = "c:\tmp\"
.Filters.Add "Bilder", "*.jpg"
.FilterIndex = .Filters.Count
If .Show = -1 Then
strFile = .SelectedItems(1)
Call GetJpgSize(strFile, dblWdth, dblHhgt)
wks.Hyperlinks.Add Anchor:=rng, Address:=strFile
Set cmt = rng.AddComment
Set sh = cmt.Shape
sh.Fill.UserPicture strFile
sh.Height = 80
sh.Width = sh.Height * dblWdth / dblHhgt
End If
End With
Set sh = Nothing
Set cmt = Nothing
Set rng = Nothing
Set wks = Nothing
End Sub
Function GetJpgSize(ByVal strFile As String, dblWdth As Double, dblHght As Double) As Boolean
' in Anlehnung an 'http://www.michael-schwimmer.de/vba061.htm
Dim intFF As Integer, c As Long, lngPntr As Long
Dim x As Byte, y As Byte, bytFlag As Byte
intFF = FreeFile
lngPntr = 1
Open strFile For Binary Access Read As #intFF
Get #intFF, 2, bytFlag
Get #intFF, 5, x
Get #intFF, 6, y
c = CDbl(x) * 256 + CDbl(y)
lngPntr = 6
Do
If (bytFlag = &HC2) Or (bytFlag = &HC0) Then
Get #intFF, lngPntr + 4, x
Get #intFF, , y
dblWdth = CDbl(x) * 256 + CDbl(y)
Get #intFF, lngPntr + 2, x
Get #intFF, , y
dblHght = CDbl(x) * 256 + CDbl(y)
GetJpgSize = True
Exit Do
End If
lngPntr = lngPntr + c - 2
Get #intFF, lngPntr + 1, x
If x  255 Then Exit Do
Get #intFF, , bytFlag
lngPntr = lngPntr + 2
Get #intFF, lngPntr + 1, x
Get #intFF, , y
c = CLng(x) * 256 + CLng(y)
lngPntr = lngPntr + 2
Loop While bytFlag  &HD9
Close #intFF
End Function

Grüße
Christian

Nachtrag:
...ich habe die Exceltabelle in der Hyperlinks zu Bildern stehen. Das sieht je Zeile vereinfacht so aus:
A1=Anschrift
B1=Strasse
C1=Ort
D1=Einbaulage
E1=HYPERLINK zum Bild
F1= hier dann Bild aus E1 anzeigen lassen
Kann ich mir in der Zelle F1 neben dem Hyperlink das dazugehörige Bild als Miniatur anzeigen lassen (ch möchte sie gern als 50x50px anzeigen lassen)? Einen Button benötige ich nicht dafür.
Ich habe dazu folgenden Code gefunden, doch mit meinen mickrigen VBA Kenntnisse kann ich den nicht für mich hinbiegen. Weiss vielleicht jemand Rat? Danke im voraus!
Gruss, Juergen

' **********************************************************************
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
Option Explicit
Private Sub CommandButton1_Click()
'PARAMETER: Tabelle, Spalte mit den Adresse, Spalte in die die Bilder sollen, Breite, Höhe
PicFromURL Me, Range("V:V").Column, Range("Y:Y").Column, 50, 50
End Sub
' Modul: Modul1 Typ: Allgemeines Modul
Option Explicit
Private Declare Function URLDownloadToFile Lib "urlmon" Alias _
"URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal _
szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Sub PicFromURL(Sh As Worksheet, URLColumn As Long, PICColumn As Long, PICWidth As Single,  _
PICHeight As Single)
Dim lngRow As Long, lngResult As Long
Dim objPic As Object
Dim strTmpFile As String, strExt As String
With Sh
For Each objPic In .Shapes
If objPic.Type = msoPicture Then objPic.Delete
Next
For lngRow = 1 To .Cells(Rows.Count, URLColumn).End(xlUp).Row
strExt = Mid(.Cells(lngRow, URLColumn).Text, InStrRev(.Cells(lngRow, URLColumn). _
Text, "."))
strTmpFile = Environ("Temp") & "\tmp" & strExt
lngResult = URLDownloadToFile(0, .Cells(lngRow, URLColumn).Text, strTmpFile, 0, 0)
If lngResult = 0 Then
Set objPic = .Pictures.Insert(strTmpFile)
objPic.Left = .Cells(lngRow, PICColumn).Left
objPic.Top = .Cells(lngRow, PICColumn).Top
objPic.ShapeRange.LockAspectRatio = False
objPic.Width = PICWidth
objPic.Height = PICHeight
Kill strTmpFile
End If
Next
End With
Set objPic = Nothing
End Sub

Thumbnail zur Bilder-URL anzeigen lassen

Forumthread: Thumbnail zur Bilder-URL anzeigen lassen

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Infobox / Tutorial