Send Outlook email with Attachment and Signature

[sparkbyte]

For those of us that are stuck doing daily reports as busy work. Here is a great example of a Sub/Function to create an email that also applies your signature.

http://www.rondebruin.nl/mail/folder3/signature.htm

-----------------------------------------------------

Here is a completed Module for Outlook that I cobbled together using several examples on the internet. I hope this will be helpfull to someone else.

I added a file copy with Date stamp to a subfolder and a check for the existance of the file so you can double check before sending out the report twice..

Sub Mail_Outlook_With_Signature_Html()

‘<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
‘
‘	Author:	John Fuhrman III
‘	Date:	February 25, 2010
‘	Version:	1.0
‘	Script Notes:
‘	Script was created to send the Daily Report
‘	
‘<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>

    ‘ Insert Outlook Signature in mail
    ‘ Ron de Bruin
    ‘ Last updated 20-Feb-2010
    ‘ Original Script Found at:  
    ‘      [URL unfurl="true"]http://www.rondebruin.nl/mail/folder3/signature.htm[/URL]

‘ This Function WILL NOT work if your email editor is set to MS Word.
‘
‘ Don’t forget to copy the function GetBoiler in the module.
‘ Working in Office 2000-2010

    Dim strbody As String
    Dim SigString As String
    Dim Signature As String
    Dim strSource As String
    Dim StrDest As String
    Dim OutApp As Outlook.Application
    Dim OutMail As Outlook.MailItem
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(olMailItem)

    SigString = "C:\Documents and Settings\" & Environ("username") & _
    "\Application Data\Microsoft\Signatures\MySignature.htm"

‘ Define source and destination for file copy and attachment
    strSource = _
"R:\Reports\DailyReport\ Daily_Report.xls"
    StrDest = _
"R:\Reports\DailyReport\Sent\" & _
      Format(Date, "yyyymmdd") & "_DailyReport.xls"
  
‘ Get formatted Signature
        If Dir(SigString) <> "" Then
            Signature = GetBoiler(SigString)
        Else
            Signature = ""
        End If
    
    
    strbody = "<H3><B>Good Morning!</B></H3>" & _
              "Attached is the Daily Report.<br>" & _
              "Let me know if you have problems.<br>"

‘ Create email and attachments
    On Error Resume Next
    With OutMail
        .To = "Cole, Vicki L; Orr, Lawrence D"
        .CC = "Dickinson, Keith A; Chambers, Jeffrey L; Powell, Kevin A"
        .BCC = ""
        .Subject = "Daily NRC OIT Report for " & Date
        
            If FileOrDirExists(StrDest) = True Then
                .Attachments.Add (StrDest)
                Answer = MsgBox("Report for today already exists!!" _
& vbCrLf & "Did you already send the report??", _
                            vbQuestion + vbYesNo, "File Exists")
                        If Answer = vbYes Then
                        Exit Sub
                        End If
            Else
                FileCopy strSource, StrDest
                .Attachments.Add (StrDest)
            End If
        .HTMLBody = strbody & Signature
      .Display
    End With
    
    
    On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

Function GetBoiler(ByVal sFile As String) As String
‘Dick Kusleika
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
    ts.Close
End Function

Function FileOrDirExists(PathName As String) As Boolean
    ‘ Author: Ken Puls
    ‘ Version:  2000, 2002, 2003, 2004 (Mac)
    ‘ Originaly Found at:  [URL unfurl="true"]http://www.vbaexpress.com/kb/getarticle.php?kb_id=559[/URL]
    
     ‘Macro Purpose: Function returns TRUE if the specified file
     ‘               or folder exists, false if not.
     ‘PathName     : Supports Windows mapped drives or UNC
     ‘             : Supports Macintosh paths
     ‘File usage   : Provide full file path and extension
     ‘Folder usage : Provide full folder path
     ‘               Accepts with/without trailing "\" (Windows)
     ‘               Accepts with/without trailing ":" (Macintosh)
     
    Dim iTemp As Integer
     
     ‘Ignore errors to allow for error evaluation
    On Error Resume Next
    iTemp = GetAttr(PathName)
     
     ‘Check if error exists and set response appropriately
    Select Case Err.Number
    Case Is = 0
        FileOrDirExists = True
    Case Else
        FileOrDirExists = False
    End Select
     
     ‘Resume error checking
    On Error GoTo 0
End Function

Thanks

John Fuhrman
faq329-6766
faq329-7301
thread329-1334328
thread329-1424438

 

[sparkbyte]

I found a good example from MS that is done as sub that you can pass the file attachment to as a parameter.

http://support.microsoft.com/?kbid=209948

Thanks

John Fuhrman
faq329-6766
faq329-7301
thread329-1334328
thread329-1424438
thread705-1592825