📄
字号:
CzxsGrid.TextMatrix(jsqte, Sydz("006", GridStr(), Szzls)) = Trim(.Fields("ScatterMoney") & "") '分配金额
CzxsGrid.TextMatrix(jsqte, Sydz("007", GridStr(), Szzls)) = Trim(.Fields("ObjectName") & "") '对象名称
CzxsGrid.TextMatrix(jsqte, Sydz("008", GridStr(), Szzls)) = Trim(.Fields("Objectcode") & "") '对象编码
CzxsGrid.TextMatrix(jsqte, Sydz("009", GridStr(), Szzls)) = Trim(.Fields("CenterCode") & "") '成本中心
'<<]
CzxsGrid.RowHeight(jsqte) = Sjhgd
.MoveNext
jsqte = jsqte + 1
Loop
End With
'将网格刷新解禁(Fixed)
CzxsGrid.Redraw = True
End Sub
Private Sub Form_Resize() '窗体调整
On Error Resume Next
With CzxsGrid
.Width = Me.Width - 160
.Height = Me.Height - .Top - 400
End With
With Pic_Title
.Width = Me.Width - 160
End With
GsToolbar.Left = Me.Width - GsToolbar.Width - 140
Call Cxxswbk
End Sub
Private Sub Form_Unload(Cancel As Integer) '窗体卸载
Set Cxnrrec = Nothing
Unload Dyymctbl
End Sub
Private Function Sub_SaveBill() As Boolean '保存数据
Dim Recfind As New ADODB.Recordset '有效性判断动态集
Dim Rowjsq As Long '网格行计数器
Dim Coljsq As Long '网格列计数器
Dim Int_RowCount As Integer '有效数据行计数器
Dim Lrywlz As Long '录入有误列值
'下面将对所有有效数据行进行有效性判断
Int_RowCount = 0
With CzxsGrid
For Rowjsq = .FixedRows To .Rows - 1
'带*号者为有效数据行
If .TextMatrix(Rowjsq, 0) <> "*" Then
Exit Function
Else
Int_RowCount = Int_RowCount + 1
End If
'2.[自定义判断(补丁)
'首先进行为空判断(固定不变)
For jsqte = Qslz To .Cols - 1
If (GridInt(jsqte, 5) = 1 And Len(Trim(.TextMatrix(Rowjsq, jsqte))) = 0) Or (GridInt(jsqte, 5) = 2 And Val(Trim(.TextMatrix(Rowjsq, jsqte))) = 0) Then
Tsxx = GridStr(jsqte, 2)
Lrywlz = jsqte
GoTo Lrcwcl
Exit For
End If
Next jsqte
Next
If Int_RowCount = 0 Then
Tsxx = "有效行数为零,不能存盘!"
Call Xtxxts(Tsxx, 0, 1)
Exit Function
End If
End With '网格
'如果以上有效性检查均顺利通过,则执行存盘动作
On Error GoTo Swcwcl
Cw_DataEnvi.DataConnect.BeginTrans
For Rowjsq = CzxsGrid.FixedRows To CzxsGrid.Rows - 1
SqlStr = "Delete From Cb_CostScatter Where Year='" & PrivateYear & "' And Period='" & PrivateMm & "' And ObjectCode='" + Trim(CzxsGrid.TextMatrix(Rowjsq, Sydz("008", GridStr(), Szzls))) + "' And ItemCode='" + Trim(CzxsGrid.TextMatrix(Rowjsq, Sydz("001", GridStr(), Szzls))) + "' And CenterCode='" + Trim(CzxsGrid.TextMatrix(Rowjsq, Sydz("009", GridStr(), Szzls))) + "'"
Cw_DataEnvi.DataConnect.Execute (SqlStr)
If RecDigest.State = 1 Then RecDigest.Close
RecDigest.Open "Select * From Cb_CostScatter Where 1=2", Cw_DataEnvi.DataConnect, adOpenDynamic, adLockPessimistic
If RecDigest.EOF Then
If CzxsGrid.TextMatrix(Rowjsq, 0) <> "*" Then
Exit Function
End If
With RecDigest
.AddNew
.Fields("Objectcode") = Trim(CzxsGrid.TextMatrix(Rowjsq, Sydz("008", GridStr(), Szzls))) '对象编码
.Fields("ItemCode") = Trim(CzxsGrid.TextMatrix(Rowjsq, Sydz("001", GridStr(), Szzls))) '项目编码
.Fields("CenterCode") = Trim(CzxsGrid.TextMatrix(Rowjsq, Sydz("009", GridStr(), Szzls))) '中心编码
.Fields("Year") = PrivateYear '会计年度
.Fields("Period") = PrivateMm '会计期间
.Fields("ScatterQuantity") = Trim(CzxsGrid.TextMatrix(Rowjsq, Sydz("005", GridStr(), Szzls))) '分配数量
.Fields("ScatterMoney") = Trim(CzxsGrid.TextMatrix(Rowjsq, Sydz("006", GridStr(), Szzls))) '分配金额
.Update
End With
End If
Next
Cw_DataEnvi.DataConnect.CommitTrans
Tsxx = "存盘完毕! "
Call Xtxxts(Tsxx, 0, 4)
Sub_SaveBill = True
Lab_OperStatus = "1"
Call Sub_OperStatus("11")
Exit Function
Swcwcl:
Cw_DataEnvi.DataConnect.RollbackTrans
If Err.Number = -2147217873 Then
Tsxx = "不能有重复的对象!"
Else
Tsxx = "存盘过程中出现未知错误,程序自动恢复保存前状态!"
End If
Call Xtxxts(Tsxx, 0, 1)
Exit Function
Lrcwcl: '录入错误处理
Cw_DataEnvi.DataConnect.RollbackTrans
With CzxsGrid
Call Xtxxts("(第 " + Trim(Str(Int_RowCount)) + " 条记录)-" + Tsxx, 0, 1)
Changelock = True
.Select Rowjsq, Lrywlz
CzxsGrid.SetFocus
Changelock = False
Exit Function
End With
End Function
'******************以下为基本处理程序(固定不变)************************'
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)
End Select
End If
End Sub
Private Sub SzToolbar_ButtonClick(ByVal Button As MSComctlLib.Button)
Select Case Button.Key
Case "ymsz" '页面设置
Dyymctbl.Show 1
Case "yl" '预 览
Call bbyl(True)
Case "dy" '打 印
Call bbyl(False)
Case "xg" '编辑
'判断用户是否有此功能执行权限,如有则写上机日志(进入)
If Not Security_Log(Str_RightEdit, Xtczybm, 1, True) Then
Exit Sub
End If
'设置状态
Lab_OperStatus.Caption = "3"
'设置工具条状态
Call Sub_OperStatus("30")
Case "bc" '保存
If Fun_Drfrmyxxpd Then Call Sub_SaveBill
Case "fq" '放弃
Call Sub_AbandonBill
Case "scatter" '分配
'判断用户是否有此功能执行权限,如有则写上机日志(进入)
If Not Security_Log(Str_RightEdit, Xtczybm, 1, True) Then
Exit Sub
End If
Glo_Year = PrivateYear
Glo_Period = PrivateMm
Load JS_FrmSelectObject
JS_FrmSelectObject.Combo_CostObject.Tag = "Scatter"
JS_FrmSelectObject.HelpContextID = "0703003"
JS_FrmSelectObject.Show 1
Glo_Year = 0
Glo_Period = 0
Call Sub_Query(Combo_Sort.ListIndex)
Case "bz" '帮 助
Call F1bz
Case "fh" '退 出
Unload Me
End Select
End Sub
Private Sub CzxsGrid_DblClick() '修改当前编码记录
With CzxsGrid
Call xswbk
End With
End Sub
Private Sub Sub_OperStatus(Str_Status As String) '工具条依据不同状态所进行的变化
With SzToolbar
Select Case Str_Status
Case "10" '浏览
'工具条
.Buttons("xg").Enabled = False '修改
.Buttons("bc").Enabled = False
.Buttons("fq").Enabled = False
.Buttons("scatter").Enabled = False
Case "11" '浏览
'工具条
.Buttons("xg").Enabled = True '修改
.Buttons("bc").Enabled = False
.Buttons("fq").Enabled = False
.Buttons("scatter").Enabled = True
Case "30" '修改
'工具条
.Buttons("xg").Enabled = False '修改
.Buttons("bc").Enabled = True
.Buttons("fq").Enabled = True
.Buttons("scatter").Enabled = False
End Select
End With
End Sub
Private Sub GsToolbar_ButtonClick(ByVal Button As MSComctlLib.Button) '表格格式设置(通用)
Select Case Button.Key
Case "bcgs" '保存表格格式
Call Bcwggs(CzxsGrid, GridCode, GridStr())
Case "hfmrgs" '恢复默认格式
Call Hfmrgs(CzxsGrid, GridCode, GridStr())
End Select
End Sub
Private Sub bbyl(bbylte As Boolean) '报表打印预览
Dim Bbzbt$, Bbxbt() As String, bbxbtzzxs() As Integer, Bbxbtgs As Integer
Dim Bbbwh() As String, Bbbwhzzxs() As Integer, Bbbwhgs As Integer
Bbxbtgs = 1 '报 表 小 标 题 行 数
Bbbwhgs = 0 '报 表 表 尾 行 数
ReDim Bbxbt(1 To Bbxbtgs)
ReDim bbxbtzzxs(1 To Bbxbtgs)
If Bbbwhgs <> 0 Then
ReDim Bbbwh(1 To Bbbwhgs)
ReDim Bbbwhzzxs(1 To Bbbwhgs)
End If
Bbzbt = ReportTitle
If Combo_Center.ListCount > 0 Then
Bbxbt(1) = Space(2) + Fun_FormatOutPut(Label_Lab.Caption + Right(Trim(Combo_Center.List(Combo_Center.ListIndex)), Len(Trim(Combo_Center.List(Combo_Center.ListIndex))) - 4), 42)
Bbxbt(1) = Bbxbt(1) + Fun_FormatOutPut(Mid(CStr(Combo_KJQJ.List(Combo_KJQJ.ListIndex)), 1, 4) + "年" + Right(CStr(Combo_KJQJ.List(Combo_KJQJ.ListIndex)), 2) + "月", 35)
Else
Bbxbt(1) = Space(2) + Label_Lab.Caption
End If
bbxbtzzxs(1) = 0 '报表行组织形式(0-居左 1-居中 2-居右)
Call Scyxsjb(CzxsGrid) '生成报表数据
Call Scdybb(Dyymctbl, Bbzbt, Bbxbt(), bbxbtzzxs(), Bbxbtgs, Bbbwh(), Bbbwhzzxs(), Bbbwhgs, bbylte)
If Not bbylte Then
Unload DY_Tybbyldy
End If
End Sub
'************以下为文本框录入处理程序(固定不变部分)*************'
Private Sub Wbklrwbcl(Index As Integer) '文本框录入事后处理程序
'以下为依据实际情况自定义部分[
'在此填写文本框录入事后处理程序
']以上为依据实际情况自定义部分
End Sub
Private Sub TextShow(Index As Integer) '文本框得到焦点,显示相应信息
'填写文本框得到焦点,进行相应信息处理程序
End Sub
Private Sub Lrsjhx() '文本框录入数据回写
With CzxsGrid
If YdCombo.Visible Then .Text = Trim(YdCombo.Text)
If Ydtext.Visible Then .Text = Trim(Ydtext.Text)
'(如果字段录入内容发生变化,则打开有效性判断锁)
If Zdlrqnr <> Trim(.Text) Then
Yxxpdlock = False
Hyxxpdlock = False
End If
'如果字段录入内容不为空则写数据行有效性标志
If Len(Trim(.Text)) <> 0 Then
Call Xyxhbz(.Row)
End If
'隐藏文本框,帮助按钮,列表组合框
Call Ycwbk
End With
End Sub
Private Function Sjhzyxxpd(ByVal Yxxpdh As Long) As Boolean '录入数据行有效性判断,同时进行行处理
Dim Lrywlz As Long
With CzxsGrid
'判断行是否为空和无效数据行清除
If Yxxpdh > (.Rows - .FixedRows) Then Exit Function
If .TextMatrix(Yxxpdh, 0) <> "*" Then
Sjhzyxxpd = True
Exit Function
Else
If pdhwk(Yxxpdh) And Yxxpdh + 1 <= .Rows - 1 Then
If .TextMatrix(Yxxpdh + 1, 0) <> "*" Then
Changelock = True
.RemoveItem Yxxpdh
If .Rows < Pmbcsjhs + .FixedRows + Fzxwghs + 1 Then
.AddItem ""
.RowHeight(.Rows - 1) = Sjhgd
End If
Changelock = False
Sjhzyxxpd = True
Exit Function
End If
End If
End If
'行没有发生变化则不进行有效性判断
If Hyxxpdlock Then
Sjhzyxxpd = True
Exit Function
End If
'以下为自定义部分[
'1.放置行有效性判断程序
'首先进行为空判断(固定不变)
For jsqte = Qslz To .Cols - 1
If (GridInt(jsqte, 5) = 1 And Len(Trim(.TextMatrix(Yxxpdh, jsqte))) = 0) Or (GridInt(jsqte, 5) = 2 And Val(Trim(.TextMatrix(Yxxpdh, jsqte))) = 0) Then
Tsxx = GridStr(jsqte, 2)
Lrywlz = jsqte
GoTo Lrcwcl
Exit For
End If
Next jsqte
End With
Sjhzyxxpd = True
Hyxxpdlock = True
Exit Function
Lrcwcl: '录入错误处理
With CzxsGrid
Call Xtxxts(Tsxx, 0, 1)
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -