i-+

VB财务软件系统下载源代码提供自由下载使用学习

            .TextMatrix(0, 11) = "供应商编码"
            .TextMatrix(0, 12) = "项目编码"
        Else
            .TextMatrix(0, 7) = "科目名称"
            .TextMatrix(0, 8) = "部门名称"
            .TextMatrix(0, 9) = "个人名称"
            .TextMatrix(0, 10) = "客户名称"
            .TextMatrix(0, 11) = "供应商名称"
            .TextMatrix(0, 12) = "项目名称"
        End If
    End With
    
End Sub

Private Sub Form_Resize()
    ResizeCtbTool Me
    ResizeForm Me, sgdSubject, sgdSubject, sgdSubject, FRM_ACCSET_WIDTH, FRM_ACCSET_HEIGHT
End Sub

Private Sub Form_Unload(Cancel As Integer)
    zjLogInfo.TaskExec "FD020204", 0, zjLogInfo.cIYear
    zjLogInfo.ClearError
    zjGen_arr.FD020204 = False
End Sub

Private Sub lgdAccSubject_DataChange()
    FillSuperGrid
End Sub

Private Sub ocxCtbTool_OnCommand(ByVal enumType As prjTBCtrl.ENUM_MENU_OR_BUTTON, ByVal cButtonId As String, ByVal cMenuId As String)
    tlbAction_ButtonClick tlbAction.Buttons(cButtonId)
End Sub

Private Sub sgdSubject_BrowUser(RetValue As String, ByVal R As Long, ByVal C As Long)
    Select Case C
        Case 7
            ShowAssRef iKm, RetValue, Switch_Mode
        Case 8
            ShowAssRef iDepart, RetValue, Switch_Mode
        Case 9
            ShowAssRef iPerson, RetValue, Switch_Mode
        Case 10
            ShowAssRef iCustomer, RetValue, Switch_Mode
        Case 11
            ShowAssRef iVendor, RetValue, Switch_Mode
        Case 12
            Dim lx As String
            lx = WKm_Propty(sgdSubject.TextMatrix(R, 0), 5)
            If lx <> "" Then
                ShowAssRef iItem, RetValue, Switch_Mode, lx
            End If
    End Select
End Sub

Private Sub sgdSubject_CancelRow()
    set_edstatus_browse
End Sub

Private Sub sgdSubject_CellDataCheck(RetValue As String, RetState As MsSuperGrid.OpType, ByVal R As Long, ByVal C As Long)
    If Frtin Then Exit Sub
    Dim ccdd As String
  
    Select Case C
        Case 7
            If RetValue = "" Then
                MsgBox "科目编码不能为空!", vbInformation, zjGl_Name
                RetState = dbRetry
            Else
                ccdd = RetValue
                If Switch_Mode = AS_CODE Then
                    If CodeToName(7, RetValue) = "" Then
                        MsgBox "编码非法！", vbCritical, zjGl_Name
                        RetState = dbRetry
                        sgdSubject.SetFocus
                        Exit Sub
                    End If
                    sgdSubject.TextMatrix(R, 0) = RetValue
                Else
                    ccdd = NameToCode(7, RetValue)
                    If ccdd = "" Then
                        MsgBox "名称非法！", vbCritical, zjGl_Name
                        RetState = dbRetry
                        sgdSubject.SetFocus
                        Exit Sub
                    End If
                    If CodeToName(1, sgdSubject.TextMatrix(R, 0)) <> RetValue Then
                        sgdSubject.TextMatrix(R, 0) = ccdd
                    Else
                        ccdd = sgdSubject.TextMatrix(R, 0)
                    End If
                End If
                Dim arco(5) As Long, ia As Byte
                For ia = 1 To 5
                    If WKm_Propty(ccdd, ia) = "" Then
                        arco(ia) = RGB(192, 192, 192)
                        sgdSubject.TextMatrix(R, ia) = ""
                        sgdSubject.TextMatrix(R, ia + 7) = ""
                        If ia = 5 Then
                            sgdSubject.TextMatrix(R, 6) = ""
                        End If
                    Else
                        arco(ia) = 0
                    End If
                Next
                For ia = 1 To 5
                    sgdSubject.SetCellBackColor R, ia + 7, arco(ia)
                Next
                tlbAction.Buttons("del").Enabled = True
                tlbAction.Buttons("copy").Enabled = True
                frmRightMenu.mnuS_DelR.Enabled = True
                
            End If
        Case Else
            If RetValue = "" Then
                sgdSubject.TextMatrix(R, C - 7) = ""
                If C = 12 Then
                    sgdSubject.TextMatrix(R, 6) = ""
                End If
                Exit Sub
            End If
            Dim kmxmdl As String
            kmxmdl = WKm_Propty(sgdSubject.TextMatrix(R, 0), 5)
            If Switch_Mode = AS_CODE Then
                If CodeToName(C, RetValue, kmxmdl) = "" Then
                    MsgBox "编码非法！", vbCritical, zjGl_Name
                    RetState = dbRetry
                Else
                    sgdSubject.TextMatrix(R, C - 7) = RetValue
                    If C = 12 Then
                        sgdSubject.TextMatrix(R, 6) = kmxmdl
                    End If
                End If
            Else
                ccdd = NameToCode(C, RetValue, kmxmdl)
                If ccdd = "" Then
                    MsgBox "名称非法！", vbCritical, zjGl_Name
                    RetState = dbRetry
                Else
                    sgdSubject.TextMatrix(R, C - 7) = ccdd
                    If C = 12 Then
                        sgdSubject.TextMatrix(R, 6) = kmxmdl
                    End If
                End If
            End If
    End Select
    sgdSubject.SetFocus
    SetTlbStyle Me, False: ocxCtbTool.RefreshEnable
