SOURCE CODECLIENT.doc

SOURCE CODECLIENT

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

End If

'Share Read Only thi mo Exclusive va Read Only

If Err.Number = 3051 Then

opt = True

bol = True

inf = inf & " (READ ONLY)"

Resume reopen

End If

showstatus "Ready", False

End Sub