企业管理

开发平台：
Visual Basic

-：源码内容
							Attribute VB_Name = "XtsyModule"
'*********************************************************************
'*    模 块 名 称 :财务分析私有模块
'*    功 能 描 述 :
'*    程序员姓名  :魏永生
'*    最后修改人  :
'*    最后修改时间:2002/1/21
'*    备        注:程序中所有依实际情况自定义部分均用[>>  <<]括起
'*
'*********************************************************************
'系统私有模块用来放置一些子系统独有的过程与函数
Public str_Code As String                               '存储列内容参数
'/*
'-------------------bsj-------------------------------------
Public Const DEBUG_FLAG = False '  调试标志，发布时设为false
Public Type TAG_TYPE
    strType As String '指标类别
    strName As String '指标名称
    strUnit As String '单位
    sigCurrentV As Double '本期实际数据
    sigYearBeginV As Double '本年年初数据
    strTagAdd1 As String '指标增减
    strCompDate As String '比较期间
    sigComPareV As Single '比较期数据
    strTagAdd2 As String '指标增减
End Type
Public TagArry() As TAG_TYPE  '自定义数组
Public Type PRO_TYPE
    strName As String '产品名称
    sigComeIn As Double '销售收入
    sigCost As Double '销售成本
    sigMaoLi As Double '销售毛利
    sigMaoLiLv As Double '销售毛利率
End Type
Public ProArry() As PRO_TYPE  '自定义数组（产品毛利分析）
Public Type ITE_TYPE
    strItemClass As String '项目大类
    strItemName As String '项目名称
    lngInCome As Double '项目收入
    lngCost As Double ' 项目成本
    lngMaoLi As Double '项目毛利
    lngMaoLiLv As Double '项目毛利率
