Save Draft before sending MS Outlook VBA

I want to save the message with attachment and all before sending, in a particular folder at my hard disk say c:\Draft.

I need a VBA code for this.

I am using MS Offfice 2003 and WIndows XP.

Please help.
LVL 9
suvmitraAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Chris BottomleySoftware Quality Lead EngineerCommented:
Hello suvmitra,

Place the snippet code in a normal code module and the following in thisOutlookSession

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    savesentDOS Item
End Sub

To Create a macro:
------------------

Alt + F11 to open the macro editor
     In the project tree select as appropriate:
      OUTLOOK      : thisOutlookSession
     In the workpane select as appropriate:
      OUTLOOK      : General
     In the workpane select the required 'event', (i.e. 'open').
     Insert the required macro(s) into the selected subroutine.
  For User Code:
     Insert | Module to insert a code module into the project
     In the project tree select the module.
     Insert the required macro(s) into the selected module, ('Module1' or similar)
  For a Class Code Module:
     Insert | Class Module to insert a class code module into the project
     In the project tree select the module.
     Insert the required macro(s) into the selected module, ('Class1' or similar)
Close the Visual Basic Editor.

Check Security as appropriate:
------------------------------

In the application select Tools | Macro | Security
Select Medium
Select OK


Regards,
Chris
Sub savesentDOS(ByVal Item As Object)
    If Item.BodyFormat = olFormatHTML Then
        Item.SaveAs "c:\draft\" & subject & " " & Item.EntryID & ".htm", olHTML
    ElseIf Item.BodyFormat = olFormatRichText Then
        mai.Item "c:\draft\" & subject & " " & Item.EntryID & ".rtf", olRTF
    Else
        mai.Item "c:\draft\" & subject & " " & Item.EntryID & ".msg", olMsg
    End If
End Sub

Open in new window

0
suvmitraAuthor Commented:
This is trowing a "Object required error" at
 mai.Item "c:\draft\" & subject & " " & Item.EntryID & ".rtf", olRTF
 
0
Chris BottomleySoftware Quality Lead EngineerCommented:
DOn't know how that got missed ...

I have modified savesentDOS and added a function cleanSubject this as below.

Chris
Sub savesentDOS(ByVal Item As Object)
    If Item.BodyFormat = olFormatHTML Then
        Item.SaveAs "c:\draft\" & cleanSubject(item.subject) & " " & Item.EntryID & ".htm", olHTML
    ElseIf Item.BodyFormat = olFormatRichText Then
        mai.Item "c:\draft\" & cleanSubject(item.subject) & " " & Item.EntryID & ".rtf", olRTF
    Else
        mai.Item "c:\draft\" & cleanSubject(item.subject) & " " & Item.EntryID & ".msg", olMsg
    End If
End Sub
 
Function cleanSubject(str As String) As String
Dim lenString As Integer
    For lenString = 1 To Len(str)
        If Mid(str, lenString, 1) Like "[!\/:*?<>|]" And Mid(str, lenString, 1) <> Chr(34) Then cleanSubject = cleanSubject & Mid(str, lenString, 1)
    Next
    Do While Right(cleanSubject, 1) = "."
        cleanSubject = Left(cleanSubject, Len(cleanSubject) - 1)
    Loop
End Function

Open in new window

0
Determine the Perfect Price for Your IT Services

Do you wonder if your IT business is truly profitable or if you should raise your prices? Learn how to calculate your overhead burden with our free interactive tool and use it to determine the right price for your IT services. Download your free eBook now!

suvmitraAuthor Commented:
Thank you this is working great. But I have two concerns:
1) Current action replacing the existing message if it has same subject line..I need when it saves it should not replace the existing..instead it should copy itself and rename itself say..if directory contains "Reply.msg" the new file should be copied itself there as "Reply(1).msg"..then "Reply(2)" msg etc.
2) I do not want to save all the messages into my hard drive..instead I want to save a category of replies.
I already have a Outlook Macro for this special category..I want to trigger savesentDOS when I am calling SpMacro()....or is it possible to have a special customized macro button for this?
I just want to seperate (1) Normal Sending (2) Special Sending.
 
