Excel/VBA/Samples/自動メール作成 のバックアップ(No.3)

Const C_KEY = "KEY-CD"
Const C_CO = "●会社名"
Const C_DPT = "部署名"
Const C_USR = "●姓"
Const C_NM = "●名"
Const C_MAIL = "E-mail"
Const C_IMG = "image"

Dim myDic As Object
Dim usrDic As Object

'---------------------------------------------------------------
'自動送信用のメールを作成する。
'---------------------------------------------------------------
'引数:なし
'返却値:なし
'---------------------------------------------------------------
Sub SendEmail()
On Error GoTo Err1
Dim objOutlook As Outlook.Application
Dim objMail As Outlook.MailItem
Dim wsMail As Worksheet
Dim wsSign As Worksheet
Dim mainBody As String
Dim path As String
Dim attachmentPath As String
Dim objInsp As Object
Dim objDoc As Object
Dim objSel As Object
Dim obj As Windows
path = ThisWorkbook.path
Set objOutlook = New Outlook.Application
Set wsMail = ThisWorkbook.Sheets("Data")
Set wsSign = ThisWorkbook.Sheets("MailTemplate")

 
'辞書登録
initDic wsSign, wsMail
'署名作成
makeSign wsSign
'メインメール作成
makeMain wsSign

 
For cnt = 2 To 30 Step 1
    Set objMail = objOutlook.CreateItem(olMailItem)
    If wsMail.Cells(cnt, usrDic.Item(C_KEY)) = "" Then
        GoTo CONTINUE
    End If
    objMail.To = wsMail.Cells(cnt, usrDic.Item(C_MAIL)).Value      'メール宛先
    objMail.Subject = getValue(wsSign.Cells(13, 2).Value)   'メール件名
    '送信済チェック
    If isSendMail(objOutlook, objMail) Then
        GoTo CONTINUE
    End If
    objMail.BodyFormat = olFormatRichText     'メールの形式
    mainBody = wsMail.Cells(cnt, usrDic.Item(C_CO)).Value & vbCrLf
    mainBody = mainBody & wsMail.Cells(cnt, usrDic.Item(C_DPT)).Value & vbCrLf
    mainBody = mainBody & wsMail.Cells(cnt, usrDic.Item(C_USR)).Value & wsMail.Cells(cnt, usrDic.Item(C_NM)).Value & " 様" & vbCrLf & vbCrLf
    mainBody = mainBody & getValue(wsSign.Cells(16, 6).Value & wsSign.Cells(1, 6).Value)
    
    num = inStrCustom(mainBody, C_IMG)
    mainBody = Replace(mainBody, "[" & C_IMG & "]", "")
    objMail.Body = mainBody       'メール本文
    objMail.Display
    If wsMail.Cells(cnt, usrDic.Item(C_IMG)) <> "" Then
        '--- 添付ファイルのパス ---'
        attachmentPath = path & "\image\" & wsMail.Cells(2, usrDic.Item(C_IMG)).Value
        
        '--- 添付ファイルを設定 ---'
        Set objInsp = objMail.GetInspector
        objInsp.Activate
        Set objDoc = objInsp.WordEditor
        If Not (objDoc Is Nothing) Then
            If objMail.BodyFormat <> olFormatPlain Then
                   objDoc.Range(num - 2, num - 2).InlineShapes.AddPicture attachmentPath, False, True
            End If
        End If
        '添付ファイルを付けるなら。。
        'Call objMail.Attachments.Add(attachmentPath)
    End If
    
    'メール送信するなら
    'objMail.Send
CONTINUE:
Next
'クリア
Set objOutlook = Nothing
Exit Sub
Err1:
    MsgBox "エラーNo.：" & Err.Number & vbCrLf _
   & "エラー内容：" & Err.Description, vbCritical, _
   "[error message]"
End Sub

'---------------------------------------------------------------
'シートからＰＧに必要な情報を辞書に設定する。
'---------------------------------------------------------------
'引数:設定シート1,設定シート2
'返却値:なし
'---------------------------------------------------------------
Sub initDic(sheet As Worksheet, sheet2 As Worksheet)
Set myDic = CreateObject("Scripting.Dictionary")
Set usrDic = CreateObject("Scripting.Dictionary")
'自分の情報を初期化
myDic.Add sheet.Cells(1, 1), sheet.Cells(1, 2)
myDic.Add sheet.Cells(2, 2), sheet.Cells(2, 3)
myDic.Add sheet.Cells(3, 2), sheet.Cells(3, 3)
myDic.Add sheet.Cells(4, 2), sheet.Cells(4, 3)
myDic.Add sheet.Cells(5, 2), sheet.Cells(5, 3)
myDic.Add sheet.Cells(6, 2), sheet.Cells(6, 3)
myDic.Add sheet.Cells(7, 2), sheet.Cells(7, 3)
myDic.Add sheet.Cells(8, 3), sheet.Cells(8, 4)
myDic.Add sheet.Cells(8, 3), sheet.Cells(8, 4)
myDic.Add sheet.Cells(8, 3), sheet.Cells(8, 4)
myDic.Add sheet.Cells(8, 3), sheet.Cells(8, 4)
myDic.Add "セイ", sheet.Cells(2, 4)
myDic.Add "メイ", sheet.Cells(3, 4)
'客先情報を取得用に初期化
usrDic.Add C_KEY, getNumColumn(C_KEY, sheet2)
usrDic.Add C_CO, getNumColumn(C_CO, sheet2)
usrDic.Add C_DPT, getNumColumn(C_DPT, sheet2)
usrDic.Add C_USR, getNumColumn(C_USR, sheet2)
usrDic.Add C_NM, getNumColumn(C_NM, sheet2)
usrDic.Add C_MAIL, getNumColumn(C_MAIL, sheet2)
usrDic.Add C_IMG, getNumColumn(C_IMG, sheet2)
End Sub

'---------------------------------------------------------------
'[文字]があれば、対応する文字で置換する。
'※置換対象は辞書登録で登録した文字列
'---------------------------------------------------------------
'引数:置換対象文字列
'返却値:置換後文字列
'---------------------------------------------------------------
Function getValue(ByVal str As String) As String
Dim Keys() As Variant
Keys = myDic.Keys
For i = 0 To UBound(Keys)
    str = Replace(str, "[" & Keys(i) & "]", myDic.Item(Keys(i)))
Next i
getValue = str
End Function

'---------------------------------------------------------------
'文字列が何番目のカラムにあるかを返す。
'---------------------------------------------------------------
'引数:検索文字,対象シート
'返却値:該当番号
'---------------------------------------------------------------
Function getNumColumn(ByVal columnStr As String, sheet As Worksheet) As Integer
sheet.Activate
sheet.Cells(1, 1).Activate
For i = 1 To 100 Step 1
    If sheet.Cells(1, i).Value = columnStr Then
        getNumColumn = i
        Exit Function
    End If
Next
Call Err.Raise(10001, "getNumColumn", "指定したカラムインデックスは存在しません「" & columnStr & "」")
End Function

 
'---------------------------------------------------------------
'メールの署名を作成する。
'---------------------------------------------------------------
'引数:対象シート
'返却値:なし
'---------------------------------------------------------------
Sub makeSign(sheet As Worksheet)
Dim sign As String
sign = sign & "---------------------------------------------------------------------" & vbCrLf
sign = sign & sheet.Cells(1, 2).Value & vbCrLf
sign = sign & sheet.Cells(7, 3).Value & "   " & sheet.Cells(8, 4).Value & vbCrLf
sign = sign & sheet.Cells(2, 3).Value & sheet.Cells(3, 3).Value & "(" & sheet.Cells(2, 4).Value & " " & sheet.Cells(3, 4).Value & ")" & vbCrLf
sign = sign & "〒" & sheet.Cells(9, 4).Value & " " & sheet.Cells(10, 4).Value & sheet.Cells(11, 4).Value & sheet.Cells(12, 4).Value & vbCrLf
sign = sign & "TEL:" & sheet.Cells(4, 3).Value & " FAX:" & sheet.Cells(5, 3).Value & vbCrLf
sign = sign & "携帯：" & sheet.Cells(6, 3).Value & "←お気軽にどうぞ！" & vbCrLf
sign = sign & "---------------------------------------------------------------------" & vbCrLf

sheet.Cells(1, 6).Value = sign
End Sub

 
'---------------------------------------------------------------
'メールの本文を作成する。
'---------------------------------------------------------------
'引数:対象シート
'返却値:なし
'---------------------------------------------------------------
Sub makeMain(sheet As Worksheet)
Dim main As String
Dim line As String
For i = 16 To 38 Step 1
line = sheet.Cells(i, 3).Value
main = main & line & vbCrLf
Next
sheet.Cells(16, 6).Value = main
End Sub

Function inStrCustom(ByVal str As String, ByVal findStr As String) As Integer
Dim num As Integer
Dim lines As Variant
lines = Split(str, vbCrLf)
For i = 0 To UBound(lines) Step 1
    If InStr(1, lines(i), findStr) > 0 Then
        num = i
        Exit For
    End If
Next
num = num + InStr(1, Replace(str, vbCrLf, ""), findStr)
inStrCustom = num
End Function

'---------------------------------------------------------------
'当日に同じ件名が同一宛先に送られたか判断する。
'---------------------------------------------------------------
'引数:outlook object , mail object
'返却値:boolean
'---------------------------------------------------------------
Function isSendMail(objOutlook As Outlook.Application, objMail As Outlook.MailItem) As Boolean
Dim mySpace As Outlook.Namespace
Dim folder As folder
Dim mail As Outlook.MailItem
Dim myItems As Outlook.Items
Set mySpace = objOutlook.GetNamespace("MAPI")
Set folder = mySpace.GetDefaultFolder(olFolderSentMail)
Set myItems = folder.Items
myItems.Sort "[ReceivedTime]", True
For Each mail In myItems
    If mail.Subject = objMail.Subject And mail.Recipients.Item(1).Address = objMail.To And DateDiff("d", mail.ReceivedTime, Date) = 0 Then
        isSendMail = True
        Exit Function
    ElseIf DateDiff("d", mail.ReceivedTime, Date) > 0 Then
        Exit For
    End If
Next mail
isSendMail = False
End Function

'---------------- 以下テスト用プログラム -----------------------
Sub testSign()
Dim wsSign As Worksheet
    Set wsSign = ThisWorkbook.Sheets("MailTemplate")
    makeSign wsSign
End Sub

Sub testMain()
Dim wsSign As Worksheet
    Set wsSign = ThisWorkbook.Sheets("MailTemplate")
    makeMain wsSign
End Sub