DEVelopers HUT

Function ImportDirListing(strPath As String, Optional strFilter As String)
' Author: CARDA Consultants Inc, 2007-01-19
' Copyright : The following may be altered and reused as you wish so long as the
'             copyright notice is left unchanged (including Author, Website and
'             Copyright).  It may not be sold/resold or reposted on other sites (links
'              back to this site are allowed).
'
' strPath = full path include trailing  ie:"c:windows"
' strFilter = extension of files ie:"pdf".  if you want to return
'             a complete listing of all the files enter a value of
'             "*" as the strFilter
On Error GoTo Error_Handler
 
Dim MyFile  As String
Dim db      As Database
Dim sSQL    As String
 
Set db = CurrentDb()
 
'Add the trailing  if it was omitted
If Right(strPath, 1) <> "" Then strPath = strPath & ""
'Modify the strFilter to include all files if omitted in the function
'call
If strFilter = "" Then strFilter = "*"
 
'Loop through all the files in the directory by using Dir$ function
MyFile = Dir$(strPath & "*." & strFilter)
Do While MyFile <> ""
    'Debug.Print MyFile
    sSQL = "INSERT INTO [YourTableName] (YourTableFieldName) VALUES(""" & MyFile & """)"
    db.Execute sSQL, dbFailOnError
    'dbs.RecordsAffected 'could be used to validate that the
                                    'query actually worked
    MyFile = Dir$
Loop
 
Error_Handler_Exit:
    On Error Resume Next
    Set db = Nothing
    Exit Function
 
Error_Handler:
    MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: ImportDirListing" & vbCrLf & _
           "Error Description: " & Err.Description, vbCritical, _
           "An Error has Occured!"
    Resume Error_Handler_Exit
End Function

'---------------------------------------------------------------------------------------
' Procedure : DoesTblFieldExist
' Author    : CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Determine if a field exists with the specified table
' Copyright : The following may be altered and reused as you wish so long as the
'             copyright notice is left unchanged (including Author, Website and
'             Copyright).  It may not be sold/resold or reposted on other sites (links
'             back to this site are allowed).
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sTableName: Name of the table to check the existance of the field in
' sFieldName: Name of the field to check the existance of
'
' Usage Example:
' ~~~~~~~~~~~~~~~~
' DoesTblFieldExist("Table1","Field1")
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2010-Feb-02             Initial Release
'---------------------------------------------------------------------------------------
Function DoesTblFieldExist(sTableName As String, sFieldName As String) As Boolean
   Dim db            As DAO.Database
   Dim tdf           As TableDef
   Dim I             As String
   Dim bTableExists  As Boolean
 
On Error GoTo Error_Handler
   'Initialize our variables
   DoesTblFieldExist = False
   bTableExists = False
 
   Set db = CurrentDb()
   Set tdf = db.TableDefs(sTableName)
 
   bTableExists = True  'If we made it to here without triggering an error
                        'the table exists
  
   I = tdf.Fields(sFieldName).Name
 
   DoesTblFieldExist = True   'If we made it to here without triggering an
                              'error the table field exists

Error_Handler_Exit:
   On Error Resume Next
   Set tdf = Nothing
   Set db = Nothing
   Exit Function
 
Error_Handler:
   If Err.Number = 3265 And bTableExists = False Then
      'Table not found in the current database
      MsgBox "The specified Table could not be found in the current database", vbCritical
   ElseIf Err.Number = 3265 And bTableExists = True Then
      'Field not found in the specified table
     
   Else
      MsgBox "MS Access has generated the following error" & vbCrLf & vbCrLf & "Error Number: " & _
      Err.Number & vbCrLf & "Error Source: DoesTblFieldExist" & vbCrLf & "Error Description: " & _
      Err.Description, vbCritical, "An Error has Occured!"
   End If
   Resume Error_Handler_Exit
End Function

'---------------------------------------------------------------------------------------
' Procedure : DoesTblExist
' Author    : CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Determine if the specified table exists or not in the current database
' Copyright : The following may be altered and reused as you wish so long as the
'             copyright notice is left unchanged (including Author, Website and
'             Copyright).  It may not be sold/resold or reposted on other sites (links
'             back to this site are allowed).
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sTableName: Name of the table to check the existance of
'
' Usage Example:
' ~~~~~~~~~~~~~~~~
' DoesTblExist("Table1")
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2010-Feb-02             Initial Release
'---------------------------------------------------------------------------------------
Function DoesTblExist(sTableName As String) As Boolean
   Dim db   As DAO.Database
   Dim tdf  As TableDef
 
On Error GoTo Error_Handler
   'Initialize our variable
   DoesTblExist = False
 
   Set db = CurrentDb()
   Set tdf = db.TableDefs(sTableName)
 
   DoesTblExist = True  'If we made it to here without triggering an error
                        'the table exists

Error_Handler_Exit:
   On Error Resume Next
   Set tdf = Nothing
   Set db = Nothing
   Exit Function
 
Error_Handler:
   If Err.Number = 3265 Then
      'If we are here it is because the table could not be found
   Else
      MsgBox "MS Access has generated the following error" & vbCrLf & vbCrLf & "Error Number: " & _
      Err.Number & vbCrLf & "Error Source: DoesTblExist" & vbCrLf & "Error Description: " & _
      Err.Description, vbCritical, "An Error has Occured!"
   End If
   Resume Error_Handler_Exit
End Function

'---------------------------------------------------------------------------------------
' Procedure : ImportAllTbls
' Author    : CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Import all the tables from an external Access database
' Copyright : The following may be altered and reused as you wish so long as the
'             copyright notice is left unchanged (including Author, Website and
'             Copyright).  It may not be sold/resold or reposted on other sites (links
'             back to this site are allowed).
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sExtDbPath - Full Path & Filename of the Database to import the tables from
'
' Usage Example:
' ~~~~~~~~~~~~~~~~
' ImportAllTbls "C:\Databases\development01.mdb"
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2009-Jan-07                 Initial Release
'---------------------------------------------------------------------------------------
Sub ImportAllTbls(sExtDbPath As String)
On Error GoTo Error_Handler
    Dim db      As DAO.Database
    Dim tdf     As DAO.TableDef
 
    Set db = OpenDatabase(sExtDbPath)
 
    For Each tdf In db.TableDefs 'Loop through all the table in the external database
        If Left(tdf.Name, 4) <> "MSys" Then 'Exclude System Tables
            On Error Resume Next
            Access.DoCmd.TransferDatabase acImport, "Microsoft Access", sExtDbPath, _
                                          acTable, tdf.Name, tdf.Name, False
        End If
    Next tdf
    db.Close
 
    Set db = Nothing 'Cleanup after ourselves

Exit Sub
 
Error_Handler:
    MsgBox "MS Access has generated the following error" & vbCrLf & vbCrLf & "Error Number: " & _
    Err.Number & vbCrLf & "Error Source: ImportAllTbls" & vbCrLf & "Error Description: " & _
    Err.Description, vbCritical, "An Error has Occured!"
    Exit Sub
End Sub

'---------------------------------------------------------------------------------------
' Procedure : findmaketbl
' Author    : CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Locate which Make-Table Query is creating a table
' Copyright : The following may be altered and reused as you wish so long as the
'             copyright notice is left unchanged (including Author, Website and
'             Copyright).  It may not be sold/resold or reposted on other sites (links
'             back to this site are allowed).
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sTableName    Name of the Table that you believe is created by a Make-Table Query.
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
'
**************************************************************************************
' 1         2009-Jun-12                 Initial Release
'---------------------------------------------------------------------------------------
Function findmaketbl(sTableName As String)
On Error GoTo Error_Handler
 
    Dim db      As DAO.Database
    Dim qdf     As DAO.QueryDef
    Dim sSQL    As String
 
    Set db = CurrentDb
 
    For Each qdf In db.QueryDefs
        'qdf.Name    'The current query's name
        'qdf.SQL     'The current query's SQL statement
        sSQL = qdf.SQL
        If InStr(sSQL, " INTO ") And InStr(sSQL, sTableName) Then
            'The Query is a Make Table Query and has our TableName we are looking for
            MsgBox "Query:'" & qdf.Name & "' is a Make-Table Query for Table '" & _
                    sTableName & "'.", vbInformation
        End If
    Next
 
    Set qdf = Nothing
    Set db = Nothing
 
If Err.Number = 0 Then Exit Function
 
Error_Handler:
    MsgBox "MS Access has generated the following error" & vbCrLf & vbCrLf & "Error Number: " & _
    Err.Number & vbCrLf & "Error Source: findmaketbl" & vbCrLf & "Error Description: " & _
    Err.Description, vbCritical, "An Error has Occured!"
    Exit Function
End Function

'---------------------------------------------------------------------------------------
' Procedure : ValInTbl
' Author    : CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Verifies if a value is found in a table
' Copyright : The following may be altered and reused as you wish so long as the
'             copyright notice is left unchanged (including Author, Website and
'             Copyright).  It may not be sold/resold or reposted on other sites (links
'             back to this site are allowed).
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sTable    : Name of the table to search for the specified value
' sField    : Name of the field in the specified table to search for the specified value
' sValue    : Value to search for
'
' Usage:
'~~~~~~~
' ValInTbl("tbl_Units", "UnitNo", 54201)
' ValInTbl("tbl_Employees", "FirstName", "Daniel")
' ValInTbl("tbl_Followup", "AttendInitSession", True)
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2009-Mar-14             Initial Release
' 2         2010-Oct-13             Adjust the sSQL string based on the table field type
'---------------------------------------------------------------------------------------
Function ValInTbl(sTable As String, sField As String, sValue As String) As Boolean
On Error GoTo Error_Handler
    Dim db      As DAO.Database
    Dim rs      As DAO.Recordset
    Dim sSQL    As String
 
    Set db = CurrentDb()
    Select Case db.TableDefs(sTable).Fields(sField).Type
        Case dbByte, dbInteger, dbLong, dbSingle, dbDouble, dbBoolean
            sSQL = "SELECT [" & sField & "] FROM [" & sTable & "] WHERE [" & sField & "]=" & sValue
        Case dbText, dbMemo
            sSQL = "SELECT [" & sField & "] FROM [" & sTable & "] WHERE [" & sField & "]='" & sValue & "'"
        Case dbDate
            sSQL = "SELECT [" & sField & "] FROM [" & sTable & "] WHERE [" & sField & "]=#" & sValue & "#"
    End Select
    Set rs = db.OpenRecordset(sSQL, dbOpenSnapshot)
 
    If rs.RecordCount <> 0 Then
        ValInTbl = True
    Else
        ValInTbl = False
    End If
 
Error_Handler_Exit:
    On Error Resume Next
    rs.Close
    Set rs = Nothing
    Set db = Nothing
    Exit Function
 
Error_Handler:
    MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: ValInTbl" & vbCrLf & _
           "Error Description: " & Err.Description, _
           vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Function