Imprimir página | Cerrar ventana

Exportar correos Outlook seleccionados a carpeta p

Impreso de: Foro de Access y VBA
Categoría: Otros de Microsoft: Windows y Office
Nombre del foro: Otros Productos Microsoft
Descripción del foro: PowerPoint, Navision, Visio, FrontPage, InfoPath etc
URL: http://www.mvp-access.com/foro/forum_posts.asp?TID=84522
Fecha de impresión: 26/Agosto/2019 a las 12:38


Tema: Exportar correos Outlook seleccionados a carpeta p
Publicado por: Galathea
Asunto: Exportar correos Outlook seleccionados a carpeta p
Fecha de publicación: 29/Mayo/2019 a las 20:08
Saludos, era para preguntar si tienen alguna macro que posibilite exportar a una determinada carpeta del PC los correos seleccionados. Algo parecido a lo que se puede hacer con los pasos rápidos en Outlook, pero exportando al ordenador.


Gracias.


-------------
he escrito tanta inútil cosa, sin descubrirme, sin dar conmigo.



Respuestas:
Publicado por: lbauluz
Fecha de publicación: 29/Mayo/2019 a las 20:39
Buenas: 

Tengo esto a medio hacer, funciona, pero hay que pulirlo un poco.

OJO, esto funciona en OutLook directamente, no en Access o Excel.

Luis

Option Explicit

Dim StrSavePath     As String

Sub sfSaveAllEmails()

    Dim i               As Long
    Dim j               As Long
    Dim n               As Long
    Dim StrSubject      As String
    Dim StrName         As String
    Dim StrFile         As String
    Dim StrReceived     As String
    Dim StrFolder       As String
    Dim StrSaveFolder   As String
    Dim StrFolderPath   As String
    Dim iNameSpace      As NameSpace
    Dim oaOutlook       As Outlook.Application
    Dim mapiSubFolder   As MAPIFolder
    Dim mItem           As MailItem
    Dim FSO             As Object
    Dim objActualFolder As Object
    Dim colFolders      As New Collection
    Dim colEntryID      As New Collection
    Dim colStoreID      As New Collection

    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set oaOutlook = Outlook.Application
    Set iNameSpace = oaOutlook.GetNamespace("MAPI")
    Set objActualFolder = iNameSpace.PickFolder
    If objActualFolder Is Nothing Then
        GoTo ExitSub:
    End If


    StrSavePath = "c:\temp\mail\"
    Call GetFolder(colFolders, colEntryID, colStoreID, objActualFolder)

    For i = 1 To colFolders.count
        StrFolder = fRemoveIlegalChars(colFolders(i))
        n = InStr(3, StrFolder, "\") + 1
        StrFolder = Mid(StrFolder, n, 256)
        StrFolderPath = StrSavePath & "\" & StrFolder & "\"
        StrSaveFolder = Left(StrFolderPath, Len(StrFolderPath) - 1) & "\"
        If Not FSO.FolderExists(StrFolderPath) Then
            FSO.CreateFolder (StrFolderPath)
        End If

        Set mapiSubFolder = oaOutlook.Session.GetFolderFromID(colEntryID(i), colStoreID(i))
        On Error Resume Next
        For j = 1 To mapiSubFolder.Items.count
            Set mItem = mapiSubFolder.Items(j)
            StrReceived = Format(mItem.ReceivedTime, "YYYYMMDD-hhmm")
            StrSubject = mItem.Subject
            StrName = fRemoveIlegalChars(StrSubject)
            StrFile = StrSaveFolder & StrReceived & "_" & StrName & ".msg"
            StrFile = Left(StrFile, 256)
            mItem.SaveAs StrFile, 3
            DoEvents
        Next j
        On Error GoTo 0
    Next i
    
    MsgBox "Done!"
ExitSub:

End Sub

Function fRemoveIlegalChars(StrInput)
    Dim RegEx As Object ' Using REGular EXPresion to remove ilegal chars

    Set RegEx = CreateObject("vbscript.regexp")

    RegEx.Pattern = "[\" & Chr(34) & "\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]"
    RegEx.IgnoreCase = True
    RegEx.Global = True

    fRemoveIlegalChars = RegEx.Replace(StrInput, "") ' If an ilegal char is in the title, is removed

    Set RegEx = Nothing ' Free Pointer

End Function


Sub GetFolder(colFolders As Collection, colEntryID As Collection, colStoreID As Collection, Fld As MAPIFolder)
    Dim mapiSubFolder As MAPIFolder ' MAPIFolder is deprecated, but still working, I'll need to change to Folder

    colFolders.Add Fld.FolderPath
    colEntryID.Add Fld.EntryID
    colStoreID.Add Fld.StoreID
    
    For Each mapiSubFolder In Fld.colFolders
        GetFolder colFolders, colEntryID, colStoreID, mapiSubFolder
    Next mapiSubFolder

    Set mapiSubFolder = Nothing ' Free Pointer

End Sub


'Function BrowseForFolder(StrSavePath As String, Optional OpenAt As String) As String
'    Dim objShell As Object
'    Dim objFolder '  As Folder
'    Dim strEnvironm As String
'
'    strEnvironm = "c:\temp\" ' CStr(strEnvironmn("USERPROFILE")) ' Do not use, cause problems because is mixing english (MyDocuments) and Spanish (Documentos)
'    Set objShell = CreateObject("Shell.Application")
'    Set objFolder = objShell.BrowseForFolder(0, "Please choose a folder", 0, strEnvironm)
'    StrSavePath = objFolder.self.Path
'
'    On Error Resume Next
'    On Error GoTo 0
'
'    Set objShell = Nothing
'End Function





-------------
Estos son mis principios. Si no le gustan... tengo otros



Imprimir página | Cerrar ventana