This is module code to ask you for the folder to look in for your photos then it adds all the photos to a column. The code also included a reset to return the application to blank!
Option Explicit
Option Base 1
Private Declare Function GetSystemDirectory _
Lib "kernel32" _
Alias "GetSystemDirectoryA" ( _
ByVal lpBuffer As String, _
ByVal nSize As Long) _
As Long
Const iMsgStyle As Integer = vbInformation + vbSystemModal
Dim x As Double
Function GetDrive()
Dim sSave As String, lRet As Long
sSave = Space(255)
lRet = GetSystemDirectory(sSave, 255)
GetDrive = Left(sSave, 3)
End Function
Sub LoadPictureFiles()
Dim objFolder As Object, strPictFullPath As String, strFileName As String
Dim ws As Worksheet, wb As Workbook
Dim OldStaBar As Boolean
Dim ArrImg
Dim z As Integer
'// Define your image Formats here [Change as required]
ArrImg = Array("*.bmp", "*.gif", "*.jpg", "*.jpeg", "*.tif")
'//
Set objFolder = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please Select Image Folder", 0, GetDrive)
If Not objFolder Is Nothing Then
'// Is it the Root Dir?...if so change
If Len(objFolder.Items.Item.Path) > 3 Then
strPictFullPath = objFolder.Items.Item.Path & Application.PathSeparator
Else
strPictFullPath = objFolder.Items.Item.Path
End If
Else
Exit Sub
End If
x = 2
'// Speed things up
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
'// Clear Old Data
DeletePicts
'// Setup Status
OldStaBar = Application.DisplayStatusBar
Application.StatusBar = True
For z = 1 To UBound(ArrImg)
strFileName = Dir(strPictFullPath & ArrImg(z))
' If strFileName = "" Then MsgBox "No " & ArrImg(z) & " files exist in " & _
' strPictFullPath, iMsgStyle: GoTo Again
'// Lets get the list
Do Until strFileName = ""
'On Error GoTo ErrH
Cells(x, 1).Select
ActiveSheet.Pictures.Insert(strPictFullPath & strFileName).Select
'// Now resize the ImageCell
ImageCellFormat x, 1
Cells(x, 2) = strFileName
Cells(x, 3) = FileLen(strPictFullPath & strFileName) \ 1024 & " Kb"
Cells(x, 4) = FileDateTime(strPictFullPath & strFileName)
Application.StatusBar = "File#:" & x - 1 & " " & strPictFullPath & strFileName
strFileName = Dir()
x = x + 1
Loop
Again:
Next
'// Format cell range
Columns("B:D").AutoFit
Columns(2).HorizontalAlignment = xlRight
MsgBox "Done......" & vbCrLf & x - 2 & " Image files found in " & _
strPictFullPath, iMsgStyle
Reset:
With Application
.DisplayAlerts = True
.ScreenUpdating = True
.StatusBar = OldStaBar
End With
Exit Sub
ErrH:
MsgBox Err.Number & vbCr & _
Err.Description & vbCr _
, vbMsgBoxHelpButton _
, "Error Accessing: " & strPictFullPath & strFileName _
, Err.HelpFile _
, Err.HelpContext
End Sub
Sub ImageCellFormat(rRow As Double, rCol As Integer)
Dim Left As Double, Top As Double
Dim Wdth As Double
Static LastW As Double
'// Incase Img is larger
'// Xl2000 409 Row Height Max!
On Error Resume Next
With ActiveSheet.Shapes
If x = 2 Then LastW = Selection.ShapeRange.Width - 0.1
Wdth = Selection.ShapeRange.Width
If Wdth > LastW Then LastW = Wdth: Columns(rCol).ColumnWidth = Wdth / 5.3
Rows(rRow).RowHeight = Selection.ShapeRange.Height
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Height = 200
Rows(rRow).RowHeight = 200
Columns("A:A").Select
Selection.ColumnWidth = 50
[A1].Select
If Err Then
'// handle Image > 409
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Height = 200
Rows(rRow).RowHeight = 200
End If
End With
End Sub
'// To delete ALL pictures then;
Sub DeletePicts()
Dim Pict As Shape
For Each Pict In ActiveSheet.Shapes
If Pict.Type = 13 Then
Pict.Delete
End If
Next
With Range([A2:D2], [A2:D2].End(xlDown))
.ClearContents
.Rows.AutoFit
.ColumnWidth = 8.43
End With
[A1].Select
'// reset the Usedrange
ActiveSheet.UsedRange
End Sub