VB开发的ERP系统

    End If
    With WglrGrid
        '限制字段录入长度
        Wbkbhlock = True
        Select Case GridInt(.Col, 1)
            Case 8
                Call Sjgskz(Ydtext, Xtjezws - Xtjexsws - 1, Xtjexsws)
            Case 9
                Call Sjgskz(Ydtext, Xtslzws - Xtslxsws - 1, Xtslxsws)
            Case 10
                Call Sjgskz(Ydtext, Xtdjzws - Xtdjxsws - 1, Xtdjxsws)
            Case Else
                If GridInt(.Col, 3) <> 0 Or GridInt(.Col, 4) <> 0 Then
                    Call Sjgskz(Ydtext, GridInt(.Col, 3), GridInt(.Col, 4))
                End If
        End Select
        Wbkbhlock = False
    End With
End Sub
Private Sub ydtext_LostFocus()            '如果由于选中网格之外的控件而发生有效性判断(选中网格会先发生Rowcolchange事件置Valiock为TRUE)
    With WglrGrid
        If Valilock = False Then
            Call Lrsjhx
            If Not sjzdyxxpd(Dqlrwgh, Dqlrwgl) Then Exit Sub
            If Not Sjhzyxxpd(Dqlrwgh) Then
                Exit Sub
            End If
        End If
    End With
End Sub

Private Sub Qkwlzd(sjh As Long, Sjl As Long)                            '清空为零字段
    If Not GridBoolean(Sjl, 5) Then Exit Sub
    With WglrGrid
        If Val(Trim(.TextMatrix(sjh, Sjl))) = 0 Then .TextMatrix(sjh, Sjl) = ""
    End With
End Sub
Private Sub fhyxh()                                                     '返回录入数据有效行,同时让得到焦点网格可见
    With WglrGrid
        If .Row >= .FixedRows Then
            If .TextMatrix(.Row, 0) <> "*" Then     '点击网格空区域时执行此语句
                For Rowjsq = .FixedRows To .Rows - 1        '为找到最后一数据行的下一行
                    If .TextMatrix(Rowjsq, 0) <> "*" Then
                    Exit For
                    End If
                Next Rowjsq
                If Rowjsq <= .Rows - 1 Then
                    Changelock = True
                    .Select Rowjsq, .Col
                    Changelock = False
                Else
                    Changelock = True
                    .Select .Rows - 1, .Col
                    Changelock = False
                End If
            End If
            Call Xldqh
        End If
    End With
End Sub
Private Sub Xldqh()                                                      '显露当前行
    Dim Toprowte As Long
    With WglrGrid
        Toprowte = 0
        Do While .CellTop + .RowHeight(.Row) + Fzxwghs * Sjhgd > .Height And .TopRow <> Toprowte
            Toprowte = .TopRow
            .TopRow = .TopRow + 1
        Loop
        Toprowte = 0
        Do While .CellTop < .FixedRows * .RowHeight(0) And .TopRow <> Toprowte
            Toprowte = .TopRow
            .TopRow = .TopRow - 1
        Loop
    End With
End Sub
Private Sub Xldql()                                                     '显露当前列
    Dim Leftcolte As Long
    With WglrGrid
        If .Col >= Qslz Then
            If .LeftCol > .Col Then
                .LeftCol = .Col
            End If
            Leftcolte = 0
            Do While .CellLeft + .CellWidth > .Width And .LeftCol <> Leftcolte
                Leftcolte = .LeftCol
                .LeftCol = .LeftCol + 1
            Loop
        End If
    End With
    
End Sub
Private Function pdhwk(sjh As Long)                                     '判断网格行是否为空行(所有录入字段均为空*非录入字段除外)
    With WglrGrid
        For Coljsq = Qslz To .Cols - 1
            If Len(Trim(.TextMatrix(sjh, Coljsq))) <> 0 And GridBoolean(Coljsq, 1) Then
                pdhwk = False
                Exit Function
            End If
        Next Coljsq
        pdhwk = True
    End With
End Function
Private Sub Xyxhbz(sjh As Long)                                         '写行有效性标志,并判断是否增行
    With WglrGrid
        If .TextMatrix(sjh, 0) = "*" Then
            Exit Sub
        End If
        .TextMatrix(sjh, 0) = "*"
        If sjh >= .Rows - Fzxwghs - 1 Then
            .AddItem ""
            .RowHeight(.Rows - 1) = Sjhgd
        End If
    End With
