엑셀 메일 보내기 자동화 매크로 :: 첨부파일, 예약발송 OK!

'##########################################
'z_SubModule 이라는 모듈을 생성한 뒤 복사/붙여넣기 하세요
'##########################################
Option Explicit
 
Public Function FileExists(ByVal path_ As String) As Boolean
 
    FileExists = (Dir(path_, vbDirectory) <> "")
 
End Function
 
Public Function GetDesktopPath(Optional BackSlash As Boolean = True)
 
Dim oWSHShell As Object
 
Set oWSHShell = CreateObject("WScript.Shell")
 
If BackSlash = True Then
    GetDesktopPath = oWSHShell.SpecialFolders("Desktop") & "\"
Else
    GetDesktopPath = oWSHShell.SpecialFolders("Desktop")
End If
 
Set oWSHShell = Nothing
 
End Function
 
Function FileSequence(FilePath As String, Optional Sequence As Long = 1)
 
Dim Ext As String: Dim Path As String: Dim newPath As String
Dim Pnt As Long
 
Pnt = InStrRev(FilePath, ".")
Path = Left(FilePath, Pnt - 1)
Ext = Right(FilePath, Len(FilePath) - Pnt + 1)
 
newPath = Path & Sequence & Ext
 
Do Until FileExists(newPath) = False
    Sequence = Sequence + 1
    newPath = Path & Sequence & Ext
Loop
 
FileSequence = newPath
 
End Function
 
Function ValidFileName(ByVal FileName As String) As Boolean
 
Dim Arr As Variant: Dim Val As Variant
Dim Pnt As Long
 