End Sub

Private Function CellDataCheck(iRow As Long, iCol As Long) As Boolean
  
    CellDataCheck = False
    If Switch_Mode = AS_CODE Then
        If CodeToName(iCol, sgdSubject.TextMatrix(iRow, iCol), sgdSubject.TextMatrix(iRow, 6)) = "" Then
            MsgBox "编码非法！", vbCritical, zjGl_Name
            Exit Function
        End If
    Else
        If NameToCode(iCol, sgdSubject.TextMatrix(iRow, iCol), sgdSubject.TextMatrix(iRow, 6)) = "" Then
            MsgBox "名称非法！", vbCritical, zjGl_Name
            Exit Function
        End If
    End If
    CellDataCheck = True
End Function

Private Sub sgdSubject_LostFocus()
    sgdSubject.ProtectUnload
End Sub

Private Sub sgdSubject_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    RightMenu Me, Button, frmRightMenu.mnuAccSetR, sgdSubject, x, y
End Sub

Private Sub sgdSubject_OnEdit(Editing As Boolean)
    If edstatus = Child_Borwse Then set_edstatus_edit
    tlbAction.Buttons("save").Enabled = True
    frmRightMenu.mnuS_SaveR.Enabled = True
    SetTlbStyle Me, False: ocxCtbTool.RefreshEnable
End Sub

'Private Sub sgdSubject_RowColChange()
'    With sgdSubject
'        If Abs(.Col - .ColSel) <> 5 Then
'            With tlbAction
'                .Buttons("copy").Enabled = False
'            End With
'        End If
'    End With
'End Sub

Private Sub sgdSubject_RowDataCheck(RetState As MsSuperGrid.OpType, ByVal R As Long, iCol As Long)
    Dim i As Long
    For i = 7 To 12
        If i = 7 Or sgdSubject.TextMatrix(R, i) <> "" Then
            If Not CellDataCheck(R, i) Then
                iCol = i
                RetState = dbRetry
            Exit Sub
            End If
        End If
    Next i
    
    With sgdSubject
        If IsClash(.TextMatrix(R, 0), .TextMatrix(R, 1), _
               .TextMatrix(R, 2), .TextMatrix(R, 3), _
               .TextMatrix(R, 4), .TextMatrix(R, 5), .TextMatrix(R, 6), R) Then
            MsgBox "此账户已有相同的科目设置,请修改!", vbInformation, zjGl_Name
            iCol = 7
            RetState = dbRetry
        End If
    End With
    set_edstatus_browse
End Sub

'Private Sub sgdSubject_SelChange()
'    With sgdSubject
'        If Abs(.Col - .ColSel) = 5 Then
'            tlbAction.Buttons("copy").Enabled = True
'        End If
'    End With
'End Sub

Private Sub sgdSubject_UpdateData(ByVal IsNew As Boolean, ByVal R As Long, Buffer() As String)
    set_edstatus_browse
End Sub


Public Sub Gen_Key(TLB_Key As String)
    On Error Resume Next
    Select Case TLB_Key
        Case "Print"
            PrintData
        Case "Preview"
            PrintView
        Case "Export"
            Export
