Alan McGowan
Senior Member
- Outlook version
- Outlook 2013 64 bit
- Email Account
- Exchange Server
I am using Items_ItemAdd(byVal Item As Object) to monitor the sent items folder and when a new item is added a userform loads. The userform has several buttons each with their own macro attached. One of the macros selects the item that has been added to the sent items folder and then saves it in MSG format to a user selected folder on a server. If you create a new message and send it all works fine. However if you have say an incoming email open in a separate window and reply or forward this message, the userform loads but the macro won't execute. The problem seems to be due to the email being open in a window. Any suggestions on how to overcome this proble. I have included the macro below that won't run.
' saves email after sending if option to do so is activated
Sub sendandfile()
Dim myNameSpace As Outlook.NameSpace
Dim myFolder As Outlook.Folder
Dim myItem As Outlook.MailItem
Dim myItems As Outlook.Items
Dim lngC As Long
Dim msgItem As Outlook.MailItem
Dim strPath As String
Set myNameSpace = Application.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderSentMail)
Set myItems = myFolder.Items
myItems.Sort "[SentOn]", True
Set myItem = myItems(1)
On Error Resume Next
strPath = UserForm6.TextBox1.Value
On Error GoTo 0
If strPath = "" Then Exit Sub
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
If TypeName(Application.ActiveWindow) = "Explorer" Then
With myItem
If UserForm4.TextBox3.Value = "NO" Then
.Subject = "[Filed" & " " & Date & "]" & " " & myItem.Subject
.Save
Else
.Subject = myItem.Subject
.Save
End If
End With
' save last sent message
If myItem.Class = olMail Then
On Error GoTo ErrHandler
MsgSaverSAF strPath, myItem
On Error GoTo 0
End If
End If
Exit Sub
ErrHandler:
MsgBox "The selected folder does not exist. Please select a valid folder or browse to a folder.", vbExclamation + vbOKOnly
' go back to the line following the error
Unload UserForm6
UserForm6.Show
End Sub
Private Sub MsgSaverSAF(strPath As String, myItem As Outlook.MailItem)
Dim intC As Integer
Dim intD As Integer
Dim strMsgSubj As String
Dim strMsgTo As String
strMsgSubj = Left(myItem.Subject, 80)
strMsgTo = Left(myItem.To, 25)
' 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
' add date to file name
strMsgSubj = Format(myItem.senton, "yyyy-mm-dd Hh.Nn.Ss") & " " & "[To " & strMsgTo & "]" & " " & strMsgSubj & ".msg"
myItem.SaveAs strPath & strMsgSubj
If UserForm1.TextBox3.Value = "YES" Then
myItem.Delete
End If
Set myItem = Nothing
Unload UserForm6
End Sub
' saves email after sending if option to do so is activated
Sub sendandfile()
Dim myNameSpace As Outlook.NameSpace
Dim myFolder As Outlook.Folder
Dim myItem As Outlook.MailItem
Dim myItems As Outlook.Items
Dim lngC As Long
Dim msgItem As Outlook.MailItem
Dim strPath As String
Set myNameSpace = Application.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderSentMail)
Set myItems = myFolder.Items
myItems.Sort "[SentOn]", True
Set myItem = myItems(1)
On Error Resume Next
strPath = UserForm6.TextBox1.Value
On Error GoTo 0
If strPath = "" Then Exit Sub
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
If TypeName(Application.ActiveWindow) = "Explorer" Then
With myItem
If UserForm4.TextBox3.Value = "NO" Then
.Subject = "[Filed" & " " & Date & "]" & " " & myItem.Subject
.Save
Else
.Subject = myItem.Subject
.Save
End If
End With
' save last sent message
If myItem.Class = olMail Then
On Error GoTo ErrHandler
MsgSaverSAF strPath, myItem
On Error GoTo 0
End If
End If
Exit Sub
ErrHandler:
MsgBox "The selected folder does not exist. Please select a valid folder or browse to a folder.", vbExclamation + vbOKOnly
' go back to the line following the error
Unload UserForm6
UserForm6.Show
End Sub
Private Sub MsgSaverSAF(strPath As String, myItem As Outlook.MailItem)
Dim intC As Integer
Dim intD As Integer
Dim strMsgSubj As String
Dim strMsgTo As String
strMsgSubj = Left(myItem.Subject, 80)
strMsgTo = Left(myItem.To, 25)
' 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
' add date to file name
strMsgSubj = Format(myItem.senton, "yyyy-mm-dd Hh.Nn.Ss") & " " & "[To " & strMsgTo & "]" & " " & strMsgSubj & ".msg"
myItem.SaveAs strPath & strMsgSubj
If UserForm1.TextBox3.Value = "YES" Then
myItem.Delete
End If
Set myItem = Nothing
Unload UserForm6
End Sub