Access'ten Excel'e Veri Aktarımı

[ßyMesMes]

HERAKLES Otomatik Avlı kalıcı sunucu. 19 Haziran'da açılıyor. Atius & Wizard güvencesiyle hemen kayıt ol, ön kayıt ödülleri aktif. HEMEN TIKLA!

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