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
