ich hab ne datei bei der man alle bilder aus einem verzeichnis hintereinander in spalte A einfügt.
in cells(1,1) steht der Quellpfand
dann gehts immer im wechel weiter Cells(2,1) ein bild darunter der name des Bildes.
und das harkt es! er schreibt mir unter jedes Bild den namen des ersten bildes hin!
hier mal der code:
Option Explicit
Sub Bildeinfügen()
Dim fSearch As FileSearch
Dim strPath As String
Dim iCnt As Integer
Dim pic As Picture
Dim a As Integer
Dim strVerzeichnis$, strDatei$
Dim b As Integer
On Error GoTo ERRORHANDLER
Application.ScreenUpdating = False
' "alte" Bilder löschen
ActiveSheet.Pictures.Delete
With ActiveSheet
'Pfad anpassen
strPath = Cells(1, 1)
End With
Set fSearch = Application.FileSearch
With fSearch
.NewSearch
.LookIn = strPath
.SearchSubFolders = False '<<<<Unterordner durchsuchen True/False
.FileType = msoFileTypeAllFiles
.Filename = "*.Jpg; *.Bmp; *.Gif; *.jpg; *.bmp; *.gif; *.JPG; *.BMP; *.GIF" '<<<<Dateiendung
.Execute
If .Execute() > 0 Then
'gefundene Dateien durchlaufen
For iCnt = 1 To .FoundFiles.Count
'Bild einfügen
a = iCnt + iCnt
b = a + 1
Set pic = ActiveSheet.Pictures.Insert(.FoundFiles(iCnt))
'Dateinamen erkennen
strDatei = Dir(strPath & "\*.jpg")
'Größe anpassen und ausrichten
With pic.ShapeRange
.LockAspectRatio = msoTrue
.Left = Cells(a, 1).Left
.Height = Cells(a, 1).Height
.Top = Cells(a, 1).Top
.Fill.Visible = msoFalse
.Fill.Transparency = 0#
.Line.Weight = 0.75
.Line.DashStyle = msoLineSolid
.Line.Style = msoLineSingle
.Line.Transparency = 0#
.Line.Visible = msoTrue
.Line.ForeColor.SchemeColor = 64
.Line.BackColor.RGB = RGB(255, 255, 255)
End With
Set pic = Nothing
Cells(b, 1) = strDatei
Next
End If
End With
Set fSearch = Nothing
ERRORHANDLER:
Application.ScreenUpdating = True
End Sub
danke für eure gedanken!
gruß Rocky