Chuyên đề Tìm hiểu về Ngôn ngữ Visual Basic

, Value2, FExpired, LExpired, MinArea, MaxArea, MinPrice, MaxPrice) End Sub Private Sub Command3_Click() Unload Me End Sub Private Sub cmdClose_Click() Unload frm_find_trans End Sub Private Sub Form_Load() If User_Permission = "Administrator" Then chk_expired.Enabled = True End If Set cnnFind = New ADODB.Connection 'cnn.Open "Provider=" & "Microsoft.Jet.OLEDB.3.51;" & "Data Source=" & App.Path & "\Database\advertisement.mdb;" & "Jet OLEDB:Database Password=" & "dankadv;" cnnFind.Provider = "Microsoft.Jet.OLEDB.4.0" cnnFind.Open App.Path & "\database\nhadatdatabase.mdb" frm_floor.Width = 1980 frm_floor.Top = 4380 frm_area.Height = 375 frm_area.Height = 375 frm_price.Height = 375 frm_date.Height = 375 Me.Height = 2590 ' Me.WindowState = 0 Call Default End Sub '-------------------------------------------------------------------------------- If District " " And District "( ALL )" Then 'Match District If rs!District = District Then FDistrict = True Else FDistrict = False End If Else FDistrict = True End If '-------------------------------------------------------------------------------- If Street " " And Street "( ALL )" Then 'Match Street If rs!Street = Street Then FStreet = True Else FStreet = False End If Else FStreet = True End If '-------------------------------------------------------------------------------- If Direction " " Then 'Match Direction If rs!Direction = Direction Then FDirection = True Else FDirection = False End If Else FDirection = True End If '-------------------------------------------------------------------------------- If Location " " Then 'Match Location If rs!Location = Location Then FLocation = True Else FLocation = False End If Else FLocation = True End If '-------------------------------------------------------------------------------- If HWidth -1 Then 'Match Width If rs!Width >= HWidth Then FWidth = True Else FWidth = False End If Else FWidth = True End If '-------------------------------------------------------------------------------- If FDate " " Then 'Match Date of Update Dim Max If CDate(FDate) > CDate(LDate) Then Max = FDate LDate = FDate FDate = Max End If If CDate(rs!dofupdate) >= FDate And CDate(rs!dofupdate) <= LDate Then FoDate = True Else FoDate = False End If Else FoDate = True End If '-------------------------------------------------------------------------------- If FExpired " " Then 'Match Date of Expired Dim MaxD If CDate(FExpired) > CDate(LExpired) Then MaxD = FExpired LExpired = FExpired FExpired = Max End If If CDate(rs!dofupdate) >= FExpired And CDate(rs!dofupdate) <= LExpired Then FoExpired = True Else FoExpired = False End If Else FoExpired = True End If '-------------------------------------------------------------------------------- If HType " " Then ' Match House Type If LCase(rs!thouse) = LCase(HType) Then FType = True Else FType = False End If Else FType = True End If '-------------------------------------------------------------------------------- 'Match Area If MinArea -1 And MaxArea = -1 Then ' Min only If TblTran = "tbl_selling" Or TblTran = "tbl_rent" Then If rs!area >= MinArea Then FArea = True Else FArea = False End If Else If rs!MinArea >= MinArea Then FArea = True Else FArea = False End If End If End If If MinArea = -1 And MaxArea -1 Then 'Max Only If TblTran = "tbl_selling" Or TblTran = "tbl_rent" Then If rs!area <= MaxArea Then FArea = True Else FArea = False End If Else If rs!MaxArea >= MaxArea Then FArea = True Else FArea = False End If End If End If If MinArea -1 And MaxArea -1 Then 'Min And Max If TblTran = "tbl_selling" Or TblTran = "tbl_hire" Then If rs!area >= MinArea And rs!area <= MaxArea Then FArea = True Else FArea = False End If Else If rs!minTarea >= MinArea And rs!MaxTarea <= MaxArea Then FArea = True Else FArea = False End If End If End If If MinArea = -1 And MaxArea = -1 Then FArea = True End If '-------------------------------------------------------------------------------- 'Match Price If MinPrice -1 And MaxPrice = -1 Then If TblTran = "tbl_selling" Or TblTran = "tbl_rent" Then If rs!Price >= MinPrice Then FPrice = True Else FPrice = False End If Else If rs!MinPrice >= MinPrice Then FPrice = True Else FPrice = False End If End If End If If MinPrice = -1 And MaxPrice -1 Then If TblTran = "tbl_selling" Or TblTran = "tbl_rent" Then If rs!Price <= MaxPrice Then FPrice = True Else FPrice = False End If Else If rs!MaxPrice >= MaxPrice Then FPrice = True Else FPrice = False End If End If End If If MinPrice -1 And MaxPrice -1 Then If TblTran = "tbl_selling" Or TblTran = "tbl_hire" Then If rs!Price >= MinPrice And rs!Price <= MaxPrice Then FPrice = True Else FPrice = False End If Else If rs!MinPrice >= MinPrice And rs!MaxPrice <= MaxPrice Then FPrice = True Else FPrice = False End If End If End If If MinPrice = -1 And MaxPrice = -1 Then FPrice = True End If '-------------------------------------------------------------------------------- 'Match Floor number If Oper1 6 Then If Oper1 = 0 Then If rs!fno Value1 Then FFloorNum = True Else FFloorNum = False End If End If If Oper1 = 1 Then If rs!fno = Value1 Then FFloorNum = True Else FFloorNum = False End If End If If Oper1 = 2 Then If rs!fno > Value1 Then FFloorNum = True Else FFloorNum = False End If End If If Oper1 = 3 Then If rs!fno >= Value1 Then FFloorNum = True Else FFloorNum = False End If End If If Oper1 = 4 Then If rs!fno < Value1 Then FFloorNum = True Else FFloorNum = False End If End If If Oper1 = 5 Then If rs!fno <= Value1 Then FFloorNum = True Else FFloorNum = False End If End If Else FFloorNum = True End If '-------------------------------------------------------------------------------- 'Match Total of floor If Oper2 6 Then If Oper2 = 0 Then If rs!toffloor Value2 Then FFloorTot = True Else FFloorTot = False End If End If If Oper2 = 1 Then If rs!toffloor = Value2 Then FFloorTot = True Else FFloorTot = False End If End If If Oper2 = 2 Then If rs!toffloor > Value2 Then FFloorTot = True Else FFloorTot = False End If End If If Oper2 = 3 Then If rs!toffloor >= Value2 Then FFloorTot = True Else FFloorTot = False End If End If If Oper2 = 4 Then If rs!toffloor < Value2 Then FFloorTot = True Else FFloorTot = False End If End If If Oper2 = 5 Then If rs!toffloor <= Value2 Then FFloorTot = True Else FFloorTot = False End If End If Else FFloorTot = True End If '-------------------------------------------------------------------------------- 'FINAL UNION FOUND CONDITION If FTran = True And FAuth = True And FDistrict = True _ And FStreet = True And FWidth = True And FoDate = True _ And FDirection = True And FLocation = True And FType = True _ And FArea = True And FPrice = True And FoExpired = True _ And FFloorNum = True And FFloorTot = True Then found = found + 1 End Function ================================================== 4. Form compose Private Sub Initial() rtxtBox.Text = "" cboSize.Text = "10" cboFont.Text = "MS Sans Serif" End Sub Private Sub lblTransparent() Dim i As Byte For i = 0 To 8 picAlign(i).BackColor = vbButtonFace Next i End Sub Private Sub cboFont_LostFocus() rtxtBox.SelFontName = cboFont.Text rtxtBox.Refresh End Sub Private Sub cboSize_Change() On Error GoTo lbl rtxtBox.SelFontSize = cboSize.Text rtxtBox.Refresh lbl: End Sub Private Sub cboSize_LostFocus() rtxtBox.SelFontSize = cboSize.Text rtxtBox.Refresh End Sub Private Sub cmdClose_Click(Index As Integer) Unload Me End Sub Private Sub cmdSend_Click(Index As Integer) If txtTo.Text = "" Then MsgBox "You must enter the UserName to sent to !", vbInformation, "Message can not be send " Exit Sub End If txtTo.Text = Trim(txtTo.Text) If rtxtBox.Text = "" Then MsgBox "You must type in the message to be sent !", vbInformation, "Message empty !" rtxtBox.SetFocus Exit Sub End If Dim rsU As ADODB.Recordset Set rsU = New ADODB.Recordset rsU.Open "tbl_Account", cnNet, adOpenKeyset, adLockOptimistic, adCmdTable If rsU.RecordCount <= 0 Then Exit Sub End If rsU.MoveFirst Dim Ex As Boolean Ex = False Do While Not rsU.EOF If LCase(rsU.Fields(0)) = LCase(txtTo.Text) Then Ex = True Exit Do End If rsU.MoveNext Loop If Ex = False Then MsgBox "The User '" & txtTo.Text & "' is not exist . Please check down your Send to !", vbCritical, "User Invalid" Exit Sub End If Select Case Index Case 0 Call UpdateM Case 1 End Select MsgBox "Message has been sent to " & txtTo.Text & " !", vbOKOnly + vbInformation, "Note !" Unload Me End Sub Private Sub Form_Load() lblTransparent Initial End Sub Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) If Not FFlag Then lblTransparent FFlag = True End If End Sub Private Sub picAlign_Click(Index As Integer) If Index >= 0 And Index <= 5 Then picAlign(Index).BorderStyle = _ (picAlign(Index).BorderStyle + 1) Mod 2 End If Select Case Index Case 0 rtxtBox.SelBold = Not rtxtBox.SelBold Case 1 rtxtBox.SelItalic = Not rtxtBox.SelItalic Case 2 rtxtBox.SelUnderline = Not rtxtBox.SelUnderline Case 3 rtxtBox.SelAlignment = vbLeftJustify Case 4 rtxtBox.SelAlignment = vbCenter Case 5 rtxtBox.SelAlignment = vbRightJustify Case 6 Seltext = rtxtBox.Seltext rtxtBox.Seltext = "" Case 7 Seltext = rtxtBox.Seltext Case 8 rtxtBox.Seltext = Seltext End Select If Index = 3 Then picAlign(ClickPicAlign).BorderStyle = 0 ClickPicAlign = Index End If If Index >= 6 And Index <= 8 Then picAlign(ClickPicEdit).BorderStyle = 0 ClickPicEdit = Index End If End Sub Private Sub picAlign_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single) If Index >= 6 And Index <= 8 Then picAlign(Index).BorderStyle = 1 End If End Sub Private Sub picAlign_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single) If Index MoveLabel Then picAlign(MoveLabel).BackColor = vbButtonFace picAlign(Index).BackColor = vbWhite '&H80000016 MoveLabel = Index End If FFlag = False End Sub Private Sub picAlign_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single) If Index >= 6 And Index <= 8 Then picAlign(Index).BorderStyle = 0 End If End Sub Private Sub UpdateM() Dim rs As New ADODB.Recordset If Not TSend Then TableM = "Tbl_Message_Account" End If rs.Open TableM, cnNet, adOpenDynamic, adLockPessimistic, adCmdTable rs.AddNew rs!RUserID = Trim(txtTo.Text) rs!Suserid = User_ID rs!DofSending = Date rs!Subject = txtSubject.Text If TSend Then rs.Fields(1) = Tcode End If rtxtBox.SaveFile (netPathDir + "User\" + Trim(txtTo.Text) + "\" + CStr(rs.Fields(0)) + ".rtf") rs.Update End Sub ================================================== 5.form browse transaction Private Sub cmb_auth_Click() cmd_qsearch.Enabled = True End Sub Private Sub cmb_dist_Click() cmd_qsearch.Enabled = True If cmb_dist.Text = "( ALL )" Then Dim rs_street As ADODB.Recordset Set rs_street = New ADODB.Recordset rs_street.Open "Tbl_street", cnNet, adOpenKeyset, adLockOptimistic, adCmdTable rs_street.MoveFirst Do While Not rs_street.EOF cmb_street.AddItem rs_street.Fields(2).Value rs_street.MoveNext Loop Exit Sub End If Call Add_Street End Sub Private Sub cmb_id_Click() cmd_qsearch.Enabled = True End Sub Private Sub cmb_id_GotFocus() cmb_id.SelStart = 0 cmb_id.SelLength = Len(cmb_id.Text) End Sub Private Sub cmb_street_Click() cmd_qsearch.Enabled = True End Sub Private Sub cmd_close_Click() Unload Me End Sub Private Sub cmd_cont_Click() Dim au As String Dim item_name As String grid1.row = row_auth grid1.Col = 6 au = grid1.Text grid1.Col = 1 item_name = grid1.Text If row_auth = 0 Then MsgBox "You must choose one of User in the list", vbInformation, "Contact Failed !" Exit Sub End If If Tab_i = 1 Then ' Tab_i = TableM = "tbl_message_selling" End If If Tab_i = 2 Then ' Tab_i = TableM = "tbl_message_buying" End If If Tab_i = 3 Then ' Tab_i = TableM = "tbl_message_rent" End If If Tab_i = 4 Then ' Tab_i = TableM = "tbl_message_hire" End If Tcode = item_name frmCompose.txtTo = au Unload Me frmCompose.Show End Sub Private Sub cmd_detail_Click() Dim i As Byte For i = 1 To 4 If tab1.Tabs(i).Selected Then Tab_i = i End If Next i Me.Hide frm_adv_det.List_Call = True frm_adv_det.Item_call = grid1.TextMatrix(grid1.RowSel, 1) frm_adv_det.Show End Sub Private Sub cmd_find_Click() Unload Me frm_find_trans.Show End Sub Private Sub cmd_list_all_Click() If tab1.Tabs(1).Selected Then Rs_local.Close Set Rs_local = New ADODB.Recordset Rs_local.Open "Tbl_Selling", cnNet, adOpenKeyset, adLockOptimistic, adCmdTable If grid1.rows - 1 = Rs_local.RecordCount Then ' MsgBox "You've already list all item", vbExclamation, "Listing Failed !" Exit Sub End If grid1.Clear Create_grid_header_SH Call ADD_ITEM_SEL End If If tab1.Tabs(2).Selected Then Rs_local.Close Set Rs_local = New ADODB.Recordset Rs_local.Open "Tbl_Buying", cnNet, adOpenKeyset, adLockOptimistic, adCmdTable If grid1.rows - 1 = Rs_local.RecordCount Then ' MsgBox "You've already list all item", vbExclamation, "Listing Failed !" Exit Sub End If grid1.Clear Create_grid_header_BR Call ADD_ITEM_SEL End If If tab1.Tabs(3).Selected Then Rs_local.Close Set Rs_local = New ADODB.Recordset Rs_local.Open "Tbl_Rent", cnNet, adOpenKeyset, adLockOptimistic, adCmdTable If grid1.rows - 1 = Rs_local.RecordCount Then 'MsgBox "You've already list all item", vbExclamation, "Listing Failed !" Exit Sub End If grid1.Clear Create_grid_header_BR Call ADD_ITEM_SEL End If If tab1.Tabs(4).Selected Then Rs_local.Close Set Rs_local = New ADODB.Recordset Rs_local.Open "Tbl_Hire", cnNet, adOpenKeyset, adLockOptimistic, adCmdTable If grid1.rows - 1 = Rs_local.RecordCount Then 'MsgBox "You've already list all item", vbExclamation, "Listing Failed !" Exit Sub End If grid1.Clear Create_grid_header_SH Call ADD_ITEM_SEL End If End Sub Private Sub cmd_New_Click() frm_adv_new.Show vbModal End Sub Private Sub cmd_qsearch_Click() row = 0 grid1.Enabled = True Dim found As Boolean Dim completed As Boolean Dim f_id As Boolean Dim f_street As Boolean Dim f_dist As Boolean Dim f_auth As Boolean Dim i As Integer Dim per As Integer If cmb_id.Text = "( ALL )" And cmb_street.Text = "( ALL )" And cmb_dist.Text = "( ALL )" And cmb_auth.Text = "( ALL )" Then If grid1.rows Rs_local.RecordCount Then Call ADD_ITEM_SEL End If Exit Sub End If grid1.Clear If cmb_id.Text = "" And cmb_street.Text = "" And cmb_dist.Text = "" And cmb_auth.Text = "" Then MsgBox "You must type in on value in one of Item ID, Street, District or Author ID", vbExclamation, "Quick Search Failed !" cmd_qsearch.Enabled = False Exit Sub Else If Rs_local.RecordCount >= 1 Then Rs_local.MoveFirst pic_progress.Visible = True pic_progress.Refresh Do While Not Rs_local.EOF per = per + 1 UpdateStatus pic_progress, per / Rs_local.RecordCount, "Searching ...", True found = False If Rs_local.Fields(0) = cmb_id.Text Then 'Item ID match or not f_id = True Else f_id = False If cmb_id.Text = "( ALL )" Then f_id = True End If End If If tab1.Tabs(1).Selected Or tab1.Tabs(4).Selected Then If Rs_local!Street = cmb_street.Text Then 'Match street for Sell and Hire f_street = True Else f_street = False If cmb_street.Text = "( ALL )" Then f_street = True End If End If If Rs_local!District.Value = cmb_dist.Text Then 'match distict f_dist = True Else f_dist = False If cmb_dist.Text = "( ALL )" Then f_dist = True End If End If If Rs_local!userid = cmb_auth.Text Then 'Match author f_auth = True Else f_auth = False If cmb_auth.Text = "( ALL )" Then f_auth = True End If End If Else If Rs_local!Street = cmb_street.Text Then 'Match street for buy and Rent f_street = True Else f_street = False If cmb_street.Text = "( ALL )" Then f_street = True End If End If If Rs_local!District.Value = cmb_dist.Text Then 'match distict f_dist = True Else f_dist = False If cmb_dist.Text = "( ALL )" Then f_dist = True End If End If If Rs_local!userid = cmb_auth.Text Then 'Match author f_auth = True Else f_auth = False If cmb_auth.Text = "( ALL )" Then f_auth = True End If End If End If If f_id = True And f_street = True And f_auth = True And f_dist = True Then found = True End If If found = True Then completed = True row = row + 1 grid1.rows = row + 1 If tab1.Tabs(1).Selected Or tab1.Tabs(4).Selected Then Call ADD_ITEM Call Create_grid_header_SH Else Call ADD_ITEM_B Call Create_grid_header_BR End If End If Rs_local.MoveNext Loop pic_progress.Visible = False 'If completed = False Then ' MsgBox "Item not found !", vbExclamation, "Searching Comleted!" ' Call Create_grid_header ' grid1.rows = 1 ' grid1.Enabled = False 'End If End If End If End Sub Private Sub Command1_Click() grid1.Col = grid1.MouseCol grid1.row = grid1.MouseRow MsgBox grid1.Text End Sub Private Sub Form_Load() user_name = User_ID Call Rs_selling Call statusbar Call create_tabs Call Create_grid_header_SH Call Header_alig_cen Call Column_width_SH grid1.ScrollTrack = True Timer1.Enabled = True cmb_street.AddItem "( ALL )" cmb_dist.AddItem "( ALL )" cmb_dist.AddItem "Ba Đình" cmb_dist.AddItem "Cầu Giấy" cmb_dist.AddItem "Đống Đa" cmb_dist.AddItem "Hai Bà Trưng" cmb_dist.AddItem "Hoàn Kiếm" cmb_dist.AddItem "Tây Hồ" cmb_dist.AddItem "Thanh Xuân" cmb_dist.Text = cmb_dist.List(0) cmb_dist_Click cmb_street.Text = cmb_street.List(0) End Sub Private Sub statusbar() 'Adding Items to Status bar Dim cpl As Panel Set cpl = stat_bar.Panels.Add(1, , " Advertisment Page ") cpl.AutoSize = sbrContents Set cpl = stat_bar.Panels.Add(2, , " Current User : " & user_name & " ") cpl.Bevel = sbrNoBevel cpl.Width = 2900 cpl.AutoSize = sbrNoAutoSize Set cpl = stat_bar.Panels.Add(3, , " Please Wait ! ") 'cpl.AutoSize = sbrSpring cpl.Width = 4020 Set cpl = stat_bar.Panels.Add(4, , , sbrDate) cpl.AutoSize = sbrContents cpl.Alignment = sbrCenter Set cpl = stat_bar.Panels.Add(5, , , sbrTime) cpl.AutoSize = sbrContents cpl.Alignment = sbrCenter End Sub Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) stat_bar.Panels(2).Bevel = sbrNoBevel End Sub Private Sub frm_option_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) Me.MousePointer = 0 stat_bar.Panels(2).Bevel = sbrNoBevel End Sub Private Sub grid1_DblClick() Dim i As Byte For i = 1 To 4 If tab1.Tabs(i).Selected = True Then Tab_i = i End If Next i frm_adv_det.List_Call = True frm_adv_det.Item_call = grid1.TextMatrix(grid1.RowSel, 1) Unload Me frm_adv_det.Show End Sub Private Sub grid1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) row_auth = grid1.MouseRow If Multi_sel = True Then ' Disable Multi Select grid1.HighLight = flexHighlightWithFocus Multi_sel = False End If Row_sel = grid1.RowSel If row_auth 0 Then If Button = 2 Then PopupMenu mnuact End If End If End Sub Private Sub grid1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) If Y > 4780 Then grid1.ToolTipText = "" frm_adv.MousePointer = 0 Exit Sub End If Dim name_u As String If grid1.rows <= 1 Then Exit Sub End If If grid1.MouseCol = 6 And grid1.MouseRow > 0 Then If grid1.TextMatrix(grid1.MouseRow, 6) "" Then frm_adv.MousePointer = 99 frm_adv.MouseIcon = LoadPicture(App.Path & "\image\link.ico") name_u = grid1.TextMatrix(grid1.MouseRow, 6) grid1.ToolTipText = " Contact to " & name_u & " " Else grid1.ToolTipText = "" frm_adv.MousePointer = 0 Exit Sub End If Else grid1.ToolTipText = "" frm_adv.MousePointer = 0 End If If grid1.MouseRow = 0 Then grid1.ToolTipText = "" frm_adv.MousePointer = 0 End If End Sub Private Sub grid1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) Row_new_sel = grid1.RowSel If Row_sel Row_new_sel Then Multi_sel = True grid1.HighLight = flexHighlightNever End If End Sub Private Sub Image4_Click() Unload Me End Sub Private Sub create_tabs() tab1.TabFixedHeight = 600 tab1.TabFixedWidth = (tab1.Height - 90) / 4 tab1.Tabs(1).Caption = "Selling" tab1.Tabs(1).ToolTipText = "Selling Items" tab1.Tabs.Add 2, , "Buying" tab1.Tabs.Add 3, , "For Rent" tab1.Tabs.Add 4, , "Hire" End Sub Private Sub mnucont_Click() cmd_cont_Click End Sub Private Sub mnudet_Click() Dim i As Byte For i = 1 To 4 If tab1.Tabs(i).Selected Then Tab_i = i End If Next i Me.Hide frm_adv_det.Show End Sub Private Sub mnuDetail_Click() cmd_detail_Click End Sub Private Sub mnuFInd_Click() cmd_find_Click End Sub Private Sub mnunew_Click() cmd_New_Click End Sub Private Sub stat_bar_Click() If user_acc = True Then Unload Me frm_account.Acc_user_id = User_ID frm_account.Show End If End Sub Private Sub stat_bar_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) If X stat_bar.Panels(2).Left Then stat_bar.Panels(2).Bevel = sbrRaised user_acc = True stat_bar.Panels(2).ToolTipText = "Check for " & user_name & "'s account " stat_bar.MousePointer = ccCustom stat_bar.MouseIcon = LoadPicture(App.Path & "\image\link.ico") Else user_acc = False stat_bar.MousePointer = ccArrow stat_bar.Panels(2).Bevel = sbrNoBevel End If End Sub Private Sub tab1_Click() If tab1.Tabs(1).Selected Then If Tab_index = 1 Then Exit Sub Else Tab_index = 1 End If Rs_local.Close Set Rs_local = New ADODB.Recordset Rs_local.Open "Tbl_Selling", cnNet, adOpenKeyset, adLockOptimistic, adCmdTable grid1.Clear Create_grid_header_SH Call ADD_ITEM_SEL End If If tab1.Tabs(2).Selected Then If Tab_index = 2 Then Exit Sub Else Tab_index = 2 End If Rs_local.Close Set Rs_local = New ADODB.Recordset Rs_local.Open "Tbl_Buying", cnNet, adOpenKeyset, adLockOptimistic, adCmdTable grid1.Clear Create_grid_header_BR Call ADD_ITEM_SEL End If If tab1.Tabs(3).Selected Then If Tab_index = 3 Then Exit Sub Else Tab_index = 3 End If Rs_local.Close Set Rs_local = New ADODB.Recordset Rs_local.Open "Tbl_Rent", cnNet, adOpenKeyset, adLockOptimistic, adCmdTable grid1.Clear Create_grid_header_BR Call ADD_ITEM_SEL End If If tab1.Tabs(4).Selected Then If Tab_index = 4 Then Exit Sub Else Tab_index = 4 End If Rs_local.Close Set Rs_local = New ADODB.Recordset Rs_local.Open "Tbl_Hire", cnNet, adOpenKeyset, adLockOptimistic, adCmdTable grid1.Clear Create_grid_header_SH Call ADD_ITEM_SEL End If End Sub Private Sub Timer1_Timer() Call ADD_ITEM_SEL Timer1.Enabled = False End Sub Private Sub Rs_selling() ' Create rs_local connection Set Rs_local = New ADODB.Recordset Rs_local.Open "Tbl_selling", cnNet, adOpenKeyset, adLockOptimistic, adCmdTable 'Rs_local.Open "auth", cnnet, adOpenKeyset, adLockOptimistic, adCmdTable End Sub ====================================================== 6. form user manager Private Sub cmdNext_Click() With rsAccount .MoveNext If .EOF Then .MoveLast End With With rsUserInfo .MoveNext If .EOF Then .MoveLast End With 'cobPermission.Text = rsAccount!Permission 'cobAge.Text = rsUserInfoBofYear Display End Sub Private Sub cmdPrevious_Click() With rsAccount .MovePrevious If .BOF Then .MoveFirst End With With rsUserInfo .MovePrevious If .BOF Then .MoveFirst End With 'cobPermission.Text = rsAccount!Permission 'cobAge.Text = rsUserInfoBofYear Display End Sub Private Sub cmdReset_Click() Dim ans As Integer ans = MsgBox("Are you sure to Reset this Account's accession time?", vbYesNo, "Warning!") If ans = vbNo Then Exit Sub Else txtStockLeft.Text = "0000" txtExprised.Text = "00.00" End If End Sub Private Sub cmdAdd_Click() Dim ctl As Control For Each ctl In Controls If TypeOf ctl Is TextBox Or TypeOf ctl Is ComboBox Then ctl.Enabled = True ctl.Text = "" End If If TypeOf ctl Is CommandButton Then ctl.Enabled = False End If Next ctl cmdSave.Enabled = True cmdCancel.Enabled = True cmdFind.Enabled = True cmdHelp.Enabled = True cmdClearPass.Enabled = True txtExprised.Text = "12.00" rsUserInfo.AddNew rsAccount.AddNew cobUserID.SetFocus cobPermission.Text = "Customer" optMale.Value = True txtExprised.Text = "12.00" txtStockLeft.Text = "0" cmdAdd.Enabled = False cmdSave.Enabled = True cmdHelp.Enabled = True cmdFind.Enabled = True cmdExit.Enabled = False cmdFirst.Enabled = False cmdPrevious.Enabled = False cmdNext.Enabled = False cmdLast.Enabled = False cmdReset.Enabled = False cmdUpgrade.Enabled = True cmdDel.Enabled = False cmdCancel.Enabled = True addFlag = True End Sub Private Sub cmdSave_Click() On Error GoTo Err '==============CHECK INPUT DATA================== If Len(cobUserID) 16 Then MsgBox "User ID must be more than 4 characters and less then 16 characters. Please Enter a valid Name in the UserID field!", vbOKOnly, "System Alert!" cobUserID.SetFocus Exit Sub End If If Len(txtPass) > 50 Or Len(txtConPass) > 50 Then MsgBox "Password must less than 50 characters.", vbOKOnly, "System Alert!" txtPass.SetFocus Exit Sub End If If txtPass.Text txtConPass.Text Then MsgBox "The Password you typed don't match. Please type and confirm the Password again.", vbOKOnly, "System Alert" txtPass.SetFocus Exit Sub End If If txtIDCode = "" Then MsgBox "Please Enter your Identify Code.", vbOKOnly, "System Alert" txtIDCode.SetFocus Exit Sub End If '=====================================END CHECK=============== Save frmUserMan.Refresh Err: If Err.Number = -2147217887 Then rsUserInfo.CancelUpdate rsAccount.CancelUpdate cobUserID.SetFocus End If Display End Sub Private Sub cmdUpgrade_Click() Dim X As Integer Dim s As String s = (InputBox("Enter New access time:", "House Transaction Center")) If IsNumeric(s) = True Then X = CInt(s) Else MsgBox "Please enter new valid time stock for this user", vbOKOnly, "Warning!" cmdUpgrade.SetFocus End If txtExprised.Text = X End Sub Private Sub cobAge_GotFocus() Dim i As Integer For i = 1930 To 2100 cobAge.AddItem i Next i End Sub Private Sub cobUserID_GotFocus() AddUserID End Sub Private Sub Form_Activate() If user_i "" Then Do While Not rsUserInfo.EOF If user_i = rsUserInfo!userid Then Exit Do End If rsUserInfo.MoveNext Loop Do While Not rsAccount.EOF If user_i = rsAccount!userid Then Exit Do End If rsAccount.MoveNext Loop End If Display End Sub Private Sub Form_Load() 'creat the connection to table Tbl_User_Infomation Set rsUserInfo = New ADODB.Recordset rsUserInfo.Open "Tbl_User_Infomation", cnNet, adOpenDynamic, adLockOptimistic, adCmdTable 'creat the connection to table Tbl_Account Set rsAccount = New ADODB.Recordset rsAccount.Open "Tbl_Account", cnNet, adOpenDynamic, adLockOptimistic, adCmdTable cobPermission.Text = "" cmdSave.Enabled = False End Sub Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) Call ImplodeForm(Me, 2, 500, 1) 'Effects End Sub Public Sub MakeDir() Dim fso As New FileSystemObject Dim dir As Folder On Error GoTo Err fso.CreateFolder (netPathDir + "User\" + cobUserID.Text) Exit Sub Err: MsgBox "This Folder is already exist", vbOKOnly End Sub Private Sub txtAddress_GotFocus() txtAddress.SelStart = 0 txtAddress.SelLength = Len(txtAddress) End Sub Public Sub RemoveDir() Dim fso As New FileSystemObject Dim dir As Folder On Error GoTo Err Set dir = fso.GetFolder(netPathDir + "User\" + cobUserID) dir.Delete Exit Sub 'RmDir netPathDir + "User\" + cobUserID Err: MsgBox "Folder is not exist ! Nothing is deleted", vbOKOnly, "Warning" End Sub Public Sub Save() With rsUserInfo ' .AddNew !userid = cobUserID.Text If txtUserName.Text "" Then !UserName = txtUserName.Text End If If txtIDCode.Text "" Then !idcard = txtIDCode.Text End If If txtAddress.Text "" Then !caddress = txtAddress.Text End If If cobAge.Text "" Then !bofyear = cobAge.Text End If If txtPhone.Text "" Then !phone = txtPhone.Text End If If txtHandphone.Text "" Then !mobile = txtHandphone.Text End If If txtEmail.Text "" Then !email = txtEmail.Text End If !sex = optMale.Value .Update End With With rsAccount ' .AddNew !userid = cobUserID.Text !Password = txtConPass.Text !permission = cobPermission.Text !accesstime = txtExprised.Text !taccount = txtStockLeft.Text rsAccount.Update End With cmdAdd.Enabled = True cmdSave.Enabled = False cmdHelp.Enabled = True cmdFind.Enabled = True cmdExit.Enabled = True cmdFirst.Enabled = True cmdPrevious.Enabled = True cmdNext.Enabled = True cmdLast.Enabled = True cmdReset.Enabled = True cmdUpgrade.Enabled = True cmdDel.Enabled = True If addFlag Then Call MakeDir End If MsgBox "Record Update successful.", vbOKOnly, "Note" End Sub ====================================================== 7. Form user information Private Sub chk_view_info_Click() cmdSave.Enabled = True End Sub Private Sub cmd_acc_Click() frm_account.Acc_user_id = Me.Us_ID Unload Me frm_account.Show End Sub Private Sub cmd_Exit_Click() Unload Me 'mdi.Show End Sub Private Sub Create_rs_lan() Set Rs_LAN = New ADODB.Recordset Rs_LAN.Open "Tbl_User_Infomation", cnNet, adOpenKeyset, adLockOptimistic, adCmdTable End Sub Private Sub cmdSave_Click() View_info = chk_view_info.Value 'MsgBox Rs_LAN!userid If View_info = True Then Rs_LAN.Fields(9).Value = True Else Rs_LAN.Fields(9).Value = False End If Rs_LAN.Update cmdSave.Enabled = False End Sub Private Sub Form_Load() Call Create_rs_lan ' Us_ID = User_ID Me.Caption = "Information about " & Us_ID End Sub Public Sub Match_user_ID(UserName As String) F = False Do While Not Rs_LAN.EOF If UserName = Rs_LAN!userid Then Call Display If UserName = User_ID Then cmdSave.Enabled = True chk_view_info.Enabled = True cmd_acc.Enabled = True Else cmdSave.Enabled = Not True chk_view_info.Enabled = Not True cmd_acc.Enabled = Not True End If Exit Do End If Rs_LAN.MoveNext Loop If F = False Then MsgBox "User " & Us_ID & " in not exist at the moment !", vbCritical, " User not exist !" frm_adv_det.Adv_det_call = True Unload Me End If End Sub Private Sub Display() F = True txt_address.Locked = True lbl_userID.Caption = Rs_LAN!userid 'User Id can't be Null lbl_user_name.Caption = Rs_LAN!UserName 'User name can't be Null If IsNull(Rs_LAN!bofyear) = False Then 'Year of birth can be NULL lbl_year.Caption = Rs_LAN!bofyear Else lbl_year.Caption = "" End If If Rs_LAN!sex = True Then lbl_sex.Caption = "Male" ' Sex can't be Null Else lbl_sex.Caption = "Female" End If If IsNull(Rs_LAN!caddress) = False Then 'Address can be NULL txt_address.Text = Rs_LAN!caddress Else lbl_year.Caption = "" End If lbl_ID.Caption = Rs_LAN!idcard ' ID Card can't be Null If IsNull(Rs_LAN!phone) = False Then ' Phone Number can be NULL lbl_phone.Caption = Rs_LAN!phone Else lbl_year.Caption = "" End If If IsNull(Rs_LAN!mobile) = False Then 'Mobile phone can be NULL lbl_mobile.Caption = Rs_LAN!mobile Else lbl_year.Caption = "" End If If IsNull(Rs_LAN!email) = False Then 'E-mail can be NULL lbl_email.Caption = Rs_LAN!email Else lbl_year.Caption = "" End If If Rs_LAN!viewinfo = True Then chk_view_info.Value = 1 View_info = True Else chk_view_info.Value = 0 View_info = False Dim ctl As Control For Each ctl In Controls If TypeOf ctl Is label Then ctl.Enabled = False End If Next ctl 'frm_user.Enabled = False 'frm_per.Enabled = False End If 'txt_address.Locked = True End Sub Private Sub Not_view() Me.Visible = False MsgBox "You are not allowed to view " & Us_ID & " personal information !", vbCritical, "Not Authorized !" Unload frm_user_detail End Sub ====================================================== 8. Form option Option Explicit Dim tblEdit As String Dim rsEdit As ADODB.Recordset Dim flagCancelEdit As Boolean, flagStreet As Boolean Dim flagCancel As Boolean, flagAdd As Boolean Dim flagRate As Boolean Dim rowSel1 As Long, rowSel2 As Long 'cho fgridbackup Dim RowSelRestore As Long Private Sub chkPath_Click() If chkPath.Value = 0 Then chkPathE (False) Else chkPathE (True) End If End Sub Private Sub cmdApply_Click() Dim fso As New FileSystemObject Dim fil As File, ts As TextStream Dim TypePath As Byte If tbsOptions.SelectedItem.Index = 1 Then If fso.FileExists(PathLogFile) = False Then fso.CreateTextFile (PathLogFile) Else Set fil = fso.GetFile(PathLogFile) End If Set ts = fil.OpenAsTextStream(ForWriting) ts.WriteLine (txtNetpath.Text) ts.WriteLine (txtLocalPath.Text) ts.WriteLine (txtCRequest.Text) ts.WriteLine (txtComputer.Text) ts.Close cmdApply.Enabled = False Call InitialData End If netPathDir = Left(NetPath, Len(NetPath) - Len("Database\NhadatDatabase.mdb")) If flagRate And tbsOptions.SelectedItem.Index = 2 Then Call UpdateRate cmdApply.Enabled = False End If End Sub Private Sub cmdBackupBrow_Click() On Error GoTo dlgerror With dlgFileOpen .CancelError = True .ShowOpen .Filter = "*.*" txtBPath.Text = .FileName End With dlgerror: End Sub Private Sub cmdBackupSave_Click() Call backup Call DispDatagrid Call chkPathE(False) chkPath.Value = 0 fgridBackup.SetFocus 'fgridBackup.RowSel End Sub Private Sub cmdCancel_Click() flagCancel = True Unload Me End Sub Private Sub cmdDelBackup_Click() Dim temp As Long Dim rsBackup As ADODB.Recordset Dim Response As String If rowSel1 > rowSel2 Then temp = rowSel1 rowSel1 = rowSel2 rowSel2 = temp End If If rowSel1 rowSel2 Then Response = MsgBox("Are you sure Delete" & _ " " & rowSel2 - rowSel1 + 1 & " Backups ?", _ vbYesNo, "Warning !") Else Response = MsgBox("Are you sure Delete" & _ " this Backup ?", vbYesNo, "Warning !") End If 'Huy Delete khi click vao No If Response = vbNo Then Exit Sub End If '==============Delete Recordsets============= Set rsBackup = New ADODB.Recordset rsBackup.Open "Tbl_Backup", cnNet, adOpenDynamic, _ adLockPessimistic, adCmdTable With rsBackup For temp = rowSel1 To rowSel2 .MoveFirst Do While Not .EOF If .Fields(0) = fgridBackup.TextMatrix(temp, 0) Then Call DelFile(.Fields(0), .Fields(3)) .Delete Exit Do End If .MoveNext Loop Next temp End With MsgBox "Files have been deleted.", vbOKOnly, "Note !" Call DispDatagrid End Sub Private Sub cmdOk_Click() Unload Me End Sub Private Sub cboEdit_GotFocus(Index As Integer) Dim i As Byte If Index 0 Then For i = 0 To cboEdit(0).ListCount - 1 If cboEdit(0).Text = cboEdit(0).List(i) Then Exit Sub End If Next i MsgBox "You must select Item from Type Edit.", vbOKOnly, "Warning !!!" cboEdit(0).SetFocus End If Select Case Index Case 0 Case 1 Case 2 Case 3 End Select End Sub Private Sub cboEdit_LostFocus(Index As Integer) 'Dim Item As String Select Case Index Case 0 If cboEdit(0).Text "" Then Call cmdEditE(True, False, False, False) End If '==========Case 1========== Select Case cboEdit(0).ListIndex Case 0 tblEdit = "Tbl_District" cboEdit(1).Width = 2115 txtEditContent.Width = 2115 cboEdit(2).Visible = False Call AddItemcboEdit(1, 1) flagStreet = False Case 1 tblEdit = "Tbl_District" Call AddItemcboEdit(1, 2) tblEdit = "Tbl_Street" flagStreet = True cboEdit(1).Width = 2115 txtEditContent.Width = 2115 cboEdit(2).Visible = True cboEdit(2).SetFocus Case 2 tblEdit = "Tbl_Type_House" cboEdit(1).Width = 3000 txtEditContent.Width = 3000 cboEdit(2).Visible = False flagStreet = False Call AddItemcboEdit(1, 1) Case Else Exit Sub End Select '==========End Case 1========== Case 1 If cboEdit(0).ListIndex = 1 And cboEdit(1).Text = "" Then MsgBox "You must select District before Street selection !", vbOKOnly, "Warning !" cboEdit(2).SetFocus End If 'If cboEdit(0).ListIndex 1 And cboEdit(1).Text "" Then Call cmdEditE(True, True, False, True) txtEditContent.Text = cboEdit(1).Text 'ElseIf cboEdit(0).ListIndex = 1 Then ' txtEditContent.Text = cboEdit(1).Text 'End If Case 2 If cboEdit(2).Text "" Then If flagAdd Then Call cmdEditE(True, False, True, False) Else Call cmdEditE(False, True, True, False) End If Call AddcboStreet End If End Select End Sub Private Sub cmdEdit_Click(Index As Integer) Select Case Index Case 0 If Not flagCancelEdit Then cmdEdit(Index).Caption = "Cancel" Call cmdEditE(True, False, True, False) cboEdit(1).Enabled = False flagCancelEdit = True flagAdd = True txtEditContent.SetFocus txtEditContent.Locked = False txtEditContent.Text = "" Else cmdEdit(Index).Caption = "Add New" Call cmdEditE(True, True, False, True) cboEdit(1).Enabled = True flagCancelEdit = False cboEdit(0).SetFocus txtEditContent.Locked = True txtEditContent.Text = "" End If Case 1 If Not flagCancelEdit Then cmdEdit(Index).Caption = "Cancel" flagCancelEdit = True flagAdd = False txtEditContent.Locked = False Call cmdEditE(False, True, True, False) Else cmdEdit(Index).Caption = "Modify" txtEditContent.Text = "" flagCancelEdit = False txtEditContent.Locked = True Call cmdEditE(True, True, False, True) End If Case 2 txtEditContent.Locked = True flagCancelEdit = False cboEdit(1).Enabled = True cmdEdit(0).Caption = "Add New" cmdEdit(1).Caption = "Modify" If flagAdd Then Call UpdateEdit(0, tblEdit) Else Call UpdateEdit(1, tblEdit) End If txtEditContent.Text = "" cboEdit(0).SetFocus Call cmdEditE(True, True, False, True) Case 3 DeleteEdit txtEditContent.Text = "" cboEdit(0).SetFocus Call cmdEditE(False, False, False, False) End Select End Sub Private Sub cmdResBackup_Click() Dim fso As New FileSystemObject Dim Dfile As File Dim TypeData As String Dim Index As String With fgridBackup .row = RowSelRestore .Col = 0 Index = CStr(.Text) .Col = 3 TypeData = .Text End With Select Case TypeData Case "nhadatDatabase" Set Dfile = fso.GetFile(netPathDir + "Backup\N" + Index + ".mdb") Call Dfile.Copy(netPathDir + "Database\nhadatDatabase.mdb", True) Case "ServerDatabase" Set Dfile = fso.GetFile(netPathDir + "Backup\S" + Index + ".mdb") Case "ALL" Set Dfile = fso.GetFile(netPathDir + "Backup\N" + Index + ".mdb") Call Dfile.Copy(netPathDir + "Database\nhadatDatabase.mdb", True) Set Dfile = fso.GetFile(netPathDir + "Backup\S" + Index + ".mdb") Call Dfile.Copy(netPathDir + "Database\ServerDatabase.mdb", True) End Select MsgBox "Databases have been Restored.", vbOKOnly, "Note !" End Sub Private Sub fgridBackup_Click() RowSelRestore = fgridBackup.MouseRow End Sub Private Sub fgridBackup_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) rowSel1 = fgridBackup.MouseRow End Sub Private Sub fgridBackup_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) rowSel2 = fgridBackup.MouseRow End Sub Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) Dim i As Integer 'handle ctrl+tab to move to the next tab If Shift = vbCtrlMask And KeyCode = vbKeyTab Then i = tbsOptions.SelectedItem.Index If i = tbsOptions.Tabs.Count Then 'last tab so we need to wrap to tab 1 Set tbsOptions.SelectedItem = tbsOptions.Tabs(1) Else 'increment the tab Set tbsOptions.SelectedItem = tbsOptions.Tabs(i + 1) End If End If End Sub Private Sub Form_Load() 'center the form Me.Move (Screen.Width - Me.Width) / 2, _ (Screen.Height - Me.Height) / 4 'tbsOptions.Tabs (1) Call cmdEditE(False, False, False, False) Call DispPath Call DispRate Call DispDatagrid Call SizeGrid txtEditContent.Locked = True '==============Frame 3===============' txtBPath.Enabled = False cmdBackupBrow.Enabled = False lblBackupPath.Enabled = False fgridBackup.Enabled = True netPathDir = Left(NetPath, Len(NetPath) - Len("Database\NhadatDatabase.mdb")) End Sub Private Sub tbsOptions_Click() Dim i As Integer 'show and enable the selected tab's controls 'and hide and disable all others For i = 0 To tbsOptions.Tabs.Count - 1 If i = tbsOptions.SelectedItem.Index - 1 Then fraOptions(i).Left = 210 fraOptions(i).Enabled = True Else fraOptions(i).Left = -20000 fraOptions(i).Enabled = False End If Next If tbsOptions.SelectedItem.Index = 1 Or tbsOptions.SelectedItem.Index = 2 Then cmdApply.Enabled = True Else cmdApply.Enabled = False End If End Sub Private Sub cmdSetupBrow_Click() Dim TypePath As Byte Select Case cboTypePath.Text Case "Network" TypePath = 0 Case "Local" TypePath = 1 Case Else MsgBox "You must select TypePath", vbOKOnly, "Stop !!" cboTypePath.SetFocus Exit Sub End Select On Error GoTo dlgerror With dlgFileOpen .CancelError = True .ShowOpen .Filter = "*.*" If TypePath = 0 Then .DialogTitle = "Select Network Path" txtNetpath.Text = .FileName Else .DialogTitle = "Select Local Path" txtLocalPath.Text = .FileName End If End With dlgerror: End Sub Private Sub DispPath() txtNetpath.Text = NetPath txtLocalPath.Text = LocalPath txtCRequest.Text = CheckTime txtComputer.Text = ComName End Sub Private Sub cmdSetupTest_Click() Dim cnNetTest As ADODB.Connection, cnLocalTest As ADODB.Connection On Error GoTo cnerror Set cnNetTest = New ADODB.Connection cnNetTest.Provider = "Microsoft.Jet.oledb.3.51" cnNetTest.Open txtNetpath.Text 'Connection Local Machine Set cnLocalTest = New ADODB.Connection cnLocalTest.Provider = "Microsoft.Jet.oledb.3.51" cnLocalTest.Open txtLocalPath.Text MsgBox "Connection successful !!!", vbOKOnly, "Test Connection " Exit Sub cnerror: MsgBox "Connection has a problem." + Chr(13) + _ "Contact Administrator for Help.", vbOKOnly, "Warning !!!" End Sub Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) Dim fso As New FileSystemObject Dim fil As File, ts As TextStream Dim TypePath As Byte If Not flagCancel Then If fso.FileExists(PathLogFile) = False Then fso.CreateTextFile (PathLogFile) Else Set fil = fso.GetFile(PathLogFile) End If Set ts = fil.OpenAsTextStream(ForWriting) ts.WriteLine (txtNetpath.Text) ts.WriteLine (txtLocalPath.Text) ts.WriteLine (txtCRequest.Text) ts.WriteLine (txtComputer.Text) ts.Close Call InitialData If flagRate Then Call UpdateRate End If End If End Sub Private Sub cmdEditE(Optional ByVal f0 As Boolean _ , Optional ByVal f1 As Boolean, Optional ByVal f2 As _ Boolean, Optional ByVal f3 As Boolean) cmdEdit(0).Enabled = f0 cmdEdit(1).Enabled = f1 cmdEdit(2).Enabled = f2 cmdEdit(3).Enabled = f3 End Sub Private Sub AddItemcboEdit(ByVal IndexS As Integer, ByVal IndexD As Integer) 'On Error GoTo lbl Set rsEdit = New ADODB.Recordset rsEdit.Open tblEdit, cnNet, adOpenDynamic, adLockPessimistic, adCmdTable rsEdit.MoveFirst cboEdit(IndexD).Clear Do While Not rsEdit.EOF cboEdit(IndexD).AddItem rsEdit.Fields(IndexS) rsEdit.MoveNext Loop cboEdit(IndexD).Refresh rsEdit.Close 'lbl: End Sub Private Sub AddcboStreet() Dim SQL As String Set rsEdit = New ADODB.Recordset SQL = "select * from Tbl_Street where District = '" & cboEdit(2).Text & "';" rsEdit.Open SQL, cnNet, adOpenDynamic, adLockPessimistic, adCmdText rsEdit.MoveFirst cboEdit(1).Clear Do While Not rsEdit.EOF cboEdit(1).AddItem rsEdit.Fields(2) rsEdit.MoveNext Loop cboEdit(1).Refresh rsEdit.Close End Sub Private Sub UpdateEdit(ByVal Index As Byte, tbl As String) Dim rsUpdate As ADODB.Recordset Dim temp As Integer 'On Error Resume Next Set rsUpdate = New ADODB.Recordset rsUpdate.Open tbl, cnNet, adOpenDynamic, adLockPessimistic, adCmdTable If flagStreet = True Then temp = 2 Else temp = 1 End If Select Case Index Case 0 rsUpdate.AddNew If Not flagStreet Then rsUpdate.Fields(1) = txtEditContent.Text Else rsUpdate.Fields(1) = cboEdit(2).Text rsUpdate.Fields(2) = txtEditContent.Text End If rsUpdate.Update flagStreet = False Case 1 rsUpdate.MoveFirst Do While Not rsUpdate.EOF If rsUpdate.Fields(temp) = cboEdit(1).Text Then If Not flagStreet Then rsUpdate.Fields(1) = txtEditContent.Text Else rsUpdate.Fields(1) = cboEdit(2).Text rsUpdate.Fields(2) = txtEditContent.Text End If rsUpdate.Update flagStreet = False Exit Sub End If rsUpdate.MoveNext Loop End Select End Sub Private Sub DeleteEdit() Dim rsUpdate As ADODB.Recordset Set rsUpdate = New ADODB.Recordset rsUpdate.Open tblEdit, cnNet, adOpenDynamic, adLockPessimistic, adCmdTable rsUpdate.MoveFirst Do While Not rsUpdate.EOF If rsUpdate.Fields(1) = cboEdit(1).Text Then rsUpdate.Delete Exit Sub End If rsUpdate.MoveNext Loop End Sub Private Sub DispDatagrid() Dim rsBackup As ADODB.Recordset Dim R As Long, i As Integer ' On Error GoTo lbl Set rsBackup = New ADODB.Recordset rsBackup.Open "Tbl_Backup", cnNet, adOpenKeyset, _ adLockPessimistic, adCmdTable With fgridBackup 'Text in header .row = 0 .Col = 0 .Text = "Code" .CellAlignment = 1 .Col = 1 .Text = "Backup" .Col = 2 .Text = "Time" .Col = 3 .Text = "Type Database" .rows = rsBackup.RecordCount + 1 rsBackup.MoveFirst R = 1 Do While Not rsBackup.EOF For i = 0 To 3 If Not IsNull(rsBackup.Fields(i)) Then .TextMatrix(R, i) = rsBackup.Fields(i) Else .TextMatrix(R, i) = "" End If Next i rsBackup.MoveNext R = R + 1 Loop End With 'lbl: End Sub Private Sub SizeGrid() With fgridBackup .ColS = 4 .ColWidth(0) = 1000 .ColWidth(1) = 1200 .ColWidth(2) = 1200 .ColWidth(3) = 1550 .ColAlignment(0) = 1 End With End Sub Private Sub backup() Dim rsBackup As ADODB.Recordset Dim TypeData As String Dim fso As New FileSystemObject Dim Nfile As File, Sfile As File Dim num As String Dim Flag As Boolean 'Kiem tra xem typedata co dung theo yeu cau hay khong Set rsBackup = New ADODB.Recordset rsBackup.Open "Tbl_Backup", cnNet, adOpenDynamic, _ adLockPessimistic, adCmdTable Set Nfile = fso.GetFile(netPathDir + "Database\nhadatdatabase.mdb") Set Sfile = fso.GetFile(netPathDir + "Database\serverdatabase.mdb") rsBackup.MoveLast num = CStr(rsBackup.Fields(0) + 1) If chkPath.Value = 0 Then TypeData = "ALL" Nfile.Copy (netPathDir + "Backup\N" + num + ".mdb") Sfile.Copy (netPathDir + "Backup\S" + num + ".mdb") Else If txtBPath.Text = "" Then MsgBox "Files can't not Save." + Chr(13) + _ "Select file carefully, please !", vbOKOnly, "Warning" cmdBackupBrow.SetFocus Exit Sub End If If InStr(1, txtBPath.Text, "ServerDatabase.mdb", vbTextCompare) 0 Then TypeData = "ServerDatabase" Sfile.Copy (netPathDir + "Backup\S" + num + ".mdb") Flag = True End If If InStr(1, txtBPath.Text, "nhadatDatabase.mdb", vbTextCompare) 0 Then TypeData = "nhadatDatabase" Nfile.Copy (netPathDir + "Backup\N" + num + ".mdb") Flag = True End If If Not Flag Then MsgBox "You only can select nhadatDatabase or " & _ "ServerDatabase for backup !", vbOKOnly, "Warning !" cmdBackupBrow.SetFocus Exit Sub End If End If With rsBackup .AddNew .Fields(1) = Date .Fields(2) = Time .Fields(3) = TypeData .Update End With End Sub Private Sub chkPathE(ByVal Flag As Boolean) txtBPath.Enabled = Flag cmdBackupBrow.Enabled = Flag lblBackupPath.Enabled = Flag fgridBackup.Enabled = Not Flag End Sub Private Sub DelFile(ByVal Index As Long, TypeData As String) '==========Delete file in backup ============= Dim fso As New FileSystemObject Dim Nfile As File, Sfile As File On Error Resume Next Select Case TypeData Case "nhadatDatabase" Set Nfile = fso.GetFile(netPathDir + "Backup\N" + CStr(Index) + ".mdb") Nfile.Delete Case "ServerDatabase" Set Sfile = fso.GetFile(netPathDir + "Backup\S" + CStr(Index) + ".mdb") Sfile.Delete Case "ALL" Set Nfile = fso.GetFile(netPathDir + "Backup\N" + CStr(Index) + ".mdb") Nfile.Delete Set Sfile = fso.GetFile(netPathDir + "Backup\S" + CStr(Index) + ".mdb") Sfile.Delete End Select End Sub Private Sub UpdateRate() Dim rsrate As New ADODB.Recordset rsrate.Open "Tbl_Transfer_Rate", cnNet, _ adOpenKeyset, adLockPessimistic, adCmdTable With rsrate .MoveFirst .Fields(2) = CDbl(1 / txtUSD.Text) .Update .MoveNext .Fields(2) = CDbl(txtTofGold.Text / txtUSD.Text) .Update End With End Sub Private Sub DispRate() txtUSD.Text = Round(1 / VND) txtTofGold.Text = Round(TofGold / VND) End Sub Private Sub txtTofGold_Change() flagRate = True End Sub Private Sub txtUSD_Change() flagRate = True End Sub