VBA Outlookでメール送信する 添付ファイル付ける

VBA Outlookでメール送信する

※Outlookがインストールされていないとできません。

①シートを以下のフォーマットにする

②VBEエディタ→ツール→参照設定で以下をチェックする

③モジュールを３つ作成する

④以下コードをコピペし、ボタン押せばメール送信できる
※ボタン押下後、以下のチェックを行っています。
　◇メール内容シート
　・空白チェック
　　タイトル、本文
　　※添付ファイルは添付しないケースもあると思うので、空白チェックは行っていません。
　・ファイル存在チェック
　　添付ファイル
　◇宛先シート
　・空白チェック
　　Name、Name2、メールアドレス
　・メール形式チェック
　　メールアドレスが「x@x.x」の形式で半角文字で入力されているか

modSendMail

Option Explicit

    '##### 変数宣言 #####
    
    Public lngCntLoop          As Long         'ループカウント格納用
    Public wsMail              As Worksheet    'シート格納用
    Public wsAtesaki           As Worksheet    'シート格納用
    Public strSubject          As String       '件名格納用
    Public StrText             As String       '本文格納用
    Public strTo               As String       'TO格納用
    Public strAttach()         As String       '添付ファイルパス格納用（配列）
    Public varAttach           As Variant      '添付ファイルパス格納用
    Public strCompany          As String       '会社名格納用
    Public strCustomer         As String       '顧客名格納用
    Public StrTextEdit         As String       '本文作成用
    Public blnRes              As Boolean      'チェック結果格納用
    Public strMsgErr           As String       'エラー格納用
    Public lngCntAry           As Long         '配列カウント用
    Public blnFlgErr           As Boolean      'エラー時フラグ
    Public lngRes              As Long         '結果格納
    Public outlookObj          As Outlook.Application    'Outlookで使用するオブジェクト生成
    Public mailItemObj         As Outlook.mailItem      'Outlookで使用するオブジェクト生成
    
    '##### 定数宣言 #####
    
    'シート名
    Public Const strWS_NAME_MAIL      As String = "メール内容"
    Public Const strWS_NAME_ATESAKI   As String = "宛先"
    
    'セル系（メール内容シート）
    Public Const strRNG_SUBJECT         As String = "B1"    '件名セル
    Public Const strRNG_TEXT            As String = "B2"    '本文セル
    Public Const lngLOOP_ATTACH_START   As Long = 3         'ループ開始行
    Public Const strRNG_ATTACH          As String = "B"     'ループ列　添付ファイル
    Public Const strRNG_LOOP_ATTACH     As String = "A"     'ループ列  添付ファイル
    
    'セル系（メール内容シート）
    Public Const lngLOOP_TO_START       As Long = 2         'ループ開始行　TO
    Public Const strRNG_LOOP_TO         As String = "B"     'ループ列  TO
    Public Const strRNG_TO              As String = "E"     'ループ列　TO
    Public Const strRNG_COMPANY         As String = "C"     'ループ列　会社名
    Public Const strRNG_CUSTOMER        As String = "D"     'ループ列　顧客名
    
    'メッセージ系
    Public Const strMSG_ERR_CHK_ADDRESS     As String = "メールアドレスの形式が間違っています。" & vbCrLf & "値を修正し再実行して下さい。"
    Public Const strMSG_INFO_END            As String = "メール送信処理が処理が完了しました。"
    Public Const strMSG_ERR_CHK_EMPTY       As String = "空白の項目があります。" & vbCrLf & "値を入力し再実行して下さい。"
    Public Const strMSG_ERR_FILE_NOT_EXIST  As String = "以下の添付ファイルが存在しません。" & vbCrLf & "ファイルを確認し再実行して下さい。"
    Public Const strMSG_ERR_FILE            As String = "ファイル："
    Public Const strMSG_ERR_SHEET           As String = "シート："
    Public Const strMSG_ERR_CELL            As String = "セルアドレス："
    Public Const strMSG_ERR_UNEXPECT        As String = "予期しないエラーが発生しました。"
    Public Const strERR_NUM                 As String = "エラー番号："
    Public Const strERR_DESCRIPTION         As String = "エラー内容："
    
    'その他定数
    Public Const strEMPTY               As String = ""  '空白
    Public Const strKEISYOU             As String = "様"
    Public Const strGYOU                As String = "行："
    
