◆Outlook VBA（Excel情報を読み込んでメールを自動送信する方法 その２）

Excel情報を読み込んでメールを自動送信する方法 その２を書いてみたいと思います。
送信情報を管理するＥｘｃｅｌ側と実際に送信するOutlook VBAです。

■Excel側
こんな感じにしてみました


■OutlookVBA側
moduleに以下のソースを貼り付けて実行してみましょう。
（１）メールの送信タイミングになるとこのダイアログを出します
 

（２）”はい”であれば処理を継続し、添付ファイル有無＝”有”であればこのダイアログを出します
添付したいファイルを複数選択します
 

（３）送信フォルダに人数分のメールが作成されます



解説ですが、自動送信管理.xlsを読み込み、セルの情報を取得します。
自動送信管理.xlsには複数シート定義する前提で全てのシート分繰返し処理します。
各シートの次回送信予定日と当日を比較して送信タイミングであれば処理を続行します。
以下のソースではわざと条件をひっくり返して必ず実行するようにしています。
添付ファイル有無＝”有”の場合はファイル選択ダイアログを表示します
自動送信管理.xlsのメール情報に基づき、宛先分の送信メールを送信フォルダに格納していきます。
ここまでがソースの機能です。あとはoutlook起動時に”メール自動送信”を実行するように設定すればOKです。定義の仕方は、◆Excel VBA（ファイル起動と同時にマクロを実行）を参考にしてみてください。

Sub メール自動送信()
    Const XlsPath As String = "c:\outlook\自動送信管理.xls"
    Dim rtn As Boolean
   
    Dim myOlApp As New Outlook.Application
    Dim myOlExp As Outlook.Explorer
    Dim myOlSel As Outlook.MailItem

    Dim myCopiedItem As Object
    Dim myAttachments As Object
    Dim myNameSpace As Object
    Dim mySendFolder As Object
   
    Dim MsgTxt As String
    Dim a As String, b As String, c As String, d As String, e As String, f As String, g As String, h As String, q As String
    Dim l As String, m As String, n As String, o As String
    Dim Files As Variant, oF As Variant
    Dim myExlApp As Object, oNewWb As Object, oSel As Object
    Dim i As Integer, j As Integer
    Dim lMax As Long, lRow As Long, lColMax As Integer
    Dim lSubject As String
   
    'On Error GoTo p_Error
   
    '現在のｳｨﾝﾄﾞｳﾀｲﾄﾙ取得
    Dim Leng As Long, hWnd As Long, ret As Long, MyTitle As String
    hWnd = GetActiveWindow()
    MyTitle = String(250, Chr(10))
    Leng = Len(MyTitle)
    ret = GetWindowText(hWnd, MyTitle, Leng)
       
    Set myOlApp = CreateObject("Outlook.Application")
    Set myOlExp = myOlApp.ActiveExplorer
    Set myNameSpace = myOlApp.GetNamespace("MAPI")
    Set mySendFolder = myNameSpace.GetDefaultFolder(olFolderOutbox)     '送信トレイ
   
    'ﾌﾞｯｸ読み込み
    Set myExlApp = CreateObject("excel.Application")
    Set oNewWb = myExlApp.workbooks.Open(FileName:=XlsPath, ReadOnly:=False)
   
    Const cTitle As String = "C2"
    Const cHonbun As String = "C3"
    Const cKenshuNm As String = "C4"
    Const cEndDay As String = "C5"
    Const cSendMax As String = "C6"
    Const cSendSu As String = "C7"
    Const cSend As String = "C8"
    Const cNextDay As String = "C9"
    Const cTempFile As String = "C10"
    Const cName As Integer = 2
    Const cId As Integer = 4
    Const cTo As Integer = 3
    Const cCC As Integer = 5
    Const cKbn As Integer = 6
    Dim oWs
    Const cStRow As Integer = 13
   
    For Each oWs In oNewWb.worksheets
        If oWs.Name Like "■*" Then GoTo next_oWs
       
        a = oWs.Range(cTitle).Value
        b = oWs.Range(cHonbun).Value
        c = oWs.Range(cKenshuNm).Value
        d = oWs.Range(cEndDay).Value
        e = oWs.Range(cSendMax).Value
        f = oWs.Range(cSendSu).Value
        g = oWs.Range(cSend).Value
        h = oWs.Range(cNextDay).Value
        q = oWs.Range(cTempFile).Value
       
        If h <> "終了" And Format(h, "yyyymmdd") >= Format(Now(), "yyyymmdd") Then
