Attribute VB_Name = "basEmail"
'*******************************************************************************
' Project   : Generic
'             Copyright © yyyy Bill Mosca
' Module    : basEmail
' DateTime  : 3/3/2006 08:41
' Author    : Bill Mosca
' Purpose   : Various Outlook Automation functions
' References: OutLook Library, WinZip Commandline utility.
' Index     :(Updated on 1/23/2007)
  ' SaveAsRTF - Save report as rtf file and return file path and name.
  ' MakeRecptString - Concantenate list of recipients in tblEmailRpts
  ' AddOutlookFolder - Add SubFolder to Inbox (Late binding)
  ' Outlook_SendEmail - Automatically send email via late-binding Outlook Automation.
  ' Outlook_FileAtchmt - Get zipped file attachment from email and save it as a file in the
  ' UnZipFile - Run WinZip CommandLine Add-On to unzip password-protected file.
  ' CDO_SendEmail - Need to add MS CDO 1.21 library.
  ' SendMAPIMessage - Sets an object variable to the MAPI Session object
'*******************************************************************************


Option Compare Database
Option Explicit

Public Function SaveAsRTF(strRptName As String, strPath As String, _
    Optional varDateTag As Variant)
'Purpose  : Save report as rtf file and return file path and name.
'           strRptName =name of report
'           strPath = path ending in "\" such as "C:\MyFolder\"
'           varDateTag = date you want added to file name.
    Dim strRTFFullPath As String
    
    If Not IsMissing(varDateTag) Then
        strRTFFullPath = strPath & strRptName & "_" & varDateTag & ".rtf"
    Else
        strRTFFullPath = strPath & strRptName & ".rtf"
    End If
    DoCmd.OutputTo acOutputReport, strRptName, acFormatRTF, _
        strRTFFullPath
    
    SaveAsRTF = strRTFFullPath
    
    'Uncomment to make file read-only.
'    Call MakeReadOnly(strRTFFullPath)
    
End Function

Public Sub MakeReadOnly(strRTFFullPath As String)
    Dim fs As FileSystemObject
    Dim f As File
    
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFile(strRTFFullPath)
    f.Attributes = f.Attributes + ReadOnly
    Set f = Nothing
    Set fs = Nothing
    
End Sub

Function MakeRecptString()
'Purpose  : Concantenate list of recipients in tblEmailRpts
    Dim strRecpt As String
    Dim strSQL As String
    
    strSQL = "Select EMailAddress from tblEmailRpts"
    Set db = CurrentDb
    Set rs = db.OpenRecordset(strSQL)
    If rs.RecordCount = 0 Then
        MsgBox "Email List table not found. Process failed"
        Exit Function
    End If
    With rs
        .MoveFirst
        strRecpt = !emailAddress
        .MoveNext
        Do While Not .EOF
            strRecpt = strRecpt & ";" & !emailAddress
            .MoveNext
        Loop
    End With
    MakeRecptString = strRecpt
    
End Function

Public Function AddOutlookFolder(strSubFolder)
'Purpose  : Add SubFolder to Inbox (Late binding)
'DateTime : 3/3/2000 09:28
'Author   : Bill Mosca
    Dim objOLApp      As Object
    Dim outFolder     As Object
    Dim outNameSpace  As Variant
    Dim outInbox      As Object
    Dim outSubFolder  As Object
    
    On Error Resume Next

    ' Create a Microsoft OutLook object.
    Set objOLApp = CreateObject("Outlook.Application")
    
    Set outNameSpace = objOLApp.GetNamespace("MAPI")
    'olFolderInbox constant=6. Can't use constant with
    '   late binding.
    Set outFolder = outNameSpace.GetDefaultFolder(6)
    
    'Test for existance of subfolder
    Set outSubFolder = outFolder.Folders(strSubFolder)
    
    'If folder not found then create it.
    If Err <> 0 Then
        Err = 0
        Set outSubFolder = outFolder.Folders.Add(strSubFolder)
    End If
    
    Set outSubFolder = Nothing
    Set outFolder = Nothing
    Set outNameSpace = Nothing
    Set objOLApp = Nothing

