i-+

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

    Else
        c_code(1) = CStr(code2)
    End If
    If IsNull(code3) Then
        c_code(2) = ""
    Else
        c_code(2) = CStr(code3)
    End If
    If IsNull(code4) Then
        c_code(3) = ""
    Else
        c_code(3) = CStr(code4)
    End If
    If IsNull(code5) Then
        c_code(4) = ""
    Else
        c_code(4) = CStr(code5)
    End If
    If IsNull(code6) Then
        c_code(5) = ""
        c_code(6) = ""
    Else
        c_code(5) = CStr(code6)
        c_code(6) = CStr(code7)
    End If
    
    For ia = 1 To 5
        If WKm_Propty(c_code(0), ia) = "" Then
            arco(ia) = RGB(192, 192, 192)
        Else
            arco(ia) = 0
        End If
    Next
    
    If Switch_Mode = AS_CODE Then
        sgdSubject.AddItem c_code(0) & Chr(9) & c_code(1) & Chr(9) & _
                c_code(2) & Chr(9) & c_code(3) & Chr(9) & _
                c_code(4) & Chr(9) & c_code(5) & Chr(9) & _
                c_code(6) & Chr(9) & c_code(0) & Chr(9) & _
                c_code(1) & Chr(9) & c_code(2) & Chr(9) & _
                c_code(3) & Chr(9) & c_code(4) & Chr(9) & c_code(5)
    Else
        sgdSubject.AddItem c_code(0) & Chr(9) & c_code(1) & Chr(9) & _
                c_code(2) & Chr(9) & c_code(3) & Chr(9) & _
                c_code(4) & Chr(9) & c_code(5) & Chr(9) & _
                c_code(6) & Chr(9) & _
                KmCodeToName(c_code(0)) & Chr(9) & _
                DeptCodeToName(c_code(1)) & Chr(9) & _
                PersonCodeToName(c_code(2)) & Chr(9) & _
                CusCodeToName(c_code(3)) & Chr(9) & _
                SupCodeToName(c_code(4)) & Chr(9) & _
                ItemCodeToName(c_code(5), c_code(6))
    End If
    For ia = 1 To 5
        sgdSubject.SetCellBackColor sgdSubject.Rows - 1, ia + 7, arco(ia)
    Next
    
End Sub
'没有账户时工具栏控制
Private Sub SetRsNullTrue()
    tlbAction.Buttons("add").Enabled = False
    tlbAction.Buttons("del").Enabled = False
    tlbAction.Buttons("save").Enabled = False
    tlbAction.Buttons("copy").Enabled = False
    tlbAction.Buttons("paste").Enabled = False
    RsNull = True
    With frmRightMenu
        .mnuS_DelR.Enabled = False
        .mnuS_AddR.Enabled = False
        .mnuS_SaveR.Enabled = False
    End With
    SetTlbStyle Me, False: ocxCtbTool.RefreshEnable
End Sub
'有账户时工具栏控制
Private Sub SetRsNullFalse()
    tlbAction.Buttons("add").Enabled = True
    tlbAction.Buttons("del").Enabled = True
    tlbAction.Buttons("save").Enabled = False
    tlbAction.Buttons("copy").Enabled = True
    RsNull = False
    With frmRightMenu
        .mnuS_DelR.Enabled = True
        .mnuS_AddR.Enabled = True
        .mnuS_SaveR.Enabled = False
    End With
    SetTlbStyle Me, False: ocxCtbTool.RefreshEnable
End Sub
'填superGrid sgdSubject
Private Sub FillSuperGrid()

    Dim SQL As String
    Dim rsl As New UfRecordset
    Dim objAccDefBI  As New U8FDBso.clsAccDefBI
    Dim objDefEO     As U8FDEso.EntityObject
    
    Set objDefEO = objAccDefBI.Init(g_sDataSourceName)
    Set objAccDefBI = Nothing
    
    With lgdAccSubject
        If curAccCode <> "" And .TextMatrix(.Row, 6) = txtAccdef_id.Text Then Exit Sub
        curAccCode = .TextMatrix(.Row, 6)
        txtAccdef_id.Text = .TextMatrix(.Row, 6)
    End With
    sgdSubject.Rows = 1
    'sql = "SELECT fd_accset.cCode, fd_accset.cDeptCode, fd_accset.cPersonCode, fd_accset.cCusCode, fd_accset.cSupCode, fd_accset.citem_id, fd_accset.citem_class, fd_accset.mQc" _
    '      & " From fd_accset" _
    '      & " WHERE (((fd_accset.cAccID)='" & curAccCode & "'))" _
    '      & " Order By cCode"
    SQL = "SELECT 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, fd_accset." & objDefEO.EOS.EOMetaData("item_code").SourceField & " as citem_id, fd_accset." & objDefEO.EOS.EOMetaData("itemclass_code").SourceField & " as citem_class, fd_accset." & objDefEO.EOS.EOMetaData("debcred_flag").SourceField & " as mQc" _
          & " From " & objDefEO.EOS.EOMetaData.SourceTable & " as fd_accset" _
          & " WHERE " & objDefEO.EOS.EOMetaData("type_flag").SourceField & "=0 and (((fd_accset." & objDefEO.EOS.EOMetaData.ParentField & ")='" & curAccCode & "'))" _
          & " Order By " & objDefEO.EOS.EOMetaData("subject_code").SourceField
    Set objDefEO = Nothing
    Set rsl = dbsZJ.OpenRecordset(SQL, dbOpenSnapshot)
    
    With rsl
        If .EOF Then
            Set_rsnull_true
            cboDebCred.Text = cboDebCred.List(0)
            Exit Sub
        Else
            Set_rsnull_false
            cboDebCred.Text = cboDebCred.List(IIf(![mQc] = 0, 0, 1))
        End If
        
        Frtin = True
        While Not .EOF
            sgdSubject_AddItem !cCode, !cdeptcode, !cPersonCode, !cCusCode, !cSupCode, !cItem_id, !citem_class
            .MoveNext
        Wend
        Frtin = False
    End With
    set_edstatus_browse
