VBScript – Guardar Correos Entrantes a una Carpeta en el Disco (.MSG) Outlook

Respondiendo a una consulta que nos realizarón el cual desean guardar correos entrantes a un folder en el disco duro local (guardar los correos como .msg)

Instrucciones de Uso 

1.- Abrir el editor de Visual Basic (ALT+F11).

2.- Insertar un modulo nuevo (Insert > Module).

3.- Copiar el código VBScript.

4.- En la linea 12 debemos especificar la ruta donde se guardaran los archivos (Esta carpeta la creamos manualmente).

Para mas información de configuración ver: Como utilizar el Editor VBA en Office (Utilizar Macros VBScript) y Outlook – Crear y configurar reglas

Código

Public Sub SaveIncomingMsgToFolder(Item As Outlook.MailItem)
  Dim sPath As String
  Dim dDate As Date
  Dim sSubject As String
  
  sSubject = Item.Subject
  ReplaceIllegalChars sSubject, "-"
  
  dDate = Item.ReceivedTime
  sSubject = Format(dDate, "yyyymmdd") & Format(dDate, "-hhnnss") & "-" & sSubject & ".msg"
 
  sPath = "C:1-Tests"
  Item.SaveAs sPath & sSubject, olMSG
End Sub
  
Private Sub ReplaceIllegalChars(sSubject As String, _
  sChr As String _
)
  sSubject = Replace(sSubject, "/", sChr)
  sSubject = Replace(sSubject, "", sChr)
  sSubject = Replace(sSubject, ":", sChr)
  sSubject = Replace(sSubject, "?", sChr)
  sSubject = Replace(sSubject, Chr(34), sChr)
  sSubject = Replace(sSubject, "<", sChr)
  sSubject = Replace(sSubject, ">", sChr)
  sSubject = Replace(sSubject, "|", sChr)
  sSubject = Replace(sSubject, "*", sChr)
End Sub