VBA in excel 2003 to create thumbnails of pictures

[Paul B]

Can VBA in excel 2003 create thumbnails of all the pictures in a folder and put them in column A and the file name in column B? and size the pictures the same say about 1 inch by 1 inch

Thanks

 

[NdNoviceHlp]

Hi PaulB. This will get you started. Making pictures size to exact size needs is difficult. If you want to make your A column and rows into 1 inch blocks this will fudge a solution. Note: there is no error code included in case you don't have pic files in the folder. HTH. Dave

Sub InsertPictures()
Dim SFolder As Object, FSO As Object, Opic As Object
Dim sFile As Object, RngCnt As Integer
Dim ws As Worksheet
Set ws = ActiveSheet ' or a specific sheet
Set FSO = CreateObject("Scripting.FileSystemObject")
'Where the pictures are. Change to suit
Set SFolder = FSO.GetFolder("C:\Users\User\Pictures\")
For Each sFile In SFolder.Files
RngCnt = RngCnt + 1
Set Opic = Application.ActiveSheet.Shapes.AddPicture(SFolder.Path & "\" & sFile.Name, False, True, 1, 1, 1, 1)
Opic.Left = ws.Range("A" & RngCnt).Left
Opic.Top = ws.Range("A" & RngCnt).Top
Opic.Width = ws.Range("A" & RngCnt).Width
Opic.Height = ws.Range("A" & RngCnt).Height
ws.Range("B" & RngCnt).Value = sFile.Name
Next sFile
Set Opic = Nothing
Set SFolder = Nothing
Set FSO = Nothing
End Sub

 

[Paul B]

Sub InsertPictures() Dim SFolder As Object, FSO As Object, Opic As Object Dim sFile As Object, RngCnt As Integer Dim ws As Worksheet Set ws = ActiveSheet ' or a specific sheet Set FSO = CreateObject("Scripting.FileSystemObject") 'Where the pictures are. Change to suit Set SFolder = FSO.GetFolder("C:\Users\User\Pictures\") For Each sFile In SFolder.Files RngCnt = RngCnt + 1 Set Opic = Application.ActiveSheet.Shapes.AddPicture(SFolder.Path & "\" & sFile.Name, False, True, 1, 1, 1, 1) Opic.Left = ws.Range("A" & RngCnt).Left Opic.Top = ws.Range("A" & RngCnt).Top Opic.Width = ws.Range("A" & RngCnt).Width Opic.Height = ws.Range("A" & RngCnt).Height ws.Range("B" & RngCnt).Value = sFile.Name Next sFile Set Opic = Nothing Set SFolder = Nothing Set FSO = Nothing End Sub

Thanks for looking at this for me
Changed the Sfolder name to where the pictures are and ran it, got and error with the line below hightlighted, in the worksheet the firet picture name was in B1 and a black square in A1??

Set Opic = Application.ActiveSheet.Shapes.AddPicture(SFolder.Path & "\" & sFile.Name, False, True, 1, 1, 1, 1)



I have been looking online and found this code and it puts the all file names in column B and the pictures in Column A but the pictures also show as a black box

 Sub InsertThumbnails()

Dim fso As Object

Dim folder As Object

Dim file As Object

Dim row As Integer

Dim picPath As String



' Set the folder path containing the images

picPath = "!pictest/"



' Create FileSystemObject

Set fso = CreateObject("Scripting.FileSystemObject")

Set folder = fso.GetFolder(picPath)



' Start inserting from row 1

row = 1



' Loop through each file in the folder

For Each file In folder.Files

' Check if the file is an image (you can add more extensions if needed)

If LCase(Right(file.Name, 4)) = ".jpg" Or LCase(Right(file.Name, 4)) = ".png" Then

' Insert the image

ActiveSheet.Pictures.Insert(file.Path).Select



' Resize the image

Selection.ShapeRange.LockAspectRatio = msoTrue

Selection.ShapeRange.Height = 50 ' Adjust this value to change thumbnail size



' Move the image to the correct cell

Selection.Top = ActiveSheet.Cells(row, 1).Top

Selection.Left = ActiveSheet.Cells(row, 1).Left



' Write the file name in the adjacent cell

ActiveSheet.Cells(row, 2).Value = file.Name



' Adjust row height

ActiveSheet.Rows(row).RowHeight = 55 ' Slightly larger than thumbnail height



' Move to the next row

row = row + 1

End If

Next file



' Clean up

Set file = Nothing

Set folder = Nothing

Set fso = Nothing

End Sub

 

[NdNoviceHlp]

What is the file extension of the file that errored? I trialed the posted code but on XL 2019 and it worked OK. I have a copy of XL 03 and can trial it needed. The other code is basically the same except it inserts the image as a link whereas when you use shapes .addpicture the picture is embedded in the sheet and travels with the wb. The second code also "sizes" the picture however picture sizing is relative to your screen resolution and personalization (zoom) settings so what you see on 1 pc may not be the same as another pc. Anyways, what was the file extension? Dave

 

[Paul B]

The error is “the specified file wasn’t found”
There are some PDF files in the folder also, took them out and it puts all the names in but only show a black square where the pictures should be

 

[NdNoviceHlp]

The "specified file wasn't found" is mysterious to me. The file path is made from the folder path and file name... "SFolder.Path & "\" & sFile.Name" it has to be there so the file name must be there. Maybe I'm missing something about XL 03. I'll trial this later on XL03 version if you haven't yet arrived at a solution. I'm on my way out for supper. Dave

 

[Paul B]

Thanks, I have not found a solution

 

[NdNoviceHlp]

It occurred to me at supper that maybe you have the funky remnants of files which produce a file path but don't actually exist. They are represented by a squiggly tilde symbol then a dollar sign followed by most of the file name that no longer exists. Anyways, this worked in my 2019 trial to remove those errant files from being listed. I'm guessing that XL 2003 doesn't like the tilde paths. If this doesn't work, I'll take some time tomorrow to further investigate. Dave

Sub InsertPictures()
Dim SFolder As Object, FSO As Object, Opic As Object
Dim sFile As Object, RngCnt As Integer
Dim ws As Worksheet

Const TILDE As String = "~"

Set ws = ActiveSheet ' or a specific sheet
Set FSO = CreateObject("Scripting.FileSystemObject")
'Where the pictures are. Change to suit
Set SFolder = FSO.GetFolder("C:\testfolder") 'Users\User\Pictures\")
For Each sFile In SFolder.Files
If Left(sFile.Name, 1) <> TILDE Then
RngCnt = RngCnt + 1
Set Opic = Application.ActiveSheet.Shapes.AddPicture(SFolder.Path & "\" & sFile.Name, False, True, 1, 1, 1, 1)
Opic.Left = ws.Range("A" & RngCnt).Left
Opic.Top = ws.Range("A" & RngCnt).Top
Opic.Width = ws.Range("A" & RngCnt).Width
Opic.Height = ws.Range("A" & RngCnt).Height
ws.Range("B" & RngCnt).Value = sFile.Name
End If
Next sFile
Set Opic = Nothing
Set SFolder = Nothing
Set FSO = Nothing
End Sub

 

[Paul B]

Found this online
If pictures in Excel 2003 are appearing as black boxes, it usually means there's a problem with the image file format or the way it's being inserted, potentially due to a mismatch between the image resolution and the Excel cell size, corrupted image files, or outdated drivers for your graphics card; to fix this, try resaving the images in a compatible format like JPEG, adjusting the cell size to fit the image, or updating your graphics card drivers.

I had and older computer so I tried the code on it and the pictures came in like they should so it must be something with my computer. Will have to look at that more. Thanks for you help on this.

 

[NdNoviceHlp]

Thanks for the update. Good luck with the resolution. Dave