Change - Make QueryDefs

If you have an MS Access job where in the loop you want to use the same query, or run update query on a different table, or want to pass different SS Number, or ... here is the solution.

1. Create a query and name it "qryMySampleQuery" (template)

2. Read your querydef from template query:
    sqlIn = CurrentDb.QueryDefs("qryMySampleQuery").SQL
3. You can have a variable table name: strMyTable (or any other parm you want to change inside SQL code.)
    sqlOut = Replace(sqlIn, "tblTableSampleName", strMyVariableTableName)
4. Pass new SQL code to change your production query "qryRealQueryname"
     If ObjectExist("Query", "qryRealQueryname") Then
          MakeMyQuery = ChangeQueryDef("qryRealQueryname", sqlOut)
    Else
          MakeMyQuery = MakeQueryDef("qryRealQueryname", sqlOut)
    End If

 For function ObjectExist check Does Access Object Exists

'Copy  two functions below in your VBA Module: 

'

'------------- Change Query Definition ---------------------
'Change existing query SQL from the VBA code module
Function ChangeQueryDef(strQuery As String, strSQL As String) As Boolean
' strSQL is SQL string for the querydef of strQuery
If strQuery = "" Or strSQL = "" Then Exit Function
'
Dim qdf As QueryDef
'
Set qdf = CurrentDb.QueryDefs(strQuery)
qdf.SQL = strSQL
qdf.Close
'
RefreshDatabaseWindow
ChangeQueryDef = True
'
End Function
'------------- End Change Query Definition -----------------
'
'------------- Make Query Definition -----------------------
'Create new query from the VBA code module
Function MakeQueryDef(strQuery As String, strSQL As String) As Boolean
' Purpose: Create a querydef
' Arguments: Query name and the SQL string for the querydef
' Returns: True
If strSQL = "" Then Exit Function
'

Dim qdf As QueryDef

'

Set qdf = CurrentDb.CreateQueryDef(strQuery)

qdf.SQL = strSQL
qdf.Close
RefreshDatabaseWindow
'

MakeQueryDef = True

'

End Function

'------------- End Make Query Definition -----------------------

Save Recordset To CSV File

Public Sub SaveRecordsetToCSV()
    Dim rsTemp As ADODB.Recordset
    Set rsTemp = New ADODB.Recordset
    
    rsTemp.Open "MyTableName", CurrentProject.Connection, adOpenStatic, adLockOptimistic
 
    Dim CSVData As String
    CSVData = RecordsetToCSV(rsTemp, True)
 
    Open "C:\MyFileName.csv" For Binary Access Write As #1
        Put #1, , CSVData
    Close #1
    
    rsTemp.Close
    Set rsTemp = Nothing
End Sub


