[Excel VBA]日報をPDFファイルで出力、添付してメール送信する

この手のマクロはネット上にサンプルがたくさんありますが、それらのサンプルを基に機能を少し拡張してみました。長めの記事になりますがコードを紹介します。

「日報を送信する」なんてタイトルで釣ってみましたが、共有PCの送信専用ファイルとしても使えます。現場でデータを採取して入力→送信といった業務がある場合、メールクライアントを立ち上げずにメールを送信できるので作業者にも簡単に教えることができます。

ファイルもアップするので可能な方はダウンロードして下さい。会社でダウンロードが禁止されている方はコピペでも作れるので最後まで読んでみて下さい。

目次

拡張した機能

シートをPDFファイルで出力し、メールで送信するマクロです。Outlookを起動せずに処理を完結できます。ベースはネット上のサンプルですが、自分の仕事の都合に合わせて改変しました。

メールフォーム作成ユーザビリティを考慮してメール用のフォームを作成しました。

宛先選択…上司不在の場合、代理の人へ送信するのにアドレスを入力し直すのが面倒なので、宛先を複数件登録できるようにしました。

CC送信(1件のみ)…たまに上司から、別の人へのCC送信を指示される事があるので追加しました。

添付ファイルを追加…日報に付帯資料を求められる事があるので、別ファイルを添付できるようにしました。

テンプレート文編集可能(件名、本文)…普段は登録したテンプレ文で問題ありませんが、たまに一言付け加えたくなる事があります。登録したテンプレ文はそのままで、本文や件名を編集できるようにしました。

フォルダ自動生成…同一フォルダ内にファイルを保存し続けると、整頓が必要になってきます。煩わしいので月別フォルダを自動で生成、その中に保存するようにしました。

ダウンロード

免責事項を一読の上、理解いただける方のみダウンロードして下さい。

尚、著作権は放棄しませんが、改変やローカルなコミュニティでの配布は自由に行って下さい。くれぐれも自己責任でお願いします。

尚、本ファイルはxlsmファイル(マクロ機能付き)です。

VBAコード

プロジェクトは5つのモジュールで構成されています。

Sheetモジュール(2個)

Sheet2つ用意して下さい。設定用シートと日報シートです。シート名は自由に名前を付けて下さい。

オブジェクト名はそれぞれSheet1を「wsData」、Sheet2を「wsReport」とします(クリックで画像拡大します)。

wsDataシートの設定は以下の通りです。1行目はフィールド名とします。自由にフィールド名を設定して下さい。

STEP
メールアドレス設定

A,B列はメールアドレス用のフィールドです。A列がコンボボックスに表示される名前、B列がそのアドレスです。件数の制限はありません。

名前の定義が必要です。名前を「メール」にして、参照範囲を=OFFSET(Sheet1!$A$2,,,COUNTA(Sheet1!$A:$A)-1,2)とします。参照範囲を可変させているので空レコードは禁止です。

STEP
メールの件名テンプレート設定

C列はメールの件名です。サンプルは=TEXT(Sheet2!A1,”m/d”)&”日報_ひよこ”としています。日報シートのA1に入力する日付を利用して件名にしています。マクロに影響はないので自由に設定して下さい。

D列は本文です。セル内の改行(ALT+ENTER)を利用して記述します。

STEP
PDFファイル保存フォルダパス指定

E列はPDFファイルを保存するフォルダのパスです。E2セルを=”C:\Users\YOU\Documents\日報\” & TEXT(Sheet2!A1, “yyyymm”)として下さい。パス(赤字)部分は自由に設定して下さい。

日報シートのA1セルに入力した日付の西暦と月を自動でフォルダ名にして生成します。

STEP
PDFファイル名設定

F列はPDFファイルのフルパスです。F2セルを=E2&”\日報_& TEXT(Sheet2!A1, “yyyymmdd”) & “.pdf”とします。

フォルダ同様、日付をファイル名に利用しています。赤字部分はマクロには影響しません。自由に設定して下さい。

STEP
追加添付ファイル用テンポラリーセルを名前定義

G列は追加添付ファイル用のTMPセルです。名前を定義して下さい。名前を「添付ファイル名」に、参照範囲を=OFFSET(Sheet1!$G$2,,,COUNTA(Sheet1!$G:$G)-1)として下さい。

STEP
カレントディレクトリ指定

H,I列は添付ファイルを追加するときの「ファイルを開く」ダイアログで選択されるフォルダです。追加添付ファイルが特定のフォルダにある場合はそのパスを指定して下さい。

H列はドライブを、I列はフォルダパスを指定します。サンプルはCドライブのドキュメントフォルダを指定しています。

wsReportは日報シートです。セルA1を日付入力欄として使用します。後は自由にレイアウトして下さい。

標準モジュール

