' win32 MessageBoxA を使うための宣言
Declare PtrSafe Function MessageBox Lib "User32.dll" Alias "MessageBoxA" (ByVal hWnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal uType As Long) As Integer
Const MB_OK As Long = &H0
Const MB_OKCANCEL As Long = &O1
Const MB_YESNO As Long = &O4
Const MB_ICONHAND As Long = &O20
Const MB_ICONSTOP As Long = &O20
Const MB_ICONERROR As Long = &O20
Const MB_ICONQUESTION As Long = &O40
Const MB_ICONEXCLAMATION As Long = &O30
Const MB_ICONINFORMATION As Long = &O40
Const IDOK As Long = &O0
Const IDCANCEL As Long = &O1
Const IDABORT As Long = &O2
Const IDYES As Long = &O6
Const IDNO As Long = &O7
Const MB_TOP As Long = &H40000
Sub メール送信()
Dim ol As Outlook.Application
Dim ml, sh
' 連続送信すると、ウェイトを入れないと CreateObject("Outlook.Application") を失敗することがあるようです。
Application.Wait [Now() + "00:00:00.1"]
Set ol = CreateObject("Outlook.Application")
Set sh = Sheets("メール設定")
Set ml = ol.CreateItem(0)
With ml
If sh.Range("D2").Value = "" Then
MsgBox "TO が空欄です。この項目を無視します。", vbOKOnly + vbCritical, "確認"
Exit Sub
End If
' 基本情報
.BodyFormat = 2 ' 1: Text, 2: HTML, 3:リッチテキスト
.To = sh.Range("D2").Value
.Cc = sh.Range("D3").Value
.Bcc = sh.Range("D4").Value
.Subject = sh.Range("D5").Value
' 署名 を退避。後述の .HtmlBody で戻します。
.Display ' "署名" を signatureString へコピーするために一旦メールを表示する必要があるようです。
signatureString = .HtmlBody
' 添付ファイル
If sh.Range("D6").Value <> "" Then
Dim v, i
v = Split(sh.Range("D6").Value, ", ")
For i = LBound(v) To UBound(v)
.Attachments.Add ThisWorkbook.Path & "\" & v(i)
Next i
End If
' 補足： .BodyFormat でどれを選択していても、ここで .HtmlBody を使うと強制的に HTML 形式へ変更されるようです。
.HtmlBody = "<div style=""font-family:游ゴシック; font-size:11pt;"">" & sh.Range("D7").Value & "</div>" & signatureString
Application.Wait [Now() + "00:00:00.5"]
' メール送信確認
' メッセージボックスを最上位（トップモスト）表示したいので、Win32 の MessageBoxA を使用します。
ret = MessageBox(0, "メール送信しますか？", "確認", MB_YESNO + MB_ICONQUESTION + MB_TOP)
If ret = IDYES Then
.Send
Else
.Delete
End If
' こちら、VBA版の MsgBox による確認ダイアログです。
' If MsgBox("メール送信しますか？", vbYesNo + vbQuestion + vbMsgBoxSetForeground + vbDefaultButton2, "確認") = vbYes Then
' .Send
' Else
' .Delete
' End If
End With
' オブジェクトを開放
Set ml = Nothing
Set ol = Nothing
Set sh = Nothing
End Sub
Sub 一斉メール送信()
Dim i, sh
Dim wrkTo, wrkCc, wrkBcc
Set sh = Sheets("メール設定")
' To list 作成
For i = 5 To Cells(Rows.Count, "C").End(xlUp).Row
wrkTo = wrkTo & Cells(i, "C").Value & ";"
Next i
' Cc list 作成
For i = 5 To Cells(Rows.Count, "D").End(xlUp).Row
wrkCc = wrkCc & Cells(i, "D").Value & ";"
Next i
' Bcc list 作成
For i = 5 To Cells(Rows.Count, "E").End(xlUp).Row
wrkBcc = wrkBcc & Cells(i, "E").Value & ";"
Next i
sh.Range("D2").Value = wrkTo
sh.Range("D3").Value = wrkCc
sh.Range("D4").Value = wrkBcc
Call メール送信
End Sub
Sub 連続メール送信()
Dim i, wrk, sh
Set sh = Sheets("メール設定")
For i = 5 To Cells(Rows.Count, "C").End(xlUp).Row
sh.Range("D2").Value = Cells(i, "C").Value
sh.Range("D3").Value = Cells(i, "D").Value
sh.Range("D4").Value = Cells(i, "E").Value
Call メール送信
Next i
MsgBox "全てのメール送信を完了しました。", vbOKOnly + vbInformation, "完了"
End Sub
' win32 MessageBoxA を使うための宣言
Declare PtrSafe Function MessageBox Lib "User32.dll" Alias "MessageBoxA" (ByVal hWnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal uType As Long) As Integer
Const MB_OK As Long = &H0
Const MB_OKCANCEL As Long = &O1
Const MB_YESNO As Long = &O4
Const MB_ICONHAND As Long = &O20
Const MB_ICONSTOP As Long = &O20
Const MB_ICONERROR As Long = &O20
Const MB_ICONQUESTION As Long = &O40
Const MB_ICONEXCLAMATION As Long = &O30
Const MB_ICONINFORMATION As Long = &O40
Const IDOK As Long = &O0
Const IDCANCEL As Long = &O1
Const IDABORT As Long = &O2
Const IDYES As Long = &O6
Const IDNO As Long = &O7
Const MB_TOP As Long = &H40000
Sub メール送信()
Dim ol As Outlook.Application
Dim ml, sh
' 連続送信すると、ウェイトを入れないと CreateObject("Outlook.Application") を失敗することがあるようです。
Application.Wait [Now() + "00:00:00.1"]
Set ol = CreateObject("Outlook.Application")
Set sh = Sheets("メール設定")
Set ml = ol.CreateItem(0)
With ml
If sh.Range("D2").Value = "" Then
MsgBox "TO が空欄です。この項目を無視します。", vbOKOnly + vbCritical, "確認"
Exit Sub
End If
' 基本情報
.BodyFormat = 2 ' 1: Text, 2: HTML, 3:リッチテキスト
.To = sh.Range("D2").Value
.Cc = sh.Range("D3").Value
.Bcc = sh.Range("D4").Value
.Subject = sh.Range("D5").Value
.VotingOptions = "あり;なし"
' 署名 を退避。後述の .HtmlBody で戻します。
.Display ' "署名" を signatureString へコピーするために一旦メールを表示する必要があるようです。
signatureString = .HtmlBody
' 添付ファイル
If sh.Range("D6").Value <> "" Then
Dim v, i
v = Split(sh.Range("D6").Value, ", ")
For i = LBound(v) To UBound(v)
.Attachments.Add ThisWorkbook.Path & "\" & v(i)
Next i
End If
' 補足： .BodyFormat でどれを選択していても、ここで .HtmlBody を使うと強制的に HTML 形式へ変更されるようです。
.HtmlBody = "<div style=""font-family:游ゴシック; font-size:11pt;"">" & sh.Range("D7").Value & "</div>" & signatureString
Application.Wait [Now() + "00:00:00.5"]
' メール送信確認
' メッセージボックスを最上位（トップモスト）表示したいので、Win32 の MessageBoxA を使用します。
ret = MessageBox(0, "メール送信しますか？", "確認", MB_YESNO + MB_ICONQUESTION + MB_TOP)
If ret = IDYES Then
.Send
Else
.Delete
End If
' こちら、VBA版の MsgBox による確認ダイアログです。
' If MsgBox("メール送信しますか？", vbYesNo + vbQuestion + vbMsgBoxSetForeground + vbDefaultButton2, "確認") = vbYes Then
' .Send
' Else
' .Delete
' End If
End With
' オブジェクトを開放
Set ml = Nothing
Set ol = Nothing
Set sh = Nothing
End Sub
Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal
in the Software without restriction, including without limitation the rights
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
SOFTWARE.
