none
Reply with a template loose the embed images sent by the sender RRS feed

  • Question

  • Hello everyone,

    I"m using VBA to reply to sender with templates in Outlook 365. In 90% of cases, it works fine. But, I have a big problem, when the sender send me an email with an embed image in his mail's body. This code loose the embed image and send a red X. I tried without any result to solve that. Can you help me on that ?
    Example of code:

    Sub TacReply()
    
    Dim origEmail As mailItem
    Dim replyEmail As mailItem
    
    Set origEmail = ActiveExplorer.Selection(1)
    Set replyEmail = CreateItemFromTemplate("S:\Share\TWGeneral.oft")
    
    replyEmail.To = origEmail.Reply.To
    
    replyEmail.HTMLBody = replyEmail.HTMLBody & origEmail.Reply.HTMLBody
    replyEmail.SentOnBehalfOfName = "email@domain.com"
    replyEmail.Recipients.ResolveAll
    replyEmail.Display
    
    Set origEmail = Nothing
    Set replyEmail = Nothing
    
    End Sub


    • Edited by dgnoyon Saturday, February 15, 2020 4:22 PM
    Saturday, February 15, 2020 4:22 PM

All replies

  • Have you tried to look at the HTML code to figure out why the image is not shown?

    Secondly, concatenating two HTML strings will not produce a valid HTML: string. The two need to be merged.


    Dmitry Streblechenko (MVP)
    http://www.dimastr.com/redemption
    Redemption - what the Outlook
    Object Model should have been
    Version 5.5 is now available!

    Saturday, February 15, 2020 10:43 PM
  • Hi Dmitry

    Thank you for your fast answer. I used OutlookSpy add-ins to check the difference and in fact if we analyze a normal answer, A Shape is added and the image is shown but in my case the shape is removed, the image is renamed ...

    I also, tried to add again it with an hidden status but I still have to change the HTML code and replace the bad image noame by the correct one ...

    But after that, i definitively don't know how to do to solve my problem

    I use this code to add the attachments:

    Private Sub CopyAttachments(objSourceItem, objTargetItem, MyKind As Integer)
        
        Const PR_ATTACH_MIME_TAG = "http://schemas.microsoft.com/mapi/proptag/0x370E001E"
        Const PR_ATTACHMENT_HIDDEN = "http://schemas.microsoft.com/mapi/proptag/0x7FFE000B"
        Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001E"
        Const PR_ATTACH_FLAGS = "http://schemas.microsoft.com/mapi/proptag/0x37140003"
        Const PR_ATTACH_CONTENT_LOCATION = "http://schemas.microsoft.com/mapi/proptag/0x3713001E"
        Const PR_ATTACH_METHOD = "http://schemas.microsoft.com/mapi/proptag/0x37050003"
        
        Dim FSO
        Dim fldTemp
        Dim strPath As String, strFile As String
        Dim objAtt
        Dim ObjAttDest
       'Dim MyItem
       'Dim MyAttachments
        Dim pa As PropertyAccessor
        Dim c As Integer
        Dim cid As String
        Dim body As String
        Dim test
    
        body = objSourceItem.HTMLBody
        
        Set FSO = CreateObject("Scripting.FileSystemObject")
        Set fldTemp = FSO.GetSpecialFolder(2) ' TemporaryFolder
        strPath = fldTemp.Path & "\"
        For Each objAtt In objSourceItem.Attachments
            Set pa = objAtt.PropertyAccessor
            cid = pa.GetProperty(PR_ATTACH_CONTENT_ID)
    
            If Len(cid) > 0 Then
                If InStr(body, cid) Then
                    If MyKind = 1 Or MyKind = 3 Then
                        If pa.GetProperty(PR_ATTACHMENT_HIDDEN) Then
                            strFile = strPath & objAtt.FileName
                            objAtt.SaveAsFile strFile
                            Set ObjAttDest = objTargetItem.Attachments.Add(strFile, olByValue, 0, objAtt.DisplayName)
                            ObjAttDest.PropertyAccessor.SetProperty PR_ATTACH_MIME_TAG, pa.GetProperty(PR_ATTACH_MIME_TAG)
                            ObjAttDest.PropertyAccessor.SetProperty PR_ATTACH_CONTENT_ID, pa.GetProperty(PR_ATTACH_CONTENT_ID)
                            ObjAttDest.PropertyAccessor.SetProperty PR_ATTACHMENT_HIDDEN, True
                            
                            objTargetItem.PropertyAccessor.SetProperty "http://schemas.microsoft.com/mapi/id/{00062008-0000-0000-C000-000000000046}/8514000B", True
                            FSO.DeleteFile strFile
                            objTargetItem.Save
                        End If
                    End If
                Else
                    If MyKind = 2 Or MyKind = 3 Then
    
                        'In case that PR_ATTACHMENT_HIDDEN does not exists,
                        'an error will occur. We simply ignore this error and
                        'treat it as false.
                        On Error Resume Next
                        If Not pa.GetProperty(PR_ATTACHMENT_HIDDEN) Then
                            strFile = strPath & objAtt.FileName
                            objAtt.SaveAsFile strFile
                            objTargetItem.Attachments.Add strFile, , , objAtt.DisplayName
                            FSO.DeleteFile strFile
                        End If
                        On Error GoTo 0
                    End If
                End If
            Else
                strFile = strPath & objAtt.FileName
                objAtt.SaveAsFile strFile
                objTargetItem.Attachments.Add strFile, , , objAtt.DisplayName
                FSO.DeleteFile strFile
            End If
        Next
     
       Set fldTemp = Nothing
       Set FSO = Nothing
    End Sub

    and of course added the call functions in my main SUB


    • Edited by dgnoyon Sunday, February 16, 2020 1:53 PM
    Sunday, February 16, 2020 1:46 PM
  • So your code copies attachments from one message to another?  What exactly goes wrong? After you copy the attachments and save the message, whcih properties disappear?

    Dmitry Streblechenko (MVP)
    http://www.dimastr.com/redemption
    Redemption - what the Outlook
    Object Model should have been
    Version 5.5 is now available!

    Sunday, February 16, 2020 5:59 PM
  • Hi Dmitry

    In fact I just try to keep the sender's embedded pictures which are lost in the reply.

    Like you said, because I'm using : 

    replyEmail.HTMLBody = replyEmail.HTMLBody & origEmail.Reply.HTMLBody

    I think it is why i loose the embedded pictures

    So, I try to 

    - copy from original pictures embedded to the new email (done in the last code provided)

    - Change in the HTML code of the new email to point to the picture name ... (have no idea on how to do it) ... I'm searching about HTML parser solution ... The problem I have is to detect 
    - 'mso-bookmark:_MailOriginal' which means we are in the original mail
    - find each 'src= cid:xxxxxx'
    - replace them with the correct image name

    The Shapes also disappear so do you think I have to create it again ?

    but maybe I'm wrong 

    If you think there is an easiest way to use a template a s reply and keep the original pictures in the body ... let me know

    Thanx in advance

    Code source extracted from original email: cid:image002.jpg@001D5E1B0.19CCBF00

    <p class=3DMsoNormal><span lang=3DDA style=3D'mso-ansi-language:DA'><!--[if=
     gte vml 1]><v:shapetype
     id=3D"_x0000_t75" coordsize=3D"21600,21600" o:spt=3D"75" o:preferrelative=
    =3D"t"
     path=3D"m@4@5l@4@11@9@11@9@5xe" filled=3D"f" stroked=3D"f">
     <v:stroke joinstyle=3D"miter"/>
     <v:formulas>
      <v:f eqn=3D"if lineDrawn pixelLineWidth 0"/>
      <v:f eqn=3D"sum @0 1 0"/>
      <v:f eqn=3D"sum 0 0 @1"/>
      <v:f eqn=3D"prod @2 1 2"/>
      <v:f eqn=3D"prod @3 21600 pixelWidth"/>
      <v:f eqn=3D"prod @3 21600 pixelHeight"/>
      <v:f eqn=3D"sum @0 0 1"/>
      <v:f eqn=3D"prod @6 1 2"/>
      <v:f eqn=3D"prod @7 21600 pixelWidth"/>
      <v:f eqn=3D"sum @8 21600 0"/>
      <v:f eqn=3D"prod @7 21600 pixelHeight"/>
      <v:f eqn=3D"sum @10 21600 0"/>
     </v:formulas>
     <v:path o:extrusionok=3D"f" gradientshapeok=3D"t" o:connecttype=3D"rect"/>
     <o:lock v:ext=3D"edit" aspectratio=3D"t"/>
    </v:shapetype><v:shape id=3D"Picture_x0020_1" o:spid=3D"_x0000_i1025" type=
    =3D"#_x0000_t75"
     alt=3D"" style=3D'width:489.75pt;height:367.5pt'>
     <v:imagedata src=3D"PrintersinCMDB_files/image001.jpg" o:href=3D"cid:image=
    002.jpg@01D5E1B0.19CCBF00"/>
    </v:shape><![endif]--><![if !vml]><img width=3D653 height=3D490
    src=3D"PrintersinCMDB_files/image001.jpg" style=3D'height:5.104in;width:6.8=
    02in'
    v:shapes=3D"Picture_x0020_1"><![endif]><o:p></o:p></span></p>

    Code source extracted from the reply mail: Name changed to cid:image001.jpg@01D5E4F2.E133E1F0

    <p style='</span><span
    style='<span lang=DA style='
    <img border=0 width=653 height=490 id="_x0000_i1025"
    src="cid:image001.jpg@01D5E4F2.E133E1F0"></span></span><span style='<span lang=DA style='<o:p></o:p></span></span></p>



    • Edited by dgnoyon Tuesday, February 18, 2020 10:57 AM
    Sunday, February 16, 2020 6:50 PM
  • Hi Dmitry,

    I tested to hardcode the correct image name provided by the original mail. I built a small parser and past his name in the new email and the emage was shown correcly.

    Now, i have to think that the original mail can have plenty embed images so I have to find the original name from the original email paste it in the new email and do that on all embed image ...

    Can you help me to improve this code:

    Sub TacReply()
    
    Dim i As Long
    Dim MyText As Long
    Dim SearchString As String
    Dim SplitFile As Variant
    Dim origEmail As MailItem
    Dim replyEmail As MailItem
    Dim MyHTMLBody As String
    
    Set origEmail = ActiveExplorer.Selection(1)
    Set replyEmail = CreateItemFromTemplate("c:\test\test2.oft")
    
    replyEmail.To = origEmail.Reply.To
    replyEmail.Recipients.ResolveAll
    
    Debug.Print origEmail.Reply.HTMLBody
    
    SplitFile = Split(origEmail.Reply.HTMLBody, "<p ")
    If Not IsEmpty(SplitFile) Then
        For i = 0 To UBound(SplitFile)
            If i > 0 Then SplitFile(i) = "<p " & SplitFile(i)
            If InStr(SplitFile(i), "_MailOriginal") Then
                MyText = InStr(SplitFile(i), "cid:")
                If MyText > 0 Then
                    SearchString = Mid$(SplitFile(i), MyText + 4, InStr(MyText, SplitFile(i), ">") - MyText - 5)
                    SplitFile(i) = Replace(SplitFile(i), SearchString, "image002.jpg@01D5E1B0.19CCBF00")
                End If
            End If
        Next i
    End If
    
    MyHTMLBody = Join(SplitFile, "")
    replyEmail.HTMLBody = replyEmail.HTMLBody & MyHTMLBody
    Debug.Print replyEmail.HTMLBody
    
    replyEmail.Save
    
    CopyAttachments origEmail, replyEmail, 3
    
    
    
    replyEmail.Display
    
    Set origEmail = Nothing
    Set replyEmail = Nothing
    
    End Sub
    

    Sunday, February 16, 2020 9:26 PM
  • OK, after checking the embed images, we have a date and time of last modification (PR_CREATION_TIME) and (PR_LASt_MODIFICATION_TIME) so we should be able to sort them.

    I give you an example of embed pictures list:
    - image002.jpg@01D5E586.1EBF0070        PR_LAST_MODIFICATION_TIME: 17/02/2020 07:11
    - image006.jpg@01D5E569.E6A09CB0        PR_LAST_MODIFICATION_TIME: 17/02/2020 07:11
    - image001.jpg@01D5E588.1EBF8870        PR_LAST_MODIFICATION_TIME: 17/02/2020 10:33

    So it is logical to understand that if we read the email from the top to the bottom, we have to consider that IMAGE1 was the last added so it should be the first added in the HTML code.
    About the 2 last, they have the same date and time so we have to consider that IMAGE2 and IMAGE6 are the next in the mail.

    Now the question is : how to build a function which is able to sort them like describe ?
    I'm using an array to store all hidden files (embed files)





    • Edited by dgnoyon Monday, February 17, 2020 3:56 PM
    Monday, February 17, 2020 2:36 PM
  • I am not sure why any date time properties would matter - the order or dates make no difference at all. In your HTML body, the content id of the the cid attribute in the img tags must match the PR_ATTACH_CONTENT_ID property, e.g. for <img cid:"xyz">, PR_ATTACH_CONTENT_ID must be xyz.

    Dmitry Streblechenko (MVP)
    http://www.dimastr.com/redemption
    Redemption - what the Outlook
    Object Model should have been
    Version 5.5 is now available!

    Tuesday, February 18, 2020 3:16 AM
  • Hi Dmitry,

    Yes you are right but this part is already solved by the code provided previously.

    The main problem is (it is what I saw when I save email to HTML) that the CID:imagename can change 

    So I cannot use the image name to replace it directly by the correct name ...

    Now, i'm working on the different embed images that an email can have in the body ...

    Imagine:

    - a mail sent the first time with embed image

    - An answer to this mail with also 2 embed images

    - Another answer with 1 embed image

    When I rebuild the 'originalmail' I have to consider the date of attachments.

    Like describe in the previous post, the attachments are added at the bottom of the list of attachments with the correct PR_ATTACH_CONTENT_ID and the PR_LAST_MODIFICATION_TIME.

    for example:

    - image003.jpg@01D5E580.1EBF8870        PR_LAST_MODIFICATION_TIME: 16/02/2020 07:11

    - image002.jpg@01D5E586.1EBF0070        PR_LAST_MODIFICATION_TIME: 17/02/2020 07:11
    - image006.jpg@01D5E569.E6A09CB0        PR_LAST_MODIFICATION_TIME: 17/02/2020 07:11
    - image001.jpg@01D5E588.1EBF8870        PR_LAST_MODIFICATION_TIME: 17/02/2020 10:33

    The problem is that an email start with the last reply first and finish with the oldest email so I have to sort email by date like that :

    - image001.jpg@01D5E588.1EBF8870        PR_LAST_MODIFICATION_TIME: 17/02/2020 10:33

    - image002.jpg@01D5E586.1EBF0070        PR_LAST_MODIFICATION_TIME: 17/02/2020 07:11

    - image006.jpg@01D5E569.E6A09CB0        PR_LAST_MODIFICATION_TIME: 17/02/2020 07:11
    - image003.jpg@01D5E580.1EBF8870        PR_LAST_MODIFICATION_TIME: 16/02/2020 07:11

    The difficulty is when we have 2 embed image in the same reply .. In this case, we have to keep the sort of the initial attachments list ...

    - image002.jpg@01D5E586.1EBF0070        PR_LAST_MODIFICATION_TIME: 17/02/2020 07:11

    - image006.jpg@01D5E569.E6A09CB0        PR_LAST_MODIFICATION_TIME: 17/02/2020 07:11

    I hope it is more clear for you ...

    So now, I have to find how to implement this logic in my vba code

    .


    • Edited by dgnoyon Tuesday, February 18, 2020 10:07 AM
    Tuesday, February 18, 2020 8:03 AM
  • OK, I just discovered that PR_LAST_MODIFICATION_TIME is not present for all hidden attachment ... so I don't know how to manage the images in a long discussion .... 
    Tuesday, February 18, 2020 10:03 AM
  • Hi Dmitry,

    Can you say me if I'm trying to do something impossible ? because I didn't find any post on what I'm doing so now i'm in a complete doubt ...

    Anyway, can you help me on this function :  

    for example:

    - image003.jpg@01D5E580.1EBF8870        PR_LAST_MODIFICATION_TIME: 16/02/2020 07:11

    - image002.jpg@01D5E586.1EBF0070        PR_LAST_MODIFICATION_TIME: 17/02/2020 07:11
    - image006.jpg@01D5E569.E6A09CB0        PR_LAST_MODIFICATION_TIME: 17/02/2020 07:11
    - image001.jpg@01D5E588.1EBF8870        PR_LAST_MODIFICATION_TIME: 17/02/2020 10:33

    The problem is that an email start with the last reply first and finish with the oldest email so I have to sort email by date like that :

    - image001.jpg@01D5E588.1EBF8870        PR_LAST_MODIFICATION_TIME: 17/02/2020 10:33

    - image002.jpg@01D5E586.1EBF0070        PR_LAST_MODIFICATION_TIME: 17/02/2020 07:11

    - image006.jpg@01D5E569.E6A09CB0        PR_LAST_MODIFICATION_TIME: 17/02/2020 07:11
    - image003.jpg@01D5E580.1EBF8870        PR_LAST_MODIFICATION_TIME: 16/02/2020 07:11

    The difficulty is when we have 2 embed image in the same reply .. In this case, we have to keep the sort of the initial attachments list ...

    - image002.jpg@01D5E586.1EBF0070        PR_LAST_MODIFICATION_TIME: 17/02/2020 07:11

    - image006.jpg@01D5E569.E6A09CB0        PR_LAST_MODIFICATION_TIME: 17/02/2020 07:11

    I will try to manage later the fact all pictures don't have a date tag 
    I will do it step by step ....

    Tuesday, February 18, 2020 3:31 PM
  • Dmitry,

    I created a complete code that you can test to see what is / are my problem.

    You will see it works fine :

    - if you reply with a template to the (first email received with no embedded image is present in the email

    - if you reply with a template to the first mail received which contains an embedded image

    - if you reply to a multiple answers done to the first mail received but which contains ONLY 1 embedded image at all

    It doesn't work if:

    - you reply with a template to a multiple answers done on the first mail received but with multiple embedded images ... 

    Reasons :

    - HTML code CID Image name change between the original and the reply so we cannot use the name as criteria to replace the HTML code.

    - We cannot use the attachments list order to replace images in the HTML code because the list doesn't reflect the order of image in the HTML code.

    Option Explicit
    
    Sub TacReply()
    
        Dim origEmail As MailItem
        Dim replyEmail As MailItem
        
        Set origEmail = ActiveExplorer.Selection(1)
        Set replyEmail = CreateItemFromTemplate("c:\test\test2.oft")
        
        replyEmail.To = origEmail.Reply.To
        replyEmail.Recipients.ResolveAll
        
        CopyAttachments origEmail, replyEmail, 3
        
        replyEmail.Display
        
        Set origEmail = Nothing
        Set replyEmail = Nothing
    
    End Sub
    
    
    Function BubbleSort1DArray(vIn As Variant, bAscending As Boolean, Optional vRet As Variant) As Boolean
        ' Sorts the single dimension list array, ascending or descending
        ' Returns sorted list in vRet if supplied, otherwise in vIn modified
            
        Dim First As Long, Last As Long
        Dim i As Long, j As Long, bWasMissing As Boolean
        Dim Temp As Variant, vW As Variant
        
        First = LBound(vIn)
        Last = UBound(vIn)
        
        ReDim vW(First To Last, 1)
        vW = vIn
        
        If bAscending = True Then
            For i = First To Last - 1
                For j = i + 1 To Last
                    If vW(i) > vW(j) Then
                    Temp = vW(j)
                    vW(j) = vW(i)
                    vW(i) = Temp
                    End If
                Next j
            Next i
        Else 'descending sort
            For i = First To Last - 1
                For j = i + 1 To Last
                    If CDate(Left$(vW(i), InStr(1, vW(i), ",") - 1)) < CDate(Left$(vW(j), InStr(1, vW(j), ",") - 1)) Then
                        Temp = vW(j)
                        vW(j) = vW(i)
                        vW(i) = Temp
                    End If
                Next j
            Next i
        End If
      
       'find whether optional vRet was initially missing
        bWasMissing = IsMissing(vRet)
       
       'transfers
       If bWasMissing Then
         vIn = vW  'return in input array
       Else
         ReDim vRet(First To Last, 1)
         vRet = vW 'return with input unchanged
       End If
       
       BubbleSort1DArray = True
    
    End Function
    
    Private Sub CopyAttachments(objSourceItem, objTargetItem, MyKind As Integer)
        
        'Content-id - MIME
        Const PR_ATTACH_CONTENT_ID_A = "http://schemas.microsoft.com/mapi/proptag/0x3712001E"
        Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001F"
    
        'binary attachment data
        Const PR_ATTACH_DATA_BIN = "http://schemas.microsoft.com/mapi/proptag/0x37010102"
        
        'formatting info for attachment
        Const PR_ATTACH_MIME_TAG_A = "http://schemas.microsoft.com/mapi/proptag/0x370E001E"
        Const PR_ATTACH_MIME_TAG = "http://schemas.microsoft.com/mapi/proptag/0x370E001F"
        Const PR_ATTACH_FLAGS = "http://schemas.microsoft.com/mapi/proptag/0x37140003"
        Const PR_ATTACH_CONTENT_LOCATION = "http://schemas.microsoft.com/mapi/proptag/0x3713001E"
        Const PR_ATTACHMENT_FLAGS = "http://schemas.microsoft.com/mapi/proptag/0x7FFD0003"
        Const PR_ATTACH_METHOD = "http://schemas.microsoft.com/mapi/proptag/0x37050003"
        Const PR_LAST_MODIFICATION_TIME = "http://schemas.microsoft.com/mapi/proptag/0x30080040"
        'set to true for hidden attachments
        'undefined otherwise and will throw an exception if queried
        Const PR_ATTACHMENT_HIDDEN = "http://schemas.microsoft.com/mapi/proptag/0x7FFE000B"
    
        Dim FSO
        Dim fldTemp
        Dim strPath As String, strFile As String
        Dim objAtt
        Dim ObjAttDest
        Dim pa As PropertyAccessor
        Dim c As Integer
        Dim cid As String
        Dim test
        Dim i As Long, j As Long
        Dim MyText As Long
        Dim SearchString As String
        Dim SplitFile As Variant
        Dim MyHTMLBody As String
        Dim listFile As Variant
        Dim DateArray As Variant
        'Dim criteria As String
        'Dim criteria2 As String
        Dim k As Long
        Dim array2 As Variant
        Dim IsOK As Boolean
        
        Set FSO = CreateObject("Scripting.FileSystemObject")
        Set fldTemp = FSO.GetSpecialFolder(2) ' TemporaryFolder
        strPath = fldTemp.Path & "\"
        
    
        '==================================================================
        ' COPY from RECEIVED MAIL TO REPLY MAIL ALL HIDDEN ATTACHMENTS
        '==================================================================
        ' Should be all Embedded images in the mail body
        '==================================================================
        For Each objAtt In objSourceItem.Attachments
            Set pa = objAtt.PropertyAccessor
            cid = pa.GetProperty(PR_ATTACH_CONTENT_ID)
    
            If Len(cid) > 0 Then
                If InStr(objSourceItem.HTMLBody, cid) Then
                    If MyKind = 1 Or MyKind = 3 Then
                        If pa.GetProperty(PR_ATTACHMENT_HIDDEN) Then
                            strFile = strPath & objAtt.FileName
                            objAtt.SaveAsFile strFile
                            Set ObjAttDest = objTargetItem.Attachments.Add(strFile, olByValue, 0, objAtt.DisplayName)
                            objTargetItem.Save
                            
                            'On Error Resume Next ' Because some attachment don't have PR_LAST_MODIFICATION_TIME set
                            If IsEmpty(listFile) = True Then
                                listFile = Array(pa.GetProperty(PR_ATTACH_CONTENT_ID_A))
                                DateArray = Array(pa.GetProperty(PR_LAST_MODIFICATION_TIME) & "," & pa.GetProperty(PR_ATTACH_CONTENT_ID_A))
                            ElseIf IsEmpty(listFile(0)) Then
                                listFile(0) = pa.GetProperty(PR_ATTACH_CONTENT_ID_A)
                                DateArray(0) = pa.GetProperty(PR_LAST_MODIFICATION_TIME) & "," & pa.GetProperty(PR_ATTACH_CONTENT_ID_A)
                            Else
                                ReDim Preserve listFile(UBound(listFile) + 1) 'Add next array element
                                ReDim Preserve DateArray(UBound(DateArray) + 1)
                                listFile(UBound(listFile)) = pa.GetProperty(PR_ATTACH_CONTENT_ID_A)
                                DateArray(UBound(DateArray)) = pa.GetProperty(PR_LAST_MODIFICATION_TIME) & "," & pa.GetProperty(PR_ATTACH_CONTENT_ID_A)
                            End If
    
                            'On Error GoTo 0
                            
                            ObjAttDest.PropertyAccessor.SetProperty PR_ATTACH_CONTENT_ID_A, pa.GetProperty(PR_ATTACH_CONTENT_ID_A)
                            ObjAttDest.PropertyAccessor.SetProperty PR_ATTACH_CONTENT_ID, pa.GetProperty(PR_ATTACH_CONTENT_ID)
                            ObjAttDest.PropertyAccessor.SetProperty PR_ATTACHMENT_HIDDEN, True
    
                            ObjAttDest.PropertyAccessor.SetProperty PR_ATTACH_MIME_TAG_A, pa.GetProperty(PR_ATTACH_MIME_TAG_A)
                            ObjAttDest.PropertyAccessor.SetProperty PR_ATTACH_MIME_TAG, pa.GetProperty(PR_ATTACH_MIME_TAG)
                            ObjAttDest.PropertyAccessor.SetProperty PR_ATTACHMENT_FLAGS, pa.GetProperty(PR_ATTACHMENT_FLAGS)
                            ObjAttDest.PropertyAccessor.SetProperty PR_ATTACH_DATA_BIN, pa.GetProperty(PR_ATTACH_DATA_BIN)
                            
                            'objTargetItem.PropertyAccessor.SetProperty "http://schemas.microsoft.com/mapi/id/{00062008-0000-0000-C000-000000000046}/8514000B", True
                            FSO.DeleteFile strFile
                            objTargetItem.Save
                        End If
                    End If
                Else
                    If MyKind = 2 Or MyKind = 3 Then
    
                        'In case that PR_ATTACHMENT_HIDDEN does not exists,
                        'an error will occur. We simply ignore this error and
                        'treat it as false.
                        On Error Resume Next
                        If Not pa.GetProperty(PR_ATTACHMENT_HIDDEN) Then
                            strFile = strPath & objAtt.FileName
                            objAtt.SaveAsFile strFile
                            objTargetItem.Attachments.Add strFile, , , objAtt.DisplayName
                            FSO.DeleteFile strFile
                        End If
                        On Error GoTo 0
                    End If
                End If
                objTargetItem.HTMLBody = objTargetItem.HTMLBody & objSourceItem.Reply.HTMLBody
            Else
                strFile = strPath & objAtt.FileName
                objAtt.SaveAsFile strFile
                objTargetItem.Attachments.Add strFile, , , objAtt.DisplayName
                FSO.DeleteFile strFile
                objTargetItem.HTMLBody = objTargetItem.HTMLBody & objSourceItem.Reply.HTMLBody
            End If
        Next
        
        
        If Not IsEmpty(listFile) Then
            '=============================================================================================
            ' Modify the HTML body to reflect the correct embedded images
            ' Unfortunately, image names in HTML code and image names in attachments can be different
            '=============================================================================================
            
            i = 0
            j = 0
        
            ' ========= Parser of HTML Code
            SplitFile = Split(objSourceItem.Reply.HTMLBody, "<p ")
            If Not IsEmpty(listFile) Then
                'listFile = SortArrayAtoZ(listFile)
                'BubbleSort2 DateArray
                'QuickSort DateArray, 0, UBound(DateArray)
                    
                IsOK = BubbleSort1DArray(DateArray, False, array2)
        
                If Not IsEmpty(SplitFile) Then
                    Do While i <= UBound(SplitFile)
                        If i > 0 Then SplitFile(i) = "<p " & SplitFile(i)
                        If InStr(SplitFile(i), "_MailOriginal") Then
                            MyText = InStr(SplitFile(i), "cid:")
                            If MyText > 0 Then
                                SearchString = Mid$(SplitFile(i), MyText + 4, InStr(MyText, SplitFile(i), ">") - MyText - 5)
                                SplitFile(i) = Replace(SplitFile(i), SearchString, listFile(j))
                                j = j + 1
                            End If
                        End If
                        i = i + 1
                    Loop
                End If
            End If
            MyHTMLBody = Join(SplitFile, "")
            objTargetItem.HTMLBody = objTargetItem.HTMLBody & MyHTMLBody
            Debug.Print objTargetItem.HTMLBody
            objTargetItem.Save
        Else
            objTargetItem.HTMLBody = objTargetItem.HTMLBody & objSourceItem.Reply.HTMLBody
        End If
       Set fldTemp = Nothing
       Set FSO = Nothing
    End Sub

     



    • Edited by dgnoyon Wednesday, February 19, 2020 10:33 AM
    Tuesday, February 18, 2020 4:22 PM
  • You are still concatenating HTMLBody properties...

    Dmitry Streblechenko (MVP)
    http://www.dimastr.com/redemption
    Redemption - what the Outlook
    Object Model should have been
    Version 5.5 is now available!

    Thursday, February 20, 2020 6:46 PM
  • Hi Dmitry

    How to do differently ? Can you provide me an example ?

     

    Friday, February 21, 2020 9:00 AM
  • Poorman's merge: search for the occurrence of the "<body" substring, then find the next ">" character - that will take care of the <body> tags with attributes. At that point, insert you HTML string (e.g. "my <b>bold</b> text").

    Dmitry Streblechenko (MVP)
    http://www.dimastr.com/redemption
    Redemption - what the Outlook
    Object Model should have been
    Version 5.5 is now available!

    Wednesday, February 26, 2020 10:26 PM