End Function

Public Function Outlook_SendEmail(ByVal strTo As String, _
                           ByVal strSubject As String, _
                           ByVal strMsg As String, _
                           ParamArray AttachmentList() As Variant) As Boolean
'Purpose  : Automatically send email via late-binding Outlook Automation.
'   Call like this:
'    Call Outlook_SendEmail("Bill.Mosca@MyDomain.com","Hey there.", _
     "Here is my message","C:\MyFiles\Test1.txt","C:\MyFiles\Test2.txt")
'DateTime : 11/30/2003 12:12
'Author   : Bill Mosca, modified by ChrisO to use Array for attachments.
    Dim objOLApp As Object    'Outlook.Application
    Dim outItem As Object    'Outlook.MailItem
    Dim outFolder As Object    'MAPIFolder
    Dim DestFolder As Object    'MAPIFolder
    Dim outNameSpace As Object    'NameSpace
    Dim lngAttachment As Long


    On Error GoTo err_Outlook_SendEmail

    Set objOLApp = CreateObject("Outlook.Application")
    Set outNameSpace = objOLApp.GetNamespace("MAPI")
    Set outFolder = outNameSpace.GetDefaultFolder(6)    'olFolderInbox=6
    Set outItem = objOLApp.CreateItem(0)                'olMailItem=0
    outItem.Body = strMsg
    outItem.Subject = strSubject
    outItem.To = strTo

    With outItem.Attachments
        For lngAttachment = LBound(AttachmentList) To UBound(AttachmentList)
            .Add AttachmentList(lngAttachment)
        Next lngAttachment
    End With

    outItem.Send
    Outlook_SendEmail = True

exit_Outlook_SendEmail:
    On Error Resume Next
    Set outItem = Nothing
    Set outFolder = Nothing
    Set outNameSpace = Nothing
    Set objOLApp = Nothing
    Exit Function

err_Outlook_SendEmail:
    Select Case Err.Number
        Case 287
            'User stopped Outlook from sending email.
            MsgBox "Email Cancelled.", vbInformation, "DCDS"
        Case Else
            MsgBox "Error " & Err.Number & " (" & Err.Description _
                   & ") in procedure Outlook_SendEmail of Module mod_Utilities"
    End Select

    Resume exit_Outlook_SendEmail

End Function

Function Outlook_FileAtchmt(sSubjectLn As String, sSaveAsFilePath As String, _
                                sUnzipToPath As String) As Boolean
'Purpose  : Get zipped file attachment from email and save it as a file in the
'folder specified by sSaveFilePath. This folder will be moved to the network as soon as
'mailbox is set up.
'
'It may be necessary to add a date/time suffix to the file to prevent overwriting
'if the name is always the same.
    Dim objOLApp As New Outlook.Application     'early binding
    Dim outFolder As MAPIFolder
    Dim outNameSpace As NameSpace
    Dim outItem
    Dim outAttachment As Attachment
    Dim AttachmentCopy As Attachment
    Dim sFile As String
    On Error GoTo err_Outlook_FileAtchmt
    
    'make sure file path ends with backslash
    If Right(sSaveAsFilePath, 1) <> "\" Then
        sSaveAsFilePath = sSaveAsFilePath & "\"
    End If
    
    sSubjectLn = UCase(sSubjectLn)    'make it all CAPS
    Set outNameSpace = objOLApp.GetNamespace("MAPI")
    
