VBA Bilder einfügen - Bildgröße
11.04.2017 12:42:11
Achim
irgendwie sehe ich den Wald vor lauter Bäumen nicht mehr.
Ich habe ein paar Makros geschrieben, die in eine Tabelle Bilder einfügen sollen.
Da die Bilder immer unterschiedliche Größe haben und ich mit einem Layout bei
den Excelblättern arbeite, gehe ich einen Umweg und füge die Bilder auf einem
temporären Tabellenblatt ein. (Vielleicht geht dies auch direkt, aber ich hatte bei ausgeblendeten Spalten immer Schwierigkeiten.)
Dies funktioniert mit der Funktion "Sheets("Bilder_Temp").Pictures.Insert" auch sehr gut. Leider fügt diese Funktion nur Links ab Excel 2010 ein. Jetzt möchte ich meine Makros umbauen und die Funktion "Sheets("Bilder_Temp").Shapes.AddPicture" verwenden.
Irgendwie finde ich gerade die Funktion zum ändern z.B. der Bildbreite nicht.
Kann mir jemand einen Tipp geben.
Noch eine Kleinigkeit tritt bei diesen Makros auf. Ich möchte nach dem Einfügen ein PDF erstellen - kein Problem grundsätzlich - aber wenn ich mit der PasteSpecial-Methode die Bilder aktuell kopiere, funktioniert im PDF das direkte Copy&Paste nicht mehr. Die normale Paste-Funktion arbeitet wieder nur mit Links. Irgendwie wird das Bild im PDF nicht als Bild eingebettet und dies führt dazu, dass die Bilder nicht direkt kopiert werden können und beim Pasten ein schwarzes Bild entsteht. Die Screenshot-PDF-Funktion ist auf Grund der Bilderanzahl nicht zielführend.
Hier seht ihr das erste Makro und in welche Richtung ich gehen möchte.
Weiter unten seht ihr das zweite Makro, welches noch vollständig mit ".insert" arbeitet.
Übersehe ich etwas, oder was mach ich falsch.
Sub Uebersichts_Bilder_einfuegen()
Dim bytBild As Byte
Dim arrBereiche1()
Dim arrBereiche2()
Dim Bildname As String
Dim Teile As Variant
Dim ic As Integer
'arrBereiche
arrBereiche1 = Array("C3", "C53", "C103", "C153", "C203")
arrBereiche2 = Array("C2", "C52", "C102", "C152", "C202")
'Auswahl des Tabellenblattes, damit das Makro sauber laeuft
ThisWorkbook.Sheets("Uebersichtsbilder").Select
'Screenupdate deaktivieren
Application.ScreenUpdating = False
'Aufruf Fileopendialog und Bilder auswaehlen
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = True
.InitialFileName = ActiveWorkbook.Path
.ButtonName = "OK"
.Title = "Bilderauswahl"
.Show
'Bilder einfügen - maximal moegliche Bildanzahl 30
If .SelectedItems.Count Sub Bilder_einfuegen2()
Dim bytBild As Byte
Dim arrBereiche1()
Dim arrBereiche2()
Dim Bildname As String
Dim Teile As Variant
Dim ic As Integer
'arrBereiche
arrBereiche1 = Array("C3", "C28", "C53", "C78", "C103", "C128", "C153", "C178", "C203", " _
C228", "C253", "C278", _
"C303", "C328", "C353", "C378", "C403", "C428", "C453", "C478", "C503", "C528", "C553", " _
C578", _
"C603", "C628", "C653", "C678", "C703", "C728", "C753", "C778", "C803", "C828", "C853", " _
C878")
arrBereiche2 = Array("C2", "C27", "C52", "C77", "C102", "C127", "C152", "C177", "C202", " _
C227", "C252", "C277", _
"C302", "C327", "C352", "C377", "C402", "C427", "C452", "C477", "C502", "C527", "C552", " _
C577", _
"C602", "C627", "C652", "C677", "C702", "C727", "C752", "C777", "C802", "C827", "C852", " _
C877")
'Auswahl des Tabellenblattes, damit das Makro sauber laeuft
ThisWorkbook.Sheets("Bilder").Select
'Screenupdate deaktivieren
Application.ScreenUpdating = False
'Aufruf Fileopendialog und Bilder auswaehlen
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = True
.InitialFileName = ActiveWorkbook.Path
'.InitialFileName = "D:\TEMP\Bilder"
.ButtonName = "OK"
.Title = "Bilderauswahl"
.Show
'Bilder einfügen - maximal moegliche Bildanzahl 30
If .SelectedItems.Count 300 Then
With .ShapeRange
.LockAspectRatio = msoTrue
.Height = 310
End With
End If
Sheets("Bilder_Temp").Pictures("Bild_Temp").Cut
'vorhandene Bilder zaehlen
ic = Sheets("Bilder").Shapes.Count
'Bilder auf den naechsten verfuegbaren Platz setzen
With Sheets("Bilder")
.Select
.Range(arrBereiche1(ic)).Select
'.Paste
.PasteSpecial Format:="Picture (JPEG)", Link:=False, DisplayAsIcon:= _
False
End With
Range(arrBereiche2(ic)) = Bildname
'.Range(arrBereiche1(bytBild - 1)).Select
End With
Next bytBild
Else
MsgBox "Maximal 30 Bilder auswählbar"
End If
End With
Application.ScreenUpdating = True
End Sub