i-+

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

        
        .TextMatrix(0, 5) = "客户编码"
        .ColAlignment(5) = UG_ALIGNLEFT
        .JoinCells 0, 5, 1, 5, True
        
        .TextMatrix(0, 6) = "供应商编码"
        .ColAlignment(6) = UG_ALIGNLEFT
        .JoinCells 0, 6, 1, 6, True
        
        .TextMatrix(0, 7) = "项目编码"
        .ColAlignment(7) = UG_ALIGNLEFT
        .JoinCells 0, 7, 1, 7, True
                   
        .HeadForeColor = &H404040
        .HeadFont.Name = "宋体"
        .HeadFont.Size = 9
        .HeadFont.Bold = True
    End With
    InitPrnGrid = True
End Function
Private Sub GenRefresh()
    load_data
End Sub

Private Sub GenSwitch()
    Dim i As Long
    
    If Switch_Mode = AS_CODE Then
        Switch_Mode = AS_NAME
    Else
        Switch_Mode = AS_CODE
    End If
    SupGrd_Switch Switch_Mode
    With sgdSubject
        For i = 1 To .Rows - 1
            SwitchRow i
        Next i
    End With
    
End Sub

Private Sub SwitchRow(iRow As Long)
    Dim i As Long
    
    With sgdSubject
        For i = 7 To 12
            If Switch_Mode = AS_CODE Then
                .TextMatrix(iRow, i) = .TextMatrix(iRow, i - 7)
            Else
                .TextMatrix(iRow, i) = CodeToName(i, .TextMatrix(iRow, i), .TextMatrix(iRow, 6))
            End If
        Next i
    End With
End Sub

Public Function CodeToName(iType As Long, code As String, Optional xmdl As String) As String

    Select Case iType
        Case 7
            CodeToName = KmCodeToName(code)
        Case 8
            CodeToName = DeptCodeToName(code)
        Case 9
            CodeToName = PersonCodeToName(code)
        Case 10
            CodeToName = CusCodeToName(code)
        Case 11
            CodeToName = SupCodeToName(code)
        Case 12
            CodeToName = ItemCodeToName(code, xmdl)
    End Select
End Function

Private Function NameToCode(iType As Long, code As String, Optional xmdl As String) As String

    Select Case iType
        Case 7
            NameToCode = KmNameToCode(code)
        Case 8
            NameToCode = DeptNameToCode(code)
        Case 9
            NameToCode = PersonNameToCode(code)
        Case 10
            NameToCode = CusNameToCode(code)
        Case 11
            NameToCode = SupNameToCode(code)
        Case 12
            NameToCode = ItemNameToCode(code, xmdl)
    End Select
End Function

Private Sub GenCopy()
    Dim i As Long
    Dim j As Long
    Dim sRow As Long
    Dim eRow As Long
    Dim code As String
    
    With clpAccSet
        With sgdSubject
            sRow = IIf(.Row <= .RowSel, .Row, .RowSel)
            eRow = IIf(.Row > .RowSel, .Row, .RowSel)
        End With
        .RecNum = eRow - sRow + 1
        For i = sRow To eRow
            For j = 0 To 6
                .ClpArr(i - sRow, j) = sgdSubject.TextMatrix(i, j)
            Next j
        Next i
    End With
    tlbAction.Buttons("paste").Enabled = True
    SetTlbStyle Me, False: ocxCtbTool.RefreshEnable
End Sub

Private Sub GenPaste()
    Dim i As Long, ClashRow As Long
    Dim code0 As String, code1 As String, code2 As String
    Dim code3 As String, code4 As String, code5 As String
    Dim name0 As String, name1 As String, name2 As String
    Dim name3 As String, name4 As String, name5 As String
    Dim NullBuf() As String
    
    With clpAccSet
        If .RecNum = 0 Then Exit Sub
        For i = 0 To .RecNum - 1
            If IsClash(.ClpArr(i, 0), .ClpArr(i, 1), _
                       .ClpArr(i, 2), .ClpArr(i, 3), _
                       .ClpArr(i, 4), .ClpArr(i, 5), .ClpArr(i, 6), -1, ClashRow) Then
                MsgBox "粘贴科目与此账户已有科目冲突，不能粘贴！", vbCritical, zjGl_Name
            Else
                sgdSubject_AddItem .ClpArr(i, 0), .ClpArr(i, 1), _
                           .ClpArr(i, 2), .ClpArr(i, 3), _
                           .ClpArr(i, 4), .ClpArr(i, 5), .ClpArr(i, 6)
            End If
        Next i
    End With
End Sub

