How to insert pictures into Excel automatically ?

[Metaldigger]

Hi - I'm trying to find a way to automatically insert and resize a picture (all saved in a specific drive)in a specific cell on a spreadsheet. s/sheet is layed out with various bits of data in rows 2 to 12 and an empty cell in row 1 (repeated in every column up to H then starting again underneath with empty cell row 13, then data 14 - 24 until data runs out). I need to automatically find the picture relating to the information in row 3 on my sheet. ie. the picture will be saved under the same name as the data stored in row 3 in a specific location. was thinking of using a macro but I'm not sure how i could get it to work. Any ideas? Sorry if this is not clear!

[Expertz]

Please refer to the following article :-

http://www.contextures.com/xlcomments02.html#Picture

That's adding photographs on to the Comments of worksheet cells.

[Gusgr8]

The easiest why to create a macro is to record it, and see how they did it.

What I would have done 4 your prob is to create a constant 4 the path (guess you knew that): dim sPath = "c:\whatever\"

I'll then loop through the cells until it finds a blank:

dim i = 1
dim sFileName
dim bContinue = true
while bContinue
  sFileName = worksheets(1).cells(i,1).value
  'worksheets is the number of the sheeg, e.g. sheet1 = 1 sheet 2 = 2 etc.
  'cells is the cell, the first parameter the row, the second the column
  if sFileName = "" then
    bContinue = false
  else
    cells(i,2).select 'select the cell where it should be inserted
    ActiveSheet.Pictures.Insert(sPath & sFilName).Select 'inserts picture and select it
    Selection.ShapeRange.ScaleWidth 0.47, msoFalse, msoScaleFromTopLeft 
    Selection.ShapeRange.ScaleHeight 0.47, msoFalse, msoScaleFromTopLeft
     i = i + 1
  end if
wend

Sorry, this is from the top of my head (didn't test it), so there might be errors.

Play around with recording macro's, and the help file is quite usefull (when you learn how to use it). Macro's are the easiest thing to write once you know how.

[JAMES_911]

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.

[modrus]

Hi guys,

I searched the web for a function to automatic insert and size the picture.
I have found this code

Sub InsertPictureInRange(PictureFileName As String, TargetCells As Range)
' inserts a picture and resizes it to fit the TargetCells range
Dim p As Object, t As Double, l As Double, w As Double, h As Double
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
If Dir(PictureFileName) = "" Then Exit Sub
Set p = ActiveSheet.Pictures.Insert(PictureFileName)

With TargetCells
t = .Top + ((.Columns.Count - 1) * 37.5)
l = .Left
w = .Offset(0, .Columns.Count).Left - .Left
h = .Offset(.Rows.Count, 0).Top - .Top
Top = .Top
MsgBox ("t = " & t & vbCrLf & "top = " & Top)
End With
' position picture
With p
.Top = t
.Left = l + 2
'.Width = w - 2
'.Height = h - 2
'.Placement = xlMoveAndSize
.ShapeRange.ScaleWidth 0.32, msoFalse, msoScaleFromTopLeft
.ShapeRange.ScaleHeight 0.32, msoFalse, msoScaleFromTopLeft

End With

Set p = Nothing

End Sub
'Placement = xlMoveAndSize


Wich works pretty well besides the fact that as i go down in Line the picture gets more and more out of the cell.

I tried to solve it adjusting the .top but it isnt working.

Anyone can help?

[Mecurtis]

Hi,

Try this code :

Sub TestInsertPicture()
    InsertPicture "C:\FolderName\PictureFileName.gif", _
        Range("D10"), True, True
End Sub

Sub InsertPicture(PictureFileName As String, TargetCell As Range, _
    CenterH As Boolean, CenterV As Boolean)
' inserts a picture at the top left position of TargetCell
' the picture can be centered horizontally and/or vertically
Dim p As Object, t As Double, l As Double, w As Double, h As Double
    If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
    If Dir(PictureFileName) = "" Then Exit Sub
    ' import picture
    Set p = ActiveSheet.Pictures.Insert(PictureFileName)
    ' determine positions
    With TargetCell
        t = .Top
        l = .Left
        If CenterH Then
            w = .Offset(0, 1).Left - .Left
            l = l + w / 2 - p.Width / 2
            If l < 1 Then l = 1
        End If
        If CenterV Then
            h = .Offset(1, 0).Top - .Top
            t = t + h / 2 - p.Height / 2
            If t < 1 Then t = 1
        End If
    End With
    ' position picture
    With p
        .Top = t
        .Left = l
    End With
    Set p = Nothing
End Sub

[modrus]

Hi,
thanks for the reply but i have already tried that code to.
Yesterday i decided to test my code on another worksheet and it works perfectly! The problem seems to be the format of the worksheet. But i need to maintain that format because it's for printing.
The same situation happens if u zoom, at 100% the pictures are inserted in the right spot (normal worksheet) and with zoom they don't.
Anyone has a clue how to counter that?

Thanks in advance

[xyz2xyz]

This code works in Excel 2007:

	Dim imgIcon
	With Range("A1")
	    Set imgIcon = ActiveSheet.Shapes.AddPicture(Filename:="C:\mypicture.jpg", LinkToFile:=False, SaveWithDocument:=True, Left:=.Left, Top:=.Top, Width:=30, Height:=30)
	End With
	Set imgIcon = Nothing

ALSO SEE THE USEFUL LINKS BELOW:

• Shapes.AddPicture Method