📄 frmintable.frm
字号:
Caption = "开始日期："
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 240
Left = 3330
TabIndex = 14
Top = 900
Width = 915
End
Begin VB.Label Label3
Caption = "费率："
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 240
Left = 180
TabIndex = 13
Top = 900
Width = 915
End
Begin VB.Label Label2
Caption = "入费日期："
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 240
Left = 3330
TabIndex = 12
Top = 180
Width = 960
End
Begin VB.Label Label1
Caption = "入费单号："
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 240
Left = 225
TabIndex = 11
Top = 225
Width = 960
End
End
Attribute VB_Name = "frmInTable"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'*******************************************************
'* 模 块 名 称 :录入用户入费单
'* 功 能 描 述 :
'* 程序员姓名 :谭怀志
'* 最后修改人 :谭怀志
'* 最后修改时间:2003/6/26
'* 备 注:
'*******************************************************
Private m_FLtype As String
Private blnPoint As Boolean
Private m_FLid As Long
Public Property Let FLtype(ByVal NewValue As Integer)
m_FLtype = NewValue
End Property
Public Property Let FLid(ByVal NewValue As Integer)
m_FLid = NewValue
End Property
Private Sub cmdCancel_Click()
Unload Me
End Sub
Private Sub cmdOK_Click()
Dim tmprstCustomers As ADODB.Recordset
Dim lngNum As Long
'检查入费单的有效性
If Trim(txtTableID.Text) = "" Then
MsgBox "必须填写入费单号！", vbCritical, ERRCAPTION
txtTableID.SetFocus
Exit Sub
End If
If Val(txtNmoney.Text) <= 0 Then
MsgBox "入费金额无效！", vbCritical, ERRCAPTION
txtTableID.SetFocus
SendKeys "{HOME}+{END}"
Exit Sub
End If
On Error GoTo ADOError
strQry = "select ID from RFDorig where ID='" & Trim(txtTableID.Text) & "'"
Set rstCustomers = GetRecordSet(cnnConnection, strQry)
If rstCustomers.RecordCount <> 0 Then
MsgBox "入费单号 " & Trim(txtTableID.Text) & " 已经存在！", vbCritical, ERRCAPTION
txtTableID.SetFocus
SendKeys "{HOME}+{END}"
Exit Sub
End If
Set tmprstCustomers = New Recordset
If m_FLtype = 1 Then '包月用户
cnnConnection.BeginTrans
strQry = "insert into RFDorig(UserID,RFdate,Money,OperID,Status,JFtype,ID,OperTime,StartDate,Enddate,FLname) values('" & txtUserID.Text & "','" & dtpDate.Value & "'," & txtNmoney.Text & ",'" & strOperatorID & "',0," & Trim(Str(m_FLtype)) & ",'" & txtTableID.Text & "','" & Now() & "','" & dtpStart.Value & "','" & dtpEnd.Value & "','" & txtFL.Text & "')"
cnnConnection.Execute strQry
strQry = "insert into RFDconf(UserID,RFdate,Money,JFtype,ID,StartDate,EndDate,Status,FLname) values('" & txtUserID.Text & "','" & dtpDate.Value & "'," & txtNmoney.Text & "," & Trim(m_FLtype) & ",'" & txtTableID.Text & "','" & dtpStart.Value & "','" & dtpEnd.Value & "',0,'" & txtFL.Text & "')"
cnnConnection.Execute strQry
strQry = "update JFsetting set StartDate='" & dtpStart.Value & "',EndDate='" & dtpEnd.Value & "' where UserID='" & txtUserID.Text & "'"
cnnConnection.Execute strQry
strQry = "select TotalMoney,SendableNum,SendFlag from MsgJF Where UserID='" & txtUserID.Text & "'"
Set rstCustomers = GetRecordSet(cnnConnection, strQry)
rstCustomers!TotalMoney = rstCustomers!TotalMoney + Val(txtNmoney.Text)
With frmIncharge!Gridbrowser
'检查本次入费后是否可发送
If DateValue(Now) >= dtpStart.Value And DateValue(Now) <= dtpEnd.Value Then
'当前日期在设定的日期范围内，可发送
rstCustomers!SendableNum = -1
rstCustomers!SendFlag = 0
.TextMatrix(.RowSel, 3) = "可发送"
Else
rstCustomers!SendableNum = 0
rstCustomers!SendFlag = 1
.TextMatrix(.RowSel, 3) = "不可发送"
End If
End With
rstCustomers.Update
cnnConnection.CommitTrans
Else '单条用户
cnnConnection.BeginTrans
strQry = "insert into RFDorig(UserID,RFdate,Money,OperID,Status,JFtype,ID,OperTime,FLname) values('" & txtUserID.Text & "','" & dtpDate.Value & "'," & txtNmoney.Text & ",'" & strOperatorID & "',0," & Trim(Str(m_FLtype)) & ",'" & txtTableID.Text & "','" & Now() & "','" & txtFL.Text & "')"
cnnConnection.Execute strQry
strQry = "insert into RFDconf(UserID,RFdate,Money,JFtype,ID,Status,FLname) values('" & txtUserID.Text & "','" & dtpDate.Value & "'," & txtNmoney.Text & "," & Trim(m_FLtype) & ",'" & txtTableID.Text & "',0,'" & txtFL.Text & "')"
cnnConnection.Execute strQry
strQry = "select JFquan,JFunit from FLlist where FLid=" & m_FLid
Set tmprstCustomers = GetRecordSet(cnnConnection, strQry)
strQry = "select Cmoney,SendableNum,SendFlag from MsgJF where UserID='" & txtUserID.Text & "'"
Set rstCustomers = GetRecordSet(cnnConnection, strQry)
rstCustomers!Cmoney = rstCustomers!Cmoney + Val(txtNmoney.Text)
lngNum = Int(rstCustomers!Cmoney / (tmprstCustomers!JFquan / tmprstCustomers!JFunit))
With frmIncharge!Gridbrowser
'检查本次入费后是否可发送
If lngNum > 0 Then
rstCustomers!SendableNum = lngNum
rstCustomers!SendFlag = 0
.TextMatrix(.RowSel, 2) = Format(rstCustomers!Cmoney, "#########0.00")
.TextMatrix(.RowSel, 3) = "可发送"
Else
rstCustomers!SendableNum = 0
rstCustomers!SendFlag = 1
.TextMatrix(.RowSel, 2) = Format(rstCustomers!Cmoney, "#########0.00")
.TextMatrix(.RowSel, 3) = "不可发送"
End If
End With
rstCustomers.Update
cnnConnection.CommitTrans
End If
'设置用户的短信管理权限
Call SetRight(txtUserID.Text)
Unload Me
Exit Sub
VBError:
DisplayVBError
Exit Sub
ADOError:
DisplayADOError cnnConnection
End Sub
Private Sub Form_Resize()
Dim intEndDay As Integer
txtTableID.Text = "RFD" & Format(Now, "yymmddhhss")
dtpDate.Value = DateValue(Now)
'开始日期的缺省值为当前月的第一天
dtpStart.Value = DateSerial(Year(Now()), Month(Now()), 1)
intEndDay = Day(DateSerial(Year(Now()), Month(Now()) + 1, 1) - 1)
'开始日期的缺省值为当前月的最后一天
dtpEnd.Value = DateSerial(Year(Now), Month(Now()), intEndDay)
If m_FLtype = 0 Then
lblStart.Enabled = False
lblEnd.Enabled = False
dtpStart.Enabled = False
dtpEnd.Enabled = False
Else
txtNmoney.Locked = True
End If
blnPoint = False
End Sub
Private Sub txtNmoney_Change()
If InStr(txtNmoney.Text, ".") > 0 Then
blnPoint = True
Else
blnPoint = False
End If
End Sub
Private Sub txtNmoney_KeyPress(KeyAscii As Integer)
'输入金额时，将无效的输入屏蔽
If (KeyAscii < Asc("0") Or KeyAscii > Asc("9")) And KeyAscii <> 8 And KeyAscii <> 13 And KeyAscii <> Asc(".") Then
KeyAscii = 0
Exit Sub
End If
'不是第一次输入小数点是时，将输入屏蔽掉
If KeyAscii = Asc(".") And blnPoint Then
KeyAscii = 0
Exit Sub
End If
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -