Access'ten Excel'e Veri Aktarımı

 
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

Yorum Yapabilmek İçin Üye Girişi Yapmanız Gerekmektedir.

access'ten excel'e veri aktarımı