Option Explicit
Private strExcelFile As String
Private strWorksheet As String
Private strDB As String
Private strTable As String
Private objDB As Database
Private strField As String
Private strSearch As String
Private DB As Database
Private WildCard As String
Private textString As String
Private UsedBrowse As Boolean
Private Sub ExportOneTable()
 
'EXPORTS TABLE IN ACCESS DATABASE TO EXCEL
'REFERENCE TO DAO IS REQUIRED
 
 
Set objDB = OpenDatabase(strDB)
 
 'If excel file already exists, you can delete it here
' If Dir(strExcelFile) <> "" Then Kill strExcelFile
 
objDB.Execute _
  "SELECT * INTO [Excel 8.0;DATABASE=" & strExcelFile & _
   "].[" & strWorksheet & "] FROM " & "[" & strTable & "]" & _
   "WHERE [" & strTable & "." & strField & "]like '" & WildCard & strSearch & WildCard & "';"
objDB.Close
Set objDB = Nothing
 
End Sub
Function FieldType(intType As Integer) As String
 
    Select Case intType
        Case dbBoolean
            FieldType = "Boolean"
        Case dbByte
            FieldType = "Byte"
        Case dbInteger
            FieldType = "Integer"
        Case dbLong
            FieldType = "Long"
        Case dbCurrency
            FieldType = "Currency"
        Case dbSingle
            FieldType = "Single"
        Case dbDouble
            FieldType = "Double"
        Case dbDate
            FieldType = "Date"
        Case dbText
            FieldType = "Text"
        Case dbLongBinary
            FieldType = "LongBinary"
        Case dbMemo
            FieldType = "Memo"
        Case dbGUID
            FieldType = "GUID"
    End Select
 
End Function
Private Sub GetDB()
  CommonDialog1.DialogTitle = "Browse for Database File"
  CommonDialog1.Filter = "Database File (*.mdb)|*.mdb"
  CommonDialog1.DefaultExt = ".mdb"
  CommonDialog1.DialogTitle = "Browse for Database File"
  CommonDialog1.ShowOpen
  Text1.Text = CommonDialog1.FileName
  UsedBrowse = True
End Sub
Private Sub FillList1()
Dim DBName As String
Dim X As Integer
  On Error GoTo ExitSub
 
  If Right(Text1.Text & textString, 4) = ".mdb" Then
    Set DB = OpenDatabase(Text1.Text & textString)
     'Extract tables from DataBase and add to combobox...
    Screen.MousePointer = 11
    List1.Clear
    For X = 0 To DB.TableDefs.Count - 1
      'Ignore system tables...
      If InStr(UCase(DB.TableDefs(X).Name), "MSYS") = 0 Then
        List1.AddItem DB.TableDefs(X).Name
      End If
    Next X
    If List1.ListCount > 0 Then List1.ListIndex = 0
    Screen.MousePointer = 0
  End If
ExitSub:
End Sub
 
Private Sub cmdBrowse_Click()
  GetDB
  FillList1
 
End Sub
 
Private Sub cmdCancel_Click()
  End
End Sub
 
Private Sub cmdClear_Click()
 Text1.Text = ""
 List1.Clear
 List2.Clear
 lblFieldType = ""
 txtSearch = ""
 txtWorkSheetName = ""
End Sub
 
Private Sub cmdOK_Click()
  If Text1.Text <> "" Then
    CommonDialog1.DialogTitle = "Save to Excel File"
    CommonDialog1.FileName = ""
    CommonDialog1.DefaultExt = ".xls"
    CommonDialog1.Filter = "Excel File (*.xls)|*.xls"
    CommonDialog1.ShowSave
    strExcelFile = CommonDialog1.FileName
    strWorksheet = txtWorkSheetName
    If strWorksheet = "" Then
      strWorksheet = "WorkSheet1"
    End If
    strDB = Text1.Text
    strTable = List1.Text
    strField = List2.Text
    strSearch = txtSearch
    If chkExact = 1 Then
      WildCard = ""
    Else
      WildCard = "*"
    End If
   ExportOneTable
  End If
CommonDialog1.Filter = "Database File(*.mdb)|*.mdb"
CommonDialog1.DefaultExt = ".mdb"
CommonDialog1.DialogTitle = "Browse for Database File"
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
On Error Resume Next
DB.Close
Set DB = Nothing
End Sub
 
Private Sub List1_Click()
List1.SetFocus
UpdateFields
End Sub
 
Private Sub List1_KeyDown(KeyCode As Integer, Shift As Integer)
UpdateFields
End Sub
 
Private Sub UpdateFields()
  Dim X As Integer
  Dim RstTemp
  Screen.MousePointer = 11
  List2.Clear
  Set RstTemp = DB.OpenRecordset(List1.Text)
  For X = 0 To RstTemp.Fields.Count - 1
    List2.AddItem RstTemp.Fields(X).Name
  Next X
  If List2.ListCount > 0 Then List2.ListIndex = 0
  Screen.MousePointer = 0
  RstTemp.Close
  Set RstTemp = Nothing
End Sub
 
Private Sub List2_Click()
Dim RstTemp As Recordset
  Set RstTemp = DB.OpenRecordset(List1.Text)
  lblFieldType = FieldType(RstTemp.Fields(List2.ListIndex).Type)
  RstTemp.Close
  Set RstTemp = Nothing
 
End Sub
 
 
Private Sub Text1_DblClick()
 Text1.SelLength = Len(Text1.Text)
End Sub
 
 
Private Sub Text1_KeyPress(KeyAscii As Integer)
List1.Clear
List2.Clear
lblFieldType = ""
textString = Chr(KeyAscii)
FillList1
textString = ""
End Sub
 
Private Sub Text1_LostFocus()
  FillList1
End Sub