Hallo, möchte über Dateimanager bis zu 8 Bilder auswählen (funktioniert), danach sollewn die Bilder automatisch in ein Excel Blatt eingefügt werden. darunter zusätzlich noch der Dateiname.
Bild Bereich A7…D27, F7…H27
Bild Bereich A31…D51, F31…H51
Bild Bereich A55…D75, F55…H75
Bild Bereich A79…D99, F79…H99
zusätzlich soll jeweils der Dateiname des Bildes eingefügt werden.
D28, G28,D52,G52,D76,G76,D100,G100
Hier mein Macro:
Sub BilderEinfuegen_neu()
Dim bytBild As Byte
Dim arrBereiche()
Dim StOrdner As String
Dim Zelle As String
Dim SNZelle As String
Dim RaBereich As Range
Dim zeile As String
SNZelle = Left$(Range(„C4“), 2)
Zelle = „20“ + SNZelle + „“
zeile = 28
StOrdner = „c:\ProgramData\SVI\ProfClaimDaten\ProfClaim_PR\Schaden“ & Zelle & Range(„C4“) ’ & Range(„D5“) Verzeichnis "C:+„Schadensnummer“ aus Zelle D5+ „“
Set RaBereich = Range(„D28,g28,D52,g52,D76,G76,D100,G100“)
arrBereiche = Array(„A7:d27“, „F7:h27“, „A31:D51“, „F31:H51“, „A55:D75“, „F55:H75“, „A79:D99“, „F79:H99“)
Application.ScreenUpdating = False
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = True
.InitialFileName = StOrdner
.ButtonName = „OK“
.Title = „Bilderauswahl“
.Show
If .SelectedItems.Count <= 8 Then
For bytBild = 1 To .SelectedItems.Count
ActiveSheet.Pictures.Insert .SelectedItems(bytBild)
Dim a(0)
Dim x As String
Dim i
x = .SelectedItems(bytBild)
a(0) = Split(x & „“, „“)
i = UBound(a(0))
If i <> 0 Then
RPT:
If (a(0)(i)) = „“ Then
i = i - 1
GoTo RPT
Else
x = a(0)(i)
End If
End If
With ActiveSheet.Pictures(ActiveSheet.Pictures.Count)
.Top = Range(arrBereiche(bytBild - 1)).Top
.Left = Range(arrBereiche(bytBild - 0)).Left
.Width = Range(arrBereiche(bytBild - 1)).Width
If .Height > Range(arrBereiche(bytBild - 1)).Height Then .Height = Range(arrBereiche(bytBild - 1)).Height
End With
Range(arrBereiche(bytBild - 1)).Cells(1, 1).Offset(21, -1).Value = Split(.SelectedItems(bytBild), „“)((UBound(Split(.SelectedItems(bytBild), „“))))
ActiveSheet.Cells(zeile, 4) = x
zeile = zeile + 4
Next bytBild
Else
MsgBox „Maximal nur 8 Bilder auswählbar“
End If
End With
Application.ScreenUpdating = True
End Sub