excel - Excel VBA循环遍历outlook html中的所有超链接并复制到excel
问题描述
嗨,我已经编写了一些 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
解决方案
目前我的代码复制了电子邮件中的所有内容,并且超链接显示的是实际链接而不是可见的措辞。
这是一个非常基本的例子来实现你想要的。我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
推荐阅读
- c# - SetActive(True) 在构建后不起作用,但在统一编辑器中可以
- mysql - UNION SELECT 和初始化用户定义的变量
- php - 如何在woocommerce单品页面的相关产品中显示随机产品?
- html - 具有突破布局的 CSS 网格。如何为不同页面上的内容设置不同的大小?
- typescript - 在联合类型中迭代子对象 - 打字稿
- python - 在 python 中从数据框(或电子表格)分配变量
- laravel - Laravel with() 一起使用表或变量名
- python - Python Selenium - 从动态页面中抓取表格
- python - 如何更改矩阵行中的最大和最小元素?
- mysql - 如何连接两个表,然后使用新的主键插入第三个表?