新版Outlook运行检测与邮件发送故障排查求助

你的问题根源在于新版Outlook（New Outlook）不再支持传统的Outlook.Application COM自动化接口，旧版的GetObject检测逻辑和邮件发送方式完全不适用于新版。

一、检测新版Outlook是否运行 #

新版和旧版Outlook的进程名都是Outlook.exe，可通过以下两种方式实现检测：

1. 通用进程检测 #

直接检查系统中是否存在Outlook.exe进程，适配新旧版本：

Function IsOutlookRunning() As Boolean
    Dim objWMIService As Object
    Dim colProcesses As Object
    
    Set objWMIService = GetObject("winmgmts:\\.\root\cimv2")
    Set colProcesses = objWMIService.ExecQuery("SELECT * FROM Win32_Process WHERE Name = 'Outlook.exe'")
    
    IsOutlookRunning = (colProcesses.Count > 0)
End Function

2. 区分版本的检测逻辑 #

如果需要明确区分是新版还是旧版Outlook，可先尝试旧版COM对象获取，失败时再检测进程：

Function GetOutlookStatus() As String
    Dim objApp As Object
    On Error Resume Next
    Set objApp = GetObject(, "Outlook.Application")
    
    If Err.Number = 0 Then
        GetOutlookStatus = "旧版Outlook运行中"
        Set objApp = Nothing
    Else
        Err.Clear
        Dim objWMIService As Object, colProcesses As Object
        Set objWMIService = GetObject("winmgmts:\\.\root\cimv2")
        Set colProcesses = objWMIService.ExecQuery("SELECT * FROM Win32_Process WHERE Name = 'Outlook.exe'")
        
        If colProcesses.Count > 0 Then
            GetOutlookStatus = "新版Outlook运行中"
        Else
            GetOutlookStatus = "Outlook未运行"
        End If
    End If
End Function

二、通过新版Outlook发送邮件 #

新版Outlook不支持传统COM自动化，推荐以下两种可行方案：

1. 命令行唤起邮件发送 #

利用Outlook命令行参数直接打开邮件编辑窗口，支持自动填充收件人、主题和内容：

Sub SendEmailViaCmd()
    Dim subject As String, toAddr As String, body As String
    subject = "测试邮件"
    toAddr = "recipient@example.com"
    body = "这是通过新版Outlook发送的测试邮件"
    
    ' 构造命令行参数（需对特殊字符做URL编码）
    Dim cmd As String
    cmd = "outlook.exe /c ipm.note /m " & toAddr & "?subject=" & URLEncode(subject) & "&body=" & URLEncode(body)
    
    ' 执行命令打开Outlook邮件窗口
    Shell cmd, vbNormalFocus
End Sub

' 辅助函数：实现URL编码
Function URLEncode(str As String) As String
    URLEncode = Replace(Replace(Replace(str, " ", "%20"), "@", "%40"), "&", "%26")
End Function

此方式会打开Outlook邮件编辑窗口，用户可确认后发送；若需完全静默发送，建议使用下方Graph API方案。

2. Microsoft Graph API（完全自动化推荐） #

新版Outlook基于Microsoft 365生态，通过Graph API可实现完全自动化的邮件发送，步骤如下：

1. 在Azure AD中注册应用，获取客户端ID、租户ID，并申请Mail.Send委派权限
2. 实现OAuth2授权流程获取访问令牌
3. 调用Graph API发送邮件：

Sub SendEmailViaGraph()
    Dim token As String, apiUrl As String
    Dim objHTTP As Object, jsonPayload As String
    
    ' 替换为实际获取的访问令牌
    token = "YOUR_ACCESS_TOKEN"
    
    ' 构造邮件JSON内容
    jsonPayload = "{" & _
        """message"": {" & _
            """subject"": ""Graph API测试邮件""," & _
            """body"": {" & _
                """contentType"": ""Text""," & _
                """content"": ""这是通过Microsoft Graph API自动发送的邮件""" & _
            "}," & _
            """toRecipients"": [{" & _
                """emailAddress"": {" & _
                    """address"": ""recipient@example.com""" & _
                "}" & _
            "}]" & _
        "}," & _
        """saveToSentItems"": true" & _
    "}"
    
    ' 调用Graph API发送邮件
    Set objHTTP = CreateObject("MSXML2.XMLHTTP.6.0")
    apiUrl = "https://graph.microsoft.com/v1.0/me/sendMail"
    
    objHTTP.Open "POST", apiUrl, False
    objHTTP.setRequestHeader "Authorization", "Bearer " & token
    objHTTP.setRequestHeader "Content-Type", "application/json"
    objHTTP.send jsonPayload
    
    ' 处理响应结果
    If objHTTP.Status = 202 Then
        MsgBox "邮件发送成功"
    Else
        MsgBox "发送失败：" & objHTTP.responseText
    End If
    
    Set objHTTP = Nothing
End Sub

注：OAuth2授权流程需引导用户登录Microsoft 365账号获取令牌，适合企业级应用场景。

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