I've written a function to loop through an array of a custom object (C_Document). In the loop, if the document number does not already exist, it should insert a new record into the table tbl_docs. If the document does exist, it should update the appropriate record in the database.
Public Function updateDocuments(docs() As C_Document) As Double
Dim db As Object
Set db = Application.CurrentDb
Dim docIndex As Double
'Loop through all imported documents
For docIndex = 1 To UBound(docs)
Dim strSQL As String
Dim exists As Double
exists = DCount("docNo", "tbl_docs", "docNo = '" & docs(docIndex).getDocNo() & "'" > 0)
'Check if entry already exists
If (exists > 0) Then
'docNo entry already exists - update
strSQL = "UPDATE tbl_docs SET " & _
"docReviewStatus = " & docs(docIndex).getDocStatus() & "," & _
"docRev = '" & docs(docIndex).getDocReview() & "'," & _
"docDate = '" & docs(docIndex).getDocDate() & "'" & _
" WHERE (" & _
"docNo = '" & docs(docIndex).getDocNo() & "');"
Else
'docNo does not exist - insert
strSQL = "INSERT INTO tbl_docs (docNo, docReviewStatus, docRev, docDate) " & _
"SELECT '" & docs(docIndex).getDocNo() & "'" & _
"," & docs(docIndex).getDocStatus() & _
",'" & docs(docIndex).getDocReview() & "'" & _
",'" & docs(docIndex).getDocDate() & "'" & _
";"
End If
DoCmd.SetWarnings False
DoCmd.RunSQL strSQL
DoCmd.SetWarnings True
MsgBox strSQL
Next
updateDocuments = docIndex
End Function
However, when the function is called (with tbl_docs empty), it only inserts one record and the SQL string thereafter becomes the update statement.
Is there a common issue when DCount() is used in a loop? Does anyone have any experience with this logical error?
Your check has a slight but important error:
exists = DCount("docNo", "tbl_docs", "docNo = '" & docs(docIndex).getDocNo() & "'" > 0)
should be
exists = DCount("docNo", "tbl_docs", "docNo = '" & docs(docIndex).getDocNo() & "'") > 0
or if exists isn't bool, but simply the count, then
exists = DCount("docNo", "tbl_docs", "docNo = '" & docs(docIndex).getDocNo() & "'")
You can simplify and speed up this a bit using DAO, where you can do the search and update/edit in one go:
Public Function updateDocuments(docs() As C_Document) As Long
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim docIndex As Long
Dim strSQL As String
strSQL = "Select * From tbl_docs"
Set db = Application.CurrentDb
Set rs = db.OpenRecordset(strSQL)
'Loop through all imported documents
For docIndex = LBound(docs) To UBound(docs)
rs.FindFirst "docNo = '" & docs(docIndex).getDocNo() & "'"
If rs.NoMatch Then
'docNo does not exist - insert
rs.AddNew
rs!docNo.Value = docs(docIndex).getDocNo()
Else
'docNo entry already exists - update
rs.Edit
End If
rs!docReviewStatus.Value = docs(docIndex).getDocStatus()
rs!docRev.Value = docs(docIndex).getDocReview()
rs!docDate = docs(docIndex).getDocDate()
rs.Update
Next
rs.Close
updateDocuments = docIndex
End Function
I have a query table and transfer to excel. I loop from cell range to re-query into database and it works fine but it really take so much time since i used below code.. The code need to query and do recordset every time satified IF condition in each single cell. Is there other way that this code will execute in database server and once complete then, only do a recordset?
'Set Connection
Set Cn = CreateObject("ADODB.Connection")
Cn.Open "Driver={MySQL ODBC 5.3 ANSI Driver};Server=" & _
Server_Name & ";Port=" & Port & ";Database=" & Database_Name & _
";Uid=" & User_ID & ";Pwd=" & Password & ";"
'Set Recordset
Set rs = CreateObject("ADODB.Recordset")
rs.CursorLocation = 3
rs.Open SQLQuery, Cn, adOpenStatic
myArray = rs.GetRows()
kolumner = UBound(myArray, 1) 'Count number of Columns
rader = UBound(myArray, 2) 'count number of rows
For K = 0 To kolumner ' Using For loop data are displayed
Range("A5").Offset(0, K).Value = rs.Fields(K).Name 'Field is the header
of each column and not included in Array. Field(0) means header of first
column.
For R = 0 To rader
Range("A5").Offset(R + 1, K).Value = myArray(K, R)
Next
Next
set rows = 0 to rader
Range("L5").Value = "Debug Note" 'insert Name of Column
For R = 6 To 1100
Datevalue = Sheets("Sheet1").Range("I" & R)
Dateexcel = FORMAT(Datevalue, "yyyy-MM-dd HH:mm:ss")
SQLQuery2 = "SELECT * FROM Mfg.databasemodels_note " & _
"where typeId = " & Sheets("Sheet1").Range("B" & R) & " AND
date > " & "'" & Dateexcel & "'" & " order by date asc
limit 1;"
Set rs2 = CreateObject("ADODB.Recordset")
rs2.CursorLocation = 3 'client
rs2.Open SQLQuery2, Cn, adOpenStatic
myArray2 = rs2.GetRows()
If Not (rs2.BOF And rs2.EOF) And (Range("J" & R).Value = "failed" Or
Range("J" & R).Value = "invalid") Then
Range("L" & R).Value = myArray2(3, 0)
Else
End If
On Error Resume Next
rs2.Close
Set rs2 = Nothing
Next
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
I've been dabbling with VBA in Access for years, but to be honest I've never really used RecordSets before.
I have a SQL string which will create a list of all engineer's visits for a specific day:
"SELECT Cases.Id, Customers.SiteName, tbl_Visits.[Visit Date], Employees.[Last Name], Employees.[Job Title], Employees.[E-mail Address] " & vbCrLf & _
"FROM (Customers INNER JOIN Cases ON Customers.ID = Cases.Customer) INNER JOIN (Employees INNER JOIN tbl_Visits ON Employees.ID = tbl_Visits.Engineer) ON Cases.Id = tbl_Visits.CaseID " & vbCrLf & _
"WHERE (((tbl_Visits.[Visit Date])=#1/27/2014#) AND ((Employees.[Job Title])=""Engineer""));"
I'm going to replace the fixed date with a variable, which works well on another RecordSet I use.
What I want to do with this data is create a text string of ID, Site name, visit date for each email address, and then send that as an email. I can do the email bit, and I could send the whole RecordSet as one email text string, I'm just stuck with sending as many emails as there are email addresses.
I have a feeling it'll be a "for each" job, but I really don't know.
You're on the right track. All you need to do is leverage the fact that an Access query can not only be based on tables, it can also use other saved queries in the same way.
So if you create a "saved query" (technically called a QueryDef object) named [dailyVisits] using your SQL string in VBA code like this
Dim qdf As DAO.QueryDef
Set qdf = CurrentDb.CreateQueryDef("dailyVisits", _
"SELECT Cases.Id, Customers.SiteName, tbl_Visits.[Visit Date], Employees.[Last Name], Employees.[Job Title], Employees.[E-mail Address] " & vbCrLf & _
"FROM (Customers INNER JOIN Cases ON Customers.ID = Cases.Customer) INNER JOIN (Employees INNER JOIN tbl_Visits ON Employees.ID = tbl_Visits.Engineer) ON Cases.Id = tbl_Visits.CaseID " & vbCrLf & _
"WHERE (((tbl_Visits.[Visit Date])=#1/27/2014#) AND ((Employees.[Job Title])=""Engineer""));"
Set qdf = Nothing
Then you can use nested loops to
extract the distinct set of e-mail addresses,
create the site information strings for each one, and send via e-mail
using VBA code something like this:
Dim rstEmail As DAO.RecordSet, rstVisits As DAO.RecordSet, VisitList As String
Set rstEmail = CurrentDb.OpenRecordset( _
"SELECT DISTINCT [E-mail Address] FROM dailyVisits", _
dbOpenSnapshot)
Do Until rstEmail.EOF
Set rstVisits = CurrentDb.OpenRecordset( _
"SELECT Id & ", " & SiteName & ", " & [Visit Date] AS Visit " & _
"FROM dailyVisits " & _
"WHERE [E-mail Address] = '" & rstEmail![E-mail Address] & "'",
dbOpenSnapshot)
VisitList = ""
Do Until rstVisits.EOF
VisitList = VisitList & rstVisits!Visit & VbCrLf
rstVisits.MoveNext
Loop
rstVisits.Close
Set rstVisits = Nothing
'
' insert code to send VisitList to rstEmail![E-mail Address]
'
rstEmail.MoveNext
Loop
rstEmail.Close
Set rstEmail = Nothing
DoCmd.DeleteObject acQuery, "dailyVisits"
Thanks so much for your help. After not very much messing around, I've settled on:
Dim rstEmail As DAO.Recordset, rstVisits As DAO.Recordset, VisitList As String, eml2txt As String, sql2 As String
Dim OutApp As Object
Dim OutMail As Object
Dim qdf As DAO.QueryDef
Set qdf = CurrentDb.CreateQueryDef("qryEngJobList1", _
"SELECT Cases.Id, Customers.SiteName, Customers.[Post Code] AS PCode, tbl_Visits.[Visit Date] AS vDate, Employees.[Last Name] AS lname, Employees.[Job Title], Employees.[E-mail Address] AS dEmail " & vbCrLf & _
"FROM Employees INNER JOIN (Customers INNER JOIN (Cases INNER JOIN tbl_Visits ON Cases.Id = tbl_Visits.CaseID) ON Customers.ID = Cases.Customer) ON Employees.ID = tbl_Visits.Engineer " & vbCrLf & _
"WHERE (((tbl_Visits.[Visit Date])=" & SQLDate([TempVars]![senddate].[Value]) & ") AND ((Employees.[Job Title])=""Engineer""));")
Set qdf = Nothing
Set rstEmail = CurrentDb.OpenRecordset( _
"SELECT DISTINCT [dEmail] FROM qryengjoblist1", _
dbOpenSnapshot)
Do Until rstEmail.EOF
Set rstVisits = CurrentDb.OpenRecordset( _
"SELECT Id, SiteName, vDate, PCode " & _
"FROM qryengjoblist1 " & _
"WHERE dEmail = '" & rstEmail![dEmail] & "'", _
dbOpenSnapshot)
VisitList = ""
Do Until rstVisits.EOF
VisitList = VisitList & rstVisits!ID & vbTab & rstVisits!SiteName & vbTab & rstVisits!PCode & vbCrLf
rstVisits.MoveNext
Loop
rstVisits.Close
Set rstVisits = Nothing
'
' insert code to send VisitList to rstEmail![E-mail Address]
eml2txt = "Please find below your visit summary for " & TempVars!senddate & ":" & Chr(13) & Chr(10) & Chr(13) & Chr(10) & "" _
& VisitList & Chr(13) & Chr(10) & Chr(13) & Chr(10) & "" _
& "If there are any issues, please contact " & TempVars!sereml & Chr(13) & Chr(10) & Chr(13) & Chr(10) & "" _
& "Thank you."
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.SentOnBehalfOfName = TempVars!sereml
.To = rstEmail!dEmail
.CC = TempVars!sereml
.BCC = ""
.Subject = "Job Summary for " & TempVars!senddate
.Body = eml2txt
.Display 'or use .Send
.ReadReceiptRequested = False
End With
On Error GoTo 0
'MsgBox eml2txt
'
rstEmail.MoveNext
Loop
rstEmail.Close
Set rstEmail = Nothing
DoCmd.DeleteObject acQuery, "qryengjoblist1"
End Sub
Which seems to be doing the trick nicely. All I've got to do now is figure out how go give you a thanks or something on here :)
I need your help. I woulod like to change one char by another but in all database and i have several table and fields. So i'm building a function in VB but that change nothing and i have no error. I think that my condition is false but i don't see how to correct it :/
Public Sub updateField()
Dim db As DAO.Database, td As DAO.TableDef, field As DAO.field
Dim rs As DAO.Recordset, sSQL As String, sData As String
Set db = CurrentDb
Change = "\"""
replaced = """"
'each table in db
For Each tbd In db.TableDefs
'each field in table
For Each fld In tbd.Fields
'check if String Data have my character
If InStr(1, fld.Name, Change) Then
sSQL = "UPDATE " & tbd.Name & " SET " & fld.Name & " = replace([" & fld.Name & "], " & Change & ", " & replaced & ")"
db.Execute sSQL
End If
Next
Next
End Sub
EDIT :
I finally find what's wrong. if some people are interested :
Set db = CurrentDb
Change = "\"""
replaced = """"
'each table in db
For Each tbd In db.TableDefs
'each field in table
For Each fld In tbd.Fields
If Left(tbd.Name, 4) <> "MSys" And Left(tbd.Name, 4) <> "~TMP" Then
If fld.Type = dbText Or fld.Type = dbMemo Then
sSQL = "UPDATE " & tbd.Name & " SET " & fld.Name & " = replace([" & fld.Name & "],'" & Chr(92) + Chr(34) & "','" & Chr(34) & "')"
db.Execute sSQL
'Debug.Print (sSQL)
End If
End If
Next
Next
Thx for your help guys ;)
If it should help there my solution :
Public Sub updateField()
Dim db As DAO.Database, td As DAO.TableDef, field As DAO.field
Dim rs As DAO.Recordset, sSQL As String, sData As String, change As String, replace As String
change = "\'"
replace = "'"
' simple quote = 39
' doulbe quote = 34
' antislash = 92
' retour chariot = 13
' n = 110
' r = 114
Set db = CurrentDb
'each table in db
For Each tbd In db.TableDefs
'each field in table
For Each fld In tbd.Fields
If Left(tbd.Name, 4) <> "MSys" And Left(tbd.Name, 4) <> "~TMP" Then
If fld.Type = dbText Or fld.Type = dbMemo Then
' \r\n
'sSQL = "UPDATE " & tbd.Name & " SET [" & fld.Name & "] = replace([" & fld.Name & "],'\r\n','" & Chr(13) & Chr(10) & "');"
' \"
'sSQL = "UPDATE " & tbd.Name & " SET [" & fld.Name & "] = replace([" & fld.Name & "],'" & Chr(92) + Chr(34) & "','" & Chr(34) & "');"
'db.Execute sSQL
sSQL = "UPDATE " & tbd.Name & " SET [" & fld.Name & "] = replace([" & fld.Name & "],'\''','''');"
db.Execute sSQL
'Debug.Print (sSQL)
End If
End If
Next
Next
End Sub
That's works for me ;)