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