SOURCE CODECLIENT.doc

Source CodeClient
Sub export(fname As String, daty As String)
On Error GoTo loi
Dim sconnect As String
Dim tname As String
Dim pa As String
Dim idx As Index
Dim idxnew As Index
Dim dbs As Database
Dim ppw As String
showstatus "Trying export ", True
'Ten cua table export
If daty = "access" Then
tname = frmtm.tvtable.SelectedItem.Text
Else
tname = getfiletitle(fname)
End If
'Lay duong dan
pa = getpath(fname)
Select Case daty

Case "access"
sconnect = "[;database=" & fname & "]." & "[" & tname & "]"
'Mo db de lay constraint
reopen:
Set dbs = OpenDatabase(fname, 0, 0, ";pwd=" & ppw)

Case "foxpro"
sconnect = "[FoxPro 2.6;database=" & pa & "]." & "[" & tname & "]"
Set dbs = OpenDatabase(pa, 0, 0, "FoxPro 2.6;")

Case "text"
sconnect = "[Text;database=" & pa & "]." & "[" & tname & "]"

End Select
pa = frmtm.tvtable.SelectedItem.Text
frmtm.dbs.Execute "Select * Into " & sconnect & " From " & "[" & pa &
"]"
frmtm.dbs.TableDefs.Refresh
'Export constraint
On Error GoTo xoa
If daty <> "text" Then
For Each idx In frmtm.dbs.TableDefs(pa).Indexes
Set idxnew = dbs.TableDefs(tname).CreateIndex(idx.name)
With idxnew
.Fields = idx.Fields
.Unique = idx.Unique
.Primary = idx.Primary
.IgnoreNulls = idx.IgnoreNulls
.Required = idx.Required
End With
dbs.TableDefs(tname).Indexes.Append idxnew
Next
End If
Set idx = Nothing
Set idxnew = Nothing
Set dbs = Nothing
showstatus "Ready", False
MsgBox "Export successfull", vbInformation, "Successfull"
frmtm.tvtable.SetFocus
Exit Sub
xoa:
MsgBox "Can't create constraint", vbInformation, "Export not complete"
frmtm.tvtable.SetFocus
showstatus "Ready", False
Exit Sub

loi:

If Err.Number = 3031 Then
showstatus "Password require", True
frmpassword.Show vbModal
ppw = frmpassword.pw
Unload frmpassword
If ppw <> "" Then
Resume reopen
End If
End If
showstatus "Ready", False
MsgBox "Can't export this table", vbInformation, "Export fail"
frmtm.tvtable.SetFocus
End Sub
Sub import(fname As String, dtype As String)
On Error GoTo loi
Dim tname As String
Dim pa As String
Dim sconnect As String
Dim dbs As Database
Dim idx As Index
Dim idxnew As Index
showstatus "Trying import", True
'Lay ten file
tname = getfiletitle(fname)
'Lay duong dan
pa = getpath(fname)

Select Case dtype
Case "access"
sconnect = "[;database=" & frmimport.dbs.name & "]." & "[" &
fname & "]"
Set dbs = frmimport.dbs
tname = fname
Case "foxpro"
sconnect = "[FoxPro 2.6;database=" & pa & "]." & "[" & tname & "]"
'Mo db de lay cac constraint
Set dbs = OpenDatabase(pa, 0, 0, "FoxPro 2.6;")

Case "text"
sconnect = "[Text;database=" & pa & "]." & "[" & tname & "]"
End Select

frmtm.dbs.Execute "Select * Into " & "[" & tname & "]" & " From " &
sconnect
frmtm.dbs.TableDefs.Refresh
On Error GoTo xoa
If dtype <> "text" Then
For Each idx In dbs.TableDefs(tname).Indexes
Set idxnew = frmtm.dbs.TableDefs(tname).CreateIndex(idx.name)
With idxnew
.Fields = idx.Fields
.Unique = idx.Unique
.Primary = idx.Primary
.Required = idx.Required
.IgnoreNulls = idx.IgnoreNulls
End With
frmtm.dbs.TableDefs(tname).Indexes.Append idxnew
Next
End If
frmtm.tvtable.Nodes.add , , "t" & CStr(frmtm.tvtable.Nodes.Count),
tname
Set dbs = Nothing
Set idx = Nothing
Set idxnew = Nothing
frmmain.mnuexport.Enabled = True
frmtm.tvtable.SetFocus
showstatus "Ready", False
Exit Sub
xoa:
On Error Resume Next
frmtm.dbs.TableDefs.Delete tname
showstatus "Ready", False
MsgBox "Can't create constraint", vbInformation, "Import fail"
Exit Sub

