Access学習メモ 6-5. Access使ってOutlookメール⑤

(*σ_σ)「学習メモ6-2. Access使ってOutlookメール②」に掲載した

「メール作成」VBAコードの書き換え（不要コードの撤去）

顧客アドレス欄(F_送信先編集)に複数のメールアドレスが含まれていた場合、先頭の1送信先に限定しメールを作る仕様のコードを組んでた(下記)。

↓　↓

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

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)

コードの意味：

『セミコロンの位置(pos)を探し、その左側の文字列(posのひとつ前の文字まで)をメールアドレスとして拾い上げる』

1社につき1宛先と固定したい場合は上記内容で問題ないが、実務上はひとつの事業所につき複数の担当者にメールを一括送信すべきケースが多い。

これまで自分は、上記仕様をバグと勘違いしていた。

複数の宛先に対しメール起こしする際には、アドレス欄への複数アドレス記入は「セミコロン(;)」を外した状態でアドレス同士を連結させておき、Accessによるメール下書きが完成するのを待って、Outlookメールアドレス欄に直接「セミコロン(;)」を記入し、Access上で結合済みのアドレスを再び切り離すという、手間ひまをかけていた。(///Д///)

余分な処理コード数行を消すだけで解決できたはずなのに、なぜ今まで気づかなかったのか？

おバカなくせにラクをしたくて、AI頼みで作り上げたコードだからである。

複数の宛先引用が機能しない不具合には、開発当初から気づいていた。

AIと壁打ちし合いながら試行錯誤を重ねたが結局、原因は分からなかった。

当のAIはもちろん、自身がコード形成した出来事やその後の議論の数々などはとっくに忘却の彼方。

「作成者(あなたかココナラの出品者)が書いたコードの意味は恐らく…」などと、私はともかくココナラに責任転嫁を始めてしまった。

あなただってば　(*σ_σ)σ(ー""ー)"

AIにはそういうところがあるから、私のような初学者ほど要注意と肝に銘じている。

昨日、たまたまある顧客から「10名分ほど宛先を追加してほしい」との要望を受け、急を要するのでダメ元で当該AIに相談したら、「犯人はコレ」と、設計の矛盾を秒で指摘。

今回の顧客要求がなければ、当ブログのテーマはきっと生まれていない。

真剣に協議し合ってもトンチンカンな返答ばかりだったのに、後日あらためて相談すると、時として生まれ変わったように覚醒するのもAIの特徴。

【例】顧客から

①test111@～...

②test222@～...

③test333@～...

上記3者にメールを届けてほしいとの要請を受けた場合。

Outlookメール上、アドレスの区切りをセミコロン(;)で表現する必要がある。

F_送信先編集を開き、メールアドレスのフィールドに

①アドレス;②アドレス;③アドレスの要領にて記入。

※ココナラ規制によりdummyアドレスの記入すら出来ないので画像を。

現行のコードで「メール作成」ボタンを押下した場合、Outlookメールに反映されるアドレスは、冒頭の①test111@～...アドレスのみ。

そこで、下記コード(再掲)をコメントアウトする処置が必要。

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)

　↓　↓黄色枠ブロックのコードを取り除く

(*σ-σ)補足

コードを削除してしまうと、のちの状況に応じ、万が一「やっぱりあのコードが必要」となったとき困ってしまう。

そこで削除の代わりに、コードの行頭に「'(半角アポストロフィー)」をつけ、Accessが読み込むコード対象から除外する方法を私はよく使う。

「'(半角アポストロフィー)」を冒頭につけた時点で、当該コード文がコメントとみなされる。グリーン色に変わるのが目印。

Accessに不要なコードをスルーさせ、次のブロックへ進ませることができる。

その結果、無事に3つのアドレスがついたOutlookメールを立ち上げることに成功した。

(*σ-σ)補足

動画では、別フォーム画面を立ち上げた際、画面が最大化し、メニュー画面を覆う形となっている。

別フォーム画面を小窓サイズとし

メニュー画面と重ならないように工夫したい場合は

別フォーム画面をデザインビューで開き

フォーム全体のプロパティシートから設定を変更できる。

プロパティシート

［その他］

ポップアップ：はい

［書式］

自動中央寄せ：はい

顧客によっては、メールの通常宛先と共にCC(写)追加を希望するケースも。

この場合、アドレス帳マスタテーブル(T_送信先)にCC用のフィールドを加え、CC用のコードを付け足す必要がある。

余裕があれば、別の記事でチャレンジしてみたい。

【全文再掲】

※Accessとメール添付資料を同一フォルダ内にまとめていること前提

 ' =========== メール作成イベント（クリック） ===========

Option Explicit

'① システムからDL済の事業所別フォルダからExcelを取り出し、タイトルの事業所コードを正式な事業所名に変換

Private Sub cmd_Excel_Click()

 ExtractAndRenameExcel

End Sub

'② ①で作成した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有無チェック・メール作成」処理 ↓===

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

'事業所別台帳一覧（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

'【CC】If Len(ccAddr) > 0 Then oMail.CC = ccAddr

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

oMail.Attachments.Add str事業所別台帳kak一覧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

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

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