Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

VBA Alle Bilder aus Ordner sortiert einfügen

VBA Alle Bilder aus Ordner sortiert einfügen
13.11.2016 15:23:52
Peter
Hallo zusammen!
Ich habe da schon seit einiger Zeit ein Problem mit dem Einfügen von Bildern in die Excel Arbeitsmappe. Ich habe ein funktionierendes Makro, dass alle Bilder aus einem Ordner in der Excel Tabelle nebeneinander anreiht. Mein Problem besteht nur darin, dass die Bilder nicht nach Datum oder Name sortiert werden. Ich hoffe es kann mir jemand dabei helfen.
Hier mein aktueller Stand:

Option Explicit
Private Const IMAGE_HEIGHT As Long = 115 'Bildhöhe
Private Const FIRST_IMAGE_TOP As Long = 15 'Startposition von oben
Private Const FIRST_IMAGE_LEFT As Long = 10 'Startposition von links
Private Const SPACE_H As Long = 5 'Horizontaler Abstand
Private Const SPACE_V As Long = 5 'Vertikaler Abstand
Private Const MAX_IMAGES_IN_ROW As Long = 3 'Maximale Bilderanzahl pro Reihe
Sub insertPictures()
Dim objImg As Object
Dim strPath As String, strImg As String
Dim dblTop As Double, dblLeft As Double, dblMaxWidth As Double
Dim lngIndex As Long, lngCalc As Long, hoehe As Long
Dim filelist() As String
Dim folder
On Error GoTo ErrExit
With Application
.ScreenUpdating = False
.EnableEvents = False
lngCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
hoehe = FIRST_IMAGE_TOP + ActiveCell.Top
dblTop = hoehe
dblLeft = FIRST_IMAGE_LEFT
strPath = fncBrowseForFolder
If Len(strPath) Then
ActiveSheet.Shapes.SelectAll
strPath = strPath & "\"
strImg = Dir(strPath & "*.jpg", vbNormal)
Do While strImg  ""
Set objImg = ActiveSheet.Pictures.Insert(strPath & strImg)
With objImg
.ShapeRange.LockAspectRatio = msoTrue
.Height = IMAGE_HEIGHT
.Left = dblLeft
.Top = dblTop
.ShapeRange.Rotation = 0
lngIndex = lngIndex + 1
dblMaxWidth = Application.Max(dblMaxWidth, .Width)
End With
If lngIndex Mod MAX_IMAGES_IN_ROW = 0 Then
dblTop = dblTop + IMAGE_HEIGHT + SPACE_V
dblLeft = FIRST_IMAGE_LEFT
Else
dblLeft = dblLeft + dblMaxWidth + SPACE_H
dblMaxWidth = 0
End If
strImg = Dir
Loop
End If
ErrExit:
With Err
If .Number  0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'insertPictures'" & vbLf & String(60, "_") & _
vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
"Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
.Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
"VBA - Fehler in Modul - Modul1"
.Clear
End If
End With
On Error GoTo 0
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = lngCalc
.DisplayAlerts = True
End With
Set objImg = Nothing
End Sub
Private Function fncBrowseForFolder(Optional ByVal defaultPath = "C:") As String
Dim objFlderItem As Object, objShell As Object, objFlder As Object
Set objShell = CreateObject("Shell.Application")
Set objFlder = objShell.BrowseForFolder(0&, "Ordner auswählen...", 0&, defaultPath)
If objFlder Is Nothing Then GoTo ErrExit
Set objFlderItem = objFlder.Self
fncBrowseForFolder = objFlderItem.Path
ErrExit:
Set objShell = Nothing
Set objFlder = Nothing
Set objFlderItem = Nothing
End Function

Danke schon mal für eure Hilfe!
Grüße
Peter

8
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: VBA Alle Bilder aus Ordner sortiert einfügen
13.11.2016 15:43:51
snb
Verwende
Sub M_snb()
sn=filtersplit(createobject("wscript.shell").exec("cmd /c dir ""G:\OF\*.jpg"" /b/s/od"). _
stdout.readall,vbcrlf),".")
cells(1).resize(ubound(sn)+1)=application.transpose(sn)
End Sub

