VBA
code behind menu form, f_MENU_ListObjects_LoopFiles_s4p
The menu form gives you a way to specify
or browse to
a path that has
one or more databases you want to list objects for.
Change checkboxes for Recursive and Count Records if desired,
and then click OK.
The code loops through every Access database in the path,
and its subfolders too, if you want.
As the program runs, you'll see where it is in the progress box.
Once the program is finished, you can get results
as reports, queries, or write your own queries.
Each time it runs, a new BatchID is assigned.
You can also choose a previous Batch to run reports and queries on.
You might find the queries more useful.
Specify criteria to open queries and reports
for Files and Objects.
If you specify a Pattern,
it will apply to filename for Files report/query
or object name for Objects report/query.
If no ? or * wildcard is included in the pattern,
* will be added to the beginning and the end of the pattern.
Option Compare Database
Option Explicit
' cbf: f_MENU_ListObjects_LoopFiles_s4p
'*************** Code Start ***************************************************
' Purpose : code behind menu form to
' Loop through files
' and store Access Object summary
' for each database in the path
' Author : crystal (strive4peace)
' Site : https://msaccessgurus.com
' This tool: https://msaccessgurus.com/tool/ListObjects_LoopFiles.htm
' LICENSE :
' You may freely use and share this code, but not sell it.
' Keep attribution. Mark your changes. Use at your own risk.
'--------------------------------------------------------------------------------
' #Const IsEarly
'--------------------------------------------------------------------------------
#Const IsEarly = gIsEarly
'--------------------------------------------------------------------------------
' Public UpdateProgress
'--------------------------------------------------------------------------------
Public Sub UpdateProgress(psMessage As String)
'230314 s4p 230828
Dim sMsg As String
With Me
.Label_Progress.Caption = psMessage
.Repaint
End With 'me
DoEvents
If Len(Trim(psMessage)) = 0 Then
'clear message on status bar
SysCmd acSysCmdClearStatus
Else
sMsg = Replace(psMessage,vbCrLf, " ")
SysCmd acSysCmdSetStatus,sMsg
End If
End Sub
'--------------------------------------------------------------------------------
' Form_Load
'--------------------------------------------------------------------------------
Private Sub Form_Load()
'230314 s4p
Call UpdateProgress( " ")
End Sub
'--------------------------------------------------------------------------------
' Form_Close
'--------------------------------------------------------------------------------
Private Sub Form_Close()
'230204 s4p
Call Release_Fso_Db
End Sub
'--------------------------------------------------------------------------------
' BatchID_AfterUpdate
'--------------------------------------------------------------------------------
Private Sub BatchID_AfterUpdate()
'230831
With Me.FileID
.Value = Null
.Requery
End With
End Sub
'--------------------------------------------------------------------------------
' cmd_Clear_Click
'--------------------------------------------------------------------------------
Private Sub cmd_Clear_Click()
'230831
With Me
.BatchID = Null
.FileID = Null
.FileID.Requery
.objTypN_ = Null
.txtPattern = Null
.chk_MSys = False
End With
End Sub
'--------------------------------------------------------------------------------
' BatchID_MouseUp
'--------------------------------------------------------------------------------
Private Sub BatchID_MouseUp(Button As Integer,Shift As Integer,X As Single,Y As Single)
'230828 s4p
Me.ActiveControl.Dropdown
End Sub
'--------------------------------------------------------------------------------
' objTypN_MouseUp
'--------------------------------------------------------------------------------
Private Sub objTypN_MouseUp(Button As Integer,Shift As Integer,X As Single,Y As Single)
Me.ActiveControl.Dropdown
End Sub
'--------------------------------------------------------------------------------
' FileID_MouseUp
'--------------------------------------------------------------------------------
Private Sub FileID_MouseUp(Button As Integer,Shift As Integer,X As Single,Y As Single)
Me.ActiveControl.Dropdown
End Sub
'--------------------------------------------------------------------------------
' objTypN_MouseUp
'--------------------------------------------------------------------------------
Private Sub objTypN__MouseUp(Button As Integer,Shift As Integer,X As Single,Y As Single)
Me.ActiveControl.Dropdown
End Sub
'--------------------------------------------------------------------------------
' cmd_ReportObjects_Click
'--------------------------------------------------------------------------------
Private Sub cmd_ReportObjects_Click()
'230828 s4p
'CALLs
' GetWhere
Dim sReportname As String _
,vWhere As Variant
sReportname = "r_Object_List"
'get objects, don't use Table Alias
vWhere = GetWhere(True,False)
DoCmd.OpenReport sReportname,acViewPreview _
,,vWhere
End Sub
'--------------------------------------------------------------------------------
' cmd_ReportFileSummary_Click
'--------------------------------------------------------------------------------
Private Sub cmd_ReportFileSummary_Click()
'
'CALLs
' GetWhere
Dim sReportname As String _
,vWhere As Variant
sReportname = "r_File_List"
'don't get objects, don't use Table Alias
vWhere = GetWhere(False,False)
DoCmd.OpenReport sReportname,acViewPreview _
,,vWhere
End Sub
'--------------------------------------------------------------------------------
' cmd_QueryObjects_Click
'--------------------------------------------------------------------------------
Private Sub cmd_QueryObjects_Click()
'230831 s4p
'CALLs
' GetWhere
Dim sSql As String _
,sWhere As String _
,sQueryTemplate As String _
,sQuery As String
Dim oQdf As QueryDef
sQueryTemplate = "qTemplate_Object_List"
sQuery = "q_Objects"
If goDb Is Nothing Then
Set goDb = CurrentDb
End If
sSql = goDb.QueryDefs(sQueryTemplate).SQL
'get crieria with table aliases
' get objects, use Table Alias
sWhere = GetWhere(True,True)
If sWhere <> "" Then
sSql = Replace(sSql, "ORDER BY " _
, " WHERE (" & sWhere & ") ORDER BY ")
End If
'make query to view
'close if open
If SysCmd(acSysCmdGetObjectState,acQuery,sQuery) _
= acObjStateOpen Then
DoCmd.Close acQuery,sQuery,acSaveNo
End If
Call Query_Make_s4p(sQuery,sSql)
'open query
DoCmd.OpenQuery sQuery
End Sub
'--------------------------------------------------------------------------------
' cmd_QueryFileSummary_Click
'--------------------------------------------------------------------------------
Private Sub cmd_QueryFileSummary_Click()
's4p
'CALLs
' GetWhere
Dim sSql As String _
,sWhere As String _
,sQueryTemplate As String _
,sQuery As String
Dim oQdf As QueryDef
sQueryTemplate = "qTemplate_File_List"
sQuery = "q_Files"
If goDb Is Nothing Then
Set goDb = CurrentDb
End If
sSql = goDb.QueryDefs(sQueryTemplate).SQL
'get crieria with table aliases
' don't get objects, use Table Alias
sWhere = GetWhere(False,True)
If sWhere <> "" Then
sSql = Replace(sSql, "ORDER BY " _
, " WHERE (" & sWhere & ") ORDER BY ")
End If
'make query to view
'close if open
If SysCmd(acSysCmdGetObjectState,acQuery,sQuery) _
= acObjStateOpen Then
DoCmd.Close acQuery,sQuery,acSaveNo
End If
Call Query_Make_s4p(sQuery,sSql)
'open query
DoCmd.OpenQuery sQuery
End Sub
'--------------------------------------------------------------------------------
' GetWhere
'--------------------------------------------------------------------------------
Function GetWhere(pbGetObjects As Boolean _
,Optional pbForQuery As Boolean = False _
) As String
'230831 s4p, 231012
Dim vWhere As Variant _
,sAlias As String _
,sPattern As String _
,sExpression As String
vWhere = Null
sAlias = ""
'------------- File /Batch
If pbForQuery Then
sAlias = "F." 'tFile
End If
With Me.FileID
If Not IsNull(.Value) Then
vWhere = (vWhere + " AND ") _
& sAlias & "FileID= " & .Value
Else
'filter by batch?
If Not IsNull(Me.BatchID.Value) Then
vWhere = (vWhere + " AND ") _
& sAlias & "BatchID= " & Me.BatchID.Value
End If
End If
End With 'FileID / BatchID
'------------- Pattern
sPattern = ""
With Me.txtPattern
If Not IsNull(.Value) Then
sPattern = .Value
'if pattern doesn't specify wildcards * or ?
' then add * before and after
If Not sPattern Like "*[?*]*" Then
sPattern = "*" & sPattern & "*"
End If
End If
End With 'txtPattern
sAlias = ""
If Not pbGetObjects Then
'pattern for Filenames
'------------- tFile
If sPattern <> "" Then
vWhere = (vWhere + " AND ") _
& "F.FileName Like '" & sPattern & "'"
End If
Else
'pattern for Objects
'------------- SysObjects
If sPattern <> "" Then
vWhere = (vWhere + " AND ") _
& "oName Like '" & sPattern & "'"
End If
'------------- ao_ObjType
If pbForQuery Then
sAlias = "OTy." 'ao_ObjType
End If
With Me.objTypN_
If Not IsNull(.Value) Then
vWhere = (vWhere + " AND ") _
& sAlias & "objTypN_= " & .Value
End If
End With 'objTypN_
'------------- exclude system objects?
If Me.chk_MSys = False Then
' calculated field oName4
If pbForQuery Then
'query
sExpression = " Left(O.oName,4) "
Else
'report
sExpression = "oName4 "
End If
vWhere = (vWhere + " AND ") _
& sExpression & " <> 'MSys'"
' calculated field oName1
If pbForQuery Then
'query
sExpression = " Left(O.oName,1) "
Else
'report
sExpression = "oName1 "
End If
vWhere = (vWhere + " AND ") _
& sExpression & " Not In ('~','{','_')"
' Flags
vWhere = (vWhere + " AND ") _
& " oFlags>=0"
End If 'chk_MSys
End If
Debug.Print vWhere
GetWhere = Nz(vWhere, "")
End Function
'--------------------------------------------------------------------------------
' cmd_Browse_Click
'--------------------------------------------------------------------------------
Private Sub cmd_Browse_Click()
'230121 strive4peace
' CALLs
' mod_Office_GetFolder_GetFile_s4p
' GetFolder
'folder path, number of files
Dim sFolder As String
'Title of dialog box
Dim sTitle As String
sTitle = "Select the Folder to loop and document databases"
' Call GetFolder
sFolder = GetFolder(sTitle)
If sFolder = "" Then Exit Sub
With Me
'folder path
.txtFolder = sFolder
End With
End Sub
'--------------------------------------------------------------------------------
' cmd_GetObjectList_Loop_Click
'--------------------------------------------------------------------------------
Private Sub cmd_GetObjectList_Loop_Click()
'230401 s4p ... 230405, 231012
' CALLS
' Start_Time
' SetBatchIDNew
' DocumentAccessObjects_Recursive_s4p -- all files in path
' Release_Fso_Db
' ReportElapsedTime
On Error GoTo Proc_Err
Dim sSql As String
Dim rs As DAO.Recordset _
,rsTable As DAO.Recordset _
,oField As DAO.Field
Dim nCountFile As Integer _
,nCountObjects As Long _
,nFileID As Long _
,nCount As Long _
,nCountTotal As Long _
,nCountRecord As Long _
,iCountField As Integer _
,dtmStart As Date _
,sMessage As String _
,sPath As String _
,sPathFile As String _
,sTable As String _
,sField As String _
,bRecursive As Boolean _
,bHasComplex As Boolean _
,bCountRecords As Boolean
dtmStart = Now()
With Me
If IsNull(.txtFolder) Then
MsgBox "You must specify a start folder",, "Missing folder"
Exit Sub
End If
Call Start_Time
.txtStart = dtmStart
sPath = .txtFolder
bRecursive = .chk_Recursive
bCountRecords = .chk_CountRecords
gnBatchID = 0 'not set
Call SetBatchIDNew 'assign gnBatchID
Me.BatchID.Value = gnBatchID
End With
Set goDb = Nothing
'Call DocumentAccessObjects_Recursive_s4p
Call DocumentAccessObjects_Recursive_s4p(sPath,bRecursive)
'get number of objects created
nCountObjects = 0
'--------------------------------------- count objects
Call UpdateProgress( "count objects")
sSql = "SELECT count(SysObjID) as CountObjects " _
& " FROM SysObjects AS A" _
& " WHERE(A.dtmAdd >=#" & dtmStart & "# )" _
& ";"
Set rs = goDb.OpenRecordset(sSql,dbOpenSnapshot)
With rs
nCountObjects = !CountObjects
.Close
End With
'get number of files
sSql = "SELECT count(FileID) as CountFile " _
& " FROM tFile AS A" _
& " WHERE(A.dtmAdd >=#" & dtmStart & "# )" _
& ";"
Set rs = goDb.OpenRecordset(sSql,dbOpenSnapshot)
With rs
nCountFile = !CountFile
.Close
End With
nCountTotal = 0
If bCountRecords Then
nCount = 0
'--------------------------------------- count records
Call UpdateProgress( "count records in tables")
'type=1, flags=0 OR not MSys
sSql = "SELECT Nz([PathName],[PathLong]) & '\' & [FileName] AS PathFile" _
& ", O.oName, O.NumRec, O.NumField, O.dtmEdit " _
& " FROM (tPath AS P " _
& " INNER JOIN tFile AS F ON P.PathID = F.PathID) " _
& " INNER JOIN SysObjects AS O ON F.FileID = O.FileID" _
& " WHERE(P.BatchID =" & gnBatchID & ") " _
& " AND(O.oType=1) AND " _
& "( O.oFlags =0 OR left(O.oName,4) <>'MSys')" _
& ";"
Set rs = goDb.OpenRecordset(sSql,dbOpenDynaset)
With rs
.MoveLast
nCountTotal = .RecordCount
.MoveFirst
Do While Not .EOF
nCount = nCount + 1
sPathFile = !PathFile
sTable = !oName
iCountField = 0
nCountRecord = -1
sMessage = "count records in tables" _
& vbCrLf & vbCrLf _
& Format(nCount / nCountTotal, "0.0%") _
& vbCrLf & vbCrLf & sTable & vbCrLf & vbCrLf & sPathFile
Call UpdateProgress(sMessage)
sSql = "SELECT top 1 t.* from [" & sTable _
& "] as t in '" & sPathFile & "'" _
& ";"
On Error Resume Next
Set rsTable = goDb.OpenRecordset(sSql,dbOpenSnapshot)
If Err.Number <> 0 Then
Err.Clear
On Error GoTo Proc_Err
GoTo NextTable
End If
iCountField = rsTable.Fields.Count
On Error GoTo Proc_Err
If iCountField > 0 Then
'find name of field for count records
For Each oField In rsTable.Fields
sField = ""
If oField.Type <= 10 And oField.Type <> 9 Then
sField = oField.Name
Exit For
End If
Next oField
If sField <> "" Then
rsTable.Close
sSql = "SELECT count([" & sField _
& "]) as zCountRecord " _
& " from [" & sTable _
& "] in '" & sPathFile & "'" _
& ";"
Set rsTable = goDb.OpenRecordset( _
sSql,dbOpenSnapshot)
nCountRecord = rsTable!zCountRecord
End If
rsTable.Close
.Edit
!NumField = iCountField
If nCountRecord >= 0 Then
!NumRec = nCountRecord
End If
!dtmEdit = Now
.Update
End If
NextTable:
.MoveNext
Loop
End With 'rs
End If 'count records
'--------------------------------------- number of files
Call UpdateProgress( "number of files")
'update number of files
sSql = "UPDATE tPath AS P " _
& " SET P.NumFile = DCount(" _
& " 'FileID','tFile','PathID=' & [PathID])" _
& " WHERE(P.BatchID =" & gnBatchID & " );"
Call ExecuteSQL_s4p(sSql,goDb)
'--------------------------------------- number of files
sMessage = Format(nCountObjects, "#,##0") _
& " objects in " _
& Format(nCountFile, "#,##0") & " files documented "
If nCountTotal > 0 Then
sMessage = sMessage & vbCrLf _
& "counted records in " _
& Format(nCountTotal, "#,##0") & " tables"
End If
Call UpdateProgress(sMessage)
'--------------------------------------- done
Me.BatchID.Requery '231012
Me.FileID.Requery
'clear status bar
SysCmd acSysCmdClearStatus
'release objects
Call Release_Fso_Db
sMessage = "Done documenting Access Objects" _
& vbCrLf & sMessage
Debug.Print sMessage
Call ReportElapsedTime(sMessage)
Proc_Exit:
On Error Resume Next
Call UpdateProgress( "")
'release object variables
If Not rs Is Nothing Then
rs.Close
Set rs = Nothing
End If
Exit Sub
Proc_Err:
MsgBox Err.Description,,_
"ERROR " & Err.Number _
& " cmd_GetObjectList_Loop_Click "
Stop
Resume Proc_Exit
Resume
End Sub
'*************** Code End *****************************************************
Goto Top
Standard module
mod_ListObjects_LoopFiles_s4p
DocumentAccessObjects_Recursive_s4p is recursive
Option Compare Database
Option Explicit
' module: mod_ListObjects_LoopFiles_s4p
'*************** Code Start ***************************************************
' Purpose : use the Microsoft Scripting Runtime library
' loop through files in a folder and optionally subfolders
' document names and other important info for Access database objects
' Recursive
' Author : crystal (strive4peace)
' Site : https://msaccessgurus.com
' This tool: https://msaccessgurus.com/tool/ListObjects_LoopFiles.htm
' LICENSE :
' You may freely use and share this code, but not sell it.
' Keep attribution. Mark your changes. Use at your own risk.
'--------------------------------------------------------------------------------
' module declarations
'--------------------------------------------------------------------------------
#Const IsEarly = False 'could be set to global such as Public Const gIsEarly
' in mod_Office_GetFolder_GetFile_s4p
#If IsEarly Then 'early binding
'needs Microsoft Scripting Runtime
Private moFso As Scripting.FileSystemObject
Private moFile As Scripting.File
Private moFolder As Scripting.Folder
#Else 'late binding
Private moFso As Object
Private moFile As Object
Private moFolder As Object
#End If
Public goDb As DAO.Database 'could be for module except menu form uses it
Public gnBatchID As Long _
,gnCountFiles As Long
Private mRsPath As DAO.Recordset _
,mRsFile As DAO.Recordset _
,nRs As DAO.Recordset _
,moQDF As DAO.QueryDef _
,moField As DAO.Field
'-------------------------------------------------------------------------------
' Set_Fso
'-------------------------------------------------------------------------------
Public Sub Set_Fso()
Set moFso = CreateObject( "Scripting.FileSystemObject")
End Sub
'-------------------------------------------------------------------------------
' Release_Fso_Db
'-------------------------------------------------------------------------------
'run when done to cleanup
Public Sub Release_Fso_Db()
Set moFso = Nothing
Set moField = Nothing
Set moQDF = Nothing
If Not mRsFile Is Nothing Then
mRsFile.Close
Set mRsFile = Nothing
End If
If Not mRsPath Is Nothing Then
mRsPath.Close
Set mRsPath = Nothing
End If
Set goDb = Nothing
End Sub
'-------------------------------------------------------------------------------
' DocumentAccessObjects_Recursive_s4p
'-------------------------------------------------------------------------------
Public Sub DocumentAccessObjects_Recursive_s4p( _
ByVal psPath As String _
,Optional ByVal pbRecursive As Boolean = True _
,Optional ByVal pnPathID As Long = -1 _
)
'strive4peace 230401, 230829 NextFolder, 230831
' uses
' goDb, moFso..., mRs...
'PARAMETERs
' psPath is start folder to document databases
'OPTIONAL
' pbRecursive = True to recurse
' pnPathID < 0 to add Path record and get new PathID
'CALLs
' Set_Fso
' GetPathIDNew
' itself if pbRecursive
' GetSystemObjects_s4p
On Error GoTo Proc_Err
Dim sFilename As String _
,sPath As String _
,sPathFile As String _
,sFolderPath As String _
,sExtension As String _
,sMessage As String _
,sSql As String _
,nPathID As Long _
,nPathIDnew As Long _
,nFileID As Long _
,iPos As Integer _
,iPart As Integer
If moFso Is Nothing Then
Call Set_Fso
End If
If goDb Is Nothing Then
Set goDb = CurrentDb
Set mRsPath = goDb.OpenRecordset( _
"tPath",dbOpenDynaset,dbAppendOnly)
Set mRsFile = goDb.OpenRecordset( _
"tFile",dbOpenDynaset,dbAppendOnly)
Else '230829
If mRsPath Is Nothing Then
Set mRsPath = goDb.OpenRecordset( _
"tPath",dbOpenDynaset,dbAppendOnly)
End If
If mRsFile Is Nothing Then
Set mRsFile = goDb.OpenRecordset( _
"tPath",dbOpenDynaset,dbAppendOnly)
End If
End If
'passed PathID
If pnPathID < 0 Then
'path for top folder
nPathID = GetPathIDNew(psPath) 'uses mRsPath
Else
nPathID = pnPathID
End If
' ---------------------------- Scripting.FileSystemObject
With moFso
'RECURSIVE
If pbRecursive <> False Then
iPart = 1
For Each moFolder In .GetFolder(psPath).SubFolders
iPart = 2
sFolderPath = moFolder.Path
'call GetPathIDNew
nPathIDnew = GetPathIDNew(sFolderPath) 'needs mRsPath 230829
'call DocumentAccessObjects_Recursive_s4p, Recursively
Call DocumentAccessObjects_Recursive_s4p(sFolderPath _
,True,nPathIDnew)
NextFolder:
Next moFolder
End If
iPart = 3
'loop files in folder of FileSystemObject for Access databases
For Each moFile In .GetFolder(psPath).Files
sFilename = moFile.Name
'make sure file is an Access database
iPos = InStrRev(sFilename, ".") + 1
If Not iPos > 1 Then GoTo Proc_NextFile
sExtension = Mid(sFilename,iPos)
' make sure extension is an Access database
Select Case sExtension
Case "accdb", "accde", "accda", "accdr" _
, "mdb", "mde", "mda", "mdr"
'store Path and File info
With mRsFile
.AddNew
!PathID = nPathID
!BatchID = gnBatchID
!FileName = sFilename
!FExt = sExtension
!FSize = moFile.Size
!FDateMod = moFile.DateLastModified
.Update
.Bookmark = .LastModified
nFileID = !FileID
gnCountFiles = gnCountFiles + 1 '230829
End With
sPathFile = psPath _
& IIf(Right(psPath,1) <> "\", "\", "") _
& sFilename
'append data from MSysObjects
sMessage = "Append Object information " _
& vbCrLf & vbCrLf & psPath _
& vbCrLf & vbCrLf & sFilename
'call UpdateProgress_form
Call UpdateProgress_form(sMessage)
sSql = "INSERT INTO SysObjects " _
& "(oConnect, oDatabase, oDateCreate, oDateUpdate " _
& ", oFlags, oForeignName, oid, oName, oParentId" _
& ", oType, oConnectLong, oDatabaseLong, FileID, BatchID )" _
& "SELECT IIf(Len([connect] & '')<=255,[connect],Null)" _
& ", IIf(Len([Database] & '')<=255,[Database],Null)" _
& ", Msys.DateCreate, Msys.DateUpdate, Msys.Flags " _
& ", Msys.ForeignName, Msys.Id, Msys.Name, Msys.ParentId" _
& ", Msys.Type" _
& ", IIf(Len([connect] & '')>255,[connect],Null)" _
& ", IIf(Len([Database] & '')>255,[Database],Null)" _
& ", " & nFileID _
& ", " & gnBatchID _
& " FROM MSysObjects " _
& " AS Msys" _
& " IN '" & sPathFile & "' " _
& ";"
'call ExecuteSQL_s4p
Call ExecuteSQL_s4p(sSql,goDb)
End Select 'extension is an Access database
Proc_NextFile:
Next moFile
End With 'moFso
Proc_Exit:
On Error Resume Next
Exit Sub
Proc_Err:
'70 permission denied
If iPart = 1 And Err.Number = 70 Then
Resume Proc_Exit
Else
Resume NextFolder
End If
MsgBox Err.Description & vbCrLf & psPath & vbCrLf & iPart _
,, "ERROR " & Err.Number _
& " DocumentAccessObjects_Recursive_s4p"
Stop
Resume Proc_Exit
Resume
End Sub
'-------------------------------------------------------------------------------
' GetPathIDNew
'-------------------------------------------------------------------------------
Private Function GetPathIDNew(psPath As String) As Long
'230401 strive4peace
'add record to tPath and return the PathID
With mRsPath
.AddNew
!BatchID = gnBatchID
If Len(psPath) > 255 Then
!PathLong = psPath
Else
!PathName = psPath
End If
.Update
.Bookmark = .LastModified
GetPathIDNew = !PathID
End With
End Function
'-------------------------------------------------------------------------------
' SetBatchIDNew
'-------------------------------------------------------------------------------
Public Sub SetBatchIDNew()
'230401 strive4peace
'set gnBatchID to the next BatchID -- ASSUME goDb is set
'default value if no records
gnBatchID = 1
gnBatchID = Nz(DMax( "BatchID", "tPath"),0) + 1
Proc_Exit:
' On Error Resume Next
' If Not rs Is Nothing Then
' rs.Close
' Set rs = Nothing
' End If
On Error GoTo 0
Exit Sub
Proc_Err:
Resume Proc_Exit
End Sub
'-------------------------------------------------------------------------------
' UpdateProgress_form
'-------------------------------------------------------------------------------
Private Sub UpdateProgress_form(psMessage As String) '--- customize
'230402 strive4peace. Send " " to clear message
Call Form_f_MENU_ListObjects_LoopFiles_s4p.UpdateProgress(psMessage)
End Sub
'*************** Code End *****************************************************
Goto Top
Standard module
mod_Office_GetFolder_s4p
browse to a folder using the Office.FileDialog
in the Microsoft Office #.0 Object Library
Option Compare Database
Option Explicit
' module name: mod_Office_GetFolder_s4p
'*************** Code Start ***************************************************
' Purpose : get a folder path using the Office file dialog box
' browse to a folder, Office.FileDialog
' Author : crystal (strive4peace)
' Code List: www.msaccessgurus.com/code.htm
' This code: https://msaccessgurus.com/VBA/Office_GetFolder.htm
' added GetFile procedure
' LICENSE :
' You may freely use and share this code, but not sell it.
' Keep attribution. Mark your changes. Use at your own risk.
'--------------------------------------------------------------------------------
' Constants
'--------------------------------------------------------------------------------
'bind early or late?
Public Const gIsEarly As Boolean = True
'set compiler directive constant
#Const IsEarly = gIsEarly
'--------------------------------------------------------------------------------
' GetFolder
'--------------------------------------------------------------------------------
Function GetFolder( _
Optional psTitle As String = "Select Folder" _
) As String
'return folder path or "" if nothing chosen
' for example, C:\MyPath
'crystal, strive4peace 220121, 230204
' REFERENCE for early binding
' Microsoft Office #.0 Object Library
' developed with 16.0
'initialize return value
GetFolder = ""
'dimension FileDialog object
#If IsEarly Then
Dim fDialog As Office.FileDialog
#Else
Dim fDialog As Object
#End If
' msoFileDialogOpen = 1
' msoFileDialogSaveAs = 2
' msoFileDialogFilePicker = 3
' msoFileDialogFolderPicker = 4
'Set File Dialog. 4=msoFileDialogFolderPicker
Set fDialog = Application.FileDialog(4)
'set Title and GetFolder
With fDialog
.Title = psTitle
If .Show Then
GetFolder = .SelectedItems(1)
End If
End With
'release object
Set fDialog = Nothing
End Function
'*************** Code End *****************************************************
Goto Top
Standard module
bas_ExecuteSQL_s4p
execute SQL statements, write information to the Debug (Immediate) window
Option Compare Database
Option Explicit
' module: bas_ExecuteSQL_s4p
'*************** Code Start ***************************************************
' Purpose : execute SQL statements and report stats and time
' Author : crystal (strive4peace)
' Code List: www.msaccessgurus.com/code.htm
' LICENSE :
' You may freely use and share this code, but not sell it.
' Keep attribution. Mark your changes. Use at your own risk.
'--------------------------------------------------------------------------------
'--------------------------------------------------------------------------------
' module declarations
'--------------------------------------------------------------------------------
Dim moDb As DAO.Database
Dim mStart_Timer As Double _
,mDtmStart As Date
'-------------------------------------------------------------------------------
' ExecuteSQL_s4p
'-------------------------------------------------------------------------------
Function ExecuteSQL_s4p( _
sSql As String _
,Optional pDb As DAO.Database _
) As Long
'200920 strive4peace
On Error GoTo Proc_Err
Dim sgTimer1 As Single
'start timer
sgTimer1 = Timer
Debug.Print sSql
If pDb Is Nothing Then
If moDb Is Nothing Then
Set moDb = CurrentDb
End If
Set pDb = moDb
End If
With pDb
.Execute sSql
ExecuteSQL_s4p = .RecordsAffected
Debug.Print Space(5) & "----- " _
& .RecordsAffected & " records, " _
& Format(Timer - sgTimer1, "#,##0.##") & " seconds"
End With
Proc_Exit:
On Error Resume Next
Exit Function
Proc_Err:
Resume Proc_Exit
End Function
'--------------------------------------------------------------------------------
' Start_Time
'--------------------------------------------------------------------------------
'call this at the beginning of your program:
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Sub Start_Time(Optional pMsg)
On Error Resume Next
mStart_Timer = Timer()
mDtmStart = Now()
DoCmd.Hourglass True
Debug.Print "--- START-------------" _
& pMsg & " ----- " & CStr(mDtmStart)
End Sub
'--------------------------------------------------------------------------------
' EndTime
'--------------------------------------------------------------------------------
' call this in exit code
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Sub EndTime()
'call in Exit code when ReportElapsedTime is used to show message
On Error Resume Next
DoCmd.Hourglass False
SysCmd acSysCmdClearStatus
Debug.Print "End " & Format(Now(), "h:nn") & " ----"
Set moDb = Nothing
End Sub
'--------------------------------------------------------------------------------
' reportProgress
'--------------------------------------------------------------------------------
'if you want to report progress to the user periodically:
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Sub reportProgress( _
Optional pMsg As String = "" _
,Optional pDebug As Boolean = False)
'...230828
If Len(pMsg) > 0 Then
SysCmd acSysCmdSetStatus,pMsg & "..."
Else
SysCmd acSysCmdClearStatus
DoCmd.Hourglass False
End If
If pDebug = True Then
Debug.Print Now(); Tab(25); pMsg
End If
End Sub
'--------------------------------------------------------------------------------
' ReportElapsedTime
'--------------------------------------------------------------------------------
'tell the user how long everything took
'this is called when execution was good
' use MessageReportElapsed
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Function ReportElapsedTime( _
Optional ByVal pMessage As String = "" _
,Optional ByVal pTitle As String = "" _
) As String
' crystal (strive4peace) ... 100321... 220130, 220211, 230402
On Error Resume Next
ReportElapsedTime = ""
'turn off hourglass
DoCmd.Hourglass False
'clear status bar
SysCmd acSysCmdClearStatus
'release module db object if it was set
Set moDb = Nothing
Dim dbSeconds As Double _
,iMinutes As Integer _
,iHr As Integer
Dim sMsg As String _
,nEndTime As Date
If pMessage <> "" Then
pMessage = pMessage _
& vbCrLf & "-------------" _
& vbCrLf
End If
If DateValue(Date) = DateValue(mDtmStart) Then
dbSeconds = (Timer() - mStart_Timer)
Else
'assume just one day has passed
'seconds from yesterday + seconds today
dbSeconds = Timer - mStart_Timer + (24 * 60 * 60)
End If
nEndTime = Now()
If dbSeconds > 60 * 60 Then
sMsg = Format(dbSeconds / 60 / 60, "#,###.##") & " hours"
ElseIf dbSeconds > 60 Then
sMsg = Format(dbSeconds / 60, "#,###.##") & " minutes"
Else
sMsg = Format(dbSeconds, "#,###.##") & " seconds"
End If
sMsg = pMessage & "Start Time: " _
& Format(mDtmStart, "hh:nn:ss") & vbCrLf _
& " End Time: " & Format(nEndTime, "hh:nn:ss") & " --> " _
& " Elapsed Time: " & sMsg
MsgBox sMsg,_
,IIf(pTitle = "", "Time to execute ",pTitle)
ReportElapsedTime = pMessage
Debug.Print " " & pMessage
End Function
'*************** Code End *****************************************************
Goto Top
Standard module
mod_Query_Make_s4p
create or modify the SQL of a query
Option Compare Database
Option Explicit
' module name: mod_Query_Make_s4p
'*************** Code Start ***************************************************
' Purpose : make a query or change the SQL of a query
' Author : crystal (strive4peace)
' Code List: www.msaccessgurus.com/code.htm
' This code: https://msaccessgurus.com/VBA/Query_Make.htm
' LICENSE :
' You may freely use and share this code, but not sell it.
' Keep attribution. Mark your changes. Use at your own risk.
'--------------------------------------------------------------------------------
' module declarations
'--------------------------------------------------------------------------------
Dim moDb As DAO.Database
'--------------------------------------------------------------------------------
' Release_QueryMake
'--------------------------------------------------------------------------------
Public Sub Release_QueryMake()
Set moDb = Nothing
End Sub
'--------------------------------------------------------------------------------
' Query_Make_s4p
'--------------------------------------------------------------------------------
Sub Query_Make_s4p( _
ByVal qName As String _
,ByVal pSql As String _
,Optional pDb As DAO.Database _
)
'crystal (strive4peace) 220127, 220401 pDb
' if query already exists, update the SQL
' if not, create the query
On Error GoTo Proc_Err
Dim oQdf As QueryDef
If pDb Is Nothing Then
If moDb Is Nothing Then
Set moDb = CurrentDb
End If
Set pDb = moDb
End If
Debug.Print "Make Query: " & qName & vbCrLf & pSql
With pDb
'Query: Type = 5
If Nz(DLookup( "[Name]", "MSysObjects" _
, "[Name]='" & qName _
& "' And [Type]=5"), "") = "" Then
.CreateQueryDef qName,pSql
Else
'if query is open, close it
On Error Resume Next
DoCmd.Close acQuery,qName,acSaveNo
If Err.Number <> 0 Then 'is this needed?
DoEvents
End If
On Error GoTo Proc_Err
.QueryDefs(qName).SQL = pSql
End If
.QueryDefs.Refresh
'refresh database window
Application.RefreshDatabaseWindow
End With
Proc_Exit:
On Error GoTo 0
Exit Sub
Proc_Err:
MsgBox Err.Description,,_
"ERROR " & Err.Number & " Query_Make"
Resume Proc_Exit
'if you want to single-step code to find error, CTRL-Break at MsgBox
'then set this to be the next statement
Resume
End Sub
'*************** Code End *****************************************************
' Code was generated with colors using the free
Color Code add-in for Access
