My code goes to errhandler most of the time and lock my database - Please help

[pedie]

Hi, below is my code 'm curently using to pass information from frontend db to main db. I'm trying to add errorhandler so that it does not lock database at any cost at any point of time....

It says sucessfull, however when i go and check main database it says table is locked by pediez - PC and wont allow me to add data again the next time which compels me to restart the application.


Thanks in advance.

What i want is to increase the performance and error handling here...

[/FONT]
[FONT=Courier New]Sub new_Request_asPen()[/FONT]
[FONT=Courier New]Dim db As DAO.Database
Dim ws As DAO.Workspace
Dim rst As DAO.Recordset
Dim MVFrst As Recordset
Dim rs As DAO.Recordset
Dim x As String
Dim Answer  As String[/FONT]
[FONT=Courier New]Answer = MsgBox("Do you want to continue and submit this request?", vbYesNo, "??? Click YES or No")[/FONT]
[FONT=Courier New]
If Answer = vbNo Then Exit Sub[/FONT]
[FONT=Courier New]On Error GoTo MyErrHandler
Set ws = DBEngine.Workspaces(0)
Set db = ws.OpenDatabase(MyMainDatabase, False, False, "MS Access;PWD=" & MyPass)
Set rst = db.OpenRecordset("MAINDBtb", dbOpenDynaset)[/FONT]
[FONT=Courier New]rst.AddNew
rst!Title = Me.Title.Value
rst!Rngk_Detail = Me.Rngk_Detail.Value
rst!DEPT_Name = Me.DEPT_Name.Value
rst!Rngk_By = Me.Rngk_By.Value
rst!RNGkng_USED_BY_ID = Me.RNGkng_USED_BY_ID.Value
rst!Rngk_Date = Me.Rngk_Date.Value
rst!Invoice_No = Me.Invoice_No.Value
rst!Rngk_Amount = Me.Rngk_Amount.Value
rst!ex_Month = Me.ex_Month.Value
rst!ex_Year = Me.ex_Year.Value
rst!ex_Quarter = Me.ex_Quarter.Value
rst!Type_of_Budget = Me.Type_of_Budget.Value
rst!Sites = Me.Sites.Value
rst!Ex_Comments = Me.Ex_Comments.Value
rst!Approval_Status = "Pending"
rst!MngID = Me.MngID.Value
rst!MngName = Me.MngName.Value
rst!MngeMail = Me.MngeMail.Value
rst!RngkCategory = Me.RngkCategory.Value
If Len(Me.LOB_Cost_Center & vbNullString) <> 0 Then rst!LOB_Cost_Center = Me.LOB_Cost_Center
If Len(Me.BACICostEnterNo & vbNullString) <> 0 Then rst!BACI_Cost_C = Me.BACICostEnterNo
rst!Req_Creator = Me.Req_Creator.Value
rst!Creator_ID = UCase(Environ("Username"))
rst!Req_CreatorEmail = Me.Req_CreatorEmail.Value
rst!SubmittedTimeAndDate = Now[/FONT]
[FONT=Courier New]If Me.LOB_ApprovalAttached = True Then rst!LOB_ApprovalAttached = True
If Me.PVR_ApprovalAttached = True Then rst!PVR_ApprovalAttached = True[/FONT]
[FONT=Courier New]x = rst!ID
Debug.Print x
rst.Update[/FONT]
[FONT=Courier New]
rst.FindFirst "ID = " & x
rst.Edit
Debug.Print rst!ID
Set MVFrst = rst.Fields("Attachment").Value
MVFrst.AddNew
MVFrst.Fields("FileData").LoadFromFile Me.Att1.Caption
MVFrst.Update
rst.Update
MVFrst.Close
Set MVFrst = Nothing
[/FONT] 
[FONT=Courier New]rst.FindFirst "ID = " & x
rst.Edit
Debug.Print rst!ID
Set MVFrst = rst.Fields("Attachment").Value
MVFrst.AddNew
MVFrst.Fields("FileData").LoadFromFile Me.Att2.Caption
MVFrst.Update
rst.Update
MVFrst.Close
Set MVFrst = Nothing[/FONT]
[FONT=Courier New][/FONT] 
[FONT=Courier New]'send email code
sendemailnow[/FONT]
[FONT=Courier New]MsgBox "Request submitted: Thanks!", vbInformation, "Request Submitted"[/FONT]
[FONT=Courier New]CloseOpnDbRSt:
If Not rst Is Nothing Then
rst.Close
Set rst = Nothing
Set ws = Nothing
Set db = Nothing
End If
Exit Sub
MyErrHandler:
MsgBox Err.Number & ":" & Err.Description, vbInformation, "Unexpected Error!"
GoTo CloseOpnDbRSt
End Sub
Sub sendemailnow()
'---------------------------Gather email
Dim CTkemail As String
Dim Spname As String
Dim Spcontno As String[/FONT]
[FONT=Courier New]Dim AdminTb As DAO.Recordset
Set AdminTb = CurrentDb.OpenRecordset("AdminTb", dbOpenDynaset)[/FONT]
[FONT=Courier New]CTkname = AdminTb!S_Name
CTkcontantno = AdminTb!ContactNo[/FONT]
[FONT=Courier New]AdminTb.MoveFirst
    Do Until AdminTb.EOF
    If AdminTb!Email_ID <> "" Then
    CTkemail = CTkemail & AdminTb!Email_ID & ";"
    End If
    AdminTb.MoveNext
    Loop
AdminTb.Close
Set AdminTb = Nothing
'---------------------------Send emial
 Dim OutApp As Object
 Dim OutMail As Object
 Set OutApp = CreateObject("Outlook.Application")
 Set OutMail = OutApp.CreateItem(0)
 
 On Error Resume Next
 With OutMail
     .to = Me.MngeMail.Value
     .CC = CTkemail
     .Subject = "TEST new Request"
     .Body = "Hi "
     If Me.Att1.Caption <> "Att" Then .Attachments.Add Me.Att1.Caption
     If Me.Att2.Caption <> "Att" Then .Attachments.Add Me.Att2.Caption
     If Me.Att3.Caption <> "Att" Then .Attachments.Add Me.Att3.Caption
     If Me.Att4.Caption <> "Att" Then .Attachments.Add Me.Att4.Caption
     If Me.Att5.Caption <> "Att" Then .Attachments.Add Me.Att5.Caption
    .Send
 End With
 On Error GoTo 0
 Set OutMail = Nothing
 Set OutApp = Nothing
End Sub[/FONT]
[FONT=Courier New]