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

Select allOpen in new window

This is trowing a "Object required error" at
 mai.Item "c:\draft\" & subject & " " & Item.EntryID & ".rtf", olRTF
 

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

Select allOpen in new window

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.

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

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

Select allOpen in new window

Do you mean you want to run savedos when the replyspecial macro runs?

Chris

Working Great..Thank you.

Glad to help

Chris