全部で7つのプロシージャがあります。全てUserForm1から呼び出されます。

VBEで「標準モジュール」を挿入し、コードをコピペして下さい。

'///1.定数風関数 保存フォルダパス///
Public Function GetSaveDir() As String
    GetSaveDir = wsData.Range("E2")
End Function

'///2.定数風関数 フルパス///
Public Function GetFilePath() As String
    GetFilePath = wsData.Range("F2")
End Function

'///3.ファイル上書き確認///
Public Function OverwriteFile(ByVal file_path As String) As Boolean
    Dim rc As Long

    If Dir(file_path) <> "" Then
        rc = MsgBox("ファイルが既に存在します。" & vbCrLf & "上書き保存しますか?", vbYesNo)
        Select Case rc
        Case vbYes
            Exit Function
        Case vbNo
            MsgBox "処理を中止しました"
            OverwriteFile = True
        End Select
    End If
End Function

'///4.月別フォルダ自動生成///
Public Function MakeDirectory(ByVal directory_path As String) As Boolean
    Dim rc As Long

    If Dir(directory_path, vbDirectory) = "" Then
        rc = MsgBox("保存用フォルダ「" & directory_path & "」がありません。作成しますか?", vbYesNo)
        Select Case rc
        Case 6
            MkDir directory_path
            MsgBox "フォルダ「" & directory_path & "」を作成しました"
            Exit Function
        Case 7
            MsgBox "処理を中止します"
            MakeDirectory = True
        End Select
    End If
End Function

'///5.PDF出力///
Public Sub OutputPDF(ByVal pdf_sheetname As Worksheet, ByVal pdf_filename As String)
    pdf_sheetname.ExportAsFixedFormat _
        Type:=xlTypePDF, _
        fileName:=pdf_filename, _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=True
End Sub

