Saving emails with sender's initials

Question

I am trying to save emails as .msg files.

I am using the following code, resulting in the filename format "yyyy-mm-dd - sender - title.msg". I need the sender's initials instead of the whole name.

Sub OpenAndSave()
    Const SAVE_TO_FOLDER = "C:\Users\Documents\Emails\"
    Dim olkMsg As Outlook.MailItem, intCount As Integer
    intCount = 1
    For Each olkMsg In Outlook.ActiveExplorer.Selection
        strDate = Format(olkMsg.ReceivedTime, "yyyy-mm-dd - ")
        olkMsg.Display
        olkMsg.SaveAs SAVE_TO_FOLDER & strDate & RemoveIllegalCharacters(olkMsg.senderName) & " - " & RemoveIllegalCharacters(olkMsg.Subject) & ".msg"
        olkMsg.Close olDiscard
    Next
    Set olkMsg = Nothing
End Sub

Function RemoveIllegalCharacters(strValue As String) As String
    ' Purpose: Remove characters that cannot be in a filename from a string.'
    RemoveIllegalCharacters = strValue
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "<", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, ">", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, ":", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, Chr(34), "'")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "/", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "\", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "|", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "?", "")
    RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "*", "")
End Function

E.g. email from John A Smith today: “2019-10-23 - JAS - Subject” Or email from Kevin Bishop yesterday: “2019-10-22 - KB - Subject”

So basically you're looking for a function to convert a name to its Initials. Can you give some sample names - are we always dealing with First, space, Last? — BigBen, Oct 23 '19 at 19:42
Yes the format I need is: “yyyy-mm-dd - sender initials - title.msg" Eg email for John A Smith today: “2019-10-23 - JAS - Subject” Or email from Kevin Bishop yesterday: “2019-10-22 - KB - Subject” Thanks again! — Jeremiah, Oct 23 '19 at 20:19

BigBen · Answer 1 · 2019-10-23T21:43:13.923

You could use a helper function like this perhaps to return the initials from the sender name:

Private Function Initials(ByVal fullName As String) As String
    Dim splitName
    splitName = Split(fullName)

    Dim i As Long
    For i = LBound(splitName) To UBound(splitName)
        Initials = UCase$(Initials & IIf(Len(splitName(i) > 0), Left$(splitName(i), 1), ""))
    Next
End Function

Call it perhaps like this:

olkMsg.SaveAs SAVE_TO_FOLDER & strDate & RemoveIllegalCharacters(Initials(olkMsg.senderName))...

though I would break that up into multiple pieces for readability.

EDIT:

You can probably simplify the Initials = ... line to:

Initials = UCase$(Initials & Left$(splitName(i), 1))

Saving emails with sender's initials

1 Answers1

Linked