学完机房收费系统之后，发现有很多的经典代码而且出现的频率非常高。下面我对这些代码进行了颗粒归仓。
下机判断花费时间和消费金额（固定用户）
txtSQL3 = "select * from BasicData_Info " Set Object2 = ExecuteSQL(txtSQL3, MsgText3) If Style = "固定用户" Then 'DateDiff判断用户类型 basicPay = Val(Trim(Object2.Fields(0))) '判断上机时间是否超过准备时间 If inttime < Val(Object2.Fields(4)) Then txtCTime.Text = 0 txtCMoney.Text = 0 returnCash = Val(Trim(txtBaLance.Text) - Trim(txtCMoney.Text)) txtBaLance.Text = returnCash mrc.Fields(7) = txtBaLance.Text mrc.Update Call Panduan Else '判断上机时间是否超过最短时间 txtCTime.Text = inttime '在窗体上显示上网时间 If inttime <= Val(Object2.Fields(3))Then '没有超过最短时间按最短时间收费 txtCMoney.Text = basicPay returnCash = Trim(txtBaLance.Text) - Trim(txtCMoney.Text) txtBaLance.Text = returnCash mrc.Fields(7) = txtBaLance.Text mrc.Update Call Panduan Else If Val(inttime) Mod 30 = 0 Then '消耗时间，正好等于要求的单位时间 txtCMoney.Text = Val(inttime) \ 30 * basicPay \ 2 returnCash = Trim(txtBaLance.Text) - Trim(txtCMoney.Text) txtBaLance.Text = returnCash mrc.Fields(7)=txtBaLance.Text '更新表中的cash余额 mrc.Update Call Panduan Else txtCMoney.Text = (Val(inttime) \ 30 + 1) * basicPay \ 2 returnCash = Val(Trim(txtBaLance.Text) - Trim(txtCMoney.Text)) txtBaLance.Text = returnCash mrc.Fields(7) = txtBaLance.Text '更新表中cash余额 mrc.Update Call Panduan End If End If End If
导出Excel表
Dim ExcelApp As Excel.Application '声明Excal对象 Dim ExcelBook As Excel.Workbook '声明工作簿对象 Dim ExcelSheet As Excel.Worksheet '声明工作表单 Dim ExcelRange As Excel.Range Dim i As Integer Dim j As Integer Set ExcelApp = CreateObject("Excel.application") '调用Excel程序，创建Excel应用程序对象 Set ExcelBook = ExcelApp.Workbooks.Add '创建新的空白工作簿 Set ExcelSheet = ExcelBook.Worksheets(1) '创建新的工作表单 DoEvents If MSFlexGrid1.Rows <= 1 Then MsgBox "没有可导出数据！", vbOKOnly, "温馨提示" End If With MSFlexGrid1 For i = 0 To .Rows - 1 '循环添加行内容 For j = 0 To .Cols - 1 '循环添加列内容 DoEvents '添加单元格内容 ExcelApp.ActiveSheet.Cells(i + 1, j + 1) = .TextMatrix(i, j) Next j Next i End With ExcelApp.ActiveWorkbook.Saved = True '保存Excel表格 MsgBox "导出成功！", vbOKOnly, "温馨提示" ExcelApp.Visible = True '显示Excel表格 Set ExcelApp = Nothing '释放ExcelApp对象 Set ExcelBook = Nothing '释放ExcelBook对象 Set ExcelSheet = Nothing '释放ExcelSheet对象
修改密码判断
Dim txtSQL, MsgText As String Dim mrc As ADODB.Recordset '判断两个文本框的内容是否一致 If Trim(txtnewpwd.Text) <> Trim(txtokpwd.Text) Then MsgBox "两次密码输入不一致", 48, "警告 " txtnewpwd.Text = "" txtokpwd.Text = "" txtnewpwd.SetFocus Else '连接User表 txtSQL = "select * from user_Info where userID = '" & Trim(UserName) & "'" Set mrc = ExecuteSQL(txtSQL, MsgText) '判断表中字段一和txtnewpwd的内容是否一致 If (Trim(mrc.Fields(1)) = Trim(txtnewpwd.Text)) Then MsgBox "与旧密码重复，请重新修改！" txtnewpwd.Text = "" txtokpwd.Text = "" txtnewpwd.SetFocus Else '判断表中字段一和txtoldpwd的内容是否一致 If (Trim(mrc.Fields(1)) <> Trim(txtoldpwd.Text)) Then MsgBox "请输入正确的旧密码！" txtoldpwd.Text = "" Else '当表中字段一等于txtnewpwd的内容时 mrc.Fields(1) = Trim(txtnewpwd.Text) mrc.Update MsgBox "密码修改成功！", 48, "修改密码" '显示修改密码成功 mrc.Close Unload Me '卸载窗体 End If End If End If