End Sub
Private Sub Sub_OperStatus(Str_Status As String)                 '工具条依据不同状态所进行的变化
    With Tlb_Action
        Select Case Str_Status
            Case "10"   '浏览
                '工具条
                '.Buttons("dy").Enabled = False     '打印
                '.Buttons("yl").Enabled = False     '预览
                .Buttons("run").Enabled = False
            Case "11"   '浏览
                 '工具条
            Case "30"   '修改
                '工具条
        End Select
    End With
End Sub
Private Sub GsToolbar_ButtonClick(ByVal Button As MSComctlLib.Button)   '表格格式设置(通用)
    Select Case Button.Key
        Case "bcgs"                              '保存表格格式
            Call Bcwggs(WglrGrid, GridCode, GridStr())
        Case "hfmrgs"                            '恢复默认格式
            Call Hfmrgs(WglrGrid, GridCode, GridStr())
        Case "szxsxm"                            '设置显示项目
            Call Szxsxm(WglrGrid, GridCode)
    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
    
    '判断是否为空
    SqlStr = "Select Count(*) From Cb_CostObject"
    Set RecTemp = Cw_DataEnvi.DataConnect.Execute(SqlStr)
    If RecTemp.Fields(0) <= 0 Then
        Bbxbt(1) = ""
    Else
        Bbxbt(1) = Mid(CStr(Combo_KJQJ.List(Combo_KJQJ.ListIndex)), 1, 4) + "年" + Right(CStr(Combo_KJQJ.List(Combo_KJQJ.ListIndex)), 2) + "月"
    End If
  
    bbxbtzzxs(1) = 1                                     '报表行组织形式(0-居左 1-居中 2-居右)
    Call Scyxsjb(WglrGrid)                               '生成报表数据
    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 Cxxswbk()                                                  'Formresize中重新显示文本框,列表框,帮助按钮(通用)
    Dim Wbkpy As Integer, Wbkpy1 As Integer
    Wbkpy = 30
    Wbkpy1 = 15
    With WglrGrid
        If YdCombo.Visible Then
            YdCombo.Left = .CellLeft + .Left + Wbkpy
            YdCombo.Top = .CellTop + .Top + Wbkpy
            YdCombo.Width = .CellWidth - Wbkpy1
        End If
        If Ydcommand.Visible Then
            Ydcommand.Left = .Left + .CellLeft + .CellWidth - Ydcommand.Width + Wbkpy
            Ydcommand.Top = .Top + .CellTop + .CellHeight - Ydcommand.Height + Wbkpy
        End If
        If Ydtext.Visible Then
            If Ydcommand.Visible Then
                If Sfblbzkd Then
                    Ydtext.Width = .CellWidth - Ydcommand.Width
                Else
                    Ydtext.Width = .CellWidth - Wbkpy1
                End If
            Else
                Ydtext.Width = .CellWidth - Wbkpy1
            End If
            Ydtext.Left = .CellLeft + .Left + Wbkpy
            Ydtext.Top = .CellTop + .Top + Wbkpy
            Ydtext.Height = .CellHeight - Wbkpy1
        End If
    End With
