Inserting Pictures Automatically

Mattrixdesign

Board Regular
Joined
Mar 6, 2002
Messages
201
Is there any way I can get XL to look in a folder of JPGs and insert and resize each picture in a new cell? Also is there any way it could place the file name for each picture underneath each cell?

I'm sure I have seen this done in a sort of mini picutre album.

Please help.

Cheers

Matt :wink:
 

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.
Hi Mattrixdesign,

Add a new module into the workbook then paste the code below in this module:



Private Declare Function FindNextFile Lib "kernel32.dll" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindFirstFile Lib "kernel32.dll" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32.dll" (ByVal hFindFile As Long) As Long
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * 260
cAlternate As String * 14
End Type

Private Sub FindFiles()
'Modified code : Reference http://www.vbapi.com
Dim hsearch As Long
Dim findinfo As WIN32_FIND_DATA
Dim success As Long
Dim buffer As String
Dim retval As Long

Dim fileinfo As String 'User defined

'I used gifs in windows directory
fileinfo = "C:Windows*.gif"

hsearch = FindFirstFile(fileinfo, findinfo)
If hsearch = -1 Then
Exit Sub
End If
Do
buffer = Left(findinfo.cFileName, InStr(findinfo.cFileName, vbNullChar) - 1)
ActiveSheet.Pictures.Insert("C:Windows" & buffer).Select
Selection.Left = 0
If ActiveSheet.Pictures.Count = 1 Then
Selection.Top = 0
Else
Selection.Top = ActiveSheet.Pictures(ActiveSheet.Pictures.Count - 1).Height + ActiveSheet.Pictures(ActiveSheet.Pictures.Count - 1).Top
End If
success = FindNextFile(hsearch, findinfo)
Loop Until success = 0
retval = FindClose(hsearch)
End Sub

Code locates pictures up to down in sheet. I dont know how you want to resize cells or all pictures are in same size? Please ask for more if you need.
 
Upvote 0
Her is another option for you just to
add to Oz good code except no API's

Running it gives the option to select where
the Picture files are and what one to load in

Avail Picture formats are;
(*.bmp)(*.tif)(*.jpg) but you can change this

select cell to paste to.

The prgm current resizes the pict....play
around with the settings to get what you want


Ivan

Sub Insert_Pict()
Dim oPict, PictObj
Dim sImgFileFormat As String
Dim rPictCell As Range
Dim iAns As Integer

sImgFileFormat = "jpg Files (*.jpg), *.jpg, bmp (*.bmp),*.bmp,tif (*.tif),*tif"

GetPict:
oPict = Application.GetOpenFilename(sImgFileFormat)
'Note you can load in any nearly file format
If oPict = False Then End

iAns = MsgBox("Open : " & oPict, vbYesNo, "Insert Picture")
If iAns = vbNo Then GoTo GetPict

'Now paste to UserSelected Cell
GetCell:
Set rPictCell = Application.InputBox("Select the cell to insert into", Type:=8)
If rPictCell.Count > 1 Then MsgBox "Select ONE cell only": GoTo GetCell

rPictCell.Select
Set PictObj = ActiveSheet.Pictures.Insert(oPict)
rPictCell.Offset(-1, 0) = oPict

With PictObj
.ShapeRange.LockAspectRatio = msoTrue
.ShapeRange.Height = 57#
.ShapeRange.Width = 57#
End With

Set PictObj = Nothing
Set rPictCell = Nothing

End Sub
 
Upvote 0

Forum statistics

Threads
1,213,543
Messages
6,114,236
Members
448,555
Latest member
RobertJones1986

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top