[VBA] Macro esportazione messaggi Outlook 2010

[Raid]

Da mettere in ThisOutlookSession e poi attivare il tasto sulla barra personalizzata con Tasto Macro.

Code: [Select]

'Macro per salvare i messaggi in formato MSG con l'export del timestamp INIZIO
'http://www.slipstick.com/developer/code-samples/save-selected-message-file/
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 sSender As String
  Dim enviro As String
 
    enviro = CStr(Environ("USERPROFILE"))
   For Each objItem In ActiveExplorer.Selection
    Set oMail = objItem
   
  sName = oMail.Subject
  sSender = oMail.SenderName
  ReplaceCharsForFileName sName, "_"
  ReplaceCharsForSenderName sSender, "_"
 
  dtDate = oMail.ReceivedTime
  sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
    vbUseSystem) & Format(dtDate, "_hhnn", _
    vbUseSystemDayOfWeek, vbUseSystem) & "_" & sSender & "_" & sName & ".msg"
     
    sPath = enviro & "\Documents\"
  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

Private Sub ReplaceCharsForSenderName(sSender As String, _
  sChr2 As String _
)
  sSender = Replace(sSender, " ", sChr2)

End Sub
'Macro per salvare i messaggi in formato MSG con l'export del timestamp FINE