添加电子邮件地址列表以打开电子邮件项目

Question

我的代码创建 Outlook 邮件项目并根据特定条件填充电子邮件地址列表。

我希望代码检查当前是否有打开的邮件项目，然后将地址列表添加到 .cc 项目。

Private Sub CommandButton15_Click()

    Dim OutApp As Object
    Dim OutMail As Object
    Dim emailRng As Range, cl As Range
    Dim sTo As String
    
    Set emailRng = Worksheets("Emails").Range("G4:G200")
    
    For Each cl In emailRng
        If cl.Value <> "" Then
        sTo = sTo & ";" & cl.Offset(, 1).Value
        End If
    Next
    
    sTo = Mid(sTo, 2)
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
        .To = sTo
        .Display
    End With
    On Error GoTo 0

End Sub

Answer 1

尝试下面的代码，我添加了一个

Select Case

，它具有各种逻辑，具体取决于您打开的 Outlook 邮件的数量。 我为代码添加了一些注释，使其有意义。

修改代码

Private Sub CommandButton15_Click()

    Dim OutApp As Object
    Dim OutMail As Object
    Dim OutInspector As Object
    Dim OutOpenObjCount As Long, i As Long, EmailMsgCount As Long
    
    Dim emailRng As Range, cl As Range
    Dim sTo As String
    
   
    Set emailRng = Worksheets("Emails").Range("G4:G200")
    
    For Each cl In emailRng
        If cl.Value <> "" Then
            sTo = sTo & ";" & cl.Offset(, 1).Value
        End If
    Next
    sTo = Mid(sTo, 2)
                
    ' --- Check if there's an Open Email Message ---
    
    ' check if Outlook already open
    On Error Resume Next
    Set OutApp = GetObject(, "Outlook.Application")
    On Error GoTo 0
    If OutApp Is Nothing Then
        ' create Outlook object before the loop
        Set OutApp = CreateObject("Outlook.Application")
    End If
    
    EmailMsgCount = 0 ' reset count
    
    ' check number of Outlook open objects, include msg, meetings, contacts
    OutOpenObjCount = OutApp.Inspectors.Count
        
    For i = 1 To OutOpenObjCount
        Set OutInspector = OutApp.Inspectors.Item(i)
    
        ' check if type of outlook item is a message
        If OutInspector.CurrentItem.Class = 43 Then ' Numeric value of olMail
            EmailMsgCount = EmailMsgCount + 1 ' increase count of open email messages
            Set OutMail = OutInspector.CurrentItem
        End If
    Next i
    
    ' - Main Logic depending of # of Open Messages in Outlook
    Select Case EmailMsgCount
        Case Is > 1 ' more than 1 open message --> can't determin automaticaal which one to refer to
            MsgBox "You have " & EmailMsgCount & " open email messages in Outlook"
    
        Case 0 ' none open --> create new Message
            ' your original code goes here
            Set OutMail = OutApp.CreateItem(0)                
            With OutMail
               .to = sTo
        
               .Display
            End With
           
        Case 1 ' Use the only 1 message open            
            With OutMail
               .to = .to & ";" & sTo  ' CONCAT new Addresses to existing email addresses
        
               .Display
            End With
                
    End Select

End Sub