Hallo,
Ich habe ein Excel Formular erstellt, auf diesem sollen bis zu 8 Bilder dargestellt werden. Über den Explorer rufe und wähle ich die Bilder aus.
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 Makro:
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
Danke, Gruss nagel