Как скопировать текст с гиперссылками из почтового сообщения Outlook и сохранить в текстовом документе с правильным форматированием - PullRequest
Новая
       38

Как скопировать текст с гиперссылками из почтового сообщения Outlook и сохранить в текстовом документе с правильным форматированием

0 голосов
/ 08 января 2019

Я пытаюсь запустить код, в который я копирую контент из тела письма, в котором могут быть некоторые гиперссылки. Я хотел бы сохранить гиперссылки при создании слова документа

Я пробовал различные методы, такие как Selection.AutoFormat = True, но ни один из них не работал 

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

Ответы [ 2 ]

0 голосов
/ 09 января 2019

Работа с копией & Метод PasteAndFormat при копировании тела письма

Быстрый пример будет 

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

Не забудьте установить ссылки библиотеки Outlook и Word, Сервис -> Ссылки

0 голосов
/ 08 января 2019

Используйте метод Word Document.Hyperlinks.Add для объекта Range, содержащего текст, чтобы добавить URL-адрес. Смотри: https://docs.microsoft.com/en-us/office/vba/api/word.hyperlinks.add

...