Macro: Add image to Excel


New Member
Jan 7, 2014
Hi All,

I have the following issue that i cant seem to solve.

I have got a Macro that important JPEG images with an unique name (style code) to a field in Excel with the same unique name.
However this Macro only works with JPEG images, now the issue is that all the images have been changed to PNG and I'm not able to run the macro anymore.

Can anyone help me out to get the macro working again?

Thanks a lot, I really appreciate it.


Attribute VB_Name = "InsertImageBasedonStyleName"

Option Explicit

' rkratt 8 Juni 2010
' select cells with style colorway

Sub Insert_Image_Based_on_StyleName()
Dim cCell As Range
   Dim cDest As Range
   Dim rngSelection As Range
   Dim strHLink As String
   Dim cComment As Comment
   Dim strPicFileName As String
   Dim VarBrwFldr As String
   Dim FileNameWithPath As Variant
    Dim ListOfFilenamesWithParh As New Collection ' create a collection of filenames

   On Error GoTo Err1:

Sheets("Price overview").Select

   VarBrwFldr = BrowseForFolder
    'if browse for folder was canceled quit
    If VarBrwFldr = "" Then Exit Sub
 'builds a list of all files in the folder including sub folders
Call FileSearchByHavrda(ListOfFilenamesWithParh, VarBrwFldr, "*.jpg", True)

   'will look at every cell that is selected. will give an error if any #N/A cells are selected but blanks are okay.
   For Each cCell In Selection

      With cCell
         Set cDest = .Offset(ColumnOffset:=0)
         On Error Resume Next
        If .Value = "" Then GoTo lastline
        'only works with jpg, would need adjustment to work with other image file.
            'strHLink = VarBrwFldr & "\" & .Value & ".jpg"
   'loop list of file names from Havrda sub
   For Each FileNameWithPath In ListOfFilenamesWithParh
        If (InStr(FileNameWithPath, .Value) > 0) Then
         strHLink = FileNameWithPath
         If strHLink <> "" Then
            'Build a picture shape
             strPicFileName = "pic_" & cCell.Row & cCell.Column
            If InsertPicFromFile( _
                  strFileLoc:=strHLink, _
                  rDestCells:=cDest, _
                  blnFitInDestHeight:=True, _
                  strPicName:=strPicFileName) _
                  = True Then
               With ActiveSheet.Shapes(strPicFileName)
'logic decides if it should base picture ratio on cell height or width
        .LockAspectRatio = msoTrue
        If .Width > .Height Then
            .Width = cDest.Width * 0.8
            If .Height > cDest.Height * 0.8 Then .Height = cDest.Height * 0.8
            .Height = cDest.Height * 0.8
           If .Width > cDest.Width * 0.8 Then .Width = cDest.Width * 0.8
        End If
    End With
           'gets rid of memory to start next cell
            End If
         End If
        End If
        Next FileNameWithPath
      End With
   Next cCell
    Exit Sub
    MsgBox "Folder was not valid"
    Resume Err1Exit
End Sub
Private Sub FileSearchByHavrda(pFoundFiles As Collection, pPath As String, pMask As String, pIncludeSubdirectories As Boolean)
' Search files in Path and create FoundFiles list(collection) of file names(path included) accordant with Mask (search in subdirectories if enabled)
' 01.06.2009, Author: P. Havrda, Czech Republic

Dim DirFile As String
Dim CollectionItem As Variant
Dim SubDirCollection As New Collection

' Add backslash at the end of path if not present
pPath = Trim(pPath)
If Right(pPath, 1) <> "\" Then pPath = pPath & "\"

' Searching files accordant with mask
DirFile = Dir(pPath & pMask)
Do While DirFile <> ""
pFoundFiles.Add pPath & DirFile 'add file name to list(collection)
DirFile = Dir ' next file

' Procedure exiting if searching in subdirectories isn't enabled
If Not pIncludeSubdirectories Then Exit Sub

' Searching for subdirectories in path
DirFile = Dir(pPath & "*", vbDirectory)
Do While DirFile <> ""
' Add subdirectory to local list(collection) of subdirectories in path
If DirFile <> "." And DirFile <> ".." Then If ((GetAttr(pPath & DirFile) And vbDirectory) = 16) Then SubDirCollection.Add pPath & DirFile
DirFile = Dir 'next file

' Subdirectories list(collection) processing
For Each CollectionItem In SubDirCollection
Call FileSearchByHavrda(pFoundFiles, CStr(CollectionItem), pMask, pIncludeSubdirectories) ' Recursive procedure call

End Sub

'* InserPicFromFile

