Visual Basic - Macro para manejar emails

dim fecha, dia, mes, anio

IF itm.Subject = "asistencia cae*" then

      dia=mid(itm.Subject,16,2)

      mes=mid(itm.Subject,19,2)

      anio=mid(itm.Subject,22,4)

     fecha=anio&"_"&mes&"_"&dia

Sub Work_with_Outlook()

Dim olApp As Outlook.Application

Dim olNs As Outlook.Namespace

Dim Fldr As Outlook.MAPIFolder

Dim myItem As Object

Dim myAttachment As Outlook.Attachment

Dim olMail As Variant

Dim i As Long

Set olApp = CreateObject("Outlook.Application")

Set olNs = olApp.GetNamespace("MAPI")

Set Fldr = olNs.GetDefaultFolder(olFolderInbox)

Set myTasks = Fldr.Items

Set olMail = myTasks.Find("[Subject] = ""test""")

     While Not olMail Is Nothing

If olMail.Attachments.Count Then

    For Each myAttachment In olMail.Attachments

        i = i + 1

       myAttachment.SaveAsFile "\archivo_destino" & i & ".txt"

     Next myAttachment

End If

Set olMail = myTasks.FindNext

Wend

MsgBox "Scan Complete."

End Sub

Sub ExportToExcel(): On Error Resume Next

Dim appExcel As Excel.Application

Dim wkb As Excel.Workbook

Dim wks As Excel.Worksheet

Dim nms As Outlook.NameSpace

Dim fld As Outlook.MAPIFolder

Dim itm As Object

'Creamos la instancia a Excel

Set appExcel = CreateObject("Excel.Application")

Workbooks.Add

Set wkb = appExcel.ActiveWorkbook

Set wks = wkb.ActiveSheet

appExcel.Application.Visible = True

'Fila de cabecera

wks.Range("A1") = "Asunto"

wks.Range("B1") = "Cuerpo"

wks.Range("C1") = "Remitente"

wks.Range("D1") = "Destinatario"

wks.Range("E1") = "Importancia"

wks.Range("F1") = "Privacidad"

wks.Range("G1") = "Fecha"

'Seleccionamos la carpeta

Set nms = Application.GetNamespace("MAPI")

Set fld = nms.PickFolder

If fld Is Nothing Then

   Exit Sub

End If

If fld.DefaultItemType <> olMailItem Or _

   fld.Items.Count = 0 Then

   MsgBox "La carpeta no contiene mensajes de correo electrónico"

   Exit Sub

End If

fila = 1

'Recorremos los mensajes

For Each itm In fld.Items

   If itm.Class = olMail Then

      fila = fila + 1

      wks.Range("A" & fila) = itm.Subject

      wks.Range("B" & fila) = itm.Body

      wks.Range("C" & fila) = itm.SenderName

      wks.Range("D" & fila) = itm.To

      wks.Range("E" & fila) = itm.Importance

      wks.Range("F" & fila) = itm.Sensitivity

      wks.Range("G" & fila) = itm.CreationTime

   End If

Next itm

'Ajustar al texto el cuepo del mensaje

wks.Range("B:B").WrapText = True

wks.Columns.ColumnWidth = 25

wks.Columns("B:B").ColumnWidth = 80

wks.Cells.VerticalAlignment = xlTop

MsgBox "*** Proceso de exportación de mensajes terminado correctamente ***"

'

'Limpiamos objetos

Set appExcel = Nothing

Set wkb = Nothing

Set wks = Nothing

Set nms = Nothing

Set fld = Nothing

Set itm = Nothing

End Sub