VBA
Code behind menu form, f_MENU_LoopLinkDocument
Specify path to folder,
whether looping will be recursive (include subfolders)
and pattern to match filenames.
Calls code in modules:
- mod_Office_GetFolder_GetFile_s4p
- mod_File_LoopLinkCsvDocument_Scripting_s4p
- mod_Query_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: https://msaccessgurus.com/code.htm
' This tool: https://msaccessgurus.com/tool/LoopLinkDocument.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
'--------------------------------------------------------------------------------
' 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 *****************************************************
Goto Top
mod_Office_GetFolder_GetFile_s4p
Procedures:
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 = 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
'*************** Code End *****************************************************
Goto Top
mod_File_LoopLinkCsvDocument_Scripting_s4p
Procedures:
- LoopLinkPattern_s4p
- GetPathIDNew
- StartCountLoopLink
- SetFso
- ReleaseLoopLink
The Main procedure is LoopLinkPattern_s4p.
It's recursive, meaning it can call itself.
Calls code in module:
Option Compare Database
Option Explicit
' REFERENCE for early binding
' Microsoft Scripting Runtime
' scrrun.dll
' Scripting.FileSystemObject
' https://learn.microsoft.com/en-us/office/vba/language/reference/user-interface-help/filesystemobject-object
' 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: https://msaccessgurus.com/tool/LoopLinkDocument.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 = 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 < 0 to add Path record and get new PathID
'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 < 0 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 *****************************************************
Goto Top
mod_Query_Make_s4p
Procedures:
- Query_Make_s4p
- ReleaseQueryMake
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
'--------------------------------------------------------------------------------
' 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 *****************************************************
Goto Top
mod_GetQuery_LinkFile_s4p
Needs modules:
- mod_CorrectName_s4p
- mod_GetSQL_LinkCsv_s4p
- mod_File_RemoveUTF8bom_s4p
- mod_Query_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: https://msaccessgurus.com/VBA/GetQuery_LinkCsv.htm
' 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 *****************************************************
Goto Top
mod_CorrectName_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: https://msaccessgurus.com/VBA/Fx_CorrectName.htm
' 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 *****************************************************
Goto Top
mod_File_RemoveUTF8bom_s4p
When data is stored in UTF-8 format,
there is a byte order mark at the beginning
that comes across as 3 odd characters, 
so this code strips them away.
Most of the time, the extra support isn't needed.
If you do need the files to stay in UTF-8,
you can link to them with tables.
I couldn't find a way, however,
to specify UTF-8 in the connect string for queries.
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: https://msaccessgurus.com/VBA/File_RemoveUTF8bom.htm
' 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 *****************************************************
Goto Top
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: https://msaccessgurus.com/VBA/GetSQL_LinkCsv.htm
' 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 *****************************************************
Goto Top
code behind report r_Documentation
This report shows data in the
tPath, tFile, and tField tables.
This information is created
during the loop and link process.
Running sums are used to count the files
in each path and for the whole report.
When a report is filtered by the menu form,
the As Of date/time is reported in the page header.
'cbr: r_Documentation
'*************** Code Start ***************************************************
' Purpose : show data structure information for queries
' Author : crystal (strive4peace)
' Code List: www.msaccessgurus.com/code.htm
' This tool: https://msaccessgurus.com/VBA/LoopLinkDocument.htm
' 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 *****************************************************
' Code was generated with colors using the free
Color Code add-in for Access.
