VBA
Código detrás del formulario de menú, f_MENU_LoopLinkDocument
Especifique la ruta a la carpeta, si el bucle será recursivo (incluir subcarpetas) y el patrón para que coincida con los nombres de archivo.
Código de llamadas en módulos:
- mod_Office_Obtener_Carpeta_Obtener_Archivo_s4p
- mod_Archivo_LoopLinkCsvDocumento_Scripting_s4p
- mod_Consulta_Make_s4p
Option Compare Database Option Explicit ' cbf: f_MENU_LoopLinkDocument '*************** Code Start *************************************************** ' Purpose : code behind menu form to Loop, Link, and Document ' Author : crystal (strive4peace) ' Code List: ' This tool: ' 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 '-------------------------------------------------------------------------------- ' Form_Load '-------------------------------------------------------------------------------- Private Sub Form_Load() '230302 Me.txtFolder = CurrentProject.Path & "\Data" End Sub '-------------------------------------------------------------------------------- ' Form_Close '-------------------------------------------------------------------------------- Private Sub Form_Close() '230204 s4p Call ReleaseLoopLink End Sub '-------------------------------------------------------------------------------- ' 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 link to files in" ' Call GetFolder sFolder = GetFolder(sTitle) If sFolder = "" Then Exit Sub With Me 'folder path .txtFolder = sFolder End With End Sub '-------------------------------------------------------------------------------- ' cmdLoopLink_Click '-------------------------------------------------------------------------------- Private Sub cmdLoopLinkDocument_Click() '230127 s4p ... 230206, 230227, 230301 ' CALLs ' mod_File_LoopLinkCsvDocument_Scripting_s4p ' StartCountLoopLink ' LoopLinkPattern_s4p ' ReleaseLoopLink ' mod_Query_Make_s4p ' ReleaseQueryMake ' REPORT ' r_Documentation On Error GoTo Proc_Err Dim sSQL As String Dim db As DAO.Database _ ,rs As DAO.Recordset Dim iCountFile As Integer _ ,iCountQuery As Integer _ ,nAdd As Long _ ,nEdit As Long _ ,nTotalAdd As Long _ ,nTotalEdit As Long _ ,dtmStart As Date _ ,sMessage As String _ ,sPattern As String _ ,sQuery As String _ ,sPath As String _ ,bRecursive As Boolean dtmStart = Now() 'Call StartCountLoopLink -- reset file counter Call StartCountLoopLink With Me sPath = .txtFolder bRecursive = .chk_Recursive sPattern = .txtPattern .txtStart = dtmStart End With 'Call LoopLinkPattern_s4p -- and return iCountFile Call LoopLinkPattern_s4p(sPath,sPattern,bRecursive,iCountFile) 'get number of queries created iCountQuery = 0 sSQL = "SELECT count(*) as CalculatedRecordCount " _ & " FROM tFile AS F" _ & " WHERE(F.dtmAdd >=#" & dtmStart & "# )" _ & ";" Set db = CurrentDb Set rs = db.OpenRecordset(sSQL,dbOpenSnapshot) With rs iCountQuery = !CalculatedRecordCount End With sMessage = iCountFile & " files linked " _ & " in " & iCountQuery & " queries" If iCountFile iCountQuery Then sMessage = sMessage & vbCrLf & vbCrLf _ & " some of the corrected file names are duplicated. " _ & "To make sure the ones you want are linked, " _ & "run again on just the latest folder(s)" End If Debug.Print sMessage 'clear status bar SysCmd acSysCmdClearStatus 'release objects Call ReleaseLoopLink Call ReleaseQueryMake 'open r_Documentation report DoCmd.OpenReport "r_Documentation",acViewPreview _ ,, "dtmEdit >=#" & dtmStart & "#" _ ,,dtmStart Proc_Exit: On Error Resume Next 'release object variables If Not rs Is Nothing Then rs.Close Set rs = Nothing End If Set db = Nothing Exit Sub Proc_Err: MsgBox Err.Description,,_ "ERROR " & Err.Number _ & " cmdLoopLink_Click " Resume Proc_Exit Resume End Sub '*************** Code End *****************************************************
Ir al inicio
mod_Office_Obtener_Carpeta_Obtener_Archivo_s4p
Procedimientos:
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: ' 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 = False '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 '-------------------------------------------------------------------------------- ' GetFile '-------------------------------------------------------------------------------- Function GetFile( _ Optional psTitle As String = "Select File" _ ) As String 'return file path and name ' for example, C:\MyPath\filename.ext 'crystal, strive4peace 230227 ' REFERENCE for early binding ' Microsoft Office #.0 Object Library 'initialize return value GetFile = "" 'dimension FileDialog object #If IsEarly Then Dim fDialog As Office.FileDialog #Else Dim fDialog As Object #End If 'Set File Dialog. 3=msoFileDialogFilePicker Set fDialog = Application.FileDialog(3) 'set Title and GetFile With fDialog .Title = psTitle If .Show Then GetFile = .SelectedItems(1) End If End With 'release object Set fDialog = Nothing End Function
‘************* Fin del código *******************************************************
Ir al inicio
mod_Archivo_LoopLinkCsvDocumento_Scripting_s4p
Procedimientos:
- Patrón de enlace de bucle_s4p
- ObtenerPathIDNuevo
- Enlace de bucle de conteo de inicio
- EstablecerFso
- Enlace de bucle de liberación
El procedimiento principal es LoopLinkPattern_s4p. Es recursivo, lo que significa que puede llamarse a sí mismo. Llama al código del módulo:
Option Compare Database Option Explicit ' REFERENCE for early binding ' Microsoft Scripting Runtime ' scrrun.dll ' Scripting.FileSystemObject ' ' module: mod_File_LoopLinkCsvDocument_Scripting_s4p '*************** Code Start *************************************************** ' Purpose : procedures using the Microsoft Scripting Runtime library ' loop through files in a folder and optionally subfolders ' create queries ' document paths, files, fields ' Author : crystal (strive4peace) ' Code List: www.msaccessgurus.com/code.htm ' This tool: ' 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 = gIsEarly #If IsEarly Then 'early binding 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 Private moDb As DAO.Database Private mRsPath As DAO.Recordset _ ,mRsFile As DAO.Recordset _ ,mRsField As DAO.Recordset _ ,nRs As DAO.Recordset _ ,moQDF As DAO.QueryDef _ ,moField As DAO.Field Private miCountFile As Integer '-------------------------------------------------------------------------------- ' SetFso '-------------------------------------------------------------------------------- Public Sub SetFso() Set moFso = CreateObject( "Scripting.FileSystemObject") End Sub '-------------------------------------------------------------------------------- ' ReleaseLoopLink '-------------------------------------------------------------------------------- 'run when done to cleanup Public Sub ReleaseLoopLink() Set moFso = Nothing Set moDb = Nothing Set moField = Nothing Set moQDF = Nothing If Not mRsField Is Nothing Then mRsField.Close Set mRsField = Nothing End If 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 End Sub '-------------------------------------------------------------------------------- ' StartCountLoopLink '-------------------------------------------------------------------------------- 'run when start to initialize Public Sub StartCountLoopLink() miCountFile = 0 End Sub '-------------------------------------------------------------------------------- ' LoopLinkPattern_s4p '-------------------------------------------------------------------------------- Public Sub LoopLinkPattern_s4p(psPath As String _ ,Optional psFilePattern As String = "*.csv" _ ,Optional ByVal pbRecursive As Boolean = True _ ,Optional ByRef piCountFile As Integer _ ,Optional ByVal pnPathID As Long = -1 _ ) 'strive4peace ...230206, 230227, 230301, 2 'PARAMETERs ' psPath is folder to loop and link CSV files 'OPTIONAL ' psFilePattern is the file mask to match, default is "*.csv" ' pbRecursive = True to recurse ' RETURN piCountFile for number of files ' pnPathID 'CALLs ' SetFso ' GetPathIDNew ' itself if pbRecursive ' mod_GetQuery_LinkFile_s4p ' GetQuery_LinkFile_s4p On Error GoTo Proc_Err Dim sFilename As String _ ,sQueryname As String _ ,sFolderPath As String _ ,sExtension As String _ ,sSQL As String _ ,nPathID As Long _ ,nFileID As Long _ ,iNumFields As Integer _ ,nNumRecord As Long _ ,vListFields As Variant Const LengthLISTFields As Integer = 220 'field size If moFso Is Nothing Or moDb Is Nothing Then Call SetFso Set moDb = CurrentDb Set mRsPath = moDb.OpenRecordset( _ "tPath",dbOpenDynaset,dbAppendOnly) Set mRsFile = moDb.OpenRecordset( _ "tFile",dbOpenDynaset,dbAppendOnly) Set mRsField = moDb.OpenRecordset( _ "tField",dbOpenDynaset,dbAppendOnly) End If 'passed PathID If pnPathID Then 'path for top folder nPathID = GetPathIDNew(psPath) Else nPathID = pnPathID End If ' ---------------------------- Scripting.FileSystemObject With moFso 'RECURSIVE If pbRecursive False Then For Each moFolder In .GetFolder(psPath).SubFolders sFolderPath = moFolder.Path 'call GetPathIDNew pnPathID = GetPathIDNew(sFolderPath) 'call LoopLinkPattern_s4p, Recursively Call LoopLinkPattern_s4p(sFolderPath,psFilePattern _ ,True,,pnPathID) Next moFolder End If 'loop files in folder of FileSystemObject for CSV files ' or whatever pattern is specified For Each moFile In .GetFolder(psPath).Files sFilename = moFile.Name ' make sure filename matches pattern, ie: CSV file If sFilename Like psFilePattern Then 'call GetQuery_LinkFile_s4p 'RETURNS sExtension sQueryname = GetQuery_LinkFile_s4p(psPath _ ,sFilename _ ,sExtension) If sQueryname = "" Then GoTo Proc_NextFile End If 'store Path and File info With mRsFile .AddNew !PathID = nPathID !File_name = sFilename !FExt = sExtension !FSize = moFile.Size !FDateMod = moFile.DateLastModified !Qry_name = sQueryname .Update .Bookmark = .LastModified nFileID = !FileID miCountFile = miCountFile + 1 iNumFields = 0 nNumRecord = 0 'store field data for the query vListFields = Null moDb.QueryDefs.Refresh Set moQDF = moDb.QueryDefs(sQueryname) With mRsField For Each moField In moQDF.Fields iNumFields = iNumFields + 1 vListFields = (vListFields + ",") & moField.Name .AddNew !FileID = nFileID !Field_name = moField.Name !Field_type = moField.Type .Update Next moField End With 'mrsField sSQL = "SELECT count(*) as CountRecords " _ & " FROM " & sQueryname Set nRs = moDb.OpenRecordset(sSQL,dbOpenSnapshot) nNumRecord = nRs!CountRecords nRs.Close .Edit !NumField = iNumFields !NumRecord = nNumRecord 'truncate list of fields if it's too long !ListFields = Left(vListFields,LengthLISTFields) !dtmEdit = Now() .Update End With 'mrsFile End If 'sFilename Like psFilePattern Proc_NextFile: Next moFile End With 'moFso piCountFile = miCountFile Proc_Exit: On Error Resume Next Exit Sub Proc_Err: MsgBox Err.Description _ ,, "ERROR " & Err.Number _ & " LoopLinkPattern_s4p" Resume Proc_Exit Resume End Sub '-------------------------------------------------------------------------------- ' GetPathIDNew '-------------------------------------------------------------------------------- Function GetPathIDNew(psPath As String) As Long '230302 strive4peace 'add record to tPath and return the PathID With mRsPath .AddNew !Path_name = psPath .Update .Bookmark = .LastModified GetPathIDNew = !PathID End With End Function '*************** Code End *****************************************************
Ir al inicio
mod_Consulta_Make_s4p
Procedimientos:
- Consulta_Make_s4p
- Consulta de lanzamiento
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: ' 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 '-------------------------------------------------------------------------------- ' Query_Make_s4p '-------------------------------------------------------------------------------- Sub Query_Make_s4p( _ ByVal qName As String _ ,ByVal pSql As String _ ) 'crystal (strive4peace) 220127 ' if query already exists, update the SQL ' if not, create the query On Error GoTo Proc_Err If moDb Is Nothing Then Set moDb = CurrentDb End If With moDb '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 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 '-------------------------------------------------------------------------------- ' ReleaseQueryMake '-------------------------------------------------------------------------------- Public Sub ReleaseQueryMake() Set moDb = Nothing End Sub '*************** Code End *****************************************************
Ir al inicio
mod_Obtener_archivo_de_enlace_consulta_s4p
Necesita módulos:
- mod_NombreCorrecto_s4p
- mod_GetSQL_LinkCsv_s4p
- mod_Archivo_EliminarUTF8bom_s4p
- mod_Consulta_Make_s4p
Option Compare Database Option Explicit 'module: mod_GetQuery_LinkFile_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: ' this code has been slightly modified from what's posted ' LICENSE : ' You may freely use and share this code, but not sell it. ' Keep attribution. Mark your changes. Use at your own risk. '-------------------------------------------------------------------------------- ' GetQuery_LinkFile_s4p '-------------------------------------------------------------------------------- Public Function GetQuery_LinkFile_s4p( _ psPath As String _ ,psFilename As String _ ,psExtension As String _ ,Optional ByRef pbStripBOM As Boolean = False _ ) As String 'return the name of the query that was created or modified 'return pbStripBOM 'return psExtension '230121, 27 s4p, 230205-6, 230228, 230301 'CALLs ' mod_CorrectName_s4p ' CorrectName_s4p ' mod_GetSQL_LinkCsv_s4p ' GetSQL_LinkCsv_s4p ' mod_File_RemoveUTF8bom_s4p ' TextFileStripBOM_s4p ' mod_Query_Make_s4p ' Query_Make_s4p 'initialize return value GetQuery_LinkFile_s4p = "" Dim sSQL As String _ ,sQueryname As String _ ,sPathFile As String _ ,sFieldname As String _ ,iPos As Integer _ ,bRemoveBOM As Boolean GetQuery_LinkFile_s4p = "" '--------------------- customize if desired 'test for UTF-8 Unicode BOM bRemoveBOM = True 'create the query name iPos = InStrRev(psFilename, ".") psExtension = Right(psFilename _ ,Len(psFilename) - iPos) sQueryname = "qLink_" _ & psExtension & "_" _ & CorrectName_s4p( _ Left(psFilename,iPos - 1)) '--------------------- Select Case psExtension Case "CSV", "TXT" 'call GetSQL_LinkCsv_s4p sSQL = GetSQL_LinkCsv_s4p(psPath,psFilename) 'remove BOM unicode indicator if there If bRemoveBOM Then 'combine Path and File sPathFile = psPath _ & IIf(Right(psPath,1) "\", "\", "") _ & psFilename 'strip BOM (byte order mark) from beginning of file for UTF-8 'call TextFileStripBOM_s4p If TextFileStripBOM_s4p(sPathFile) False Then 'file was modified pbStripBOM = True End If End If Case Else ' MsgBox "Don't know what to do with " & psExtension & " file" _ ,, "Need VBA CodE IN GetQuery_LinkFile_s4p" 'skip this file Exit Function End Select 'create or overwite query 'call Query_Make_s4p Call Query_Make_s4p(sQueryname,sSQL) Debug.Print sQueryname,Format(pbStripBOM, "0") GetQuery_LinkFile_s4p = sQueryname End Function '*************** Code End *****************************************************
Ir al inicio
mod_NombreCorrecto_s4p
Option Compare Database Option Explicit ' module name: mod_CorrectName_s4p '*************** Code Start *************************************************** ' Purpose : replace unwanted characters in string with underscore (_) ' Author : crystal (strive4peace) ' Code List: www.msaccessgurus.com/code.htm ' This code: ' LICENSE : ' You may freely use and share this code, but not sell it. ' Keep attribution. Mark your changes. Use at your own risk. '-------------------------------------------------------------------------------- ' CorrectName_s4p '--------------------------------------------------------------------------------' Function CorrectName_s4p( _ ByVal psName As String _ ) As String 'strive4peace 221223, 230129 ' replace spaces and unwanted characters with underscore _ ' if 2 in a row, only use 1 ' trim beginning and end Dim i As Integer _ ,sName As String _ ,sChar As String * 1 _ ,sLastChar As String * 1 _ ,sNewChar As String * 1 _ ,iPos As Integer 'PARAMETERS 'psName is the string you want to correct 'EXAMPLE USEAGE ' on the AfterUpdate event of a control ' =CorrectName((controlname)) ' 'in a query: 'field --> CorrectName: CorrectName_s4p((strFieldname)) 'EXAMPLE ' ? CorrectName_s4p("as(,48209j@##@!") ' --> as_48209j_ CorrectName_s4p = "" If psName = "" Then Exit Function Dim sBadCharacters As String sBadCharacters = "`!@#$%^&*()+-=|\:;""',.?/ " psName = Trim(psName) For i = 1 To Len(psName) sChar = Mid(psName,i,1) If InStr(sBadCharacters,sChar) > 0 Then sNewChar = "_" Else sNewChar = sChar End If If sLastChar = "_" And sNewChar = "_" Then 'leave the same for multiple characters to replace in a row Else sName = sName & sNewChar End If sLastChar = sNewChar Next i CorrectName_s4p = sName End Function '*************** Code End *****************************************************
Ir al inicio
mod_Archivo_EliminarUTF8bom_s4p
Cuando los datos se almacenan en formato UTF-8, hay una marca de orden de bytes al principio que aparece como 3 caracteres impares, por lo que este código los elimina. La mayoría de las veces, no se necesita soporte adicional. Si necesita que los archivos permanezcan en formato UTF-8, puede vincularlos con tablas. Sin embargo, no pude encontrar una manera de especificar UTF-8 en la cadena de conexión para las consultas.
Option Compare Database Option Explicit ' module name: mod_File_RemoveUTF8bom_s4p '*************** Code Start *************************************************** ' Purpose : strip  from beinning of file contents ' Author : crystal (strive4peace) ' Code List: www.msaccessgurus.com/code.htm ' This code: ' LICENSE : ' You may freely use and share this code, but not sell it. ' Keep attribution. Mark your changes. Use at your own risk. '-------------------------------------------------------------------------------- ' TextFileStripBOM_s4p '--------------------------------------------------------------------------------' Public Function TextFileStripBOM_s4p( _ psPathFile As String _ ) As Boolean '230127 strive4peace ' strip UTF-8 BOM (byte order mark)  ' from beginning of file 'Return ' False if no change made to file ' True if file was changed TextFileStripBOM_s4p = False Dim iFile As Integer _ ,sFileContents As String _ ,s3 As String 'get a numeric file handle to refer to the file iFile = FreeFile 'open the file for reading Open psPathFile For Input As iFile 'get first 3 characters of file s3 = Input(3,iFile) 'see if there is a marker for UTF-8 If s3 "" Then 'no changes to file GoTo Proc_Exit End If 'get rest of file sFileContents = Input(LOF(iFile) - 3,iFile) Close iFile 'over-write file without BOM characters Open psPathFile For Output As iFile Print #iFile,sFileContents 'indicate that a change to the file was made TextFileStripBOM_s4p = True Proc_Exit: On Error Resume Next Close iFile Exit Function Proc_Err: MsgBox Err.Description _ ,, "ERROR " & Err.Number _ & " TextFileStripBOM_s4p" Resume Proc_Exit Resume End Function '-------------------------------------------------------------------------------- ' testTextFileStripBOM_s4p '--------------------------------------------------------------------------------' Sub testTextFileStripBOM_s4p() '230127 s4p test TextFileStripBOM_s4p 'CALLs ' TextFileStripBOM_s4p Dim sPath As String _ ,sFile As String _ ,sPathFile As String sPath = "C:\MyPath" '------------ customize sFile = "Filename.csv" '------------ customize sPathFile = sPath _ & IIf(Right(sPath,1) "\", "\", "") _ & sFile ' Call TextFileStripBOM_s4p(sPathFileIn, sPathFileOut) MsgBox TextFileStripBOM_s4p(sPathFile),, "Done" End Sub '*************** Code End *****************************************************
Ir al inicio
mod_GetSQL_LinkCsv_s4p
Option Compare Database Option Explicit ' module name: mod_GetSQL_LinkCsv_s4p '*************** Code Start *************************************************** ' Purpose : Function to create and return SQL to link to a CSV file ' Author : crystal (strive4peace) ' Code List: www.msaccessgurus.com/code.htm ' This code: ' LICENSE : ' You may freely use and share this code, but not sell it. ' Keep attribution. Mark your changes. Use at your own risk. ' Then use the SQL to create a saved query or to open a recordset '-------------------------------------------------------------------------------- ' GetSQL_LinkCsv_s4p '--------------------------------------------------------------------------------' Public Function GetSQL_LinkCsv_s4p( _ psPath As String _ ,psFilename As String _ ) As String '230131 strive4peace Dim sConnect As String sConnect = "(Text;DATABASE=" _ & psPath _ & ").(" & psFilename _ & ")" GetSQL_LinkCsv_s4p = "SELECT Q.* FROM " & sConnect & " as Q;" End Function '-------------------------------------------------------------------------------- ' testSQL_LinkCsv_s4p '--------------------------------------------------------------------------------' Sub testGetSQL_LinkCsv_s4p() Dim sPath As String _ ,sFile As String _ ,sSQL As String sPath = "C:\MyPath" '------------ customize sFile = "MyFilename.csv" '------------ customize 'Call GetSQL_LinkCsv_s4p sSQL = GetSQL_LinkCsv_s4p(sPath,sFile) MsgBox sSQL,, "done" End Sub '*************** Code End *****************************************************
Ir al inicio
Código detrás del informe r_Documentation
Este informe muestra datos en las tablas tPath, tFile y tField. Esta información se crea durante el proceso de bucle y enlace.
Las sumas corrientes se utilizan para contar los archivos en cada ruta y para todo el informe.
Cuando se filtra un informe mediante el formulario de menú, la fecha y hora de inicio se informa en el encabezado de la página.
'cbr: r_Documentation '*************** Code Start *************************************************** ' Purpose : show data structure information for queries ' Author : crystal (strive4peace) ' Code List: www.msaccessgurus.com/code.htm ' This tool: ' LICENSE : ' You may freely use and share this code, but not sell it. ' Keep attribution. Mark your changes. Use at your own risk. '-------------------------------------------------------------------------------- ' Report_Load '-------------------------------------------------------------------------------- Private Sub Report_Load() '230228 strive4peace, 230302 Dim sAsOf As String With Me If Not IsNull(.OpenArgs) Then sAsOf = "as of " & .OpenArgs End If .Label_AsOf.Caption = sAsOf End With End Sub '-------------------------------------------------------------------------------- ' GroupFooter0_Format for Path '-------------------------------------------------------------------------------- Private Sub GroupFooter0_Format( _ Cancel As Integer,FormatCount As Integer) 'path footer Me.txtCountFilePath = Me.txtRunSumPath End Sub '-------------------------------------------------------------------------------- ' GroupFooter3_Format for Report '-------------------------------------------------------------------------------- Private Sub GroupFooter3_Format( _ Cancel As Integer,FormatCount As Integer) 'report footer Me.txtCountFileReport = Me.txtRunSumReport End Sub '*************** Code End *****************************************************
‘El código se generó con colores utilizando el complemento gratuito Color Code para Access.