End Sub

Private Sub Set_rsnull_true()
    tlbAction.Buttons("del").Enabled = False
    frmRightMenu.mnuS_DelR.Enabled = False
    RsNull = True
    SetTlbStyle Me, False: ocxCtbTool.RefreshEnable
End Sub

Private Sub Set_rsnull_false()
    tlbAction.Buttons("del").Enabled = True
    frmRightMenu.mnuS_DelR.Enabled = True
    RsNull = False
    SetTlbStyle Me, False: ocxCtbTool.RefreshEnable
End Sub

Private Sub genadd()

'If edstatus = Child_Add Then Exit Sub
'If edstatus = Child_Add Or edstatus = Child_Edit Then Exit Sub

set_edstatus_add
ReDim ColorArray(12)
Dim i
For i = 0 To 12
  ColorArray(i) = COLOR_WHITE
Next i
With frmAccSet.sgdSubject
  .AddRecord "", ColorArray
End With
End Sub

Private Sub set_edstatus_add()
    edstatus = Child_Add
End Sub

Private Sub set_edstatus_browse()
    tlbAction.Buttons("add").Enabled = True
    tlbAction.Buttons("del").Enabled = True
    frmRightMenu.mnuS_DelR.Enabled = True
    frmRightMenu.mnuS_AddR.Enabled = True
    edstatus = Child_Borwse
    SetTlbStyle Me, False: ocxCtbTool.RefreshEnable
End Sub

Private Sub set_edstatus_edit()
    edstatus = Child_Edit
End Sub

Private Sub GenExit()
    Unload Me
End Sub

Private Sub GenDel()
  
    If sgdSubject.Rows = 1 Then
        MsgBox "没有可删除记录!", vbInformation, zjGl_Name
        Exit Sub
    End If
  
    With frmAccSet
      '  If .sgdSubject.ProtectUnload = dbRetry Then Exit Sub
        If sgdSubject.Rows = 1 Then Exit Sub
        If sgdSubject.TextMatrix(sgdSubject.Row, 0) <> "" Then
            If MsgBox("请确认是否删除此账户科目?", vbQuestion + vbOKCancel, zjGl_Name) = vbCancel Then Exit Sub
        End If
        tlbAction.Buttons("save").Enabled = True
        frmRightMenu.mnuS_SaveR.Enabled = True
        .sgdSubject.RemoveItem .sgdSubject.Row
        If .sgdSubject.Rows = 1 Then
            Set_rsnull_true
        Else
            Set_rsnull_false
        End If
    End With
    set_edstatus_browse
End Sub

Private Sub cboDebCred_Click()
    If sgdSubject.Rows > 1 Then
        tlbAction.Buttons("save").Enabled = True
        frmRightMenu.mnuS_SaveR.Enabled = True
        SetTlbStyle Me, False: ocxCtbTool.RefreshEnable
    End If
End Sub

Public Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
    Select Case KeyCode
        Case vbKeyP     '打印
            If Shift = 2 Then
                Gen_Key "Print"
                KeyCode = 0
            End If
        Case vbKeyS     '预览
            'cuidong 2001.01.15
            'If Shift = 2 Then
            '    Gen_Key "Preview"
            '    KeyCode = 0
            'End If
        Case vbKeyW     '预览
            If Shift = 2 Then
                Gen_Key "Dataout"
                KeyCode = 0
            End If
        Case vbKeyF5
            If Shift = 0 Then
                Gen_Key "add"
            End If
        Case vbKeyY
            If Shift = 2 And tlbAction.Buttons("del").Enabled Then
                Gen_Key "del"
                KeyCode = 0
            End If
        Case vbKeyF6
            If Shift = 0 And tlbAction.Buttons("save").Enabled Then
                Gen_Key "save"
            End If
        Case vbKeyF8
            If Shift = 0 Then
                Gen_Key "switch"
            End If
        Case vbKeyR
            If Shift = 2 Then
                Gen_Key "refresh"
                KeyCode = 0
            End If
        Case vbKeyC
            If Shift = 2 And tlbAction.Buttons("copy").Enabled Then
                Gen_Key "copy"
                KeyCode = 0
            End If
        Case vbKeyV
            If Shift = 2 And tlbAction.Buttons("paste").Enabled Then
                Gen_Key "paste"
                KeyCode = 0
            End If
        Case vbKeyF4
            If Shift = 2 Then
                Gen_Key "exit"
            End If
    End Select
    SetTlbStyle Me, False: ocxCtbTool.RefreshEnable
