Access学習メモ 6-2. Access使ってOutlookメール②

学習メモ「6-1. Access使ってOutlookメール①」の続きです

(*σ-σ)VBAコード内に発信者メアドや参考URLが含まれるため、coconalaNGワードに抵触。もちろん架空だし、学習のためのガチネタなのでお許しを...

Accessファイルと①で作成した「Mail添付用」フォルダ、各種pdf資料は必ず同一ドライブ上に置く

============= メール作成イベントModule　=============

「②メール作成」コマンドのイベントプロシージャ

'② ①で作成したExcelおよび各資料を顧客あてOutlookメールに添付

Private Sub cmd_メール作成_Click()

    On Error GoTo ErrHandler

    ' 実行パラメータ

    Dim AccountIndex As Long: AccountIndex = 1

    Dim IntervalMs As Long: IntervalMs = 700

    ' 送信フロー制御

    Dim ShowConfirm As Boolean: ShowConfirm = True ' 送信前にプレビュー表示する

    Dim SaveToDrafts As Boolean: SaveToDrafts = False ' メール下書き自動保存は使わない

    ' 添付ON/OFF（メールに添付したいファイルを選択可）

    Dim UseAttach1 As Boolean: UseAttach1 = True ' 添付1：Excelを添付1として送付, 送る＝True,送らない＝False

    Dim UseAttach2 As Boolean: UseAttach2 = True ' 添付2：案内書pdfを添付2として送付,送る必要がなければFalse

    Dim UseAttach3 As Boolean: UseAttach3 = True ' 添付3：手順書pdfを添付3として送付,送る必要がなければFalse

    ' （Excel以外に資料を送付したい時は下段2Path/3Pathを有効化,不要なら下段とoMailブロック「oMail.Attachments.Add str事業所別台帳一覧Path」次行のPath消去）

    Dim Attach2Path As String

    Attach2Path = CurrentProject.Path & "\案内書.pdf"

    Dim Attach3Path As String

    Attach3Path = CurrentProject.Path & "\手順書.pdf"

    ' メッセージ未作成分抽出・グループ→作成順→事業所コードの順で並べる

    Dim rs As DAO.Recordset

    Set rs = CurrentDb.OpenRecordset( _

        "SELECT [グループ], [事業所コード], [事業所名], [メールアドレス], [作成済], [作成順] " & _

        "FROM [T_送信先] " & _

        "WHERE Nz([作成済], False) = False " & _

         "ORDER BY UCase(Trim([事業所コード]));", _

        dbOpenDynaset)

    ' Outlook準備（起動済み取得→未起動なら起動）

    Dim olApp As Object, acc As Object

    Set olApp = GetOutlookApp()

    If olApp Is Nothing Then

        MsgBox "Outlookアプリを起動できません。処理を終了します。", vbExclamation, "Outlook未準備"

        GoTo ExitPoint

    End If

    On Error Resume Next

    Set acc = olApp.Session.Accounts.Item(AccountIndex) ' 失敗時は既定

    On Error GoTo ErrHandler

    ' 本文・件名

    Dim styleBase As String, subj As String

    styleBase = "font-family:Meiryo, YuGothic, sans-serif; font-size:11pt; color:#222;"

    subj = "事業所別台帳一覧および案内書ご送付の件"

    Dim made As Long: made = 0

    Do While Not rs.EOF

    ' 値取得＋整形

    Dim office As String, addr As String

    office = Nz(rs.Fields("事業所名").Value, "")

    office = Trim$(Replace(Replace(Replace(office, vbCr, ""), vbLf, ""), vbTab, ""))

    addr = ParseEmail(rs.Fields("メールアドレス").Value)

    ' 宛名

    Dim salutation As String

    If Len(addr) > 0 And Len(office) > 0 Then

        salutation = "<p><b>" & HtmlEsc(office) & " 御中</b></p>"

    Else

        salutation = "<p><b>各位</b></p>"

    End If

    ' 本文＋署名

    Dim bodyHtml As String

    bodyHtml = BuildBody(styleBase, salutation)

'==============================

'事業所別台帳一覧（Excel）の存在チェック

'==============================

'送付の必要がない事業所はスキップして次の事業所のメール作成に進む

Dim fname As String

Dim str事業所別台帳一覧Path As String

fname = Dir(CurrentProject.Path & _

            "\Mail添付用\事業所別台帳一覧_" & rs!事業所コード & "_*.xlsm")

