Macro: Add image to Excel

Kevin85

New Member
Joined
Jan 7, 2014
Messages
1
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.

Regards,
Kevin

Code:
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
Range("F9:OV1210").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
        Else
            .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
        
               cCell.Hyperlinks.Delete
            End If
         End If
        End If
        Next FileNameWithPath
lastline:
      End With
   Next cCell
   
Err1Exit:
    Exit Sub
Err1:
    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
Loop


' 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
Loop


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


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)
   shtWS.Shapes(strPicName).Delete
   
   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
   
Finish:
   If Err.Number <> 0 Then
      InsertPicFromFile = False
      rDestCells.Cells(1, 1).Value = rDestCells.Cells(1, 1).Value
   Else
      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, www.VBAExpress.com..portion 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


Invalid:
   
    
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
    
KeepGoing:
    
    '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
    Toolbars("ProductCodeImages").Delete
    '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).PasteFace
        .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).PasteFace
        .ToolbarButtons(2).Name = "DeleteSelectedImages"
        


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




Sub TlBarClose()
    On Error Resume Next
    Toolbars("ProductCodeImages").Delete
    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
Range("F9:OV1210").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

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest

pbornemeier

Well-known Member
Joined
May 24, 2005
Messages
3,890
Apparently the LoadPicture function cannot load .PNG files. This chain of posts:
http://www.mrexcel.com/forum/excel-questions/691847-using-png-images-userform.html
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

Threads
1,137,298
Messages
5,680,678
Members
419,924
Latest member
Dhamodharan992

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
Top