AW: VBA Alle Bilder aus Ordner sortiert einfügen
13.11.2016 15:45:58
snb
etwas vergessen:
Sub M_snb()
sn=filter(split(createobject("wscript.shell").exec("cmd /c dir ""G:\OF\*.jpg"" /b/s/od"). _
stdout.readall,vbcrlf),".")
cells(1).resize(ubound(sn)+1)=application.transpose(sn)
End Sub

AW: VBA Alle Bilder aus Ordner sortiert einfügen
13.11.2016 16:18:32
Peter
Hallo,
noch was... wie muss ich "sn" deklarieren?
Grüße
as variant
13.11.2016 17:40:41
Michael
Hi Peter,
so schön sich die Shell formulieren läßt: sie hat den Nachteil, daß sie Dateinamen mit DOS-Zeichensatz zurückgibt, d.h. die Umlaute - sofern vorhanden - passen nicht.
Die kann man mit einem API-Aufruf in einem Rutsch konvertieren, siehe u.a. http://www.activevb.de/tipps/vb6tipps/tipp0058.html
Dazu mußt Du allerdings snbs Anweisung aufteilen:
sn=createobject("wscript.shell").exec("cmd /c dir ""G:\OF\*.jpg"" /b/s/od").stdout.readall
'.readall gibt einen String zurück, diesen
sn=konvertieren(sn) ' im Prinzip, siehe link
' und dann erst nach Zeilen zerlegen und filtern:
sn=filter(split(sn,vbcrlf),".")
sn ergibt ein Array, das Du anstelle der wiederholten Dirs nur auszulesen brauchst, also etwa
for i=lbound(sn) to ubound(sn) : machen(i) : next
/od sortiert nach Datum, /on nach Namen: nachzulesen in der Kommandozeile mit: dir /?
Schöne Grüße,
Michael
Anzeige
AW: as variant
13.11.2016 18:01:40
Peter
Hallo,
danke für die Info. Ich hab jetzt aber immer noch ein Problem...
und zwar bekomme ich beim ausführen immer einen Laufzeitfehler '13': Typen unverträglich. Weiß jemand womit das zu tun hat?
check Ergebnis
13.11.2016 23:03:03
snb
Deklarieren braucht man nicht (sn is sowieso -Methode-inherent- ein Variant), 'Option Explicit' löschen doch.
Du solltest die Mappe "G:\OF\" ändern bevor das Makro laufen zu lassen.
Wenn's keine Ergebnisse gibt könnte es auch schief gehen.
Kansst du test mit:

msgbox createobject("wscript.shell").exec("cmd /c dir ""G:\OF\*.jpg"" /b/s/od").stdout.readall 

