Help with VBA please!

[Alan McGowan]

The organisation I work for has a requirement to save incoming and outgoing emails in MSG format in a standard filenaming format to different locations on a server (different projects have different locations on server). As I can received hundreds of emails per day I am trying to develop some code to make this as simple as possible although I am very new to writing code and have managed to scrounge bits and pieces from the internet. One of the functions I have partially working is a prompt to save a sent email to the server folder. At present I have a userform that opens using Application_ItemSend. On this userform is a listbox which has the paths to the different folders on the server and I have a button that runs a routine that saves the email in MSG format in the selected folder. If this is a new email (i.e. not a reply of a forward) then it works fine. The problem is when I reply to a message or forward a message it is not my message that is being saved its the original message that I'm forwarding or replying to. I'm sure the problem is becase at the point the routine is ran the message hasn't actually been sent at that point. The code attached to my button is below.

I would really appreciate any help in solving this.

Sub SaveSent2_test()
Dim lngC As Long
Dim msgItem As Outlook.MailItem
Dim strPath As String
On Error Resume Next
strPath = UserForm3.TextBox1.Value

On Error GoTo 0
If strPath = "" Then Exit Sub
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
If TypeName(Application.ActiveWindow) = "Explorer" Then
' save selected messages in Explorer window
If CBool(ActiveExplorer.Selection.Count) Then
With ActiveExplorer
For lngC = 1 To .Selection.Count
Set msgItem = .Selection.Item(lngC)
If .Selection(lngC).Class = olMail Then
MsgSaverTest strPath, .Selection(lngC)
End If
Next lngC
End With
End If
ElseIf Inspectors.Count Then

' save active open message
If ActiveInspector.CurrentItem.Class = olMail Then
MsgSaverTest strPath, ActiveInspector.CurrentItem
End If
End If
End Sub
Private Sub MsgSaverTest(strPath As String, msgItem As Outlook.MailItem)
Dim intC As Integer
Dim intD As Integer
Dim intE As Integer
Dim intF As Integer
Dim strMsgSubj As String
Dim strMsgTo As String
Dim senton As String
Dim senttime As String
senton = Format(Date, "yyyy-mm-dd")
senttime = Time
strMsgSubj = msgItem.Subject
strMsgTo = msgItem.To

' Clean out characters from Subject which are not permitted in a file name
For intC = 1 To Len(strMsgSubj)
If InStr(1, ":<&>""", Mid(strMsgSubj, intC, 1)) > 0 Then
Mid(strMsgSubj, intC, 1) = "-"
End If
Next intC
For intC = 1 To Len(strMsgSubj)
If InStr(1, "\/|*?", Mid(strMsgSubj, intC, 1)) > 0 Then
Mid(strMsgSubj, intC, 1) = "_"
End If
Next intC

' Clean out characters from Sender Name which are not permitted in a file name
For intD = 1 To Len(strMsgTo)
If InStr(1, ":<&>""", Mid(strMsgTo, intD, 1)) > 0 Then
Mid(strMsgTo, intD, 1) = "-"
End If
Next intD
For intD = 1 To Len(strMsgTo)
If InStr(1, "\/|*?", Mid(strMsgTo, intD, 1)) > 0 Then
Mid(strMsgTo, intD, 1) = "_"
End If
Next intD
' Clean out characters from Date which are not permitted in a file name
For intE = 1 To Len(senton)
If InStr(1, "\/|*?", Mid(senton, intE, 1)) > 0 Then
Mid(senton, intE, 1) = "-"
End If
Next intE

For intF = 1 To Len(senttime)
If InStr(1, "\:/|*?", Mid(senttime, intF, 1)) > 0 Then
Mid(senttime, intF, 1) = "."
End If
Next intF

' add date to file name
strMsgSubj = senton & " " & senttime & " " & "[To " & strMsgTo & "]" & " " & strMsgSubj & ".msg"
msgItem.SaveAs strPath & strMsgSubj

If UserForm1.TextBox3.Value = "YES" Then
Set msgItem.SaveSentMessageFolder = _
Session.GetDefaultFolder(olFolderDeletedItems)
End If

Set msgItem = Nothing
UserForm3.Hide
End Sub

 

[Diane Poremsky]

The itemsend macro should work on replies and forwards too.

 

[Alan McGowan]

I've just tried it again and whilst the user form loads when I click the button to send and save the MSG which runs the code above, it is the original message that is being saved

 

[Diane Poremsky]

With ActiveExplorer
For lngC = 1 To .Selection.Count
Set msgItem = .Selection.Item(lngC)
If .Selection(lngC).Class = olMail Then
MsgSaverTest strPath, .Selection(lngC)

i think this is the problem - it's picking up the selection, not the reply. You'd only need that if you were saving a bunch of messages already in the folder.

Are you using this same macro with new messages? The macro that works for new messages should also work with replies.

 

[Alan McGowan]

I use the same code on another userform to save messages that are selected in a folder although I have changed the macro and sub names in the other code. If I REM those lines of code out then nothing happens. I get no errors but the message isn't sent or saved. The userform stays open so it suggests the code isn't getting processed.

 

[Diane Poremsky]

what code do you use for new messages?

 

[niton]

With ItemSend you must have a mailitem open.

