Option Explicit
Option Base 0
Global gCancel As Boolean
Dim olApp As Outlook.Application
const A列 = 1
const B列 = 2
const C列 = 3
const D列 = 4
const E列 = 5
Sub メール送信()
gCancel = False
Set olApp = New Outlook.Application
Dim n As Long, rtn As VbMsgBoxResult
'件数チェック
Dim 件数 As Long: 件数 = 0
While Not IsEmpty(Cells(件数 + 2, A列))
Cells(件数 + 2, E列).ClearContents
件数 = 件数 + 1
Wend
If vbYes <> MsgBox(prompt:="メール送信を開始しますか？" + vbCrLf + "（メール件数：" & 件数 & "）", Buttons:=vbQuestion + vbYesNo + vbSystemModal, Title:=ThisWorkbook.name) Then
MsgBox prompt:="中止しました。", Buttons:=vbOKOnly + vbCritical, Title:=ThisWorkbook.name
Exit Sub
End If
Dim startTime As Double
Dim endTime As Double
Dim lapTime As Double
startTime = Timer()
' Load UserForm1
' UserForm1.Caption = ThisWorkbook.name
' UserForm1.ProgressBar1.Min = 0
' UserForm1.ProgressBar1.Max = 件数
' UserForm1.ProgressBar1.Value = 0
' UserForm1.Label1.Caption = "0"
' UserForm1.Label3.Caption = "/ " & Format(件数, "#,###")
' UserForm1.Show vbModeless
Dim row As Long: row = 2
While Not IsEmpty(Cells(row, A列))
If gCancel Then
If vbYes = MsgBox(prompt:="メール送信を中止しますか？", Buttons:=vbYesNo + vbQuestion + vbSystemModal, Title:=ThisWorkbook.name) Then
' UserForm1.Hide
GoTo ErrExit
End If
gCancel = False
End If
lapTime = Timer()
' UserForm1.ProgressBar1.Value = row - 1
' UserForm1.Label1.Caption = Format(row - 1, "#,###")
Application.StatusBar = Format(row - 1, "#,###") & " / " & Format(件数, "#,###") & " 件目を処理中"
DoEvents
Dim skip As Boolean: skip = False
Dim 宛先 As String: 宛先 = Cells(row, A列)
Dim adr_to As String: adr_to = ""
Dim adr_cc As String: adr_cc = ""
Dim adr_bcc As String: adr_bcc = ""
Dim adr As Long: adr = 1 'To:1, Cc:2, Bcc:3
If Len(宛先) > 0 Then
Dim ary As Variant: ary = Split(宛先, ";")
For n = LBound(ary) To UBound(ary)
Dim p As Long: p = InStr(ary(n), ":")
If p > 0 Then
If "to:" = LCase(Left(ary(n), 3)) Then
adr = 1
ElseIf "cc:" = LCase(Left(ary(n), 3)) Then
adr = 2
ElseIf "bcc:" = LCase(Left(ary(n), 4)) Then
adr = 3
End If
ary(n) = Mid(ary(n), p + 1)
End If
If adr = 1 Then
adr_to = adr_to & ary(n) & ";"
ElseIf adr = 2 Then
adr_cc = adr_cc & ary(n) & ";"
ElseIf adr = 3 Then
adr_bcc = adr_bcc & ary(n) & ";"
End If
Next
Else
Cells(row, E列) = "宛先無し"
skip = True
End If
If Len(Cells(row, B列)) = 0 Then
Cells(row, E列) = "メールタイトル無し"
skip = True
End If
If Len(Cells(row, C列)) = 0 Then
Cells(row, E列) = "本文無し"
skip = True
End If
Dim 添付ファイル As String: 添付ファイル = Cells(row, D列)
If Len(添付ファイル) = 0 Then
Cells(row, E列) = "添付ファイル無し"
skip = True
ElseIf Not fileExists(filepathStrip(添付ファイル)) Then
Cells(row, E列) = "添付ファイルが見つからない"
skip = True
End If
If skip Then GoTo Skip_mail
Call makeMailSend(row, adr_to, adr_cc, adr_bcc) 'メール作成＆送信
lapTime = Timer() - lapTime
Cells(row, E列) = lapTime
Skip_mail:
row = row + 1
Wend
' UserForm1.Hide
Application.StatusBar = False
endTime = Timer()
MsgBox prompt:="メール送信を完了しました" & vbCrLf & "(" & Format(endTime - startTime, "0.000") & "秒)", Buttons:=vbInformation + vbOKOnly + vbSystemModal, Title:=ThisWorkbook.name
Exit Sub
ErrExit:
If gCancel Then
MsgBox prompt:="メール送信を中止しました", Buttons:=vbOKOnly + vbCritical, Title:=ThisWorkbook.name
Else
MsgBox prompt:="エラーのため中止します", Buttons:=vbOKOnly + vbCritical, Title:=ThisWorkbook.name
End If
End Sub
Sub makeMailSend(row As Long, adr_to As String, adr_cc As String, adr_bcc As String)
Dim mailTemplate As MailItem
Set mailTemplate = olApp.CreateItem(olMailItem)
With mailTemplate
.To = adr_to
.CC = adr_cc
.BCC = adr_bcc
.subject = Cells(row, B列)
.body = Cells(row, C列)
.BodyFormat = olFormatPlain
.Attachments.Add Source:=filepathStrip(Cells(row, D列)), Type:=olByValue
.Send '送信する（保存しない）
' .Save '下書きに保存
' .Display 'プレビュー
' .Close olDiscard
End With
End Sub
Function filepathStrip(path As String) As String
filepathStrip = path
If Len(path) < 2 Then Exit Function
If Left(path, 1) = """" Then filepathStrip = Mid(path, 2, Len(path) - 2)
End Function
Function extractFileName(path As String) As String
Dim PathName As String, FileName As String, pos As Long
pos = InStrRev(path, "\")
extractFileName = IIf(pos = 0, path, Mid(path, pos + 1))
End Function
Function fileExists(f As String) As Boolean
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
fileExists = fso.fileExists(f)
Set fso = Nothing
End Function