' Excelが無ければ、この事業所は完全スキップ

If fname = "" Then

    Debug.Print "SKIP（Excelなし）: "; rs!事業所コード

    GoTo ContinueLoop

End If

'str事業所別台帳一覧Path = 実在フォルダ + 実在ファイルのフルパスを代入

str事業所別台帳一覧Path = CurrentProject.Path & "\Mail添付用\" & fname

'==============================

'メール配信事業所のみ作成実行

'==============================

Dim oMail As Object

Set oMail = olApp.CreateItem(0)

If Not acc Is Nothing Then oMail.SendUsingAccount = acc

oMail.SentOnBehalfOfName = "[e-mail]"

oMail.Subject = subj

oMail.htmlBody = bodyHtml

If Len(addr) > 0 Then oMail.To = addr

' メール添付(添付ファイルを変更した場合は忘れず編集)

oMail.Attachments.Add str事業所別台帳一覧Path

oMail.Attachments.Add Attach2Path

oMail.Attachments.Add Attach3Path

' 表示 or 送信

oMail.Display ' 送信の場合は oMail.Send

'===================

' 作成済Check更新

'=================== 

  ' メール作成できたら made = made + 1

rs.Edit

rs!作成済 = True

rs.Update

made = made + 1 ' ここでカウントを更新

' メール5件ごとに継続有無をユーザーに問う

If made >= 5 Then

    Dim ans As VbMsgBoxResult

    ans = MsgBox( _

        "メール下書きを5件作成しました。" & vbCrLf & _

        "続けて次の5件を作成しますか？", _

        vbYesNo + vbQuestion, "確認")

    If ans = vbYes Then

        PauseMs 1745

    ' カウンタだけリセットして続行（Recordset は継続）

        made = 0

    Else

    ' いいえを選択した場合（終了案内を表示して終了）

                MsgBox "作成を終了します。すぐに送信しない場合は下書き保存をお願いします。", _

                       vbInformation, "案内"

「いいえ」を選択すると...

    ' Outlook上の自動保存対策：表示中のメールを下書きトレイに残さない

    oMail.Close 1 ' olDiscard

    Set oMail = Nothing

        Exit Sub

    End If

End If

 ' Excelデータが見当たらない(配信対象外)なら GoTo ContinueLoop, メールは作成せず次社のチェックに進む

ContinueLoop:

    Set oMail = Nothing

    rs.MoveNext

Loop

' ===== 作成結果チェック =====

If made = 0 Then

    MsgBox "通知対象事業所のチェックが完了しました。", _

           vbInformation, "お知らせ"

    GoTo ExitPoint

End If

ExitPoint:

    On Error Resume Next

    If Not rs Is Nothing Then rs.Close

    Set rs = Nothing

    Set acc = Nothing

    Set olApp = Nothing

    On Error GoTo 0

    Exit Sub

ErrHandler:

    Select Case Err.Number

        Case -2147023174, 462

            MsgBox "メール作成を再開するには、Outlookアプリ準備が必要です。" & vbCrLf & _

                   "Outlook を起動してから、もう一度実行してください。", _

                   vbExclamation, "Outlook未準備"

            Resume ExitPoint

        Case Else

            MsgBox "ERR " & Err.Number & " - " & Err.Description, vbExclamation, "エラー"

            Resume ExitPoint

    End Select

End Sub

' Outlook.Application を安全に取得（起動済み優先／未起動なら起動）

Private Function GetOutlookApp() As Object

    On Error Resume Next

    Dim app As Object

    Set app = GetObject(, "Outlook.Application")

    If app Is Nothing Then

        Set app = CreateObject("Outlook.Application")

    End If

    Set GetOutlookApp = app

End Function

' 宛名用：最低限のHTMLエスケープ

Private Function HtmlEsc(ByVal s As String) As String

    Dim t As String: t = Nz(s, "")

    t = Replace(t, "&", "&amp;")

    t = Replace(t, "<", "&lt;")

    t = Replace(t, ">", "&gt;")

    HtmlEsc = t

End Function

' ハイパーリンク/ mailto:/ 改行混入などからSMTPを抽出

