Question

我正在尝试运行一个代码，在该代码中我从邮件正文中复制可能包含某些超链接的内容。我想在创建单词文档时保留超链接

我尝试了各种方法，例如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

Answer 1

在处理电子邮件正文时使用Copy＆PasteAndFormat Method

快速示例为

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库参考，工具->参考

Answer 2

对包含文本的Range对象使用Word的Document.Hyperlinks.Add方法以添加URL。参见：https://docs.microsoft.com/en-us/office/vba/api/word.hyperlinks.add

如何从Outlook邮件正文中复制带有超链接的文本，并以正确的格式保存到Word文档中

2 个答案: