Outlook - Auto Email Saved to Local Folder Once Sent-CodePudding

So sorry if this has been asked before, I have a need to save down each email I send into a local folder (These are then archived each month) and I have been using the following code that works great unless there is illegal characters in the subject line. I have tried to insert some code to strip out any illegal characters but always seem to mess it up. I am very new to VBA and would be very grateful for any help.

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    Call SaveACopy(Item)
End Sub

Sub SaveACopy(Item As Object)
    Const olMsg As Long = 3

    Dim m As MailItem
    Dim savePath As String
    Dim sSenderEmailAddress As String
    
    If TypeName(Item) <> "MailItem" Then Exit Sub

    Set m = Item

    savePath = "C:\Users\Email-SENT\"
    savePath = savePath & Format(Now(), "(yy.mm.dd-hh.NN ss) - ") & m.Subject & " (T) " & m.To
    savePath = savePath & ".msg"


    m.SaveAs savePath, olMsg


End Sub

CodePudding user response：

You can use string-related functions available in VBA. For example, the Replace function returns a string, which is a substring of a string expression beginning at the start position (defaults to 1), in which a specified substring has been replaced with another substring a specified number of times. The return value of the Replace function is a string, with substitutions made, that begins at the position specified by start and concludes at the end of the expression string. It's not a copy of the original string from start to finish. So, you can strip out any illegal characters.

Also I'd suggest handling the ItemAdd of the Items class (which comes from the Sent Items folder) instead. The ItemSend event is fired when the item submitted but not being sent actually. So, any other software which handles the ItemSend event may cancel any further processing by setting the Cancel parameter to true. But when the mail item was sent out in Outlook the sent item is put to the Sent Items folder. Actually, it can be any folder if you set the SaveSentMessageFolder property which sets a Folder object that represents the folder in which a copy of the email message will be saved after being sent. For example:

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    Dim SentFolder As Folder
    Dim desFolder As Folder
 
    If TypeName(Item) = "MailItem" And Item.DeleteAfterSubmit = False Then
       'Specify the sent emails
       If InStr(Item.To, "shirley") > 0 Or InStr(LCase(Item.Subject), "test") > 0 Then
          'Specify the folder for saving the sent emails
          'You can change it as per your needs
          Set SentFolder = Application.Session.GetDefaultFolder(olFolderSentMail)
          Set desFolder = SentFolder.Folders("Test")
          Set Item.SaveSentMessageFolder = desFolder
       End If
    End If
End Sub

So, then you could save sent items to the disk, not items that were submitted, but not sent yet.

CodePudding user response：

Please, try the next function. It offer the possibility to replace all the illegal characters with a common legal one. Or eliminate them:

Function ReplaceIllegChars(strClean As String, strChar As String) As String
    Dim strCharsToElim As String, i As Long, strSolved As String
    strCharsToElim = "~""#%&*:<>,@?{|}/\[]" & Chr(10) & Chr(13)

    For i = 1 To Len(strCharsToElim)
        strClean = Replace(strClean, Mid$(strCharsToElim, i, 1), strChar)
    Next

    ReplaceIllegChars = strClean
End Function

I am not the 'father' of the above function... I found it on internet some time before, added some other characters and personalized according to my need.

You may add other characters in strCharsToElim, too.

You can test it in the next way:

Sub testReplaceIllegChars()
     Dim x As String, strCorrect As String
     x = "<>,today,]|[%tomorrow\?@/"
     Debug.Print ReplaceIllegChars(x, "_")
     Debug.Print ReplaceIllegChars(x, "") 'to only replace them...
     strCorrect = ReplaceIllegChars(m.Subject, "_")
End Sub

In order to use it in your code, please replace the following code line:

savePath = savePath & Format(Now(), "(yy.mm.dd-hh.NN ss) - ") & m.Subject & " (T) " & m.To

with:

Dim strCorrect As String
strCorrect = ReplaceIllegChars(m.Subject, "_")
savePath = savePath & Format(Now(), "(yy.mm.dd-hh.NN ss) - ") & strCorrect & " (T) " & m.To
'your existing code...