Anzeige
AW: VBA Alle Bilder aus Ordner sortiert einfügen
13.11.2016 15:51:10
Peter
Hallo,
Ich bin ein VBA Neuling. Wie soll ich das einbauen bzw. verwenden?
Viele Grüße
Peter
jetzt mal am Stück
15.11.2016 15:44:34
Michael
Hi,
ich habe mal den Shell-Aufruf weggelassen und mich näher an Deinem Code angelehnt, damit Du eher die Chance hast, zu verstehen, was passiert:
Option Explicit
Private Const IMAGE_HEIGHT As Long = 115 'Bildhöhe
Private Const FIRST_IMAGE_TOP As Long = 15 'Startposition von oben
Private Const FIRST_IMAGE_LEFT As Long = 10 'Startposition von links
Private Const SPACE_H As Long = 5 'Horizontaler Abstand
Private Const SPACE_V As Long = 5 'Vertikaler Abstand
Private Const MAX_IMAGES_IN_ROW As Long = 3 'Maximale Bilderanzahl pro Reihe
Sub BilderWeg()
Dim sh As Shape
For Each sh In ActiveSheet.Shapes
If LCase(Mid(sh.Name, 1, 3)) = "pic" Then sh.Delete
' hier ggf. "pic" durch "jpg" ersetzen, siehe unten
Next
End Sub
Sub insertPictures()
Dim objImg As Object
Dim strPath As String, strImg As String
Dim dblTop As Double, dblLeft As Double, dblMaxWidth As Double
Dim lngIndex As Long, lngCalc As Long, hoehe As Long
Dim filelist() As String
Dim folder
Dim datein, z As Long, i As Long
On Error GoTo ErrExit
With Application
.ScreenUpdating = False
.EnableEvents = False
lngCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
hoehe = FIRST_IMAGE_TOP + ActiveCell.Top
dblTop = hoehe
dblLeft = FIRST_IMAGE_LEFT
strPath = fncBrowseForFolder
If Len(strPath) Then
' ActiveSheet.Shapes.SelectAll ' warum? Zum Überschreiben bzw. Löschen?
strPath = strPath & "\"
strImg = Dir(strPath & "*.jpg", vbNormal)
Do While strImg  ""
z = z + 1
Range("A" & z) = strImg
strImg = Dir
Loop
If z > 0 Then BilderWeg
Range("A1").Resize(z).Sort Range("A1"), xlAscending, Header:=xlNo
datein = Range("A1").Resize(z)
Range("A1").Resize(z).Clear
For i = 1 To z
Set objImg = ActiveSheet.Pictures.Insert(strPath & datein(i, 1))
With objImg
.ShapeRange.LockAspectRatio = msoTrue
.Height = IMAGE_HEIGHT
.Left = dblLeft
.Top = dblTop
.Name = "JpgImport_" & i  ' *** siehe unten
.ShapeRange.Rotation = 0
lngIndex = lngIndex + 1
dblMaxWidth = Application.Max(dblMaxWidth, .Width)
End With
If lngIndex Mod MAX_IMAGES_IN_ROW = 0 Then
dblTop = dblTop + IMAGE_HEIGHT + SPACE_V
dblLeft = FIRST_IMAGE_LEFT
Else
dblLeft = dblLeft + dblMaxWidth + SPACE_H
dblMaxWidth = 0
End If
Next
End If
ErrExit:
With Err
If .Number  0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'insertPictures'" & vbLf & String(60, "_") & _
vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
"Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
.Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
"VBA - Fehler in Modul - Modul1"
.Clear
End If
End With
On Error GoTo 0
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = lngCalc
.DisplayAlerts = True
End With
Set objImg = Nothing
End Sub
Private Function fncBrowseForFolder(Optional ByVal defaultPath = "C:") As String
Dim objFlderItem As Object, objShell As Object, objFlder As Object
Set objShell = CreateObject("Shell.Application")
Set objFlder = objShell.BrowseForFolder(0&, "Ordner auswählen...", 0&, defaultPath)
If objFlder Is Nothing Then GoTo ErrExit
Set objFlderItem = objFlder.Self
fncBrowseForFolder = objFlderItem.Path
ErrExit:
Set objShell = Nothing
Set objFlder = Nothing
Set objFlderItem = Nothing
End Function

Eigentlich ist das Array "Datei" unnötig, Du kannst auch beim Set schreiben:
.Insert(strPath & range("A" & i))
nur habe ich festgestellt, daß der zweite Import komischerweise nicht ganz links oben, sondern irgendwo mittendrin anfängt: deshalb der (vergebliche) Versuch, erst die Zellen ins Array zu stecken und die Dateinamen im Range("A1:Az") *vor* dem Import der Grafiken zu löschen.
Zum Löschen habe ich eine extra-Prozedur BilderWeg: auf die Art wird sichergestellt, daß nur die importierten Grafiken, nicht aber etwaige Schaltflächen gelöscht werden.
Seltsam ist hier wiederum, daß der Name eines angeklickten Bildes mit "Grafiken x" angezeigt wird, die findet das Makro aber nicht, weil sie VBA-intern als "Picture x" bezeichnet werden.
Das kannst Du leicht begradigen, indem Du nach .Top noch eine Zeile einfügst und einen Namen vergibst.
Schöne Grüße,
Michael
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige