Excel/VBA/Samples/自動メール作成 の変更点

https://cloudroid.work:443/pukiwiki/index.php?Excel/VBA/Samples/%E8%87%AA%E5%8B%95%E3%83%A1%E3%83%BC%E3%83%AB%E4%BD%9C%E6%88%90

[ トップ ]   [ 編集 | 差分 | バックアップ | 添付 | リロード ]   [ 新規 | 一覧 | 単語検索 | 最終更新 | ヘルプ | ログイン ]

• 追加された行はこの色です。
• 削除された行はこの色です。
• Excel/VBA/Samples/自動メール作成 へ行く。
• Excel/VBA/Samples/自動メール作成 の差分を削除

---

#author("2020-06-10T00:32:11+09:00","ldap:pandora"," pandora")
#author("2020-06-11T22:27:01+09:00","ldap:pandora"," pandora")
[[Excel/VBA/Samples]]
* 手順 [#wcfa7240]
** 準備 [#hec3014b]
+ 参照設定~
ExcelからOutlookを動かす為に、ライブラリを読み込む設定をします。~
#br
Excelの開発タブから【VisualBasic】を選択します。~
&ref(vba_sample0.png);~
開いたエディタのツールタブの【参照設定】を選びます。~
&ref(vba_sample1.png);~
Microsoft Outlook 14.0 Object Libliry にチェックを入れます。~
※versionが新しいと14.0 の部分が16.0だったりします。14.0の部分は変動するとversionによって変わると思ってください。~
&ref(vba_sample2.png);
+ 必要シートの作成
++ MailTemplate シートの作成~
下記のセルに設定内容を記載します。~
[名前]はメール作成時に、置換されます。~
※灰色背景文は変更しないでください。データ入力位置も変更しないでください。~
&ref(vba_sample4.png);~
++ Data シートの作成~
送信先情報を設定します。~
※1行目は必須項目なので、変更しないでください。~
&ref(vba_sample5.png);~~
+ 添付ファイル設定~
Excelと同じフォルダに「image」というフォルダを作成する。~
&ref(vba_sample9.png);~~
作成したimageフォルダの中に画像ファイルを入れて、ファイル名(拡張子含む）をimageカラムに設定する。
** VBAソース [#f3683c77]
#highlighter(Perl){{
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)
For Each mail In folder.Items
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


}}

* Sample [#gef9d785]
以下の手順で実行します。~
+ 開発タブ→マクロ~
&ref(vba_sample6.png);~
+ sendEmailを選択し、実行~
&ref(vba_sample7.png);~
** 実行結果 [#nf974cc6]
&ref(vba_sample8.png);~

       

Site admin: anonymous

PukiWiki 1.5.1 © 2001-2016 PukiWiki Development Team. Powered by PHP 7.4.33. HTML convert time: 0.009 sec.