求教：如何VBA调用Outlook用不同发件人发送邮件

luyueyuelu

如题，求教各位老师，我现在outlook有两个不同的账户，希望能用vba调用不同的账户去发送邮件，求指教，我现在用的vba代码如下：Public Sub SendMail(ByVal strTo As String, ByVal strCC As String, ByVal strSubject As String, ByVal strBody As String, Optional ByVal strAttach1 As String, Optional ByVal strAttach2 As String, Optional ByVal strAttach3 As String)

Dim Outlook As Outlook.Application
Dim NewMail As mailitem

'Dim strTo, strCC, strSubject, strBody, strAttach As String

Dim otlk As Outlook.Application
Dim mailitem As Outlook.mailitem
Dim signature As String

Set Outlook = CreateObject("outlook.application")
Set NewMail = Outlook.CreateItem(olMailItem)

On Error GoTo errHandle
Set otlk = New Outlook.Application
Set mailitem = otlk.CreateItem(olMailItem)

signature = Environ("appdata") & "\Microsoft\Signatures\"
If Dir(signature, vbDirectory) <> vbNullString Then
    signature = signature & Dir$(signature & "*.htm")
Else:
    signature = ""
End If
signature = CreateObject("Scripting.FileSystemObject").GetFile(signature).OpenAsTextStream(1, -2).ReadAll

With mailitem
    .To = strTo
    .CC = strCC
    .Subject = strSubject
        If InStr("Important", strSubject) > 0 Then
        .Importance = olImportanceHigh
        End If
    .HTMLBody = strBody & signature
    If Len(strAttach1) <> 0 Then .Attachments.Add strAttach1
    If Len(strAttach2) <> 0 Then .Attachments.Add strAttach2
    If Len(strAttach3) <> 0 Then .Attachments.Add strAttach3
    .Send
End With
Do Until mailitem.Sent = True
    DoEvents
Loop

end sub

tyxvba7529

我以前也问过这个问题， 已解决。 请参考。
http://club.excelhome.net/thread-1130351-3-1.html">[url]http://club.excelhome.net/thread-1130351-3-1.html[/url]

1. ' 发送单个邮件的子程序
   
2. Sub SendMail(ByVal to_who As String, ByVal subject As String, ByVal body As String, ByVal attachement As String, ByVal CC As String)
   
3.     Dim ObjOL As Object
   
4.    Dim itmNewMail As Outlook.MailItem
   
5.     Dim mailaddress As String
   
6.     'Dim OutMail As Outlook.MailItem
   
7.     'Dim OutApp As Outlook.Application
   
8.     '引用Microsoft Outlook 对象
   
9.     Set ObjOL = CreateObject("Outlook.Application")
   
10.     Set itmNewMail = ObjOL.CreateItem(olMailItem)
    
11.     With itmNewMail
    
12.         .subject = subject  '主旨
    
13.         .body = body   '正文本文
    
14.         .To = to_who  '收件者
    
15.         .Attachments.Add attachement '附件,如果你不需要发送附件,可以把这一句删掉即可,Excel中的第四列留空,不能删哦
    
16.         .CC = CC  '抄送
    
17.         .SendUsingAccount = ObjOL.Session.Accounts.Item(2)
    
18.         .Display  '启动Outlook发送窗口
    
19.         'SetTimer 0, 0, 0, AddressOf WinProcA
    
20.     End With
    
21.     Set ObjOL = Nothing
    
22.     Set itmNewMail = Nothing
    
23. End Sub
    

复制代码

luyueyuelu

tyxvba7529 发表于 2016-11-22 10:40
我以前也问过这个问题， 已解决。 请参考。
http://club.excelhome.net/thread-1130351-3-1.html">http:// ...

多谢@tyxvba7529！！正在测试你给的建议。
以下为我目前解决的方法，也供你参考：
我放弃outlook object的引用方法，而是用了CDO方法。代码如下：
Function SendMailGmail(ByVal strFrom As String, ByVal strTo As String, ByVal strCC As String, ByVal strSubject As String, ByVal strBcc As String, ByVal strBody As String, Optional ByVal strAttach1 As String, Optional ByVal strAttach2 As String, Optional ByVal strAttach3 As String)
   
Dim NewMail As CDO.Message
Dim signature As String

Set NewMail = New CDO.Message
  
'Enable SSL Authentication
NewMail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
  
'Make SMTP authentication Enabled=true (1)
  
NewMail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
  
'Set the SMTP server and port Details
'To get these details you can get on Settings Page of your Gmail Account
  
NewMail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
  
NewMail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
  
NewMail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
  
'Set your credentials of your Gmail Account
signature = Environ("appdata") & "\Microsoft\Signatures\"

If strFrom = "xxxxxxxxxx11@gmail.com" Then
    NewMail.Configuration.Fields.Item _
    ("http://schemas.microsoft.com/cdo/configuration/sendusername") = "xxxxxxxxxx11@gmail.com"
      
    NewMail.Configuration.Fields.Item _
    ("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "xxxxxx"
   
    If Dir(signature, vbDirectory) <> vbNullString Then
        signature = signature & Dir$(signature & "xxx.htm")
    Else:
        signature = ""
    End If
    signature = CreateObject("Scripting.FileSystemObject").GetFile(signature).OpenAsTextStream(1, -2).ReadAll
ElseIf strFrom = "xxxxxxxxxx222@gmail.com" Then
    NewMail.Configuration.Fields.Item _
    ("http://schemas.microsoft.com/cdo/configuration/sendusername") = "xxxxxxxxxx222@gmail.com"
      
    NewMail.Configuration.Fields.Item _
    ("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "xxxxxx"
    If Dir(signature, vbDirectory) <> vbNullString Then
        signature = signature & Dir$(signature & "NewMail.htm")
    Else:
        signature = ""
    End If
    signature = CreateObject("Scripting.FileSystemObject").GetFile(signature).OpenAsTextStream(1, -2).ReadAll
End If
'Update the configuration fields
NewMail.Configuration.Fields.Update
   
'Set All Email Properties

  
With NewMail
  .Subject = strSubject
  .From = strFrom
  .To = strTo
  .cc = strCC
  .BCC = strBcc
  .HTMLBody = strBody & signature
  .BodyPart.Charset = "GB18030" 'Big5"
  .HTMLBodyPart.Charset = "GB18030" '"Big5"
  
    If Len(strAttach1) <> 0 Then .AddAttachment strAttach1
    If Len(strAttach2) <> 0 Then .AddAttachment strAttach2
    If Len(strAttach3) <> 0 Then .AddAttachment strAttach3
  
End With
  
  
NewMail.Send
'MsgBox ("Mail has been Sent")
  
'Set the NewMail Variable to Nothing
Set NewMail = Nothing
   
End Function

Bruce_xu

两位，问一下，如果想要获取第二帐号(非默认帐号）的收件箱,要怎么做?

sbansar

牛逼，学习，mark一下。

MaterFu

厉害了，老铁