VB售楼管理系统及源代码

VB售楼管理系统及源代码Option ExplicitDim rs_shoufei As New ADODB.RecordsetDim rs_hetong As New ADODB.RecordsetPrivate Sub cdmprint_Click() Dim X% X% = BitBlt(Picture1.hDC, 0, 0, Picture1.Width, Picture1.Height, _ Picture1.hDC, 0, 0, SRCCOPY) Picture1.Picture = Picture1.Image Printer.PaintPicture Picture1.Picture, 0, 0End SubPrivate Sub cmdsave_Click()Dim i As IntegerIf Trim(txtloupannum.Text) = Then MsgBox 楼盘编号不能为空！, vbOKOnly + vbExclamation txtloupannum.SetFocus Exit SubEnd IfLabel7.Caption = CStr(CCur(Trim(txtprice.Text)Label6.Caption = ChineseFormat(CCur(Trim(txtprice.Text)rs_shoufei.AddNewrs_shoufei.Fields(0) = Val(Trim(Label5.Caption)rs_shoufei.Fields(1) = Val(Trim(Combo1.Text)rs_shoufei.Fields(2) = Trim(txtloupannum.Text)rs_shoufei.Fields(3) = Daters_shoufei.Fields(4) = CCur(Trim(txtprice.Text)rs_shoufei.Fields(5) = Trim(Combo2.Text)rs_shoufei.Fields(6) = Trim(txtskr.Text)rs_shoufei.Fields(7) = Trim(txtjkr.Text)rs_shoufei.UpdateMsgBox 保存成功！, vbOKOnly + vbExclamationExit SubEnd SubPrivate Sub cmdprint_Click() Dim X% X% = BitBlt(Picture1.hDC, 0, 0, Picture1.Width, Picture1.Height, _ Picture1.hDC, 0, 0, SRCCOPY) Picture1.Picture = Picture1.Image Printer.PaintPicture Picture1.Picture, 0, 0End SubPrivate Sub cmdexit_Click()rs_shoufei.CloseUnload MeEnd SubPrivate Sub Form_Load()Dim sql As StringDim i As IntegerOn Error GoTo loaderrorsql = select * from 收款登记表If rs_shoufei.State 0 Then rs_shoufei.Closers_shoufei.CursorLocation = adUseClient rs_shoufei.Open sql, conn, adOpenKeyset, adLockPessimistic txtprice.Text = 0.00 i = rs_shoufei.RecordCount Label2.Caption = Year(Date) Date取得当前系统日期 Label3.Caption = Month(Date) Month函数取得日期的月数部分 Label4.Caption = Day(Date) Label5.Caption = Format(i + 1, 000000) 系统中现有记录条数加1 Combo2.AddItem (现金) Combo2.AddItem (刷卡) Combo2.AddItem (银行票据) Combo2.ListIndex = 0 sql = select * from 合同资料表 If rs_hetong.State 0 Then rs_hetong.Close rs_hetong.CursorLocation = adUseClient rs_hetong.Open sql, conn, adOpenKeyset, adLockPessimistic If rs_hetong.RecordCount 0 Then rs_hetong.MoveFirst Do While Not rs_hetong.EOF Combo1.AddItem (Trim(rs_hetong.Fields(0) rs_hetong.MoveNext Loop Combo1.ListIndex = 0 End If rs_hetong.Close Exit Subloaderror: MsgBox Err.DescriptionEnd SubFunction ChineseFormat(n As Variant) Dim s As String, sFormat As String Dim i As Integer, c As String Const sString = 分角元拾佰仟万拾佰仟亿拾佰仟万 Const sNumber = 零壹贰叁肆伍陆柒捌玖 s = Format(Int(n * 100) sFormat = For i = Len(s) To 1 Step -1 c = Mid(s, i, 1) sFormat = Mid(sNumber, Val(c) _ + 1, 1) + Mid(sString, Len(s) - i + 1, 1) _ + sFormat Next ChineseFormat = sFormatEnd FunctionPrivate Sub Picture1_Click()End SubOption ExplicitDim rs_shoukuan As New ADODB.RecordsetDim rs_yushou As New ADODB.RecordsetDim getrow As IntegerDim select_row As StringPrivate Sub cmdexit_Click()Unload MefrmMain.ShowEnd SubPrivate Sub cmdfind_Click()Dim sql As StringOn Error GoTo loaderrorgrdShoukuanFind.ClearIf Option1.Value = True Then sql = select * from 收款登记表 where 收款登记表.icm_ID = & Val(txtnum.Text) rs_shoukuan.CursorLocation = adUseClient rs_shoukuan.Open sql, conn, adOpenKeyset, adLockPessimistic 打开数据库 setgrid1 setgridhead displaygrid rs_shoukuan.Close Exit SubEnd IfIf Option2.Value = True Then sql = select * from 收款登记表 where 收款登记表.icm_houseID = & Trim(txtloupannum.Text) & rs_shoukuan.CursorLocation = adUseClient rs_shoukuan.Open sql, conn, adOpenKeyset, adLockPessimistic 打开数据库 setgrid1 setgridhead displaygrid rs_shoukuan.Close Exit SubEnd IfIf Option3.Value = True Then sql = select * from 收款登记表 where 收款登记表.icm_jkr = & Trim(txtjkr.Text) & rs_shoukuan.CursorLocation = adUseClient rs_shoukuan.Open sql, conn, adOpenKeyset, adLockPessimistic 打开数据库 setgrid1 setgridhead displaygrid rs_shoukuan.Close Exit SubEnd IfIf Option4.Value = True Then sql = select * from 收款登记表 where 收款登记表.icm_date between # & DTPicker1.Value & _ # and # & DTPicker2.Value & # rs_shoukuan.CursorLocation = adUseClient rs_shoukuan.Open sql, conn, adOpenKeyset, adLockPessimistic 打开数据库 setgrid1 setgridhead displaygrid rs_shoukuan.Close Exit SubEnd IfExit Subloaderror: MsgBox Err.DescriptionEnd SubPrivate Sub cmdprint_Click()Printgrid1.Unit = CentimeterPrintgrid1.PrintObject = grdShoukuanFindPrintgrid1.DoPreViewEnd SubPrivate Sub Form_Load()Dim sql As StringOn Error GoTo loaderrorsql = select * from 收款登记表rs_shoukuan.CursorLocation = adUseClientrs_shoukuan.Open sql, conn, adOpenKeyset, adLockPessimistic 打开数据库setgrid1setgridheaddisplaygridrs_shoukuan.CloseExit Subloaderror: MsgBox Err.DescriptionEnd SubPublic Sub displaygrid()Dim i As IntegerOn Error GoTo displayerrorgrdShoukuanFind.Row = 0If Not rs_shoukuan.EOF Then rs_shoukuan.MoveFirst Do While Not rs_shoukuan.EOF grdShoukuanFind.Row = grdShoukuanFind.Row + 1 For i = 0 To 7 grdShoukuanFind.Col = i If Not IsNull(rs_shoukuan.Fields(i) Then grdShoukuanFind.Text = rs_shoukuan.Fields(i) Else grdShoukuanFind.Text = End If Next i rs_shoukuan.MoveNext LoopEnd Ifdisplayerror:If Err.Number 0 Then MsgBox Err.DescriptionEnd IfEnd SubPublic Sub setgrid1()Dim i As IntegerOn Error GoTo seterrorWith grdShoukuanFind .ScrollBars = flexScrollBarBoth .FixedCols = 1 .Rows = rs_shoukuan.RecordCount + 1 .Cols = 8 .SelectionMode = flexSelectionByRowFor i = 0 To .Rows - 1 .RowHeight(i) = 315NextFor i = 0 To .Cols - 1 .ColWidth(i) = 1300Next iEnd WithExit Subseterror: MsgBox Err.DescriptionEnd SubPublic Sub setgridhead()On Error GoTo setheaderrorWith grdShoukuanFind .Row = 0 .Col = 0 .Text = 收款单号 .Col = 1 .Text = 合同号 .Col = 2 .Text = 楼盘编号 .Col = 3 .Text = 收款日期 .Col = 4 .Text = 收款金额 .Col = 5 .Text = 付款方式 .Col = 6 .Text = 收款人 .Col = 7 .Text = 交款人End WithExit Subsetheaderror: MsgBox Err.DescriptionEnd SubPublic Sub setgrid2()Dim i As IntegerWith grdYuding .ScrollBars = flexScrollBarBoth .FixedCols = 1 .Rows = rs_yushou.RecordCount + 1 .Cols = 3 .SelectionMode = flexSelectionByRowFor i = 0 To .Rows - 1 .RowHeight(i) = 315NextFor i = 0 To .Cols - 1 .ColWidth(i) = 1300Next iEnd WithWith grdYuding .Row = 0 .Col = 0 .Text = 付款日期 .Col = 1 .Text = 付款金额 .Col = 2 .Text = 是否已付款End WithEnd SubPrivate Sub grdShoukuanFind_Click()On Error GoTo griderrorgetrow = grdShoukuanFind.RowIf grdShoukuanFind.Rows = 1 Then MsgBox 无相关纪录, vbOKOnly + vbExclamation, Elseselect_row = grdShoukuanFind.TextMatrix(getrow, 1)displaymingxiEnd Ifgriderror:If Err.Number 0 Then MsgBox Err.DescriptionEnd IfEnd SubPublic Sub displaymingxi()Dim sql As StringDim i As Integersql = select * from 预计付款表 where 预计付款表.Add_pactid = & Val(select_row)rs_yushou.CursorLocation = adUseClientrs_yushou.Open sql, conn, adOpenKeyset, adLockPessimisticsetgrid2grdYuding.Row = 0If Not rs_yushou.EOF Then rs_yushou.MoveFirst Do While Not rs_yushou.EOF grdYuding.Row = grdYuding.Row + 1 For i = 0 To 2 grdYuding.Col = i If Not IsNull(rs_yushou.Fields(i + 1) Then grdYuding.Text = rs_yushou.Fields(i + 1) Else grdYuding.Text = End If Next i rs_yushou.MoveNext LoopEnd Ifrs_yushou.CloseEnd SubOption ExplicitDim rs_shoufei As New ADODB.RecordsetPrivate Sub cmdsave_Click()Dim i As IntegerIf Trim(txtmoney(0).Text) = Then MsgBox 楼盘编号不能为空！, vbOKOnly + vbExclamation txtmoney(0).SetFocus Exit SubEnd IfDim fee As Currencyfee = 0For i = 1 To 6 fee = fee + CCur(txtmoney(i).Text)Next itxtmoney(7).Text = CStr(fee)Label5.Caption = ChineseFormat(fee)rs_shoufei.AddNewrs_shoufei.Fields(0) = Label4rs_shoufei.Fields(1) = txtmoney(0).Textrs_shoufei.Fields(2) = DateFor i = 1 To 6 rs_shoufei.Fields(i + 2) = txtmoney(i).TextNext irs_shoufei.Fields(9) = txtskr.Textrs_shoufei.Fields(10) = txtjkr.Textrs_shoufei.UpdateMsgBox 保存成功！, vbOKOnly + vbExclamationExit SubEnd SubPrivate Sub cmdprint_Click() Dim X% X% = BitBlt(Picture1.hDC, 0, 0, Picture1.Width, Picture1.Height, _ Picture1.hDC, 0, 0, SRCCOPY) Picture1.Picture = Picture1.Image Printer.PaintPicture Picture1.Picture, 0, 0End SubPrivate Sub cmdexit_Click()rs_shoufei.CloseUnload MeEnd SubPrivate Sub Form_Load()Dim sql As StringDim i As IntegerOn Error GoTo loaderrorsql = select * from 收费信息表rs_shoufei.CursorLocation = adUseClient rs_shoufei.Open sql, conn, adOpenKeyset, adLockPessimistic For i = 1 To 7 txtmoney(i).Text = 0.00 Next i i = rs_shoufei.RecordCount Label1.Caption = Year(Date) Date取得当前系统日期 Label2.Caption = Month(Date) Month函数取得日期的月数部分 Label3.Caption = Day(Date) Label4.Caption = Format(i + 1, 000000) 系统中现有记录条数加1 Exit Subloaderror: MsgBox Err.DescriptionEnd SubFunction ChineseFormat(n As Variant) Dim s As String, sFormat As String Dim i As Integer, c As String Const sString = 分角元拾佰仟万拾佰仟亿拾佰仟万 Const sNumber = 零壹贰叁肆伍陆柒捌玖 s = Format(Int(n * 100) sFormat = For i = Len(s) To 1 Step -1 c = Mid(s, i, 1) sFormat = Mid(sNumber, Val(c) _ + 1, 1) + Mid(sString, Len(s) - i + 1, 1) _ + sFormat Next ChineseFormat = sFormatEnd FunctionPrivate Sub txtmoney_Change(Index As Integer)End SubOption ExplicitDim rs_shoufei As New ADODB.RecordsetPrivate Sub cmdfind_Click()Dim sql As StringOn Error GoTo loaderrorgrdShoufeiFind.ClearIf optionid.Value = True Then sql = select * from 收费信息表 where fee_ID = & CInt(txtshoufeinum.Text) rs_shoufei.CursorLocation = adUseClient rs_shoufei.Open sql, conn, adOpenKeyset, adLockPessimistic setgrid setgridhead displaygrid rs_shoufei.Close Exit SubEnd IfIf optionloupan.Value = True Then sql = select * from 收费信息表 where fee_houseID = & txtloupannum.Text & rs_shoufei.CursorLocation = adUseClient rs_shoufei.Open sql, conn, adOpenKeyset, adLockPessimistic setgrid setgridhead displaygrid rs_shoufei.Close Exit SubEnd IfIf Optionjkr.Value = True Then sql = select * from 收费信息表 where fee_jkr = & txtjkr.Text & rs_shoufei.CursorLocation = adUseClient rs_shoufei.Open sql, conn, adOpenKeyset, adLockPessimistic setgrid setgridhead displaygrid rs_shoufei.Close Exit SubEnd IfIf optionjkt.Value = True Then sql = select * from 收费信息表 where Fee_date between # & _ DTPicker1.Value & # and # & DTPicker2.Value & # rs_shoufei.CursorLocation = adUseClient rs_shoufei.Open sql, conn, adOpenKeyset, adLockPessimistic setgrid setgridhead displaygrid rs_shoufei.Close Exit SubEnd IfExit Subloaderror: MsgBox Err.DescriptionEnd SubPrivate Sub cmdprint_Click()Printgrid1.Unit = CentimeterPrintgrid1.PrintObject = grdShoufeiFindPrintgrid1.DoPreViewEnd SubPrivate Sub cmdexit_Click()Unload MeEnd SubPrivate Sub Form_Load()Dim sql As StringOn Error GoTo loaderrorsql = select * from 收费信息表rs_shoufei.CursorLocation = adUseClientrs_shoufei.Open sql, conn, adOpenKeyset, adLockPessimisticsetgridsetgridheaddisplaygridrs_shoufei.CloseExit Subloaderror: MsgBox Err.DescriptionEnd SubPublic Sub displaygrid()Dim i As IntegerDim j As IntegerOn Error GoTo displayerrorgrdShoufeiFind.Row = 0If Not rs_shoufei.EOF Then rs_shoufei.MoveFirst Do While Not rs_shoufei.EOF grdShoufeiFind.Row = grdShoufeiFind.Row + 1 For j = 0 To 10 grdShoufeiFind.Col = j If Not IsNull(rs_shoufei.Fields(j) Then grdShoufeiFind.Text = _ rs_shoufei.Fields(j) Else grdShoufeiFind.Text = Next j rs_shoufei.MoveNext LoopEnd Ifdisplayerror:If Err.Number 0 Then MsgBox Err.DescriptionEnd IfEnd SubPublic Sub setgrid()Dim i As IntegerOn Error GoTo seterrorWith grdShoufeiFind .ScrollBars = flexScrollBarBoth .FixedCols = 1 .Rows = rs_shoufei.RecordCount + 1 .Cols = 12 .SelectionMode = flexSelectionByRowFor i = 0 To .Rows - 1 .RowHeight(i) = 315NextFor i = 0 To .Cols - 1 .ColWidth(i) = 1500Next iEnd WithExit Subseterror: MsgBox Err.DescriptionEnd SubPublic Sub setgridhead()On Error GoTo setheaderrorgrdShoufeiFind.Row = 0grdShoufeiFind.Col = 0grdShoufeiFind.Text = 收费编号grdShoufeiFind.Col = 1grdShoufeiFind.Text = 楼盘编号grdShoufeiFind.Col = 2grdShoufeiFind.Text = 交费时间grdShoufeiFind.Col = 3grdShoufeiFind.Text = 有线电视grdShoufeiFind.Col = 4grdShoufeiFind.Text = 电话调试grdShoufeiFind.Col = 5grdShoufeiFind.Text = 煤气初装grdShoufeiFind.Col = 6grdShoufeiFind.Text = 公用设施grdShoufeiFind.Col = 7grdShoufeiFind.Text = 其他费用grdShoufeiFind.Col = 8grdShoufeiFind.Text = 押金grdShoufeiFind.Col = 9grdShoufeiFind.Text = 合计grdShoufeiFind.Col = 10grdShoufeiFind.Text = 收款人grdShoufeiFind.Col = 11grdShoufeiFind.Text = 交款人Exit Subsetheaderror: MsgBox Err.DescriptionEnd SubPrivate Sub grdShoufeiFind_Click()End SubOption ExplicitDim rs_xiaoshou As New ADODB.RecordsetDim gridclick As BooleanDim select_row As String 记录选择的楼盘Dim getrow As LongPrivate Sub cmdadd_Click()On Error GoTo adderrorIf cmdadd.Caption = 保存 Then cmdadd.Caption = 增加If Trim(txtnum.Text) = Then MsgBox 编号不能为空！, vbOKOnly + vbExclamation txtnum.SetFocus Exit SubEnd IfIf Trim(txtID.Text) = Then MsgBox 身份证号不能为空！, vbOKOnly + vbExclamation txtID.SetFocus Exit SubEnd IfIf Trim(txtname.Text) = Then MsgBox 姓名不能为空！, vbOKOnly + vbExclamation txtname.SetFocus Exit SubEnd IfIf Trim(Combo1.Text) = Then MsgBox 请选择性别！, vbOKOnly + vbExclamation Combo1.SetFocus Exit SubEnd Ifrs_xiaoshou.MoveFirstDim i As IntegerFor i = 0 To rs_xiaoshou.RecordCount - 1 If rs_xiaoshou.Fields(0) = txtnum.Text Then MsgBox 编号重复！, vbOKOnly + vbExclamation txtnum.SetFocus Exit Sub End If If rs_xiaoshou.Fields(1) = txtID.Text Then MsgBox 身份证号重复！, vbOKOnly + vbExclamation txtID.SetFocus Exit Sub End If rs_xiaoshou.MoveNextNext irs_xiaoshou.MoveLastrs_xiaoshou.AddNewrs_xiaoshou.Fields(0) = txtnum.Textrs_xiaoshou.Fields(1) = txtID.Textrs_xiaoshou.Fields(2) = txtname.Textrs_xiaoshou.Fields(3) = Combo1.TextIf Trim(txttelnum.Text) = Then rs_xiaoshou.Fields(5) = NullElse rs_xiaoshou.Fields(5) = txttelnum.TextEnd IfIf Trim(txtcell.Text) = Then rs_xiaoshou.Fields(6) = NullElse rs_xiaoshou.Fields(6) = txtcell.TextEnd Ifrs_xiaoshou.Fields(4) = DTPicker1.ValueIf Trim(txtemail.Text) = Then rs_xiaoshou.Fields(7) = NullElse rs_xiaoshou.Fields(7) = txtemail.TextEnd IfIf Trim(txtzone.Text) = Then rs_xiaoshou.Fields(8) = NullElse rs_xiaoshou.Fields(8) = txtzone.TextEnd IfIf Trim(txtaddr.Text) = Then rs_xiaoshou.Fields(9) = NullElse rs_xiaoshou.Fields(9) = txtaddr.TextEnd Ifrs_xiaoshou.UpdateMsgBox 添加成功！, vbOKOnly + vbExclamationWith grdSalemanLogin .Rows = rs_xiaoshou.RecordCount + 1 .Row = grdSalemanLogin.Rows - 1 .Col = 0 .Text = txtnum.Text .Col = 1 .Text = txtID.Text .Col = 2 .Text = txtname.Text .Col = 3 .Text = Combo1.Text .Col = 4 .Text = DTPicker1.Value .Col = 5 .Text = txttelnum.Text .Col = 6 .Text = txtcell.Text .Col = 7 .Text = txtemail.Text .Col = 8 .Text = txtzone.Text .Col = 9 .Text = txtaddr.TextEnd WithElse cmdadd.Caption = 保存 txtnum.Text = txtID.Text = txtname.Text = txttelnum.Text = txtcell.Text = txtemail.Text = txtaddr.Text = txtzone.Text = cmdmodify.Enabled = False cmddel.Enabled = FalseEnd IfExit Subadderror: MsgBox Err.DescriptionEnd SubPrivate Sub cmdmodify_Click()On Error GoTo modifyerrortxtnum.Enabled = FalsetxtID.Enabled = FalseIf Trim(txtname.Text) = Then MsgBox 姓名不能为空！, vbOKOnly + vbExclamation txtname.SetFocus Exit SubEnd Ifrs_xiaoshou.MoveFirstDim