A sample code to workaround Access 97 TransferText implicit features

Question

Are there any workarounds of Access 97 TransferText implicit features ?

Answer

I hope that the following code answers the question:

Public Function smsTransferText(ByVal vstrTblName As String, _
                                ByVal vstrTransferToFullPath As String, _
                                Optional ByRef rvarDbs As Variant = Nothing, _
                                Optional ByVal vblnUseODBC As Boolean = False) As Boolean
'*+
' Public domain. Written by Shamil Salakhetdinov. DARTS Ltd., St.Petersburg, Russia
'                e-mail: shamil@marta.darts.spb.ru
'
' Abstract:
'       It seems that MS Access 97 uses current locale settings to round Double, Single and
'       Currency numbers when data are exported by DoCmd.TransferText ....
'       This function wraps up DoCmd.TransferText. It formats Double, Single and Currency
'       numbers using field's DecimalPlaces property creating temporary format and export
'       queries. Then it uses export query in DoCmd.TransferText to export data into target
'       delimited text file.
'       This function also shows different (advanced) code techniques used to process DAO objects,
'       ODBC datasources and optional arguments.
'
'       Note: Single, Double and Currency numbers exported by this function are enclosed in
'       Text Qualifier chars (usually double quotes - Asc("""") = 34) - this isn't a problem
'       for MS Access 97 to export them back correctly.
'
' Arguments:
'       vstrTblName - table name to export
'       vstrTransferToFullPath - file path to export
'       rvarDbs - (optional) database object reference of opened database, MS Access .mdb file path
'                 or ODBC connect string
'       vblnUseODBC - use linked ODBC datasource if True. Should be always true if rvarDbs is
'                     ODBC connect string
'
' Returns:
'       True - if export is OK
'       False and error message box if export failed
'
' Examples:
'
'     smsTransferText "Table1", "c:\daisy\temp\Table1_Acc97.txt"
'
'     smsTransferText "Table1", "c:\daisy\temp\Table1_Acc97.txt", Codedb()
'
'     smsTransferText "Table1", "c:\daisy\temp\Table1_Acc97.txt", CodeDB().name
'
'     strODBC = "ODBC;DSN=DAISY;DATABASE=DAISY"
'     smsTransferText "Table1", "c:\daisy\temp\Table1_SQL.txt", strODBC, True
'
'     strODBC = "Excel 5.0;HDR=YES;IMEX=2;DATABASE=C:\daisy\Temp\Table1.xls;TABLE=Table1$"
'     smsTransferText "Table1", "c:\daisy\temp\Table1_XLS.txt", strODBC, True
'
'     strODBC = "dBase 5.0;HDR=NO;IMEX=2;DATABASE=C:\daisy\Temp;TABLE=Table1#dbf"
'     smsTransferText "Table1", "c:\daisy\temp\Table1_dBase.txt", strODBC, True
'
'     strODBC = "FoxPro 2.0;HDR=NO;IMEX=2;DATABASE=C:\daisy\Temp;TABLE=Table1f#dbf"
'     smsTransferText "Table1", "c:\daisy\temp\Table1_Fox.txt", strODBC, True
'
'     strODBC = "HTML Import;HDR=NO;IMEX=2;DATABASE=C:\daisy\Temp\Table1.html;TABLE=Table1"
'     smsTransferText "Table1", "c:\daisy\temp\Table1_HTML.txt", strODBC, True
'
'*-
 
    On Error GoTo smsTransferText_Err
    
    Dim dbs As Database
    Dim dbsCode As Database
    Dim tdf As TableDef
    Dim qdf As QueryDef
    Dim fld As Field
    Dim strTblName As String
    Dim strFormat As String
    Dim intDecPlaces As Integer
    Dim strSqlFormat As String
    Dim strSqlExport As String
    Dim strFormatQryName As String
    Dim strExportQryName As String
    Dim strInDbs As String
    Dim strLinkedTblName As String
    
    If TypeName(rvarDbs) = "Nothing" Then
        Set dbs = CodeDb()
        strInDbs = ";Database=" & dbs.Name
    ElseIf TypeName(rvarDbs) = "Database" Then
        Set dbs = rvarDbs
        strInDbs = ";Database=" & dbs.Name
    Else
        If vblnUseODBC Then
            'Use temporary linked table instead of directly opened ODBC source
            'Set dbs = DBEngine(0).OpenDatabase("ExportDBS", dbDriverNoPrompt, True, rvarDbs)
            Set dbs = Nothing
            strInDbs = rvarDbs
        Else
            Set dbs = DBEngine(0).OpenDatabase(rvarDbs, , True)
            strInDbs = ";Database=" & dbs.Name
        End If
    End If
    
    Set dbsCode = CodeDb()
    
    strLinkedTblName = ""
    If vblnUseODBC Then
        strLinkedTblName = "zttbl" & vstrTblName & "_ToExport"
        On Error Resume Next
        dbsCode.TableDefs.Delete strLinkedTblName
        On Error GoTo smsTransferText_Err
        Set tdf = dbsCode.CreateTableDef(strLinkedTblName)
        tdf.Connect = rvarDbs
        tdf.SourceTableName = vstrTblName
        dbsCode.TableDefs.Append tdf
    Else
        Set tdf = dbs.TableDefs(vstrTblName)
    End If
    
    strSqlFormat = " select "
    strSqlExport = " select "
    
    For Each fld In tdf.Fields
       strFormat = ""
       
       Select Case fld.Type
        Case dbDouble, dbSingle, dbCurrency:
            On Error Resume Next
            intDecPlaces = fld.Properties("DecimalPlaces")
            If Err <> 0 Then
                strFormat = "General Number"
            Else
                
                Select Case fld.Properties("DecimalPlaces")
                Case 255: ' Auto
                Case Else: strFormat = "0." & String(CLng(fld.Properties("DecimalPlaces")), "0")
                End Select
                
            End If
            On Error GoTo smsTransferText_Err
        
        Case dbGUID:
            strFormat = "GUID"
        Case Else
        End Select
        
        If strFormat = "" Then
            strSqlFormat = strSqlFormat & "[" & fld.Name & "],"
            strSqlExport = strSqlExport & "[" & fld.Name & "],"
        ElseIf strFormat = "GUID" Then
            strSqlFormat = strSqlFormat & """{guid "" & CStr([" & fld.Name & "]) & ""}""" & " as [" & _
                             fld.Name & "_Formatted],"
            strSqlExport = strSqlExport & "[" & fld.Name & "_Formatted] as [" & fld.Name & "],"
        Else
            strSqlFormat = strSqlFormat & "Format([" & fld.Name & "],""" & strFormat & """) as [" & _
                             fld.Name & "_Formatted],"
            strSqlExport = strSqlExport & "[" & fld.Name & "_Formatted] as [" & fld.Name & "],"
       End If
   Next
    
   'Use temporary linked table instead of 'in' clause
   'strSqlFormat = Left(strSqlFormat, Len(strSqlFormat) - 1) & _
   '               " from [" & vstrTblName & "] in '' [" & strInDbs & "]"
   If vblnUseODBC Then
        strSqlFormat = Left(strSqlFormat, Len(strSqlFormat) - 1) & _
                  " from [" & strLinkedTblName & "]"
   Else
        strSqlFormat = Left(strSqlFormat, Len(strSqlFormat) - 1) & _
                  " from [" & vstrTblName & "]"
   End If
   
   strSqlExport = Left(strSqlExport, Len(strSqlExport) - 1) & " from [ztqry" & vstrTblName & "_Formatted]"
   
   On Error Resume Next
   strFormatQryName = "ztqry" & vstrTblName & "_Formatted"
   dbsCode.QueryDefs.Delete strFormatQryName
   Set qdf = dbsCode.CreateQueryDef(strFormatQryName, strSqlFormat)
   
   strExportQryName = "ztqry" & vstrTblName & "_ToExport"
   dbsCode.QueryDefs.Delete strExportQryName
   Set qdf = dbsCode.CreateQueryDef(strExportQryName, strSqlExport)
   On Error GoTo smsTransferText_Err
   
   DoCmd.TransferText acExportDelim, , strExportQryName, vstrTransferToFullPath, True
   
   On Error Resume Next
   dbsCode.QueryDefs.Delete strFormatQryName
   dbsCode.QueryDefs.Delete strExportQryName
   dbsCode.TableDefs.Delete strLinkedTblName
   On Error GoTo smsTransferText_Err
   smsTransferText = True

smsTransferText_Exit:
    Set fld = Nothing
    Set tdf = Nothing
    Set qdf = Nothing
    Set dbs = Nothing
    Set dbsCode = Nothing
    
    Exit Function
smsTransferText_Err:
    MsgBox "smsTransferText: " & Err & " - " & Err.Description, vbOKOnly
    smsTransferText = False
    Resume smsTransferText_Exit
End Function