End Type
Public IteArry() As ITE_TYPE  '自定义数组（项目毛利分析）
Public mySeachForm As New Bbfx_SelDate
'----------------------------------------------------------
Public g_code As String             '传递单据号
Public g_status As String           '传递单据状态
Public g_help_infor() As String     '用以返回帮助窗体的信息
Public m, n As Long                 '公用计数器
Public StrString As String
'在预算设置中使用
Public Str_DeptCode                                '预算部门代码
Public Str_DeptName                                '预算部门名称
Public Str_ItemCode                                '项目代码
Public Str_ItemName                                '项目名称
Public Str_ItemClassCode                           '项目类别代码
Public Str_ItemClassName                           '项目类别名称
Public Str_Ccode As String                         '预算科目
Public Int_OriYear As Integer                      '条件选择的会计年度
Public Int_Month As Integer                        '月份
Public Str_Show As String                          '追加金额提示信息
Public Str_TableAdd As String                      '追加金额表名
Public Cur_TableAdd As Currency                    '追加金额表合计值回写主表单元格
Public Int_I_Id As Integer                         '主表记录标识，供从表使用
Public Str_Title As String                         '从表标题
Public Str_ReportSubTitle As String                '从表子标题
Public Frm_AnalysisC As Form                       '预算分析查询条件窗体
Public Frm_AnalysisA As Form                       '预算分析查询结果窗体
'Public Str_ReportSubTitle As String               '预算分析表子标题，使用上面定义的变量
'Public Str_Title As String                        '预算分析表主标题，使用上面定义的变量
Public str_BudgetProc As String                    '预算分析存贮过程字串
Public str_AnalysisProc As String                  '预算分析存贮过程字串
Public bln_FrmBudgetA As Boolean                   '代表窗体是否已经存在
Public Function FnBln_RefreshArray(int_StartCol As Long, int_FinishCol As Long, GridStr() As String, GridInf()) As Boolean
    '功能：实现网格的列移动
    '说明：本函数是在模式工程的基础上创建的，请确认你的窗体中的网格是通过
    '     BzWgcsh(CxbbGrid, GridCode, GridInf(), GridBoolean(), GridInt(), GridStr()) 函数来定义的
    '参数：int_StartCol——网格开始移动列
    '参数：int_FinishCol——网格移动结束列
    '参数：GridStr()——网格的信息数组
    '思路：对于要移动的网格来说，所有的信息都保存在几个系统数组中，其中GridStr（）数组保存着逻辑定位和
    '       物理定位之间的转换关系，使我们可以通过逻辑值找到物理值,由于我们通常通过逻辑值来定位网格的
    '       物理列（sydz(zdbmte as String,GridStr() as String,szzls as Integer)函数），所以我们只需要
    '       改变GridStr()数组中物理列和逻辑列之间的对应关系，从而达到改变列的目的。
    '扩展：虽然本程序只是针对数据显示网格而作，但是此程序给大家提供了一个思路，通过交换GridBoolean()、
    ' GridInt()、网格列标题wglbt()等数组，就可以实现输入的列移动
    On Error GoTo Err_Ctrl
    
    Dim int_Temp As Integer
    Dim str_temp() As String '用来保存移动开始列的GridStr()信息
    Dim i, j As Long
    
    
    
    '保存移动开始列的GridStr()信息
    ReDim str_temp(0, UBound(GridStr, 2))
    For j = 1 To UBound(GridStr, 2)
        str_temp(0, j) = GridStr(int_StartCol, j)
    Next
    '[[在此加入你的代码，保存当前开始移动列的其他信息]]
    
    '依次移动各列的信息
    If int_StartCol < int_FinishCol Then
        For i = int_StartCol To int_FinishCol - 1
            For j = 1 To UBound(GridStr, 2)
                GridStr(i, j) = GridStr(i + 1, j)
            Next j
        Next i
    Else
        For i = int_StartCol To int_FinishCol + 1 Step -1
            For j = 1 To UBound(GridStr, 2)
                GridStr(i, j) = GridStr(i - 1, j)
            Next j
        Next i
    End If
    '[[在此加入你的代码，依照上面的代码格式，移动列的其他信息]]
    
    '恢复开始移动列的信息到结束列上
    For j = 1 To UBound(GridStr, 2)
        GridStr(int_FinishCol, j) = str_temp(0, j)
    Next j
    
    '[[在此加入你的代码，恢复开始移动列的其他信息到结束列上]]
    
    FnBln_RefreshArray = True
    
Err_Ctrl:
    FnBln_RefreshArray = False
End Function
Public Function Sfyxzx() As Boolean                                '判断是否允许执行某项功能
    Dim Ztxxrec As New ADODB.Recordset
    Dim Tsxx As String
    Sfyxzx = False
    Set Ztxxrec = Cw_DataEnvi.DataConnect.Execute("Select * From Gdzc_ztxx")
    With Ztxxrec
        If Not .EOF Then
            If (Xtyear <> .Fields("ztdqyear")) Or (Xtmm <> .Fields("ztdqmm")) Then
                Tsxx = "选择期间非帐套当前会计期间,此项功能模块不能使用!"
                Call Xtxxts(Tsxx, 0, 4)
                Exit Function
            Else
                If .Fields("sfjtzj") Then
                    Tsxx = "当前会计期间已计提折旧,此项功能模块不能使用!"
                    Tsxx = Tsxx + Chr(10) + "请先将本月执行月末结帐!"
                    Call Xtxxts(Tsxx, 0, 4)
                    Exit Function
                End If
            End If
        End If
    End With
    Sfyxzx = True
