• Home
 · 
• Files/File Controls/Input/Output
 · 
• The ImportTXTFilesToTables function Copies all files in a specified Dir to a temp Dir, renames them

The ImportTXTFilesToTables function Copies all files in a specified Dir to a temp Dir, renames them

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





Rate The ImportTXTFilesToTables function Copies all files in a specified Dir to a temp Dir, renames them

• 1
• 2
• 3
• 4
• 5

(1(1 Vote))

'##############################################################################################################################
' 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