VBA
código detrás del formulario de menú, f_MENU_ListObjects_LoopFiles_s4p
El formulario de menú le permite especificar o buscar una ruta que contenga una o más bases de datos para las que desea incluir objetos. Cambie las casillas de verificación de Recursivo y Contar registros si lo desea y, a continuación, haga clic en Aceptar.
El código recorre cada base de datos de Access en la ruta y también sus subcarpetas, si lo desea. A medida que se ejecuta el programa, verá dónde se encuentra en el cuadro de progreso.
Una vez finalizado el programa, puede obtener resultados en forma de informes, consultas o escribir sus propias consultas. Cada vez que se ejecuta, se asigna un nuevo BatchID. También puede elegir un Batch anterior para ejecutar informes y consultas. Es posible que las consultas le resulten más útiles.
Especifique criterios para abrir consultas e informes de archivos y objetos. Si especifica un patrón, se aplicará al nombre de archivo para el informe o consulta de archivos o al nombre de objeto para el informe o consulta de objetos. Si no se incluye ningún comodín ? o * en el patrón, se agregará * al principio y al final del patrón.
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 : ' This tool: /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 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 *****************************************************
Ir al inicio
Módulo estándar
mod_ListObjects_LoopFiles_s4p
DocumentAccessObjects_Recursive_s4p es recursivo
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 : ' This tool: /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 '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 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)" _ & ", " & 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 *****************************************************
Ir al inicio
Módulo estándar
mod_Office_ObtenerCarpeta_s4p
Busque una carpeta usando Office.FileDialog en la biblioteca de objetos de Microsoft Office #.0
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: /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 *****************************************************
Ir al inicio
Módulo estándar
bas_EjecutarSQL_s4p
ejecutar sentencias SQL, escribir información en la ventana Depurar (Inmediato)
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 *****************************************************
Ir al inicio
Módulo estándar
mod_Consulta_Make_s4p
crear o modificar el SQL de una consulta
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: /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 *****************************************************
‘ El código se generó con colores utilizando el complemento gratuito Color Code para Access
