quisiera saber como modificar este macro para extraer correos de outlook.
Código:
Option Explicit
Sub Mails_a_Texto()
On Error Resume Next
Dim oNameSpace As Outlook.NameSpace
Dim oFolder As Outlook.MAPIFolder
Dim oMailIt As Outlook.MailItem
Dim oSubFolder As Outlook.MAPIFolder
Dim oRecipient As Outlook.Recipient
Dim sRecipients As String
Dim NumArchivo
Const Separador = ";"
Set oNameSpace = Application.GetNamespace("MAPI")
For Each oFolder In oNameSpace.Folders
sRecipients = sRecipients & oFolder & vbLf & vbLf
For Each oSubFolder In oFolder.Folders
If oSubFolder.DefaultItemType = olMailItem Then
For Each oMailIt In oSubFolder.Items
sRecipients = sRecipients & oMailIt.SenderEmailAddress & Separador
For Each oRecipient In oMailIt.Recipients
sRecipients = sRecipients & oRecipient.Address & Separador
Next
Next
End If
Next
Next
NumArchivo = FreeFile
Open "C:\Correos.txt" For Output As #NumArchivo
Print #NumArchivo, sRecipients
Close #NumArchivo
'Debug.Print sRecipients
End Sub
este macro extrae los correos y los guarda en C: con el nombre de "correos", pero cuando se usa en miles de correos la maquina no responde y creo que es por los correos repetidos, también no me funciona en maquinas que tienen win7 espero me puedan ayudar.
Gracias!!