loi:
If Err.Number = 3010 Then
MsgBox "Table already exists", vbInformation, "Import fail"
Exit Sub
End If
If Err.Number = 3066 Then
MsgBox "The table make sure at least one field", vbInformation,
"Import fail"
Exit Sub
End If
showstatus "Ready", False
MsgBox "Can't import this table", vbInformation, "Import fail"
End Sub
Public Function getfiletitle(s As String) As String
'lay ten file, cat bo duong dan, bo phan mo rong (.***) vd:abc
On Error Resume Next
Dim i As Integer
For i = Len(s) To 1 Step -1
If Mid$(s, i, 1) = "\" Then
Exit For
End If
Next
If InStr(1, s, ".", 0) <> 0 Then
getfiletitle = Mid$(s, i + 1, Len(s) - i - 4)
'file khong co phan mo rong
Else
getfiletitle = Mid$(s, i + 1, Len(s) - i)
End If
End Function
Sub mnuimport_Click()
Dim datype As String
Dim da As Database
Dim ppw As String
On Error GoTo loi
'Chon kieu du lieu import
frmdatatype.Show vbModal
datype = frmdatatype.datatype
Unload frmdatatype
If datype = "" Then Exit Sub
setcmdlg (datype)
'Chon file de import
cmdlg.ShowOpen

If cmdlg.FileName <> "" Then
If datype = "access" Then
reopen:
Set da = OpenDatabase(cmdlg.FileName, 0, 0, ";pwd=" & ppw)
Set frmimport.dbs = da
frmimport.daty = datype
frmimport.lbtitle.Caption = frmimport.lbtitle.Caption &
cmdlg.FileTitle
frmimport.Show vbModal
Else
import cmdlg.FileName, datype
End If
End If
Exit Sub
loi:
If Err.Number = 3031 Then
showstatus "Password require", True
frmpassword.Show vbModal
ppw = frmpassword.pw
If ppw <> "" Then
Resume reopen
End If
End If
showstatus "Ready", False
End Sub
Sub mnuopen_Click()
Dim ppw As String
Dim opt As Boolean
Dim bol As Boolean
Dim st As String
Dim accessdb As Database
Dim inf As String
On Error GoTo loi
cmdlg.InitDir = "c:\program files\Microsoft Visual Studio\vb98\"
cmdlg.Filter = "Database File (*.mdb)|*.mdb"
cmdlg.CancelError = True
cmdlg.ShowOpen
showstatus "Openning database ", True
'Flags = 1024 : binh thuong, 1025 :Read Only
If (cmdlg.Flags And FileOpenConstants.cdlOFNReadOnly) =
FileOpenConstants.cdlOFNReadOnly Then
bol = True
inf = Left$(cmdlg.FileTitle, Len(cmdlg.FileTitle) - 4) & " (READ
ONLY)"
Else
bol = False
inf = Left$(cmdlg.FileTitle, Len(cmdlg.FileTitle) - 4)
End If



reopen:
st = ";Database=" & cmdlg.FileName & ";PWD=" & ppw &
";QueryTimeout=1000"
Set accessdb = OpenDatabase("", opt, bol, st)

Set frmtm = New frmtablelist

frmtm.rol = bol
frmtm.Caption = inf
frmtm.Show
showstatus "Ready", False
Exit Sub
loi:
'File co passworld
If Err.Number = 3031 Then
showstatus "Password required", False
frmpassword.Show vbModal
ppw = frmpassword.pw
Unload frmpassword
If ppw <> "" Then
Resume reopen
End If

Xem chi tiết: SOURCE CODECLIENT.doc