Outlook - copy/rename file before attaching to email. 1

[sparkbyte]

I was given a new require to our daily report that is sent out. Add a datestamp to the attached file name.

Here is the VBA code I cobbled together from examples to create the basic email. What I need to do is find a way to copy the original file to a new name and attach the new file that has a date stamp.

DailyReport.xls becomes 20100223_DailyReport.xls

Sub Daily_Report()
    Dim msg As Outlook.MailItem
    Set msg = Application.CreateItem(olMailItem)
    strToList = "Recip1; Recip2"
    msg.To = strToList
    strCCList = "CC1; CC2; CC3"
    msg.CC = strCCList
    msg.Subject = "Daily Report for " & Date
        strSig1 = "John F Fuhrman III"
        strSig2 = vbCrLf & "Title"
        strSig3 = vbCrLf & "Company Name"
        strSig4 = vbCrLf & "Street Address"
        strSig5 = vbCrLf & "City, State  Zipcode"
        strSig6 = vbCrLf & "Office:  "
        strSig7 = vbCrLf & "Fax:     "
        strSig8 = vbCrLf & "Email:   "
    strSignature = strSig1 & strSig2 & strSig3 & strSig4 & strSig5 & strSig6 & strSig7 & strSig8
    msg.Body = "Good morning," & vbCrLf & "Attached is the Daily Report." & vbCrLf & vbCrLf & vbCrLf & strSignature
    msg.Display
    msg.Attachments.Add ("R:\Reports\DailyReport\FY_2010_DailyReport.xls")
    Set msg = Nothing
End Sub

Thanks

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

 

[SkipVought]

Hi,

I'd suggest using CDO rather than the OUTLOOK object. BUT...

   dim sPath as string, sName as string

   sPath = "R:\Reports\DailyReport"

   sName = format(date, "yyyymmdd") & "_" & thisworkbook.name

    msg.Attachments.Add (sPath & "\" & sName)

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}

 

[sparkbyte]

Thanks, that got me to where I needed to get started.

Here is what I think will work.

    strSource = "R:\Reports\DailyReport\FY_2010_DailyReport.xls"
    strDest = "R:\Reports\DailyReport\Sent\" & Format(Date, "yyyymmdd") & "_Daily_Report.xls"
    FileCopy strSource, strDest
    msg.Attachments.Add (strDest)

BTW, what do you mean by

I'd suggest using CDO rather than the OUTLOOK object.

Thanks

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

 

[SkipVought]

Don't have to mess with security questions, allowing outlook to run, etc.

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}

 

[sparkbyte]

I just added an icon to the standard tool bar that runs the Module with no problems.

New email comes up properly formatted copies the file to the "sent" directory. No problems about running macros.


Thanks

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

 

[sparkbyte]

Just to properly close this thread.

Here is the finished VBA code.

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
   
   Dim objOutlook As Outlook.Application
   Dim objOutlookMsg As Outlook.MailItem
   Dim objOutlookRecip As Outlook.Recipient
   Dim objOutlookAttach As Outlook.Attachment


    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\FY_2010_Report.xls"
    StrDest = "R:\Reports\DailyReport\Sent\" & _
               Format(Date, "yyyymmdd") & "_Report.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 the Outlook session.
   Set objOutlook = CreateObject("Outlook.Application")

   ' Create the message.
   Set objOutlookMsg = objOutlook.CreateItem(olMailItem)

' Create email and attachments
    On Error Resume Next
    
    With objOutlookMsg
          
    ' Add the To recipient(s) to the message.
        Set objOutlookRecip = .Recipients.Add("")
        objOutlookRecip.Type = olTo
    ' Add the CC recipient(s) to the message.
        Set objOutlookRecip = .Recipients.Add("")
        objOutlookRecip.Type = olCC
'    ' Add the BCC recipient(s) to the message.
'        Set objOutlookRecip = .Recipients.Add("")
'        objOutlookRecip.Type = olBCC
    
    ' Set the Subject, Body, and Importance of the message.
        .Subject = "Daily Report for " & Date
        .HTMLBody = strbody & Signature
        .Importance = olImportanceHigh
        .Display
        
        If FileOrDirExists(StrDest) = True Then
            Answer = MsgBox("Report for today already exists!!" & vbCrLf & _
                    "Did you already send the report??", _
                        vbQuestion + vbYesNo, "File Exists")
            Select Case Answer
                Case vbYes
                    MsgBox ("Deleting Email and Exiting Script.")
                    .Delete
                    Exit Sub
                Case vbNo
                    .Attachments.Add (StrDest)
                Case Else
                    MsgBox ("Exiting, Script crashed!!")
                    .Delete
                    Exit Sub
            End Select
        Else
            FileCopy strSource, StrDest
            .Attachments.Add (StrDest)
        End If
    
    ' Resolve each Recipient's name.
        For Each objOutlookRecip In .Recipients
           objOutlookRecip.Resolve
           If Not objOutlookRecip.Resolve Then
           objOutlookMsg.Display
        End If
        Next
    
    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
thread705-1592825