How to copy text with hyperlinks from outlook mail body and save into a word document with correct formatting

Question

I am trying to run a code where I copy content from mail body that may have some hyperlinks. I would like to retain hyperlinks while creating the word document

I tried various methods like Selection.AutoFormat = True but none worked

Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder As MAPIFolder
Dim OutlookMail As Variant
Dim olItems As Outlook.Items
Dim i As Integer
Dim savePath As String
Dim filePath As String

Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set Folder = OutlookNamespace.GetDefaultFolder(olFolderInbox)
Set olItems = Folder.Items
filePath = ActiveWorkbook.Path

For Each OutlookMail In olItems
    If OutlookMail.ReceivedTime >= Date - 1 Then
        Dim objWord
        Dim objDoc
        Dim objSelection
        Dim text As String
        Set objWord = CreateObject("Word.Application")
        Set objDoc = objWord.Documents.Add
        objWord.Visible = False
        Set objSelection = objWord.Selection

        text = OutlookMail.Body
        startPos = InStr(1, text, "Market Briefs")
        endPos = InStr(startPos, text, "http")
        text = Replace(Mid(text, startPos, endPos - startPos), "   ", "-")
        Set oPara1 = objDoc.Content.Paragraphs.Add
        oPara1.Range.text = text
        oPara1.Range.Font.Bold = True
        oPara1.Format.SpaceAfter = 0
        savePath = filePath & "\" & Format(Now(), "yyyy-mm-dd")

        With objDoc.Styles("Normal").ParagraphFormat
            .SpaceBefore = 0
            .SpaceBeforeAuto = False
            .SpaceAfter = 0
            .SpaceAfterAuto = False
            .LineSpacingRule = wdLineSpaceSingle
        End With

        If Len(Dir(savePath, vbDirectory)) = 0 Then
            MkDir savePath
        End If
        objDoc.SaveAs (savePath & "\ABC.docx")
        objDoc.Close

    End If
Next OutlookMail

Set Folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing

user_4539709 · Answer

Work with Copy & PasteAndFormat Method when coping email body

Quick Example would be

Option Explicit
Public Sub Example()

    Dim OutlookMail As Variant
    For Each OutlookMail In ActiveExplorer.Selection

        Dim wdApp As New Word.Application

        Dim wdDoc As Word.Document
        Set wdDoc = wdApp.Documents.Add

            OutlookMail.GetInspector().WordEditor.Range.Copy

        Dim oPara1 As Word.Paragraph
        Set oPara1 = wdDoc.Content.Paragraphs.Add
            oPara1.Range.PasteAndFormat Type:=wdFormatOriginalFormatting

    Next

End Sub

Remember to set Outlook & Word library References, Tools -> References

user_519226 · Answer

Use Word's Document.Hyperlinks.Add method against the Range object containing the text to add a URL. See: https://docs.microsoft.com/en-us/office/vba/api/word.hyperlinks.add

How to copy text with hyperlinks from outlook mail body and save into a word document with correct formatting

2 Answers