Hallo Daniel,
ich habe unten eine weitere Sub beigefügt un darüberhinaus folgende Line hinzugefügt:
hyperLinkedShape.OnAction = "BildVergrössern"
Die Vergrößerung habe ich auf Basis Deiner Wunschgrößen ermittelt.
Sub fotosEinfügen()
Dim sh As Shape, hyperLinkedShape As Shape
Dim ws As Worksheet
Dim strDateiPfad As String
Dim fs As Object, fPfad As Object, fFoto As Object, fFotos As Object
Dim i As Integer
Dim lz As Long
Dim strLecknummer As String, strLecknummerFoto As String
Dim laenge As Integer
'Annahme: Diese Datei liegt in dem Pfad, in dem die Bilder gespeichert sind
'Ich habe den Sheetnamen als "1" festgelegt. Bitte auf den entsprechenden Namen umändern
Set ws = Sheets("1")
strDateiPfad = ThisWorkbook.Path
'FileSystemObject erstellen um auf Ordner und Dateien zugreifen zu können
Set fs = CreateObject("scripting.FileSystemObject")
'Pfad festlegen, in dem die Fotos gespeichert sind
Set fPfad = fs.getfolder(strDateiPfad)
Set fFotos = fPfad.Files
With ws
For Each sh In ws.Shapes
sh.Delete
Next sh
'letzte Zeile ermitteln
lz = .Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lz
strLecknummer = .Cells(i, 1).Value
'Alle in dem Ordner gespeicherten Fotos durchlaufen
For Each fFoto In fFotos
If Left(fFoto.Name, 4) = "Leck" Then
'Länge des Fotonamens ermitteln
laenge = Len(fFoto.Name)
'Lecknummer aus Dateinamen ermitteln
'Dateiname: Leck 1-2.jpg
'-> Die ersten sieben und die letzten vier Zeichen müssen abgeschnitten werden, um die jeweilige Lecknummer zu ermitteln
'Diese wird mit der Lecknumme rin Spalte A verglichen
strLecknummerFoto = Mid(fFoto.Name, 6, (laenge - 11))
'Prüfung, ob die aktuelle Lecknummer der Nummer in dem Foto entspricht
If strLecknummer = strLecknummerFoto Then
'Aus dateinamen ermitteln ob es das Fot -2 oder -3 ist und entsprechend die Zelle festlegen, in der das Foto eingefügt werden soll.
If Left(Right(fFoto.Name, 5), 1) = "2" Then
'Einfügen des Fotos (40,40 bedeutet Breite, Höhe des Fotos in Pixeln
.Shapes.AddPicture fPfad & "\" & fFoto.Name, _
False, True, _
.Cells(i, 6).Left, _
.Cells(i, 6).Top, _
196, 147
Set hyperLinkedShape = .Shapes(.Shapes.Count)
hyperLinkedShape.OnAction = "BildVergrössern"
'ws.Hyperlinks.Add Anchor:=hyperLinkedShape, Address:=fFoto.Name
ElseIf Left(Right(fFoto.Name, 5), 1) = "3" Then
.Shapes.AddPicture fPfad & "\" & fFoto.Name, _
False, True, _
.Cells(i, 7).Left, _
.Cells(i, 7).Top, _
196, 147
Set hyperLinkedShape = .Shapes(.Shapes.Count)
hyperLinkedShape.OnAction = "BildVergrössern"
'ws.Hyperlinks.Add Anchor:=hyperLinkedShape, Address:=fFoto.Name
End If
End If
End If
Next fFoto
Next i
End With
End Sub
Sub BildVergrössern()
Dim Faktor As Double
With ActiveSheet.Shapes(Application.Caller)
'23.6734694 ist der Faktor, der erforderlich ist das Bild von 196x147 aus 4.640 x 3.480 zu vergrößern
Faktor = IIf(.Width > 200, 1 / 23.6734694, 23.6734694)
.ScaleWidth Faktor, msoFalse, msoScaleFromTopLeft
.ScaleHeight Faktor, msoFalse, msoScaleFromTopLeft
End With
End Sub
Ich hoffe, das ist, was Du suchst.
Viele Grüße
Kai
|