Option Explicit
'Set recommendations for parameters requested via InputBox
Const recstartrow = 5
Const recstartcol = 3
Const reccolshift = 3
Const recrowshift = 3
Const recDfltPicHeight = 75
Const recDfltPicWidth = 75
Const recDfltColWidth = 15
Const recWrapAtCol = 12
Dim Shp As Shape 'Shape object to which pictures are loaded
Dim RootPath As String 'Holds the path to files
Dim swUseKillShapes As Boolean 'Controls is Activesheet is cleared
Dim swCancel As Integer 'Switch to test if user wants to cancel at any time in the dialogs
Dim startrow, rowshift, startcol, colshift, _
DfltPicHeight, DfltPicWidth, DfltColWidth, WrapAtCol, _
nextrow, nextcol As Long
Dim i As Integer
'Requires reference to Microsoft Scripting Runtime
' IDE menu Tools/References
Dim HashTable As New Scripting.Dictionary
Dim keez 'Array for HashTable Keys
Dim picfile As String
Sub LoadPicsLeftToRight()
On Error GoTo LoadPics_Error
Application.ScreenUpdating = False
GetParms:
Do
startrow = Application.InputBox("Start Images at row: ", , Default:=recstartrow, Type:=1)
If startrow = False Then GoSub DesireToCancel
Loop While startrow = False
Do
rowshift = Application.InputBox("Place Images with this many rows of separation: ", , Default:=recrowshift, Type:=1)
If rowshift = False Then GoSub DesireToCancel
Loop While rowshift = False
Do
startcol = Application.InputBox("Start Images at column: ", , Default:=recstartcol, Type:=1)
If startcol = False Then GoSub DesireToCancel
Loop While startcol = False
Do
colshift = Application.InputBox("Place Images with this many columns of separation: ", , Default:=reccolshift, Type:=1)
If colshift = False Then GoSub DesireToCancel
Loop While colshift = False
Do
DfltPicHeight = Application.InputBox("The Images should have default height of: ", , Default:=recDfltPicHeight, Type:=1)
If DfltPicHeight = False Then GoSub DesireToCancel
Loop While DfltPicHeight = False
Do
DfltPicWidth = Application.InputBox("The Images should have default width of: ", , Default:=recDfltPicWidth, Type:=1)
If DfltPicWidth = False Then GoSub DesireToCancel
Loop While DfltPicWidth = False
Do
DfltColWidth = Application.InputBox("Default Column widths to: ", , Default:=recDfltColWidth, Type:=1)
If DfltColWidth = False Then GoSub DesireToCancel
Loop While DfltColWidth = False
Do
WrapAtCol = Application.InputBox("Jump to the next row if the image would be placed after column: ", , Default:=recWrapAtCol, Type:=1)
If WrapAtCol = False Then GoSub DesireToCancel
Loop While WrapAtCol = False
Process:
Do
RootPath = BrowseForFolder
If RootPath = "False" Then GoSub DesireToCancel
Loop While RootPath = "False"
If RootPath <> "False" Then RootPath = RootPath & "\"
LoadHashTable
If HashTable.Count < 1 Then Exit Sub
nextrow = startrow
nextcol = startcol
KillShapesII 'Deletes all shapes/pictures and text of the active sheet
With ActiveSheet
keez = HashTable.Keys ' Get the keys.
For i = 0 To HashTable.Count - 1 ' Iterate the array.
If HashTable.Exists(keez(i)) Then
picfile = HashTable.Item(keez(i))
.Cells(nextrow, nextcol).Select
'Method Insert Shape
Set Shp = .Shapes.AddPicture(picfile, msoFalse, msoCTrue, .Cells(nextrow, nextcol).Left, .Cells(nextrow, nextcol).Top, DfltPicWidth, DfltPicHeight)
.Cells(nextrow, nextcol).RowHeight = Shp.Height
.Cells(nextrow, nextcol).ColumnWidth = DfltColWidth
.Cells(nextrow + 1, nextcol) = keez(i)
End If
'Determine the column for the next pic
nextcol = nextcol + 2
If nextcol > WrapAtCol Then
nextcol = startcol
nextrow = nextrow + rowshift
Else
nextcol = nextcol
nextrow = nextrow
End If
DoEvents 'Allows computer to process other things in intense loops
Next i
End With
On Error GoTo 0
Exit Sub
DesireToCancel:
'Manages messaging to user & prog. flow when cancel condition may be present
swCancel = MsgBox("Do you want to cancel?", vbYesNo)
Select Case swCancel
Case Is = vbYes
MsgBox "Exiting"
Exit Sub
Case Is = vbNo
Return
End Select
LoadPics_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure LoadPics " & vbLf & picfile
Err = 0
End Sub
Private Function LoadHashTable()
'Load Dictionary/Index
'A Dictionary/Index is an ordered list
'Omits the need to bubble sort an array
'clear hashtable
HashTable.RemoveAll
For i = 1 To 2
'Initialize picfile/Dir function
If i = 1 Then picfile = Dir(RootPath & "*.jpg")
If i = 2 Then picfile = Dir(RootPath & "*.gif")
Do While picfile <> ""
HashTable.Add picfile, RootPath & picfile
picfile = Dir()
DoEvents 'Allows computer to process other things in intense loops
Loop
Next
End Function
Sub KillShapesII()
Application.ScreenUpdating = False
With ActiveSheet
If .Shapes.Count > 0 Then
.Shapes.SelectAll
Selection.Delete
End If
.Cells.Clear
End With
End Sub
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'Citation: By Ken Puls http://www.vbaexpress.com/kb/getarticle.php?kb_id=284
'Function purpose: To Browser for a user selected folder.
'If the "OpenAt" path is provided, open the browser at that directory
'NOTE: If invalid, it will open at the Desktop level
Dim ShellApp As Object
'Create a file browser window at the default folder
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
'Destroy the Shell Application
Set ShellApp = Nothing
'Check for invalid or non-entries and send to the Invalid error
'handler if found
'Valid selections can begin L: (where L is a letter) or
'\\ (as in \\servername\sharename. All others are invalid
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
Invalid:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = False
End Function
)
