Inserting Pictures Automatically

[Mattrixdesign]

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

[smozgur]

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.

[Ivan F Moala]

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