📄 +
字号:
Case 39 '屏蔽"'"
KeyAscii = 0
End Select
End Sub
'调入窗体
Private Sub Form_Load()
'定义可变部分变量
ReportTitle = "成本对象设置"
Combo_BZ = "0"
'调入打印页面设置窗体
XtReportCode = "Cbhs_object"
Load Dyymctbl
'初始化成本中心
Call CshAccountCell
'以下为文本框处理程序
TextGroupCode = "Cbhs_object"
Call Drwbkxx(TextGroupCode, Textvar(), Textboolean(), Textint(), Textstr()) '读入文本框录入信息
Call Wbkcsh
'调 入 网 格
GridCode = "Cbhs_Object"
Call BzWgcsh(CzxsGrid, GridCode, GridInf(), GridBoolean(), GridInt(), GridStr())
Qslz = GridInf(1)
Sjhgd = GridInf(2)
Szzls = CzxsGrid.Cols - 1
'填 充 网 格
Call Cxnrtcwg
'初始化toolbar,tab卡状态
StTab.Tab = 0
StTab.TabEnabled(1) = False
Frame1.Enabled = False
Lrzt = 0
End Sub
Private Sub Cxnrtcwg() '查 询 内 容 填 充 网 格
Dim SqlStr As String
Dim Jsqte As Long
'查询连接串
SqlStr = "Select Objectcode,ObjectName,MeasureUnitName,ProPlanCost,ProPlanQuantity,ObjectClassName,TurnNextClassName,CompleteClassName,costobject_name From Cbhs_object A " _
& "Left Outer Join Cbhs_ObjectType B On A.ObjectClassCode=B.ObjectClassCode " _
& "Left OUter Join Cbhs_TurnNextType C On A.TurnNextClassCode=C.TurnNextClassCode " _
& "Left OUter Join Cbhs_Completetype D On A.CompleteClassCode=D.CompleteClassCode " _
& "Left Outer Join Cbhs_MeasureUnitType E On A.MeasureUnitCode=E.MeasureUnitCode " _
& "Left Outer Join Kf_costobject F On A.KF_Object=F.costobject_code " _
& "Where AccountCellcCode='" + Trim(Combo_CostCellCode(Combo_CostCell.ListIndex)) + "' Order By ObjectCode"
Set Cxnrrec = Cw_DataEnvi.DataConnect.Execute(SqlStr)
With Cxnrrec
CzxsGrid.Clear 1
CzxsGrid.Rows = .RecordCount + CzxsGrid.FixedRows
If .EOF And .BOF Then
Exit Sub
End If
Jsqte = CzxsGrid.FixedRows
Do While Not .EOF
If Jsqte >= CzxsGrid.Rows Then
CzxsGrid.AddItem ""
End If
Call Jltcwg(Cxnrrec, Jsqte)
CzxsGrid.RowHeight(Jsqte) = Sjhgd
.MoveNext
Jsqte = Jsqte + 1
Loop
End With
End Sub
Private Sub Jltcwg(Jlbrec As ADODB.Recordset, Rowjsq As Long) '记录内容填充网格
Dim RecTemp As New ADODB.Recordset
'[以下为自定义部分
With Jlbrec
'-----------对象编码------------------------
CzxsGrid.TextMatrix(Rowjsq, Sydz("001", GridStr(), Szzls)) = Trim(.Fields("ObjectCode")) & ""
'-----------对象名称-------------------------
CzxsGrid.TextMatrix(Rowjsq, Sydz("002", GridStr(), Szzls)) = Trim(.Fields("ObjectName")) & ""
'-----------计量单位-------------------------
CzxsGrid.TextMatrix(Rowjsq, Sydz("003", GridStr(), Szzls)) = Trim(.Fields("MeasureUnitName")) & ""
'-----------计划成本--------------------------
CzxsGrid.TextMatrix(Rowjsq, Sydz("004", GridStr(), Szzls)) = Trim(.Fields("ProPlanCost")) & ""
'-----------计划产量--------------------------
CzxsGrid.TextMatrix(Rowjsq, Sydz("005", GridStr(), Szzls)) = Trim(.Fields("ProPlanQuantity")) & ""
'-----------转下道工序方式----------------------
CzxsGrid.TextMatrix(Rowjsq, Sydz("006", GridStr(), Szzls)) = Trim(.Fields("TurnNextClassName")) & ""
'-------------对象类别-----------------
CzxsGrid.TextMatrix(Rowjsq, Sydz("007", GridStr(), Szzls)) = Trim(.Fields("ObjectClassName")) & ""
'---------------完工转出方式---------------------
CzxsGrid.TextMatrix(Rowjsq, Sydz("008", GridStr(), Szzls)) = Trim(.Fields("CompleteClassName")) & ""
CzxsGrid.TextMatrix(Rowjsq, Sydz("009", GridStr(), Szzls)) = Trim(.Fields("costobject_name")) & ""
End With
'以上为自定义部分]
End Sub
Private Sub Form_Unload(Cancel As Integer) '窗体卸载
Set Cxnrrec = Nothing
Unload Dyymctbl
End Sub
Private Function Bclrsj() As Boolean '判断录入数据有效性,并保存数据
Dim RecTemp As New ADODB.Recordset
Dim Jsqte As Integer
Bclrsj = False
With RecSettlement
For Jsqte = 0 To Max_Text_Index
If Textint(Jsqte, 8) = 1 Then '字段不能为空
If Len(Trim(LrText(Jsqte).Text)) = 0 Then
Tsxx = Textstr(Jsqte, 7) & "不能为空!"
Call Xtxxts(Tsxx, 0, 1)
LrText(Jsqte).SetFocus
Bclrsj = False
Exit Function
End If
Else
If Textint(Jsqte, 8) = 2 Then '字段不能为零
If Val(Trim(LrText(Jsqte).Text)) = 0 Then
Tsxx = Textstr(Jsqte, 7) & "不能为零!"
Call Xtxxts(Tsxx, 0, 1)
LrText(Jsqte).SetFocus
Bclrsj = False
Exit Function
End If
End If
End If
Next Jsqte
'对需要进行事后判断的文本框录入内容进行有效性判断 (固定不变)
For Jsqte = 0 To Max_Text_Index
If Textint(Jsqte, 9) = 0 Or Textint(Jsqte, 9) = 2 Then
If Not TextYxxpd(Jsqte) Then
Exit Function
End If
End If
Next Jsqte
If Lrzt = 1 Then '增 加
If .State = 1 Then .Close
.Open "SELECT * FROM Cbhs_Object WHERE ObjectCode= '" + Trim(LrText(0)) + "'", Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
If Not .EOF Then
Tsxx = "对象编码重复!"
Call Xtxxts(Tsxx, 0, 1)
LrText(0).SetFocus
Bclrsj = False
Exit Function
End If
If .State = 1 Then .Close
.Open "SELECT * FROM Cbhs_Object WHERE ObjectName= '" + Trim(LrText(1)) + "'", Cw_DataEnvi.DataConnect, adOpenDynamic
If Not .EOF Then
Tsxx = "对象名称重复!"
Call Xtxxts(Tsxx, 0, 1)
LrText(1).SetFocus
Bclrsj = False
Exit Function
End If
.AddNew
.Fields("ObjectCode") = Trim(LrText(0))
.Fields("ObjectName") = Trim(LrText(1))
.Fields("MeasureUnitCode") = Trim(LrText(2).Tag)
.Fields("ProPlanCost") = Trim(LrText(3))
.Fields("ProPlanQuantity") = Trim(LrText(4))
.Fields("TurnNextClassCode") = Trim(LrText(5).Tag)
.Fields("ObjectClassCode") = Trim(LrText(6).Tag)
.Fields("CompleteClassCode") = Trim(LrText(7).Tag)
.Fields("AccountCellcCode") = Combo_CostCellCode(Combo_CostCell.ListIndex)
.Fields("KF_Object") = Trim(LrText(8).Tag)
.Update
SqlStr = "Select Objectcode,ObjectName,MeasureUnitName,ProPlanCost,ProPlanQuantity,ObjectClassName,TurnNextClassName,CompleteClassName,costobject_name From Cbhs_object A " _
& "Left Outer Join Cbhs_ObjectType B On A.ObjectClassCode=B.ObjectClassCode " _
& "Left Outer Join Cbhs_TurnNextType C On A.TurnNextClassCode=C.TurnNextClassCode " _
& "Left Outer Join Cbhs_Completetype D On A.CompleteClassCode=D.CompleteClassCode " _
& "Left Outer Join Cbhs_MeasureUnitType E On A.MeasureUnitCode=E.MeasureUnitCode " _
& "Left Outer Join Kf_costobject F On A.KF_Object=F.costobject_code " _
& "Where AccountCellcCode='" + Trim(Combo_CostCellCode(Combo_CostCell.ListIndex)) + "' " _
& "And ObjectCode='" & Trim(LrText(0).Text) & "' Order By ObjectCode"
Set Cxnrrec = Cw_DataEnvi.DataConnect.Execute(SqlStr)
With CzxsGrid
.AddItem ""
.RowHeight(.Rows - 1) = Sjhgd
.Select .Rows - 1, Qslz
Call Jltcwg(Cxnrrec, .Rows - 1)
End With
Tsxx = "保存完毕!"
Call Xtxxts(Tsxx, 0, 4)
Call Cshlrxx(1)
LrText(0).SetFocus
Else
'对象名
If .State = 1 Then .Close
.Open "SELECT * FROM Cbhs_object WHERE ObjectName= '" + Trim(LrText(1).Text) + "' And ObjectCode<>'" & Trim(LrText(0)) & "'", Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
If Not .EOF Then
Tsxx = "对象名称重复!"
Call Xtxxts(Tsxx, 0, 1)
LrText(1).SetFocus
Bclrsj = False
Exit Function
End If
If .State = 1 Then .Close
.Open "SELECT * FROM Cbhs_Object WHERE ObjectCode= '" + Trim(LrText(0)) + "'", Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
If Not .EOF Then
.Fields("ObjectName") = Trim(LrText(1))
'计量单位
SqlStr = "Select * From Cbhs_MeasureUnitType Where MeasureUnitCode='" & Trim(LrText(2).Text) & "' Or MeasureUnitName='" & Trim(LrText(2).Text) & "'"
Set RecTemp = Cw_DataEnvi.DataConnect.Execute(SqlStr)
If Not RecTemp.EOF Then
.Fields("MeasureUnitCode") = Trim(RecTemp.Fields("MeasureUnitCode"))
End If
.Fields("ProPlanCost") = Trim(LrText(3))
.Fields("ProPlanQuantity") = Trim(LrText(4))
'转下道工序
SqlStr = "Select * From Cbhs_TurnNextType Where TurnNextClassCode='" & Trim(LrText(5).Text) & "' Or TurnNextClassName='" & Trim(LrText(5).Text) & "'"
Set RecTemp = Cw_DataEnvi.DataConnect.Execute(SqlStr)
If Not RecTemp.EOF Then
.Fields("TurnNextClassCode") = Trim(RecTemp.Fields("TurnNextClassCode"))
End If
'对象类型
SqlStr = "Select * From Cbhs_ObjectType Where ObjectClassCode='" & Trim(LrText(6).Text) & "' Or ObjectClassName='" & Trim(LrText(6).Text) & "'"
Set RecTemp = Cw_DataEnvi.DataConnect.Execute(SqlStr)
If Not RecTemp.EOF Then
.Fields("ObjectClassCode") = Trim(RecTemp.Fields("ObjectClassCode"))
End If
'完工方式
SqlStr = "Select * From Cbhs_Completetype Where CompleteClassCode='" & Trim(LrText(7).Text) & "' Or CompleteClassName='" & Trim(LrText(7).Text) & "'"
Set RecTemp = Cw_DataEnvi.DataConnect.Execute(SqlStr)
If Not RecTemp.EOF Then
.Fields("CompleteClassCode") = Trim(RecTemp.Fields("CompleteClassCode"))
End If
'库房对象
SqlStr = "Select * From kf_costobject Where costobject_code='" & Trim(LrText(8).Text) & "' Or costobject_name='" & Trim(LrText(8).Text) & "'"
Set RecTemp = Cw_DataEnvi.DataConnect.Execute(SqlStr)
If Not RecTemp.EOF Then
.Fields("KF_Object") = Trim(RecTemp.Fields("costobject_code"))
End If
.Update
End If
SqlStr = "Select Objectcode,ObjectName,MeasureUnitName,ProPlanCost,ProPlanQuantity,ObjectClassName,TurnNextClassName,CompleteClassName From Cbhs_object A " _
& "Left Outer Join Cbhs_ObjectType B On A.ObjectClassCode=B.ObjectClassCode " _
& "Left OUter Join Cbhs_TurnNextType C On A.TurnNextClassCode=C.TurnNextClassCode " _
& "Left OUter Join Cbhs_Completetype D On A.CompleteClassCode=D.CompleteClassCode " _
& "Left Outer Join Cbhs_MeasureUnitType E On A.MeasureUnitCode=E.MeasureUnitCode " _
& "Where AccountCellcCode='" + Trim(Combo_CostCellCode(Combo_CostCell.ListIndex)) + "' " _
& "And ObjectCode='" & Trim(LrText(0).Text) & "' Order By ObjectCode"
Set Cxnrrec = Cw_DataEnvi.DataConnect.Execute(SqlStr)
If Not Cxnrrec.EOF Then
With CzxsGrid
Call Jltcwg(Cxnrrec, .Row)
End With
End If
End If
Bclrsj = True
Exit Function
End With
Swcwcl:
Tsxx = "存盘过程中出现错误,请退出后重新进入!"
Call Xtxxts(Tsxx, 0, 1)
Exit Function
End Function
Private Sub Cshlrxx(lrztxx As Integer) '初始化录入字段信息
TextChangeLock = True '关闭Chang事件
If lrztxx = 1 Then
For Jsqte = 0 To Max_Text_Index
If Len(Trim(Textstr(Jsqte, 1))) <> 0 Then
TextChangeLock = True
LrText(Jsqte).Text = ""
LrText(Jsqte).Tag = ""
TextChangeLock = False
End If
TextValiJudgeLock(Jsqte) = True
Next Jsqte
Else
Dim strCode As String
Dim i As Integer
With CzxsGrid
LrText(0).Text = Trim(.TextMatrix(.Row, Sydz("001", GridStr(), Szzls)))
LrText(1).Text = Trim(.TextMatrix(.Row, Sydz("002", GridStr(), Szzls)))
LrText(2).Text = Trim(.TextMatrix(.Row, Sydz("003", GridStr(), Szzls)))
LrText(3).Text = Trim(.TextMatrix(.Row, Sydz("004", GridStr(), Szzls)))
LrText(4).Text = Trim(.TextMatrix(.Row, Sydz("005", GridStr(), Szzls)))
LrText(5).Text = Trim(.TextMatrix(.Row, Sydz("006", GridStr(), Szzls)))
LrText(6).Text = Trim(.TextMatrix(.Row, Sydz("007", GridStr(), Szzls)))
LrText(7).Text = Trim(.TextMatrix(.Row, Sydz("008", GridStr(), Szzls)))
LrText(8).Text = Trim(.TextMatrix(.Row, Sydz("009", GridStr(), Szzls)))
End With
End If
TextChangeLock = False
End Sub
Private Sub Scdqjl() '删 除 当 前 记 录
Dim yhAnswer As Integer
If CzxsGrid.Row < CzxsGrid.FixedRows Then
Exit Sub
End If
Tsxx = "请确认是否删除当前记录?"
yhAnswer = Xtxxts(Tsxx, 2, 2)
If yhAnswer = 2 Then
Exit Sub
End If
On Error GoTo Cwcl
'[以下需自定义部分
Cw_DataEnvi.DataConnect.Execute "delete Cbhs_Object where ObjectCode = '" + Trim(CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("001", GridStr(), Szzls))) + "'"
'以上为自定义部分]
CzxsGrid.RemoveItem CzxsGrid.Row
Exit Sub
Cwcl:
If ERR.Number = -2147217900 Then
Tsxx = "该编码已经被使用,不能删除!"
Call Xtxxts(Tsxx, 0, 1)
Exit Sub
Else
Tsxx = "出现未知情况,该编码不能被删除!"
Call Xtxxts(Tsxx, 0, 1)
Exit Sub
End If
End Sub
'******************以下为基本处理程序(固定不变)************************'
Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer) '支持热键操作
If Shift = 2 Then
Select Case UCase(Chr(KeyCode))
Case "P" 'Ctrl+P 打印
Call bbyl(False)
Case "I" 'Ctrl+I 增加
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -