如果主题带有星号，Outlook 电子邮件存档宏将不起作用

我正在使用以下代码将我的电子邮件存档到目前完美运行的指定文件夹...除非电子邮件主题包含 *...然后这会给出调试消息“运行时错误'-2147286788 (800300fc) )'

我可以在下面的代码中添加任何内容，使其忽略或将 * 替换为其他内容，以允许它自动存档这些电子邮件吗？

Option Explicit

Public Sub Received2016()

Dim oMail As Outlook.MailItem

Dim objItem As Object

Dim sPath As String

Dim dtDate As Date

Dim sName As String

Dim enviro As String

enviro = CStr(Environ("USERPROFILE"))

For Each objItem In ActiveExplorer.Selection

Set oMail = objItem

sName = oMail.Subject

ReplaceCharsForFileName sName, "_"

dtDate = oMail.ReceivedTime

sName = Format(dtDate, "yyyy-mm-dd - ", vbUseSystemDayOfWeek, _

vbUseSystem) & Format(dtDate, "hh-nn-ss", _

vbUseSystemDayOfWeek, vbUseSystem) & " - " & sName & ".msg"

sPath = "H:\Email Archive\2016 Emails\Received\"

Debug.Print sPath & sName

oMail.SaveAs sPath & sName, olMSG

Next

End Sub

Private Sub ReplaceCharsForFileName(sName As String, _

sChr As String _

)

sName = Replace(sName, "/", sChr)

sName = Replace(sName, "\", sChr)

sName = Replace(sName, ":", sChr)

sName = Replace(sName, "?", sChr)

sName = Replace(sName, Chr(34), sChr)

sName = Replace(sName, "<", sChr)

sName = Replace(sName, ">", sChr)

sName = Replace(sName, "|", sChr)

End Sub

删除所有替换并添加（根据需要更改字符）-

sName = RemoveSpecials(sName)

Function RemoveSpecials(strInput As String) As String
    Dim strChars As String
    strChars = "!£$%^&*()_+{}@~:<>?,./;'#[]-=`¬¦" & Chr(34)
    Dim intIndex As Integer
    For intIndex = 1 To Len(strChars)
        strInput = Replace(strInput, Mid(strChars, intIndex, 1), "")
    Next
    RemoveSpecials = strInput
End Function