Posts by rakee_josh

    Re: Image cannot be displayed in email body using vba


    Sorry to reply late, Thank you so much, its working now.
    one more help - as per my above code:
    .HTMLBody = .HTMLBody & Cells(i, 4).Value & "," & _
    "<br><br>" & Cells(i, 5).Value & _
    "<br><br>" & Cells(i, 6).Value & _
    "<br><br>" & Cells(i, 7).Value & _
    "<br><br>" & Cells(i, 8).Value & _
    "<br><br>" & Cells(i, 9).Value & _
    "<br><br>" & "Regards<br>" & _


    if cells(i, 9).value is blank, it should jump to next line regards.
    am trying like this but its not working -


    "If cells(i, 9).value = "" then
    go to next
    End if"


    Pls help

    Hi,


    Am using vba macro for sending mass emails, where in everything looks good, but image is not loading properly and it should be placed at the end.
    Any thoughts on this would be helpful.


    Here is my code:


    Sub EmbeddedHTMLGraphicDemo()
    On Error Resume Next
    ' 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 OutApp As Object
    Dim OutMail As Object
    Dim strbody As String
    Dim MyRange As Range
    Dim i As Long
    For i = 2 To Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
    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:\Users\U700029\Desktop\mypic.jpg")
    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.Display
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    Set Rng = Nothing
    With OutMail
    .SentOnBehalfOfName = "[email protected]"
    .To = Cells(i, 1).Value
    .CC = Cells(i, 2).Value
    .Subject = Cells(i, 3).Value
    .Attachments.Add Cells(i, 10).Value
    .Attachments.Add Cells(i, 11).Value
    .HTMLBody = .HTMLBody & Cells(i, 4).Value & "," & _
    "<br><br>" & Cells(i, 5).Value & _
    "<br><br>" & Cells(i, 6).Value & _
    "<br><br>" & Cells(i, 7).Value & _
    "<br><br>" & Cells(i, 8).Value & _
    "<br><br>" & Cells(i, 9).Value & _
    "<br><br>" & "Regards<br>" & _
    "**************************************<br>" & _
    "<b><A HREF=""[email protected]"">ghi</A></b>" & _
    "<br><i>" & "Business" & "</br></i>" & _
    "<br><b><A HREF=""https://google.com/support/portal"">Google Portal</A></b></br>" & " - " & "Login to review." & _
    "<img src='cid:Mypic.jpg'" & "width='500' height='200'><br>"
    .Display
    With OutMail
    .HTMLBody = .HTMLBody & l_Attach
    End With
    End With
    Next
    Set OutMail = Nothing
    Set OutApp = Nothing

    ' 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

    Re: Save email attachments and rename to my folder on desktop


    I got the code, its working now, the only thing is worrying me is, its not saving the files in given path, its saving in my documents.
    And also its not working on other systems. Can u help:


    Re: Save email attachments and rename to my folder on desktop


    I got the code, its working now, the only thing is worrying me is, its not saving the files in given path, its saving in my documents.
    And also its not working on other systems. Can u help:


    Public Sub SaveAttachments()
    Dim objOL As Outlook.Application
    Dim objMsg As Outlook.MailItem 'Object
    Dim objAttachments As Outlook.Attachments
    Dim objSelection As Outlook.Selection
    Dim i As Long
    Dim lngCount As Long
    Dim strFile As String
    Dim strFolderpath As String
    Dim strFileName As String
    Dim objSubject As String
    Dim strDeletedFiles As String
    Dim dateFormat As String





    ' Get the path to your My Documents folder
    'strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
    On Error Resume Next
    ' Instantiate an Outlook Application object.
    Set objOL = CreateObject("Outlook.Application")
    ' Get the collection of selected objects.
    Set objSelection = objOL.ActiveExplorer.Selection
    ' The attachment folder needs to exist
    ' You can change this to another folder name of your choice
    ' Set the Attachment folder.
    strFolderpath = "C:\Users\U700029\Desktop\Medstat"
    dateFormat = Format(Now - 1, " yyyy-mm-dd")
    ' Check each selected item for attachments.
    For Each objMsg In objSelection
    'Set FileName to Subject
    objSubject = objMsg.Subject
    objSubject = Left(objMsg.Subject, Len(objMsg.Subject) - 12)
    Set objAttachments = objMsg.Attachments
    lngCount = objAttachments.Count
    If lngCount > 0 Then
    ' Use a count down loop for removing items
    ' from a collection. Otherwise, the loop counter gets
    ' confused and only every other item is removed.
    For i = lngCount To 1 Step -1
    ' Get the file name.
    strFileName = objSubject
    ' Combine with the path to the Temp folder.
    strFile = objSubject & dateFormat & ".xlsx"
    Debug.Print strFile
    ' Save the attachment as a file.
    objAttachments.item(i).SaveAsFile strFile
    Next i
    End If
    Next
    ExitSub:
    Set objAttachments = Nothing
    Set objMsg = Nothing
    Set objSelection = Nothing
    Set objOL = Nothing
    End Sub

    This is what i have created, but i require the file to be saved with Subject and Yesterday date:


    Public Sub SaveAttachments()
    Dim objOL As Outlook.Application
    Dim objMsg As Outlook.MailItem 'Object
    Dim objAttachments As Outlook.Attachments
    Dim objSelection As Outlook.Selection
    Dim i As Long
    Dim lngCount As Long
    Dim strFile As String
    Dim strFolderpath As String
    Dim strFileName As String
    Dim objSubject As String
    Dim strDeletedFiles As String
    Dim dateFormat As String
    Dim MsgSubject As String



    ' Get the path to your My Documents folder
    'strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
    On Error Resume Next
    ' Instantiate an Outlook Application object.
    Set objOL = CreateObject("Outlook.Application")
    ' Get the collection of selected objects.
    Set objSelection = objOL.ActiveExplorer.Selection
    ' The attachment folder needs to exist
    ' You can change this to another folder name of your choice
    ' Set the Attachment folder.
    strFolderpath = "C:\Users\U700029\Desktop\Medstat"
    dateFormat = Format(Now - 1, " yyyy-mm-dd")
    ' Check each selected item for attachments.
    For Each objMsg In objSelection
    'Set FileName to Subject
    objSubject = objMsg.Subject
    MsgSubject = objMsg.Subject
    Set objAttachments = objMsg.Attachments
    lngCount = objAttachments.Count
    If lngCount > 0 Then
    ' Use a count down loop for removing items
    ' from a collection. Otherwise, the loop counter gets
    ' confused and only every other item is removed.
    For i = lngCount To 1 Step -1
    ' Get the file name.
    strFileName = objSubject
    ' Combine with the path to the Temp folder.
    strFile = MsgSubject & dateFormat & ".xlsx"
    Debug.Print strFile
    ' Save the attachment as a file.
    objAttachments.item(i).SaveAsFile strFile
    Next i
    End If
    Next
    ExitSub:
    Set objAttachments = Nothing
    Set objMsg = Nothing
    Set objSelection = Nothing
    Set objOL = Nothing
    End Sub



    Any idea would be great.

    Re: Save email attachments and rename to my folder on desktop


    This code is not working, can u help:


    Re: Save email attachments and rename to my folder on desktop


    Thank you Pike for your response,


    However this code does not save with subject and yesterdays date, can u have a look: