We use this third-party tool to automate the saving of attachments ...
http://www.sperrysoftware.com/Outlook/Attachment-Save.asp
Once the attachments are saved, it's a simple matter of looping through the
files in the target directory, importing each file, and renaming or moving
the file after import (so that the code will not attempt to import the same
file more than once).
Here's some code from one of my own apps ...
Public Sub ReadText()
Dim strInput As String
Dim intInput As Integer
Dim intOutput As Integer
Dim strLine As String
Dim db As DAO.Database
Dim rst As DAO.Recordset
Dim strCompanyCode As String
Dim strCompanyName As String
Dim strOutputDate As String
Dim dtmOutputDate As Date
Dim strFileNumber As String
Dim lngTransactions As Long
Dim curAmount As Currency
Dim curTotal As Currency
Dim strProcessDate As String
Dim dtmProcessDate As Date
Dim strSummaryDate As String
Dim dtmSummaryDate As Date
Dim lngReportedTransactions As Long
Dim curReportedAmount As Currency
Set db = CurrentDb
Set rst = db.OpenRecordset("SELECT * FROM tblTransaction",
dbOpenDynaset, dbAppendOnly)
strInput = Dir("C:\BillPay\Input\*.DAT")
Do Until strInput = vbNullString
intInput = FreeFile
Open "C:\BillPay\Input\" & strInput For Input As intInput
intOutput = FreeFile
Open "C:\BillPay\Done\" & strInput For Output As intOutput
Do Until EOF(intInput)
Line Input #intInput, strLine
Select Case Left$(strLine, 1)
Case "H"
'Header
strCompanyCode = Mid$(strLine, 2, 2)
strCompanyName = Trim$(Mid$(strLine, 4, 30))
'ddmmyy
strOutputDate = Mid$(strLine, 34, 6)
dtmOutputDate = DateSerial(CInt(Right$(strOutputDate, 2)),
CInt(Mid$(strOutputDate, 3, 2)), _
CInt(Left$(strOutputDate, 2)))
strFileNumber = Mid$(strLine, 40, 2)
lngTransactions = 0
curTotal = 0
Print #intOutput, strLine
Case "D"
'Detail
lngTransactions = lngTransactions + 1
With rst
.AddNew
.Fields("FileName") = strInput
.Fields("CompanyCode") = strCompanyCode
.Fields("CompanyName") = strCompanyName
.Fields("OutputDate") = dtmOutputDate
.Fields("FileNumber") = strFileNumber
.Fields("BatchNumber") = Mid$(strLine, 2, 8)
.Fields("SequenceNumber") = Mid$(strLine, 10, 8)
.Fields("TransactionCode") = Mid$(strLine, 18, 3)
.Fields("GrofNumber") = Mid$(strLine, 21, 4)
.Fields("AccountNumber") = Mid$(strLine, 25, 11)
curAmount = (CCur(Mid$(strLine, 36, 6)) / 100)
.Fields("AmountPaid") = curAmount
curTotal = curTotal + curAmount
'yymmdd
strProcessDate = Mid$(strLine, 42, 6)
dtmProcessDate = DateSerial(CInt(Left$(strProcessDate,
2)), CInt(Mid$(strProcessDate, 3, 2)), _
CInt(Right$(strProcessDate, 2)))
.Fields("ProcessDate") = dtmProcessDate
'undocumented, appears to be ddmmyy
strSummaryDate = Mid$(strLine, 48, 6)
dtmSummaryDate = DateSerial(CInt(Right$(strSummaryDate,
2)), CInt(Mid$(strSummaryDate, 3, 2)), _
CInt(Left$(strSummaryDate, 2)))
.Fields("SummaryDate") = dtmSummaryDate
.Fields("DateGrof") = Mid$(strLine, 54, 4)
.Update
End With
Print #intOutput, strLine
Case "T"
lngReportedTransactions = CLng(Mid$(strLine, 2, 7))
curReportedAmount = CCur(Mid$(strLine, 9, 10)) / 100
If lngReportedTransactions <> lngTransactions Then
MsgBox "Number of reported transactions does not match
actual number. File name: " & strInput
End If
If curReportedAmount <> curTotal Then
MsgBox "Reported amount does not match actual amount.
File name: " & strInput
End If
Print #intOutput, strLine
Case Else
MsgBox "Unrecognized record type!"
On Error Resume Next
Close
rst.Close
Exit Sub
End Select
Loop
Close intInput
Close intOutput
Name "C:\BillPay\Input\" & strInput As "C:\BillPay\Input\" &
Left$(strInput, InStrRev(strInput, ".")) & "BAK"
strInput = Dir()
Loop
rst.Close
MsgBox "Finished"
On Error Resume Next
Close
rst.Close
End Sub