'///6.フルパスからファイル名を切り出し///
Public Sub GetAttachment(file_path As String)
    Dim pos As String
    pos = InStrRev(file_path, "\")  'filePathの文字列を後方から検索し、初めに見つかった「\」の位置を返す
    UserForm1.TextBox_Attachments.Value = Mid(file_path, pos + 1) 'pos以降の文字列を全て返す
End Sub

'///7.メール送信///
Public Sub SendMail(ByVal arg_mailaddress As String, ByVal arg_mailaddresscc As Variant, ByVal arg_subject As Variant, ByVal arg_body As Variant, ByVal arg_attachmentsname As Variant, ByVal arg_attachmentspath As Variant)
    Dim myOLApp As Object
    Dim myData As Object
    Dim r As Range
    Dim rc As String
    
    If IsNull(arg_mailaddresscc) Then arg_mailaddresscc = ""
    If wsData.Range("G2") = "" Then
        rc = MsgBox("件名:" & arg_subject & vbCrLf & "添付ファイル:" & arg_attachmentsname & vbCrLf & "でよろしいですか?", vbYesNo)
    Else
        rc = MsgBox("件名:" & arg_subject & vbCrLf & "添付ファイル:" & arg_attachmentsname & vbCrLf & "追加添付ファイル 有" & vbCrLf & "でよろしいですか?", vbYesNo)
    End If
    
    Select Case rc
    Case vbYes
        Set myOLApp = CreateObject("Outlook.Application") '可能なら参照設定推奨
        Set myData = myOLApp.CreateItem(0)  '0 = MailItemオブジェクト
        
        With myData
            .BodyFormat = 1  '1 = olFormatPlain:テキスト形式
            .To = arg_mailaddress
            .CC = arg_mailaddresscc
            .Subject = arg_subject
            .Body = arg_body
            .attachments.Add arg_attachmentspath   'デフォルト添付ファイル
            On Error Resume Next
            For Each r In Range("添付ファイル名")   '追加添付ファイル
                .attachments.Add r.Value
            Next
            .Send
        End With

        Set myData = Nothing
        Set myOLApp = Nothing
        MsgBox "メールを送信しました"
        
    Case vbNo
        MsgBox "送信を中止しました"
    End Select
End Sub

3.ファイル上書き確認、4.月別フォルダ自動生成

この記事で詳しく紹介しています。

5.PDF出力

7.メール送信

このプロシージャはWeb上にたくさん紹介記事があるのでここでは割愛。コードはCreateObject関数を使用していますが、可能なら参照設定推奨です。違いが気になる方はこちらの記事も読んでみて下さい。

プロシージャ中盤のSet myData = myOLApp.CreateItem(0)ですが、私の環境ではCreateItemの定数をアイテム名(OlMailItem)で指定するとエラーになりました(Microsoft Outlook 16.0 Object Libraryを参照設定すればエラーは出ませんが、それならそもそもCreateObject関数使いませんし)。

他サイトではアイテム名で指定する記述が散見されますが、おま環なのか間違いなのか分かりません。ともかく、紹介した記述でエラーが出ることはないと思います。

Bookモジュール

ファイルオープン時の処理、日報シートのアクティブ/非アクティブ時の処理、日報シートA1セルの更新時処理を記述しています。ThisWorkBookモジュールにコピペして下さい。

Private Sub Workbook_Open()
    If ActiveSheet.CodeName = "wsReport" Then
        UserForm1.Show vbModeless
        Range("A1").Activate
    End If
    
    Application.EnableEvents = False     'Bookオープン時はWorkbook_SheetChangeイベントを走らせたくないので
    wsReport.Range("A1").Clear
    Application.EnableEvents = True
    
    On Error Resume Next                 'Range("添付ファイル名")が空だとエラーになるので回避
    Range("添付ファイル名").Clear
End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    If Sh.CodeName <> "wsData" Then
        UserForm1.Show vbModeless
        Range("A1").Activate
        AppActivate Application.Caption  'フォーカスをユーザーフォームから移す
    End If
End Sub

Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
    If Sh.CodeName = "wsReport" Then UserForm1.Hide
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    If Sh.CodeName = "wsReport" Then
        If Intersect(Target, wsReport.Range("A1")) Is Nothing Then
            Exit Sub
        Else
            UserForm1.TextBox_Subject = wsData.Range("C2")
            Call GetAttachment(GetFilePath)
        End If
    End If
End Sub

Workbook_Open

入力データのクリアです。前回使用した日付と追加添付ファイルのパスをクリアします。

Workbook_SheetActivate

ユーザフォームの表示とフォーカスをフォームからシートに移す処理です。フォーカスがフォームに残ったままだとセルへの入力にワンクリック必要でイラっとするのでその対策です。

以前、フォームからフォーカスを外すのにWindowsAPISetFocus関数を使用したことがあります。

'API関数はDeclareステートメントで呼び出しグローバルで宣言する
Public Declare PtrSafe Function SetFocus Lib “user32” (ByVal hwnd As Long) As Long 'PtrSafe…64ビット対応

Sub demo1()
    SetFocus Application.hwnd
End Sub

今回もこれで、と思ったもののエラーが返されました。「オブジェクトモジュール(ThisWorkBookSheetモジュール)では使えません」との事。他に方法がないか探していたところ、MicroSoftのコミュニティでヒットしました。

モードレスなUserFormから下記のようにするのはどうでしょうか?(試していないので上手くいくかどうか分かりませんが・・・)

ActiveSheet.Range(“C5”).Select

AppActivate Application.Caption

https://answers.microsoft.com/ja-jp/msoffice/forum/all/excel/d3888bc5-70b8-4b4f-8eb4-ee4b07a358ae

力業感が否めません(誉め言葉)が、狙った通りの動きになりました。

Workbook_SheetChange

日報シートのセルA1(日付入力)を変更すると、関連する「件名」と「添付ファイル名」を更新する処理です。

Formモジュール

「ユーザーフォーム」を挿入し、ツールボックスを使ってレイアウトします。各コントロールの名称と配置は画像を参照して下さい。

コピペ用に各コントロールのオブジェクト名を列挙します。

ComboBox_ToComboBox_CCTextBox_SubjectTextBox_AttachmentsTextBox_AttachAddTextBox_LetterBodyCommandButton_ClipFileCommandButton_TrashCommandButton_SendMail

ComboBox_CCですが、下に「必要があれば追加して下さい」のラベルと白地のラベルを重ねています。ComboBox_CCが一番上になるように書式で順序を設定して下さい。「必要があれば追加して下さい」のラベルは少し小さめにすると位置の調整が楽になります。

コードはこれをコピペして下さい。

'///1.初期化///
Private Sub UserForm_Initialize()
    With ComboBox_To
        .RowSource = "メール"
        .BoundColumn = 2
        .ListIndex = 0                           'プロパティウィンドウで設定不可
    End With
    
    With ComboBox_CC
        .RowSource = "メール"
        .BoundColumn = 2
        .BackStyle = fmBackStyleTransparent
    End With
    
    With TextBox_LetterBody
        .MultiLine = True
        .EnterKeyBehavior = True
        .Value = wsData.Range("D2").Value        'プロパティウィンドウで設定不可
    End With
    
    TextBox_Attachments.Locked = True
    TextBox_AttachAdd.Locked = True
End Sub
'///2.CCコンボボックスA///
Private Sub ComboBox_CC_Enter()
    ComboBox_CC.BackStyle = fmBackStyleOpaque    'フォーカスを受け取った時は不透明にする
End Sub

'///3.CCコンボボックスB///
Private Sub ComboBox_CC_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    If ComboBox_CC.Text = "" Then                      'フォーカスが外れた時にコンボボックスに値がなければ
        ComboBox_CC.BackStyle = fmBackStyleTransparent 'コンボボックスを透明にする=下のテキストボックスが見える
    End If
End Sub

'///4.追加添付ファイル///
Private Sub CommandButton_ClipFile_Click()
    Dim clipFile As Variant
    Dim f As Variant
    
    ChDrive wsData.Range("H2") 'ネットワークドライブの場合は
    ChDir wsData.Range("I2")   '(外部ライブラリWshShellクラス)を使用
    clipFile = Application.GetOpenFilename(MultiSelect:=True)  '[ファイルを開く]ダイアログの表示
 
    If IsArray(clipFile) Then  'IsArray(clipFile) = False はダイアログでキャンセルが選択された時に成立
        For Each f In clipFile
            With wsData.Cells(Rows.Count, 7).End(xlUp)
                If .Row = 2 And .Value = "" Then
                    .Value = f
                Else
                    .Offset(1, 0).Value = f
                End If
                
                If TextBox_AttachAdd.Text = "" Then
                    TextBox_AttachAdd = Dir(f)
                Else
                    TextBox_AttachAdd = TextBox_AttachAdd.Text & " , " & Dir(f)
                End If
            End With
        Next f
    End If
End Sub

'///5.追加添付ファイル削除///
Private Sub CommandButton_Trash_Click()
    TextBox_AttachAdd.Value = ""
    On Error Resume Next      'Range("添付ファイル名")が空だとエラーになるので回避
    Range("添付ファイル名").Clear
End Sub

'///6.メール送信///
Private Sub CommandButton_SendMail_Click()
    Dim mailSubject As String, mailBody As String
    
    If wsReport.Range("A1") = "" Then
        MsgBox "日付を入力して下さい"
        Exit Sub
    ElseIf ComboBox_To.ListIndex = -1 Then
        MsgBox "宛先を選択して下さい"
        Exit Sub
    End If
    
    If MakeDirectory(GetSaveDir) Then Exit Sub   'フォルダ作成
    If OverwriteFile(GetFilePath) Then Exit Sub   'ファイル上書き
    
    Call OutputPDF(ActiveSheet, GetFilePath)   'PDF出力

    mailSubject = TextBox_Subject
    mailBody = TextBox_LetterBody

    Call GetAttachment(GetFilePath)   '添付ファイル名取得
    Call SendMail(ComboBox_To, ComboBox_CC, mailSubject, mailBody, TextBox_Attachments, GetFilePath)
End Sub

全部で6つのプロシージャがあります。初期化、CC用コンボボックスの挙動、追加添付ファイルの処理、送信処理を記述しています。

1.初期化

大半のプロパティがVBEのプロパティウィンドウでも設定できます。私はサイズ、フォント、位置等をプロパティウィンドウで設定し、その他はコードで書くようにしています。共有しないコードであれば、自分が分かりやすい方法でいいと思います。

可読性で考えるならコード > プロパティウィンドウです。

2.CCコンボボックスA、3.CCコンボボックスB

CCコンボボックスは未選択の状態だとグレー文字で「必要があれば追加して下さい」が表示されます。

方法は、ラベル(必要があれば~が入力されたもの)の上にコンボボックスを重ね、コンボボックスを透明にします(初期化でプロパティを設定しています)。

コンボボックスがフォーカスされると透明をいったん解除し(不透明)、フォーカスが外れた時に値のあり/なしで透明/不透明の2択処理をします。

アプリ等の入力フォームでよくみるアレを再現している訳ですが、本家の処理方法が気になります…

4.追加添付ファイル

添付するファイルのフルパスを取得してワークシートに入力する処理と[ファイルを開く]ダイアログを表示する処理です。

フルパスを取得する処理は、If IsArray(clipFile) Thenはダイアログでファイルが選択された時にTrueになり、キャンセルされたときにFalseになります。Application.GetOpenFilenameでググれば丁寧な解説がヒットします。

「ファイルを開く」ダイアログを表示する処理は、wsDataシートで設定したフォルダが表示されます。表示したいフォルダがローカルPCではなく、ネットワークドライブの場合はChDirステートメントは使えません。CurrentDirectoryプロパティを使用して下さい。

6.メール送信

メインのプロシージャです。必須項目が未入力の場合の処理とテンプレ文の更新、他プロシージャの呼び出しです。

以上です。とりあえずコピペで動く状態にはなっている(筈)ので、後はご自身の環境に合わせてカスタムして下さい。ユーザーフォームの挙動は、まだ詰められる要素があると思います。

テストはご自身のメールアドレスで行うのが吉です。

コピペで一から作ると30分~1時間はかかると思います。結構なボリュームですが、興味ある方は是非マクロを動かしてみて下さい。可能ならダウンロード推奨です。

それでは、最後までご高覧いただきありがとうございました。

目次
閉じる