2017年12月
          1 2
3 4 5 6 7 8 9
10 11 12 13 14 15 16
17 18 19 20 21 22 23
24 25 26 27 28 29 30
31            

« ◆Outlook VBA(Excel情報を読み込んでメールを自動送信する方法 その1) | トップページ | ■Word VBA(ツールの構成と配布方法について その1) »

2009年5月16日 (土)

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

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

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

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

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

(3)送信フォルダに人数分のメールが作成されます
3_2


解説ですが、自動送信管理.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情報を読み込んでメールを自動送信する方法 その1) | トップページ | ■Word VBA(ツールの構成と配布方法について その1) »

パソコン・インターネット」カテゴリの記事

コメント

大変参考になる情報ありがとうございます。

ひとつ質問なのですが、
このVBAは、お客様ごとに、
固有のメッセージを挿入することは可能でしょうか?

営業で、セミナー後にお客様固有のメッセージを
テンプレートにいれて送りたいなと思っております。

よろしくお願いします。

こんにちは、田中さん

お客様固有のメッセージ挿入ということですが、可能です。
Excel側の画像を見てもらえば分かるとおり、お客様情報の列に固有メッセージ欄を設けて、そこの情報を元に、メール本文に用意した置換文字列■■■などに差し込んでいくようなVBAを書けばよいはずです。

こういう情報探してました。

ありがとうございます!

とても素晴らしいサイトで、感謝しています。
メールでの仕事の効率がかなりUPしており、感謝感謝です。

で、さらに質問ですが。

田中さんの「お客様ごとに、固有のメッセージを挿入する」に加えて、「固有の添付ファイルを挿入する」といったことはできないでしょうか。

「メールの情報をエクセルに一覧化し、添付ファイルにリンクをつける」というマクロが紹介されていましたが、その逆のイメージで、エクセルの一覧データに、添付したいファイルのパスやリンクを書き込んで、送信者毎に異なるファイルを自動送信するというものです。

・画像データ(旅行等のスナップ写真を)を送信者毎に添付してあげる。
・ワード等で作られたお礼状を送信者毎に添付してあげる。

その他もろもろありますが、送信者毎に添付ファイルが異なるメールを送信するというシュチュエーションは(私個人的には)結構あります。

「ファイルを添付する」というVBAの書き方すらわからない初心者で、自分ではどうにもできず投稿しました。

聞くばかり、参考にするばかりで図々しいかもしれませんが、せめてヒントだけでもいただければ嬉しいです。

長々とすみません。

VBA初心者さん

おはようございます。平陽凛です。
ご希望の機能は、Excel情報を読み込んでメールを自動送信する方法その1、その2を参考にしてみて下さい。そのものずばりの内容を記載していると思います。

コメントを書く

(ウェブ上には掲載しません)

« ◆Outlook VBA(Excel情報を読み込んでメールを自動送信する方法 その1) | トップページ | ■Word VBA(ツールの構成と配布方法について その1) »