Arr = Array("/", "\", ":", "*", "?", """", "<", ">", "|")
 
If InStr(1, FileName, ":\") > 0 Then
    Pnt = InStrRev(FileName, "\")
    FileName = Right(FileName, Len(FileName) - Pnt)
    Debug.Print FileName
End If
 
ValidFileName = True
 
For Each Val In Arr
    If InStr(1, FileName, Val) > 0 Then ValidFileName = False: Exit Function
Next
 
End Function

'##########################################
'z_PageSetup 이라는 모듈을 생성한 뒤 복사/붙여넣기 하세요
'##########################################
 
Public Enum ePrintMargin
xlNone = 0
xlNarrow = 1
xlNormal = 2
xlWide = 3
End Enum
 
Public Enum ePaperSize
xlA4 = 9
xlA3 = 8
xlLetter = 1
xlA5 = 11
End Enum
 
Function getPrintMargin(eValue As ePrintMargin) As Variant
 
'// 설정된 eNum 값으로 페이지 여백설정을 위한 값을 배열로 나열합니다.
 
Select Case eValue
Case 0
getPrintMargin = Array(0.05, 0.05, 0.05, 0.05, 0.1, 0.1)
Case 1
getPrintMargin = Array(0.25, 0.25, 0.75, 0.75, 0.3, 0.3)
Case 2
getPrintMargin = Array(0.7, 0.7, 0.75, 0.75, 0.3, 0.3)
Case 3
getPrintMargin = Array(1, 1, 1, 1, 0.5, 0.5)
End Select
 
End Function
 
Sub Page_setup(WS As Worksheet, Optional LHead As String = "", Optional RHead As String = "&D / &T", _
Optional LFoot As String = "본 페이지의 무단복제를 금합니다.", Optional RFoot As String = "&P / &N 페이지", _
Optional eMargin As ePrintMargin = xlNarrow, _
Optional HFit As Boolean = True, Optional VFit As Boolean = False, _
Optional HCenter As Boolean = True, Optional VCenter As Boolean = False, _
Optional eOrient As XlPageOrientation = xlPortrait, Optional eSize As ePaperSize = xlA4)
 
Dim pSetup As String
Dim varMargin As Variant
Dim lngOrient As Integer
 
'// 인쇄설정 업데이트 중단 (속도증가)
Application.PrintCommunication = False
 
'// 인쇄여백값을 받아옵니다.
varMargin = getPrintMargin(eMargin)
 
'// 인쇄용지 방향을 설정합니다.
If eOrient = xlPortrait Then
lngOrient = 1
Else
lngOrient = 2
End If
 
'// ExecuteExcel4Macro 의 Page.Setup 명령문 실행을 위한 문구를 입력합니다.
Head = """&L" & LHead & "&R" & RHead & """"     '// 페이지 머릿말입니다.
Foot = """&L" & LFoot & "&R" & RFoot & """"     '// 페이지 꼬릿말입니다.
pLeft = varMargin(0)                            '// 왼쪽여백
pRight = varMargin(1)                           '// 오른쪽여백
Top = varMargin(2)                              '// 윗여백
Bot = varMargin(3)                              '// 아래여백
Head_margin = varMargin(4)                      '// 머릿말여백
Foot_margin = varMargin(5)                      '// 꼬릿말여백
Hdng = 0                                        '// 행/열반복 출력여부 0 = 반복출력안함 1 = 반복출력
Grid = False                                    '// 눈금선출력여부
Notes = False                                   '// 메모출력여부
H_cntr = HCenter                                '// 가운데정렬
V_cntr = VCenter                                '// 중앙정렬
Orient = lngOrient                              '// 문서방향, 1 = 세로 2 = 가로
Paper_size = eSize                              '// 용지크기
Pg_num = 1                                      '// 페이지 시작번호
Pg_order = 1                                    '// 페이지번호 순서, 1 = 위-아래-우 2 = 좌-우-아래
Quality = ""                                    '// 인쇄품질 (dot-per-inch로 입력) (공백 = 자동)
bw_cells = False                                '// 흑백인쇄여부, TRUE = 글자/테두리 검정,배경 흰색 FALSE = 색깔
pScale = 100                                    '// 축소/확대비율 또는 TRUE (Fit to Page)
 
'// 여백을 없음으로 설정할 경우 머릿말/꼬릿말을 삭제하여 인쇄영역과 겹치지 않도록 합니다.
If eMargin = xlNone Then
Head = """"""
Foot = """"""
End If
 
 
'// ExecuteExcel4Macro 명령문을 실행합니다.
pSetup = "PAGE.SETUP(" & Head & ", " & Foot & ", " & pLeft & ", " & pRight & ", " & Top & ", " & Bot & ", "
pSetup = pSetup & Hdng & ", " & Grid & "," & H_cntr & "," & V_cntr & "," & Orient & ","
pSetup = pSetup & Paper_size & "," & pScale & ","
pSetup = pSetup & Pg_num & "," & Pg_order & "," & bw_cells & "," & Quality & ","
pSetup = pSetup & Head_margin & "," & Foot_margin & "," & Notes & ")"
 
 
Application.ExecuteExcel4Macro pSetup
 
'// ExecuteExcel4Macro에서는 '한 페이지에 행/열 맞추기' 기능이 지원되지 않습니다.
'// 따라서 시트의 PageSetup 속성으로 '페이지 행/열 맞추기 기능을 설정합니다.
With WS.PageSetup
If HFit = True Then
.FitToPagesWide = 1
Else
.FitToPagesWide = False
End If
 
If VFit = True Then
.FitToPagesTall = 1
Else
.FitToPagesTall = False
End If
End With
 
'// 인쇄설정 업데이트
Application.PrintCommunication = True
 
End Sub

'####################################################
'모듈을 추가한 뒤 복사/붙여넣기 하세요.
'####################################################
 
Sub Rng_To_Pdf(rngSelect As Range, _
                Optional FileName As String = "pdf출력", _
                Optional SavePath As String = "", _
                Optional DocProperty As Boolean = True, _
                Optional PrintArea As Boolean = False, _
                Optional OpenPdf As Boolean = False, _
                Optional AddSequence As Boolean = True)
 
Dim WS As Worksheet
Dim FilePath As String
 
Set WS = rngSelect.Parent
 
If SavePath = "" Then SavePath = GetDesktopPath
 
FilePath = SavePath & FileName & ".pdf"
 
If ValidFileName(FilePath) = False Then MsgBox ("올바른 파일명을 사용하세요"): Exit Sub
 
If AddSequence = True Then
    FilePath = FileSequence(FilePath, 1)
End If
 
rngSelect.ExportAsFixedFormat xlTypePDF, FilePath, xlQualityStandard, DocProperty, PrintArea, , , OpenPdf
 
End Sub

Dim AppOutlook As Outlook.Application      
Dim newEmail As Outlook.MailItem            
Dim pageInspector As Outlook.Inspector      
Dim pageEditor As Object                    
Dim varFilePath As Variant                  
Dim FileCount As Long                       
Dim i As Long                               
Dim wdPasteDefault As Variant
 
Set AppOutlook = New Outlook.Application
Set newEmail = AppOutlook.CreateItem(olMailItem)

With newEmail
    .To = MailTo
    .CC = CCTo
    .BCC = BCCTo
    .Subject = Subject
    If AttachFilePath <> "" Then
        For i = 1 To UBound(varFilePath) + 1
            .Attachments.Add varFilePath(i - 1), 1, i
        Next
    End If
    .HTMLBody = HTMLString
 
    '.DeferredDeliveryTime = DateAdd("n", 5, Now)
    .DeferredDeliveryTime = DateSerial(2030, 1, 1) + TimeSerial(8, 0, 0)
 
End With

If PasteSelection = True Then
        .Display
        Set pageInspector = newEmail.GetInspector
        Set pageEditor = pageInspector.WordEditor
        pageEditor.Application.Selection.Start = Len(.Body)
 
        Selection.Copy
        pageEditor.Application.Selection.PasteAndFormat wdPasteDefault
    Else
        .Display
    End If

'.Send    '// 메일을 보내려면 주석처리를 해제하세요.
 
Set pageEditor = Nothing
Set pageInspector = Nothing
Set newEmail = Nothing
Set AppOutlook = Nothing

'######################################################################
' 명령문    : Send_Email
' 설명      : 아웃룩과 연동하여 메일보내기를 자동화하는 모듈입니다.
'######################################################################
 
Sub Send_Email(MailTo As String, _
                Subject As String, _
                HTMLString As String, _
                Optional PasteSelection As Boolean = False, _
                Optional CCTo As String = "", _
                Optional BCCTo As String = "", _
                Optional AttachFilePath As String = "", _
                Optional PathDelimiter As String = "|")
 
Dim AppOutlook As Outlook.Application       '// 아웃룻 프로그램
Dim newEmail As Outlook.MailItem            '// 아웃룻 새로 메일을 보내기 위해 생성한 메일
Dim pageInspector As Outlook.Inspector      '// 아웃룩 워드에디터 가져오기위한 항목
Dim pageEditor As Object                    '// 아웃룩 이메일 편집창
Dim varFilePath As Variant                  '// 파일경로를 배열형태로 만들어준 변수
Dim FileCount As Long                       '// 첨부파일의 개수
Dim i As Long                               '// For문 반복문의 변수
Dim wdPasteDefault As Variant
 
Set AppOutlook = New Outlook.Application
Set newEmail = AppOutlook.CreateItem(olMailItem)
 
 
If AttachFilePath <> "" Then
        varFilePath = Split(AttachFilePath, PathDelimiter)
End If
 
 
With newEmail
    .To = MailTo
    .CC = CCTo
    .BCC = BCCTo
    .Subject = Subject
    If AttachFilePath <> "" Then
        For i = 1 To UBound(varFilePath) + 1
            .Attachments.Add varFilePath(i - 1), 1, i
        Next
    End If
    .HTMLBody = HTMLString
 
    '.DeferredDeliveryTime = DateAdd("n", 5, Now)
    .DeferredDeliveryTime = DateSerial(2030, 1, 1) + TimeSerial(8, 0, 0)
 
    If PasteSelection = True Then
        .Display
        Set pageInspector = newEmail.GetInspector
        Set pageEditor = pageInspector.WordEditor
        pageEditor.Application.Selection.Start = Len(.Body)
 
        Selection.Copy
        pageEditor.Application.Selection.PasteAndFormat wdPasteDefault
    Else
        .Display
    End If
 
'.Send    '// 메일을 보내려면 주석처리를 해제하세요.
 
End With
 
Set pageEditor = Nothing
Set pageInspector = Nothing
Set newEmail = Nothing
Set AppOutlook = Nothing
 
End Sub

'##########################################################
' 오빠두엑셀 퀵 VBA 7강, 메일 보내기 자동화 완성파일
' 명령문에 대한 자세한 설명은 아래 링크에서 확인하세요.
' https://www.oppadu.com/엑셀-메일-보내기-아웃룩-매크로/
'##########################################################
 
Sub Test()
 
Dim FileName As String
Dim SavePath As String
 
FileName = Sheet4.Range("E3").Value & "_" & Sheet4.Range("C4").Value & "_" & Sheet4.Range("H3").Value & "년 " & Sheet4.Range("H4").Value & "월"
SavePath = GetDesktopPath
 
Rng_To_Pdf Sheet4.Range("B2:E18"), FileName, SavePath, OpenPdf:=False, AddSequence:=False
'// Rng_To_Pdf 명령문의 첫번째 인수를 Selection으로 변경하면 선택한 범위를 PDF파일로 추출하여 메일에 첨부합니다.
 
Sheet4.Range("B2:E18").Select
'// 선택된 범위가 아닌 원하는 부분을 지정해서 메일에 첨부하는 방법이 궁금하신분은 Send_Email 명령문 관련 포스트를 참고하세요.
Send_Email "test@oppadu.com", _
            FileName, _
            "

With newEmail
    .To = MailTo
    .CC = CCTo
    .BCC = BCCTo
    .Subject = Subject
    If AttachFilePath <> "" Then
        For i = 1 To UBound(varFilePath) + 1
            .Attachments.Add varFilePath(i - 1), 1, i
        Next
    End If
 
    '-------------------------------
    ' 서명 추가를 위해 변경된 부분
    '-------------------------------
    .Display
    Dim Signature As String
    Signature = .HTMLBody
 
    .HTMLBody = HTMLString
 
    '.DeferredDeliveryTime = DateAdd("n", 5, Now)
    .DeferredDeliveryTime = DateSerial(2030, 1, 1) + TimeSerial(8, 0, 0)
 
    If PasteSelection = True Then
        .Display
        Set pageInspector = newEmail.GetInspector
        Set pageEditor = pageInspector.WordEditor
        pageEditor.Application.Selection.Start = Len(.Body)
 
        Selection.Copy
        pageEditor.Application.Selection.PasteAndFormat wdPasteDefault
 
        '-------------------------------
        ' 서명 추가를 위해 변경된 부분
        '-------------------------------
        .HTMLBody = .HTMLBody & Signature
    Else
        .Display
    End If
 
'.Send    '// 메일을 보내려면 주석처리를 해제하세요.
 
End With