You need to enable JavaScript to run this app.
优惠活动
大模型
产品
解决方案
定价
更多

Outlook VBA实现共享邮箱直接发邮件,去除‘代表发送’标识

从共享邮箱直接发送邮件(非代表发送)的问题求助

已为Outlook所用账户配置共享邮箱的读取和管理权限及发送权限,特意未配置「代表发送权限」,但通过编程发送邮件时,收件方始终看到「代表发送」标识。先后尝试以下三种方案均未解决问题:


方案1:直接创建邮件并设置Sender

Public Sub test()

    Dim outApp As Outlook.Application
    Dim objOutlookMsg As Outlook.MailItem
    Dim objOutlookRecip As Recipient
    Dim Recipients As Recipients
    Dim addrEntry As Outlook.AddressEntry
    Dim addrEntries As Outlook.AddressEntries
    Dim nameSpace As Outlook.nameSpace
    Dim addrLists As Outlook.AddressLists
    Dim uMailInbox As Outlook.Recipient
     
    Set outApp = CreateObject("Outlook.Application")
    Set objOutlookMsg = outApp.CreateItem(olMailItem)
    Set nameSpace = outApp.GetNamespace("MAPI")
    Set addrLists = nameSpace.Session.AddressLists
    
    Set addrEntry = addrLists.Item("Global Address List").AddressEntries.Item("testSender")

    Set Recipients = objOutlookMsg.Recipients
    Set objOutlookRecip = Recipients.Add("testReceiver@testdomain.com")
    objOutlookRecip.Type = 1
    
    objOutlookMsg.Sender = addrEntry
    
'    Debug.Print objOutlookMsg.SentOnBehalfOfName
    
    objOutlookMsg.Subject = "Testing this macro"
    objOutlookMsg.HTMLBody = "Testing this macro" & vbCrLf & vbCrLf
    
    For Each objOutlookRecip In objOutlookMsg.Recipients
        objOutlookRecip.Resolve
    Next
    
    objOutlookMsg.Display
    objOutlookMsg.Send
    
    Set outApp = Nothing

End Sub

方案2:添加共享邮箱至Outlook账户列表后发送

将共享邮箱账户添加到Outlook的账户列表中,使用该账户直接发送邮件,问题依旧存在。


方案3:从共享邮箱发件箱创建邮件项

Public Sub test2()

    Dim outApp As Outlook.Application
    Dim trgtStore As Outlook.Store
    Dim trgtFolder As Outlook.Folder
    Dim emailItem As Outlook.MailItem
    Dim recip As Outlook.Recipient
    Dim addrEntry As Outlook.AddressEntry
    Dim addrLists As Outlook.AddressLists
    Dim nameSpace As Outlook.nameSpace
    
    Set outApp = CreateObject("Outlook.Application")
    Set trgtStore = outApp.Session.Stores("testSender")
    
    Set trgtFolder = trgtStore.GetDefaultFolder(4) ' olFolderOutbox = 4
    Set emailItem = trgtFolder.Items.Add
    
    Set nameSpace = outApp.GetNamespace("MAPI")
    Set addrLists = nameSpace.Session.AddressLists
    
    Set addrEntry = addrLists.Item("Global Address List").AddressEntries.Item("testSender")
    
    With emailItem
        
        Set recip = .Recipients.Add("testReceiver@testdomain.com")
        recip.Type = 1 'olTo = 1  olOriginator = 0 olCC = 2 olBCC = 3
        .Subject = "Testing this macro"
        .HTMLBody = "Testing this macro" & vbCrLf & vbCrLf
        .Sender = addrEntry
        .Display
        .Send
        
    End With
    
End Sub

所有方案均未解决问题,收件端始终显示「代表发送」标识,恳请提供可行的解决方案。

内容的提问来源于stack exchange,提问作者David

相关产品推荐
方舟 Agent Plan

超全模态模型 × Harness 升级,最新支持 Deepseek-V4.1-Flash、GLM-5.3 系列、Doubao-Seedream-5.0-pro、Kimi-K3 (部分), 限时 9.9 元起

最近更新时间:2026.08.11 06:55:45