适配Microsoft Outlook/新Outlook版本的邮件发送VBA代码优化需求

一、核心优化思路 #

• 先识别用户当前运行的Outlook版本（旧版/新版），或是否已有旧版Outlook在后台运行
• 仅在必要时主动启动旧版Outlook，发送完成后仅关闭我们启动的实例，避免强制关闭用户正在使用的客户端
• 针对New Outlook用户，因新版暂不支持完整VBA自动化，补充提示说明

二、版本识别与进程判断代码 #

1. 检查是否有旧版Outlook在运行 #

通过进程路径区分新旧版本（旧版在Office安装目录，新版在WindowsApps目录）：

Function IsOldOutlookRunning() As Boolean
    Dim objWMIService As Object, colProcesses As Object, objProcess As Object
    Set objWMIService = GetObject("winmgmts:\\.\root\cimv2")
    Set colProcesses = objWMIService.ExecQuery("SELECT * FROM Win32_Process WHERE Name = 'OUTLOOK.EXE'")
    
    For Each objProcess In colProcesses
        ' 旧版Outlook路径包含Office16目录，新版无此特征
        If InStr(objProcess.ExecutablePath, "Office16\OUTLOOK.EXE") > 0 Then
            IsOldOutlookRunning = True
            Exit Function
        End If
    Next
    IsOldOutlookRunning = False
End Function

2. 判断默认Outlook版本 #

通过注册表读取默认邮件客户端配置：

Function IsNewOutlookDefault() As Boolean
    Dim regPath As String, regValue As String
    regPath = "HKEY_CURRENT_USER\Software\Microsoft\Office\16.0\Outlook\Options\General\DefaultMailClient"
    On Error Resume Next
    regValue = GetSetting("", regPath, "")
    On Error GoTo 0
    IsNewOutlookDefault = (regValue = "NewOutlook")
End Function

三、优化后的邮件发送主流程 #

Sub SendRegistrationEmail()
    Dim olApp As Object, olMail As Object
    Dim weStartedOutlook As Boolean
    
    ' 优先复用已运行的旧版Outlook
    If IsOldOutlookRunning() Then
        Set olApp = GetObject(, "Outlook.Application")
        weStartedOutlook = False
    Else
        ' 无旧版运行时，启动旧版Outlook实例
        Set olApp = CreateObject("Outlook.Application")
        weStartedOutlook = True
    End If
    
    ' 以下替换为你的原有邮件生成/数据附加逻辑
    Set olMail = olApp.CreateItem(0)
    With olMail
        .To = "收件人邮箱"
        .Subject = "注册数据提交"
        .Body = "以下是最新注册数据：" & vbCrLf & vbCrLf
        ' 复制工作表数据到邮件正文
        ThisWorkbook.Sheets("注册数据").Range("A1:D10").Copy
        .GetInspector.WordEditor.Range.Paste
        .Send
    End With
    
    ' 仅关闭我们主动启动的Outlook实例
    If weStartedOutlook Then
        olApp.Quit
    End If
    
    ' 释放对象
    Set olMail = Nothing
    Set olApp = Nothing
    
    ' 针对New Outlook默认用户的提示（可选）
    If IsNewOutlookDefault() And weStartedOutlook Then
        MsgBox "已通过旧版Outlook完成邮件发送，若需使用New Outlook发送，请手动复制数据到邮件中。"
    End If
End Sub

四、关键说明 #

• weStartedOutlook标记确保不会关闭用户正在使用的旧版Outlook客户端
• 版本判断采用进程路径+注册表双重验证，准确性更高
• New Outlook目前不支持完整VBA自动化，因此仍需依赖旧版完成自动发送

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