Cannot open database after record inserted by vba (1 Viewer)

[schniggeldorf]

Hi:

I have written vba code in Microsoft Outlook that reads each incoming email, selects those whose subject line matches my criteria, then extracts particular data from the body of the message. All that code works as I wish.

The attached Sub is intended to take the extracted values and insert them into a table (tblKpEmailUpload) in an existing accdb. Afterwards, it runs an append query to move the new record into an existing table. Then it runs a delete query to erase all the data in tblKpEmailUpload.

Everything works exactly as I wish -- Except that after the Sub finishes running, I cannot open the accdb. When I try, it immediately creates a .laccdb file, but doesn't open. I can get around this by opening the vba Editor in Outlook and pressing the reset button, or by closing Outlook altogether. Surely there must be a way to prevent my accdb from locking up, but I haven't been able to find it. Can anybody help?

My code is below:

Sub ExportToAccess(MRN As Long, PatientLastName As String, PatientFirstName As String, AttendingLastName As String, _
AttendingFirstName As String, strEncounterDate As String, Optional Status
As Integer, Optional PendingType As Integer, Optional ClosedType As Integer)

On Error GoTo Err_ExportToAccess

Dim wrkspc As DAO.Workspace
Dim db As DAO.Database
Dim rst As DAO.Recordset
Dim strMonth As String
Dim Month As Integer
Dim Day As Integer
Dim Year As Integer
Dim EncounterDate As Date
Dim CcfMdId As Integer
Dim SQL1 As String
Dim SQL2 As String

Set wrkspc = DBEngine.Workspaces(0)
Set db = wrkspc.OpenDatabase(constDbPath)
Set rst = db.OpenRecordset("tblKpEmailUpload", dbOpenDynaset) 'Specify the table where the data go after they're processed (e.g. tblPatients).
rst.FindFirst "MRN= " & MRN

'If record already exists, edit. Else add new.
If rst.NoMatch = False Then 'If recExist > 0 Then
rst.Edit
Else
rst.AddNew
rst.Fields("MRN").Value = MRN
End If

rst.Fields("PatientFirstName").Value = StrConv(PatientFirstName, vbProperCase)
rst.Fields("PatientLastName").Value = StrConv(PatientLastName, vbProperCase)
rst.Fields("AttendingFirstName").Value = AttendingFirstName
rst.Fields("AttendingLastName").Value = AttendingLastName

'Parse EncounterDate to a format access can accept.
strMonth = LCase(Left(strEncounterDate, 3))
Select Case strMonth
Case "jan"
Month = 1
Case "feb"
Month = 2
Case "mar"
Month = 3
Case "apr"
Month = 4
Case "may"
Month = 5
Case "jun"
Month = 6
Case "jul"
Month = 7
Case "aug"
Month = 8
Case "sep"
Month = 9
Case "oct"
Month = 10
Case "nov"
Month = 11
Case "dec"
Month = 12
Case Else
MsgBox "Sub ExportToAccess can't find the month of this encounter."
End Select

Day = CInt(Mid(strEncounterDate, 4, 2))
Year = CInt(Right(strEncounterDate, 4))
EncounterDate = DateSerial(Year, Month, Day)

rst.Fields("EncounterDate").Value = EncounterDate
rst.Fields("Status").Value = Status
rst.Fields("PendingType").Value = PendingType
rst.Fields("ClosedType").Value = ClosedType
rst.Update

' Run queries to append this record to tblPatients in IMATCH Data File.accdb, and to delete the records in tblKpEmailUpload afterwards

SQL1 = "INSERT INTO tblPatients (MRN, FirstName, LastName, RefDate, Status, PendingType, ClosedType, PatientCcfHaMdId )" _
& "SELECT tblKpEmailUpload.MRN, tblKpEmailUpload.PatientFirstName, tblKpEmailUpload.PatientLastName, tblKpEmailUpload.EncounterDate, " _
& "tblKpEmailUpload.Status, tblKpEmailUpload.PendingType, tblKpEmailUpload.ClosedType, tblCcfHeadacheStaff.CcfStaffID " _
& "FROM tblKpEmailUpload INNER JOIN tblCcfHeadacheStaff ON (tblKpEmailUpload.AttendingLastName = tblCcfHeadacheStaff.LastName) " _
& "AND (tblKpEmailUpload.AttendingFirstName = tblCcfHeadacheStaff.FirstName);"

SQL2 = "Delete tblKpEmailUpload.MRN " _
& "From tblKpEmailUpload " _
& "WHERE (((tblKpEmailUpload.MRN)>0));"

db.Execute SQL1 'This uploads the new data from tblKpEmailUpload to tblPatients
db.Execute SQL2 'This empties tblKpEmailUpload

' Close open objects
rst.Close
Set rst = Nothing
db.Close
Set db = Nothing
wrkspc.Close
Set wrkspc = Nothing

Exit_ExportToAccess:
Exit Sub

Err_ExportToAccess:
MsgBox Err.Number & ": " & Err.Description
End Sub

 

[Cronk]

Check your Task Manager and look not at application but running processes. I think you have Access running hidden. I would explicitly open an instance of access with CreateObject and close that instance at the end of your code.

 

[The_Doc_Man]

Just a comment here... Your run around the mulberry bush to generate a date is perhaps not necessary. If you have a date such as "1-Jan-2017" (to keep it simple), you can just do CDate( datestring ) or even a simple assignment to a date variable such as

date-var = "#" & your-date-string-here & "#"

At worst, all you would have to do is extract the parts and put them together with dashes for punctuation, because it looks like your dates are run together.

Also, instead of this...

rst.Fields("EncounterDate").Value = EncounterDate

You could do this...

rst![EncounterDate] = EncounterDate

Though I might have chosen a different name for the variable vs. the field name, just for reading clarity.

One last comment: This sequence is incorrect and will hang you up hard and fast.

Err_ExportToAccess:
MsgBox Err.Number & ": " & Err.Description
End Sub

Once you take a trap, you must use RESUME - perhaps only via Resume Exit_ExportToAccess - to close out the trap handler's execution. This is because trap context is NOT a subroutine and an Exit Sub will not properly close out the context.

 

[schniggeldorf]

Check your Task Manager and look not at application but running processes. I think you have Access running hidden. I would explicitly open an instance of access with CreateObject and close that instance at the end of your code.

Thank you! Task Manager indeed indicated that MSACCESS was running, even though it didn't appear in the Applications tab. Your solution worked as well.

 

[schniggeldorf]

Thank you! Your date variable suggestion worked, and is indeed simpler than mine. I also changed the error handling as you suggested. Everything is running fine now.

 

[The_Doc_Man]

Glad we could help.