'        If h <> "終了" And Format(h, "yyyymmdd") <= Format(Now(), "yyyymmdd") Then
            If vbNo = MsgBox("===========================================================================" & vbCrLf & vbCrLf & _
                                "  " & oWs.Name & "は【第" & f + 1 & "回】目の送信日になりました。" & vbCrLf & _
                                "  送信フォルダにメールを準備しますか？" & vbCrLf & vbCrLf & _
                             "===========================================================================" _
                             , vbQuestion + vbYesNo, "☆☆☆ 自動送信確認 ☆☆☆") Then GoTo next_oWs
        Else
            GoTo next_oWs
        End If
            
        '添付ファイル有無
        myExlApp.Visible = True
        If q Like "*有*" Then
            Files = myExlApp.GetOpenFilename("ﾌｧｲﾙ(*.*),*.*", , "--- 添付するﾌｧｲﾙを選択してください ---", "選択", True)
            If IsArray(Files) <> True Then
                q = "無"
                oWs.Range(cTempFile).Value = "無"
            End If
        End If
        myExlApp.Visible = False
       
        '受講者分送信メール作成
        lMax = oWs.cells(65500, 2).End(-4162).row
        lColMax = oWs.cells(cStRow - 1, 255).End(-4159).column + 1
        For lRow = cStRow To lMax
            If oWs.cells(lRow, cTo).Value <> "" And oWs.cells(lRow, cKbn).Value = "" Then
                l = oWs.cells(lRow, cName).Value
                m = oWs.cells(lRow, cId).Value
                n = oWs.cells(lRow, cTo).Value
                o = oWs.cells(lRow, cCC).Value
               
                'メール送信
                lSubject = c & " (" & lRow - cStRow + 1 & "/" & lMax - cStRow + 1 & ")"
                ret = SetWindowText(hWnd, lSubject & "を処理中...")
                Set myCopiedItem = Application.CreateItem(0)
                myCopiedItem.Subject = "【第" & f + 1 & "回】" & a
                myCopiedItem.Importance = olImportanceHigh
                myCopiedItem.Body = l & b
                myCopiedItem.To = n
                myCopiedItem.CC = o
                myCopiedItem.BCC = "bcc@hogehoge.co.jp"
               
                '添付ﾌｧｲﾙを貼り付ける
                If q Like "*有*" Then
                    For j = 1 To UBound(Files)
                        Set myAttachments = myCopiedItem.Attachments
                        myAttachments.Add Files(j), olByValue, 9999, Mid(Files(j), InStrRev(Files(j), "\") + 1)
                    Next
                End If
               
                '送信ﾄﾚｲに移動
                myCopiedItem.Save
                myCopiedItem.Move mySendFolder
               
               
                '送信実績設定
                oWs.cells(cStRow - 1, lColMax).Value = Format(Now(), "yyyy/mm/dd")
                oWs.cells(lRow, lColMax).Value = myExlApp.Application.username
               
            End If
        Next
       
        '送信実施回数更新
        oWs.Range(cSendSu).Value = oWs.Range(cSendSu).Value + 1
       
next_oWs:
    Next
   
   
p_Error:
    'ファイルクローズ
    oNewWb.Close SaveChanges:=True
   
    Set oF = Nothing
    Set oSel = Nothing
    Set myExlApp = Nothing
    Set oNewWb = Nothing
    Set myOlApp = Nothing
    Set myOlExp = Nothing
    Set myOlSel = Nothing
    Set myCopiedItem = Nothing
    Set myAttachments = Nothing
    ret = SetWindowText(hWnd, MyTitle)
End Sub

◆Outlook VBA（Excel情報を読み込んでメールを自動送信する方法 その１）

久しぶりのVBAネタです。
それもOutlookです。
仕事で１ヶ月に１度くらいの頻度で自動的にメールを送信したいという要望が出ました。送信要件が複数あり、送信タイミングもばらばらといった具合です。
そこで予めExcelにその情報を設定しておいて、マクロで毎日送信タイミングを確認すればよいと考えました。
以下がその仕様です。
■Excel側
送信要件毎にシートを分け、そのシートには、
   ・メールタイトル（送信要件）
   ・メール本文
   ・次回送信予定日
   ・添付ファイル有無
   ・送信者名（複数）
   ・送信者アドレス（複数）
   ・CCアドレス（複数）
   ・BCCアドレス（複数）
といった情報を持たせます

■OutlookVBA側
以前、◆Excel VBA（ファイル起動と同時にマクロを実行）で書いたPrivate Sub Application_Startup()にマクロを登録しておきます。これでOutlook起動時に実行してくれます。
そのマクロの処理ですが、以下の流れでいきます。
（１）Excelブックを読み込み
　　　　　↓
（２）全てのシート（送信要件）に対して次回送信予定日＜＝今日であれば
　　　　　↓
（３）送信者アドレス（複数）分のメールを新規作成して
タイトル、本文、To、Cc、Bcc、添付ファイルなどを設定して送信フォルダに格納する
　　　　　↓
（４）以前書いた◆Outlook VBA（Outlookのカスタマイズと配布方法）にある
"選択メールを一括送信"で一括送信する

いきなり送信は厳しいので送信フォルダにメールを作成し、確認したうえで
送信したいメールを選択した状態で一括送信マクロを実行するという構想です
（１）は以前書いた◆Outlook VBA（Outlookメール情報をExcel一覧化）を応用すれば
すぐに出来そうです。（４）は既に出来ているので実質（３）までを新規作成すればよいわけです。

ではマクロを作成してみましょう。
と、大分長くなりましたので実際の処理は次回その２に公開します。
それではまた。