响应电子邮件保存为“文件”文件类型

Question

我很想知道为什么每个回复电子邮件和转发的电子邮件都没有使用.msg文件扩展名保存。相反，它们被保存为.file扩展名。任何原因，为什么会发生这种情况以及如何解决问题？这是我现在正在处理的代码。

Public Sub SaveMsgs(Item As Outlook.MailItem)

 'Declare Variables
 Dim sPath As String
 Dim dtDate As Date
 Dim sName As String
 Dim sSubject As String
 Dim enviro As String
 Dim sSender As String
 Dim strFolder As String
 Dim strNewFolder As String
 Dim save_to_folder As String

 'enviro = CStr(Environ("USERPROFILE"))

 ReplaceCharsForFileName sName, "_"

 sSender = Item.Sender

 dtDate = Item.ReceivedTime
 'sName = sSender & " - " & sSubject & ".msg"

 'Set Folder path
 strNewFolder = Format(dtDate, "mm-dd-yyyy")
 strFolder = "C:\IT Documents\" & strNewFolder & "\"

 'Determine if there is subject
 If Len(Item.Subject) > 0 Then
   sSubject = Item.Subject
 Else
   sSubject = "No Subject "
 End If

 'Determine if folder is in the directory
 If Len(Dir(strFolder, vbDirectory)) = 0 Then
   MkDir (strFolder)
 End If

 sName = sSender & " - " & sSubject
 save_to_folder = strFolder

 Item.SaveAs save_to_folder & sName & ".msg"
End Sub

Answer 1

确保您参考

Microsoft Scripting Runtime
Microsoft outlook Object Library
Microsoft Word Object Library

以下代码已在 Outlook 2010

上进行了测试

Option Explicit
'// Save the message as a native .msg
Public Sub SaveMsg(Item As Outlook.MailItem)
    Dim fso As FileSystemObject
    Dim olNS As Outlook.NameSpace
    Dim SavePath As String
    Dim TimeDate As Date
    Dim SaveName As String
    Dim Enviro As String
    Dim NewFolder As String
    Dim EmailSubject As String

    '// enviro gets the user account part of the path
    '// so you can use the same code on different computers
    Set olNS = Application.GetNamespace("MAPI")

    ReplaceCharsForFileName SaveName, "_"

    '// Use My Documents for older Windows.
    NewFolder = "C:\IT Documents\" & Format(Now, "YYYY-MM-DD") & "\"

    '// Test if directory or file exists
    If FileOrDirExists(NewFolder) Then
        MsgBox NewFolder & " exists!"
    Else
        MkDir NewFolder
    End If

    EmailSubject = FileName(Item.Subject)

    '// Determine if there is subject
    If Item.Subject <> vbNullString Then
        EmailSubject = Item.Subject
    Else
        EmailSubject = "No Subject"
    End If


    '// Get Email subject & set name to be saved as
    TimeDate = Item.ReceivedTime
    SaveName = Format(TimeDate, "YYYYMMDD", vbUseSystemDayOfWeek, _
    vbUseSystem) & Format(TimeDate, "-HHNNSS", _
    vbUseSystemDayOfWeek, vbUseSystem) & "-" & EmailSubject & SaveName & ".msg"
    Set fso = CreateObject("Scripting.FileSystemObject")



    '// Save .msg File
    SavePath = "C:\IT Documents\" & NewFolder & "\"
    Debug.Print NewFolder & SaveName
    Item.SaveAs NewFolder & SaveName, olMsg

End Sub

'// This function removes invalid and other characters from file names
Private Sub ReplaceCharsForFileName(SaveName As String, _
  sChr As String _
)
  SaveName = Replace(SaveName, "/", sChr)
  SaveName = Replace(SaveName, "\", sChr)
  SaveName = Replace(SaveName, ":", sChr)
  SaveName = Replace(SaveName, "?", sChr)
  SaveName = Replace(SaveName, Chr(34), sChr)
  SaveName = Replace(SaveName, "<", sChr)
  SaveName = Replace(SaveName, ">", sChr)
  SaveName = Replace(SaveName, "|", sChr)
  SaveName = Replace(SaveName, "&", sChr)
  SaveName = Replace(SaveName, "%", sChr)
  SaveName = Replace(SaveName, "*", sChr)
  SaveName = Replace(SaveName, " ", sChr)
  SaveName = Replace(SaveName, "{", sChr)
  SaveName = Replace(SaveName, "[", sChr)
  SaveName = Replace(SaveName, "]", sChr)
  SaveName = Replace(SaveName, "}", sChr)
  SaveName = Replace(SaveName, "!", sChr)

End Sub

'// Good practice suggests that it is wise to check before taking certain actions
'// This function checks if File or Dir Exists
Function FileOrDirExists(PathName As String) As Boolean
    Dim iTemp As Integer

     '// Ignore errors to allow for error evaluation
    On Error Resume Next
    iTemp = GetAttr(PathName)

     '// Check if error exists and set response appropriately
    Select Case Err.Number
    Case Is = 0
        FileOrDirExists = True
    Case Else
        FileOrDirExists = False
    End Select

     '// Resume error checking
    On Error GoTo 0
End Function

Function FileName(strText As String) As String
    Dim strStripChars As String
    Dim intLen As Integer
    Dim i As Integer
    strStripChars = "/\[]:=," & Chr(34)
        intLen = Len(strStripChars)
    strText = Trim(strText)
        For i = 1 To intLen
    strText = Replace(strText, Mid(strStripChars, i, 1), "")

    Next
    FileName = strText
End Function

祝你好运。