保存带有发件人姓名缩写的电子邮件

Question

我正在尝试将电子邮件另存为.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

例如今天来自John A Smith的电子邮件：“ 2019-10-23-JAS-主题”或昨天来自Kevin Bishop的电子邮件：“ 2019-10-22-KB-主题”

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

也许这样称呼：

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

尽管为了可读性我将其分解成多个部分。

编辑：

您可能可以将Initials = ...行简化为：

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