次のコードは、のインスタンスを定義し、送信準備が整ったMailItemを設定します。これは、電子メールと呼ばれるDictionary
オブジェクトを使用してTo、BCCなどのデータを埋め込むためのさまざまな情報を保持しますが、それらは自分の文字列などで置き換えることができます。これを私が書いた関数から引っ張り出して少し一般的にしました:
Public Function OL_SendMail()
Dim bOpenedOutlook, sComputer, iLoop, iAccount, sAttachArray, sAttachment
bOpenedOutlook = False
sComputer = "."
Dim oWMIService : Set oWMIService = GetObject("winmgmts:\\" & sComputer & "\root\cimv2")
Dim colItems : Set colItems = oWMIService.ExecQuery ("Select * from Win32_Process Where Name = 'outlook.exe'")
Dim oOutlook : Set oOutlook = CreateObject("Outlook.Application")
Dim oNamespace : Set oNamespace = oOutlook.GetNamespace("MAPI")
If colItems.Count = 0 Then
' Outlook isn't open, logging onto it...
oNamespace.Logon "Outlook",,False,True
bOpenedOutlook = True
End If
Dim oFolder : Set oFolder = oNamespace.GetDefaultFolder(olFolderInbox)
If EmailData("SendFrom") = "" Then
' default to first email account the user has access to
iAccount = 1
Else
' Checking to see if the account to send from is accessible by this user...
iAccount = 0
For iLoop = 1 To oOutlook.Session.Accounts.Count
If UCase(Trim(oOutlook.Session.Accounts.Item(iLoop))) = UCase(Trim(EmailData("SendFrom"))) Then
iAccount = iLoop
Exit For
End If
Next
If iAccount = 0 Then
sErrorMsg = "Cannot send email from specified account: " & EmailData("SendFrom") & " as this user doesn't appear to have access to it in Outlook!"
OL_SendMail = False
Exit Function
End If
End If
Dim oMailItem : Set oMailItem = oOutlook.CreateItem(olMailItem)
With oMailItem
Set .SendUsingAccount = oOutlook.Session.Accounts.Item(iAccount)
.To = EmailData("To")
.CC = EmailData("CC")
.BCC = EmailData("BCC")
.Subject = EmailData("Subject")
.Body = EmailData("Body")
sAttachArray = Split(EmailData("AttachmentPaths"), ";")
For Each sAttachment In sAttachArray
.Attachments.Add(sAttachment)
Next
.Recipients.ResolveAll
.Display ' debug mode - uncomment this to see email before it's sent out
End With
'Mail Item created and ready to send
'oMailItem.Send ' this is commented out so the mail doesn't auto send, allows checking of it!!
Set oMailItem = Nothing
Set oNamespace = Nothing
If bOpenedOutlook Then
'oOutlook.Quit
End If
Set oOutlook = Nothing
Set colItems = Nothing
Set oWMIService = Nothing
OL_SendMail = True
End Function