'***************************************************************************************
'If logIn is to be required, uncomment this section and LogOff line at end of function
'after mailbox is established and change code to prompt for password.
'Otherwise delete section.
'
'    'log on to Outlook as user with access to ATS mailbox.
'    'Show Profile dialog;use new session
'    outNameSpace.Logon "<Profile Name goes here>", "<Password goes here>", True, True
'***************************************************************************************
    
    Set outFolder = outNameSpace.GetDefaultFolder(olFolderInbox)
     
    'Loop through all items in mailbox. Get email by subject.
    For Each outItem In outFolder.Items
        If UCase(outItem.Subject) = sSubjectLn Then
            'Get all attachments and save them as files in ATS_Files folder
            For Each outAttachment In outItem.Attachments
                sFile = outAttachment.FileName
                'save attacjment as file to specified folder
                outAttachment.SaveAsFile sSaveAsFilePath & sFile
            Next
            
            'Unzip file to import folder
            If UnZipFile(sSaveAsFilePath, sFile, sUnzipToPath) Then
                outItem.UnRead = False
                Outlook_FileAtchmt = True
            Else: MsgBox "Could not unzip file." & vbNewLine & "Import Process has been terminated", _
                vbCritical
                Exit Function
            End If
        End If
    Next
    
    'clear instance of Outlook from memory
    Set objOLApp = Nothing
exit_Outlook_FileAtchmt:
    On Error Resume Next
    Set outFolder = Nothing
    Set outNameSpace = Nothing
    Exit Function
    
err_Outlook_FileAtchmt:
    MsgBox "Error " & Err.Description
    Resume Next

End Function

Function UnZipFile(sZipFilePath As String, sZipFile As String, _
            sUnzipToPath As String) As Boolean
'Purpose  : Run WinZip CommandLine Add-On to unzip password-protected file.
'User is prompted for password
    Dim RetVal
    Dim sShellString As String
    
    If gbolErrorTrapOff = False Then On Error GoTo err_UnZipFile

     'Make sure file made it to folder
    If CheckFile(sZipFilePath, sZipFile) Then
        'remove file extension if any
        If InStr(sZipFile, ".") Then
            sZipFile = Left(sZipFile, InStr(sZipFile, ".") - 1)
        End If

        'Command line: wzunzip -s ZippedFile PathToUnzipTo
        ' -s switch prompts for password
         sShellString = "c:\Program Files\winzip\wzunzip -s " & sZipFilePath & sZipFile _
             & " " & sUnzipToPath
         RetVal = Shell(sShellString, vbNormalFocus)
        UnZipFile = True
    End If

exit_UnZipFile:
    On Error Resume Next
    WarnOn
    Exit Function

err_UnZipFile:
    gProcName = "UnZipFile"
    glngErrNum = Err.Number
    gstrErrDescr = Err.Description
    Call ErrorLog("mod_Utilities")
    Resume exit_UnZipFile

'Alternate error handler
'   MsgBox "Error " & Err.Number & " (" & Err.Description _
'       & ") in procedure UnZipFile of Module mod_Utilities"
'   Resume exit_UnZipFile
    
End Function

Public Function CDO_SendEmail()
'Purpose  : Need to add MS CDO 1.21 library.
'DateTime : 3/3/2006 10:39
'Author   : Bill Mosca
Dim myMail As CDO.Message

    If gbolErrorTrapOff = False Then On Error GoTo err_CDO_SendEmail

Set myMail = New CDO.Message
myMail.Subject = "Email Test"
myMail.To = "xxx@XXX.com"
myMail.From = "yyy@XXX.com"
myMail.TextBody = "Bla Blah"
myMail.AddAttachment "file://C:\MyFile.txt"
myMail.Configuration.Fields(CDO.cdoSendUsingMethod).Value = CDO.cdoSendUsingPort
myMail.Configuration.Fields(CDO.cdoSMTPServer).Value = "username/outgoingserver"
myMail.Configuration.Fields(CDO.cdoSMTPServerPort).Value = 25
myMail.Configuration.Fields.Update
myMail.Send
Set myMail = Nothing

exit_CDO_SendEmail:
    On Error Resume Next
    Exit Function

err_CDO_SendEmail:
    Select Case Err.Number
        Case 2501
            'Open cancelled.
            MsgBox "No information for selected filter.", _
                vbInformation, GetSummaryInfo("Title", False)
        Case Else
            gProcName = "CDO_SendEmail"
            glngErrNum = Err.Number
            gstrErrDescr = Err.Description
            glngLineNum = Erl
            Call ErrorLog("basEmail")
    End Select
    
    Resume exit_CDO_SendEmail

