** NORMAS DEL FORO **
Inicio del foro Inicio del foro > Otros de Microsoft: Windows y Office > Otros Productos Microsoft
  Mensajes nuevos Mensajes nuevos RSS - Exportar correos Outlook seleccionados a carpeta p
  Preguntas frecuentes Preguntas frecuentes  Buscar en el foro   Eventos   Registro Registro  Iniciar sesion Iniciar sesion

Tema cerradoExportar correos Outlook seleccionados a carpeta p
 Responder Responder
Autor
Mensaje
  Tema Buscar Tema Buscar  Opciones del Tema Opciones del Tema
Galathea Ver desplegable
Habitual
Habitual
Avatar

Unido: 15/Septiembre/2012
Localización: España
Estado: Sin conexión
Puntos: 135 		Enlace directo a este mensaje Tema: Exportar correos Outlook seleccionados a carpeta p
    Enviado: 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.
Arriba
lbauluz Ver desplegable
Administrador
Administrador
Avatar

Unido: 29/Marzo/2005
Localización: La Gloria
Estado: Sin conexión
Puntos: 3835 		Enlace directo a este mensaje Enviado: 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
El Búho es un pajarraco
Arriba
 Responder Responder
  Compartir tema   

Ir al foro Permisos de foro Ver desplegable