Thank you.
0
Chris BottomleySoftware Quality Lead EngineerCommented:
If you want to call savesentDOS from SpMacro then you need to pass the parameter that relates to the email.  If you are not comfortable with how then you will need to post the code for savesentDOS here.

As for incremental save whilst that is possible I should have avoided the work by adding the entryid to the filename.  IN this case a specific email will always overwrite itself but different emails with the same subject should not - can you review this action?

Chris
0
suvmitraAuthor Commented:
Hi,
This is the entire staff I am using I want to initiate savesentDOS with replySpecial()..or If we could have another another button for avesentDOS is welcome.
 

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim strSubject As String
strSubject = Item.Subject
'savesentDOS Item
If Len(strSubject) = 0 Then
Prompt$ = "Subject is Empty. Are you sure you want to send the Mail?"
If MsgBox(Prompt$, vbYesNo + vbQuestion + vbMsgBoxSetForeground, "Check for Subject") = vbNo Then
Cancel = True
End If
End If
savesentDOS Item
End Sub
Sub savesentDOS(ByVal Item As Object)
    If Item.BodyFormat = olFormatHTML Then
        Item.SaveAs "c:\draft\" & cleanSubject(Item.Subject) & " " & Item.EntryID & ".msg", olMSG
    ElseIf Item.BodyFormat = olFormatRichText Then
        mai.Item "c:\draft\" & cleanSubject(Item.Subject) & " " & Item.EntryID & ".msg", olMSG
    Else
        mai.Item "c:\draft\" & cleanSubject(Item.Subject) & " " & Item.EntryID & ".msg", olMSG
    End If
End Sub
Function cleanSubject(str As String) As String
Dim lenString As Integer
    For lenString = 1 To Len(str)
        If Mid(str, lenString, 1) Like "[!\/:*?<>|]" And Mid(str, lenString, 1) <> Chr(34) Then cleanSubject = cleanSubject & Mid(str, lenString, 1)
    Next
    Do While Right(cleanSubject, 1) = "."
        cleanSubject = Left(cleanSubject, Len(cleanSubject) - 1)
    Loop
End Function
 
Sub replySpecial()
On Error Resume Next
Dim maiNew As Outlook.MailItem
Dim maiOrig As Object
    
    If TypeName(Application.ActiveWindow) = "Explorer" Then
        Set maiOrig = Application.ActiveExplorer.Selection.Item(1)
    ElseIf TypeName(Application.ActiveWindow) = "Inspector" Then
            Set maiOrig = Application.ActiveInspector.CurrentItem
    Else
        Exit Sub
    End If
    If Not maiOrig Is Nothing Then
        'Set maiNew = maiOrig.Reply
        Set maiNew = maiOrig.ReplyAll
                CopyAttachments maiOrig, maiNew
        maiNew.Display
        
    End If
    
Set maiNew = Nothing
Set maiOrig = Nothing
End Sub
 
Sub CopyAttachments(objSourceItem, objTargetItem)
Dim fso As Object
Dim fldTemp As Object
Dim strPath As String
Dim strFile As String
Dim objatt As Object
Dim fileType As String
 
 
   Set fso = CreateObject("Scripting.FileSystemObject")
   Set fldTemp = fso.GetSpecialFolder(2) 'Temp
   strPath = fldTemp.Path & "\"
   For Each objatt In objSourceItem.Attachments
      fileType = LCase(Right(objatt.FileName, Len(objatt.FileName) - InStrRev(objatt.FileName, ".")))
      If fileType <> "jpg" And fileType <> "jpeg" And fileType <> "bmp" And fileType <> "gif" And fileType <> "png" And fileType <> "jpe" And fileType <> "pict" And fileType <> "pct" And fileType <> "zzzzz" And fileType <> "zzzzz" And fileType <> "zzzzz" And fileType <> "zzzzz" Then
        strFile = strPath & objatt.FileName
        objatt.SaveAsFile strFile
        objTargetItem.Attachments.Add strFile, , , objatt.DisplayName
        fso.DeleteFile strFile
    End If
   Next
    Set fldTemp = Nothing
   Set fso = Nothing