End Function

Sub SendMAPIMessage()
'Purpose  : Sets an object variable to the MAPI Session object
' using the CreateObject() function. Then, it logs on to the session
' using a predefined profile. As soon as you are logged on,
' the procedure creates
' a new message and adds it to the Messages collection of the Outbox
' of the user. Then, it creates two recipients (one on the TO: line and
' one on the CC: line) and then adds both to the Recipients collection
' of the message. Next, it resolves the names of all recipients.
' Then, it attaches a sample file before filling in the Subject,
' Text, and Importance attributes of the message.
'DateTime : 1/23/2007 15:07
'Author   : MS
'           http://support.microsoft.com/kb/153311
'Reference: OLE/Messaging 1.0 Object Library
    Dim MapiSession As Object
    Dim MapiMessage As Object
    Dim MapiRecipient As Object
    Dim MapiAttachment As Object
    Dim Recpt
    Dim errObj As Long
    Dim errMsg

    On Error GoTo MAPITrap
    ' Create the MAPI Session.
    Set MapiSession = CreateObject("Mapi.Session")

    ' Log on to the session. If the ProfileName argument is omitted,
    ' Microsoft Exchange prompts you for the profile to use. If the
    ' profile name is incorrect, you receive a runtime error.
    MapiSession.Logon profilename:="Steven Buchanan"

    ' Add a message to the Outbox.
    Set MapiMessage = MapiSession.Outbox.Messages.Add

    ' Add the recipients of the message. Note, each recipient must be
    ' added separately to the Recipients collection of the Message
    ' object.

    With MapiMessage
        Set MapiRecipient = MapiMessage.Recipients.Add
        MapiRecipient.Name = "Nancy Davolio"
        MapiRecipient.Type = mapiTo
        Set MapiRecipient = MapiMessage.Recipients.Add
        MapiRecipient.Name = "Andrew Fuller"
        MapiRecipient.Type = mapiCc
        Set MapiRecipient = MapiMessage.Recipients.Add
        MapiRecipient.Name = "Michael Suyama"
        MapiRecipient.Type = mapiBcc

        ' Resolve each recipient's e-mail name.
        ' Starting with Outlook version 8.03 (ref. Q172623)
        ' OLE Messaging 1.0 was replaced with Active Messaging 1.1.
        ' Outlook 98 (version 8.5) replaced Active Messaging
        ' with Microsoft CDO (Collaborative Data Objects) 1.21.
        ' OLE Messaging 1.0 uses a zero-based Recipients collection;
        ' Active Messaging 1.1 and Microsoft CDO 1.21 are 1-based.
        For Recpt = 1 To .Recipients.Count
            .Recipients(Recpt).Resolve showdialog:=False
        Next

        ' Attach a file to the message.
        Set MapiAttachment = MapiMessage.Attachments.Add
        With MapiAttachment
            .Name = "Customers.txt"
            .Type = mapiFileData
            .Source = "C:\Examples\Customers.txt"
            .ReadFromFile FileName:="C:\Examples\Customers.txt"
            .position = 2880
        End With

        ' Assign the text, subject, and importance of the message.
        .Subject = "My Subject"
        .Text = "This is the text of my message." & vbCrLf & vbCrLf
        .importance = mapiHigh

        ' View the message in Microsoft Exchange before sending. Set
        ' the ShowDialog argument to False if you want to send the
        ' message without viewing it in Microsoft Exchange.
        .Send showdialog:=True
    End With
    Set MapiSession = Nothing  ' Clear the object variable.

MAPIExit:
    Exit Sub

MAPITrap:
    errObj = Err - vbObjectError  ' Strip out the OLE automation error.
    Select Case errObj
        Case 275                  ' User cancelled sending of message.
            Resume MAPIExit
        Case Else
            errMsg = MsgBox("Error " & errObj & " was returned.")
            Resume MAPIExit
    End Select
End Sub