'        Case "Print", "Preview", "Dataout"
'            'If tlbAction.Buttons("save").Enabled Then Exit Sub
'            If Not InitPrnGrid Then Exit Sub
'            Print_Doc Me, TLB_Key, TAB_ACCSET
        Case "add"
            If edstatus <> Child_Add And edstatus <> Child_Edit Then
                genadd
                tlbAction.Buttons("save").Enabled = True
                tlbAction.Buttons("del").Enabled = True
            
                frmRightMenu.mnuS_SaveR.Enabled = True
            ElseIf Zhkmhf Then
                genadd
                tlbAction.Buttons("save").Enabled = True
                tlbAction.Buttons("del").Enabled = True
            
                frmRightMenu.mnuS_SaveR.Enabled = True
            End If
            frmRightMenu.mnuS_DelR.Enabled = tlbAction.Buttons("del").Enabled
            tlbAction.Buttons("switch").Enabled = False
            
        Case "del"
            Frtin = True
            GenDel
            Frtin = False
            If sgdSubject.Rows = 1 Then
                tlbAction.Buttons("del").Enabled = False
            Else
                tlbAction.Buttons("del").Enabled = True
            End If
            frmRightMenu.mnuS_DelR.Enabled = tlbAction.Buttons("del").Enabled
        Case "save"
            If Zhkmhf Then
                GenSave
                tlbAction.Buttons("save").Enabled = False
                frmRightMenu.mnuS_SaveR.Enabled = False
                set_edstatus_browse
                tlbAction.Buttons("switch").Enabled = True
                
            End If
        Case "copy"
            GenCopy
        Case "paste"
            GenPaste
            tlbAction.Buttons("save").Enabled = True
            frmRightMenu.mnuS_SaveR.Enabled = True
        Case "switch"
            GenSwitch
        Case "refresh"
            GenRefresh
            tlbAction.Buttons("switch").Enabled = True
            frmRightMenu.mnuS_RefreshR.Enabled = True
        Case "help"
            SendKeys "{F1 3}"
        Case "exit"
            GenExit
    End Select
    SetTlbStyle Me, False: ocxCtbTool.RefreshEnable
End Sub

Public Function Zhkmhf() As Boolean
    Dim zhs As Integer, ia As Long, ib As Long ', kmfx As Boolean
    Dim RetState As MsSuperGrid.OpType

    With sgdSubject
        zhs = .Rows - 1
        For ia = 1 To zhs
            For ib = 7 To 12
                sgdSubject_CellDataCheck .TextMatrix(ia, ib), RetState, ia, ib
                If RetState = dbRetry Then
                    Exit Function
                End If
            Next
        Next
        For ia = 1 To zhs
            If IsClash(.TextMatrix(ia, 0), .TextMatrix(ia, 1), _
               .TextMatrix(ia, 2), .TextMatrix(ia, 3), _
               .TextMatrix(ia, 4), .TextMatrix(ia, 5), .TextMatrix(ia, 6), ia) Then
                MsgBox "此账户已有相同的科目设置,请修改!", vbInformation, zjGl_Name
                Exit Function
            End If
        Next
'        If zhs > 0 Then
'            kmfx = Getkmfx(.TextMatrix(1, 0))
'            For ia = 2 To zhs
'                If kmfx <> Getkmfx(.TextMatrix(ia, 0)) Then
'                    MsgBox "账户下所有科目的余额方向必须相同！", vbInformation, zjGl_Name
'                    Exit Function
'                End If
'            Next
'        End If
    End With
    Zhkmhf = True
