by John Thatcher / Tele - Data Services (1 Submission)
Category: Files/File Controls/Input/Output
Compatability: VB 6.0
Difficulty: Unknown Difficulty
Originally Published: Wed 19th December 2001
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
The ImportTXTFilesToTables function Copies all files in a specified Dir to a temp Dir, renames them as *.txt, then imports Into Microsoft
API Declarations
Public Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
' Used in the NetWorkUser function
Public Declare Function Wnetgetuser Lib "mpr" Alias "WNetGetUserA" (ByVal lpName As String, ByVal lpUserName As String, lpnLength As Long) As Long
VBcoders
'##############################################################################################################################
' The ImportTXTFilesToTables function Copies all files in a specified Dir to a temp Dir, renames them as *.txt, then imports
' Into access calling the appropriate import specs. Then Runs Sql to append them into the CallsHistory table, then deletes
' the temp table, then deletes the *.txt file.
'
' Source: Location (Folder) Where files are located.
' TempDir: The folder where files will temporarily be located.
' CurrentFileExt: The file extension of the files to be imported NOTE: Must Be A Text File, Regardless Of Extension.
' ImportInto: The name of the table that the text files will be imported into. NOTE: The table must already exist.
' ImportSpecName: The name of the Import Specifications that you will use.
' SearchString: OPTIONAL: A string within the filename to help limit the found files.
' DeleteOrigional: OPTIONAL: True / False: Determins if the origional file should be deleted or not. Default is False
'
' Usage:
' Call ImportTXTFilesToTables("\\Beta\f\TAMMS\MSGS\History\M12132001", "C:\TempMXGFiles", "MXG", "CallsHistory", "CallsImport", "2333", False)
'##############################################################################################################################
Public Function ImportTXTFilesToTables(Source As String, TempDir As String, CurrentFileExt As String, ImportInto As String, ImportSpecName As String, Optional SearchString As String, Optional DeleteOrigional As Boolean)
On Error Resume Next
DoCmd.SetWarnings (False)
Dim filesys, demofolder, fil, filecoll, filist, FileName As String, OldName As String, NewName As String, TableName As String
If Len(DeleteOrigional) < 1 Then DeleteOrigional = False
Set filesys = CreateObject("Scripting.FileSystemObject")
Set demofolder = filesys.GetFolder(Source)
Set filecoll = demofolder.Files
MkDir TempDir
For Each fil In filecoll
If InStr(fil.Name, "." & CurrentFileExt) > 0 Then
If Len(DNIS) > 0 Then
If InStr(fil.Name, SearchString) = 1 Then
OldName = Source & "\" & fil.Name
NewName = TempDir & "\" & Left(fil.Name, InStr(fil.Name, ".") - 1) & ".txt"
TableName = Left(fil.Name, (InStr(fil.Name, ".") - 1))
FileCopy OldName, NewName
DoCmd.TransferText acImportDelim, ImportSpecName, TableName, NewName, False
Sql = "INSERT INTO " & ImportInto & " SELECT [" & TableName & "].* FROM " & TableName & ";"
DoCmd.RunSQL Sql
DoCmd.DeleteObject acTable, TableName
If DeleteOrigional = True Then
Kill OldName
End If
Kill NewName
End If
Else
OldName = Source & "\" & fil.Name
NewName = TempDir & "\" & Left(fil.Name, InStr(fil.Name, ".") - 1) & ".txt"
TableName = Left(fil.Name, (InStr(fil.Name, ".") - 1))
FileCopy OldName, NewName
DoCmd.TransferText acImportDelim, ImportSpecName, TableName, NewName, False
Sql = "INSERT INTO " & ImportInto & " SELECT [" & TableName & "].* FROM " & TableName & ";"
DoCmd.RunSQL Sql
DoCmd.DeleteObject acTable, TableName
If DeleteOrigional = True Then
Kill OldName
End If
Kill NewName
End If
End If
Next
DoCmd.SetWarnings (True)
End Function
'##############################################################################################################################
' The Pause function pauses the program for a specified number of seconds
'##############################################################################################################################
Public Function Pause(PauseTimeInSeconds As Double)
Dim PauseTime, Start, Finish, TotalTime
PauseTime = PauseTimeInSeconds
Start = Timer
Do While Timer < Start + PauseTime
DoEvents
Loop
Finish = Timer
TotalTime = Finish - Start
End Function
'##############################################################################################################################
' The ListFiles function returns an array of all files in a specified folder with a specified Ext.
'##############################################################################################################################
Public Function ListFiles(PathLocation As String, FileType As String) As Variant
Dim fs As FileSearch, i As Long, FileCount As Long
Dim MyArray()
Set fs = Application.FileSearch
With fs
fs.LookIn = PathLocation
fs.FileName = "*." & FileType
If fs.Execute(SortBy:=msoSortByFileName, SortOrder:=msoSortOrderAscending) > 0 Then
FileCount = .FoundFiles.count
ReDim MyArray(FileCount)
For i = 1 To FileCount
MyArray(i) = .FoundFiles(i)
Next i
End If
End With
ListFiles = MyArray
End Function
'##############################################################################################################################
' The ListDirs function Lists all the Subfolders of a specified Directory NOTE: This only returns the first level of folders.
'##############################################################################################################################
Sub ListDirs(RootPath As String)
Dim filesys, ThisFolder, folcoll, folist, subfol
Set filesys = CreateObject("Scripting.FileSystemObject")
Set ThisFolder = filesys.GetFolder(RootPath)
Set folcoll = ThisFolder.SubFolders
For Each subfol In folcoll
Debug.Print ThisFolder & "\" & subfol.Name
Next
End Sub
'##############################################################################################################################
' The NetWorkUser function returns the network Username of the current user
'##############################################################################################################################
Public Function NetWorkUser() As String
Static strUser As String
Dim lpUserName As String * 64
If Wnetgetuser("", lpUserName, Len(lpUserName)) Then
strUser = CurrentUser()
Else
strUser = Left(lpUserName, InStr(lpUserName, Chr(0)) - 1)
End If
NetWorkUser = strUser
End Function
'##############################################################################################################################
' The Get_ComputerName function returns the name of the current users computer
'##############################################################################################################################
Function Get_ComputerName()
Dim lpBuff As String * 25
Dim ret As Long, ComputerName As String
ret = GetComputerName(lpBuff, 25)
ComputerName = Left(lpBuff, InStr(lpBuff, Chr(0)) - 1)
Get_ComputerName = ComputerName
End Function
'##############################################################################################################################
' The Replace function replaces one string with another. You can replace a single character, or
' as many characters as you want to.
' CheckString : The string that contains the data that is to be replaced.
' ReplaceWhat : The Sub string or characters that need to be replaced.
' ReplaceWith : The new Character or string
'##############################################################################################################################
Public Function Replace(ByVal CheckString As String, ByVal ReplaceWhat As String, ByVal ReplaceWith As String) As String
Dim i As Long
Dim strTemp As String
i = 1
Do While InStr(i, CheckString, ReplaceWhat, vbTextCompare) <> 0
strTemp = strTemp & Mid(CheckString, i, InStr(i, CheckString, ReplaceWhat, vbTextCompare) - i) & ReplaceWith
i = InStr(i, CheckString, ReplaceWhat, vbTextCompare) + Len(ReplaceWhat)
Loop
strTemp = strTemp & Right(CheckString, Len(strString) - i + 1)
Replace = strTemp
End Function
'##############################################################################################################################
' The MySplit function spilts a string (with a delimiter) into an array.
'##############################################################################################################################
Function VBASplit(VariableToSplit As String, CharacterToSplitOn As String) As Variant
Dim Splitter As String, MainString As String, Pos1 As Long, TempLeftString As String
Dim StringArray() As Variant, Counter As Double
MainString = VariableToSplit
Splitter = CharacterToSplitOn
Counter = 0
Do Until Len(MainString) = 0
Pos1 = InStr(MainString, Splitter)
If Pos1 > 0 Then
TempLeftString = Left(MainString, Pos1)
TempLeftString = Replace(TempLeftString, Splitter, "")
ReDim Preserve StringArray(Counter)
StringArray(Counter) = Trim(TempLeftString)
MainString = Right(MainString, (Len(MainString) - Pos1))
Counter = Counter + 1
Else
ReDim Preserve StringArray(Counter)
StringArray(Counter) = Trim(MainString)
MainString = ""
End If
Loop
VBASplit = StringArray()
End Function
'##############################################################################################################################
' The MakeQuery function creates a MS. Access query object dynamically
'##############################################################################################################################
Public Function MakeQuery(QueryName As String, SqlStatement As String)
Dim db As Database, qd As QueryDef
Set db = CurrentDb
db.QueryDefs.Refresh
For Each qd In db.QueryDefs
If qd.Name = QueryName Then
db.QueryDefs.Delete QueryName
End If
Next qd
If IsNull(SqlStatement) = False Then
Set qd = db.CreateQueryDef(QueryName, SqlStatement)
Else
MsgBox "Warning There is no Query data for the query " & QueryName & ".", vbCritical
End If
Set qd = Nothing
Set db = Nothing
End Function
'##############################################################################################################################
' The ListFields function returns an array of all the fields in a specified Access database and table
'##############################################################################################################################
Public Function ListFields(DBLocation As String, TableName As String) As Variant
Dim db As Database, tdf As TableDef, fld As Field, MyArray()
Dim ArrayCount As Long, count As Long
Set db = OpenDatabase(DBLocation)
Set tdf = db.TableDefs!TableName
count = 0
For Each fld In tdf.Fields
count = count + 1
Next fld
ReDim MyArray(count)
count = 0
For Each fld In tdf.Fields
count = count + 1
MyArray(count) = fld.Name
Next fld
Set db = Nothing
ListFields = MyArray
End Function
'##############################################################################################################################
' The DoesFieldExist function Returns True if a specified field exists in a specified Access database and table
'##############################################################################################################################
Public Function DoesFieldExist(FieldName As String, DBNameAndLocation As String, TableName As String) As Boolean
Dim MyTest As Variant, ArrayCount As Long, n As Long
MyTest = ListFields(DBNameAndLocation, TableName)
ArrayCount = UBound(MyTest)
DoesFieldExist = False
For n = 1 To ArrayCount
If MyTest(n) = FieldName Then
DoesFieldExist = True
Exit Function
End If
Next n
End Function
'##############################################################################################################################
' The DoesTableExist function Returns True if a specified table exists in a specified Access database
'##############################################################################################################################
Public Function DoesTableExist(TableName As String, DBNameAndLocation As String) As Boolean
Dim db As Database
Dim TblName As TableDef
Set db = OpenDatabase(DBNameAndLocation)
DoesTableExist = False
For Each TblName In db.TableDefs
If TblName.Name = TableName Then
DoesTableExist = True
Exit Function
End If
Next TblName
End Function
'##############################################################################################################################
' The GetFileExtension function Returns The Extension (Everything to the right of the dot) of a file.
'##############################################################################################################################
Public Function GetFileExtension(FileName As String)
If InStr(FileName, ".") > 0 Then
GetFileExtension = Right(FileName, (Len(FileName) - InStr(FileName, ".")))
Else
GetFileExtension = ""
End If
End Function
'##############################################################################################################################
' The OpenPasswordProtertiesSheet function Opens the Password Properties Dialog Box.
'##############################################################################################################################
Public Sub OpenPasswordProtertiesSheet()
Shell "rundll32.exe shell32.dll,Control_RunDLL password.cpl", 1
End Sub
'##############################################################################################################################
' The convertSecondsToHoursAndMinutes function Convert specified number of seconds to 'HH:MM:SS' Format
'##############################################################################################################################
Public Function convertSecondsToHoursAndMinutes(NumberOfSeconds As Double) As String
Dim MySeconds As Double, MyMinutes As Double, MyHours As Double, MyTime As String
MySeconds = NumberOfSeconds
Do Until MySeconds < 60
MySeconds = (MySeconds - 60)
MyMinutes = (MyMinutes + 1)
Loop
Do Until MyMinutes < 60
MyMinutes = (MyMinutes - 60)
MyHours = (MyHours + 1)
Loop
If MyHours < 10 Then
MyTime = "0" & CStr(MyHours)
Else
MyTime = CStr(MyHours)
End If
If MyMinutes < 10 Then
MyTime = MyTime & ":0" & CStr(MyMinutes)
Else
MyTime = MyTime & ":" & CStr(MyMinutes)
End If
If MySeconds < 10 Then
MyTime = MyTime & ":0" & CStr(MySeconds)
Else
MyTime = MyTime & ":" & CStr(MySeconds)
End If
convertSecondsToHoursAndMinutes = MyTime
End Function
No comments have been posted about The ImportTXTFilesToTables function Copies all files in a specified Dir to a temp Dir, renames them. Why not be the first to post a comment about The ImportTXTFilesToTables function Copies all files in a specified Dir to a temp Dir, renames them.
