用于从Outlook中保存电子邮件的宏-具有发件人首字母缩写

Question

我正在尝试使Outlook宏正常工作，该宏仅将电子邮件保存为具有特定格式的.msg文件，以进行归档。类似于此处的另一个用户，我正在使用以下代码，导致文件格式为“ yyyy-mm-dd-发送方-title.msg”，这正是我想要的，除了我需要获取发送方的仅缩写，而不是全名。任何帮助是极大的赞赏！谢谢。

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

Answer 1

您也许可以使用这样的辅助函数：

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