Excel VBA цикл по всем гиперссылкам в Outlook HTML и копировать в Excel - PullRequest
Новая
       18

Excel VBA цикл по всем гиперссылкам в Outlook HTML и копировать в Excel

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

Привет! Я написал некоторый код VBA, чтобы просмотреть все электронные письма в папке, но я изо всех сил пытаюсь найти способ поиска гиперссылки. скопируйте гиперссылку на следующую пустую строку в столбце A. скопируйте текст под гиперссылкой на столбец B. Затем найдите следующую гиперссылку и повторите процесс. В настоящее время мой код копирует все из электронной почты, а гиперссылки показывают фактическую ссылку, а не видимую формулировку.

enter image description here

код 

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

1 Ответ

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

В настоящее время мой код копирует все из электронного письма, и гиперссылки показывают фактическую ссылку, а не видимую формулировку.

Вот очень простой пример для достижения того, чего вы хотите. Я использую 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
...