AW: (mehrere) Bilder einfügen
16.10.2021 13:28:28
Nepumuk
Hallo M@tt,
teste mal:
Option Explicit
Private Sub CommandButton1_Click()
Dim objFileDialog As FileDialog
Dim objShape As Shape
Dim aobjImageRange(1 To 6) As Range
Dim ialngIndex As Long
Set objFileDialog = Application.FileDialog(msoFileDialogFilePicker)
With objFileDialog
.AllowMultiSelect = True
.InitialFileName = "C:\Users\Ma\OneDrive - GA\Pictures\ZZZProbleme\"
With .Filters
If .Count > 0 Then Call .Delete
Call .Add("Bilddateien", "*.jpg;*.gif;*.bmp")
End With
If .Show Then
Set aobjImageRange(1) = ThisWorkbook.Sheets("Tabelle1").Cells(20, 1)
Set aobjImageRange(2) = ThisWorkbook.Sheets("Tabelle1").Cells(20, 4)
Set aobjImageRange(3) = ThisWorkbook.Sheets("Tabelle1").Cells(30, 1)
Set aobjImageRange(4) = ThisWorkbook.Sheets("Tabelle1").Cells(20, 4)
Set aobjImageRange(5) = ThisWorkbook.Sheets("Tabelle1").Cells(40, 1)
Set aobjImageRange(6) = ThisWorkbook.Sheets("Tabelle1").Cells(40, 4)
For ialngIndex = 1 To .SelectedItems.Count
Set objShape = ThisWorkbook.Sheets("Tabelle1").Shapes.AddPicture( _
Filename:=.SelectedItems(ialngIndex), LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _
Left:=aobjImageRange(ialngIndex).Left, Top:=aobjImageRange(ialngIndex).Top, Width:=-1, Height:=-1)
With objShape
.LockAspectRatio = msoTrue
.Height = 141
End With
Next
End If
End With
Set objFileDialog = Nothing
Set objShape = Nothing
Erase aobjImageRange
End Sub
Gruß
Nepumuk