'###############################################
'#  処理概要：Outlookでメール送信する
'#　引数　　：なし
'#  戻り値　：なし
'#
'###############################################
Sub subOutlook()

    On Error GoTo Err_Exit
    
    '##### 初期設定 #####
    
    Call fncStopConfig  '無駄な設定を止める
    Set wsMail = ThisWorkbook.Sheets(strWS_NAME_MAIL)       'シート格納
    Set wsAtesaki = ThisWorkbook.Sheets(strWS_NAME_ATESAKI)   'シート格納
    lngCntAry = 0
    strMsgErr = strEMPTY
    strSubject = strEMPTY
    StrText = strEMPTY
    strTo = strEMPTY
    varAttach = strEMPTY
    strCompany = strEMPTY
    strCustomer = strEMPTY
    StrTextEdit = strEMPTY
    blnFlgErr = False
    Erase strAttach
    Set outlookObj = CreateObject("Outlook.Application")        'Outlook設定


    '##### 値取得（メール内容シート） #####
    
    '件名取得A
    strSubject = wsMail.Range(strRNG_SUBJECT)
    '本文取得
    StrText = wsMail.Range(strRNG_TEXT)
    
    '添付ファイル取得
    lngCntLoop = lngLOOP_ATTACH_START
    Do Until wsMail.Range(strRNG_LOOP_ATTACH & CStr(lngCntLoop)) = strEMPTY
        '添付ファイルが空白の場合は取得しない
        If Not wsMail.Range(strRNG_ATTACH & CStr(lngCntLoop)) = strEMPTY Then
            ReDim Preserve strAttach(lngCntAry)
            strAttach(lngCntAry) = wsMail.Range(strRNG_ATTACH & CStr(lngCntLoop))
            lngCntAry = lngCntAry + 1
        End If
        lngCntLoop = lngCntLoop + 1
    Loop
    
    
    '##### メール送信前チェック #####
    
    blnRes = fncCheckVal
    If Not blnRes Then
        GoTo Err_Exit
    End If
    

    '##### 値取得（メール内容シート） #####
    
    lngCntLoop = lngLOOP_TO_START
    Do Until wsAtesaki.Range(strRNG_LOOP_TO & CStr(lngCntLoop)) = strEMPTY
        
        '本文初期化
        StrTextEdit = strEMPTY
        '宛先取得
        strTo = wsAtesaki.Range(strRNG_TO & CStr(lngCntLoop))
        '会社名取得
        strCompany = wsAtesaki.Range(strRNG_COMPANY & CStr(lngCntLoop))
        '顧客名取得
        strCustomer = wsAtesaki.Range(strRNG_CUSTOMER & CStr(lngCntLoop))
        '本文作成
        StrTextEdit = strCompany & vbCrLf & strCustomer & strKEISYOU & vbCrLf & StrText
    
        '##### メール送信設定、送信 #####
        
        Set mailItemObj = outlookObj.CreateItem(olMailItem)
        mailItemObj.BodyFormat = 3          'リッチテキストに変更
        mailItemObj.To = strTo              'to宛先をセット
        mailItemObj.Subject = strSubject    '件名をセット
        mailItemObj.Body = StrTextEdit      '本文をセット
        
        '添付ファイルをセット
        lngRes = fncIsArrayEx(strAttach)
        If lngRes = 1 Then
            For Each varAttach In strAttach
                If Not varAttach = strEMPTY Then
                     mailItemObj.Attachments.Add (varAttach)
                End If
            Next varAttach
        End If
        
        'メール送信
        mailItemObj.Send   'メール送信する場合、コメントアウト
        'mailItemObj.Display  'メール表示(ここでは誤送信を防ぐために表示だけにして、メール送信はしない)

        lngCntLoop = lngCntLoop + 1
    Loop
    
    GoTo Finaly

Err_Exit:
    
    If Err.Number = 0 Then
        MsgBox strMsgErr, vbExclamation
    Else
        MsgBox strMSG_ERR_UNEXPECT & vbCrLf & strERR_NUM & Err.Number & vbCrLf & strERR_DESCRIPTION & Err.Description, vbExclamation
    End If
    
    blnFlgErr = True
    
