VB实现自动发邮件功能时如何设置固定常量发件人邮箱地址

实现原理 #

当前代码通过Outlook COM对象创建邮件时，默认读取当前用户Outlook配置的默认账号作为发件人，只需显式指定邮件的发件人相关属性，即可绕开默认账号配置，实现所有用户运行程序都从固定邮箱发信。

前置配置要求：企业域/Office 365环境下，需要让邮箱管理员给所有使用程序的用户开放固定公共邮箱的「代表发送」权限，配置完成后用户无需在本地Outlook手动挂载该邮箱即可正常发信。

修改后完整可运行代码 #

' 全局常量：固定统一发件邮箱地址，修改为你实际要用的公共邮箱即可
Const FIXED_SENDER_MAIL As String = "your-fixed-sender@your-company.com"
Dim msgBody
Dim thresholdInfo
Dim receipAddress
Dim cc

' 补全Outlook相关常量值，避免未引用Outlook对象库时运行报错
Const olMailItem As Integer = 0
Const olImportanceLow As Integer = 0

thresholdInfo="xxx :"+CStr(Threshold.StatValue)+vbNewLine+vbNewLine
receipAddress="xx"
cc="xx"

SendMail receipAddress,msgBody+thresholdInfo,"xxxxxx"

Sub SendMail(recipient,msg,subject)
    
    Dim objOutlook 
    Dim objOutlookMsg 
    
    Set objOutlook = CreateObject( "Outlook.Application" )
    Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
    
    ' 指定固定发件人
    objOutlookMsg.SentOnBehalfOfName = FIXED_SENDER_MAIL
    
    objOutlookMsg.To = recipient
    objOutlookMsg.Cc = cc
    objOutlookMsg.Subject = subject
    
    objOutlookMsg.Body = msg
    
    objOutlookMsg.Importance = olImportanceLow
    
    objOutlookMsg.Send
    
    Set objOutlookMsg = Nothing
    Set objOutlook = Nothing
    
End Sub

备选方案（直接用指定账号发送，非代发） #

如果要求邮件发件人完全不显示代发标识，需要提前把固定公共邮箱添加到所有运行程序用户的Outlook账号配置中，将上述代码中指定发件人的行替换为以下逻辑即可，遍历Outlook已配置的账号匹配到固定邮箱后指定为发送账号：

' 替换objOutlookMsg.SentOnBehalfOfName = FIXED_SENDER_MAIL 这行即可
Dim acc
For Each acc In objOutlook.Session.Accounts
    If acc.SmtpAddress = FIXED_SENDER_MAIL Then
        Set objOutlookMsg.SendUsingAccount = acc
        Exit For
    End If
Next

注意事项 #

• 如果运行时提示权限错误，先确认当前登录用户是否已经获得固定公共邮箱的发送权限
• 不要硬编码邮箱账号密码走SMTP协议发送，企业环境下容易触发安全策略拦截、账号锁定问题，用Outlook原生接口走已授权的代发/账号发送兼容性最好
• 代码里补全了Outlook常量的实际值，不需要手动在VBA/VB工程里添加Outlook对象库引用，兼容所有版本的Outlook客户端

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