Excel VBA循环遍历outlook html中的所有超链接并复制到excel

Question

您好，我已经编写了一些 vba 代码来循环浏览文件夹中的所有电子邮件，但我正在努力寻找一种方法来查找超链接。将超链接复制到 A 列中的下一个空行。将超链接下方的文本复制到 B 列。然后查找下一个超链接并重复该过程。目前我的代码复制了电子邮件中的所有内容，并且超链接显示的是实际链接而不是可见的文字。

代码

Option Explicit
Sub Get_Google_Alerts_From_Emails()
Sheet1.Select
ActiveSheet.Cells.NumberFormat = "@"
Application.DisplayAlerts = False
Dim oHTML As MSHTML.HTMLDocument: Set oHTML = New MSHTML.HTMLDocument
Dim ObjOutlook As Object
Dim MyNamespace As Object
Dim i As Integer
Dim j As Long
Dim abody() As String
Dim strSubject As String
Dim k
Dim x
Dim google_text As String

Dim strPattern As String
Dim strReplace As String
Dim strInput As String
Dim objRegex As Object
Set objRegex = CreateObject("vbscript.regexp")
Dim regEx As New RegExp
strPattern = "\s+"
strReplace = " "
x = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row


Set ObjOutlook = GetObject(, "Outlook.Application")

Set MyNamespace = ObjOutlook.GetNamespace("MAPI")
k = MyNamespace.GetDefaultFolder(6).Folders("_Google_Alerts").Items.Count
For i = k To 1 Step -1
On Error GoTo vend
strSubject = MyNamespace.GetDefaultFolder(6).Folders("_Google_Alerts").Items(i).Subject

If strSubject Like "*Google*" Then GoTo google:

GoTo notfound

google:
abody = Split(MyNamespace.GetDefaultFolder(6).Folders("_Google_Alerts").Items(i).Body, vbCrLf)

For j = 0 To UBound(abody)
On Error GoTo error_google
If Len(abody(j)) > 1 Then
With regEx
.Pattern = "(https?[:]//([0-9a-z=\?:/\.&-^!#$;_])*)"
.Global = False
.IgnoreCase = True
End With

If regEx.Test(abody(j)) Then
google_text = regEx.Replace(abody(j), strReplace)
End If
With objRegex
.Pattern = "[A-Z]+"
.Global = True
.IgnoreCase = False
If .Test(abody(j)) Then
x = x + 1
Sheet1.Range("A" & x) = google_text
Sheet1.Range("C" & x) = strSubject
Else

End If
End With
End If
error_google:
Next j
MyNamespace.GetDefaultFolder(6).Folders("_Google_Alerts").Items(i).Move MyNamespace.GetDefaultFolder(6).Folders("_Google_Alerts_Complete")
GoTo comp
notfound:
comp:
Next i
vend:
Set ObjOutlook = Nothing
Set MyNamespace = Nothing
Application.DisplayAlerts = True
End Sub

Answer 1

目前我的代码复制了电子邮件中的所有内容，并且超链接显示的是实际链接而不是可见的文字。

这是一个非常基本的示例，可以实现您想要的。我正在使用Debug.Print 来显示数据。随意修改它以将其移动到 Excel。我正在从 Excel 运行此代码。

Option Explicit

Const olMail As Integer = 43

Sub Sample()
    Dim OutApp As Object
    Dim MyNamespace As Object
    Dim objFolder As Object
    Dim olkMsg As Object
    Dim objWordDocument As Object
    Dim objWordApp As Object
    Dim objHyperlinks As Object
    Dim objHyperlink As Object

    Set OutApp = CreateObject("Outlook.Application")
    Set MyNamespace = OutApp.GetNamespace("MAPI")

    '~~> Let the user select the folder
    Set objFolder = MyNamespace.PickFolder

    '~~> Loop through the emails in that folder
    For Each olkMsg In objFolder.Items
        '~~> Check if it is an email
        If olkMsg.Class = olMail Then
            '~~> Get the word inspector
            Set objWordDocument = olkMsg.GetInspector.WordEditor
            Set objWordApp = objWordDocument.Application
            Set objHyperlinks = objWordDocument.Hyperlinks

            If objHyperlinks.Count > 0 Then
               For Each objHyperlink In objHyperlinks
                   Debug.Print objHyperlink.Address '<~~ Address
                   Debug.Print objHyperlink.TextToDisplay '<~~ Display text
               Next
            End If
        End If
    Next
End Sub