none
Macro para ler nomes de Anexo de email e copiar em uma data base RRS feed

  • Pergunta

  • Boa tarde pessoal,

    Preciso criar uma Macro que pegue um email padrão diário que chega na minha caixa, sempre com alguns anexos de atualização. Gostaria de pegar os nomes destes arquivos e colocar em uma coluna, pra posteriormente fazer alguns procvs.


    Alguém tem alguma idéia?

    Obrigado!!

    sexta-feira, 6 de fevereiro de 2015 16:14

Respostas

  • Option Explicit
    
    'Change to suit: Database workbook:
    Private Const mcsWorkbookPath As String = "c:\temp\Anexos.xlsx"
    
    'Change to suit: What the e-mail subject:
    Private Const mcsSubject As String = "New Filled Form"
    
    Sub pMain()
      Dim clcFields As VBA.Collection
      Dim wb As Object 'Excel.Workbook
      Dim ws As Object 'Excel.Worksheet
      Dim oMail As Outlook.MailItem
      Dim oAtt As Outlook.Attachment
      Dim l As Long
      Dim lRow As Long
      
      Set oMail = ActiveExplorer.Selection(1)
      
      Set wb = pGetWorkbook
      If wb Is Nothing Then Exit Sub
      Set ws = wb.Worksheets(1)
      lRow = ws.Cells(ws.Rows.Count, "A").End(-4162).Row
      
      For l = 1 To oMail.Attachments.Count
        ws.Cells(lRow, "A").Offset(l) = oMail.Attachments(l).FileName
      Next l
      
      'Fechar e salvar?
      'wb.Close SaveChanges:=True
      
      MsgBox "Anexos listados com sucesso!", vbInformation
    End Sub
    
    Private Function pGetWorkbook() As Object 'Excel.Application
      Dim appExcel As Object 'Excel.Application
      Dim wb As Object 'Excel.Workbook
      
      If Dir(mcsWorkbookPath) = "" Then
        MsgBox "Couldn't find workbook at '" & mcsWorkbookPath & "'.", vbCritical
        Exit Function
      End If
      
      On Error Resume Next
      Set appExcel = GetObject(, "Excel.Application")
      If appExcel Is Nothing Then Set appExcel = CreateObject("Excel.Application")
      If appExcel Is Nothing Then
        MsgBox "Couldn't initialize Excel.", vbCritical
        Exit Function
      End If
      appExcel.Visible = True
      
      Set wb = appExcel.Workbooks(Mid(mcsWorkbookPath, InStrRev(mcsWorkbookPath, "\") + 1))
      If wb Is Nothing Then Set wb = appExcel.Workbooks.Open(mcsWorkbookPath)
      If wb Is Nothing Then
        MsgBox "Couldn't open the Form's database workbook."
        Exit Function
      End If
      
      Set pGetWorkbook = wb
    End Function
    


    Felipe Costa Gualberto - http://www.ambienteoffice.com.br

    sábado, 7 de fevereiro de 2015 19:43
    Moderador