Public Function RecordsetToCSV(rsData As ADODB.Recordset, _
        Optional ShowColumnNames As Boolean = True, _
        Optional NULLStr As String = "") As String
    'Function returns a string to be saved as .CSV file
    'Option: save column titles

    Dim K As Long, RetStr As String
    
    If ShowColumnNames Then
        For K = 0 To rsData.Fields.Count - 1
            RetStr = RetStr & ",""" & rsData.Fields(K).Name & """"
        Next K
        
        RetStr = Mid(RetStr, 2) & vbNewLine
    End If
    
    RetStr = RetStr & """" & rsData.GetString(adClipString, -1, """,""", """" & vbNewLine & """", NULLStr)
    RetStr = Left(RetStr, Len(RetStr) - 3)
    
    RecordsetToCSV = RetStr
End Function

Write Table Or Query To CSV File

' 
Public Sub ExportDelim(strTableOrQuery As String, strExportFile As String, _
                        Optional blnHeader As Boolean, _
                        strDelimiter As String, Optional TxtQualifier As String)
'INPUT:
' strTableOrQuery   is the table or query name
' strExportFile     is the full path and name of file to export to
' blnHeader         export column titles: True / False
' strDelimiter      is the field deliminator: Chr(9) for tab or Chr(44) for comma
' TxtQualifier      is optinal double qoutes Chr (34)
'OUTPUT:
' Delimited text file; fields can be souranded with quotes TxtQualifier
    Dim fld As Field
    Dim varData As Variant
    Dim rs As Recordset
    Dim intFileNum As Integer
    
    
    'set recordset on table or query
    Set rs = CurrentDb.OpenRecordset(strTableOrQuery, dbOpenSnapshot)
      
    'get file handle and open for output
    intFileNum = FreeFile()
      
    Open strExportFile For Output As #intFileNum
      
    If blnHeader Then
        'output the header row if requested
        varData = ""
        For Each fld In rs.Fields   'traverse the fields collection
            varData = varData & TxtQualifier & fld.Name & TxtQualifier & strDelimiter
        Next
          
        'remove extra last strDelimiter
        varData = Left(varData, Len(varData) - 1)
        'write out the header row
        Print #intFileNum, varData
    End If
      
    'now your data
    Do While Not rs.EOF
        varData = ""
        'concatenate the data row
        For Each fld In rs.Fields
            varData = varData & TxtQualifier & fld.Value & TxtQualifier & strDelimiter
        Next
        
        'remove extra last strDelimiter
        varData = Left(varData, Len(varData) - 1)
        'write out data row
        Print #intFileNum, varData
        rs.MoveNext
    Loop
      
    Close #intFileNum
    rs.Close
    Set rs = Nothing
End Sub

Extended DLookup

This is a great utility I found at allenbrowne.com Allen is one of 95 Access MVP.

'===============================
'Extended DLookup()
'===============================
'The DLookup() function in Access retrieves a value from a table.
'For basic information on how to use DLookup(), see Getting a value from a table.
'
'Why a replacement?
'DLookup() has several shortcomings:
'
'It just returns the first match to finds. Since you cannot specify a sort order,
'the result is unpredictable. You may even get inconsistent results from the same data
'(e.g. after compacting a database, if the table contains no primary key).
'Its performance is poor.
'It does not clean up after itself (can result in Not enough databases/tables errors).
'It returns the wrong answer if the target field contains a zero-length string.
'ELookup() addresses those limitations:
'
'An additional optional argument allows you to specify a sort order. That means you
'can specify which value to retrieve: the min or max value based on any sort order
'you wish to specify.
'It explicitly cleans up after itself.
'It runs about twice as fast as DLookup(). (Note that if you are retrieving a value
'for every row of a query, a subquery would provide much better performance.)
'It correctly differentiates a Null and a zero-length string.
'Limitations of ELookup():
'
'If you ask ELookup() to concatenate several (not memo) fields, and more than
'255 characters are returned, you strike this Access bug:
'      Concatenated fields yield garbage in recordset.
'DLookup() can call the expression service to resolve an argument such as:
'    DLookup("Surname", "Clients", "ClientID = [Forms].[Form1].[ClientID]")
'You can resolve the last issue by concatenating the value into the string:
'    ELookup("Surname", "Clients", "ClientID = " & [Forms].[Form1].[ClientID])
'
'Before using ELookup() in a query, you may want to modify it so it does not pop
'up a MsgBox for every row if you get the syntax wrong. Alternatively, if you don't
'mind a read-only result, a subquery would give you faster results than any function.
'
'How does it work?
'The function accepts exactly the same arguments as DLookup(), with an optional
'fourth argument. It builds a query string:
'    SELECT Expr FROM Domain WHERE Criteria ORDER BY OrderClause
'
'This string opens a recordset. If the value returned is an object, the requested
'expression is a multi-value field, so we loop through the multiple values to return a
'delimited list. Otherwise it returns the first value found, or Null if there are no matches.
'
'Note that ELookup() requires a reference to the DAO library.
'For more information, see References.
'
'
'--------------------------------------------------------------------------------

Public Function ELookup(Expr As String, Domain As String, Optional Criteria As Variant, _
    Optional OrderClause As Variant) As Variant
On Error GoTo Err_ELookup
    'Purpose:   Faster and more flexible replacement for DLookup()
    'Arguments: Same as DLookup, with additional Order By option.
    'Return:    Value of the Expr if found, else Null.
    '           Delimited list for multi-value field.
    'Author:    Allen Browne. allen@allenbrowne.com
    'Updated:   December 2006, to handle multi-value fields (Access 2007.)
    'Examples:
    '           1. To find the last value, include DESC in the OrderClause, e.g.:
    '               ELookup("[Surname] & [FirstName]", "tblClient", , "ClientID DESC")
    '           2. To find the lowest non-null value of a field, use the Criteria, e.g.:
    '               ELookup("ClientID", "tblClient", "Surname Is Not Null" , "Surname")
    'Note:      Requires a reference to the DAO library.
    Dim db As DAO.Database          'This database.
    Dim rs As DAO.Recordset         'To retrieve the value to find.
    Dim rsMVF As DAO.Recordset      'Child recordset to use for multi-value fields.
    Dim varResult As Variant        'Return value for function.
    Dim strSQL As String            'SQL statement.
    Dim strOut As String            'Output string to build up (multi-value field.)
    Dim lngLen As Long              'Length of string.
    Const strcSep = ","             'Separator between items in multi-value list.

    'Initialize to null.
    varResult = Null

    'Build the SQL string.
    strSQL = "SELECT TOP 1 " & Expr & " FROM " & Domain
    If Not IsMissing(Criteria) Then
        strSQL = strSQL & " WHERE " & Criteria
    End If
    If Not IsMissing(OrderClause) Then
        strSQL = strSQL & " ORDER BY " & OrderClause
    End If
    strSQL = strSQL & ";"

    'Lookup the value.
    Set db = DBEngine(0)(0)
    Set rs = db.OpenRecordset(strSQL, dbOpenForwardOnly)
    If rs.RecordCount > 0 Then
        'Will be an object if multi-value field.
        If VarType(rs(0)) = vbObject Then
            Set rsMVF = rs(0).Value
            Do While Not rsMVF.EOF
                If rs(0).Type = 101 Then        'dbAttachment
                    strOut = strOut & rsMVF!fileName & strcSep
                Else
                    strOut = strOut & rsMVF![Value].Value & strcSep
                End If
                rsMVF.MoveNext
            Loop
            'Remove trailing separator.
            lngLen = Len(strOut) - Len(strcSep)
            If lngLen > 0& Then
                varResult = Left(strOut, lngLen)
            End If
            Set rsMVF = Nothing
        Else
            'Not a multi-value field: just return the value.
            varResult = rs(0)
        End If
    End If
    rs.Close

    'Assign the return value.
    ELookup = varResult

Exit_ELookup:
    Set rs = Nothing
    Set db = Nothing
    Exit Function

Err_ELookup:
    MsgBox Err.Description, vbExclamation, "ELookup Error " & Err.Number
    Resume Exit_ELookup
End Function

Does filed exist in Access table

Sample call: test = FieldExist(CurrentDb.Name, "EmployeeTable", "EmployeeNbr")

'-------------------------------------------------------------------------
' FieldExists: Determine if a field exists in an Access table
'-------------------------------------------------------------------------
Public Function FieldExists(DatabaseName As String, _
    TableName As String, FieldName As String) As Boolean
    'DataBaseName is the file/path name of the database
    'with the field you want to test
    'tablename is the table, fieldname is the field
    'if database or table does not exist, an error is raised
    
    Dim oDB As Database
    Dim td As TableDef
    Dim f As Field
    
    On Error GoTo ErrorHandler
    
    Set oDB = Workspaces(0).OpenDatabase(DatabaseName)
    Set td = oDB.TableDefs(TableName)
    
    On Error Resume Next
    Set f = td.Fields(FieldName)
    FieldExists = Err.Number = 0
    oDB.Close
    
    Exit Function
    
ErrorHandler:
    
    If Not oDB Is Nothing Then oDB.Close
    Err.Raise Err.Number
    Exit Function
    
End Function
'---------------- END FieldExits  ---------------------------------------

Does Access Object Exists

To avoid errors you should always check before accessing an object if it exists.
Sample call: MyTest = ObjectExists("Table", "MyTableName")
or         : If Not ObjectExists("Table", "MyTableName") Then ...

'---------------------------------------------------------------------
' ObjectExists:  Find if the object exists in DB
'---------------------------------------------------------------------
' Pass the Object type: Table, Query, Form, Report, Macro, or Module
' Pass the Object Name
' Function returns boolean "Yes/NO"
Function ObjectExists(strObjectType As String, strObjectName As String) As Boolean
     Dim db As Database
     Dim tbl As TableDef
     Dim qry As QueryDef
     Dim i As Integer
     
     Set db = CurrentDb()
     ObjectExists = False
     
     If strObjectType = "Table" Then
          For Each tbl In db.TableDefs
               If tbl.Name = strObjectName Then
                    ObjectExists = True
                    Exit Function
               End If
          Next tbl
     ElseIf strObjectType = "Query" Then
          For Each qry In db.QueryDefs
               If qry.Name = strObjectName Then
                    ObjectExists = True
                    Exit Function
               End If
          Next qry
     ElseIf strObjectType = "Form" Or strObjectType = "Report" Or strObjectType = "Module" Then
          For i = 0 To db.Containers(strObjectType & "s").Documents.Count - 1
               If db.Containers(strObjectType & "s").Documents(i).Name = strObjectName Then
                    ObjectExists = True
                    Exit Function
               End If
          Next i
     ElseIf strObjectType = "Macro" Then
          For i = 0 To db.Containers("Scripts").Documents.Count - 1
               If db.Containers("Scripts").Documents(i).Name = strObjectName Then
                    ObjectExists = True
                    Exit Function
               End If
          Next i
     Else
          MsgBox "Invalid Object Type, must be Table, Query, Form, Report, Macro, or Module"
     End If  
End Function
'-------------- END ObjectExists ----------------------

Format Excel Sheet From Access

I have this function in my Access modules. When a table or a query is transfered to a speadsheet I use the function to format all sheets in the workbook.

'================================================================
'*************   Format Excel Sheet   ***************************
'================================================================
Sub FormatExcelSheet(ByVal myFilePath As String)
'
  Dim objXL As Excel.Application
  Dim objWkb As Excel.Workbook
  Dim objSht As Excel.Worksheet
  Dim WKB_NAME As String
  'Dim SHT_NAME As String
  Dim intLastCol As Integer
  Dim Current As Worksheet   ' Declare Current as a worksheet object variable.

  WKB_NAME = myFilePath
  
  Set objXL = Excel.Application
  With objXL
    .Visible = False
    Set objWkb = .Workbooks.Open(WKB_NAME)
    On Error Resume Next
    Debug.Print objWkb.Name
    'Loop through all of the worksheets in the active workbook.
    For Each Current In Worksheets
        Set objSht = objWkb.Worksheets(Current.Name)
        objSht.Activate
        intLastCol = objSht.UsedRange.Columns.Count
        With objSht
             ' Paint first row yellow
            .Cells(1, 1).EntireRow.Interior.ColorIndex = 6
             ' Use bold font in first row
            .Cells(1, 1).EntireRow.Font.Bold = True
             'Auto fit cell width
            .Columns("A:CZ").AutoFit
        End With
        objSht.Cells(2, 1).Select
        objXL.ActiveWindow.FreezePanes = False
        'Freeze the first row with column titles.
        objXL.ActiveWindow.FreezePanes = True
        Set objSht = Nothing
    Next
  End With
  objWkb.Save
  objWkb.Close
  objXL.Quit
  
  Set objWkb = Nothing
  Set objXL = Nothing
  
  WKB_NAME = ""
End Sub
'==========================================================================

Merge Text Files FSO

' You can create a function that receives three file names.
' Needs References to Microsoft Scripting Runtime

' Merge two text files
fHeader = "C:\MyHeaderFile.csv"
fData = "C:\MyDataFile.csv"
fOut = "C:\NewFile.csv"

Const ForReading = 1

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objOutputFile = objFSO.CreateTextFile(fOut)

Set objTextFile = objFSO.OpenTextFile(fHeader, ForReading)

strText = objTextFile.ReadAll
objTextFile.Close
objOutputFile.WriteLine strText

Set objTextFile = objFSO.OpenTextFile(fData & " ", ForReading)

strText = objTextFile.ReadAll
objTextFile.Close
objOutputFile.WriteLine strText

objOutputFile.Close

Mass replace characters in a text file

'--------------------------------------------------------------------
' sFile - path and file name of your file
' sNewFile - new file name, can be same like old file name
' sFind - text you want to replace (can be special character like: vbCrLf)
' sReplace - new text
'
Public Sub TextFileReplace(ByVal sFile As String, ByVal sNewFile As String, ByVal sFind As String, ByVal sReplace As String)
Dim iFile As Integer
Dim sTextBuffer As String
'
' Get the next available file handle
iFile = FreeFile
' Open the source file (sFile) for read access
Open sFile For Binary Access Read As iFile
' Create a buffer that will hold the contents of the file
sTextBuffer = Space(LOF(iFile))
' Read the contents of the file into the buffer
Get #iFile, , sTextBuffer
' Close the file
Close iFile

' Use the "Replace" function to replace all instances of
' (sFind) in the buffer with the value in (sReplace)
sTextBuffer = Replace(sTextBuffer, sFind, sReplace)

' Get the next available file handle
iFile = FreeFile
' Open/Create the new file for write access
Open sNewFile For Binary Access Write As iFile
' Write the modified buffer contents to the file
Put #iFile, , sTextBuffer
' Close the file
Close iFile
End Sub
'--------------------------------------------------------------------

Example Usage:
'--------------------------------------------------------------------
Call TextFileReplace("C:\MyFile.csv", "C:\NewFileName.txt", "IT_Number", "IT_Nbr")
'--------------------------------------------------------------------

Read Text File

Use VBA to read a text file line by line, the whole file, and one by one character.

Dim objSource
Dim strLine
Dim objFSO
Const ForReading = 1    
Dim strFile As String
Dim strTempFile As String

strTextFile = "C:\MyFileName.txt"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objSource = objFSO.OpenTextFile(strTextFile, ForReading)
       
' Read file line by line
Do Until objSource.AtEndOfStream
    strLine = objSource.ReadLine
    'Processing data
    Debug.Print strLine
Loop
       
' Read file in one big buffer
strTextBuffer = objSource.ReadAll
Debug.Print strTextBuffer
       
objSource.Close
Set objSource = Nothing
Set objFSO = Nothing
       
'----------------------------------------
       
'To read the file one by one character use this:
Dim MyChar
Open "C:\MyTextFile.txt" For Input As #1      ' Open file.
Do While Not EOF(1)        ' Loop until end of file.    
  MyChar = Input(1, #1)    ' Get one character.      
  Debug.Print MyChar       ' Print to the Immediate window.
Loop
Close #1    ' Close file.

How To Build ODBC Connection String

I'm  working with MS Access and have many tables linked to Oracle and DB2. When I wanted to automate some process I needed to connect to DB2 and pass my ID and Password using VBA code. I spent many hours trying to guess the correct ODBC Connection String. Web site http://www.connectionstrings.com/ gave me some examples, but I couldn't make it work. I asked our DB2 admin for advice, and got an email saying that I just have to use my ID and Password????  What .... Really...  No help there.
Than one day while creating my first Pass-Trough Query I saw the string. It was so simple and strings I was trying to use were so close to this one, but still not exact and not correct. All I had to do was to copy the string into my porogram. If you have the same problem here is what you have to do to find the exact ODBC Connection String.
In Access Open New Query. Without adding tables close the Show Table dialog box. 
On  the Query menu, Point to SQL Specific, and click Pass-Trough

Than click on the menu bar Properties,  and clcik ... to build ODBC Connect String.

Select your Data Source where your DB2 tablese are located (on my system it's DB2A)

Enter your system/network ID and Password.

After you click YES to Save password in the connection string, you can see the string in the wizard box, so you can copy it and save the string in your program.  Now you can close the query without saving it.

Here is the code I'm using to connect to DB2 and Oracle. You can create a function and pass the UserID and password.
'---------------------------------------------------------------------------------------
Dim db As Database
Dim strConnect As String
 
strDB2id = "Your_DB2_UserName"
strDB2pw = "Your_DB2_Password"
strORAid = "Your_Oracle_UserName"
strORApw = "Your_Oracle_Password"

' DB2 connection string:
' "ODBC;DSN=DB2A;UID=Your_ID;PWD=Your_Password;MODE=SHARE;DBALIAS=DB2A;"
strConnect = "ODBC;DSN=DB2A;UID=" & strDB2id & ";PWD=" & strDB2pw & ";MODE=SHARE;DBALIAS=DB2A;"
Set db = DBEngine.Workspaces(0).OpenDatabase("", False, False, strConnect)
db.Close

' Oracle connection string for Oracle10 ODBC driver.
' "DSN=PRD26;SERVER=PRD26;UID=Your_ID;PWD=Your_Password"
strConnect = "DSN=PRD26;SERVER=PRD26;UID=" & strORAid & ";PWD=" & strORApw
Set db = DBEngine.Workspaces(0).OpenDatabase("", False, False, strConnect)
db.Close
'----------------------------------------------------------------------------------------------