◆Outlook VBA(Excel情報を読み込んでメールを自動送信する方法 その2)
Excel情報を読み込んでメールを自動送信する方法 その2を書いてみたいと思います。
送信情報を管理するExcel側と実際に送信するOutlook VBAです。
■Excel側
こんな感じにしてみました
■OutlookVBA側
moduleに以下のソースを貼り付けて実行してみましょう。
(1)メールの送信タイミングになるとこのダイアログを出します
(2)”はい”であれば処理を継続し、添付ファイル有無=”有”であればこのダイアログを出します
添付したいファイルを複数選択します
(3)送信フォルダに人数分のメールが作成されます
解説ですが、自動送信管理.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
最近のコメント