End Function
'*/
Public Sub Drxtztcs()                                   '读入系统帐套参数
    
    Dim Ztcsbrec As New ADODB.Recordset
    Dim RecTemp As New ADODB.Recordset
    Dim SqlStr As String
    
    With Ztcsbrec
        '金额总位数
        .Open "Select * From Gy_AccInformation Where SystemCode='Cwzz'", Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
        .MoveFirst
        .Find "itemcode='cwjezws'"
        If Not Ztcsbrec.EOF Then
            Xtjezws = Val(Trim(Ztcsbrec.Fields("itemvalue")))
        End If
        
        '数量总位数
        .MoveFirst
        .Find "itemcode='cwslzws'"
        If Not Ztcsbrec.EOF Then
            Xtslzws = Val(Trim(Ztcsbrec.Fields("itemvalue")))
        End If
        
        '单价总位数
        .MoveFirst
        .Find "itemcode='cwdjzws'"
        If Not Ztcsbrec.EOF Then
            Xtdjzws = Val(Trim(Ztcsbrec.Fields("itemvalue")))
        End If
        
        '金额小数位数
        .MoveFirst
        .Find "itemcode='cwjexsws'"
        If Not Ztcsbrec.EOF Then
            Xtjexsws = Val(Trim(Ztcsbrec.Fields("itemvalue")))
        End If
        
        '数量小数位数
        .MoveFirst
        .Find "itemcode='cwslxsws'"
        If Not Ztcsbrec.EOF Then
            Xtslxsws = Val(Trim(Ztcsbrec.Fields("itemvalue")))
        End If
        
        '单价小数位数
        .MoveFirst
        .Find "itemcode='cwdjxsws'"
        If Not Ztcsbrec.EOF Then
            Xtdjxsws = Val(Trim(Ztcsbrec.Fields("itemvalue")))
        End If
        .Close
    End With
    
End Sub
Public Sub fill_tv(tv As TreeView, flbm As ADODB.Recordset, field1 As String, field2 As String, bmjc_bz As Boolean, tree_name As String, Treeprant As String, Treechr As String)
    '---------------------------------------------
    '填充TREEVIEW
    Dim fllb, lsbl(), lsbl1(), remlayer, nodX, tem, count
    On Error GoTo ERRORCL
    tv.Nodes.Clear
    flbm.Requery
    If flbm.EOF Then
        Set nodX = tv.Nodes.Add(, 4, "r", tree_name, Treeprant)
        Exit Sub
    Else
        Set nodX = tv.Nodes.Add(, 4, "r", tree_name, Treeprant)
    End If
    flbm.MoveFirst
    count = 1
    If bmjc_bz Then
        Do While Not flbm.EOF
            fllb = "(" + Trim(flbm.Fields(field1)) + ")" + Trim(flbm.Fields(field2))
            remlayer = flbm.Fields("code_level")
            tem = Trim(flbm.Fields(field1))
            Select Case remlayer
            Case 1
                ReDim Preserve lsbl(remlayer)
                ReDim Preserve lsbl1(remlayer)
                lsbl(remlayer) = "p" & tem
                Set nodX = tv.Nodes.Add("r", 4, lsbl(remlayer), fllb, Treechr)
            Case 2
                ReDim Preserve lsbl1(remlayer)
                ReDim Preserve lsbl1(remlayer)
                lsbl1(remlayer) = "p" & tem
                Set nodX = tv.Nodes.Add(lsbl(remlayer - 1), tvwChild, lsbl1(remlayer), fllb)
            Case 3
                ReDim Preserve lsbl(remlayer)
                ReDim Preserve lsbl1(remlayer)
                lsbl(remlayer) = lsbl1(remlayer - 1)
                lsbl1(remlayer) = "p" & tem
                Set nodX = tv.Nodes.Add(lsbl(remlayer), tvwChild, lsbl1(remlayer), fllb)
            Case Else
                ReDim Preserve lsbl(remlayer)
                ReDim Preserve lsbl1(remlayer)
                lsbl(remlayer) = lsbl1(remlayer - 1)
                lsbl1(remlayer) = "p" & tem
                Set nodX = tv.Nodes.Add(lsbl(remlayer), tvwChild, lsbl1(remlayer), fllb)
            End Select
            tv.Nodes(count).Expanded = True
            count = count + 1
            flbm.MoveNext
        Loop
    Else
        Do While Not flbm.EOF
            fllb = "(" + Trim(flbm.Fields(field1)) + ")" + Trim(flbm.Fields(field2))
            tem = Trim(flbm.Fields("flbm"))
            lsbl(remlayer) = "p" & tem
            Set nodX = tv.Nodes.Add(, 4, lsbl(remlayer), fllb)
            flbm.MoveNext
        Loop
    End If
    Exit Sub
