Access学習メモ 6-1. Access使ってOutlookメール①

職場では毎月、社内システムから自動抽出したExcel資料を顧客あてにメールでお届けする必要がある。

150社分ほどあるそのExcelは、何故か1ファイルずつフォルダに格納。

タイトルもコード表記のみでわかりにくい。

Accessを用いて

作業１：

フォルダに格納されたExcelをひとつひとつ取り出し、

「Mail添付用」フォルダに全部を集約

作業２：

各顧客に失礼なく、かつ間違いなく安全にメールをお届けできるよう、

添付ファイルであるExcelに、適切なファイル名をつけていく

(｡◕ˇдˇ​◕｡)・・・そもそもシステムがお客さま目線でキチンと機能してくれれば、本来ここまで手を焼かなくていいはずなんですけどね。

大金かけてエンジニアとアプリ開発契約して、生じたシステム不備のために、従業員の実働時間も結局、増えちゃって。

「Accessを使った業務効率化」って、ほんとうに素晴らしいことなのかな。

不完全なシステムの後始末に追われ、現場の負荷が増えてしまう状況は、会社にとって健全と言えるのかな。

Accessを使った開発も、かなりの集中力や忍耐を要する消耗試合だし、

本格的に取り組んでたら本業への影響大。

誰もが副業できる余裕を持ち合わせて仕事してるわけじゃないし、そんなに簡単なことじゃない。

Accessって時間を贅沢に使える管理職とか、内職しても叱られない勝ち組な社会人のために用意されたんだ、きっと。・・・(｡◕ˇдˇ​◕｡)

作業１：

システムからダウンロードされた各顧客向けExcelファイルは「事業所コード」別の個別フォルダに格納され、そのままではメール送信できないため、

ひとつひとつフォルダから取り出して、ひとつのフォルダ内にまとめて保管

作業2：

システムデフォルトのExcelタイトルが「事業所コード」のみの表記であり、一見どの顧客に宛てたExcelかわかりにくく誤送信の恐れがあるため、

Accessのマスタテーブルを用いて、顧客の「コード」と「名称」を紐づけて、

正式な事業所名がついた適切なファイル名に変換する

Excelでリスト化したものを

Accessのマスタテーブルとしてインポート

AccessのイベントModuleと標準Moduleを組み合わせてコード搭載

=========== メール作成イベントプロシージャ ===========

Option Explicit

Private Sub cmd_Excel_Click()

    ExtractAndRenameExcel

End Sub

==「ExtractAndRenameExcel」に紐づくプロシージャ(標準Module) ==

Option Compare Database

Public Sub ExtractAndRenameExcel()

    On Error GoTo ErrHandler

    Dim basePath As String

    Dim outPath As String

    Dim fso As Object

    Dim parentFld As Object

    Dim subFld As Object

    Dim f As Object

    Dim officeCode As String

    Dim officeName As String

    Dim safeOfficeName As String

    Dim newName As String

    ' Access事業所マスタ未登録を記録（最後に通知）

    Dim skippedMasterless As String

    skippedMasterless = ""

    basePath = CurrentProject.Path & "\"

    outPath = CurrentProject.Path & "\Mail添付用\"

    Set fso = CreateObject("Scripting.FileSystemObject")

    ' Mail添付用フォルダを自動作成

    If Not fso.FolderExists(outPath) Then

        fso.CreateFolder outPath

    End If

    Set parentFld = fso.GetFolder(basePath)

    For Each subFld In parentFld.SubFolders

        ' 出力フォルダ「Mail添付用」は作業用フォルダ対象外

        If subFld.Name <> "Mail添付用" Then

            officeCode = subFld.Name

            ' マスタから事業所名取得

            officeName = Nz(DLookup("事業所名", "T_送信先", _

                          "事業所コード='" & officeCode & "'"), "")

            ' Accessマスタテーブル未登録分は作成スキップ（後で通知）

            If officeName = "" Then

                If skippedMasterless <> "" Then skippedMasterless = skippedMasterless & ", "

                skippedMasterless = skippedMasterless & officeCode

                GoTo NextSubFld

            End If

            ' ファイル名安全化（禁止文字対策）

            safeOfficeName = SafeFileName(officeName)

            ' フォルダ内の Excel を探す（フォルダ内には1事業所1ファイルの前提、複数ファイルある場合は最新ファイル名で上書きされるので注意）

            For Each f In subFld.Files

            ' Excelの拡張子（xlsx,xlsm）を引き継ぐ前提（ファイル名変更前と変更後で拡張子を変えない）

            Dim ext As String

            If LCase(fso.GetExtensionName(f.Name)) = "xlsm" _

            Or LCase(fso.GetExtensionName(f.Name)) = "xlsx" Then

             ' Excel に"事業所別台帳一覧_" & 事業所コード & "事業所名" & 拡張子のタイトルをつけていく

            ext = LCase(fso.GetExtensionName(f.Name))

            newName = outPath & _

                      "事業所別台帳一覧_" & officeCode & "_" & _

                      safeOfficeName & "." & ext

                    ‘書き換え前のファイルのパスと書き換え後のファイルのパスが異なることを確認し、ファイル名上書きを実行、

‘万が一、同一パスを上書きしようとした場合は処理中止

                  If StrComp(f.Path, newName, vbTextCompare) <> 0 Then

                        ' ただし、その場合も次ファイルの処理実行を継続する

                        On Error Resume Next

                        fso.CopyFile f.Path, newName, True

                        Err.Clear

                        On Error GoTo ErrHandler

                    End If

                End If

            Next f

        End If

NextSubFld:

    Next subFld

    ' マスタ未登録をファイル名形成処理の完了後に通知

    If skippedMasterless <> "" Then

        MsgBox _

            "以下の事業所コードは事業所マスタ未登録のため、" & vbCrLf & _

            "メール対象外としてExcel出力をスキップしました。" & vbCrLf & vbCrLf & _

            skippedMasterless, _

            vbInformation, "お知らせ"

    End If

‘実行完了時

    MsgBox "Excel抽出・名称変換が完了しました。", vbInformation

    Exit Sub

‘実行中断時

ErrHandler:

    MsgBox "Excel出力処理でエラーが発生しました。" & vbCrLf & _

           Err.Number & " : " & Err.Description, vbCritical

End Sub