VBScript – Guardar Correos Seleccionados en un mismo Archivo Doc (Word)

El siguiente código VBscript sirve para guardar correos seleccionados en un mismo archivo doc, al momento de leer el cuerpo del correo este pierde el formato el cual quedara en formato plain text y al momento de guardar ya que el archivo Doc contendrá la información de los correos seleccionados toma el valor de la fecha actual y se el asigna al nombre del archivo.

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 8 debemos especificar la ruta donde se guardaran los archivos (Esta carpeta la creamos manualmente).

5.- En la linea 13 automáticamente asigna la fecha al nombre del archivo en el formato Año-Mes-Dia-Hora el cual podemos remplazar “Format(Now(), “yyyy-mm-dd-hh” por cualquier nombre.

6.- Ahora desde el editor de Visual Basic una vez seleccionados los correos a exportar a Doc ejecutamos el script.

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

Sub MergeSelectedEmailsIntoDocFile()
 
Dim objItem As Object, strFile As String
Dim sName As String
Set objFS = CreateObject("Scripting.FileSystemObject")
 
Dim saveFolder As String
saveFolder = "C:1-Tests"
 
  If ActiveExplorer.Selection.count = 0 Then Exit Sub

' add the current date to the filename Year-Month-Day-Hour
sName = Format(Now(), "yyyy-mm-dd-hh")
 
' The folder path you use needs to exist
strFile = saveFolder & sName & ".doc"
   
  Set objFile = objFS.CreateTextFile(strFile, False)
  If objFile Is Nothing Then
    MsgBox "Error creating file '" & strFile & "'.", vbOKOnly + vbExclamation _
      , "Invalid File"
    Exit Sub
  End If
   
  For Each objItem In ActiveExplorer.Selection
   
  With objFile
    .Write vbCrLf & "--Email Start--" & vbCrLf
    .Write "Sender: " & objItem.Sender & " <" & objItem.SenderEmailAddress & ">" & vbCrLf
    .Write "Recipients : " & objItem.To & vbCrLf
    .Write "Received: " & objItem.ReceivedTime & vbCrLf
    .Write "Subject: " & objItem.Subject & vbCrLf & vbCrLf
    .Write objItem.Body
    .Write vbCrLf & "--Email End--" & vbCrLf
 End With
 
  Next
  objFile.Close
   
  MsgBox "Email text merge completed!", vbOKOnly + vbInformation, "DONE!"
   
  Set objFS = Nothing
  Set objFile = Nothing
  Set objItem = Nothing
   
End Sub

Basado un codigo de Diane Poremsky publicado en slipstick