Excel Picture Inserting Macro Help - Urgent [Solved/Closed]

nadimn 3 Posts Tuesday April 27, 2010Registration date April 28, 2010 Last seen - Apr 27, 2010 at 04:34 PM - Latest reply:  jackcluseau
- Dec 4, 2014 at 11:26 PM
Dear Rizvisa,

please consider this little urgent and be kind to help me please

I m trying to insert picture in excel column using macro which takes the file name refrence from the B2 cell and insert picture in A2 cell.
for example: if B2 cell is N235 then the picture which will be inserted in A2 would be N235.jpg from the given path in Macro. This is working fine EXCEPT when there is no picture in the folder with the the same name as in folder.
I get a runtime error 1004 and Macro stops and can not fill picture after that cell.
I m using following Macro.
----------------------------------------------------------------------------------------------------------------
Sub Picture()
Dim picname As String

Dim pasteAt As Integer
Dim lThisRow As Long

lThisRow = 2

Do While (Cells(lThisRow, 2) <> "")


pasteAt = lThisRow
Cells(pasteAt, 1).Select 'This is where picture will be inserted


picname = Cells(lThisRow, 2) 'This is the picture name

ActiveSheet.Pictures.Insert("C:\Users\Administrator\Desktop\LC\" & picname & ".jpg").Select 'Path to where pictures are stored
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
' This resizes the picture
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
With Selection
'.Left = Range("A6").Left
'.Top = Range("A6").Top
.Left = Cells(pasteAt, 1).Left
.Top = Cells(pasteAt, 1).Top

.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 100#
.ShapeRange.Width = 130#
.ShapeRange.Rotation = 0#
End With

lThisRow = lThisRow + 1

Loop

Range("A10").Select
Application.ScreenUpdating = True

Exit Sub

ErrNoPhoto:
MsgBox "Unable to Find Photo" 'Shows message box if picture not found
Exit Sub
Range("B20").Select

End Sub
----------------------------------------------------------------------------------------------------------------

Could you please help me in solving this problem. I want it like this, if there is no picture with the same name then "no picture found" should be displayed in the cell. or any dummy picture in all those cell where there is no picture in the folder with the same name as in the cell.

for example: if in B5 value is Z028 and if the picture Z028.jpg is not there in my LC folder (as given above in macro) then it should show "no picture found" and continue adding all other pictures till end.

I would be grateful to you.

Thanks in advance
See more 

25 replies

Best answer
rizvisa1 4481 Posts Thursday January 28, 2010Registration dateContributorStatus January 6, 2016 Last seen - Apr 27, 2010 at 10:15 PM
5
Thank you
Try this. New lines are highlighted



Sub Picture() 
Dim picname As String 

Dim pasteAt As Integer 
Dim lThisRow As Long 

    lThisRow = 2 
     
    Do While (Cells(lThisRow, 2) <> "") 
     
     
        pasteAt = lThisRow 
        Cells(pasteAt, 1).Select 'This is where picture will be inserted 
         
         
        picname = Cells(lThisRow, 2) 'This is the picture name 
         
        present = Dir("C:\Users\Administrator\Desktop\LC\" & picname & ".jpg") 
         
        If present <> "" Then 
             
            ActiveSheet.Pictures.Insert("C:\Users\Administrator\Desktop\LC\" & picname & ".jpg").Select 'Path to where pictures are stored 
            ''''''''''''''''''''''''''''''''''''''''''''''''''''''' 
            ' This resizes the picture 
            ''''''''''''''''''''''''''''''''''''''''''''''''''''''' 
            With Selection 
            '.Left = Range("A6").Left 
            '.Top = Range("A6").Top 
            .Left = Cells(pasteAt, 1).Left 
            .Top = Cells(pasteAt, 1).Top 
             
            .ShapeRange.LockAspectRatio = msoFalse 
            .ShapeRange.Height = 100# 
            .ShapeRange.Width = 130# 
            .ShapeRange.Rotation = 0# 
            End With 
         
 

        Else 
            Cells(pasteAt, 1) = "No Picture Found" 
        End If 
         
           lThisRow = lThisRow + 1 
    Loop 
     
    Range("A10").Select 
    Application.ScreenUpdating = True 
     
    Exit Sub 
     
ErrNoPhoto: 
    MsgBox "Unable to Find Photo" 'Shows message box if picture not found 
    Exit Sub 
    Range("B20").Select 

End Sub

Thank you, rizvisa1 5

Something to say? Add comment

CCM has helped 1797 users this month

Hi rizvisa1,

I have a macro to insert image from a folder to an outlook email. I want to know if it is feasible to add a loop to pick up image one by one everyday and the same picture is not picked up by the macro next day when the macro is run to sent the outlook mail with an image; also if possible to add the picture from the folder to the excel tab sheet with a name and path in the next column where the picture is inserted:

Here is the code I am using however it picks up only one picture as I am not so good in excel vba:

Sub EmbeddedHTMLGraphicDemo()
' Outlook objects
Dim objApp as Outlook.Application
Dim l_Msg As MailItem
Dim colAttach As Outlook.Attachments
Dim l_Attach As Outlook.Attachment
Dim oSession As MAPI.Session
' CDO objects
Dim oMsg As MAPI.Message
Dim oAttachs As MAPI.Attachments
Dim oAttach As MAPI.Attachment
Dim colFields As MAPI.Fields
Dim oField As MAPI.Field

Dim strEntryID As String

' create new Outlook MailItem
Set objApp = CreateObject("Outlook.Application")
Set l_Msg = objApp.CreateItem(olMailItem)
' add graphic as attachment to Outlook message
' change path to graphic as needed
Set colAttach = l_Msg.Attachments
Set l_Attach = colAttach.Add("c:\test\graphic.jpg")
l_Msg.Close olSave
strEntryID = l_Msg.EntryID
Set l_Msg = Nothing
' *** POSITION CRITICAL *** you must dereference the
' attachment objects before changing their properties
' via CDO
Set colAttach = Nothing
Set l_Attach = Nothing

' initialize CDO session
On Error Resume Next
Set oSession = CreateObject("MAPI.Session")
oSession.Logon "", "", False, False

' get the message created earlier
Set oMsg = oSession.GetMessage(strEntryID)
' set properties of the attached graphic that make
' it embedded and give it an ID for use in an <IMG> tag
Set oAttachs = oMsg.Attachments
Set oAttach = oAttachs.Item(1)
Set colFields = oAttach.Fields
Set oField = colFields.Add(CdoPR_ATTACH_MIME_TAG, "image/jpeg")
Set oField = colFields.Add(&H3712001E, "myident")
oMsg.Fields.Add "{0820060000000000C000000000000046}0x8514", 11, True
oMsg.Update

' get the Outlook MailItem again
Set l_Msg = objApp.GetNamespace("MAPI").GetItemFromID(strEntryID)
' add HTML content -- the <IMG> tag
l_Msg.HTMLBody = "<IMG align=baseline border=0 hspace=0 src=cid:myident>"
l_Msg.Close (olSave)
l_Msg.Display

' clean up objects
Set oField = Nothing
Set colFields = Nothing
Set oMsg = Nothing
oSession.Logoff
Set oSession = Nothing
Set objApp = Nothing
Set l_Msg = Nothing
End Sub
rizvisa1 4481 Posts Thursday January 28, 2010Registration dateContributorStatus January 6, 2016 Last seen - Dec 2, 2014 at 06:09 AM
If for a given day you want to send same image for every email, then I think you need a hack. One hack could be

1. One folder that has all your images that are not yet used.
2. One folder that has all your images that have been used.
3. One folder that has image to be used for today saved in YYYYMMDD format to check for date

Code check in #3 if the file name and today's date match. If yes then use that image. end of story.

If they dont match, then pick at random an image from #1, and move it to #2. At the same time copy the same image in #3 as YYYYMMDD.

Every day the images available in #1 get reduced to a point where there is none left. In that case, rename #1 as #2 and #2 as #1 (or move images back to original spot)
Hi rizvisa1,

I read your comment on the workaround, what I wonder is that if possible for you to help me with the vb code as an example:

The scenario is explained below:

My workbook has two tabs, one is named "birthdatenames" which has birthday names with date of birth" and second tab is named "Images"

The macro coding checks the current day for any birthdate matching if matches draft a masils for those number of colleagues from the "birthdatenames" tabs.

Birthday mails are drafted using the above macro everyday and I have already prepared the draft for sending mail on the basis of vba macro but what I am trying to design that the images for the email is picked from the next worksheet tab:

Here's what I am looking for

1. Macro gets the image and path in the worksheet tab name "Images" from a specific folder however the image is pasted next to image path in the "Images" worksheet tab. (note: I have used your macro to get the image based on name and it runs successfully)

2. the specific picture is picked up (either by name or path) by the macro from the "Images" tab, once that picture is used it is either marked as or used in any of the column in the "Images" tab however in the same row and the macro does not pick it again for another birthday mail



An immediate attention to the above request will be greatly appreciated, riz.

I hope I can count on you.

Regards,
Hi rizvisa1,

Please let me know if you have found any solution to my request.

Regards,
Jack
Hi rizvisa1,

Any update as I am in dire need of that code which can help me in my workplace.

regards,
Jack