Outlook 2013 , vba to save sent emails as msg in a folder 1

[Billz66]

Can anyone help with vba code that will do the following in outlook 2013 ( used with exchange)

- what i want to happen is
when an email is sent
the sent email is saved as a msg to a folder on a local hard drive

If I never did anything I'd never done before , I'd never do anything.....

and due to an endless stream of MiCollab , MiCC issues
Life would be simpler If only they tested products properly before releasing them .....

 

[kjv1611]

Second item in this blog post seems to fit the bill for what you're asking:

http://www.slipstick.com/developer/code-samples/save-selected-message-file/

"But thanks be to God, which giveth us the victory through our Lord Jesus Christ." 1 Corinthians 15:57

 

[Billz66]

thanks , i did find something like that and have it working in a manual method as follows

I added a toolbar buttonfor the macro and it works on selected messages , any ideas on whether there is some code to make it automatically save all sent emails ?


Sub MySaveAs()
Dim objApp As Outlook.Application
Dim objSel As Outlook.Selection
Dim x As Integer
Dim sSubjectName As String
Dim ynTried As Boolean
Dim fixsubject As String

' Find the currently selected emails
Set objApp = CreateObject("Outlook.Application")
Set objSel = objApp.ActiveExplorer.Selection

' For each email
For x = 1 To objSel.Count
With objSel.Item(x)
' perform save only on selected mail messages
If .Class = olMail Then

Dim sSpecialChars As String
Dim i As Long
fixsubject = .Subject

sSpecialChars = "\/:*?™""® <>|.&@#_+`©~;-+=^$!,'" 'This is your list of characters to be removed
For i = 1 To Len(sSpecialChars)
fixsubject = Replace$(fixsubject, Mid$(sSpecialChars, i, 1), " ") ' remove special characters
Next
fixsubject = Replace(fixsubject, " ", " ") ' remove doublespaces
'fixsubject = Replace(fixsubject, " ", "") ' remove spaces
sSubjectName = fixsubject
ynTried = False
On Error GoTo ErrorSaving
.SaveAs "F:\AAASentMail\" & sSubjectName & ".msg", olMSG
On Error GoTo 0
End If
End With
Next
Set objSel = Nothing
Set objApp = Nothing
Exit Sub

ErrorSaving:
' some subjects are unsuitable for file names
' so allow renaming if necessary
If ynTried Then 'they only get one chance to rename the message
MsgBox "The message '" & sSubjectName & "' was not saved successfully", vbOKOnly, "Save Failed"
Resume Next 'skips the save
Else
' get a new subject name from user
ynTried = True
sSubjectName = InputBox("Error: Subject name not suitable. Please type a new name excluding any special characters (i.e. :,'.!@ etc)", _
"Save Failed", sSubjectName)
Resume
End If
End Sub


If I never did anything I'd never done before , I'd never do anything.....

and due to an endless stream of MiCollab , MiCC issues
Life would be simpler If only they tested products properly before releasing them .....

 

[kjv1611]

Did you refer to the section entitled, Save messages as they are sent? I would assume that's what that portion means. The top portion is based on current selection, but by title, the next section should be based on when the messages are sent.

"But thanks be to God, which giveth us the victory through our Lord Jesus Christ." 1 Corinthians 15:57

 

[Billz66]

I must be going blind , i missed that section thinking that it was what i had already found(shown above)
Thanks , with some modification ( new folder name) and changes to file renaming its working like i wanted

If I never did anything I'd never done before , I'd never do anything.....

and due to an endless stream of MiCollab , MiCC issues
Life would be simpler If only they tested products properly before releasing them .....

 

[kjv1611]

Great! Yeah, I've done the same thing myself in the past. Hopefully it'll stay that way - in the past.

"But thanks be to God, which giveth us the victory through our Lord Jesus Christ." 1 Corinthians 15:57