End Sub
'=================以下自定义部分=================
Sub Run2()                          '结转产成品
    Dim Rec_SubTemp As New ADODB.Recordset
    Dim lng_OperationNum As Long
    Dim i As Integer
    Dim CF_Count As Integer
    Dim IdCount As Integer
    
    Bln_DeleteFlag = True
    Changelock = False
    CF_Count = 0
    If CF_Judge = False Then                 '结转之前判断
        Exit Sub
    End If
    
    On Error GoTo Err1
    Screen.MousePointer = 11
    Cw_DataEnvi.DataConnect.BeginTrans
    IdCount = 0
    For jsq = 1 To Tranjsq
        
        '有无可结转的数据
        SqlStr = "Select Sum(ThmonConsumeMoney) As ThmonConsumeMoney From Cb_Fn_CFProduceCost('" + CStr(TranNum(jsq)) + "'," + CStr(PrivateYear) + "," + CStr(PrivateMm) + ") "
        Set Rec_SubTemp = Cw_DataEnvi.DataConnect.Execute(SqlStr)
        If Not IsNull(Rec_SubTemp.Fields("ThmonConsumeMoney")) Or Rec_SubTemp.Fields("ThmonConsumeMoney") = 0 Then
            '写临时凭证主表
            lng_OperationNum = CreatBillID("0102")
            Call Save_TempPz_Main(OperationNum, lng_OperationNum)
            
            '写临时凭证子表
            SqlStr = "Select '成本结转' As Digest,0 As Jfje,Sum(ThmonConsumeMoney) As Dfje,0 As ye,0 As Jfsl,Sum(ThmonConsumeAmount) As Dfsl,Ccode1 As Ccode " _
                        & "From Cb_Fn_CFProduceCost('" + CStr(TranNum(jsq)) + "'," + CStr(PrivateYear) + "," + CStr(PrivateMm) + ") Group By Ccode1  Having Sum(ThmonConsumeMoney)<>0 Union " _
                        & "Select '成本结转',Sum(ThmonConsumeMoney),0,0,Sum(ThmonConsumeAmount),0,B.Ccode From Cb_Fn_CFProduceCost('" + CStr(TranNum(jsq)) + "'," + CStr(PrivateYear) + "," + CStr(PrivateMm) + ") A " _
                        & "Left Outer Join Cb_CostObject B On A.ObjectCode=b.ObjectCode " _
                        & "Group By B.Ccode"
                        
            Set Rec_SubTemp = Cw_DataEnvi.DataConnect.Execute(SqlStr)
            i = 1
            Do Until Rec_SubTemp.EOF
                Call Save_TempPz_Ass(Rec_SubTemp, lng_OperationNum, i)
                Rec_SubTemp.MoveNext
                i = i + 1
            Loop
            If IdCount = 0 Then
                ReDim Glo_ObjectId1.OId(IdCount)
                ReDim Glo_ObjectId1.ONum(IdCount)
                Glo_ObjectId1.OId(IdCount) = TranNum(jsq)
                Glo_ObjectId1.ONum(IdCount) = lng_OperationNum
            End If
            If IdCount > 0 Then
                ReDim Preserve Glo_ObjectId1.OId(IdCount)
                ReDim Preserve Glo_ObjectId1.ONum(IdCount)
                Glo_ObjectId1.OId(IdCount) = TranNum(jsq)
                Glo_ObjectId1.ONum(IdCount) = lng_OperationNum
            End If
            IdCount = IdCount + 1
            CF_Count = CF_Count + 1
        Else
            Tsxx = "对象没有可结转的数据!"
            Call Xtxxts(Tsxx, 0, 3)
        End If
        
    Next
    
    Cw_DataEnvi.DataConnect.CommitTrans
    Screen.MousePointer = 0
    If CF_Count > 0 Then
        AutoTran_PzFrm.OperationNumPz = OperationNum
        AutoTran_PzFrm.vouchsourcePz = "成本核算"
        AutoTran_PzFrm.HelpContextID = "0705003"
        AutoTran_PzFrm.Show 1
    End If
    
    Call WriteVouchId(OperationNum, 2)  '写数据
    Call Clean                        '删除信息
    Call Sub_Query                    '查询信息
    Exit Sub
Err1:
    Cw_DataEnvi.DataConnect.RollbackTrans
    Screen.MousePointer = 0
    Exit Sub
End Sub
Sub Run1()                              '结转生产成本
    Dim jsq As Integer
    Dim Rec_SubTemp As New ADODB.Recordset
    Dim lng_OperationNum As Long
    Dim i As Integer
    Dim CF_Count As Integer
    Dim IdCount As Integer
    
    Bln_DeleteFlag = True
    Changelock = False
    CF_Count = 0
    If CF_Judge = False Then                 '结转之前判断
        Exit Sub
    End If
    
    On Error GoTo Err1
    Screen.MousePointer = 11
    Cw_DataEnvi.DataConnect.BeginTrans
    IdCount = 0
    For jsq = 1 To Tranjsq
        
        '有无可结转的数据
        SqlStr = "Select Sum(Isnull(ThmonConsumeMoney,0)) As ThmonConsumeMoney From Cb_Fn_CFProduceCost('" + CStr(TranNum(jsq)) + "'," + CStr(PrivateYear) + "," + CStr(PrivateMm) + ") "
        Set Rec_SubTemp = Cw_DataEnvi.DataConnect.Execute(SqlStr)
        If Not IsNull(Rec_SubTemp.Fields("ThmonConsumeMoney")) Or Rec_SubTemp.Fields("ThmonConsumeMoney") = 0 Then
            '写临时凭证主表
            lng_OperationNum = CreatBillID("0102")
            Call Save_TempPz_Main(OperationNum, lng_OperationNum)
            
            '写临时凭证子表
            SqlStr = "Select '成本结转' As Digest,0 As Jfje,isnull(ThmonConsumeMoney,0) As Dfje,0 As ye,0 As Jfsl,isnull(ThmonConsumeAmount,0) As Dfsl,Ccode2 As Ccode From Cb_Fn_CFProduceCost('" + CStr(TranNum(jsq)) + "'," + CStr(CStr(PrivateYear)) + "," + CStr(PrivateMm) + ") Where isnull(ThmonConsumeMoney,0)<>0" _
                        & "U