Private Sub GenSave()
    Dim objAccDefBI  As New U8FDBso.clsAccDefBI
    Dim objDefEO     As U8FDEso.EntityObject
    Dim Child_EO     As U8FDEso.EntityObject
    Dim objOIDMgr    As New U8FDMgr.OIDManager
    Dim objOID       As New U8FDEso.OIDObject
    Dim ChildBIType  As Long
    
    objOID.id = txtAccdef_id.Text
    Set objDefEO = objAccDefBI.MoveTo(g_sDataSourceName, U8FDEso.esoCurrent, , objOID)
    Set objOID = Nothing
    
    sgdSubject.ProtectUnload
    Dim zhs As Integer, i As Integer, rsAccSet As New UfRecordset
    
    dbsZJ.Execute "Delete from " & objDefEO.EOS.EOMetaData.SourceTable & " where " & objDefEO.EOS.EOMetaData("type_flag").SourceField & "=0 and " & objDefEO.EOS.EOMetaData.ParentField & "='" & txtAccdef_id.Text & "'"

    Set rsAccSet = dbsZJ.OpenRecordset(objDefEO.EOS.EOMetaData.SourceTable, dbOpenDynaset)
    
    ChildBIType = objDefEO.EOS.EOMetaData.BIType
    If objDefEO.EOS.count > 0 Then
        For i = objDefEO.EOS.count To 1 Step -1
            objDefEO.EOS.Delete i
        Next
    End If
    
    With sgdSubject
          zhs = .Rows - 1
          For i = 1 To zhs
            Set Child_EO = objAccDefBI.Init(g_sDataSourceName, ChildBIType)
            objDefEO.EOS.Append Child_EO, str(i)
            
            objDefEO.EOS(i)("accset_id") = objOIDMgr.GetNewOID(g_sDataSourceName, ChildBIType, True)
            objDefEO.EOS(i)("accdef_code") = lgdAccSubject.Text
            objDefEO.EOS(i)("accdef_id") = txtAccdef_id.Text 'objDefEO("accdef_id")
            objDefEO.EOS(i)("type_flag") = 0
            If .TextMatrix(i, 0) <> "" Then objDefEO.EOS(i)("subject_code") = .TextMatrix(i, 0)
            If .TextMatrix(i, 1) <> "" Then objDefEO.EOS(i)("person_code") = .TextMatrix(i, 1)
            If .TextMatrix(i, 2) <> "" Then objDefEO.EOS(i)("department_code") = .TextMatrix(i, 2)
            If .TextMatrix(i, 3) <> "" Then objDefEO.EOS(i)("customer_code") = .TextMatrix(i, 3)
            If .TextMatrix(i, 4) <> "" Then objDefEO.EOS(i)("provider_code") = .TextMatrix(i, 4)
            If .TextMatrix(i, 5) <> "" Then
                objDefEO.EOS(i)("item_code") = .TextMatrix(i, 5)
                objDefEO.EOS(i)("itemclass_code") = .TextMatrix(i, 6)
            End If
            objDefEO.EOS(i)("debcred_flag") = IIf(cboDebCred.Text = cboDebCred.List(0), 0, 1)
            
'            rsAccSet.AddNew
'            rsAccSet!cAccID = lgdAccSubject.Text
'            rsAccSet!cCode = .TextMatrix(i, 0)
'            If .TextMatrix(i, 1) <> "" Then rsAccSet!cdeptcode = .TextMatrix(i, 1)
'            If .TextMatrix(i, 2) <> "" Then rsAccSet!cPersonCode = .TextMatrix(i, 2)
'            If .TextMatrix(i, 3) <> "" Then rsAccSet!cCusCode = .TextMatrix(i, 3)
'            If .TextMatrix(i, 4) <> "" Then rsAccSet!cSupCode = .TextMatrix(i, 4)
'            If .TextMatrix(i, 5) <> "" Then
'                rsAccSet!cItem_id = .TextMatrix(i, 5)
'                rsAccSet!citem_class = .TextMatrix(i, 6)
'            End If
'            rsAccSet!mQc = IIf(cboDebCred.Text = cboDebCred.List(0), 0, 1)
'            rsAccSet.Update
        Next
    End With
    If Not objAccDefBI.Save(g_sDataSourceName, objDefEO) Then MsgBox "保存不成功！"
    Set objOIDMgr = Nothing
    Set Child_EO = Nothing
    Set objAccDefBI = Nothing
    Set objDefEO = Nothing
    rsAccSet.oClose
End Sub

Private Function IsClash(str0 As String, str1 As String, _
                         str2 As String, str3 As String, _
                         str4 As String, str5 As String, str6 As String, _
                         iRow As Long, Optional RetRow As Long) As Boolean
    Dim i As Long
    Dim kmCode As String
    Dim BmCode As String
    Dim GrCode As String
    Dim KhCode As String
    Dim GysCode As String
    Dim Xm_dl As String
    Dim XmCode As String
    
    IsClash = True
    With sgdSubject
        For i = iRow + 1 To .Rows - 1
            'If i <> iRow Then
                kmCode = .TextMatrix(i, 0)
                BmCode = .TextMatrix(i, 1)
                GrCode = .TextMatrix(i, 2)
                KhCode = .TextMatrix(i, 3)
                GysCode = .TextMatrix(i, 4)
                XmCode = .TextMatrix(i, 5)
                Xm_dl = .TextMatrix(i, 6)
                If KmClash(kmCode, BmCode, GrCode, _
                           KhCode, GysCode, XmCode, Xm_dl, _
                           str0, str1, str2, _
                           str3, str4, str5, str6) Then
                    RetRow = i
                    IsClash = True
                    Exit Function
                End If
            'End If
        Next i
    End With
    IsClash = False
End Function

Private Function KmClash(OldKm As String, OldBm As String, _
                         OldGr As String, OldKh As String, _
                         OldGys As String, OldXm As String, Olddl As String, _
                         NewKm As String, NewBm As String, _
                         NewGr As String, NewKh As String, _
                         NewGys As String, NewXm As String, Newdl As String) As Boolean
    Dim i
    If OldKm = "" Or NewKm = "" Then
        KmClash = False
        Exit Function
    End If
    If OldKm Like NewKm & "?*" Then
        KmClash = True
        Exit Function
    End If
    If NewKm Like OldKm & "?*" Then
        KmClash = True
        Exit Function
    End If
    If OldKm = NewKm Then
        If (OldBm = "" Or NewBm = "" Or OldBm = NewBm) And _
           (OldGr = "" Or NewGr = "" Or OldGr = NewGr) And _
           (OldKh = "" Or NewKh = "" Or OldKh = NewKh) And _
           (OldGys = "" Or NewGys = "" Or OldGys = NewGys) And _
           (Olddl = "" Or Newdl = "" Or Olddl = Newdl) And _
           (OldXm = "" Or NewXm = "" Or OldXm = NewXm) Then
            KmClash = True
            Exit Function
        End If
    End If
    KmClash = False
End Function

'Private Sub tlbAction_ButtonClick(ByVal Button As ComctlLib.Button)
'    Gen_Key Button.key
'End Sub
'
'Private Sub tlbAction_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
'    RightMenu Me, Button, frmRightMenu.mnuAccSetR, tlbAction, x, y
'End Sub

Private Sub tlbAction_ButtonClick(ByVal Button As MSComctlLib.Button)
    On Error Resume Next
    Select Case Button.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"
            Unload Me
    End Select
    If UCase(Button.key) <> "EXIT" Then SetTlbStyle Me, False: ocxCtbTool.RefreshEnable
End Sub

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

Private Sub PrintData()
    If SetPrintDataStyleXML_flag = False Then SetPrintDataStyleXML
    frmRightMenu.ocxPrint.DoPrint
End Sub

Private Sub PrintView()
    If SetPrintDataStyleXML_flag = False Then SetPrintDataStyleXML
    frmRightMenu.ocxPrint.PrintPreview
End Sub

Private Sub Export()
    If SetPrintDataStyleXML_flag = False Then SetPrintDataStyleXML
    frmRightMenu.ocxPrint.ExportToFile 0, PrintTypeList, PrintSizeList, "", ""
End Sub

Public Sub SetPrintDataStyleXML()
    Dim lRet        As Long
    Dim sData       As String
    Dim sStyle      As String
    Dim sModuleId   As String
    Dim SQL         As String
    
    On Error GoTo lblHandle
    
    SQL = "SELECT fd_accdef.cAccName as [账户名称],fd_accdef.cAccID as [账户号],fd_accset.cCode as [科目编码],fd_accset.cDeptCode as [部门编码],fd_accset.cPersonCode as [个人编码],fd_accset.cCusCode as [客户编码],fd_accset.cSupCode as [供应商编码],citem_id as [项目编码] from fd_accset as fd_accset INNER JOIN fd_accdef as fd_accdef ON fd_accset.accdef_id=fd_accdef.accdef_id where fd_accset.type_flag=0 order by fd_accset.accdef_id,fd_accset.cCode"
    
    sData = SetPrintDataXML(SQL, "账户取数科目", PrintTypeList, PrintSizeList)
    sStyle = SetPrintStyleXML("")
    sModuleId = "Default"
    
    lRet = frmRightMenu.ocxPrint.SetDataStyleXML(sData, False, sStyle, False, sModuleId)
    If lRet <> 0 Then
        MsgBox "打印数据格式设置失败！", vbInformation, App.ProductName
        SetPrintDataStyleXML_flag = False
    End If
    
    SetPrintDataStyleXML_flag = True
    Exit Sub
lblHandle:
    SetPrintDataStyleXML_flag = False
    MsgBox "打印数据格式设置失败！", vbInformation, App.ProductName
End Sub