Fatal编程技术网
  • vba/
  • Outlook VBA-选择发件人帐户时"；新电邮；创造

Outlook VBA-选择发件人帐户时"；新电邮；创造

vba email outlook

Outlook VBA-选择发件人帐户时"；新电邮；创造,vba,email,outlook,Vba,Email,Outlook,我使用Outlook设置了许多帐户（POP和IMAP）。当我写一封新的电子邮件时，我可以通过点击“发件人”按钮并选择合适的帐户来更改用来发送电子邮件的帐户。然而，我经常忘记这样做，然后从默认帐户发送电子邮件 我想能够做的是陷阱的新电子邮件的创建，并显示一个单选按钮列出所有帐户的形式，以便正确的发件人帐户可以选择之前，电子邮件起草 我可以创建带有帐户列表的表单，该列表将返回所选帐户。我还可以通过Inspecters_NewInspecter事件捕获新电子邮件的创建，但我在尝试设置发件人帐户时遇到问

我使用Outlook设置了许多帐户（POP和IMAP）。当我写一封新的电子邮件时，我可以通过点击“发件人”按钮并选择合适的帐户来更改用来发送电子邮件的帐户。然而，我经常忘记这样做，然后从默认帐户发送电子邮件

我想能够做的是陷阱的新电子邮件的创建，并显示一个单选按钮列出所有帐户的形式，以便正确的发件人帐户可以选择之前，电子邮件起草

我可以创建带有帐户列表的表单，该列表将返回所选帐户。我还可以通过Inspecters_NewInspecter事件捕获新电子邮件的创建，但我在尝试设置发件人帐户时遇到问题

我使用SendUsingAccount属性尝试了以下代码（在ThisOutlookSession中），但代码标记了一个错误，表示该属性为只读。任何想法都将不胜感激

Option Explicit

Private WithEvents objInspectors As Outlook.Inspectors

Private Sub Application_Startup()

  Set objInspectors = Application.Inspectors
  
End Sub

Private Sub objInspectors_NewInspector(ByVal Inspector As Inspector)

    Dim oEmail As Outlook.MailItem
    
    If TypeName(Inspector.CurrentItem) = "MailItem" Then
        Set oEmail = Inspector.CurrentItem
        Set oEmail.SendUsingAccount = GetUserSelectedInput '<<<<gives error 440 - property is read-only
    End If
    
End Sub

Private Function GetUserSelectedInput() As Account

    Dim oNs As Outlook.NameSpace
    
    Set oNs = Application.GetNamespace("MAPI")
    
    'The following line is selecting an arbitrary account for testing purposes
    'this will be replaced with the code to call a userform
    'that will return the selected account
    Set GetUserSelectedInput = oNs.Accounts.Item(2)
    
End Function

选项显式
以事件对象作为Outlook.Inspector的Private
私有子应用程序_启动（）
设置objInspectors=Application.Inspectors
端接头
私人子对象检查员\新检查员（ByVal检查员作为检查员）
将oEmail设置为Outlook.MailItem
如果TypeName（Inspector.CurrentItem）=“MailItem”，则
设置oEmail=Inspector.CurrentItem
Set oEmail.SendUsingAccount=GetUserSelectedInput'首先，事件不是访问邮件项目对象的正确位置。该事件发生在创建新的
检查器
对象之后，但在出现检查器窗口之前。因此，我建议等待当检查器成为活动窗口时触发的事件，无论是由于用户操作还是通过程序代码

你可能会发现这篇文章很有帮助

其次，该属性允许设置一个对象，该对象表示发送
MailItem
的帐户。例如，VBA示例代码显示了如何设置属性：


Sub SendUsingAccount()  
 Dim oAccount As Outlook.account  
 For Each oAccount In Application.Session.Accounts  
   If oAccount.AccountType = olPop3 Then  
     Dim oMail As Outlook.MailItem  
     Set oMail = Application.CreateItem(olMailItem)  
     oMail.Subject = "Sent using POP3 Account"  
     oMail.Recipients.Add ("someone@example.com")  
     oMail.Recipients.ResolveAll  
     Set oMail.SendUsingAccount = oAccount  
     oMail.Send  
   End If  
 Next  
End Sub



我尝试使用Inspector.Activate事件，但仍然存在SendUsingAccount属性为只读的相同问题。我还尝试使用MailIem.Open事件，但属性错误仍然是只读的

然后，在尝试写入SendUsingAccount属性之前，我修改了代码以保存电子邮件，这是可行的，但是，我并不完全满意这是一个特别优雅的解决方案，因为它强制将电子邮件保存为草稿。我无法理解的是，在保存之前，电子邮件处于什么“状态”，以及是否存在另一种解决方案，可以在不进行保存的情况下更改SendUsingAccount

我当前使用的代码如下所示。欢迎提出任何意见


Option Explicit

Private WithEvents objInspectors As Outlook.Inspectors
Private WithEvents objEmail As Outlook.MailItem

Public Sub test()
    Set objInspectors = Application.Inspectors
End Sub


Private Sub Application_Startup()

    Set objInspectors = Application.Inspectors
  
End Sub

Private Sub objInspectors_NewInspector(ByVal Inspector As Inspector)

    If TypeOf Inspector.CurrentItem Is Outlook.MailItem Then
        If Len(Inspector.CurrentItem.EntryID) = 0 Then
            Set objEmail = Inspector.CurrentItem
        End If
    End If
  
End Sub


Private Sub objEmail_Open(Cancel As Boolean)

    Dim objAcc As Outlook.Account

    With objEmail
        Set objAcc = GetUserSelectedInput()
        If objAcc Is Nothing Then
            Cancel = True
        Else
            .Save
            .SendUsingAccount = objAcc
        End If
    End With

    Set objAcc = Nothing
    Set objEmail = Nothing
    