Finaly:

    '##### 終了処理 #####
    
    Call fncReStartCongig
    
    'オブジェクトの解放
    Set outlookObj = Nothing
    Set mailItemObj = Nothing
    Set wsMail = Nothing
    Set wsAtesaki = Nothing
    Erase strAttach
    If Not blnFlgErr Then
        'メッセージ表示
        MsgBox strMSG_INFO_END, vbInformation
    End If
    
End Sub

modCheckVal

Option Explicit

'###############################################
'#  処理概要：値チェック
'#　引数　　：なし
'#  戻り値　：チェック成功　→　True
'#            チェック失敗　→　False
'#
'###############################################
Public Function fncCheckVal()

    '##### チェック（メール内容シート）#####
    
    '空白チェック 件名
    blnRes = fncCheckEmpty(strSubject)
        If Not blnRes Then
            strMsgErr = strMSG_ERR_CHK_EMPTY & vbCrLf & strMSG_ERR_SHEET & strWS_NAME_MAIL & vbCrLf & strRNG_SUBJECT
            GoTo Err_Exit
        End If
    '空白チェック 本文
    blnRes = fncCheckEmpty(StrText)
    If Not blnRes Then
        strMsgErr = strMSG_ERR_CHK_EMPTY & vbCrLf & strMSG_ERR_SHEET & strWS_NAME_MAIL & vbCrLf & strRNG_TEXT
        GoTo Err_Exit
    End If
    '添付ファイル存在確認
    lngRes = fncIsArrayEx(strAttach)
    If lngRes = 1 Then
        For Each varAttach In strAttach
            If Dir(varAttach) = strEMPTY Then
                strMsgErr = strMSG_ERR_FILE_NOT_EXIST & vbCrLf & strMSG_ERR_FILE & varAttach
                GoTo Err_Exit
            End If
        Next varAttach
    End If
    
    '##### チェック（宛先シート）#####
    
    lngCntLoop = lngLOOP_TO_START
    Do Until wsAtesaki.Range(strRNG_LOOP_TO & CStr(lngCntLoop)) = strEMPTY

        '会社名取得
        strCompany = wsAtesaki.Range(strRNG_COMPANY & CStr(lngCntLoop))
        '顧客名取得
        strCustomer = wsAtesaki.Range(strRNG_CUSTOMER & CStr(lngCntLoop))
        '宛先取得
        strTo = wsAtesaki.Range(strRNG_TO & CStr(lngCntLoop))
        
        '空白チェック 会社名
        blnRes = fncCheckEmpty(strCompany)
        If Not blnRes Then
            strMsgErr = strMSG_ERR_CHK_EMPTY & vbCrLf & strMSG_ERR_SHEET & strWS_NAME_ATESAKI & vbCrLf & strMSG_ERR_CELL & strRNG_COMPANY & CStr(lngCntLoop)
            GoTo Err_Exit
        End If
        '空白チェック 顧客名
        blnRes = fncCheckEmpty(strCustomer)
        If Not blnRes Then
            strMsgErr = strMSG_ERR_CHK_EMPTY & vbCrLf & strMSG_ERR_SHEET & strWS_NAME_ATESAKI & vbCrLf & strMSG_ERR_CELL & strRNG_CUSTOMER & CStr(lngCntLoop)
            GoTo Err_Exit
        End If
        '空白チェック 宛先
        blnRes = fncCheckEmpty(strTo)
        If Not blnRes Then
            strMsgErr = strMSG_ERR_CHK_EMPTY & vbCrLf & strMSG_ERR_SHEET & strWS_NAME_ATESAKI & vbCrLf & strMSG_ERR_CELL & strRNG_TO & CStr(lngCntLoop)
            GoTo Err_Exit
        End If
        '形式チェック 宛先
        blnRes = fncCheckEmailAddress(strTo)
        If Not blnRes Then
            strMsgErr = strMSG_ERR_CHK_ADDRESS & vbCrLf & strGYOU & CStr(lngCntLoop) & vbCrLf & strTo
            GoTo Err_Exit
        End If
        '半角チェック 宛先
        blnRes = fncCheckHalfByteChar(strTo)
        If Not blnRes Then
            strMsgErr = strMSG_ERR_CHK_ADDRESS & vbCrLf & strGYOU & CStr(lngCntLoop) & vbCrLf & strTo
            GoTo Err_Exit
        End If
        
        lngCntLoop = lngCntLoop + 1
    Loop

    GoTo Finaly