ERRORCL:
    MsgBox "程序出现错误", vbExclamation, title_bar
    Exit Sub
End Sub
Public Sub BalFx(ByVal strItem As String, Optional sHelpID As String)
    If DEBUG_FLAG = False Then On Error Resume Next
    '此过程由系统主面板，树型菜单在单击“资产负债表分析”时调用，参数为模块标识
    '财务分析-资产负债表分析
    'BBFX_FrmBalFx.Show
    
    Dim temRs As New ADODB.Recordset
    Dim mySeachForm As New Bbfx_SelDate
    mySeachForm.Show vbModal
    If mySeachForm.bSeach = True Then '如果单击查询窗体的“确定”按钮则：
        Set temRs = Cw_DataEnvi.DataConnect.Execute("SELECT gnmc FROM xt_xtgnb where gnsy='" & strItem & "'")
        DoEvents
        With Bbfx_FrmBalFx
            If DEBUG_FLAG = False Then
                XT_Wait.Show
                XT_Wait.Refresh
            End If
            DoEvents
            .Caption = "资产负债表分析-" & Trim(temRs!gnmc)
            .TsLabel(4).Caption = "资产负债表分析（" & Trim(temRs!gnmc) & "）"
            .intType = mySeachForm.intType '传递查询参数
            .strBegin = mySeachForm.strBegin '
            .strEnd = mySeachForm.strEnd
            .strItem = strItem
            .bSeach = mySeachForm.bSeach
            .HelpContextID = sHelpID
            Call .FormInit
            .Show '并显示窗体
            If DEBUG_FLAG = False Then
                XT_Wait.Hide
            End If
            
        End With
    End If
    '否则（即击“取消”按钮）退出过程
End Sub
Public Sub BalFx2(ByVal strItem As String, Optional sHelpID As String)
    If DEBUG_FLAG = False Then On Error Resume Next
    '此过程由系统主面板，树型菜单在单击“资产负债表分析”时调用，参数为模块标识
    '财务分析-资产负债表分析
    'BBFX_FrmBalFx.Show
    
    Dim mySeachForm As New Bbfx_SelDate2
    
    
    Dim temRs As New ADODB.Recordset
    mySeachForm.Show vbModal
    If mySeachForm.bSeach = True Then '如果单击查询窗体的“确定”按钮则：
        Set temRs = Cw_DataEnvi.DataConnect.Execute("SELECT gnmc FROM xt_xtgnb where gnsy='" & strItem & "'")
        With Bbfx_FrmBalFx2
            If DEBUG_FLAG = False Then
                XT_Wait.Show
                XT_Wait.Refresh
            End If
            DoEvents
            .Caption = "资产负债表分析-" & Trim(temRs!gnmc)
            .TsLabel(4).Caption = "资产负债表分析（" & Trim(temRs!gnmc) & "）"
            .intType = mySeachForm.intType '传递查询参数
            '----------------------时间传递-----------------
            .iThisYear = mySeachForm.iThisYear
            .iThisMonthBegin = mySeachForm.iThisMonthBegin
            .iThisMonthEnd = mySeachForm.iThisMonthEnd
            .iCompYear = mySeachForm.iCompYear
            .iCompMonthBegin = mySeachForm.iCompMonthBegin
            .iCompMonthEnd = mySeachForm.iCompMonthEnd
            .bSeach = mySeachForm.bSeach
            .HelpContextID = sHelpID
            
            '------------------------------------------------
            .strItem = strItem
            Call .FormInit
            
            
            
            .Show '并显示窗体
            If DEBUG_FLAG = False Then
                XT_Wait.Hide
                ' .Enabled = True
            End If
        End With
    Else
        Bbfx_FrmBalFx2.bSeach = False
    End If
    '否则（即击“取消”按钮）退出过程
