Set a Outlook Folder desde un valor de una celda
Estoy trabajando en una macro que me permite rescatar información desde mi correo electrónico, el problema que me gustaría en una hoja resumen seleccionar que bandeja deseo descargar, en mi correo tengo varios buzones. El problema que es el siguiente:
El codigo:
Sub ExtraeCorreo ()
Dim OutlookApp As Object
Dim ONameSpace As Object
Dim MyFolder as Object
Dim Mailbox as String
Mailbox = Range("A1").Value 'En este campo dejaré el nombre del buzón
Set OutlookApp = CreateObject("Outlook.Aplication")
Set ONameSpace = OutlookApp.GetNamespace("MAPI")
Set MyFolder = ONameSpace.Folder(Mailbox).Folders(1)
En el ultimo punto no funciona, será que la variable utilizada no es la correcta, me faltan comillas, tengo que crear un objeto, no losé, he probado muchas maneras y no funciona, favor su ayuda.
1 Respuesta
Revisa el código en las siguientes respuestas que envié:
Copy texts from current email in Outlook to cells in Excel | MrExcel Message Board
Sub Get_Mail_Data()
Dim olApp As Object 'Outlook.Application
Dim objNS As Object 'Outlook.Namespace
Dim olFolder As Object 'Outlook.MAPIFolder
Dim itm As Object
Dim sh As Worksheet
Dim i As Long
'
Application.ScreenUpdating = False
Set olApp = CreateObject("Outlook.Application")
Set objNS = olApp.GetNamespace("MAPI")
Set olFolder = objNS.GetDefaultFolder(6) 'The Inbox folder
Set sh = ThisWorkbook.Sheets("Sheet1")
sh.Range("A2:C" & Rows.Count).ClearContents
On Error Resume Next
i = 2
For Each itm In olFolder.Items
sh.Range("A" & i).Value = itm.SenderName
sh.Range("B" & i).Value = itm.Subject
sh.Range("C" & i).Value = itm.body
i = i + 1
Next
sh.Range("A:C").WrapText = False
Application.ScreenUpdating = True
End SubVBA Help - Excel and Outlook | MrExcel Message Board
Sub GetEmail_1()
'Fuente: http://stackoverflow.com/questions/8322432/using-visual-basic-to-access-subfolder-in-inbox
'fuente: http://www.snb-vba.eu/VBA_Outlook_external_en.html
'fuente: https://support.microsoft.com/en-us/kb/208520
Dim olApp As Outlook.Application, objNS As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder, MyItems As Outlook.Items
Dim subfolder As Outlook.MAPIFolder
Dim msg As Outlook.MailItem, i As Long
'
Application.ScreenUpdating = False
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set olFolder = objNS.Folders(olFolderInbox)
Set subfolder = olFolder.Folders("test")
Set MyItems = subfolder.Items
Sheets(1).Select
Columns("A:D").Clear
Range("A1:D1") = Array("Sender", "Date", "Subject", "Body")
On Error Resume Next
For i = 1 To subfolder.Items.Count
Cells(i + 1, "A") = MyItems(i).SenderName
Cells(i + 1, "B") = MyItems(i).ReceivedTime
Cells(i + 1, "C") = MyItems(i).Subject
Cells(i + 1, "D") = MyItems(i).body
Next
Range("A:D").WrapText = False
Range("A:D").EntireColumn.AutoFit
End SubCount Emails in Outlook and export to excel | MrExcel Message Board
Sub GetEmail_2()
'Fuente: http://stackoverflow.com/questions/8322432/using-visual-basic-to-access-subfolder-in-inbox
'fuente: http://www.snb-vba.eu/VBA_Outlook_external_en.html
'fuente: https://support.microsoft.com/en-us/kb/208520
Dim olApp As Outlook.Application
Dim objNS As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim msg As Outlook.MailItem
'
Application.ScreenUpdating = False
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
'
Set olFolder = objNS.Folders("Backup")
Set subfolder = olFolder.Folders("disks")
Set MyItems = subfolder.Items
i = 2
Columns("A:C").Clear
NumItems = subfolder.Items.Count
f = 1
On Error Resume Next
For n = 1 To NumItems
Cells(f, "A") = MyItems(n).SenderName
Cells(f, "B") = MyItems(n).Subject
Cells(f, "C") = MyItems(n).body
f = f + 1
Next
Columns("B:C").WrapText = False
Application.ScreenUpdating = True
MsgBox "End"
End SubOtras recomendaciones en mi canal para empezar a programar:
Curso de macros. Metodo find completo. - YouTube
Curso de macros. Metodo find ejemplos. - YouTube
Sal u dos Dante Amor