Err_Exit:
    
    fncCheckVal = False
    Exit Function
    
Finaly:

    fncCheckVal = True
    
End Function

modCommonFunc

Option Explicit

'###############################################
'#  処理概要：無駄な設定を止める
'#　引数　　：なし
'#  戻り値　：なし
'#
'###############################################
Public Function fncStopConfig()

    With Application
        .Calculation = xlCalculationManual  '自動計算
        .EnableEvents = False               'イベント
        .ScreenUpdating = False             '画面更新
    End With
    
End Function

'###############################################
'#  処理概要：無駄な設定を初期状態に戻す
'#　引数　　：なし
'#  戻り値　：なし
'#
'###############################################
Public Function fncReStartCongig()

    With Application
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    
End Function

'###############################################
'#  処理概要：メールアドレス形式チェック
'#　引数　　：strMailAddress
'#  戻り値　：正しいメールアドレスの場合　　　　→　TRUE
'#　　　　　　正しいメールアドレスではない場合　→　FALSE
'#
'###############################################
Public Function fncCheckEmailAddress(ByVal strMailAddress As String) As Boolean
    
    '##### 変数宣言 #####
    Dim objRegEX    As Object

    'RegExpオブジェクトをセットする。
    Set objRegEX = CreateObject("VBScript.RegExp")
        With objRegEX
            .Pattern = "^.+@.+\..+$"            '正規表現をPatternプロパティにセットする　「x@x.x」の形式の確認
                If .test(strMailAddress) Then   '正規表現にマッチしているかチェック
                    fncCheckEmailAddress = True
                Else
                    fncCheckEmailAddress = False
                End If
        End With
 
End Function

'###############################################
'#  処理概要：メールアドレス半角チェック
'#　引数　　：strMailAddress
'#  戻り値　：正しいメールアドレスの場合　　　　→　TRUE
'#　　　　　　正しいメールアドレスではない場合　→　FALSE
'#
'###############################################
Public Function fncCheckHalfByteChar(ByVal strMailAddress As String) As Boolean

    '##### 変数宣言 #####
    Dim strASCII       As String
    Dim strCell        As String
    Dim lngLenASCII    As Long
    Dim lngLenUNICODE  As Long
    
    'セルの文字列とそれをASCII変換した文字列を取得
    strCell = strMailAddress
    strASCII = StrConv(strMailAddress, vbFromUnicode)
    
    'それぞれの文字列長を取得
    lngLenASCII = Len(strCell)
    lngLenUNICODE = LenB(strASCII)
    
    '半角文字だけでない場合
    If (lngLenUNICODE <> lngLenASCII) Then
        fncCheckHalfByteChar = False
        Exit Function
    End If
    
    fncCheckHalfByteChar = True
    
End Function

'###############################################
'#  処理概要：空白チェック
'#　引数　　：strValue
'#  戻り値　：空白ではないの場合　　　　→　TRUE
'#　　　　　　空白である場合　→　FALSE
'#
'###############################################
Public Function fncCheckEmpty(ByVal strValue As String) As Boolean
    
    '##### 定数宣言 #####
    Const strEMPTY               As String = ""  '空白
    
    If strValue = strEMPTY Then
        fncCheckEmpty = False
        Exit Function
    End If
    
    fncCheckEmpty = True
    
End Function

'###############################################
'#  機能   : 引数が配列か判定
'#  引数   : varArray  配列
'#  戻り値 : 判定結果（1:配列/0:空の配列/-1:配列じゃない）
'#
'###############################################
Public Function fncIsArrayEx(varArray As Variant) As Long

On Error GoTo ERROR_

    If IsArray(varArray) Then
        fncIsArrayEx = IIf(UBound(varArray) >= 0, 1, 0)
    Else
        fncIsArrayEx = -1
    End If

    Exit Function

ERROR_:

    If Err.Number = 9 Then
        fncIsArrayEx = 0
    End If
    
End Function