Forum Discussion

brady's avatar
brady
Copper Contributor
May 01, 2018

VBA help for a Macro (inserting picture from file)

Hi,

 

I am new to VBA and macros and I was hoping that someone could help me writing the VBA to insert a photo from your personal files. I created the button, but I just need to write the VBA to pull up the users files so they can select the photo. From there I want the photo to be placed in the cell (you'll see on the sheet which cell I am referring to). The cells are already merged together. I want the photo to fit in the cell that is already merged. 

 

For some reason this forum won't let me upload a macro, so I am going to insert the excel file. You'll see where I want the photo's on the "FLYER V1" tab. 

 

Thanks! Let me know if you have any questions 

  • Matt Mickle's avatar
    Matt Mickle
    Bronze Contributor

    Brady-

     

    Please follow the below steps to accomplish your task:

     

    1. Open the Visual Basic Editor (VBE) using Alt + F11

    2. Insert > Module

    3. Paste the below code in the new code module

     

    Sub GetPic()
    Dim fNameAndPath As Variant
    Dim img As Picture
    fNameAndPath = Application.GetOpenFilename(Title:="Select Picture To Be Imported")
    If fNameAndPath = False Then Exit Sub
        Set img = ActiveSheet.Pictures.Insert(fNameAndPath)
        With img
           'Resize Picture to fit in the range....
           .Left = ActiveSheet.Range("D9").Left
           .Top = ActiveSheet.Range("D9").Top
           .Width = ActiveSheet.Range("D9:H9").Width
           .Height = ActiveSheet.Range("D9:D28").Height
           .Placement = 1
           .PrintObject = True
        End With
    End Sub
    

    4. Go back to the worksheet

    5. Right Click on the button > Assign Macro

    6. Select the GetPic Macro

     

    After following these steps you should get the expected result.

    • dklein_14's avatar
      dklein_14
      Copper Contributor

      That code worked perfectly, my question is I have 6 other locations to place the same image how can I do so for the other 6?

      • Matt Mickle's avatar
        Matt Mickle
        Bronze Contributor

        Hey dklein_14-

        Can you please tell me a few things for clarification?

        What are the 6 different ranges?  If the ranges are on different worksheets can you further clarify with worksheet names?

        -Matt

    • Tsengee's avatar
      Tsengee
      Copper Contributor

      Hello Matt Mickle 

      Can you help me on this Macro Please. I want to insert Picture but this Macro is not working in my MacBook maybe this Macro for PC computer. 

    • tghendrick's avatar
      tghendrick
      Copper Contributor

      Hey Matt Mickle 

       

      I'm having problems with this Macro for inserting photos. I copied it from a PC parallel to use on my Mac but it's keeps telling me the file doesn't exist. Can you help? 

      I uploaded a test file, the other one is a much larger file. 

       

      Sub InsertAnyPicture() Dim image As String Columns("A:B").Select Selection.Insert Shift:=xlToRight Range("A2").Select ActiveCell.FormulaR1C1 = _ "=CONCATENATE(""E:\Users\Tamara\Desktop\MIASTOCK INVENTORY\images\"",RC[2],"".jpeg"")" Application.Goto Reference:="OFFSET(R2C1,0,0,COUNTA(C3)-1,1)" Selection.FillDown Application.Goto Reference:="OFFSET(R2C1,0,0,COUNTA(C3)-1,1)" Set InputedRange = Range(Selection.Address) For Each C In InputedRange C.RowHeight = 45.5 image = C.Value If File_Exists(image) = True Then Call AddPic(image, C.Offset(0, 1)) Else C.Offset(0, 1).Value = "NO FILE" End If If C.Value = "" Then Exit Sub End If Next C Range("a1").Select Columns(1).EntireColumn.Delete End Sub Sub AddPic(sFile As String, r As Range) With r.Areas(1) ActiveSheet.Shapes.AddPicture FileName:=sFile, _ LinkToFile:=msoFalse, _ SaveWithDocument:=msoTrue, _ Top:=.Top, Left:=.Left, _ Height:=45, Width:=45 End With End Sub Private Function File_Exists(ByVal sPathName As String, Optional Directory As Boolean) As Boolean 'Returns True if the passed sPathName exist 'Otherwise returns False On Error Resume Next If sPathName <> "" Then If IsMissing(Directory) Or Directory = False Then File_Exists = (Dir$(sPathName) <> "") Else File_Exists = (Dir$(sPathName, vbDirectory) <> "") End If End If End Function

  • Matt Mickle's avatar
    Matt Mickle
    Bronze Contributor

    Brady-

     

    Just wanted to follow up and see if you were able to resolve your issue.  If you're still having trouble don't hesitate to reach back out and ask additional inquiries.  Always happy to help!

  • sumera1913's avatar
    sumera1913
    Copper Contributor

    brady 

     

    After using the VBA how to break the link from images. As the file is shared through email and images will goes off

    • Gstg72's avatar
      Gstg72
      Copper Contributor

      I'm having the same issue as far as the link being inserted, but not the picture. So It can't be shared or sent via email to customers. Any thoughts on how to change this from a link insert to a picture insert? 

       

      Thanks so much for your time

      • NikolinoDE's avatar
        NikolinoDE
        Gold Contributor

        Gstg72 

        To be honest, I asked where it is best to include such a VBA code.

        Most of them say with Outlook, not Excel.

        So I searched the internet and found this information.

         

        Folder selection when sending With this VBA code, any e-mail folder can be selected as storage when sending an e-mail. To use this example, please note the important information and the workshop Using VBA in Outlook.

        Please copy the 1st part of the code into a new module (insert -> module in the VBA editor):

         

         

        Option Explicit
         
        Public Function SentFolder (ByRef Item As Object) As Boolean
         
            '================================================== =====================
            '' Displays the Outlook® selection folder when sending an email
            'If required, e-mail to a folder other than "Sent Items"
            'to discard.
            '(c) http://www.outlook-stuff.com
            '2008-11-19 version 1.0.1
            '================================================= =====================
        
            Dim obj Folder As Object
         
            '------------------------------------------------- --------------------
            'Although the SaveSentMessageFolder-
            'property should also be possible for meeting requests
            'there is a mistake with these. Hence, prior to using this
            'Function asks whether the item is an email.
            '------------------------------------------------- --------------------
            If Not Item.Class = olMail Then Exit Function
         
            '------------------------------------------------- --------------------
            'The loop is run through until a valid folder is selected
            'or the selection is canceled.
            '------------------------------------------------- --------------------
            do
         
                '------------------------------------------------- ----------------
                'Show folder selection
                '------------------------------------------------- ----------------
                Set objFolder = Nothing
                Set objFolder = Outlook.Session.PickFolder
         
                '------------------------------------------------- ----------------
                'Has the selection been canceled?
                '------------------------------------------------- ----------------
                If objFolder Is Nothing Then
                    SentFolder = True
                    Exit function
                End If
         
                '------------------------------------------------- ----------------
                'Wrong folder type selected?
                '------------------------------------------------- ----------------
                If InStr (objFolder.DefaultMessageClass, "IPM.Note") = 0 Then
                    Set objFolder = Nothing
                    If MsgBox ("Please select a folder for emails." _
                        , vbCritical + vbOKCancel, "Select shelf") = vbCancel Then
                        SentFolder = True
                        Exit function
                    End If
                End If
         
                '------------------------------------------------- ----------------
                'The inbox is not suitable as a shelf
                '------------------------------------------------- ----------------
                If Not objFolder Is Nothing Then
                    If objFolder = Outlook.Session.GetDefaultFolder (olFolderInbox) Then
                        If MsgBox ("Are you sure you want to put the sent email in the inbox?" _
                            , vbExclamation + vbYesNo + vbDefaultButton2, "Select storage") = vbNo Then
                            Set objFolder = Nothing
                        End If
                    End If
                End If
         
            Loop While objFolder Is Nothing
         
            '------------------------------------------------- --------------------
            'Define the storage location of the email
            '------------------------------------------------- --------------------
            Set Item.SaveSentMessageFolder = objFolder
         
            '------------------------------------------------- --------------------
            'Delete reference to folder
            '------------------------------------------------- --------------------
            Set objFolder = Nothing
         
        End function
        
        'source: https://www.outlook-stuff.com/tipps-tricks/programmierung/287-ordnerauswahl-'beim-senden.html

         

         

        The call is made from the Application_ItemSend event in the module ThisOutlookSession. Please copy the 2nd part of the code here:

         

         

        Übersetzungstypen
        Textübersetzung
        Ausgangstext
        908 / 5000
        Übersetzungsergebnisse
        Private Sub Application_ItemSend (ByVal Item As Object, Cancel As Boolean)
         
             '================================================= =====================
             'This procedure is recorded immediately before an email is sent.
             ' call. If "Cancel" is true, the sending of the e-mail is canceled.
             '(c) http://www.outlook-stuff.com
             '2008-11-19 version 1.0.1
             '================================================== =====================
               
             '------------------------------------------------- --------------------
             'Show folder selection for storing the sent mail
             '------------------------------------------------- --------------------
             Cancel = SentFolder (Item)
         
             '------------------------------------------------- --------------------
             'Delete reference to email
             '------------------------------------------------- --------------------
             Set Item = Nothing
         
        End Sub

         

         

         At the beginning I would not have thought that it could be so difficult.

        In retrospect, however, I understand watum it's so hard.

        It's not about Excel, it's about Outlook.

        It doesn't really matter whether I send an Excel file or another file as an e-mail.

        -------------------

        Supplement:

        (Step by step)

         

        Outlook, start the VBA editor successfully.

         

        I add Code 1 via "Insert / Module". In the drop-down menus in the pop-up window, (“Selection”), (“Declarations”) remains.

         

        The left is now under Project1 (VbaProject.OTM)

        - Microsoft Outlook objects

        - ThisOutlookSession

        - modules

        - Module 1

         

        If I now double-click “ThisOutlookSession”, a window opens again, the drop-down menu says “Application” on the left and “ItemSend” on the right.

        I copy code 2 into the free field.

         

        I save everything (without renaming anything), go back to Outlook, restart Outlook.

         

        When I write an email now, I get various error messages:

        First runtime error for "AddinTools Classic Menu for Outlook".

        Then the VBA editor opens again, module 1 is marked on the left and the pop-up window reads:

        "Error during compilation, invalid outside of a procedure, module 1 marked".

        If I click away, I quit the debugger.

        Don't forget to reactivate the macros.

        ----------------------------------------------

        I hope that you will get a little further with it.

         

        Thank you for your understanding and patience

         

        Nikolino

        I know I don't know anything (Socrates)

  • NikolinoDE's avatar
    NikolinoDE
    Gold Contributor

    brady 

     

    Look the File please

    If it helped, I am very happy ... please mark this as the correct answer so that others are informed. If not, please give a short feedback, maybe the other helpers could help more than me.

     

    Nikolino

    I know I don't know anything (Socrates)

  • NikolinoDE's avatar
    NikolinoDE
    Gold Contributor

    brady 

     

    Here is a very simple solution that also works ... has been tested.

    Open the file and enable all macros and content, then click the "Insert Photo" button.

    An explorer appears where you can search for and select your picture and confirm with OK.

    Then a window will appear asking you to click on the start cell where the photo should be inserted. Click on the start cell and the picture is where you want it to be.

     

    I would be happy to know if I could help.

     

    Nikolino

    I know I don't know anything (Socrates)

     

    * Kindly Mark and Vote this reply if it helps please, as it will be beneficial to more Community members reading here.

  • kadirguler's avatar
    kadirguler
    Copper Contributor

    brady 

    Hi,

    First of all I recommend that the pictures are in the same folder as the workbook.
    Next you need to enter some codes in the Worksheet_Change procedure of the worksheet. For example, we can enter the following codes to add the image that with the same name as the value of cell in column A to the cell in column :

    Private Sub Worksheet_Change(ByVal Target As Range)
    Dim pic As Picture
    If Intersect(Target, [A:A]) Is Nothing Then Exit Sub
    On Error GoTo son
    
    For Each pic In ActiveSheet.Pictures
        If Not Application.Intersect(pic.TopLeftCell, Range(Target.Offset(0, 3).Address)) Is Nothing Then
            pic.Delete
        End If
    Next pic
    
    ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & Target.Value & ".jpg").Select
    Selection.Top = Target.Offset(0, 2).Top
    Selection.Left = Target.Offset(0, 3).Left
    Selection.ShapeRange.LockAspectRatio = msoFalse
    Selection.ShapeRange.Height = Target.Offset(0, 2).Height
    Selection.ShapeRange.Width = Target.Offset(0, 3).Width
    son:
    
    End Sub

     

    The picture is sized according to the cell that it is added to.

    Details and sample files here

     

    • Darkman's avatar
      Darkman
      Copper Contributor
      Dear Sirs I have been trying without success to create a VBA or macro to automatically take a folder address of pictures and then match it ascending down from the pic name i.e hf-001.jpg by using the cell ref within the other cell say i.e hf-001 descending down to last populated cell is this possible as all I have managed to do is get 1 picture to populate 1 cell sorry if a big ask as a beginner in all this but trying my best to do as much on my own for a small charity.
  • Full_Moon's avatar
    Full_Moon
    Copper Contributor
    Hii,

    I want a code of "Insert multiple Images on Multiple worksheets automatically" give path and run.
    I don't want to choose path.

    Please share

Resources