使用电子邮件域单元格值获取电子邮件地址

Question

我从我的 Outlook 帐户中获取电子邮件地址。

现在我试图从收件箱中仅获取特定的电子邮件地址，例如Gmail.com 仅 returns gmail 地址。

我修改了使用数组临时存储地址然后与字符串进行比较的代码。更改代码后 returns 什么都没有（甚至没有错误）。

Option Explicit

Sub GetInboxItems()

Dim ol As outlook.Application
Dim ns As outlook.Namespace
Dim fol As outlook.Folder
Dim I As Object
Dim mi As outlook.MailItem
Dim N As Long
Dim val As String
Dim MyArray() As String, MyString As String, J As Variant, K As Integer

Dim MyAs As Variant
Dim Awo As Variant

MyString = Worksheets("Inbox").Range("D1")
MyArray = Split(MyString, ";")

Application.ScreenUpdating = False
Set ol = New outlook.Application
Set ns = ol.GetNamespace("MAPI")
Set fol = ns.GetDefaultFolder(olFolderInbox)

'Dim inputSheet As Worksheet
'Dim aCellOnInputSheet As Range
'Dim inputDateCell As Range
'Dim userSheetName As String

'Set cod = ThisWorkbook.Worksheets("Inbox")
'Set aCellOnInputSheet = cod.Range("D1")
'userSheetName = aCellOnInputSheet.Value

Range("A3", Range("A3").End(xlDown).End(xlToRight)).Clear

N = 2
For Each I In fol.Items
    If I.Class = olMail Then
        Set mi = I
        
        N = N + 1
        If mi.SenderEmailType = "EX" Then
        
            MyAs = Array(mi.Sender.GetExchangeUser().PrimarySmtpAddress)
        
            For Each Awo In MyAs
                If InStr(MyString, Awo) > 0 Then
                    Cells(N, 1).Value = mi.Sender.GetExchangeUser().PrimarySmtpAddress             
                    Cells(N, 2).Value = mi.SenderName
                    Exit For
                End If
            Next
        '    Cells(N, 1).Value = mi.Sender.GetExchangeUser().PrimarySmtpAddress  
        '   Cells(N, 2).Value = mi.SenderName
                  
        Else
            MyAs = Array(mi.SenderEmailAddress)
                       
            For Each Awo In MyAs
                If InStr(MyString, Awo) > 0 Then          
                    Cells(N, 1).Value = mi.SenderEmailAddress
                    Cells(N, 2).Value = mi.SenderName 
                    Exit For
                End If
            Next   
        End If
    End If
Next I

Application.ScreenUpdating = True
End Sub

获取所有电子邮件地址会有问题。除了定义的电子邮件域，我不想公开任何电子邮件域。

Answer 1

在 Instr 中对第 n 行进行操作和切换变量的最小更改就足够了。

这还展示了如何在一个域中删除数组。

Option Explicit

Sub GetInboxItems_SingleDomain()

' Early binding - reference to Microsoft Outlook XX.X Object Library required
Dim ol As Outlook.Application
Dim ns As Outlook.Namespace
Dim fol As Outlook.Folder

Dim folItm As Object
Dim mi As Outlook.MailItem
Dim n As Long

Dim myString As String
Dim myAddress As String

myString = Worksheets("Inbox").Range("D1")  ' gmail.com
'Debug.Print myString

Application.ScreenUpdating = False

Set ol = New Outlook.Application
Set ns = ol.GetNamespace("MAPI")
Set fol = ns.GetDefaultFolder(olFolderInbox)

Range("A3", Range("A3").End(xlDown).End(xlToRight)).Clear

n = 3

' If slow, limit the number of items in the loop
' e.g. 
' strFilter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:fromemail" & Chr(34) & " like '%" & myString & "'"

For Each folItm In fol.Items

    If folItm.Class = olMail Then
    
        Set mi = folItm
        
        If mi.SenderEmailType = "EX" Then
            myAddress = mi.Sender.GetExchangeUser().PrimarySmtpAddress
        Else
            myAddress = mi.SenderEmailAddress
        End If
        'Debug.Print myAddress
        
        'The bigger text on the left
        ' In general, not necessarily here, keep in mind case sensitivity
        If InStr(LCase(myAddress), LCase(myString)) > 0 Then
            Cells(n, 1).Value = myAddress
            Cells(n, 2).Value = mi.SenderName
            n = n + 1
        End If
        
    End If
    
Next folItm

Application.ScreenUpdating = True

Debug.Print "Done."

End Sub

使用电子邮件域单元格值获取电子邮件地址

Fetching email addresses with email domain cell value

arrays

excel

outlook

vba