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]

Just had another thought, trial changing your default printer and/or updating your printer driver. I think older versions of XL (maybe new ones too??) used the printer somehow for graphics. Just a possibility. Dave

 

[Paul B]

After some testing with more pictures the pictures I had in the folder to start with all had red backgrounds and they came in as black boxes, not sure why, but all the other pictures I put in the folder did ok.

The folder I am using will have some PDF files in it also and I am still getting the error
“The specified file wasn’t found” and when I click debug the line below is highlighted but all the pictures and file names are put in the sheet?
Set Opic = Application.ActiveSheet.Shapes.AddPicture(SFolder.Path & "\" & sFile.Name, False, True, 1, 1, 1, 1)

Is there anyway to just have it list just the .jpg files in the folder or some other way to keep the error out?

I found this code online to resize all the pictures to fit the cell, is there anyway to use that in your code, right now I am just running it after yours to fit the picture to the cell.

Sub ResizePicturesToFillCells()

Dim shp As Shape

Dim cel As Range

For Each shp In ActiveSheet.Shapes

If shp.Type = msoPicture Then

Set cel = shp.TopLeftCell

shp.LockAspectRatio = msoFalse

shp.Height = cel.Height

shp.Width = cel.Width

End If

Next shp

End Sub

Thanks

 

[NdNoviceHlp]

The code posted should fit the pics to the cells but I added the lockaspect ratio bit to the following. This code will only show jpg pics. 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

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 And LCase(Right(sFile.Name, 3)) = "jpg" Then
RngCnt = RngCnt + 1
Set Opic = Application.ActiveSheet.Shapes.AddPicture(SFolder.Path & "\" & sFile.Name, False, True, 1, 1, 1, 1)
Opic.LockAspectRatio = msoFalse
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]

Thank you very much, it is working great!

 

[NdNoviceHlp]

You are welcome. Glad you got it sorted out. Thanks for posting your outcome. Dave