Option Explicit
Private Const IMAGE_HEIGHT As Long = 45
Private Const IMAGE_WIDTH As Long = 175
Private Const FIRST_IMAGE_TOP As Long = 15
Private Const FIRST_IMAGE_LEFT As Long = 20
Private Const SPACE_H As Long = 5
Private Const SPACE_V As Long = 5
Private Const MAX_IMAGES_IN_COL As Long = 3
Sub insertPictures()
Dim objImg As Object
Dim strPath As String, strImg As String
Dim dblTop As Double, dblLeft As Double
Dim lngIndex As Long, lngCalc As Long
On Error GoTo ErrExit
With Application
.ScreenUpdating = False
.EnableEvents = False
lngCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
dblTop = FIRST_IMAGE_TOP
dblLeft = FIRST_IMAGE_LEFT
strPath = ThisWorkbook.Path
If Len(strPath) Then
ActiveSheet.Shapes.SelectAll
Selection.Delete
strPath = strPath & "\"
strImg = Dir(strPath & "*.jpg", vbNormal)
Do While strImg <> ""
Set objImg = ActiveSheet.Pictures.Insert(strPath & strImg)
With objImg
.ShapeRange.LockAspectRatio = msoFalse
.Height = IMAGE_HEIGHT
.Width = IMAGE_WIDTH
.Left = dblLeft
.Top = dblTop
lngIndex = lngIndex + 1
End With
If lngIndex Mod MAX_IMAGES_IN_COL = 0 Then
dblTop = FIRST_IMAGE_TOP
dblLeft = dblLeft + IMAGE_WIDTH + SPACE_H
Else
dblTop = dblTop + IMAGE_HEIGHT + SPACE_V
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 = "") 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