📄 评价指标.frm
字号:
DoEvents
TxtcalMarkFormu.SelStart = pos + 1
' Call oprclick
' TxtcalMarkFormu.SetFocus
' Lastinput = "op"
End Sub
Private Sub delzero()
str = mID(str, 1, Len(str) - Len(Lastchar) - 1)
strcalMark = mID(strcalMark, 1, Len(strcalMark) - Len(Lastchar) - 1)
TxtcalMarkFormu.Text = str
Call oprclick
End Sub
Function getnumber(ByVal str As String)
If right(str, 1) = "." Then
getnumber = mID(str, 1, Len(str) - 1)
Else
getnumber = str
End If
End Function
'实际值
Private Sub cmdRealValue_Click()
pos = TxtcalMarkFormu.SelStart
str = left(TxtcalMarkFormu.Text, TxtcalMarkFormu.SelStart) + cpara(0) + mID(TxtcalMarkFormu.Text, TxtcalMarkFormu.SelStart + 1)
' str = Trim(TxtcalMarkFormu.Text) + cpara(0)
' strcalMark = strcalMark + epara(0)
TxtcalMarkFormu.Text = Trim(str)
' TxtcalMarkFormu.SelStart = Len(str)
TxtcalMarkFormu.SetFocus
DoEvents
TxtcalMarkFormu.SelStart = pos + 3
' Call paraclick
' TxtcalMarkFormu.SetFocus
' Lastinput = "pa"
End Sub
Private Sub cmdReinp_Click()
str = ""
strcalMark = ""
bL = 0
Lastinput = ""
str = ""
Lastchar = ""
oprcount = 0
strcalMark = ""
TxtcalMarkFormu.Text = ""
cpara(0) = "实际值"
cpara(1) = "标准值"
cpara(2) = "标准分"
epara(0) = "realValue"
epara(1) = "stanValue"
epara(2) = "stanMark"
' oprcount = 0
' bL = 0
'' cmdRealValue.Enabled = True
' cmdstanValue.Enabled = True
' cmdStanMark.Enabled = True
' Dim numi
' For numi = 0 To 9
' cmdnum(numi).Enabled = True
' Next
'
' '置操作数按钮状态
' cmdoprPlus.Enabled = False
' cmdoprMinus.Enabled = False
' cmdoprTime.Enabled = False
' cmdoprDiv.Enabled = False
' cmdoprLBracket.Enabled = True
' cmdoprRBracket.Enabled = False
End Sub
'标准分
Private Sub cmdStanMark_Click()
pos = TxtcalMarkFormu.SelStart
str = left(TxtcalMarkFormu.Text, TxtcalMarkFormu.SelStart) + cpara(2) + mID(TxtcalMarkFormu.Text, TxtcalMarkFormu.SelStart + 1)
' strcalMark = strcalMark + epara(2)
TxtcalMarkFormu.Text = Trim(str)
TxtcalMarkFormu.SetFocus
DoEvents
TxtcalMarkFormu.SelStart = pos + 3
' TxtcalMarkFormu.SelStart = Len(str)
' Call paraclick
' TxtcalMarkFormu.SetFocus
' Lastinput = "pa"
End Sub
'标准值
Private Sub cmdstanValue_Click()
pos = TxtcalMarkFormu.SelStart
str = left(TxtcalMarkFormu.Text, TxtcalMarkFormu.SelStart) + cpara(1) + mID(TxtcalMarkFormu.Text, TxtcalMarkFormu.SelStart + 1)
' strcalMark = strcalMark + epara(1)
TxtcalMarkFormu.Text = Trim(str)
TxtcalMarkFormu.SetFocus
DoEvents
TxtcalMarkFormu.SelStart = pos + 3
' TxtcalMarkFormu.SelStart = Len(str)
' Call paraclick
' Lastinput = "pa"
End Sub
'参照测试
Private Sub Command1_Click()
Dim rs1 As New ADODB.Recordset
Dim rfd As New UFReferC.UFReferClient
rfd.SetLogin zjLogInfo
rfd.SetReferSQLString "select cUnitcode As 单位代码 , cUnitName as 单位名称 from FD_Accunit order by cunitcode;"
rfd.SetReferDisplayMode enuGrid
rfd.Show
If rfd.recmx Is Nothing Then Exit Sub
Set rs1 = rfd.recmx
Dim i As Integer
For i = 0 To rs1.RecordCount - 1
MsgBox rs1(0) & " " & rs1(1)
rs1.MoveNext
Next
End Sub
'定性指标列表单击事件
Private Sub dxItemSG1_Click()
credstat.selcol = dxItemSG1.col
credstat.selRow = dxItemSG1.row
If credstat.ModifyState = 0 Then
tlbTool.Buttons("addColumn").Enabled = False
tlbTool.Buttons("delColumn").Enabled = False
Exit Sub
ElseIf credstat.ModifyState = 1 Then
If TxtitemName = "" Then
MsgBox "请先输入评价指标名称！", vbInformation, "输入错误！"
TxtitemName.SetFocus
Exit Sub
Else
dxItemSG1.ReadOnly = False
credstat.selRow = dxItemSG1.row
tlbTool.Buttons("addColumn").Enabled = True
tlbTool.Buttons("delColumn").Enabled = True
End If
Else
tlbTool.Buttons("addColumn").Enabled = True
tlbTool.Buttons("delColumn").Enabled = True
End If
If dxItemSG1.row = dxItemSG1.Rows - 1 And dxItemSG1.col = 2 Then
precol = 1
Else
precol = 0
End If
End Sub
Private Sub dxItemSG1_GotFocus()
If credstat.ModifyState = 0 Then
tlbTool.Buttons("addColumn").Enabled = False
tlbTool.Buttons("delColumn").Enabled = False
Exit Sub
ElseIf credstat.ModifyState = 1 Then
If TxtitemName = "" Then
' MsgBox "请先输入评价指标名称！", vbInformation, "输入错误！"
TxtitemName.SetFocus
Exit Sub
Else
dxItemSG1.ReadOnly = False
credstat.selRow = dxItemSG1.row
tlbTool.Buttons("addColumn").Enabled = True
tlbTool.Buttons("delColumn").Enabled = True
End If
Else
tlbTool.Buttons("addColumn").Enabled = True
tlbTool.Buttons("delColumn").Enabled = True
End If
End Sub
Private Sub dxItemSG1_KeyUp(KeyCode As Integer, Shift As Integer)
Dim discolor() As Long
If credstat.ModifyState = 0 Then
tlbTool.Buttons("addColumn").Enabled = False
tlbTool.Buttons("delColumn").Enabled = False
ElseIf credstat.ModifyState = 1 Then
If TxtitemName = "" Then
MsgBox "请先输入评价指标名称！", vbInformation, "输入错误！"
TxtitemName.SetFocus
Else
dxItemSG1.ReadOnly = False
credstat.selRow = dxItemSG1.row
tlbTool.Buttons("addColumn").Enabled = True
tlbTool.Buttons("delColumn").Enabled = True
End If
Else
tlbTool.Buttons("addColumn").Enabled = True
tlbTool.Buttons("delColumn").Enabled = True
End If
If credstat.ModifyState <> 0 Then
If KeyCode = vbKeyReturn Then
If credstat.selcol = 2 And credstat.selRow = dxItemSG1.Rows - 1 Then
If precol = 0 Or precol = 2 Then
precol = 1
ElseIf precol = 1 Then
dxItemSG1.AddRecord "0" & dxItemSG1.Rows, discolor()
End If
Else
precol = 0
End If
End If
End If
End Sub
''定性指标列表获得焦点事件
'Private Sub dxItemSG1_GotFocus()
' If credstat.ModifyState = 0 Then
' tlbTool.Buttons("addColumn").Enabled = False
' tlbTool.Buttons("delColumn").Enabled = False
' ElseIf credstat.ModifyState = 1 Then
' If TxtitemName = "" Then
' MsgBox "请先输入评价指标名称！", vbInformation, "输入错误！"
' TxtitemName.SetFocus
' Else
' dxItemSG1.ReadOnly = False
' credstat.selRow = dxItemSG1.Row
' tlbTool.Buttons("addColumn").Enabled = True
' tlbTool.Buttons("delColumn").Enabled = True
' End If
' Else
' tlbTool.Buttons("addColumn").Enabled = True
' tlbTool.Buttons("delColumn").Enabled = True
' End If
'End Sub
'定性指标列表按键事件
'定性指标列表失去焦点事件
Private Sub dxItemSG1_LostFocus()
' If credstat.selRow <> 0 Then
' If credstat.ModifyState <> 4 And credstat.ModifyState <> 0 And (credstat.ItemType = 0) Then
' If Not credstat.modified Then
' If ((dxItemSG1.TextMatrix(credstat.selRow, 1) = "") Or _
' (Not isnumber(dxItemSG1.TextMatrix(credstat.selRow, 2)))) Then
' MsgBox "非法数据输入!" & vbCrLf & "标准不能为空,得分必须为数字！", vbInformation, "输入错误"
' dxItemSG1.ReadOnly = False
' credstat.selRow = dxItemSG1.Row
' Exit Sub
' Else
' Call infocheckproc
' Txtdxmemo.SetFocus
' tlbTool.Buttons("addColumn").Enabled = False
' tlbTool.Buttons("delColumn").Enabled = False
' End If
' Else
' savedxzb
' End If
' tlbTool.Buttons("delColumn").Enabled = False
' End If
'End If
End Sub
Private Sub infocheckproc()
Dim i As Integer
Dim b As Boolean
b = False
If credstat.ModifyState = 2 Then
If credstat.selRow <> 0 Then
For i = 1 To 2
If dxItemSG1.TextMatrix(credstat.selRow, i) <> credstat.dxzbitem(credstat.selRow - 1, i) Then
b = True
End If
Next
Else
b = False
End If
If TxtitemName.Text <> credstat.ItemName Then
b = True
End If
Else
If dxItemSG1.TextMatrix(dxItemSG1.row, 2) <> "" Then
b = True
End If
End If
credstat.modified = b
End Sub
'定性指标存储处理
Private Function saveDxzb() As Boolean
Dim i As Integer
If Not ItemUsed.Visible Then
On Error GoTo error0
con.BeginTrans
If credstat.ModifyState <> 1 Then
sqlstr = "delete From Fd_creEvaPara Where ItemName='" & credstat.ItemName & "';"
con.Execute sqlstr
End If
With dxItemSG1
For i = 1 To dxItemSG1.Rows - 1
sqlstr = "Insert Into Fd_creEvaPara (itemName,itemType,standard,quaMark,Memo) values('"
sqlstr = sqlstr & Trim(TxtitemName.Text) & "','" & 0 & "','" & Trim(.TextMatrix(i, 1)) & "'," & Trim(.TextMatrix(i, 2)) & ",'" & Trim(Txtdxmemo.Text) & "');"
con.Execute sqlstr
Next
End With
con.CommitTrans
saveDxzb = True
Exit Function
error0:
con.RollbackTrans
saveDxzb = False
ElseIf ItemUsed.Visible Then
On Error GoTo Error1
con.BeginTrans
sqlstr = "update fd_creEvapara set itemname='" & Trim(TxtitemName.Text) & "',memo='" & Trim(Txtdxmemo.Text) & "' "
sqlstr = sqlstr & " Where itemname='" & ItemName & "'"
con.Execute sqlstr
con.CommitTrans
saveDxzb = True
Exit Function
Error1:
con.RollbackTrans
saveDxzb = False
End If
End Function
'定性指标存储处理
Private Function saveDlzb() As Boolean
Dim i As Integer
If Not ItemUsed.Visible Then
On Error GoTo error0
con.BeginTrans
If credstat.ModifyState <> 1 Then
sqlstr = "delete From Fd_creEvaPara Where ItemName='" & credstat.ItemName & "';"
con.Execute sqlstr
End If
sqlstr = "Insert Into Fd_creEvaPara (itemName,calFormu,stanvalue,calMarkFormu,calMarkFormu1,Memo) values('"
sqlstr = sqlstr & Trim(TxtitemName.Text) & "','" & Trim(TxtcalFormula.Text) & "'," & Trim(TxtstanValue.Text) & ",'"
sqlstr = sqlstr & Trim(TxtcalMarkFormu.Text) & "','" & Trim(strcalMark) & "','" & Trim(TxtdlMemo.Text) & "');"
con.Execute sqlstr
con.CommitTrans
saveDlzb = True
Exit Function
error0:
con.RollbackTrans
saveDlzb = False
ElseIf ItemUsed.Visible Then
On Error GoTo Error1
con.BeginTrans
sqlstr = "update fd_creEvapara set itemname='" & Trim(TxtitemName.Text) & "',calformu='" & TxtcalFormula.Text & "', memo='" & Trim(TxtdlMemo.Text) & "' "
sqlstr = sqlstr & " Where itemname='" & ItemName & "'"
con.Execute sqlstr
con.CommitTrans
saveDlzb = True
Exit Function
Error1:
con.RollbackTrans
saveDlzb = False
End If
End Function
'定性指标列表行列改变事件
Private Sub dxItemSG1_RowColChange()
' If credstat.ModifyState = 2 Then
' If credstat.selRow <> 0 Then
' If (dxItemSG1.Row <> credstat.selRow And checkmodify) Then
' dxItemSG1.Row = credstat.selRow
' Else
' credstat.selRow = dxItemSG1.Row
' credstat.selcol = dxItemSG1.Col
' End If
' Else
' credstat.selRow = dxItemSG1.Row
' credstat.selcol = dxItemSG1.Col
' End If
' End If
' If credstat.ModifyState = 1 Then
' credstat.selRow = dxItemSG1.Row
' ⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -