Invalid Argument Error: MSAccess and SQL - ms-access

I am trying to access certain lines from my SQL database from MSAccess and I keep getting an Invalid Argument Error on this line:
Set rs = CurrentDb.OpenRecordset("SELECT TimeID " & _
"FROM tblLunchTime " & _
"WHERE ProductionID = prodSelect AND EndTime is NULL AND StartTime < dateAdd('h', 3, NOW())", [dbSeeChanges])
Is something not right in this?
Private Sub cmdClockEnd_Click()
'Check if a group has been selected.
If frmChoice.value = 0 Then
MsgBox "Please select a production line."
End
End If
'Setup form for user input.
lblEnd.Visible = True
'Save end of lunch value.
lblEnd.Caption = Format(Now, "MMM/DD/YY hh:mm:ss AMPM")
'Declare database variables.
Dim dbName As DAO.Database
Dim strValuesQuery As String
Dim rs As DAO.Recordset
Dim prodSelect As String
Dim sSQL As String
Dim timeValue As String
Set dbName = CurrentDb
'Get values of Production Line.
If frmChoice.value = 1 Then
prodSelect = "L2"
ElseIf frmChoice.value = 2 Then
prodSelect = "L3"
End If
'Get the last TimeID with the following parameters.
sSQL = "SELECT TimeID " & _
"FROM tblLunchTime " & _
"WHERE ProductionID = prodSelect AND EndTime is NULL AND StartTime < #" & DateAdd("h", 3, Now()) & "#"
Set rs = dbName.OpenRecordset(sSQL, dbSeeChanges)
strValuesQuery = _
"UPDATE tblLunchTime " & _
"SET EndTime = '" & Now & "'" & _
"WHERE TimeID = " & rs![TimeID] & " "
'Turn warning messages off.
DoCmd.SetWarnings False
'Execute Query.
DoCmd.RunSQL strValuesQuery
'Turn warning messages back on.
DoCmd.SetWarnings True
End Sub

You need to put prodSelect outside the quotes:
"WHERE ProductionID = " & prodSelect & " AND ...
It is nearly always best to say:
sSQL="SELECT TimeID " & _
"FROM tblLunchTime " & _
"WHERE ProductionID = " & prodSelect & _
" AND EndTime is NULL AND StartTime < dateAdd('h', 3, NOW())"
''Debug.print sSQL
Set rs = CurrentDb.OpenRecordset(sSQL)
You can see the advantage in the use of Debug.Print.
AHA prodSelect is text! You need quotes!
sSQL="SELECT TimeID " & _
"FROM tblLunchTime " & _
"WHERE ProductionID = '" & prodSelect & _
"' AND EndTime is NULL AND StartTime < dateAdd('h', 3, NOW())"

There appears to be confusion about tblLunchTime ... whether it is a native Jet/ACE table or a link to a table in another database. Please show us the output from this command:
Debug.Print CurrentDb.TableDefs("tblLunchTime").Connect
You can paste that line into the Immediate Window and press the enter key to display the response. (You can open the Immediate Window with CTRL+g keystroke combination.)
Just in case the response starts with "ODBC", suggest you try this line in your code:
Set rs = CurrentDb.OpenRecordset(sSQL, dbOpenDynaset, dbSeeChanges)
Update: Now that you're past that hurdle, suggest you change your approach with the UPDATE statement. Don't turn off warnings; try something like this instead:
'Execute Query. '
CurrentDb.Execute strValuesQuery, dbFailOnError
And add an error handler to deal with any errors captured by dbFailOnError.

I think I would do the date criterion concatenation client-side, too, since it's one more thing that could go wrong:
"...StartTime < #" & DateAdd("h", 3, Now()) & "#"
I don't know that SQL Server doesn't have DateAdd() and Now() function nor that they don't behave exactly the same as in Access, but I wouldn't take the chance -- I'd do this calculation on the client instead of handing it off to the server.

Related

Error: cannot update, database or object read only while edit record set in another function

I'm passing record set from one function (i.e.chkMismatchData) to another (CheckMismatches) and if the record is not found I update some values of passed recordset.
Even I declare variable of recordset in module level still finding the error.
My code is :
Set rec1 = CurrentDb.OpenRecordset("select * from CBWCFAVENDORMATCHOFFMASTER where [vendor]='" & rec![Vendor] & "'")
While Not rec.EOF
Set rec3 = CurrentDb.OpenRecordset("select ID,[HCI_NO],CLEARLOC,SUM([AMOUNT])AS AMOUNT1 from CBWCFAMISUPLOAD WHERE [vendor]='" & rec![Vendor] & "' and nz([match],'')='' and nz([HCI_NO],'')<>'' GROUP BY HCI_NO,CLEARLOC,ID ")
While Not rec3.EOF
Set rec2 = CurrentDb.OpenRecordset("select ID,DEPSLIPNO,CLEARLOC from CBWCFAPENDINGPAYMENTDATA WHERE [DEPSLIPNO]='" & rec3![HCI_NO] & "' GROUP BY DEPSLIPNO,CLEARLOC,ID HAVING CLEARLOC='" & rec3![CLEARLOC] & "' AND SUM([amt])=" & rec3![AMOUNT1])
If rec2.EOF = False Then
If rec2.RecordCount = 1 Then
CurrentDb.Execute ("UPDATE CBWCFAMISUPLOAD SET [MATCH]='Y' ,[CASHIN_ID]='" & rec2![ID] & "' WHERE [HCI_NO]='" & rec3![HCI_NO] & "' ")
CurrentDb.Execute ("UPDATE CBWCFAPENDINGPAYMENTDATA SET [MATCH]='Y' ,[MIS_ID]='" & rec3![ID] & "' WHERE [DEPSLIPNO]='" & rec3![HCI_NO] & "'")
ElseIf rec1.RecordCount > 1 Then
Call UpdateRec(rec3, 0, "Duplicate Match", 0)
End If
Else
strSlipType = "HCI_NO"
Call UpdateRec(rec3, 0, CheckMismatches(rec3), 0) 'here im passing
End If
rec3.MoveNext
Wend
Wend
Private Function CheckMismatches(rec As DAO.Recordset) As String
Dim RecCheck As DAO.Recordset
Dim strDepSlipNo As String, strID As String
If strSlipType = "HCI_NO" Then
'--Clearing Loc Not Matching
Set RecCheck = CurrentDb.OpenRecordset("select ID,DEPSLIPNO,CLEARLOC from CBWCFAPENDINGPAYMENTDATA WHERE [DEPSLIPNO]='" & rec![HCI_NO] & "' GROUP BY DEPSLIPNO,CLEARLOC,ID HAVING CLEARLOC<>'" & rec![CLEARLOC] & "' AND SUM([amt])=" & rec![AMOUNT1])
If RecCheck.EOF = True Then
rec.Edit 'here i'm geting error
rec![match]="Y" 'added line
rec!.update 'added line
CheckMismatches = "Clearing Loc Not Matching"
RecCheck.Close
Exit Function
End If
RecCheck.Close
end function
Your rec3 has a GROUP BY clause.
A recordset that is aggregated is by definition read-only. So you have to edit the table separately from this recordset.
Why do you have rec.Edit in the function when you don't edit any fields of it?

VBA issues when trying to run a SQL query between 2 dates

To give a brief summary of the objective of this macro, I am trying to get the sum of cash between certain dates based on a set of parameters. I keep getting an error in VBA when I try to run a SQL query with a date. I'm not sure what the issue is but I think it's related to how I have the date formatted. I have tried running it multiple ways but keep getting a syntax error, whether it be related to 'a', '#', or 'table'.
Here's the query I'm using. Any help would be greatly appreciated.
Sub GetCashBalance()
Dim cn As New ADODB.Connection
Dim rs As ADODB.Recordset
Dim SQL As String
Dim StartDate As String
Dim EndDate As String
StartDate = InputBox("Enter Start Date in mm/dd/yy format.")
EndDate = InputBox("Enter End Date in mm/dd/yy format.")
SQL = "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=True;Initial Catalog=master;Data Source=SERVER\ODS"
Set cn = New ADODB.Connection
Set rs = New ADODB.Recordset
cn.Open SQL
Set rs = cn.Execute("SELECT SUM(a.CASH)" & _
"FROM CUSTOMER_DATA.dbo.TRANSACTION_HISTORY a" & _
"LEFT JOIN CUSTOMER_DATA.dbo.DAILY_TRANSACTION b" & _
"ON a.T01_KEY = b.T01_KEY" & _
"WHERE PROC_DATE BETWEEN #StartDate# AND #EndDate#" & _
"AND a.CODE NOT IN ('22','23','M','2-L','36-R')" & _
"AND isnull(a.DESCRIPTION, '') NOT IN ('01','02','03','0DO1','0NF2');")
If Not rs.EOF Then
Sheets(7).Range("A40").CopyFromRecordset rs
rs.Close
Else
MsgBox "Error", vbCritical
End If
cn.Close
End Sub
Set rs = cn.Execute("SELECT SUM(a.CASH)" & _
"FROM CUSTOMER_DATA.dbo.TRANSACTION_HISTORY a" & _
"LEFT JOIN CUSTOMER_DATA.dbo.DAILY_TRANSACTION b" & _
"ON a.T01_KEY = b.T01_KEY" & _
"WHERE PROC_DATE BETWEEN '" & StartDate & "' AND '" & EndDate & _
"# AND a.CODE NOT IN ('22','23','M','2-L','36-R')" & _
"AND isnull(a.DESCRIPTION, '') NOT IN ('01','02','03','0DO1','0NF2');")
Take a look at below piece, that should be changed
BETWEEN '" & StartDate & "' AND '" & EndDate & _
"' AND ....
I think it is better to use ADODB.Command and Parameters instead of doing a concatenation in the sql query.

Change Navigation pane group in access through vba

I have a module of VBA code in access that creates 4 new tables and adds them to the database. I would like to add in a part at the end where they are organized in the navigation pane through custom groups so that way they are all organized. Would this be possible through vba?
EDIT:
I don't want the tables to be in the unassigned objects group. I want to change the name of that group through VBA.
EDIT: Added more code to add other object types to the custom Nav group.
The following code will assign tables to your custom Navigation Group.
WARNING!! There is a 'refresh' issue of table 'MSysNavPaneObjectIDs' that I am still trying to resolve. If you create a new table and then try to add to your group - sometimes it works on the first try, other times it fails but will work after a delay (sometimes up to five or ten minutes!)
At this moment, I got around the issue (when it fails) by reading info from table 'MSysObjects', then adding a new record to 'MSysNavPaneObjectIDs'.
The code below simply creates five small tables and adds to Nav Group 'Clients'
Modify the code to use your Group name / table names.
Option Compare Database
Option Explicit
Sub Test_My_Code()
Dim dbs As DAO.Database
Dim strResult As String
Dim i As Integer
Dim strSQL As String
Dim strTableName As String
Set dbs = CurrentDb
For i = 1 To 5
strTableName = "Query" & i
'>>> CHANGE FOLLOWING LINE TO YOUR CUSTOM NAME
' Pass the Nav Group, Object Name, Object Type
strResult = SetNavGroup("Clients", strTableName, "Query")
Debug.Print strResult
Next i
For i = 1 To 5
strTableName = "0000" & i
strSQL = "CREATE TABLE " & strTableName & " (PayEmpID INT, PayDate Date);"
dbs.Execute strSQL
'>>> CHANGE FOLLOWING LINE TO YOUR CUSTOM NAME
' Pass the Nav Group, Object Name, Object Type
strResult = SetNavGroup("Clients", strTableName, "Table")
Debug.Print strResult
Next i
dbs.Close
Set dbs = Nothing
End Sub
Function SetNavGroup(strGroup As String, strTable As String, strType As String) As String
Dim strSQL As String
Dim dbs As DAO.Database
Dim rs As DAO.recordSet
Dim lCatID As Long
Dim lGrpID As Long
Dim lObjID As Long
Dim lType As Long
SetNavGroup = "Failed"
Set dbs = CurrentDb
' Ignore the following code unless you want to manage 'Categories'
' Table MSysNavPaneGroupCategories has fields: Filter, Flags, Id (AutoNumber), Name, Position, SelectedObjectID, Type
' strSQL = "SELECT Id, Name, Position, Type " & _
' "FROM MSysNavPaneGroupCategories " & _
' "WHERE (((MSysNavPaneGroupCategories.Name)='" & strGroup & "'));"
' Set rs = dbs.OpenRecordset(strSQL)
' If rs.EOF Then
' MsgBox "No group named '" & strGroup & "' found. Will quit now.", vbOKOnly, "No Group Found"
' rs.Close
' Set rs = Nothing
' dbs.Close
' Set dbs = Nothing
' Exit Function
' End If
' lCatID = rs!ID
' rs.Close
' When you create a new table, it's name is added to table 'MSysNavPaneObjectIDs'
' Types
' Type TypeDesc
'-32768 Form
'-32766 Macro
'-32764 Reports
'-32761 Module
'-32758 Users
'-32757 Database Document
'-32756 Data Access Pages
'1 Table - Local Access Tables
'2 Access object - Database
'3 Access object - Containers
'4 Table - Linked ODBC Tables
'5 Queries
'6 Table - Linked Access Tables
'8 SubDataSheets
If LCase(strType) = "table" Then
lType = 1
ElseIf LCase(strType) = "query" Then
lType = 5
ElseIf LCase(strType) = "form" Then
lType = -32768
ElseIf LCase(strType) = "report" Then
lType = -32764
ElseIf LCase(strType) = "module" Then
lType = -32761
ElseIf LCase(strType) = "macro" Then
lType = -32766
Else
MsgBox "Add your own code to handle the object type of '" & strType & "'", vbOKOnly, "Add Code"
dbs.Close
Set dbs = Nothing
Exit Function
End If
' Table MSysNavPaneGroups has fields: Flags, GroupCategoryID, Id, Name, Object, Type, Group, ObjectID, Position
Debug.Print "---------------------------------------"
Debug.Print "Add '" & strType & "' " & strTable & "' to Group '" & strGroup & "'"
strSQL = "SELECT GroupCategoryID, Id, Name " & _
"FROM MSysNavPaneGroups " & _
"WHERE (((MSysNavPaneGroups.Name)='" & strGroup & "') AND ((MSysNavPaneGroups.Name) Not Like 'Unassigned*'));"
Set rs = dbs.OpenRecordset(strSQL)
If rs.EOF Then
MsgBox "No group named '" & strGroup & "' found. Will quit now.", vbOKOnly, "No Group Found"
rs.Close
Set rs = Nothing
dbs.Close
Set dbs = Nothing
Exit Function
End If
Debug.Print rs!GroupCategoryID & vbTab & rs!ID & vbTab & rs!Name
lGrpID = rs!ID
rs.Close
Try_Again:
' Filter By Type
strSQL = "SELECT Id, Name, Type " & _
"FROM MSysNavPaneObjectIDs " & _
"WHERE (((MSysNavPaneObjectIDs.Name)='" & strTable & "') AND ((MSysNavPaneObjectIDs.Type)=" & lType & "));"
Set rs = dbs.OpenRecordset(strSQL)
If rs.EOF Then
' Seems to be a refresh issue / delay! I have found no way to force a refresh.
' This table gets rebuilt at the whim of Access, so let's try a different approach....
' Lets add the record vis code.
Debug.Print "Table not found in MSysNavPaneObjectIDs, try MSysObjects."
strSQL = "SELECT * " & _
"FROM MSysObjects " & _
"WHERE (((MSysObjects.Name)='" & strTable & "') AND ((MSysObjects.Type)=" & lType & "));"
Set rs = dbs.OpenRecordset(strSQL)
If rs.EOF Then
MsgBox "This is crazy! Table '" & strTable & "' not found in MSysObjects.", vbOKOnly, "No Table Found"
rs.Close
Set rs = Nothing
dbs.Close
Set dbs = Nothing
Exit Function
Else
Debug.Print "Table not found in MSysNavPaneObjectIDs, but was found in MSysObjects. Lets try to add via code."
strSQL = "INSERT INTO MSysNavPaneObjectIDs ( ID, Name, Type ) VALUES ( " & rs!ID & ", '" & strTable & "', " & lType & ")"
dbs.Execute strSQL
GoTo Try_Again
End If
End If
Debug.Print rs!ID & vbTab & rs!Name & vbTab & rs!type
lObjID = rs!ID
rs.Close
' Add the table to the Custom group
strSQL = "INSERT INTO MSysNavPaneGroupToObjects ( GroupID, ObjectID, Name ) VALUES ( " & lGrpID & ", " & lObjID & ", '" & strTable & "' )"
dbs.Execute strSQL
dbs.Close
Set dbs = Nothing
SetNavGroup = "Passed"
End Function
Thanks a lot for your code,
I had to modify it a little on my specific case due to the issue on the refresh of the table.
In fact I am recreating a table (deleting the old one before). As the MSysNavPaneObjectIDs does not refresh, the old ID is kept inside.
e.g. let's use a table tmpFoo that I want to put in a group TEMP.
tmpFoo is already in group TEMP. TEMP has ID 1 and tmpFoo has ID 1000
Then I delete tmpFoo, and immediately recreate tmpFoo.
tmpFoo is now in 'Unassigned Objects'.
In MSysObjects, ID of tmpFoo is now 1100, but in MSysNavPaneObjectIDs the table is not refreshed and the ID of tmpFoo here is still 1000.
In this case, in the table MSysNavPaneGroupToObjects a link between TEMP(1) and tmpFoo(1000) is created => Nothing happen as ID 1000 does not exists anymore in MSysObjects.
So, the modified code below get in all cases ID from MSysObjects, then check if the ID exists in MSysNavPaneObjectIDs.
If not, add the line, then use the same ID to add it to MSysNavPaneGroupToObjects.
In this way seems I do not have any refresh issue (adding Application.RefreshDatabaseWindow in the upper function).
Thanks again Wayne,
Function SetNavGroup(strGroup As String, strTable As String, strType As String) As String
Dim strSQL As String
Dim dbs As DAO.Database
Dim rs As DAO.Recordset
Dim lCatID As Long
Dim lGrpID As Long
Dim lObjID As Long
Dim lType As Long
SetNavGroup = "Failed"
Set dbs = CurrentDb
' When you create a new table, it's name is added to table 'MSysNavPaneObjectIDs'
' Types
' Type TypeDesc
'-32768 Form
'-32766 Macro
'-32764 Reports
'-32761 Module
'-32758 Users
'-32757 Database Document
'-32756 Data Access Pages
'1 Table - Local Access Tables
'2 Access object - Database
'3 Access object - Containers
'4 Table - Linked ODBC Tables
'5 Queries
'6 Table - Linked Access Tables
'8 SubDataSheets
If LCase(strType) = "table" Then
lType = 1
ElseIf LCase(strType) = "query" Then
lType = 5
ElseIf LCase(strType) = "form" Then
lType = -32768
ElseIf LCase(strType) = "report" Then
lType = -32764
ElseIf LCase(strType) = "module" Then
lType = -32761
ElseIf LCase(strType) = "macro" Then
lType = -32766
Else
MsgBox "Add your own code to handle the object type of '" & strType & "'", vbOKOnly, "Add Code"
dbs.Close
Set dbs = Nothing
Exit Function
End If
' Table MSysNavPaneGroups has fields: Flags, GroupCategoryID, Id, Name, Object, Type, Group, ObjectID, Position
Debug.Print "---------------------------------------"
Debug.Print "Add '" & strType & "' '" & strTable & "' to Group '" & strGroup & "'"
strSQL = "SELECT GroupCategoryID, Id, Name " & _
"FROM MSysNavPaneGroups " & _
"WHERE (((MSysNavPaneGroups.Name)='" & strGroup & "') AND ((MSysNavPaneGroups.Name) Not Like 'Unassigned*'));"
Set rs = dbs.OpenRecordset(strSQL)
If rs.EOF Then
MsgBox "No group named '" & strGroup & "' found. Will quit now.", vbOKOnly, "No Group Found"
rs.Close
Set rs = Nothing
dbs.Close
Set dbs = Nothing
Exit Function
End If
Debug.Print rs!GroupCategoryID & vbTab & rs!ID & vbTab & rs!Name
lGrpID = rs!ID
rs.Close
' Get Table ID From MSysObjects
strSQL = "SELECT * " & _
"FROM MSysObjects " & _
"WHERE (((MSysObjects.Name)='" & strTable & "') AND ((MSysObjects.Type)=" & lType & "));"
Set rs = dbs.OpenRecordset(strSQL)
If rs.EOF Then
MsgBox "This is crazy! Table '" & strTable & "' not found in MSysObjects.", vbOKOnly, "No Table Found"
rs.Close
Set rs = Nothing
dbs.Close
Set dbs = Nothing
Exit Function
End If
lObjID = rs!ID
Debug.Print "Table found in MSysObjects " & lObjID & " . Lets compare to MSysNavPaneObjectIDs."
' Filter By Type
strSQL = "SELECT Id, Name, Type " & _
"FROM MSysNavPaneObjectIDs " & _
"WHERE (((MSysNavPaneObjectIDs.ID)=" & lObjID & ") AND ((MSysNavPaneObjectIDs.Type)=" & lType & "));"
Set rs = dbs.OpenRecordset(strSQL)
If rs.EOF Then
' Seems to be a refresh issue / delay! I have found no way to force a refresh.
' This table gets rebuilt at the whim of Access, so let's try a different approach....
' Lets add the record via this code.
Debug.Print "Table not found in MSysNavPaneObjectIDs, add it from MSysObjects."
strSQL = "INSERT INTO MSysNavPaneObjectIDs ( ID, Name, Type ) VALUES ( " & lObjID & ", '" & strTable & "', " & lType & ")"
dbs.Execute strSQL
End If
Debug.Print lObjID & vbTab & strTable & vbTab & lType
rs.Close
' Add the table to the Custom group
strSQL = "INSERT INTO MSysNavPaneGroupToObjects ( GroupID, ObjectID, Name ) VALUES ( " & lGrpID & ", " & lObjID & ", '" & strTable & "' )"
dbs.Execute strSQL
dbs.Close
Set dbs = Nothing
SetNavGroup = "Passed"
End Function
Here's my code it's not as user-error friendly as the main code, but it should be a bit quicker to make a mass move.
Public Sub Test_My_Code()
Dim i As Long, db As Database, qd As QueryDef
Set db = CurrentDb
For i = 1 To 10
DoCmd.RunSQL "CREATE TABLE [~~Table:" & Format(i, "00000") & "](PayEmpID INT, PayDate Date)"
Set qd = db.CreateQueryDef("~~Query:" & Format(i, "00000"), "SELECT * FROM [~~Table:" & Format(i, "00000") & "];")
Next i
MsgBox IIf(SetNavGroup(CategorySelection:="Like '*'", GroupSelection:="='TestGroup'", ObjectSelection:="Like '~~Table:#####'"), "New Tables Moved", "Table Move Failed")
MsgBox IIf(SetNavGroup(CategorySelection:="Like '*'", GroupSelection:="='TestGroup'", ObjectSelection:="Like '~~Query:#####'"), "New Queries Moved", "Query Move Failed")
End Sub
Private Sub SetNavGroup_tst(): MsgBox IIf(SetNavGroup(GroupSelection:="='Verified Formularies'", ObjectSelection:="Like '*Verified*'"), "Tables Moved OK", "Failed"): End Sub
'Parameters:
' CategorySelection -- used to filter which custom(type=4) categories to modify
' ex select the 'Custom' Navigation Category (default): "='Custom'"
' GroupSelection -- used to filter which custom(type=-1) groups to add the objects to
' ex select a specific group: "='Verified Formularies'"
' ex select set of specific groups: "In ('Group Name1','Group Name2')"
' ObjectSelection -- used to filter which database objects to move under the groups
' ex select a range of tables: "Like '*Verified*'"
' UnassignedOnly -- used to only look at objects from the Unassigned group
' True - set only unassigned objects
' False - add objects even if they're already in a group
Public Function SetNavGroup(GroupSelection As String, ObjectSelection As String, Optional CategorySelection As String = "='Custom'", Optional UnassignedOnly As Boolean = True) As Boolean
SetNavGroup = False
If Trim(GroupSelection) = "" Then Exit Function
If Trim(ObjectSelection) = "" Then Exit Function
DoCmd.SetWarnings False
On Error GoTo SilentlyContinue
'TempTable Name
Dim ToMove As String
Randomize: ToMove = "~~ToMove_TMP" & (Fix(100000 * Rnd) Mod 100)
'Build temporary table of what to move
Dim SQL As String: SQL = _
"SELECT [Ghost:ToMove].* INTO [" & ToMove & "] " & _
"FROM ( " & _
"SELECT MSysNavPaneGroups.GroupCategoryID, MSysNavPaneGroupCategories.Name AS CategoryName, MSysNavPaneGroups.Id AS GroupID, MSysNavPaneGroups.Name AS GroupName, MSysObjects.Id AS ObjectID, MSysObjects.Name AS ObjectName, MSysObjects.Type AS ObjectType, '' AS ObjectAlias " & _
"FROM MSysObjects, MSysNavPaneGroupCategories INNER JOIN MSysNavPaneGroups ON MSysNavPaneGroupCategories.Id = MSysNavPaneGroups.GroupCategoryID " & _
"WHERE (((MSysNavPaneGroupCategories.Name) " & CategorySelection & ") AND ((MSysNavPaneGroups.Name) " & GroupSelection & ") AND MSysObjects.Name " & ObjectSelection & " AND ((MSysNavPaneGroupCategories.Type)=4) AND ((MSysNavPaneGroups.[Object Type Group])=-1)) " & _
"GROUP BY MSysNavPaneGroups.GroupCategoryID, MSysNavPaneGroupCategories.Name, MSysNavPaneGroups.Id, MSysNavPaneGroups.Name, MSysObjects.Id, MSysObjects.Name, MSysObjects.Type " & _
"ORDER BY Min(MSysNavPaneGroupCategories.Position), Min(MSysNavPaneGroups.Position)" & _
") AS [Ghost:ToMove] LEFT JOIN ( " & _
"SELECT MSysNavPaneGroups.GroupCategoryID, MSysNavPaneGroupToObjects.GroupID, MSysNavPaneGroupToObjects.ObjectID " & _
"FROM MSysNavPaneGroups INNER JOIN MSysNavPaneGroupToObjects ON MSysNavPaneGroups.Id = MSysNavPaneGroupToObjects.GroupID " & _
") AS [Ghost:AssignedObjects] ON ([Ghost:ToMove].ObjectID = [Ghost:AssignedObjects].ObjectID) AND ([Ghost:ToMove].GroupID = [Ghost:AssignedObjects].GroupID) AND ([Ghost:ToMove].GroupCategoryID = [Ghost:AssignedObjects].GroupCategoryID) " & _
"WHERE [Ghost:AssignedObjects].GroupCategoryID Is Null;"
If Not UnassignedOnly Then SQL = _
"SELECT MSysNavPaneGroups.GroupCategoryID, MSysNavPaneGroupCategories.Name AS CategoryName, MSysNavPaneGroups.Id AS GroupID, MSysNavPaneGroups.Name AS GroupName, MSysObjects.Id AS ObjectID, MSysObjects.Name AS ObjectName, MSysObjects.Type AS ObjectType, '' AS ObjectAlias " & _
"INTO [" & ToMove & "] " & _
"FROM MSysObjects, MSysNavPaneGroupCategories INNER JOIN MSysNavPaneGroups ON MSysNavPaneGroupCategories.Id = MSysNavPaneGroups.GroupCategoryID " & _
"WHERE (((MSysNavPaneGroupCategories.Name) " & CategorySelection & ") AND ((MSysNavPaneGroups.Name) " & GroupSelection & ") AND MSysObjects.Name " & ObjectSelection & " AND ((MSysNavPaneGroupCategories.Type)=4) AND ((MSysNavPaneGroups.[Object Type Group])=-1)) " & _
"GROUP BY MSysNavPaneGroups.GroupCategoryID, MSysNavPaneGroupCategories.Name, MSysNavPaneGroups.Id, MSysNavPaneGroups.Name, MSysObjects.Id, MSysObjects.Name, MSysObjects.Type " & _
"ORDER BY Min(MSysNavPaneGroupCategories.Position), Min(MSysNavPaneGroups.Position);"
DoCmd.RunSQL SQL
If DCount("*", "[" & ToMove & "]") = 0 Then Err.Raise 63 'Nothing to move
'Add the objects to their groups
DoCmd.RunSQL _
"INSERT INTO MSysNavPaneGroupToObjects ( GroupID, Name, ObjectID ) " & _
"SELECT TM.GroupID, TM.ObjectAlias, TM.ObjectID " & _
"FROM [" & ToMove & "] AS TM LEFT JOIN MSysNavPaneGroupToObjects ON (TM.ObjectID = MSysNavPaneGroupToObjects.ObjectID) AND (TM.GroupID = MSysNavPaneGroupToObjects.GroupID) " & _
"WHERE MSysNavPaneGroupToObjects.GroupID Is Null;"
'Add any missing NavPaneObjectIDs
DoCmd.RunSQL _
"INSERT INTO MSysNavPaneObjectIDs ( Id, Name, Type ) " & _
"SELECT DISTINCT TM.ObjectID, TM.ObjectName, TM.ObjectType " & _
"FROM [" & ToMove & "] AS TM LEFT JOIN MSysNavPaneObjectIDs ON TM.ObjectID = MSysNavPaneObjectIDs.Id " & _
"WHERE (((MSysNavPaneObjectIDs.Id) Is Null));"
SetNavGroup = True
EOFn:
On Error Resume Next
DoCmd.DeleteObject acTable, ToMove
On Error GoTo 0
DoCmd.SetWarnings True
Exit Function
SilentlyContinue: Resume EOFn
End Function

Access Database table with multiple overlapping schedule

I have Access Database table with multiple overlapping schedule. I hought it will be simple for me to create Bu faced with some overlapping existing time range. If an user approves a schedule for one employee. When user goes to approve next schedule with overlapping time for the same employee. I Need to create an alert message when user approves overlapping schedule and delete ‘approved’ text from the table. Not much knowledge about VB code or if there is something I can set up in query. Any help will be appreciated.
OK, I have a table with 3 fields: EmpID, StartTime, & EndTime. The Start & End times have the date & time together.
Then I have a form with the same 3 fields.
In the VBA code, under the Before_Update event, I check to see if there's a conflict, and if so, I set the Cancel property to true and display a message. Here's the code:
Private Sub Form_BeforeUpdate(Cancel As Integer)
Dim RS As Recordset
Dim strSQL As String
Dim EmpID As Long
Dim ScheduleStart As String
Dim ScheduleEnd As String
EmpID = Me.txtEmpID
ScheduleStart = Me.txtStartTime
ScheduleEnd = Me.txtEndTime
strSQL = ""
strSQL = strSQL & "SELECT Count(schedule.EmpID) AS Conflict " & vbCrLf
strSQL = strSQL & "FROM schedule " & vbCrLf
strSQL = strSQL & "WHERE ( ( ( Schedule.EmpID ) = #EmpID ) " & vbCrLf
strSQL = strSQL & " AND ( ( ##ScheduleStart# ) <= [StartTime] ) " & vbCrLf
strSQL = strSQL & " AND ( ( ##ScheduleEnd# ) > [StartTime] ) ) " & vbCrLf
strSQL = strSQL & " OR ( ( ( Schedule.EmpID ) = #EmpID ) " & vbCrLf
strSQL = strSQL & " AND ( ( ##ScheduleStart# ) <= [EndTime] ) " & vbCrLf
strSQL = strSQL & " AND ( ( ##ScheduleEnd# ) > [EndTime] ) )"
strSQL = Replace(strSQL, "#EmpID", EmpID)
strSQL = Replace(strSQL, "#ScheduleStart", ScheduleStart)
strSQL = Replace(strSQL, "#ScheduleEnd", ScheduleEnd)
Debug.Print strSQL
Set RS = CurrentDb.OpenRecordset(strSQL)
If RS("Conflict") > 0 Then
Cancel = True
MsgBox "Conflict Detected", vbExclamation, "Conflict Detected"
End If
End Sub
This looks for 2 scenarios, both using the EmpID.
If the ScheduleStart < StartTime AND ScheduleEnd > StartTime
Or ScheduleStart < EndTime AND ScheduleEnd > EndTime
Most of the code is building the SQL. It would be much neater if a parameter query was used, but I did it this way because I thought it was clearer.
The Debug.Print strSQL will show you what the query your building looks like.
This has no error checking, so you'l have to put some in.
Right now, when you enter dates, it has to look like: 6/26/13 4:31 pm
I created a sample set of data and a form that looks like this:
And I added this bit of code to the conflicts button to see if your StartTime and StartDate fall between the StartTime/StartDate and EndTime/EndDate of any of the other records. You would need to modify the code just a bit to also check that the EndTime and EndDate don't fall between as well.
Private Sub Test_Button_Click()
Dim myR As Recordset
Dim strSQL As String
strSQL = "Select * From Sample Where " & _
"StartDate <= #" & Me.StartDate & "# " & _
"And StartTime <= #" & Me.StartTime & "# " & _
"And EndDate >= #" & Me.StartDate & "# " & _
"And EndTime >= #" & Me.StartTime & "#"
Debug.Print strSQL
Set myR = CurrentDb.OpenRecordset(strSQL, dbOpenDynaset)
If myR.RecordCount = 0 Then
Debug.Print "There are no conflicts"
End If
Set myR = Nothing
End Sub

Dlookup retrieves a date wrong

I'm trying to get a date in my database but when the day is less than 12, the month and the day are switched
Example: In the database 2012-02-10 (2 october 2012), the value I get when I do that:
lastDateMill = Nz(DLookup("LastContactDate", "Mills", "MillID = " & lstMills.Column(0, i)), 0)
is
lastDateMill = "10/02/2012"
So I thought that was only a format thing but when I do
Format(lastDateMill, "Long Date")
it equals "February-10-12"
This is how I update the date
DoCmd.RunSQL "UPDATE Mills SET LastContactDate = #" & SalesCallDate & "# WHERE MillID = " & lstMills.Column(0, i)
And the SalesCallDate = "2/10/2012" so the good date
So why the day and the month are switched?
The front end is ms-access-2010 and the back end is on SQL SERVER 2012
Your SalesCallDate variable contains a date as text:
SalesCallDate = "2/10/2012"
Apparently you intend the date format of that string to be m/d/yyyy, but it gets interpreted as d/m/yyyy format.
Store the string value in yyyy/mm/dd format to eliminate confusion due to locale issues ... 2012/02/10
Since it turns out that SalesCallDate is actually a text box containing a date value, change your UPDATE approach to avoid date problems due to locale.
Dim strUpdate As String
Dim db As DAO.Database
strUpdate = "UPDATE Mills SET LastContactDate = " & _
Format(Me.SalesCallDate, "\#yyyy-m-d\#") & vbCrLf & _
"WHERE MillID = " & Me.lstMills.Column(0, i)
Debug.Print strUpdate
Set db = CurrentDb
db.Execute strUpdate, dbFailonerror
Set db = Nothing
Try this, by explicitly specifying a format
DoCmd.RunSQL "UPDATE Mills SET LastContactDate = #" & _
Format$(SalesCallDate,"yyyy/mm/dd") & "# WHERE MillID = " & _
lstMills.Column(0, i)
UPDATE:
Maybe there is better way to do it, that is independent of any formattings. The idea is to tranfer the date from table to table, without any combo-, list- or text in between. Therefore any conversion from a date type to string and then back to a date field is avoided.
If the tables can be joined (assuming that MillID is the bound field of the listbox):
DoCmd.RunSQL "UPDATE Mills " & _
"INNER JOIN sourceTable ON Mills.MillID = sourceTable.MillID " & _
"SET LastContactDate = sourceTable.SalesCallDate " & _
"WHERE Mills.MillID = " & lstMills
Otherwise
DoCmd.RunSQL "UPDATE Mills SET LastContactDate = " & _
"(SELECT SalesCallDate FROM sourceTable WHERE ID = " & sourceID & ")" _
"WHERE Mills.MillID = " & lstMills