Record Saving issue

[James Bowyer]

I am having an issue with my database in that it occasionally fails to save records, but the rest of the code ran by the button works flawlessly.

I am using the :

RunCommand acCmdSaveRecord
 

method, there are no errors reported (although this could be because the users aren't telling me...).

My only guess is that it won't save if two users are viewing records from the same table at once, which I'm rather hoping isn't the problem. Obviously I can stop users from exiting the record without it being saved properly, but it would be nice to know the most common reasons for records not saving.

[TheSmileyCoder]

Unless your code is supressing errors/warnings, you should get an error message when a record is not saved. Without more details/seeing the rest of your code I have no other advice to offer.

[James Bowyer]

the error coding is as follows:

CreateFile_Error:
Select Case errorstate
Case Is = 1
MsgBox "Job Number Not able to be created, please contact Administrator", vbCritical, "SCM"
Case Is = 2
MsgBox "Job Number May Already Exist On This System, Please contact Administrator", vbCritical, "SCM"
Case Is = 3
MsgBox "Please ensure All Fields Marked With an Asterix (*) Are Filled In", vbCritical, "SCM"
Case Is = 4
MsgBox "File May Already Exist, Please contact Administrator", vbCritical, "SCM"
Case Is = 5
MsgBox "Unable To Create Project File, Please contact Administrator", vbCritical, "SCM"
Case Is = 6
MsgBox "Unable To Copy Project Files from Standards Folder, Please Contact Administrator", vbCritical, "SCM"
Case Is = 7
MsgBox "Unable To Locate External Project Manager Details, Please contact Administrator", vbCritical, "SCM"
Case Is = 8
Dim excelopen As String
excelopen = MsgBox("Is there a version of SiteDetails.xlsx Currently Open?", vbYesNo, "SCM")
Select Case excelopen
Case vbYes
MsgBox "Please Close Sitedetails.xlsx NOW!", vbCritical, "SCM"
GoTo Line4
Case Else
MsgBox "Unable To Create Sitedetails.xlsx, Please Contact Administrator", vbCritical, "SCM"
End Select
Case Is = 9
MsgBox "Unable to create Permananent Values, Please Contact Administrator", vbCritical, "SCM"
Case Else
Dim emailproblem As String
emailproblem = MsgBox("Is Outlook open and Logged in?", vbYesNo, "SCM")
Select Case emailproblem
Case vbNo
MsgBox "Please Open Outlook Before Continuing", vbCritical, "SCM"
GoTo Line29
Case Else
MsgBox "Not Able to send email, Please contact administrator", vbCritical, "SCM"
End Select
End Select
 

so, as far as I can see, does not suppress any warnings.

I have just spoken to one of the users who had the problem, and he has assured me that no warnings came up, and the program did not crash (what it used to do before I discvered error reporting!!).

So, no errors, code definately running all the way to the end (it ends with the system sending an email, checked the users sent items and the email has gone), but the record has not been saved.

I am very confused!!

[TheSmileyCoder]

Its hard to say from your code, but I would start by adding a Case Else to your first Select statement. (As a good programming practise, I recommend always having a Case Else. If you know that its not meant to be used, simply add a Msgbox within the case else, so that if it should happen, you will be alerted.

Also I dont see where the RunCommand acCmdSaveRecord comes in.

[James Bowyer]

I tried to avoid putting the full code in, as its horrendously long!

I shall have to try and put in an additional Case Else statement, although it should be covered by errorstate=9 (errorstate is simply an integer that rises throughout the function to give the appropriate error response).

The problem seems to stem from when a user is creating a new record in a table which another user has a record of open.

Obviously if it was the same record, this would be understandable, but its not!

[TheSmileyCoder]

Do you have your forms recordlock property set to edited record?

Im no expert on recordlocks, but from what little I tried a while ago, I found that access locks the page that record is on, meaning it will also lock neighboring records. Now I dont think this should affect new records, but I really haven't worked much with recordlocks.

I dont really think your problem is connected to the "Case Else", I only mentioned it as a "best practice" advice.

Are you able to replicate the problem consistently?

Have you tried putting a simple msgbox before your save command, to ensure that the command is actually being run?
Example:

Msgbox "About to Save"
Docmd.Runcommand acCmdSaveRecord

[James Bowyer]

I haven't, but the code immediately preceeding it sends an email, and this always happens (it appears in the sent items), so I know it is always getting to the right point.

I did manage to replicate the problem, and there was no error message, so I have recoded the close button to check if the record has actually been saved, to prevent records being lost. However, this isn't an ideal situation!

I think you might be right in the record lock being the problem.

[TheSmileyCoder]

If you dont have record locks enabled, like myself, you can add a bit of code yourself to maintain changes.

Personally I don't like access's option to overwrite or discard changes. In the areas I work in, the only viable solution is to discard changes, look at what the other user has done, and then decide how to proceed.

So I add a field to my table, dt_LastModified. Whenever the record is saved, I just set the field to Now()

This is then the code in the beforeupdate of the form, to check whether any edits has been made by other users:

Private Sub Form_BeforeUpdate(Cancel As Integer)
 
    If Not Me.NewRecord Then
        'Check last modified
        If Me.tb_LastModified < DLookup("dt_LastModified", Me.RecordSource, "KEY_Auto=" & Me.KEY_Auto) Then
            MsgBox "This record has been modified by another user since you started editing"
            Cancel = True
            Me.Undo
            Exit Sub
        End If
    End If
    Me.tb_LastModified = Now()
End Sub

If the record has been modified, I then Cancel the update, and undo the changes.

[James Bowyer]

How do you make sure record locks are totally disabled?

I already have a record created/last modified date in the table, so that code would be nice and easy to apply.

[TheSmileyCoder]

In the forms view you can set:
Record Locks: No Locks

I think there are other ways of locking as well, but I haven't really looked into it.

[James Bowyer]

Finally got back into the office to have a look at this, the problem form already has no record locks.

So, back to being confused.

Here is the full code (Slightly abbreviated, as lots of it does the same thing)

Private Sub CreateFile_Click()
On Error GoTo CreateFile_Error
Dim errorstate As Integer
errorstate = 1
 
MsgBox "Please ensure all excel files are closed and Outlook is Open before continuing", vbCritical, "Warning!"
 
If IsNull(BranchNumber) Or BranchNumber = "" Then
BranchNumber.Value = "None"
Dim jNoPrefix As String
Dim jnocasewithtype As String
Dim jnocasewithnotype As String
Dim notype As String
Dim jnocase As String
Dim Numbergenerationwithtype As String
Dim numbergenerationwithnotype As String
Dim NumberGeneration As String
 
 
 
Dim numberrecordsforsite As Integer
numberrecordsforsite = Nz(DCount("*", "Job", "[CustomerName] = CustomerName.Value AND [JobSiteName] = jobsitename.value"), 0)
numberrecordsforsite = numberrecordsforsite + 1
 
 
notype = "None"
 
jnocasewithtype = Nz(DLookup("[Prefix]", "tblJobNumberPrefix", "[Customer] = CustomerName.Value AND [Type] = JobType.Value"), "")
jnocasewithnotype = Nz(DLookup("[Prefix]", "tblJobNumberPrefix", "[Customer] = CustomerName.Value AND [Type] = '" & notype & "'"), "")
 
jnocase = jnocasewithtype & jnocasewithnotype
 
Numbergenerationwithtype = Nz(DLookup("[Numbergeneration]", "tblJobNumberPrefix", "[Customer] = CustomerName.Value AND [Type] = JobType.Value"), "")
numbergenerationwithnotype = Nz(DLookup("[NumberGeneration]", "tblJobNumberPrefix", "[Customer] = CustomerName.Value AND [Type] = '" & notype & "'"), "")
 
NumberGeneration = Numbergenerationwithtype & numbergenerationwithnotype
 
 
Select Case NumberGeneration
Case Is = "Branch Number"
JobNumber.Value = jnocase & [BranchNumber] & "-" & numberrecordsforsite
Case Is = "AutoNumber"
JobNumber.Value = jnocase & [JobID]
Case Else
Dim jnocaseelse As String
Dim notinlist As String
notinlist = "Not In List"
jnocaseelse = Nz(DLookup("[Prefix]", "tblJobNumberPrefix", "[Customer] = '" & notinlist & "'"), "")
JobNumber.Value = jnocaseelse & [JobID]
End Select
End If
 
errorstate = errorstate + 1
 
Dim JNR As String
Dim rsc As DAO.Recordset
Dim jncheck As Long
Dim datenow As Date
datenow = Date
datenow = datenow - 365
Dim jncheckarchived As Long
Dim sitealreadycreatedmsg1 As String
Dim sitealreadycreatedmsg2 As String
 
Set rsc = Me.RecordsetClone
JNR = Me.JobSiteName.Value
jncheck = DCount("*", "job", "[Jobsitename]=jobsitename.value AND [CustomerName] = CustomerName.Value AND [Job File Creation Date]>#" & datenow & "#")
jncheckarchived = DCount("*", "job", "[Jobsitename]=jobsitename.value AND [CustomerName] = CustomerName.Value AND [Job File Creation Date]>#" & datenow & "# AND [Archived]=-1")
If jncheck > 0 And jncheckarchived = 0 Then
sitealreadycreatedmsg = MsgBox("Site " & JNR & " Has been created on the system within the last year, are you sure you wish to continue?", vbYesNo, "Duplicate Value")
Select Case sitealreadycreatedmsg1
Case vbNo
Exit Sub
Case Else
End Select
 
Else
 
End If
If jncheckarchived > 0 Then
sitealreadycreatedmsg2 = MsgBox("Site " & JNR & " Has been created on the system within the last year, but is currently archived" & vbCrLf & "Are you sure you wish to continue?", vbYesNo, "Duplicate Value")
Select Case sitealreadycreatedmsg2
Case vbNo
Exit Sub
Case Else
End Select
Else
End If
 
errorstate = errorstate + 1
 
Set rsc = Nothing
 
 
If IsNull(CustomerName) Or CustomerName = "" Then
MsgBox "Please enter Client Name", vbOKOnly, "Required Data"
CustomerName.SetFocus
Exit Sub
End If
 
'Line repeated lots of times for different fields
 
errorstate = errorstate + 1
 
 
Dim mdrive As String
mdrive = [DriveDesignation]
ChDrive mdrive
Dim mdir As String
mdir = [FolderPath]
ChDir mdrive & mdir
 
 
Line1:
Dim cdir As String
Dim cusdir As String
cdir = [CustomerName]
cusdir = Dir([CustomerName], vbDirectory)
If cusdir = cdir Then GoTo Line2 Else
 
MkDir cdir
Line2:
ChDir cdir
jobdir = Dir([JobSiteName] & " - " & [JobNumber], vbDirectory)
If jobdir = [JobSiteName] & " - " & [JobNumber] Then
MsgBox "File Already Exists"
GoTo Line100
Else
RunCommand acCmdSaveRecord
 
errorstate = errorstate + 1
 
MkDir [JobSiteName] & " - " & [JobNumber]
ChDir [JobSiteName] & " - " & [JobNumber]
MkDir "a. Site Details"
MkDir "i. Correspondence"
MkDir "j. Photographs"
MkDir "p. O&M Manual"
ChDir "p. O&M Manual"
MkDir "Completion Certificates"
ChDir mdrive & mdir & "\" & [CustomerName] & "\" & [JobSiteName] & " - " & [JobNumber]
Dim FSO As New Scripting.FileSystemObject
Set FSO = New Scripting.FileSystemObject
 
errorstate = errorstate + 1
 
Dim specdrive As String
specdrive = Nz(DLookup("[SpecificFolder]", "tbljobtype", "[JobType]='" & Me.JobType.Value & "'"), "")
Dim sdir As String
Dim sdrive As String
sdir = [StandardsFolderPath]
sdrive = [StandardsDriveDesignation]
 
 
Select Case specdrive
Case Is = -1
FSO.CopyFolder sdrive & sdir & "\b. Tender or Quote\" & Me.JobType, "b. Tender or Quote", True
 
FSO.CopyFolder sdrive & sdir & "\d. Drawings\" & Me.JobType, "d. Drawings", True
FSO.CopyFolder sdrive & sdir & "\e. Programmes\" & Me.JobType, "e. Programmes", True
FSO.CopyFolder sdrive & sdir & "\h. Load Lists\" & Me.JobType, "h. Load Lists", True
FSO.CopyFolder sdrive & sdir & "\f. Health & Safety\" & [FolderName] & "\" & Me.JobType, "f. Health & Safety", True
FSO.CopyFolder sdrive & sdir & "\g. Orders\" & Me.JobType, "g. Orders", True
FSO.CopyFolder sdrive & sdir & "\l. Signoffs\" & Me.JobType, "l. Signoffs", True
FSO.CopyFolder sdrive & sdir & "\m. Variations\" & Me.JobType, "m. Variations", True
FSO.CopyFolder sdrive & sdir & "\k. Minutes\" & Me.JobType, "k. Minutes", True
FSO.CopyFolder sdrive & sdir & "\n. Finance\" & Me.JobType, "n. Finance", True
FSO.CopyFolder sdrive & sdir & "\o. Snagging\" & Me.JobType, "o. Snagging", True
 
Case Else
FSO.CopyFolder sdrive & sdir & "\b. Tender or Quote\Standard", "b. Tender or Quote", True
 
FSO.CopyFolder sdrive & sdir & "\d. Drawings\Standard", "d. Drawings", True
FSO.CopyFolder sdrive & sdir & "\e. Programmes\Standard", "e. Programmes", True
FSO.CopyFolder sdrive & sdir & "\h. Load Lists\Standard", "h. Load Lists", True
FSO.CopyFolder sdrive & sdir & "\f. Health & Safety\" & [FolderName] & "\Standard", "f. Health & Safety", True
FSO.CopyFolder sdrive & sdir & "\g. Orders\Standard", "g. Orders", True
FSO.CopyFolder sdrive & sdir & "\l. Signoffs\Standard", "l. Signoffs", True
FSO.CopyFolder sdrive & sdir & "\m. Variations\Standard", "m. Variations", True
FSO.CopyFolder sdrive & sdir & "\k. Minutes\Standard", "k. Minutes", True
FSO.CopyFolder sdrive & sdir & "\n. Finance\Standard", "n. Finance", True
FSO.CopyFolder sdrive & sdir & "\o. Snagging\Standard", "o. Snagging", True
End Select
 
ChDir "a. Site Details"
FSO.CopyFolder sdrive & sdir & "\a. Site Details\Survey", "Survey", True
MkDir "Site Details Old"
 
 
ChDir sdrive & sdir & "\c. Standard Specifications"
ssdir = Dir(cdir, vbDirectory)
ChDir mdrive & mdir & "\" & [CustomerName] & "\" & [JobSiteName] & " - " & [JobNumber]
If ssdir = [CustomerName] Then
FSO.CopyFolder sdrive & sdir & "\c. Standard Specifications\" & [CustomerName], "c. Standard Specifications", True
GoTo Line3
 
Else
MkDir "c. Standard Specifications"
Line3:
 
errorstate = errorstate + 1
 
Dim JSFCreator As String
JSFCreator = [CurUser]
JSFCreatedBy.Value = JSFCreator
 
Dim ExtPMLookupM As String
Dim ExtPMLookupE As String
Dim ExtPMLookupP As String
Dim ExtPMLookupF As String
 
ExtPMLookupM = Nz(DLookup("[ExternalPMMobile]", "tblexternalPM", "[ExternalPMName]='" & Me.ExternalPM & "'"), "")
ExtPMLookupE = Nz(DLookup("[ExternalPMEmail]", "tblexternalPM", "[ExternalPMName]='" & Me.ExternalPM & "'"), "")
ExtPMLookupP = Nz(DLookup("[ExternalPMPhone]", "tblexternalPM", "[ExternalPMName]='" & Me.ExternalPM & "'"), "")
ExtPMLookupF = Nz(DLookup("[ExternalPMFax]", "tblexternalPM", "[ExternalPMName]='" & Me.ExternalPM & "'"), "")
 
errorstate = errorstate + 1
 
Line4:
 
Dim ExcelSheet As Object
Set ExcelSheet = CreateObject("Excel.Sheet")
ExcelSheet.Application.Visible = True
ExcelSheet.Application.Cells(1, 1).Value = "Customer"
ExcelSheet.Application.Cells(1, 2).Value = [CustomerName]
'Again repeated lots of times for various different values
 
ExcelSheet.Application.ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
 
 
ExcelSheet.SaveAs mdrive & mdir & "\" & [CustomerName] & "\" & [JobSiteName] & " - " & [JobNumber] & "\a. Site Details\SiteDetails.xlsx"
ExcelSheet.Application.Quit
 
Set ExcelSheet = Nothing
 
errorstate = errorstate + 1
 
Dim cnpermvalue As String
cnpermvalue = [CustomerName]
CNPermanent.Value = cnpermvalue
 
'repeated more times for more hidden values
 
Dim RevisionNo As Integer
RevisionNo = 0
RevisionNumber.Value = RevisionNo
 
 
RunCommand acCmdSaveRecord
 
errorstate = errorstate + 1
 
Line29:
 
Dim sSubject As String
Dim Mail_Object As Object
Dim Mail_Single As Variant
Dim Mail_to As String
Dim Mail_to_CC As String
 
Mail_to = DLookup("[email]", "tblusers", "[Username]='" & Me.IFSJobNoSetup & "'")
Mail_to_CC = DLookup("[email]", "tblusers", "[Username]='" & Me.IFSJJobNoSetupCC & "'")
 
 
Dim currentusername As String
 
 
 
currentusername = DLookup("[StaffName]", "tblusers", "[Username]='" & Me.CurUser & "'")
 
 
Stext1 = "Please set up the following job" & vbCrLf & _
"Job Number - " & [JobNumber] & vbCrLf & _
"Customer - " & [CustomerName] & vbCrLf & _
"Site Name - " & [JobSiteName] & vbCrLf & _
"Address:" & vbCrLf & _
[SiteAddressLine1] & vbCrLf & _
[SiteAddressLine2] & vbCrLf & _
[SiteAddressLine3] & vbCrLf & _
[SiteAddressLine4] & vbCrLf & _
[SitePostcode] & vbCrLf & _
"Regards" & vbCrLf & vbCrLf & _
currentusername
 
 
sSubject = "Job Setup Request"
 
 
 
Set Mail_Object = CreateObject("Outlook.Application")
 
Set Mail_Single = Mail_Object.CreateItem(0)
With Mail_Single
.Subject = sSubject
.To = Mail_to
.cc = Mail_to_CC
.Body = Stext1
.Send
End With
 
Set Mail_Object = Nothing
Set Mail_Single = Nothing
 
 
MsgBox "Project File Succesfully Created", vbInformation, "SCM"
 
 
End If
Line100:
End If
 
Exit Sub
 
CreateFile_Error:
Select Case errorstate
Case Is = 1
MsgBox "Job Number Not able to be created, please contact Administrator", vbCritical, "SCM"
Case Is = 2
MsgBox "Job Number May Already Exist On This System, Please contact Administrator", vbCritical, "SCM"
Case Is = 3
MsgBox "Please ensure All Fields Marked With an Asterix (*) Are Filled In", vbCritical, "SCM"
Case Is = 4
MsgBox "File May Already Exist, Please contact Administrator", vbCritical, "SCM"
Case Is = 5
MsgBox "Unable To Create Project File, Please contact Administrator", vbCritical, "SCM"
Case Is = 6
MsgBox "Unable To Copy Project Files from Standards Folder, Please Contact Administrator", vbCritical, "SCM"
Case Is = 7
MsgBox "Unable To Locate External Project Manager Details, Please contact Administrator", vbCritical, "SCM"
Case Is = 8
Dim excelopen As String
excelopen = MsgBox("Is there a version of SiteDetails.xlsx Currently Open?", vbYesNo, "SCM")
Select Case excelopen
Case vbYes
MsgBox "Please Close Sitedetails.xlsx NOW!", vbCritical, "SCM"
GoTo Line4
Case Else
MsgBox "Unable To Create Sitedetails.xlsx, Please Contact Administrator", vbCritical, "SCM"
End Select
Case Is = 9
MsgBox "Unable to create Permananent Values, Please Contact Administrator", vbCritical, "SCM"
Case Else
Dim emailproblem As String
emailproblem = MsgBox("Is Outlook open and Logged in?", vbYesNo, "SCM")
Select Case emailproblem
Case vbNo
MsgBox "Please Open Outlook Before Continuing", vbCritical, "SCM"
GoTo Line29
Case Else
MsgBox "Not Able to send email, Please contact administrator", vbCritical, "SCM"
End Select
End Select