If you only open the userform from ItemSend this should pick up the item being sent.

Public Sub SaveSent2_test()

Dim strPath As String

On Error Resume Next
strPath = UserForm3.TextBox1.Value
On Error GoTo 0
If strPath = "" Then Exit Sub

If Right(strPath, 1) <> "\" Then strPath = strPath & "\"

' save active open message
If ActiveInspector.currentItem.Class = olMail Then
MsgSaverTest strPath, ActiveInspector.currentItem
End If

End Sub

If you also open the userform outside of ItemSend put the test for an open item first.

Public Sub SaveSent2_test()
Dim lngC As Long
'Dim msgItem As MailItem
Dim strPath As String

On Error Resume Next

strPath = UserForm3.TextBox1.Value
On Error GoTo 0
If strPath = "" Then Exit Sub

If Right(strPath, 1) <> "\" Then strPath = strPath & "\"

If Inspectors.count Then

' save active open message
If ActiveInspector.currentItem.Class = olMail Then
MsgSaverTest strPath, ActiveInspector.currentItem
End If

ElseIf TypeName(Application.ActiveWindow) = "Explorer" Then

' save selected messages in Explorer window
If CBool(ActiveExplorer.Selection.count) Then
With ActiveExplorer
For lngC = 1 To .Selection.count
'Set msgItem = .Selection.item(lngC)
If .Selection(lngC).Class = olMail Then
MsgSaverTest strPath, .Selection(lngC)
End If
Next lngC
End With
End If

End If

End Sub

 

[Alan McGowan]

Niton,
Unfortunately this doesn't work. If I try and use your code when sending a new email, it works to an extent but actually saves the message as an unsent message in MSG format. What I really need is to save the sent message in MSG format. Also when I try and forward or reply to an email from my inbox and use your code it is saving the top email in my inbox (when sorted by most recent date) although sending the correct email.

I'm coming to the conclusion that I need to change my approach and have code that is executed after the sent message lands in the sent items folder...problem is this is my first attempt at writing code and therefore not up to speed on what can and can't be done and how to write code.
Thanks for your help
[DOUBLEPOST=1433507800][/DOUBLEPOST]

what code do you use for new messages?

Diane, i've just realised the code I was using on new mail items was saving the email in MSG format as an unsent message which isn't what I want. I want to save the sent message in MSG format

 

[Diane Poremsky]

What I really need is to save the sent message in MSG format.

You need to save it after it is added to the sent items folder. Use an itemadd macro to watch the sent folder.

Private WithEvents Items As Outlook.Items

Private Sub Application_Startup()
Dim Ns As Outlook.NameSpace
 Set Ns = Application.GetNamespace("MAPI")
'use the default folder 
Set Items = Ns.GetDefaultFolder(olFolderSentItems).Items
End Sub

Private Sub Items_ItemAdd(ByVal Item As Object)
' put your code here
End Sub

 

[Alan McGowan]

OK so I use this code to open my userform, and then the relevant button can use the SaveSent2_test() code above, but I will need to amend that to select the item that has been added to the sent item folder. How do I do that?
[DOUBLEPOST=1433512962][/DOUBLEPOST]I alsi have some code that checks for missing attachments etc that is triggered using pplication_ItemSend. Since you can only have one of these in the ThisOutlookSession, is it possible to combine them?

 

[Diane Poremsky]

Re: multiple itemadds: you can combine the code or call one macro then the other. But you won't combine an item send with an item add - the item send checks the message as it is sent, not after it hits the sent folder.


As soon as you send and item and it hits the sent folder, the macro kicks in and applies to that item.

 

[Alan McGowan]

Diane, the problem is I am intercepting the process by opening a userform when the item hits the sent items and I then have different macros to run from buttons on the userform so I need these macros to be ale to be applied to the items that's hit the sent items folder

 

[Alan McGowan]

You need to save it after it is added to the sent items folder. Use an itemadd macro to watch the sent folder.

Private WithEvents Items As Outlook.Items
 
Private Sub Application_Startup()
Dim Ns As Outlook.NameSpace
Set Ns = Application.GetNamespace("MAPI")
'use the default folder
Set Items = Ns.GetDefaultFolder(olFolderSentItems).Items
End Sub
 
Private Sub Items_ItemAdd(ByVal Item As Object)
' put your code here
End Sub

Diane, I have pasted the code above into ThisOutlookSession and when I startup outlook I get a runtime error and the debugger highlights the following line of code:

Set Items = Ns.GetDefaultFolder(olFolderSentItems).Items

Any thoughts?

 

[Alan McGowan]

I have solved this issue. The olFolderSentItems should actually be olFolderSentMail. However I still have the problem of selecting the item that was added to the sent items folder and then running a macro on this item

 

[Alan McGowan]

I'm fully sorted by using the sort function, sorting by ascending senton date and then selecting the first item

 

[niton]

Pass the item in a public variable.

In a regular module
Public sentMailNewMail as Mailitem


Private Sub olSentItems_ItemAdd(ByVal Item As Object)
If TypeOf Item Is MailItem Then
Set sentMailNewMail = Item
UserForm1.Show
End If
End Sub


Userform 1
Private Sub CommandButton1_Click()
MsgBox sentMailNewMail.Subject
End Sub