End Sub

Private Function GetUserSelectedInput() As Outlook.Account

    Dim oNs As Outlook.NameSpace
    
    Set oNs = Application.GetNamespace("MAPI")
    
    'The following line is selecting an arbitrary account for testing purposes
    'this will be replaced with the code to call a userform
    'that will return the selected account
    Set GetUserSelectedInput = oNs.Accounts.Item(3)
    
End Function



好吧，这太傻了-我确信在设置SendUsingAccount属性时遇到了只读错误。感谢尼顿指出，没有它也能工作。因此，现在我有了完整的解决方案，它正在按要求工作。对于那些感兴趣的人，下面列出了完整的代码。它需要一个简单的表单（“SelectAccount”），该表单有一个框架（“frmeOptionButtons”）和两个按钮（“btnOk”和“btnCancel”）。框架和窗体将根据帐户数调整大小。它依赖于在打开表单时使用form.tag属性传递默认帐户地址，并在单击“确定”时传递所选地址

此OutlookSession的代码为：


Option Explicit

Private WithEvents objInspectors As Outlook.Inspectors
Private WithEvents objEmail As Outlook.MailItem

Public Sub test()
    Set objInspectors = Application.Inspectors
End Sub

Private Sub Application_Startup()
    Set objInspectors = Application.Inspectors
End Sub

Private Sub objInspectors_NewInspector(ByVal Inspector As Inspector)

    If TypeOf Inspector.CurrentItem Is Outlook.MailItem Then
        If Len(Inspector.CurrentItem.EntryID) = 0 Then
            Set objEmail = Inspector.CurrentItem
        End If
    End If
  
End Sub

Private Sub objEmail_Open(Cancel As Boolean)

    Dim objAcc As Outlook.Account

    With objEmail
        Set objAcc = GetUserSelectedInput(.SendUsingAccount.SmtpAddress)
        If objAcc Is Nothing Then
            Cancel = True
        Else
            .SendUsingAccount = objAcc
        End If
    End With

    Set objAcc = Nothing
    Set objEmail = Nothing
    
End Sub

Private Function GetUserSelectedInput(DefaultAccount As String) As Outlook.Account

    Dim objNs As Outlook.NameSpace
    Dim objAcc As Outlook.Account
    Dim SelectedAccount As String
 
    With SelectAccount
        .tag = LCase(DefaultAccount)
        .Show
        SelectedAccount = ""
        On Error Resume Next 'in case form is closed
        SelectedAccount = .tag
        On Error GoTo 0
    End With
    
    If SelectedAccount = "" Then Exit Function
    
    Set objNs = Application.GetNamespace("MAPI")
    
    For Each objAcc In objNs.Accounts
        If LCase(objAcc.SmtpAddress) = SelectedAccount Then
            Set GetUserSelectedInput = objAcc
            Exit For
        End If
    Next
    
    Set objAcc = Nothing
    Set objNs = Nothing

End Function



SelectAccount表单的代码为：


Option Explicit

Private Sub btnCancel_Click()
    Me.tag = ""
    Me.Hide
End Sub

Private Sub btnOk_Click()
    
    Dim optButton As MSForms.OptionButton

    Me.tag = ""

    For Each optButton In Me.frmeOptionButtons.Controls
        If optButton.value Then
            Me.tag = optButton.tag
            Exit For
        End If
    Next
    
    Me.Hide

End Sub

Private Sub UserForm_Activate()
    
    Dim optButton As MSForms.OptionButton
    Dim NoOfBtns As Integer
    Dim CaptionWidth As Long
    Dim AccList() As String
    Dim DefaulAccount As String
    Dim i As Integer
    
    DefaulAccount = LCase(Me.tag)
    
    AccList = GetAccountList
   
    NoOfBtns = UBound(AccList)
    
    Me.btnOk.top = Me.frmeOptionButtons.top + (NoOfBtns) * 18 + 4
    Me.btnCancel.top = Me.btnOk.top
    Me.Height = Me.btnOk.top + Me.btnOk.Height + 36
    
    With Me.frmeOptionButtons
        
        .Height = NoOfBtns * 18 + 2
            
        For Each optButton In .Controls
            .Controls.Remove (optButton.Name)
        Next
    
        CaptionWidth = .Width - 4
        
        For i = 1 To NoOfBtns
        
            Set optButton = .Controls.Add("Forms.OptionButton.1")
              
            With optButton
                .left = 0
                .top = 18 * (i - 1)
                .Height = 18
                .Width = CaptionWidth
                .tag = LCase(AccList(i))
                .Caption = AccList(i)
                .value = (.tag = DefaulAccount)
            End With

        Next

    End With
    
End Sub

Private Function GetAccountList() As Variant

    Dim objNs As Outlook.NameSpace
    Dim objAcc As Outlook.Account
    Dim strAcc() As String
    Dim i As Integer
    
    Set objNs = Application.GetNamespace("MAPI")
    
    i = 0
    For Each objAcc In objNs.Accounts
        i = i + 1
        ReDim Preserve strAcc(i)
        strAcc(i) = objAcc.SmtpAddress
    Next

    GetAccountList = strAcc
    
    Set objAcc = Nothing
    Set objNs = Nothing

End Function



不需要在我的机器上存钱。在您的案例中，第二个问题“保存前电子邮件处于什么状态”很可能出现在Eugene Astafiev的回答中。尝试将
.Save
替换为
Dim myInspector As Inspector
和
Set myInspector=.GetInspector
或
。Display
。