vba code for outlook ----email saving

[indiewolf]

while saving an email message in outlook i would like to build a macro in outlook so that i can do the following:

1)extract the date from the email in reverse ie yyyy-mm--dd

2) user input for the filename

3) extract the subject heading of the email into the saving field

so combining 1,2,3 the email wud be saved with the resulting name.

can somebody help me with it.

i am very new to macro coding for vba.

thanking you

cheers!!!

[RobDog888]

Its a bit of code but mostly for invoking the procedure. It may be simplier to select the email and click a custom menu item to invoke the save and prompt you for the info. Does this sound ok?

[indiewolf]

Its a bit of code but mostly for invoking the procedure. It may be simplier to select the email and click a custom menu item to invoke the save and prompt you for the info. Does this sound ok?

hi ,
thanks for replying.

well can u plz elaborate on what u have said.

i am using outlook 2003 , i dont think there is any custom menu which can help me save the email messages in my desired format name.

thanks


cheers!!

[RobDog888]

No there isnt, we will have to create one via code.

If I get some time I will write an example for you.

[indiewolf]

No there isnt, we will have to create one via code.

If I get some time I will write an example for you.

oh thanks a lot!!
cheerS!!

[indiewolf]

No there isnt, we will have to create one via code.

If I get some time I will write an example for you.

can u just give an eg or a way so that i can get it starting adn perhaps post whatever i code over here so that it saves our time of developing the whole code.

thanks

cheers!!

[indiewolf]

hello???

sumbody help

[RobDog888]

Sorry for the delay but I havent been online lately.

Here it is. Add this to your ThisOutlookSession and make sure Macros are enabled.

With this, you make a selection of the email you want to save. Then go into the "Tools > Save Email As.." custom menu item and click it. Then the item will be saved using the subject. You can add on the reverse date and a user prompt for the filename if you want. Here is the major functionality you asked for.

You may also want to error trap for a MailItem and multiple selections, etc.

Option Explicit
'Behind ThisOutlookSession
Private oCBTools As Office.CommandBarPopup
Private oCBSaveMe As Office.CommandBarButton
 
Public WithEvents oSaveAs As Office.CommandBarButton
 
Private Sub SyncButton(btn As Office.CommandBarButton)
    Set oSaveAs = btn
    If btn Is Nothing Then
        MsgBox "Sync. of '" & btn.Caption & "' button event failed!", vbCritical + vbOKOnly
    End If
End Sub
 
Private Sub Application_MAPILogonComplete()
    Set oCBTools = Application.ActiveExplorer.CommandBars("Menu Bar").Controls("&Tools")
    Set oCBSaveMe = Application.ActiveExplorer.CommandBars("Menu Bar").FindControl(msoControlButton, 1, "888", True, True)
    If TypeName(oCBSaveMe) = "Nothing" Then
        Set oCBSaveMe = oCBTools.Controls.Add(msoControlButton, 1, "888", , True)
    End If
    With oCBSaveMe
        .BeginGroup = True
        .Caption = "Save Email As..."
        .Enabled = True
        .Style = msoControlCustom
        .Tag = "888"
        .Visible = True
    End With
    Call SyncButton(oCBSaveMe)
End Sub
 
