|
Responder ![]() |
Autor | |
alexsc ![]() Ver perfil usuario
Enviar mensaje privado
Ver los mensajes del usuario
Visite la página de los usuarios
Añadir a la lista de amigos
Habitual ![]() ![]() Unido: 02/Septiembre/2010 Localización: Colombia Estado: Sin conexión Puntos: 188 |
![]() Enviado: 23/Marzo/2016 a las 18:50 |
Buenos dias:
He creado una macro en VBA sobre outlook 2007 para poder exportar los mensajes de correo entrante hacia un archivo de Excel. Necesito incluir en la informacion exportada, si alguno de los mensajes entrantes fueron respondidos y en que fecha y hora se respondio, pero no he podido lograrlo Recurro a ustedes para que por favor me den ayudita con esta parte. Les agradezco mucho su valiosa y pronta colaboraciòn. Saludos |
|
"El espiritu de lucha es lo que nos impulsa cada día a emprender nuevos retos..."
Alexsc Bogotá - Colombia |
|
![]() |
|
Galathea ![]() Habitual ![]() ![]() Unido: 15/Septiembre/2012 Localización: España Estado: Sin conexión Puntos: 135 |
![]() |
pon esto en un modulo, después selecciona la carpeta en cuestión y ejecuta:
Option Explicit Public Sub CopyEmailToExcelWhenArrive() 'olItem As Outlook.MailItem) Dim olItem As Outlook.MailItem Dim xlApp As Object Dim xlWB As Object Dim xlSheet As Object Dim rCount As Long Dim bXStarted As Boolean Dim enviro As String Dim strPath As String Dim iDefault As Long 'Prueba Tabla Dim doClip As MSForms.DataObject 'Bloque Registro Declarar Registro - Se puede eliminar si no se utiliza Dim sKey As String Dim lRegValue As Long Dim sAppName As String Dim sSection As String 'Dar nombre a las llaves de registro - Se puede eliminar si no se utiliza sAppName = "Outlook" sSection = "received" sKey = "Current Value Number XLS" iDefault = 2 lRegValue = GetSetting(sAppName, sSection, sKey, iDefault) 'Fin Bloque Registro Dim currentExplorer As Explorer Dim Selection As Selection Dim objOL As Outlook.Application Dim objFolder As Outlook.MAPIFolder Dim objItems As Outlook.Items Dim obj As Object Dim strColB, strColC, strColD, strColE, strColF, strColG As String 'Iniciar Excel 'Ruta del Excel strPath = "C:\Users\Manuel\Desktop\Correo\Prueba.xlsx" On Error Resume Next Set xlApp = GetObject(, "Excel.Application") If Err <> 0 Then Application.StatusBar = "Please wait while Excel source is opened ... " Set xlApp = CreateObject("Excel.Application") bXStarted = True End If On Error GoTo 0 'Abre la hoja de calculo Set xlWB = xlApp.Workbooks.Open(strPath) 'Especificar nombre de hoja de calculo Set xlSheet = xlWB.Sheets("Test") 'Lee el ultimo registro de la hoja de calculo 'lRegValue = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row ' Requerido para Outlook 2016 - si genera espacios en blanco 'lRegValue = lRegValue + 1 On Error Resume Next 'Bloque para leer folder actual- se puede remover si no se utiliza Set objOL = Outlook.Application 'Cambiar CurrentFolder por Selection para exportar selección de correos Set objFolder = objOL.ActiveExplorer.CurrentFolder Set objItems = objFolder.Items For Each obj In objItems 'Lee el ultimo registro de la hoja de calculo lRegValue = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row ' Requerido para Outlook 2016 - si genera espacios en blanco lRegValue = lRegValue + 1 Set olItem = obj Set doClip = New MSForms.DataObject doClip.SetText olItem.HTMLBody doClip.PutInClipboard 'Recolecta los datos strColB = olItem.SenderName strColC = olItem.SenderEmailAddress strColD = olItem.Subject strColE = olItem.Body strColF = olItem.To strColG = olItem.ReceivedTime ' Obtener las direcciones Exchange - Se puede remover si no se utiliza Exchange Dim olEU As Outlook.ExchangeUser Dim oEDL As Outlook.ExchangeDistributionList Dim recip As Outlook.Recipient Set recip = Application.Session.CreateRecipient(strColB) If InStr(1, strColC, "/") > 0 Then Select Case recip.AddressEntry.AddressEntryUserType Case OlAddressEntryUserType.olExchangeUserAddressEntry Set olEU = recip.AddressEntry.GetExchangeUser If Not (olEU Is Nothing) Then strColC = olEU.PrimarySmtpAddress End If Case OlAddressEntryUserType.olOutlookContactAddressEntry Set olEU = recip.AddressEntry.GetExchangeUser If Not (olEU Is Nothing) Then strColC = olEU.PrimarySmtpAddress End If Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry Set oEDL = recip.AddressEntry.GetExchangeDistributionList If Not (oEDL Is Nothing) Then strColC = olEU.PrimarySmtpAddress End If End Select End If 'Finaliza Seccion de Exchange 'Escribe valores en hoja de calculo 'xlSheet.Range("A" & lRegValue) = "Sender Name" 'xlSheet.Range("B" & lRegValue) = strColB 'lRegValue = lRegValue + 1 'xlSheet.Range("A" & lRegValue) = "Sender Email" 'xlSheet.Range("B" & lRegValue) = strColC 'lRegValue = lRegValue + 1 'xlSheet.Range("A" & lRegValue) = "Subject" 'xlSheet.Range("B" & lRegValue) = strColD 'lRegValue = lRegValue + 1 xlSheet.Range("A" & lRegValue) = "To" xlSheet.Range("B" & lRegValue) = strColF lRegValue = lRegValue + 1 'xlSheet.Range("A" & lRegValue) = "Received Time" 'xlSheet.Range("B" & lRegValue) = strColG 'lRegValue = lRegValue + 1 xlSheet.Range("A" & lRegValue) = "Body" xlSheet.Range("B" & lRegValue).PasteSpecial "Text" = strColE lRegValue = lRegValue + 1 'Si no se lee folder actual remover Next 'Guarda el registro - Si se utiliza registro remover el ' 'SaveSetting sAppName, sSection, sKey, lRegValue + 1 xlWB.Close 1 If bXStarted Then xlApp.Quit End If Set olItem = Nothing Set obj = Nothing Set currentExplorer = Nothing Set xlApp = Nothing Set xlWB = Nothing Set xlSheet = Nothing End Sub |
|
he escrito tanta inútil cosa, sin descubrirme, sin dar conmigo.
|
|
![]() |
Responder ![]() |
|
Tweet
|
Ir al foro | Permisos de foro ![]() Usted No puede publicar nuevos temas en este foro Usted No puede responder a temas en este foro Usted No puede borrar sus mensajes en este foro Usted No puede editar sus mensajes en este foro Usted No puede crear encuestas en este foro Usted No puede votar en encuestas en este foro |