Function InsertPicFromFile( _
   strFileLoc As String, _
   rDestCells As Range, _
   blnFitInDestHeight As Boolean, _
   strPicName As String) As Boolean
         Dim Pic As IPictureDisp
      Const ScaleChange As Double = (635 / 24)
   Dim oNewPic As Shape
   Dim shtWS As Worksheet
   Dim tmpWidth As Integer
   Dim tmpHeight As Integer

   Set shtWS = rDestCells.Parent

   On Error Resume Next
   'Delete the named picture (if it already exists)
   On Error GoTo Finish
   With rDestCells

   'uses the picture ratio to build the virtual rectangle (see below)
            Set Pic = LoadPicture(strFileLoc)
         tmpWidth = 0.4 * (Pic.Width / ScaleChange)
         tmpHeight = 0.4 * (Pic.Height / ScaleChange)
      'Create the new picture
      '(virtual rectangle that is the height and width of image to import. the with and top refer to cDest Cell)
      Set oNewPic = shtWS.Shapes.AddPicture( _
         Filename:=strFileLoc, _
         LinkToFile:=msoFalse, _
         SaveWithDocument:=msoTrue, _
         Left:=.Left + (.Width * 0.1), Top:=.Top + (.Height * 0.05), Width:=tmpWidth, Height:=tmpHeight)

      'Maintain original aspect ratio and set to full size
      oNewPic.LockAspectRatio = msoTrue
      oNewPic.ScaleHeight Factor:=1, RelativeToOriginalSize:=msoTrue
      oNewPic.ScaleWidth Factor:=1, RelativeToOriginalSize:=msoTrue
      If blnFitInDestHeight = True Then
         'Resize the picture to fit in the destination cells
         oNewPic.Height = .Height - 1
      End If
      'Assign the desired name to the picture
      oNewPic.Name = strPicName
   End With 'rCellDest
   If Err.Number <> 0 Then
      InsertPicFromFile = False
      rDestCells.Cells(1, 1).Value = rDestCells.Cells(1, 1).Value
      InsertPicFromFile = True
'      rDestCells.Cells(1, 1).Value = rDestCells.Cells(1, 1).Value
   End If
End Function

Function BrowseForFolder(Optional OpenAt As Variant) As Variant
    '''Code from kpuls, of Knowledge base submission
  Dim ShellApp As Object
  Set ShellApp = CreateObject("Shell.Application"). _
    BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
    On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
    On Error GoTo 0
    Set ShellApp = Nothing
    Select Case Mid(BrowseForFolder, 2, 1)
        Case Is = ":"
            If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
        Case Is = "\"
            If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
        Case Else
            GoTo Invalid
        End Select
    Exit Function

End Function

Sub TlBarOpen()
Dim msg As String
Dim Ans As String

'I added a message to allow a cancel in case macro selected by mistake.
    msg = "File should be saved on computer before adding toolbar!!!" & vbCrLf
    msg = msg + "A folder under My Documents in C Drive is best (do not use network drive)." & vbCrLf & vbCrLf
    msg = msg + "Continue with adding buttons to toolbar?"
    Ans = MsgBox(msg, vbYesNo)
    Select Case Ans
    Case vbNo
        GoTo Canceled
    Case vbYes
        GoTo KeepGoing
    End Select
    'Application.Iteration = True
    'Set Toolbar options
    With Application
        .ShowToolTips = True
        .LargeButtons = False
        .ColorButtons = True
    End With
    On Error Resume Next
    'If the "ProductCodeImages" toolsbar already exists Then delete the "Add Images" toolbar
    'Add a new toolbar "ProductCodeImages"
    Toolbars.Add Name:="ProductCodeImages"
    On Error GoTo 0
    'Set the "Add Images" toolbar optoins
    With Toolbars("ProductCodeImages")
        .Visible = True
        .Position = xlFloating
        .Left = 600
        .Top = 24
        .Width = 145
        'Add all buttons to the "ProductCodeImages" toolbar
        .ToolbarButtons.Add Button:=231
        .ToolbarButtons(1).OnAction = "Insert_Image_Based_on_StyleName"
        ThisWorkbook.Worksheets("Buttons").DrawingObjects("Picture 1").Copy
        .ToolbarButtons(1).Name = "InsertImages"
        'Add all buttons to the "ProductCodeImages" toolbar
        .ToolbarButtons.Add Button:=231
        .ToolbarButtons(2).OnAction = "DeleteSelectedPics"
        ThisWorkbook.Worksheets("Buttons").DrawingObjects("Picture 2").Copy
        .ToolbarButtons(2).Name = "DeleteSelectedImages"

       ' Add a gap between buttons
        .ToolbarButtons.Add Button:=0, before:=2
    End With
    'error handle
End Sub

Sub TlBarClose()
    On Error Resume Next
    On Error GoTo 0
End Sub
   Sub DeleteSelectedPics()
'This sub makes it possible to delete pictures within a given range.
'all pictures in selected area are deleted.
'other image types remain

Sheets("Price overview").Select

Dim Sh As Shape
Dim Rng As Range
Dim ThisSheet As Worksheet

'rename current sheet so it can later be used as a variable
Set ThisSheet = ActiveSheet
'rename selection so it can later be used as a variable
Set Rng = Selection

With ThisSheet
   For Each Sh In .Shapes
        'intersect command defines area for macro to perform task
'       If Not Application.Intersect(Sh.TopLeftCell, Rng) Is Nothing Then
         If Sh.Type = msoPicture Then Sh.Delete
'       End If
    Next Sh
End With
End Sub

Excel Facts

What is the fastest way to copy a formula?
If A2:A50000 contain data. Enter a formula in B2. Select B2. Double-click the Fill Handle and Excel will shoot the formula down to B50000.


Well-known Member
May 24, 2005
Apparently the LoadPicture function cannot load .PNG files. This chain of posts:
Images on Custom Ribbon controls in Excel 2007-2013
provided an alternate.

In Module1 of your workbook use search and replace (Current Module) to change .jpg to .png (2 instances).
In Module1 of your workbook use search and replace (Current Module) to change "Set Pic = LoadPicture(strFileLoc)" to "Set Pic = LoadPictureGDI(strFileLoc)"
Download the "Download the example workbooks and images" file from the last link above. Unzip and open the Toggle Button 2.xlsm file and copy the MLoadPictureGDI module to your workbook.

Forum statistics

Latest member
Muhammad Tanzeel Ur Rehma

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
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 "".
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