Private Sub oSaveAs_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
    
    Dim oSel As Outlook.Selection
    Dim oEmail As Outlook.MailItem
    Dim sSub As String
    
    Set oSel = Application.ActiveExplorer.Selection
    If oSel.Class = olMail Then
        Set oEmail = oSel
        'Use the email subject as the filename
        sSub = oEmail.Subject
        'Parse out any invalid characters for a filename.
        sSub = Replace(sSub, ":", vbNullString)
        sSub = Replace(sSub, "*", vbNullString)
        sSub = Replace(sSub, "/", vbNullString)
        sSub = Replace(sSub, "\", vbNullString)
        sSub = Replace(sSub, "?", vbNullString)
        sSub = Replace(sSub, "<", vbNullString)
        sSub = Replace(sSub, ">", vbNullString)
        sSub = Replace(sSub, "|", vbNullString)
        sSub = Replace(sSub, Chr(34), vbNullString)
        'Add code for checking for duplicate filenames and implement a index number if so
        oEmail.SaveAs "C:\MyEmails\" & sSub & ".txt", olTXT
        Set oEmail = Nothing
        MsgBox "Saved"
    End If
    Set oSel = Nothing
    
End Sub

[cillianmccarthy]

Hi There,

This is exactly what I was looking for - except I can't get it to work!!

I have added it to ThisOutlookSession and the "Save Email As" appears in the tools menu.

But when I select an email and then click on the command nothing happens.

I did enter a ' before all the lines in the Private Sub oSaveAs_Click except for the msgbox, and when I click it displays the box.

Can you help? (I am using Outlook 2003)

Thanks a million

Cillian

[RobDog888]

Welcome to the Forums.

Did you add all the rest of the code? Do you have Macros enabled? did you restart Outlook?

[cillianmccarthy]

Hi There,

Thanks for the fast reply -

I have definately added all of the code in your post.

I have set my macro security to low.

I have re-strated a number of times (each time I made a change to your original)

This might sound a bit simple but - how do you select the email? I have myu inbox open and am clicking on them in the list of emails - is this right?

Thanks again

Cillian

[RobDog888]

Yes, that is how and just try a single selection first as I didnt code it to handle multiple selections.

Just set your Macro security to Medium and when outlook starts just select Enable. This is safer then Low.

[cillianmccarthy]

Hi again,

Still nothing :-(

[RobDog888]

You did get the menu item?

[RobDog888]

This is all you should have as a test to make sure the click event works.

After you paste it in, save and close it and log off Outlook and exit it. It should not be showing as running in your task manager at all.

Option Explicit
'Behind ThisOutlookSession
Private oCBTools As Office.CommandBarPopup
Private oCBSaveMe As Office.CommandBarButton
 
Public WithEvents oSaveAs As Office.CommandBarButton
 
Private Sub SyncButton(btn As Office.CommandBarButton)
    Set oSaveAs = btn
    If btn Is Nothing Then
        MsgBox "Sync. of '" & btn.Caption & "' button event failed!", vbCritical + vbOKOnly
    End If
End Sub
 
Private Sub Application_MAPILogonComplete()
    Set oCBTools = Application.ActiveExplorer.CommandBars("Menu Bar").Controls("&Tools")
    Set oCBSaveMe = Application.ActiveExplorer.CommandBars("Menu Bar").FindControl(msoControlButton, 1, "888", True, True)
    If TypeName(oCBSaveMe) = "Nothing" Then
        Set oCBSaveMe = oCBTools.Controls.Add(msoControlButton, 1, "888", , True)
    End If
    With oCBSaveMe
        .BeginGroup = True
        .Caption = "Save Email As..."
        .Enabled = True
        .Style = msoControlCustom
        .Tag = "888"
        .Visible = True
    End With
    Call SyncButton(oCBSaveMe)
End Sub
 
Private Sub oSaveAs_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
    MsgBox "Saved"
End Sub

[cillianmccarthy]

Hi,

OKay - That definately works - when I click I get the Saved message box

[RobDog888]

Ok, there must be an error from having multiple selections. Update your click event to this new one with error handling.

Private Sub oSaveAs_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
    
    On Error GoTo MyError
 
    Dim oSel As Outlook.Selection
    Dim oEmail As Outlook.MailItem
    Dim sSub As String
    
100    Set oSel = Application.ActiveExplorer.Selection
110    If oSel.Class = olMail Then
120        Set oEmail = oSel
           'Use the email subject as the filename
130        sSub = oEmail.Subject
           'Parse out any invalid characters for a filename.
           sSub = Replace(sSub, ":", vbNullString)
           sSub = Replace(sSub, "*", vbNullString)
           sSub = Replace(sSub, "/", vbNullString)
           sSub = Replace(sSub, "\", vbNullString)
           sSub = Replace(sSub, "?", vbNullString)
           sSub = Replace(sSub, "<", vbNullString)
           sSub = Replace(sSub, ">", vbNullString)
           sSub = Replace(sSub, "|", vbNullString)
           sSub = Replace(sSub, Chr(34), vbNullString)
           'Add code for checking for duplicate filenames and implement a index number if so
140        oEmail.SaveAs "C:\MyEmails\" & sSub & ".txt", olTXT
           Set oEmail = Nothing
           MsgBox "Saved"
    End If
    Set oSel = Nothing
    Exit Sub
        
MyError:
    MsgBox Err.Number & " - " & Err.Description & vbNewline & "On Line: " & Erl, vbOkOnly
 
End Sub

[cillianmccarthy]

Hi There,

I really appreciate your help with this - but still nothing happens when I click Save-Emails as. I only have 1 email selected.

This is the code currently in "ThisOutlookSession"

Option Explicit
'Behind ThisOutlookSession
Private oCBTools As Office.CommandBarPopup
Private oCBSaveMe As Office.CommandBarButton
 
Public WithEvents oSaveAs As Office.CommandBarButton
 
Private Sub SyncButton(btn As Office.CommandBarButton)
    Set oSaveAs = btn
    If btn Is Nothing Then
        MsgBox "Sync. of '" & btn.Caption & "' button event failed!", vbCritical + vbOKOnly
    End If
End Sub
 
Private Sub Application_MAPILogonComplete()
    Set oCBTools = Application.ActiveExplorer.CommandBars("Menu Bar").Controls("&Tools")
    Set oCBSaveMe = Application.ActiveExplorer.CommandBars("Menu Bar").FindControl(msoControlButton, 1, "888", True, True)
    If TypeName(oCBSaveMe) = "Nothing" Then
        Set oCBSaveMe = oCBTools.Controls.Add(msoControlButton, 1, "888", , True)
    End If
    With oCBSaveMe
        .BeginGroup = True
        .Caption = "Save Email As..."
        .Enabled = True
        .Style = msoControlCustom
        .Tag = "888"
        .Visible = True
    End With
    Call SyncButton(oCBSaveMe)
End Sub
 
Private Sub oSaveAs_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
    
    On Error GoTo MyError
 
    Dim oSel As Outlook.Selection
    Dim oEmail As Outlook.MailItem
    Dim sSub As String
    
100    Set oSel = Application.ActiveExplorer.Selection
110    If oSel.Class = olMail Then
120        Set oEmail = oSel
           'Use the email subject as the filename
130        sSub = oEmail.Subject
           'Parse out any invalid characters for a filename.
           sSub = Replace(sSub, ":", vbNullString)
           sSub = Replace(sSub, "*", vbNullString)
           sSub = Replace(sSub, "/", vbNullString)
           sSub = Replace(sSub, "\", vbNullString)
           sSub = Replace(sSub, "?", vbNullString)
           sSub = Replace(sSub, "<", vbNullString)
           sSub = Replace(sSub, ">", vbNullString)
           sSub = Replace(sSub, "|", vbNullString)
           sSub = Replace(sSub, Chr(34), vbNullString)
           'Add code for checking for duplicate filenames and implement a index number if so
140        oEmail.SaveAs "C:\MyEmails\" & sSub & ".txt", olTXT
           Set oEmail = Nothing
           MsgBox "Saved"
    End If
    Set oSel = Nothing
    Exit Sub
        
MyError:
    MsgBox Err.Number & " - " & Err.Description & vbNewLine & "On Line: " & Erl, vbOKOnly
 
End Sub

[RobDog888]

What do you mean "nothing happens"? Can you be more descriptive?

Place a breakpoint on line 110 and then go back and make a single selection, click on the menu and then step through the code by pressing F8 once per line and see where it processes.

[DubweiserTM]

Hi guys !

Sorry if I bring back an old post...

Im trying to use this code, but I've got a runtime error 13 type mismatch on this line: Set oEmail = oSel

I dont know if it's because I use Office 2007...

Private Sub oSaveAs_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)

Dim oSel As Outlook.Selection
Dim oEmail As Outlook.MailItem
Dim sSub As String

Set oSel = Application.ActiveExplorer.Selection

'If oSel.Class = olMail Then
'I use=74 instead because it doesnt enter in the condition above !
If oSel.Class = 74 Then
        Set oEmail = oSel
        'Use the email subject as the filename
        sSub = oEmail.Subject
        'Parse out any invalid characters for a filename.
        sSub = Replace(sSub, ":", vbNullString)
        sSub = Replace(sSub, "*", vbNullString)
        sSub = Replace(sSub, "/", vbNullString)
        sSub = Replace(sSub, "\", vbNullString)
        sSub = Replace(sSub, "?", vbNullString)
        sSub = Replace(sSub, "<", vbNullString)
        sSub = Replace(sSub, ">", vbNullString)
        sSub = Replace(sSub, "|", vbNullString)
        sSub = Replace(sSub, Chr(34), vbNullString)
        'Add code for checking for duplicate filenames and implement a index number if so
        oEmail.SaveAs "C:\Documents and Settings\username\Bureau\" & sSub & ".txt", olTXT
        Set oEmail = Nothing
        MsgBox "Saved"
End If

Set oSel = Nothing
   
End Sub

Thanks in advance !!!

[emartinho]

oEmail is defined as a mailItem and at the point where you get the error, the object assigned to oSel is probably not a mailItem (could be a meeting Request, task assignment, for e.g.).

Before assigning to oEmail, test oSel's type to determine if it is a MailItem or not.

Cheers.
-EM.

[DubweiserTM]

The oSel type is checked by these lines:

'If oSel.Class = olMail Then 'Note: olMail = 43 for now oSel is olSelection = 74

If oSel.Class = 74 Then
        Set oEmail = oSel
        'Use the email subject as the filename
        sSub = oEmail.Subject
        .........

oSel is not ok, I dont kwow why ???

I'm really sure about one thing, the selected item it's a message...

Thanks in advance !

[emartinho]

I think you've identified your own problem here:

'Note: olMail = 43 for now oSel is olSelection = 74

the code in the IF should only execute for an object that is a MailItem. Since, as you specify, oSel.Class is an olSelection, then you get the type mismatch error (i.e. olSelection <> olMail).

I think you may need to rewrite your code to use the Selection.Item instead:

Private Sub oSaveAs_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)

Dim oEmail As Outlook.MailItem
Dim sSub As String

'Check if first selected item is a MailItem.
if Application.ActiveExplorer.Selection.Item(1).Class = olMail Then
        Set oEmail = Application.ActiveExplorer.Selection.Item(1)
        'Use the email subject as the filename
        sSub = oEmail.Subject
        'Parse out any invalid characters for a filename.
        sSub = Replace(sSub, ":", vbNullString)
        sSub = Replace(sSub, "*", vbNullString)
        sSub = Replace(sSub, "/", vbNullString)
        sSub = Replace(sSub, "\", vbNullString)
        sSub = Replace(sSub, "?", vbNullString)
        sSub = Replace(sSub, "<", vbNullString)
        sSub = Replace(sSub, ">", vbNullString)
        sSub = Replace(sSub, "|", vbNullString)
        sSub = Replace(sSub, Chr(34), vbNullString)
        'Add code for checking for duplicate filenames and implement a index number if so
        oEmail.SaveAs "C:\Documents and Settings\username\Bureau\" & sSub & ".txt", olTXT
        Set oEmail = Nothing
        MsgBox "Saved"
End If
   
End Sub

Hope this helps.
-EM

[DubweiserTM]

You're right !

Resolved for me, but I'm not the thread starter !

Thanks !