最新の投稿

HKU\.Defaultはデフォルトユーザのものではない。

HKU\.DEFAULT(HKEY_USERS\.DEFAULT)は、あちこちで間違った認識をされている。HKU\.DEFAULT(HKEY_USERS\.DEFAULT)は、デフォルトユーザとかテンプレートユーザと呼ばれるアカウント(=今後作成されるユーザアカウントの初期設定)...

2020/04/06

Excel VBA+Outlookでメール送信

ExcelからOutlookを呼び出して、メールを送信するVBAを作ってみた。


下から9行目あたりの.sendをコメントアウトしておいて、下書きフォルダに溜め込んでおいて、内容を確認しながら送信しても良いかも。

Option Explicit


Sub test()
    Call Send_Mail("recipient@example.co.jp", "cc_recipient@example.co.jp", "bcc_recipient@example.co.jp", "test subject", "D:\tmp\aaaa.txt", "<HTML><BODY>test message</BODY></HTML>", "sender@example.com")
    '複数の宛先を入れる場合は、;で区切る。

End Sub

Sub Send_Mail(ByVal s_TO As String, ByVal s_CC As String, ByVal s_BCC As String, ByVal s_subject As String, ByVal s_PathToAttachment As String, ByVal s_body As String, ByVal s_sender As String)
    Dim objOutlook As Outlook.Application
    Dim myNamespace As Outlook.Namespace
    Dim myInbox As Variant
    Dim objMail As MailItem
    Dim b_isOutlookAvailable As Boolean

    Err.Clear

    On Error Resume Next
    
    Set objOutlook = GetObject(, "Outlook.Application")
    
    If Err.Number <> 0 Then
        Err.Clear
        Set objOutlook = CreateObject("Outlook.Application")
        b_isOutlookAvailable = False
    Else
        b_isOutlookAvailable = True
    End If
    
    Set myNamespace = objOutlook.getNamespace("MAPI")
    Set myInbox = myNamespace.getDefaultFolder(olFolderInbox)
    'Set myInbox = objOutlook.getNamespace("MAPI").getDefaultFolder(olFolderInbox)
    
    If b_isOutlookAvailable = False Then
        myInbox.Display
    End If
        
    objOutlook.WindowState = xlMinimized
    Set objMail = objOutlook.createitem(olMailItem)
    
    With objMail
        .to = s_TO
        .cc = s_CC
        .bcc = s_BCC
        .Subject = s_subject
        .HTMLbody = s_body
        .bodyFormat = olFormatHTML
        .attachments.Add (s_PathToAttachment)
        .SentOnBehalfOfName = s_sender
        .Save
        .Display
        'ここで、送信内容を確認させると良いかも↓
        '注意:これは例。少なくともobjOutlookを閉じるコードを入れること。
        'If MsgBox("メールの下書きができました。" & vbCrLf & "このメールを送信しますか?", vbYesNo) <> vbYes Then Exit Sub
        .send
    End With
    
    Set objMail = Nothing
    Set myInbox = Nothing
    Set myNamespace = Nothing
    Set objOutlook = Nothing
    'objOutlook.Quit
End Sub

参考
https://qiita.com/salmonosushi/items/7f63eb2e59d9c9cd01a6
https://www.slipstick.com/developer/code-samples/send-email-address-vba/

0 件のコメント:

コメントを投稿