OutlookメールExcelのデータからメールを作成｜VBA自動化

Option Explicit

' メール作成と送信準備のメイン処理
Sub CreateAndPrepareEmail()
    On Error GoTo ErrorHandler

    ' シート名の指定
    Dim sheetName As String
    sheetName = "Sheet1"

    ' OutlookとMailItemオブジェクトの初期化
    Dim OL As Object
    Set OL = CreateOutlookObject()

    Dim MI As Object
    Set MI = CreateMailItem(OL)

    ' ワークシートの取得
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(sheetName)

    ' 基本情報の設定
    SetBasicEmailInfo MI, ws

    ' ファイルの添付
    AttachFilesFromFolder MI, ws.Range("C8").Value
    AddSelectedAttachment MI

    ' メールの表示
    MI.Display

    ' オブジェクトの解放
CleanExit:
    Set OL = Nothing
    Set MI = Nothing
    Set ws = Nothing
    Exit Sub

ErrorHandler:
    MsgBox "エラーが発生しました: " & Err.Description, vbCritical
    Resume CleanExit
End Sub

' Outlookオブジェクトの作成
Function CreateOutlookObject() As Object
    On Error Resume Next
    Set CreateOutlookObject = CreateObject("Outlook.Application")
    On Error GoTo 0
End Function

' MailItemオブジェクトの作成
Function CreateMailItem(OL As Object) As Object
    If Not OL Is Nothing Then
        Set CreateMailItem = OL.CreateItem(0) ' olMailItem
    End If
End Function

' メールの基本情報を設定
Sub SetBasicEmailInfo(ByRef MI As Object, ByRef ws As Worksheet)
    If MI Is Nothing Or ws Is Nothing Then Exit Sub

    ' 宛先、CC、件名、本文の設定
    MI.To = ws.Range("C4").Value
    MI.Cc = ws.Range("C5").Value
    MI.Subject = ws.Range("C6").Value

    ' メール本文のHTML形式での設定
    Dim emailBody As String
    emailBody = ws.Range("C7").Value
    emailBody = Replace(emailBody, vbLf, "")

    ' フォントの設定
    Dim fontName As String
    Dim fontSize As String
    fontName = ws.Range("C2").Value
    fontSize = ws.Range("C3").Value
    MI.HTMLBody = "" & emailBody & ""
End Sub

' 指定されたフォルダ内のファイルをメールに添付
Sub AttachFilesFromFolder(ByRef MI As Object, folderPath As String)
    If MI Is Nothing Or folderPath = "" Then Exit Sub

    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")

    If Not fso.FolderExists(folderPath) Then Exit Sub

    Dim folder As Object
    Set folder = fso.GetFolder(folderPath)

    Dim file As Object
    For Each file In folder.Files
        MI.Attachments.Add file.Path
    Next file

    Set fso = Nothing
    Set folder = Nothing
End Sub

' ファイル選択ダイアログを表示し、選択されたファイルをメールに添付
Sub AddSelectedAttachment(ByRef MI As Object)
    If MI Is Nothing Then Exit Sub

    Dim selectedFilePath As String
    selectedFilePath = SelectAttachmentFile()

    If selectedFilePath <> "" Then
        MI.Attachments.Add selectedFilePath
    End If
End Sub

' ファイル選択ダイアログを表示し、選択されたファイルのパスを返す
Function SelectAttachmentFile() As String
    Dim fd As Object
    Set fd = Application.FileDialog(3) ' msoFileDialogFilePicker

    With fd
        .AllowMultiSelect = False
        .Title = "添付ファイルを選択してください"
        .InitialFileName = ThisWorkbook.Path & "\"
        If .Show = -1 Then
            SelectAttachmentFile = .SelectedItems(1)
        Else
            SelectAttachmentFile = ""
        End If
    End With
    Set fd = Nothing
End Function

Function CreateOutlookObject() As Object
    Set CreateOutlookObject = CreateObject("Outlook.Application")
End Function

Function CreateMailItem(OL As Object) As Object
    Set CreateMailItem = OL.CreateItem(0) ' olMailItem
End Function

Sub SetBasicEmailInfo(ByRef MI As Object, ByRef ws As Worksheet)
    MI.To = ws.Range("C4").Value
    MI.Cc = ws.Range("C5").Value
    MI.Subject = ws.Range("C6").Value
    ' 以下、本文とフォント設定のコード
End Sub

Sub AttachFilesFromFolder(ByRef MI As Object, folderPath As String)
    ' フォルダ内のファイルをメールに添付する処理
End Sub

Sub AddSelectedAttachment(ByRef MI As Object)
    ' ユーザーが選択したファイルをメールに添付する処理
End Sub

MI.Display

sheetName = "YourSheetName"

MI.To = ws.Range("YourCellForTo").ValueMI.Cc = ws.Range("YourCellForCc").ValueMI.Subject = ws.Range("YourCellForSubject").ValueemailBody = ws.Range("YourCellForBody").Value

fontName = ws.Range("YourCellForFontName").ValuefontSize = ws.Range("YourCellForFontSize").Value

folderPath = ws.Range("YourCellForFolderPath").Value

.InitialFileName = "YourInitialPath\"