BAJAR ADJUNTOS EMAIL

[mbriculle]

Buenos días chicos ,

He revisado que mi consulta no estuviera resuelta y no la he encontrado.He visto algunas parecidas pero lo que necesito concretamente.

1-OBJETIVO

Tengo un archivo excel donde llevo el control economico de proyectos de inevrsión y quiero que desde el excel me baje los archivos adjuntos de los emails seleccionados en el outlook y me los guarde en la carpeta OFERTAS.Estos archivos son ofertas relacionadas con el proyecto de inversión y quiero ahorrar tiempo en la acción de bajar estos archivos adjuntos.

Lo que me interesa es que me baje los archivos del email seleccionado  o emails que yo seleccione , y no de los emails marcados como no leidos.

Quiero esto en concreto porque la macro original me baja los emails marcados como no leidos y esto es muy engorroso porque hay usuarios en mi empresa que tienen muchos emails marcados como no leidos hace que se bajen demasiados archivos adjuntos que no tienen nada que ver con el adjunto que me interesa.

2-PROBLEMA

La macro me baja los adjuntos de los emails marcados como no leidos y yo quiero solo los emails que yo seleccione manualmente.

3-PROGRAMACION DE LA MACRO

Os dejo el modulo con la programación de la macro en cuestión.Creo que me la baje de este foro.

Const olFolderInbox As Integer = 6

Sub DownloadAttachmentFirstUnreadEmail()
Dim oOlAp As Object, oOlns As Object, oOlInb As Object
Dim oOlItm As Object, oOlAtch As Object

Application.DisplayAlerts = False

'~~> New File Name for the attachment
Dim NewFileName As String
NewFileName = ThisWorkbook.path & "\OFERTAS\"

'~~> Get Outlook instance
Set oOlAp = GetObject(, "Outlook.application")
Set oOlns = oOlAp.GetNamespace("MAPI")
Set oOlInb = oOlns.GetDefaultFolder(olFolderInbox)

 '~~> Check if there are any actual emails
If oOlInb.items.Restrict("[UnRead] = false").Count = 0 Then Exit Sub

'~~> Extract the attachment files
For Each oOlItm In oOlInb.items.Restrict("[UnRead] = true")

    '~~> Check if the email actually has an attachment
    If oOlItm.Attachments.Count <> 0 Then
        For Each oOlAtch In oOlItm.Attachments
            '~~> Download the attachment
            oOlAtch.SaveAsFile NewFileName & oOlAtch.Filename
            '[ActiveCell]= oOlAtch.DisplayName
            
           
        Next
    End If
    
    
Next

End Sub

 

Saludos y muchas gracias de antemano,

[Mauricio_ODN]

Hace 3 horas, mbriculle dijo:

'~~> Check if there are any actual emails
If oOlInb.items.Restrict("[UnRead] = false").Count = 0 Then Exit Sub

'~~> Extract the attachment files
For Each oOlItm In oOlInb.items.Restrict("[UnRead] = true")

Hola @mbriculle

Estas son las líneas que realizan el filtro en el correo "de todos los no leídos", modifica estas líneas.

No uso Outlook, por restricciones de la empresa, no logre hacer pruebas, pero te dejo este link:

https://stackoverflow.com/questions/33261598/display-email-body-of-selected-email-in-outlook-as-a-message-box-in-excel

En lo que alguien más atiende la consulta. Espero pueda ser de utilidad.

[mbriculle]

Muchas gracias mauricio

he intentado cambiarlo pero me falta poner los codigos para que sólo me baje los adjuntos de los emails que yo seleccione.

Te copio el desarrollo .Con estas lineas lo que me hace es bajarme todos los adjuntos de los emails que tengo en la bandeja de entrada .

 

Const olFolderInbox As Integer = 6

Sub DownloadAttachmentFirstUnreadEmail()
Dim oOlAp As Object, oOlns As Object, oOlInb As Object
Dim oOlItm As Object, oOlAtch As Object

Dim objItem As Object

Application.DisplayAlerts = False

'~~> New File Name for the attachment
Dim NewFileName As String
NewFileName = ThisWorkbook.path & "\OFERTAS\"

'~~> Get Outlook instance
Set oOlAp = GetObject(, "Outlook.application")
Set oOlns = oOlAp.GetNamespace("MAPI")
Set oOlInb = oOlns.GetDefaultFolder(olFolderInbox)
Set objItem = oOlAp.ActiveExplorer.Selection.Item(1)

i = 0

If oOlInb.items.Count = 0 Then
MsgBox "There are no messages in folder.", vbInformation, _
"Nothing Found"

Exit Sub
End If

If oOlInb.items.Count > 0 Then
For Each oOlItm In oOlInb.items
For Each oOlAtch In oOlItm.Attachments
oOlAtch.SaveAsFile NewFileName & oOlAtch.FileName

i = i + 1
Next oOlAtch
Next oOlItm
End If

End Sub

 

A ver si me podeis ayudar. :)

[qwerty123]

Hola.

Prueba con el siguiente código:

Sub DescargarAdjuntos()
Dim olApp As Outlook.Application
Dim olExpl As Outlook.Explorer
Dim olSel As Outlook.Selection
Dim olMail As Outlook.MailItem
Dim olAdj As Outlook.Attachment
Dim iÍnd As Integer
Dim sUbic As String
Dim lArc As Long

    sUbic = ThisWorkbook.Path & "\OFERTAS\"
    Set olApp = GetObject(, "Outlook.application")
    Set olExpl = olApp.ActiveExplorer
    Set olSel = olExpl.Selection
    
    On Error Resume Next
    For Each olMail In olSel
        If olMail.Class = 43 Then
            For Each olAdj In olMail.Attachments
                olAdj.SaveAsFile sUbic & olAdj.Filename
                lArc = lArc + 1
            Next
        End If
    Next
    On Error GoTo 0

    MsgBox "Se han guardado " & Format(lArc, "#,##0") & " ficheros.", vbInformation, "TERMINADO"
    
End Sub

Hay que tener en cuenta que Outlook entiende por adjunto todo lo que no es texto. Por ejemplo, si el correo tiene una o varias imágenes, como puede ser el logotipo de la empresa, éstas se consideran también adjuntos y por lo tanto también las descargará. Por esta razón, quizá deberías considerar filtrar el tipo de archivo (excel, pdf, etc).

 

Un saludo.

PS.  En el código anterior no está contemplado que correos distintos tengan adjuntos con el mismo nombre.  Si se diera el caso, habría que modificarlo para que no se sobreescriban.

[Mauricio_ODN]

Hola @mbriculle

Prueba así

->> 

Const olFolderInbox As Integer = 6

Sub DownloadAttachmentSelectedEmail()
Dim oOlAp As Object, oOlns As Object, oOlInb As Object
Dim oOlItm As Object, oOlAtch As Object

Dim objItem As Object

Application.DisplayAlerts = False

'~~> New File Name for the attachment
Dim NewFileName As String
NewFileName = ThisWorkbook.Path & "\OFERTAS\"

'~~> Get Outlook instance
Set oOlAp = GetObject(, "Outlook.application")
Set oOlns = oOlAp.GetNamespace("MAPI")
Set oOlInb = oOlns.GetDefaultFolder(olFolderInbox)
Set objItem = oOlAp.ActiveExplorer.Selection

''MsgBox oOlAp.ActiveExplorer.Selection.Count

i = 0
a = 0

If objItem.Count = 0 Then
MsgBox "There are no messages in folder.", vbInformation, _
"Nothing Found"
Exit Sub

ElseIf objItem.Count > 0 Then
    For Each oOlItm In objItem
        For Each oOlAtch In oOlItm.Attachments
            oOlAtch.SaveAsFile NewFileName & oOlAtch.Filename
            
            i = i + 1
        Next oOlAtch
        ''MsgBox oOlItm
    Next oOlItm
End If

End Sub
 

<<-

Nos comentas.

[mbriculle]

Hola Mauricio,

 

Me ha funcionado a la perfección.He seleccionado 3 emails de la bandeka de entrada y me ha bajado solo los adjuntos de esos 3 emails,

Sois unos cracks.

 

Muchisimas gracias ,

Un abrazo,

[mbriculle]

Hola qwerty123

Gracias por el código , pero entiendo que funciona desde eVBA de Outlook no ?

Lo voy a probar también , porque la opción en Outlook también me interesa.

 

Muchas gracias ,

 

[mbriculle]

Hola qwerty123

Me ha funcionado a la perfección también.

Solo he tenido que cambiar 

Dim olApp As Outlook.Application
Dim olExpl As Outlook.Explorer
Dim olSel As Outlook.Selection
Dim olMail As Outlook.MailItem
Dim olAdj As Outlook.Attachment

 

Y poner al final Object.

Dim olApp As Object

Dim olExpl As Object
Dim olSel As Object
Dim olMail As Object
Dim olAdj As Object

 

Con este cambio ha funcionado muy bien

Estoy encantada con vosotros .Sois unos cracks

 

Muchas gracias ,

[mbriculle]

Hola qwerty123

Como podría excluir los archivos que sean imagenes  como JPG, PNG ??

 

Muchas gracias ,

[Mauricio_ODN]

Hace 41 minutos , mbriculle dijo:

Como podría excluir los archivos que sean imagenes  como JPG, PNG ??

Una sugerencia para esta última pregunta:

If objItem.Count = 0 Then
MsgBox "There are no messages in folder.", vbInformation, _
"Nothing Found"
Exit Sub
    ElseIf objItem.Count > 0 Then
        For Each oOlItm In objItem
            For Each oOlAtch In oOlItm.Attachments
                ''MsgBox InStr(1, oOlAtch.Filename, ".", vbTextCompare)
                ''MsgBox Mid(oOlAtch.Filename, InStr(1, oOlAtch.Filename, ".", vbTextCompare) + 1, 1)

''->> Aqui se busca la primera letra de la extensión dle archivo
                If Mid(oOlAtch.Filename, InStr(1, oOlAtch.Filename, ".", vbTextCompare) + 1, 1) = "x" Then
                    oOlAtch.SaveAsFile NewFileName & oOlAtch.Filename
                End If
                
                i = i + 1
            Next oOlAtch
            ''MsgBox oOlItm
        Next oOlItm
End If

 

Espero sea de utilidad

[mbriculle]

Mauricio

 

Muy amable ,lo he probado y me exluye las extensiones que empiecen por una letra determinada.

Funciona muy bien

Excelente

 

De nuevo graciasssssssssssssssssssssssssssss