Outlook 2010 VBA Как сохранить сообщение, включая вложение

Question

Привет, я использую следующий код для сохранения сообщений в папку, однако, если сообщение имеет вложение, оно не работает.

Я знаю, что если вручную переместить сообщение на жесткий диск, вложение все еще находится в файле * .msg.

Я думаю, что это, как я спасаю сообщение в данном разделе

oMail.SaveAs sPath & sName, olMSG 

Как я могу изменить следующий код, чтобы сделать это с помощью VBA.

Sub SaveMessageAsMsg() 
    Dim oMail As Outlook.MailItem 
    Dim objItem As Object 
    Dim sPath As String 
    Dim dtDate As Date 
    Dim sName As String 
    Dim sndName As String 
    Dim enviro As String 

    enviro = "c:\emails" 
    For Each objItem In ActiveExplorer.Selection 
    If objItem.MessageClass = "IPM.Note" Then 
    Set oMail = objItem 
    sndName = oMail.Sender 
    ReplaceCharsForFileName sndName, "-" 
    sName = oMail.Subject 
    ReplaceCharsForFileName sName, "-" 

    dtDate = oMail.ReceivedTime 
    sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _ 
    vbUseSystem) & Format(dtDate, "-hhnnss", _ 
    vbUseSystemDayOfWeek, vbUseSystem) & "-" & sndName & "-" & sName  & ".msg" 

    sPath = enviro 
    Debug.Print sPath & sName 
    oMail.SaveAs sPath & sName, olMSG 

    End If 
    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, ":", 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 

Заранее спасибо

ОБНОВЛЕНИЕ Решенный себя

Я устранили все неполадки самостоятельно, вы должны быть осторожны, так как это зависит от того, как электронная почта получила была создана.

Если адрес электронной почты и тема были специально созданы с использованием excel, в нем будут указаны разделители табуляции, которые могут выбросить вышеуказанный код. Для решения этого используйте следующий код:

Public Sub SaveMessageAsMsg() 

    Dim oMail As Outlook.MailItem 
    Dim objItem As Object 
    Dim sPath As String 
    Dim dtDate As Date 
    Dim sName As String 
    Dim SndName As String 
    Dim enviro As String 


enviro = "c:\emails\" 'sets folder to save messgaes to 

For Each objItem In ActiveExplorer.Selection 
    If objItem.MessageClass = "IPM.Note" Then 
    Set oMail = objItem 

     sName = oMail.Subject 
     SndName = oMail.SenderName 
     dtDate = oMail.ReceivedTime 

     ReplaceCharsForFileName sName, "-" 

      sName = Right(sName, 100) 
    'formats the file name as "Sender name - Date - Time - Subject" 
       sName = SndName & " - " & Format(dtDate, "dd-mm-yy", vbUseSystemDayOfWeek, _ 
       vbUseSystem) & " - " & Format(dtDate, "hhnnss", _ 
       vbUseSystemDayOfWeek, vbUseSystem) & " - " & sName & ".msg" 

     sPath = enviro 

     Debug.Print sPath & sName 
     oMail.SaveAs sPath & sName, olMSG 

    End If 
    Next 

End Sub 

Private Sub ReplaceCharsForFileName(sName As String, _ 
    sChr As String _ 
) 

'Replaces the invalid characters you could use RegX with vbscript instead 

sName = Replace(sName, "´", "'") 
sName = Replace(sName, "`", "'") 
sName = Replace(sName, "{", "(") 
sName = Replace(sName, "[", "(") 
sName = Replace(sName, "]", ")") 
sName = Replace(sName, "}", ")") 
sName = Replace(sName, " ", " ")  'Replace two spaces with one space 
sName = Replace(sName, " ", " ") 'Replace three spaces with one space 
sName = Replace(sName, " ", " ") 'Replace four spaces with one space 
sName = Replace(sName, "  ", " ") 'Replace five spaces with one space 
sName = Replace(sName, "  ", " ") 'Replace six spaces with one space 

'Cut out invalid signs. 
sName = Replace(sName, ": ", "_")  'Colan followded by a space 
sName = Replace(sName, ":", "_")  'Colan with no space 
sName = Replace(sName, "/", "_") 
sName = Replace(sName, "\", "_") 
sName = Replace(sName, "*", "_") 
sName = Replace(sName, "?", "_") 
sName = Replace(sName, """", "'") 
sName = Replace(sName, "<", "_") 
sName = Replace(sName, ">", "_") 
sName = Replace(sName, "|", "_") 
sName = Replace(sName, "%", "pc") 
sName = Replace(sName, vbTab, " ")  'Replaces vbTab as this is sometimes a delimiter if copied from excel 

End Sub 

Answer 1

Вы должны использовать SaveAsFile метод класса вложений, чтобы сохранить привязанность к указанному пути. Например:

Sub SaveAttachment() 
    Dim myInspector As Outlook.Inspector 
    Dim myItem As Outlook.MailItem 
    Dim myAttachments As Outlook.Attachments 
    Set myInspector = Application.ActiveInspector 
    If Not TypeName(myInspector) = "Nothing" Then 
    If TypeName(myInspector.CurrentItem) = "MailItem" Then 
     Set myItem = myInspector.CurrentItem 
     Set myAttachments = myItem.Attachments 
     'Prompt the user for confirmation 
     Dim strPrompt As String 
     strPrompt = "Are you sure you want to save the first attachment in the current item to the Documents folder? If a file with the same name already exists in the destination folder, it will be overwritten with this copy of the file." 
     If MsgBox(strPrompt, vbYesNo + vbQuestion) = vbYes Then 
     myAttachments.Item(1).SaveAsFile Environ("HOMEPATH") & "\My Documents\" & _ 
     myAttachments.Item(1).DisplayName 
     End If 
    Else 
     MsgBox "The item is of the wrong type." 
    End If 
    End If 
End Sub