vba - office - como guardar un correo electronico en mis documentos

Cómo guardar un correo electrónico enviado no único a la carpeta de Windows

Question

Tengo un código VBA cuyas principales funciones son:

1. Cargar un formulario
2. Permitir que un usuario elija una respuesta de stock de correo electrónico
3. Abra un documento de Word con el texto de respuesta completo
4. Crea una respuesta usando el texto
5. Busque en el correo electrónico y cree una colección de cadenas que contengan números de archivos corporativos
6. Agregue los números de archivo a una lista de Excel
7. Envía la respuesta

Ahora quiero guardar una copia del artículo enviado en una carpeta de Windows, para cada número de archivo. He estado tratando de esperar hasta que se envíe el elemento y se mueva a Elementos enviados. El problema es que después de llamar al método de envío, el elemento de correo no envía ni se mueve a Elementos enviados hasta que el código finaliza, por lo que termino en un ciclo infinito.

Todas las opciones que encontré implican el uso de un módulo de clase y WithEvents. Eso funcionaría si quisiera copiar cada elemento enviado a la carpeta. No puedo pensar en ningún criterio que diferencie los correos electrónicos creados por esta macro de los correos electrónicos normales. Podría entrar en la lista de archivos de Excel, pero eso empantanaría la máquina de todos en cada envío.

¿Hay alguna manera de simplemente hacer que el correo electrónico se entere cuando se envió y se trasladó a los artículos enviados? Mi código para enviar, esperar que vaya a los artículos enviados y guardar los correos electrónicos está a continuación. Tenga en cuenta que tengo dos variables globales: cReply (Outlook.MailItem - la respuesta) y fNums (Colección - los números de archivo).

Estoy codificando en Outlook 2016, pero espero mover el módulo a Outlook 2010 en el trabajo.

Sub Send()
Dim badChar As String
badChar = "//:*?™""® <>|.&@#_+`©~;-+=^$!,''" & Chr(34)
Dim x As Integer
Dim fName As String
Dim inSentItems As Boolean
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olFldr As Outlook.MAPIFolder
Dim cSent As Outlook.MailItem
Dim sentMoment As Date
fName = cReply.Subject
For x = 1 To Len(badChar)
fName = Replace(fName, Mid(badChar, x, 1), "-")
Next x
Set olApp = GetObject(, "Outlook.Application")
Set olNS = olApp.GetNamespace("MAPI")
Set olFldr = olNS.GetDefaultFolder(olFolderSentMail)
inSentItems = True
x = olFldr.Items.Count
sentMoment = Now
cReply.Send
Do While olFldr.Items.Count <> x + 1
If Now - sentMoment > TimeValue("0:00:10") Then
inSentItems = False
Exit Do
End If
DoEvents
Loop
If inSentItems Then
Set cSent = olFldr.Items(olFldr.Items.Count)
For x = 1 To fNums.Count
cSent.SaveAs sentFldrPth & fNums.Item(x) & " - " & fName & ".msg", olMSG
Next x
''cSent.Delete
End If
Set olApp = Nothing
Set olNS = Nothing
Set olFldr = Nothing
End Sub

Answer 1

Puede usar SaveSentMessageFolder para guardar en otra carpeta.

https://msdn.microsoft.com/en-us/library/office/ff868473.aspx

Controle esta otra carpeta con el código ItemAdd. Puede mover el correo a la carpeta Elementos enviados una vez hecho.