Correct OLEDB connection string for .DBF file, Excel VBA

Question

Hello, can someone help me. I am seeking correct connection string for .DBF file:

Sub ImportDataFile()  
  

   Range("A1").Select  
     
    
  
   With ActiveSheet.QueryTables.Add(Connection:="Provider=Microsoft.Jet.OLEDB.4.0;Data Source=c:\3;Extended Properties=dBASE IV;User ID=Admin;Password=", Destination:=Range("A1"))  
     
         .Name = "MAT1.DBF"   
         .FieldNames = True  
         .RowNumbers = False  
         .FillAdjacentFormulas = False  
         .PreserveFormatting = True  
         .RefreshOnFileOpen = False  
         .RefreshStyle = xlInsertDeleteCells  
         .SavePassword = False  
         .SaveData = True  
         .AdjustColumnWidth = True  
         .RefreshPeriod = 0  
         .TextFilePromptOnRefresh = False  
         .TextFilePlatform = xlMSDOS '437  
         .TextFileStartRow = 1  
         .TextFileParseType = xlFixedWidth 'xlDelimited  
         .TextFileTextQualifier = xlTextQualifierNone  
         .TextFileConsecutiveDelimiter = True  
         .TextFileTabDelimiter = False  
         .TextFileSemicolonDelimiter = False  
         .TextFileCommaDelimiter = False  
         .TextFileSpaceDelimiter = False  
         .TextFileDecimalSeparator = ","  
         .TextFileOtherDelimiter = ","  
         .TextFileColumnDataTypes = Array(xlGeneralFormat)  
         .Refresh BackgroundQuery:=True  
          
   End With  
     
   Sheets("List1").QueryTables(1).Delete  
     
   Worksheets("List1").Cells.Select  
  
End Sub  

Answer 1

I probably found a solution which is working in MS Excel 2003 and with .DBF file from FoxPro 2.6

Sub QuerytableAdd()  
  
Dim vFilename As String  
Dim vFolderName As String  
Dim vSheetname As String  
  
  
vFilename = "MAT1"  
vFolderName = "C:\2\"  
vSheetname = "List1"  
  
