如何修改VBA代码向Outlook已打开邮件添加邮箱地址至CC栏

以下是修改后的代码，实现检测已打开的Outlook邮件并将生成的邮箱列表添加至CC字段，若没有已打开的邮件则新建邮件并设置CC：

Private Sub CommandButton15_Click()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim emailRng As Range, cl As Range
    Dim sCC As String
    Dim inspector As Object
    Dim foundOpenMail As Boolean
    
    ' 生成CC收件人列表
    Set emailRng = Worksheets("Emails").Range("G4:G200")
    For Each cl In emailRng
        If cl.Value <> "" Then
            sCC = sCC & ";" & cl.Offset(, 1).Value
        End If
    Next
    ' 移除开头多余的分号
    If sCC <> "" Then sCC = Mid(sCC, 2)
    
    ' 初始化Outlook应用：优先获取已运行实例，避免重复启动
    On Error Resume Next
    Set OutApp = GetObject(, "Outlook.Application")
    If Err.Number <> 0 Then
        Set OutApp = CreateObject("Outlook.Application")
    End If
    On Error GoTo 0
    
    ' 检测是否有已打开的邮件项
    foundOpenMail = False
    For Each inspector In OutApp.Inspectors
        ' 43代表Outlook邮件项类型，Visible确保窗口是打开状态
        If inspector.CurrentItem.Class = 43 And inspector.Visible Then
            Set OutMail = inspector.CurrentItem
            ' 追加CC列表，自动处理原有CC为空的情况
            If OutMail.CC <> "" Then
                OutMail.CC = OutMail.CC & ";" & sCC
            Else
                OutMail.CC = sCC
            End If
            foundOpenMail = True
            Exit For ' 仅处理第一个已打开邮件，如需批量处理可移除此行
        End If
    Next
    
    ' 无已打开邮件时，新建邮件并设置CC
    If Not foundOpenMail Then
        Set OutMail = OutApp.CreateItem(0)
        On Error Resume Next
        With OutMail
            .CC = sCC
            .Display
        End With
        On Error GoTo 0
    End If
    
    ' 释放对象
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

关键改动说明： #

• 变量语义优化：将原sTo重命名为sCC，明确变量用于存储CC收件人列表
• Outlook实例优化：优先调用已运行的Outlook进程，避免重复启动程序
• 已打开邮件检测逻辑：遍历Outlook的Inspectors集合，精准筛选出可见的邮件窗口
• CC字段智能追加：处理已有CC内容的情况，避免出现多余分号
• ** fallback机制**：未找到已打开邮件时，保留新建邮件的基础功能，保证代码兼容性

内容的提问来源于stack exchange，提问作者Zed