End Sub
Public Sub IncFx(ByVal strItem As String, Optional sHelpID As String)
    '负债表分析
    If DEBUG_FLAG = False Then On Error Resume Next
    Dim mySeachForm1 As New Bbfx_SelDate
    Dim mySeachForm2 As New Bbfx_SelDate2
    Dim temRs As New ADODB.Recordset
    Select Case strItem
    Case "cwfx_IncJds", "cwfx_IncDj", "cwfx_IncHb" '绝对数、定基、环比
        mySeachForm1.Show vbModal
    Case "cwfx_IncDb", "cwfx_IncJg" '对比、结构
        mySeachForm2.Show vbModal
    End Select
    
    If mySeachForm1.bSeach = True Or mySeachForm2.bSeach = True Then
        '-----根据不同参数给不同窗体赋值------------------------
        
        Select Case strItem
        Case "cwfx_IncJds", "cwfx_IncDj", "cwfx_IncHb" '绝对数、定基、环比
            With Bbfx_FrmIncFx
                .iThisYear = mySeachForm1.iThisYear
                .iCompYear = mySeachForm1.iCompYear
                .intType = mySeachForm1.intType
                .iThisMonthBegin = mySeachForm1.iThisMonthBegin
                .iThisMonthEnd = mySeachForm1.iThisMonthEnd
                .strBegin = mySeachForm1.strBegin
                .strEnd = mySeachForm1.strEnd
                .bSeach = mySeachForm1.bSeach
                .HelpContextID = sHelpID
                
            End With
        Case "cwfx_IncDb", "cwfx_IncJg" '对比、结构
            With Bbfx_FrmIncFx
                .iThisYear = mySeachForm2.iThisYear
                .intType = mySeachForm2.intType
                .iThisMonthBegin = mySeachForm2.iThisMonthBegin
                .iThisMonthEnd = mySeachForm2.iThisMonthEnd
                .iCompYear = mySeachForm2.iCompYear
                .iCompMonthBegin = mySeachForm2.iCompMonthBegin
                .iCompMonthEnd = mySeachForm2.iCompMonthEnd
                .bIFComp = mySeachForm2.chk_ComSel.Value
                If .bIFComp = False Then
                    .iCompMonthBegin = 0
                    .iCompMonthEnd = 0
                End If
                If .intType = 1 Then
                    .strBegin = .iThisYear & "." & .iThisMonthBegin & "-" & .iThisYear & "." & .iThisMonthEnd
                    If .bIFComp = True Then
                        .strEnd = .iCompYear & "." & .iCompMonthBegin & "-" & .iCompYear & "." & .iCompMonthEnd
                    Else
                        .strEnd = ""
                    End If
                Else
                    .strBegin = ""
                    .strEnd = ""
                End If
                .bSeach = mySeachForm2.bSeach
                .HelpContextID = sHelpID
            End With
        End Select
        '---------------------------------------------------------
        With Bbfx_FrmIncFx
            If DEBUG_FLAG = False Then
                XT_Wait.Show
                XT_Wait.Refresh
            End If
            DoEvents
            .strItem = strItem
            Set temRs = Cw_DataEnvi.DataConnect.Execute("SELECT gnmc FROM xt_xtgnb where gnsy='" & strItem & "'")
            .Caption = "损益表分析-" & Trim(temRs!gnmc)
            .TsLabel(4).Caption = "损益表分析（" & Trim(temRs!gnmc) & "）"
            
            Call .FormInit
            .Show
            If DEBUG_FLAG = False Then
                XT_Wait.Hide
            End If
            If temRs.State = adStateOpen Then temRs.Close
        End With
    Else
        Bbfx_FrmIncFx.bSeach = False
    End If
End Sub

						