With ActiveSheet.QueryTables.Add(Connection:=Array( _  
        "OLEDB;Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & vFolderName & ";Mode=Share Deny Write;Extended Propert" _  
        , _  
        "ies="""";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Database Password="""";Jet OLEDB:Engine Type=18;Jet OLEDB" _  
        , _  
        ":Database Locking Mode=0;Jet OLEDB:Global Partial Bulk Ops=2;Jet OLEDB:Global Bulk Transactions=1;Jet OLEDB:New Database Passwor" _  
        , _  
        "d="""";Jet OLEDB:Create System Database=False;Jet OLEDB:Encrypt Database=False;Jet OLEDB:Don't Copy Locale on Compact=False;Jet OL" _  
        , "EDB:Compact Without Replica Repair=False;Jet OLEDB:SFP=False"), Destination _  
        :=Sheets(vSheetname).Range("A1"))  
        .CommandType = xlCmdTable  
        .CommandText = Array(vFilename)  
        .Name = vFilename  
        .FieldNames = True  
        .RowNumbers = False  
        .FillAdjacentFormulas = False  
        .PreserveFormatting = False  
        .RefreshOnFileOpen = False  
        .BackgroundQuery = False  
        .RefreshStyle = xlInsertDeleteCells  
        .SavePassword = True  
        .SaveData = True  
        .AdjustColumnWidth = True  
        .RefreshPeriod = 0  
        .PreserveColumnInfo = False  
        .SourceDataFile = vFolderName & vFilename & ".DBF"  
        .Refresh BackgroundQuery:=False  
    End With  
  
  
End Sub  
  
Sub ReadDBF()  
      
    '-------------------------------------------------------------------------------  
    'This macro opens the Sample.dbf database, runs an SQL query (filtering all  
    'the country data from Canada) and copies the results back in the Excel sheet.  
    'The code uses late binding, so no reference to external library is required.  
      
    'Written by:    Christos Samaras  
    'Date:          25/09/2013  
    'e-mail:        ******@gmail.com  
    'site:          https://myengineeringworld.net/////  
    '-------------------------------------------------------------------------------  
  
    'Declaring the necessary variables.  
    Dim con         As Object  
    Dim rs          As Object  
    Dim DBFFolder   As String  
    Dim FileName    As String  
    Dim sql         As String  
    Dim myValues()  As String  
    Dim i           As Integer  
    Dim j           As Integer  
    Dim k           As Integer  
    Dim row         As Integer  
              
    'Disable screen flickering.  
    Application.ScreenUpdating = False  
      
    'Specify the folder and the filename of the dbf file. If you use full path like  
    'C:UsersChristosDesktop be careful not to forget the backslash at the end.  
    DBFFolder = "g:\Double\Dbnel08\FILE\" ' ThisWorkbook.Path & ""  
    FileName = "MAT1.DBF"  
      
    On Error Resume Next  
    'Create the ADODB connection object.  
    Set con = CreateObject("ADODB.connection")  
  
      
    'Check if the object was created.  
    If Err.Number <> 0 Then  
        MsgBox "Connection was not created!", vbCritical, "Connection error"  
        Exit Sub  
    End If  
    On Error GoTo 0  
      
    'Open the connection.  
    'con.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & DBFFolder & ";Extended Properties=dBASE IV; Characterset=20866"  
    con.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & DBFFolder & ";Extended Properties=dBASE IV; "  
    'con.Charset = "cp367" Characterset=CP895;  HDR=Yes;FMT=Delimited;CharacterSet=65001;  
      
    'Create the SQL statement to read the file. Filter all the data from Canada.  
    'Note that the filename is used instead of the table name.  
    Rem sql = "SELECT * FROM " & Left(FileName, (InStrRev(FileName, ".", -1, vbTextCompare) - 1)) & " WHERE COUNTRY='Canada'"  
    sql = "SELECT * FROM MAT1.DBF" ' & Left(FileName, (InStrRev(FileName, ".", -1, vbTextCompare) - 1)) & " WHERE COUNTRY='Canada'"  
      
    On Error Resume Next  
    'Create the ADODB recordset object.  
    Set rs = CreateObject("ADODB.recordset")  
  
      
    'rs.Charset = "cp852"  
    'Check if the object was created.  
      
    If Err.Number <> 0 Then  
        MsgBox "Connection was not created!", vbCritical, "Connection error"  
        Exit Sub  
    End If  
    On Error GoTo 0  
      
      
    'Exit Sub  
           
    'Set thee cursor location.  
    rs.CursorLocation = 3 'adUseClient on early  binding  
    rs.CursorType = 1 'adOpenKeyset on early  binding  
      
    'Open the recordset.  
    rs.Open sql, con  
      
  
      
    'Redim the table that will contain the filtered data.  
    ReDim myValues(rs.RecordCount, 4)  
      
    MsgBox "Otevreno, celkem zaznamu: " + CStr(rs.RecordCount)  
          
    'Loop through the recordset and pass the selected values to the array.  
    row = 1  
    If Not (rs.EOF And rs.BOF) Then  
      
        Debug.Print "rec in line : " + CStr(rs.Fields.Count)  
          
        'Go to the first record.  
        On Error Resume Next  
        rs.MoveFirst  
        'Do Until rs.EOF = True  
        For k = 0 To 1000  
           'Debug.Print "R: " + CStr(row)  
          
           For i = 0 To rs.Fields.Count - 1  
          
              ' Debug.Print "R: " + CStr(i) + "  " + rs.Fields(i).Name, rs.Fields(i).Value, rs.Fields.Count ', rs.Fields(0).Value  
              'Debug.Print "Fields.Count : " + CStr(rs.Fields.Count)  
              'Debug.Print "R: " + CStr(i)  
              'Debug.Print "R: " + CStr(i), "  ", rs.Fields(0).Value, rs.Fields(1).Value, rs.Fields(2).Value, rs.Fields(3).Value, rs.Fields(4).Value,  
              
              'myValues(i, 1) = rs.Fields(0).Value  ' Item(1) '(1)rs!datum 'rs.Fields(1).Value 'rs.!datum  
              'myValues(i, 2) = rs.Fields(1).Value  ' rs.Fields.Item(2) 'rs!doklad 'rs.Fields(2).Value 'rs!doklad  
              'myValues(i, 3) = rs.Fields(2).Value  ' rs.Fields.Item(3) 'rs!material ' rs.Fields(3).Value 'rs!material  
              'myValues(i, 4) = rs.Fields(3).Value  ' rs.Fields.Item(4) ' rs!nazev ' rs.Fields(4).Value 'rs!nazev  
  
              If IsNull(rs.Fields(i).Value) = True Then  
                 ThisWorkbook.Worksheets("List1").Cells(row, i + 1) = ""  
              Else  
                 ThisWorkbook.Worksheets("List1").Cells(row, i + 1) = CStr(rs.Fields(i).Value)  
              End If  
              
              'Move to the next record.  
         Next i  
           
         rs.MoveNext  
           
         row = row + 1 '   i = i + 1  
              
        'Loop  
        Next k  
        On Error GoTo 0  
    Else  
        'Close the recordet and the connection.  
        rs.Close  
        con.Close  
        'Release the objects.  
        Set rs = Nothing  
        Set con = Nothing  
        'Enable the screen.  
        Application.ScreenUpdating = True  
        'In case of an empty recordset display an error.  
        MsgBox "There are no records in the recordset!", vbCritical, "No Records"  
        Exit Sub  
    End If  
      
    MsgBox "Nacteno"  
          
    'Write the array in the sheet.  
    List1.Activate  
      
    'Close the recordet and the connection.  
    rs.Close  
    con.Close  
      
    'Release the objects.  
    Set rs = Nothing  
    Set con = Nothing  
      
    'Adust the columns width.  
    ' Columns("A:D").EntireColumn.AutoFit  
      
    'Enable the screen.  
    Application.ScreenUpdating = True  
  
    'Inform the user that the macro was executed successfully.  
    MsgBox "The values were read from recordset successfully!", vbInformation, "Done"  
  
End Sub