End Sub

Private Sub Form_Load()
    Screen.MousePointer = vbHourglass
    Me.width = 9300
    Me.Height = 5715
    Me.Icon = LoadResPicture(109, vbResIcon)
    CenterForm Me
    'ImageList_Initialize ilsTlb1
    MSImageList_Initialize ilsTlb
    MSToolBar_Initialize tlbAction, "Print", TB_PRINT
    MSToolBar_Initialize tlbAction, "Preview", TB_PREVIEW
    MSToolBar_Initialize tlbAction, "Export", TB_Export
    MSToolBar_Initialize tlbAction, "add", TB_ADD
    MSToolBar_Initialize tlbAction, "del", TB_DEL
    MSToolBar_Initialize tlbAction, "copy", TB_COPY
    MSToolBar_Initialize tlbAction, "paste", TB_PASTE
    MSToolBar_Initialize tlbAction, "save", TB_Save
    MSToolBar_Initialize tlbAction, "switch", TB_SWITCH
    MSToolBar_Initialize tlbAction, "refresh", TB_Refresh
    MSToolBar_Initialize tlbAction, "help", TB_HELP
    MSToolBar_Initialize tlbAction, "exit", TB_EXIT
    
    SetTlbStyle Me, False
    ocxCtbTool.RefreshEnable
    cboDebCred.AddItem "借方"
    cboDebCred.AddItem "贷方"
    SetPrintDataStyleXML_flag = False
    
    With frmAccSet.lgdAccSubject
        .Cols = 7
        .GrdKeyCol = 1
        .Row = 0
        .col = 0
        .GrdText = "单位名称"
        .ColWidth(0) = 2000
        .ColAlignment(0) = 1
        .FixedAlignment(0) = 4
        .Row = 0
        .col = 1
        .GrdText = "账户号"
        .ColWidth(1) = 2000
        .ColAlignment(1) = 1
        .FixedAlignment(1) = 4
        .Row = 0
        .col = 2
        .GrdText = "账户名"
        .ColWidth(2) = 2500
        .ColAlignment(2) = 1
        .FixedAlignment(2) = 4
        .Row = 0
        .col = 3
        .GrdText = "利率"
        .ColWidth(3) = 830
        .ColAlignment(3) = 1
        .FixedAlignment(3) = 4
        .Row = 0
        .col = 4
        .GrdText = "类型"
        .ColWidth(4) = 465
        .ColAlignment(4) = 4
        .FixedAlignment(4) = 4
        .Row = 0
        .col = 5
        .GrdText = "标志"
        .ColWidth(5) = 465
        .ColAlignment(5) = 4
        .FixedAlignment(5) = 4
        .Row = 0
        .col = 6
        .GrdText = "ID"
        .ColWidth(6) = 0
        .ColAlignment(6) = 4
        .FixedAlignment(6) = 4
        
        .Rows = 2
        .RowHeight(0) = 300
    End With
    
    With frmAccSet.sgdSubject
        .RowHeight(0) = 400
        .Cols = 13
        .FixedCols = 7
        .ColWidth(0) = 0
        .ColWidth(1) = 0
        .ColWidth(2) = 0
        .ColWidth(3) = 0
        .ColWidth(4) = 0
        .ColWidth(5) = 0
        .ColWidth(6) = 0
        .ColWidth(7) = 2025
        .ColWidth(8) = 1815
        .ColWidth(9) = 1815
        .ColWidth(10) = 1815
        .ColWidth(11) = 1815
        .ColWidth(12) = 1815
        .FixedAlignment(7) = 4
        .FixedAlignment(8) = 4
        .FixedAlignment(9) = 4
        .FixedAlignment(10) = 4
        .FixedAlignment(11) = 4
        .FixedAlignment(12) = 4
        .ColAlignment(7) = 1
        .ColAlignment(8) = 1
        .ColAlignment(9) = 1
        .ColAlignment(10) = 1
        .ColAlignment(11) = 1
        .ColAlignment(12) = 1
        
        Switch_Mode = AS_CODE
        SupGrd_Switch Switch_Mode
        Dim i As Long
        For i = 7 To 12
          .SetColProperty i, 20, UserBrowButton, EditStr
        Next i
        .AddDisColor RGB(192, 192, 192)
        
    End With
    load_data
    Screen.MousePointer = vbDefault
    Me.Show
End Sub

Private Sub SupGrd_Switch(mode As SwitchMode)

    With sgdSubject
        If Switch_Mode = AS_CODE Then
            .TextMatrix(0, 7) = "科目编码"
            .TextMatrix(0, 8) = "部门编码"
            .TextMatrix(0, 9) = "个人编码 "
            .TextMatrix(0, 10) = "客户编码"