Bilder automatisch einfügen/verkleinern
17.06.2017 20:38:42
Angela
Aber ich bekomme die größe der Bilder einfach nicht hin und bräuchte da mal eine Erklärung. Die Bilder sollten eigentich in der Größe der Spalte/Zelle sein.
Also die Spalte soll sich nicht vergrößern wenn das Bild eingefügt wird.
War das jetzt verständlich erklärt?
Sub Bilder_einfügen()
Dim Pfad As String
Dim strDatnam As String
Dim Wiederholungen As Long
Dim Bildbreite As Single
Dim Bildhöhe As Single
Dim meinBild
Dim maxSpaltenbreite As Single
Dim Bild As Shape
Dim Zelle As Range
'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False
'Pfad anpassen
Pfad = "C:\Users\PC\Desktop\AM-Web-Office\Bilder\"
'Spalte D ab Zeile 2 durchlaufen
For Wiederholungen = 2 To ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
'Namen der Bilder stehen in Spalte B - ohne Endung; Einlesen in Variable mit Pfadangaben
strDatnam = Pfad & Cells(Wiederholungen, 4).Value & ".jpg"
'Prüfen, ob Bilddatei im Verzeichnis existiert
If Dir(strDatnam) "" Then
'falls ja, dann Bildhöhe und -breite einlesen
Set meinBild = LoadPicture(strDatnam)
Bildbreite = meinBild.Width
Bildhoehe = meinBild.Height
'Bild einfügen, 9 cm hoch - 1 cm = 28,35 pt - und Breite entsprechend skaliert
ActiveSheet.Shapes.AddPicture strDatnam, msoFalse, msoTrue, Cells(Wiederholungen, 7).Left, _
Cells(Wiederholungen, 7).Top, 141.75 * Bildbreite / Bildhoehe, 141.75
'maximale Spaltenbreite ermitteln, für die Anpassung der Spaltenbreite
If maxSpaltenbreite