Private Function ParseEmail(ByVal v As Variant) As String

    Dim s As String: s = Nz(v, "")

    s = Replace(Replace(Replace(s, vbCr, ""), vbLf, ""), vbTab, "")

    s = Replace(s, "　", "")

    s = Trim$(s)

    If s = "" Then ParseEmail = "": Exit Function

    ' 「表示#アドレス#…」形式に対応

    Dim p As Long: p = InStr(1, s, "#")

    If p > 0 Then

        s = Mid$(s, p + 1)

        p = InStr(1, s, "#")

        If p > 0 Then s = Left$(s, p - 1)

    End If

    ' mailto:/smtp: 除去

    If LCase$(Left$(s, 7)) = "mailto:" Then s = Mid$(s, 8)

    If LCase$(Left$(s, 5)) = "smtp:" Then s = Mid$(s, 6)

    ' 余分な括弧/引用符/山括弧

    s = Replace(s, "<", "")

    s = Replace(s, ">", "")

    s = Replace(s, """", "")

    s = Replace(s, "'", "")

    ' 区切り（; , 空白 など）は先頭だけ採用

    Dim pos As Long

    pos = InStr(1, s, ";"): If pos = 0 Then pos = InStr(1, s, ",")

    If pos = 0 Then pos = InStr(1, s, " ")

    If pos > 0 Then s = Left$(s, pos - 1)

    s = Trim$(s)

    If s Like "*@*.*" Then ParseEmail = s Else ParseEmail = ""

End Function

' 本文（Outlookで安全に解釈／宛名を先頭に差し込み）

Private Function BuildReferenceSection(styleBase As String) As String

    BuildReferenceSection = ""

End Function

Private Function BuildBody(ByVal styleBase As String, ByVal salutationHtml As String) As String

    Dim h As String

    h = "<html><body style=""" & styleBase & """>"

    h = h & salutationHtml

    h = h & "<p>暑中お見舞い申し上げます。<br>"

    h = h & "盛夏の折、貴社ますますご清栄のこととお喜び申し上げます。<br>"

    h = h & "平素は格別のご高配を賜り、厚く御礼申し上げます。</p>"

    h = h & "<p>今月分の貴社登録台帳一覧をお届けいたします。<br> "

    h = h & "情報公開に際しましては「案内書」をご活用いただけます。<br>"

    h = h & "Excel操作方法につきましては「手順書」にてご確認をお願いいたします。<br>"

    h = h & "<p>詳細情報を下記ホームページ上からご案内可能です。<br>"

    h = h & "<a href=""https://coconala.com/blogs/5424855"">https://coconala.com/blogs/5424855</a></p>"

    h = h & "</p>"

    h = h & "<p>お手数をおかけし申し訳ございませんが、何卒よろしくお願い申し上げます。</p>"

    h = h & "<p style=""text-align:right; margin:0; padding:0;""><span style=""display:inline-block; min-width:100%; text-align:right;"">以上</span></p>"

    ' ↓ 署名に続く

    h = h & BuildSignatureHtml(styleBase)

    h = h & "</body></html>"

    BuildBody = h

End Function

;σ＿σ)モジュール画面はこんな感じ

参考URLの綴り方は一見、誤記に見えますが正しい表記です

Outlookは色々制約があるようで、通常のURL表記だとうまく反映されません

' 指定ミリ秒待機（簡易）

Private Sub PauseMs(ByVal ms As Long)

    Dim t0 As Single: t0 = Timer

    Dim span As Single: span = ms / 1000#

    Do While Timer < t0 + span

        DoEvents

    Loop

End Sub

Private Function BuildSignatureHtml(ByVal styleBase As String) As String

    Dim s As String

    s = ""

    s = s & "<div style=""" & styleBase & " margin:0;"">"

    s = s & ":｡☆｡:ﾟ･*ﾟ:｡☆｡:ﾟ･*ﾟ:｡☆｡:ﾟ･*ﾟ:｡☆｡:ﾟ･*ﾟ:｡☆｡:ﾟ･*ﾟ<br>"

    s = s & "株式会社 ちび怪獣ズ <br>"

    s = s & "世話役 ちびメカ <br>"

    s = s & "〒XXX-xxxx 怪獣島 XXX村XXX丁目XXX番地<br>"

    s = s & "TEL: ****-**-**** / FAX: ****-**-****<br>"

    s = s & "E-mail:[e-mail]<br>"

    s = s & ":｡☆｡:ﾟ･*ﾟ:｡☆｡:ﾟ･*ﾟ:｡☆｡:ﾟ･*ﾟ:｡☆｡:ﾟ･*ﾟ:｡☆｡:ﾟ･*ﾟ<br>"

    s = s & "</div>"

    BuildSignatureHtml = s

End Function