Load attachment into Access database

[bradh_nz]

I have the below code that runs off a rule in outlook (runs a script) and then saves the attachment in a folder and loads it into an access table. It works fine once and then leaves an excel file open and will not load in when a subsequent email arrives. Any help appreciated.

Sub SaveToFolder_Vector(MyMail As MailItem)
Dim strID As String
Dim objNS As Outlook.NameSpace
Dim objMail As Outlook.MailItem
Dim objAtt As Outlook.Attachment
Dim c As Integer
Dim save_name As String

'Place path to sav to on next line.
Const save_path As String = "G:\Gas\Trading Daily Gas Tools\Interruptible User Contract\Recieved Transmission Scheduler\"

'Error_Trapping
'On Error GoTo GetError_err

strID = MyMail.EntryID
Set objNS = Application.GetNamespace("MAPI")
Set objMail = objNS.GetItemFromID(strID)

If objMail.Attachments.Count > 0 Then
For c = 1 To objMail.Attachments.Count
Set objAtt = objMail.Attachments(c)
save_name = Format(objMail.CreationTime, "yyyymmdd-hhnnss") & ".xls"
objAtt.SaveAsFile save_path & save_name
Next
End If

'Upload excel to access
Call DAOFromExcelToAccess(save_name)

Set objAtt = Nothing
Set objMail = Nothing
Set objNS = Nothing

Exit Sub
GetError_err:
'Error_Message = "Error with NZRC Recived Attachment"
'SendErrorMessage True, Error_Message
End Sub
Sub DAOFromExcelToAccess(save_name)
Dim db As Database
Dim rs As Recordset
Dim r As Long
Dim ApExcel As Object 'To open Excel
'save_name = "20100311-142359.xls"

Const save_path As String = "G:\Gas\Trading Daily Gas Tools\Interruptible User Contract\Recieved Transmission Scheduler\"
Const save_path_succesful As String = "G:\Gas\Trading Daily Gas Tools\Interruptible User Contract\Recieved Transmission Scheduler\Succesfully Uploaded\"

Set db = OpenDatabase("G:\Gas\Trading Daily Gas Tools\Interuptible.mdb")
Set rs = db.OpenRecordset("NZRC_Vector", dbOpenTable) ' open the database

Set ApExcel = CreateObject("Excel.application") 'Creates an object
ApExcel.Visible = False ' So you cant see Excel
ApExcel.Workbooks.Open filename:=save_path & save_name

' get all records in a table
r = 19 ' the start row in the worksheet
Do While Len(Range("B" & r).Formula) > 0
' repeat until first empty cell in column A
With rs
.AddNew ' create a new record
'.Fields("Identifier") = Range("A" & r).Text
.Fields("Transmission Date") = Range("B" & r).Value
.Fields("Email Sent") = save_name
.Fields("Shipper Nomination") = Range("C" & r).Value
.Fields("Vector Offer") = Range("D" & r).Value
.Fields("Nomination Cycle") = Range("C15").Value
.Fields("Todays Date") = Range("C8").Value
.Fields("Delivery Point") = Range("C14").Value
.Update ' stores the new record
End With
r = r + 1 ' next row
Loop

'close excel
'ApExcel.ThisWorkbook.Close SaveChanges:=False
ApExcel.Quit
Set ApExcel = Nothing

Name save_path & save_name As save_path_succesful & save_name
rs.Close
Set rs = Nothing
db.Close
Set db = Nothing


End Sub