【Excel VBA】2クリックでシートをPDF保存、メール添付/送信するマクロ

'///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.ファイル上書き確認/// ※1
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.月別フォルダ自動生成/// ※1
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出力/// ※2
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") '※3
        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

Private Sub Workbook_Open()
    If ActiveSheet.CodeName = "wsReport" Then
        UserForm1.Show vbModeless
        Range("A1").Activate
    End If
    
    Application.EnableEvents = False '※1
    wsReport.Range("A1").Clear '※2
    Application.EnableEvents = True
    
    On Error Resume Next
    Range("添付ファイル名").Clear '※3
End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    If Sh.CodeName <> "wsData" Then
        UserForm1.Show vbModeless
        Range("A1").Activate
        AppActivate Application.Caption '※4
    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) '※5
    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

'///1.初期化/// ※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/// ※2
Private Sub ComboBox_CC_Enter()
    ComboBox_CC.BackStyle = fmBackStyleOpaque    'フォーカスを受け取った時は不透明にする
End Sub

'///3.CCコンボボックスB/// ※2
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") '※3
    clipFile = Application.GetOpenFilename(MultiSelect:=True)
 
    If IsArray(clipFile) Then  '※4
        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