End Sub

Open in new window

0
Chris BottomleySoftware Quality Lead EngineerCommented:
Do you mean you want to run savedos when the replyspecial macro runs?

Chris
0
Chris BottomleySoftware Quality Lead EngineerCommented:
If so then assuming it is the original mail you want to save then replace the above code with the snippet and see how it looks.

Chris
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim strSubject As String
 
    strSubject = Item.Subject
    If Len(strSubject) = 0 Then
        Prompt$ = "Subject is Empty. Are you sure you want to send the Mail?"
        If MsgBox(Prompt$, vbYesNo + vbQuestion + vbMsgBoxSetForeground, "Check for Subject") = vbNo Then
            Cancel = True
        End If
    End If
'    savesentDOS Item
End Sub
Sub savesentDOS(ByVal Item As Object)
    If Item.BodyFormat = olFormatHTML Then
        Item.SaveAs "c:\draft\" & cleanSubject(Item.Subject) & " " & Item.EntryID & ".msg", olMSG
    ElseIf Item.BodyFormat = olFormatRichText Then
        mai.Item "c:\draft\" & cleanSubject(Item.Subject) & " " & Item.EntryID & ".msg", olMSG
    Else
        mai.Item "c:\draft\" & cleanSubject(Item.Subject) & " " & Item.EntryID & ".msg", olMSG
    End If
End Sub
Function cleanSubject(str As String) As String
Dim lenString As Integer
    For lenString = 1 To Len(str)
        If Mid(str, lenString, 1) Like "[!\/:*?<>|]" And Mid(str, lenString, 1) <> Chr(34) Then cleanSubject = cleanSubject & Mid(str, lenString, 1)
    Next
    Do While Right(cleanSubject, 1) = "."
        cleanSubject = Left(cleanSubject, Len(cleanSubject) - 1)
    Loop
End Function
 
Sub replySpecial()
On Error Resume Next
Dim maiNew As Outlook.mailitem
Dim maiOrig As Object
    
    If TypeName(Application.ActiveWindow) = "Explorer" Then
        Set maiOrig = Application.ActiveExplorer.Selection.Item(1)
    ElseIf TypeName(Application.ActiveWindow) = "Inspector" Then
            Set maiOrig = Application.ActiveInspector.CurrentItem
    Else
        Exit Sub
    End If
    If Not maiOrig Is Nothing Then
        'Set maiNew = maiOrig.Reply
        Set maiNew = maiOrig.ReplyAll
                CopyAttachments maiOrig, maiNew
        maiNew.Display
        savesentDOS maiOrig
 
    End If
    
Set maiNew = Nothing
Set maiOrig = Nothing
End Sub
 
Sub CopyAttachments(objSourceItem, objTargetItem)
Dim fso As Object
Dim fldTemp As Object
Dim strPath As String
Dim strFile As String
Dim objatt As Object
Dim fileType As String
 
 
   Set fso = CreateObject("Scripting.FileSystemObject")
   Set fldTemp = fso.GetSpecialFolder(2) 'Temp
   strPath = fldTemp.Path & "\"
   For Each objatt In objSourceItem.Attachments
      fileType = LCase(Right(objatt.FileName, Len(objatt.FileName) - InStrRev(objatt.FileName, ".")))
      If fileType <> "jpg" And fileType <> "jpeg" And fileType <> "bmp" And fileType <> "gif" And fileType <> "png" And fileType <> "jpe" And fileType <> "pict" And fileType <> "pct" And fileType <> "zzzzz" And fileType <> "zzzzz" And fileType <> "zzzzz" And fileType <> "zzzzz" Then
        strFile = strPath & objatt.FileName
        objatt.SaveAsFile strFile
        objTargetItem.Attachments.Add strFile, , , objatt.DisplayName
        fso.DeleteFile strFile
    End If
   Next
    Set fldTemp = Nothing
   Set fso = Nothing
End Sub

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
suvmitraAuthor Commented:
Working Great..Thank you.
0
Chris BottomleySoftware Quality Lead EngineerCommented:
Glad to help

Chris
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Programming

From novice to tech pro — start learning today.