End Function

            
Public Function InitPrnGrid() As Boolean
    InitPrnGrid = False
    With frmRightMenu.GrdPrn
        frmRightMenu.TabFlg = TAB_ACCSET
        .Redraw = False
        .Cols = 8
        .FixedCols = 0
        .ColWidth(0) = 2205
        .ColWidth(1) = 2205
        .ColWidth(2) = sgdSubject.ColWidth(7)
        .ColWidth(3) = sgdSubject.ColWidth(8)
        .ColWidth(4) = sgdSubject.ColWidth(9)
        .ColWidth(5) = sgdSubject.ColWidth(10)
        .ColWidth(6) = sgdSubject.ColWidth(11)
        .ColWidth(7) = sgdSubject.ColWidth(12)
          
        Dim vt As Variant
        Dim rsl As New UfRecordset
        Dim SQL As String
        Dim objAccDefBI  As New U8FDBso.clsAccDefBI
        Dim objDefEO     As U8FDEso.EntityObject
        
        Set objDefEO = objAccDefBI.Init(g_sDataSourceName)
        Set objAccDefBI = Nothing

        'sql = "Select fd_accdef.cAccName,fd_accdef.cAccID,ccode,cDeptCode,cPersonCode,cCusCode,cSupCode," & IIf(Me.Switch_Mode = AS_NAME, "citem_class & ", "") & "citem_id as zd1 " & _
              "from fd_accset INNER JOIN fd_accdef ON fd_accset.cAccid = fd_accdef.cAccid order by fd_accset.cAccid,fd_accset.ccode" 'cuidong 2001.02.13
        'sql = "Select fd_accdef.cAccName,fd_accdef.cAccID,ccode,cDeptCode,cPersonCode,cCusCode,cSupCode," & IIf(Me.Switch_Mode = AS_NAME, "citem_class + ", "") & "citem_id as zd1 " & _
              "from fd_accset INNER JOIN fd_accdef ON fd_accset.cAccid = fd_accdef.cAccid order by fd_accset.cAccid,fd_accset.ccode" 'cuidong 2001.02.13
        
        SQL = "SELECT fd_accdef." & objDefEO("accdef_name").SourceField & " as cAccName,fd_accdef." & objDefEO("accdef_code").SourceField & " as cAccID,fd_accset." & objDefEO.EOS.EOMetaData("subject_code").SourceField & " as cCode,fd_accset." & objDefEO.EOS.EOMetaData("department_code").SourceField & " as cDeptCode,fd_accset." & objDefEO.EOS.EOMetaData("person_code").SourceField & " as cPersonCode,fd_accset." & objDefEO.EOS.EOMetaData("customer_code").SourceField & " as cCusCode,fd_accset." & objDefEO.EOS.EOMetaData("provider_code").SourceField & " as cSupCode,"
        If Me.Switch_Mode = AS_NAME Then
            SQL = SQL & objDefEO.EOS.EOMetaData("itemclass_code").SourceField & " + " & objDefEO.EOS.EOMetaData("item_code").SourceField & " as zd1 "
        Else
            SQL = SQL & objDefEO.EOS.EOMetaData("item_code").SourceField & " as zd1 "
        End If
        SQL = SQL & "from " & objDefEO.EOS.EOMetaData.SourceTable & " as fd_accset" & " INNER JOIN " & objDefEO.SourceTable & " as fd_accdef ON fd_accset." & objDefEO.EOS.EOMetaData.ParentField & "=" & "fd_accdef." & objDefEO.SourceOIDField & " where " & objDefEO.EOS.EOMetaData.SourceTable & "." & objDefEO.EOS.EOMetaData("type_flag").SourceField & "=0 order by fd_accset." & objDefEO.EOS.EOMetaData.ParentField & ",fd_accset." & objDefEO.EOS.EOMetaData("subject_code").SourceField
        Set objDefEO = Nothing
        
        Set rsl = dbsZJ.OpenRecordset(SQL, dbOpenSnapshot)
        If rsl.EOF Then
            MsgBox "没有打印数据!", vbCritical, zjGl_Name
            Exit Function
        Else
            rsl.MoveLast
            rsl.MoveFirst
        End If
        Set vt = rsl.Recordset
        .Rows = 2
        .FixedRows = 2
        .BindRecordSet vt, False, True, True
        CloseRS rsl
        
        '初始化表头及对齐方式
        .TextMatrix(0, 0) = "账户名称"
        .ColAlignment(0) = UG_ALIGNLEFT
        .JoinCells 0, 0, 1, 0, True
        
        .TextMatrix(0, 1) = "账户号"
        .ColAlignment(1) = UG_ALIGNLEFT
        .JoinCells 0, 1, 1, 1, True
        
        .TextMatrix(0, 2) = "科目编码"
        .ColAlignment(2) = UG_ALIGNLEFT
        .JoinCells 0, 2, 1, 2, True
        
        .TextMatrix(0, 3) = "部门编码"
        .ColAlignment(3) = UG_ALIGNLEFT
        .JoinCells 0, 3, 1, 3, True
                    
        .TextMatrix(0, 4) = "个人编码 "
        .ColAlignment(4) = UG_ALIGNLEFT
        .JoinCells 0, 4, 1, 4, True