XLA routines: EE_SendReport

Nick's picture
EE_SendReport is a hugely useful routine that sends a range as an email - can also add attachments like zipped up files - requires ms outlook
Sub EE_SendReport(rptRange As range, recipients As range, Files As range, Optional SendOrDisplay As Boolean, Optional ZipFileName As String)
'RptRange is a range containing text we want to be contained in the body
'Recipients is range containing email addresses Files is range containing
'list of files that we will zip up and add to mail SendOrDisplay - If= Send, mail is sent.. If Display, display mail.
    Const cstrAddSep            As String = ";"
    Dim arrTo
    Dim strTo           As String
    Dim arrAttach
    Dim strAttach       As String
    Dim strZipFile      As String
    Dim strFirstFile    As String
'http://excelexperts.com/xla-routines-eeSendReport    for updates on this sub routine

    arrTo = recipients
    If recipients.Cells.Count = 1 Then
        strTo = CStr(arrTo)
        strTo = Join(Application.Transpose(arrTo), cstrAddSep)
    End If
    arrAttach = Files
    If Files.Cells.Count = 1 Then
        strAttach = CStr(arrAttach)
        strFirstFile = strAttach
        strAttach = Join(Application.Transpose(arrAttach), ",")
        strFirstFile = Split(strAttach, ",")(0)
    End If
    strFirstFile = Left(strFirstFile, InStrRev(strFirstFile, ".") - 1)
    If ZipFileName <> "" Then
        strZipFile = Environ("Temp") & Application.PathSeparator & Replace(ZipFileName, ".zip", "") & ".zip"
        strZipFile = Environ("Temp") & Application.PathSeparator & EE_FileNameFromFilePath(strFirstFile) & ".zip"
    End If
    Call EE_ZipFile(Left(strZipFile, InStrRev(strZipFile, Application.PathSeparator)), EE_FileNameFromFilePath(strZipFile), strAttach)
    Call SendEmail(strTo, "", rptRange.value, Display, False, strZipFile)
    Kill strZipFile
End Sub
Public Function SendEmail(strMailTo As String, strSubject As String, _
    strBodyText As String, SendOrDisp As OptSendDisplay, blnReceipt As _
    Boolean, Optional strAttachment As String, Optional strCCTo As String, _
    Optional strBCCTo As String) As Long
'This will return 0 if successfull else error number

    Dim objApp                  As Object
    Dim objMail                 As Object
    Dim arrAttachment()         As String
    Dim intAttachLoop           As Integer
    On Error GoTo ErrHandler
    Set objApp = CreateObject("Outlook.Application")
    Set objMail = objApp.CreateItem(0)
    With objMail
        .To = strMailTo
        If Len(strCCTo) > 0 Then .CC = strCCTo
        If Len(strBCCTo) > 0 Then .BCC = strBCCTo
        .Subject = strSubject
        .Body = strBodyText
        .ReadReceiptRequested = blnReceipt
        If Len(strAttachment) > 0 Then
            arrAttachment() = Split(strAttachment, ",")
            For intAttachLoop = 0 To UBound(arrAttachment, 1)
                .Attachments.Add arrAttachment(intAttachLoop)
            Next intAttachLoop
        End If
        If SendOrDisp = Display Then .Display
        If SendOrDisp = Send Then .Send
    End With
    SendEmail = 0 'Success returned
    Set objApp = Nothing
    Set objMail = Nothing
    Exit Function
    SendEmail = Err.Number 'Error returned
    GoTo exitSendAttachment
End Function