结算价格.frm

用友u8财务源码,用visual basic开发

    Else
        lblSettleType(2).Caption = "单价"
        lblSettleType(3).Caption = "备注"
        lblSettleType(4).Visible = False
        txtSettleType(1).Visible = False
        txtSettleType(2).left = txtSettleType(1).left
        txtSettleType(2).top = txtSettleType(1).top
    End If
End Sub

Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
    On Error GoTo ErrHandler
    Dim ShiftDown, AltDown, CtrlDown
    ShiftDown = (Shift And vbShiftMask) > 0
    AltDown = (Shift And vbAltMask) > 0
    CtrlDown = (Shift And vbCtrlMask) > 0
    
    Select Case KeyCode
        Case vbKeyF1
            SendKeys "{F1 3}"
        Case vbKeyF5
            If Me.tlbAction.Buttons("AddNew").Enabled Then
                'AddNew
            End If
        Case vbKeyF8
            If Me.tlbAction.Buttons("Edit").Enabled Then
                Edit
            End If
        Case vbKeyDelete
            If Me.tlbAction.Buttons("Delete").Enabled Then
                'Delete
            End If
        Case vbKeyF6
            If Me.tlbAction.Buttons("Save").Enabled Then
                Save
            End If
        Case vbKeyZ
            If CtrlDown And Me.tlbAction.Buttons("Cancel").Enabled Then
                CancelDo
            End If
        Case vbKeyI
            If CtrlDown And Me.tlbAction.Buttons("AddCol").Enabled Then
                m_EditCol = 1
                AddCol
            End If
        Case vbKeyD
            If CtrlDown And Me.tlbAction.Buttons("DelCol").Enabled Then
                m_EditCol = 2
                DeleteCol
            End If
        Case vbKeyP
            If CtrlDown And Me.tlbAction.Buttons("Print").Enabled Then
                If Not InitPrnGrid Then Exit Sub
                Print_Doc Me, "Print", TAB_CADSET
            End If
        Case vbKeyF4
            If CtrlDown Then
                Unload Me
            End If
    End Select
ErrHandler:
    Exit Sub
End Sub

Public Sub Gen_Key(TLB_Key As String)
    On Error Resume Next
    Select Case TLB_Key
        Case "Print", "Preview", "Dataout"
            If Not InitPrnGrid Then Exit Sub
            Print_Doc Me, TLB_Key, TAB_CADSET
    End Select
End Sub

Private Sub Form_Load()
    Dim objSettlePriceBI As New U8FDBso.clsSettlePriceBI
    Dim objDataMgr       As New U8FDMgr.DataManager
    Dim con              As New adodb.Connection
    Dim rec              As New adodb.Recordset
    Dim SQL              As String
    Dim arrCurr          As Variant
    Dim i                As Integer
    
    MSImageList_Initialize ilsTlb
    MSToolBar_Initialize tlbAction, "Print", TB_PRINT
    MSToolBar_Initialize tlbAction, "Preview", TB_PREVIEW
    MSToolBar_Initialize tlbAction, "Export", TB_Export
    MSToolBar_Initialize tlbAction, "AddNew", TB_AddNew
    MSToolBar_Initialize tlbAction, "Edit", TB_Edit
    MSToolBar_Initialize tlbAction, "Delete", TB_Delete
    MSToolBar_Initialize tlbAction, "Save", TB_Save
    MSToolBar_Initialize tlbAction, "Cancel", TB_Cancel
    MSToolBar_Initialize tlbAction, "Refresh", TB_Refresh
    MSToolBar_Initialize tlbAction, "AddCol", TB_AddCol
    MSToolBar_Initialize tlbAction, "DelCol", TB_DelCol
    MSToolBar_Initialize tlbAction, "Help", TB_HELP
    MSToolBar_Initialize tlbAction, "Exit", TB_EXIT
    SetPrintDataStyleXML_flag = False
    
    Me.jkrTree.width = 100
    m_EditCol = 3
    
    Me.treStyle.LineStyle = tvwRootLines
    Me.treStyle.Style = tvwTreelinesPlusMinusPictureText
    Me.treStyle.LabelEdit = tvwManual
    Me.treStyle.Indentation = 300
    
    txt2Top = Me.txtSettleType(2).top
    txt2Left = Me.txtSettleType(2).left
    Me.Charge(1).Value = True
    Charge_Click 1
    Me.cboMoneyName.clear
    arrCurr = GetAllCurrencyNames
    For i = 0 To UBound(arrCurr) - 1
        Me.cboMoneyName.AddItem arrCurr(i)
    Next
    If cboMoneyName.ListCount > 0 Then cboMoneyName.ListIndex = 0
    
    con.Open g_sDataSourceName

    SQL = "select * from SettleStyle order by cSSCode"
    rec.Open SQL, con, adOpenStatic, adLockOptimistic

    If Not rec.EOF Then
        Do Until rec.EOF
            If Len(Trim(rec("cSSCode"))) = 1 Then
                Me.treStyle.Nodes.Add , , "K" & Trim(rec("cSSCode")), "【" & Trim(rec("cSSCode")) & "】" & Trim(rec("cSSName"))
                NodeKey = "K" & Trim(rec("cSSCode"))
                Set EO = objSettlePriceBI.FindByCode(g_sDataSourceName, mID(NodeKey, 2))
                For i = 1 To EO.EOS.count
                    Me.treStyle.Nodes.Add NodeKey, tvwChild, "K" & EO.EOS(i)("settle_b_id"), EO.EOS(i)("money_name")
                Next
            Else
                Me.treStyle.Nodes.Add "K" & mID(Trim(rec("cSSCode")), 1, 1), tvwChild, "K" & Trim(rec("cSSCode")), "【" & Trim(rec("cSSCode")) & "】" & Trim(rec("cSSName"))
                NodeKey = "K" & Trim(rec("cSSCode"))
                Set EO = objSettlePriceBI.FindByCode(g_sDataSourceName, mID(NodeKey, 2))
                For i = 1 To EO.EOS.count
                    Me.treStyle.Nodes.Add NodeKey, tvwChild, "K" & EO.EOS(i)("settle_b_id"), EO.EOS(i)("money_name")
                Next
            End If
            rec.MoveNext
        Loop
    Else
        MsgBox "请先在系统控制台设置结算方式!", vbInformation, App.ProductName
        NodeKey = "K"
    End If
    
    For i = 1 To treStyle.Nodes.count
        If treStyle.Nodes(i).children > 0 Then
            treStyle.Nodes(i).Image = 1
        Else
            treStyle.Nodes(i).Image = 3
        End If
    Next
    
    If Me.treStyle.Nodes.count > 0 Then
        Me.treStyle.Nodes(1).Selected = True
        Me.treStyle.Nodes(1).Expanded = True
        NodeKey = Me.treStyle.SelectedItem.key
        Set EO = objSettlePriceBI.FindByCode(g_sDataSourceName, mID(NodeKey, 2))
        If Me.treStyle.Nodes(1).children > 0 Then
            Me.treStyle.Nodes(1).Image = 2
            Me.treStyle.Nodes(1).child.Selected = True
            NodeKey = Me.treStyle.Nodes(1).child.key
        End If
    Else
        Set EO = objDataMgr.LoadEOMetaData(g_sDataSourceName, m_conBIStyle)
    End If
    
    SetUI
    
    Set objSettlePriceBI = Nothing
    Set objDataMgr = Nothing
    Set rec = Nothing
    Set con = Nothing
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    On Error GoTo lblHandle
    Dim iAnswer As VbMsgBoxResult
    If EO.State = U8FDEso.esoEdit Or EO.State = U8FDEso.esoAddNew Then
        iAnswer = MsgBox("还有尚未保存的数据，保存吗？", vbQuestion + vbYesNoCancel)
        If iAnswer = vbNo Then
            m_EditStatus = False
            If m_EO.State = U8FDEso.esoEdit Then CancelDo
            m_EditStatus = True
            Unload Me
        ElseIf iAnswer = vbYes Then
            Save
            Unload Me
        Else
            Cancel = 1
        End If
    Else
        Unload Me
    End If
    Exit Sub
lblHandle:
    MsgBox Err.Description, vbInformation, g_conSysName
    Cancel = True
End Sub

Private Sub Form_Resize()
    On Error Resume Next
    Me.jkrTree.maxLeft = Me.ScaleWidth - conMoveLimit
    Me.jkrTree.minLeft = conMoveLimit

    Me.treStyle.Move 0, Me.tlbAction.Height, Me.jkrTree.left, Me.ScaleHeight - Me.tlbAction.Height
    Me.jkrTree.Move Me.jkrTree.left, Me.tlbAction.Height, 50, Me.ScaleHeight
    Me.picView.Move Me.jkrTree.left + 50, Me.tlbAction.Height, Me.ScaleWidth - Me.jkrTree.left - 50, Me.ScaleHeight - Me.tlbAction.Height
    ResizeCtbTool Me, picView, treStyle, jkrTree
    On Error GoTo 0
End Sub

Private Sub jkrTree_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    Me.jkrTree.ZOrder 0
End Sub

Private Sub jkrTree_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Me.jkrTree.left < conMoveLimit Then
        Me.jkrTree.left = conMoveLimit
    ElseIf Me.jkrTree.left > Me.ScaleWidth - conMoveLimit Then
        Me.jkrTree.left = Me.ScaleWidth - conMoveLimit
    End If

    Me.treStyle.width = Me.jkrTree.left
    Me.picView.left = Me.jkrTree.left + 50
    Me.picView.width = Me.ScaleWidth - Me.treStyle.width - 50
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 tlbAction_ButtonClick(ByVal Button As MSComctlLib.Button)
    Select Case Button.key
        Case "Print"
            PrintData
        Case "Preview"
            PrintView
        Case "Export"
            Export
'        Case "Print", "Preview", "Export"
'            If Not InitPrnGrid Then Exit Sub
'            Print_Doc Me, Button.key, TAB_CADSET
        Case "AddNew"
            AddNew
        Case "Edit"
            m_EditCol = 0
            Edit
        Case "Delete"
            Delete
        Case "Save"
            Save
        Case "Cancel"
            CancelDo
        Case "Refresh"
            RefreshUI
        Case "AddCol"
            m_EditCol = 1
            AddCol
        Case "DelCol"
            m_EditCol = 2
            DeleteCol
        Case "Help"
            SendKeys "{F1 3}"
        Case "Exit"
            Unload Me
    End Select
End Sub

Private Function InitPrnGrid() As Boolean
    InitPrnGrid = False
    With frmRightMenu.GrdPrn
        frmRightMenu.TabFlg = TAB_ACCDEF
        .Redraw = False
        .Cols = 7
        .FixedCols = 0
        .ColWidth(0) = 1000
        .ColWidth(1) = 1600
        .ColWidth(2) = 1600
        .ColWidth(3) = 600
        .ColWidth(4) = 1000
        .ColWidth(5) = 1000
        .ColWidth(6) = 1900

        Dim vt As Variant
        Dim rsl As New UfRecordset
        Dim SQL As String
        'SQL = "select " & EO("settle_code").SourceField & "," & "SettleStyle.cSSName" & ",'" & Charge(1).Caption & "'," & EO("unitprice_mny").SourceField & "," & EO("money_name").SourceField & "," & EO("limit_mny").SourceField & "," & EO("digest").SourceField & " from " & EO.SourceTable & "," & "SettleStyle" & " where " & EO.SourceTable & "." & EO("settle_code").SourceField & "=" & "SettleStyle" & ".cSSCode" & " and fd_settle.charge_flag=1"
        'SQL = SQL & " union " & "select " & EO("settle_code").SourceField & "," & "SettleStyle.cSSName" & ",'" & Charge(0).Caption & "'," & EO("unitprice_mny").SourceField & "," & EO("money_name").SourceField & "," & EO("limit_mny").SourceField & "," & EO("digest").SourceField & " from " & EO.SourceTable & "," & "SettleStyle" & " where " & EO.SourceTable & "." & EO("settle_code").SourceField & "=" & "SettleStyle" & ".cSSCode" & " and fd_settle.charge_flag=0" & " order by " & EO("settle_code").SourceField
        SQL = "select fd_settle.settle_code,SettleStyle.cSSName,case fd_settle.charge_flag when 0 then '结算笔数' when 1 then '计提比例' end as charge_flag,fd_settle_b.money_name,fd_settle_b.unitprice_mny,fd_settle_b.limit_mny,fd_settle_b.digest from fd_settle_b left join fd_settle on fd_settle_b.settle_id=fd_settle.settle_id  left join settlestyle on fd_settle.settle_code=settlestyle.csscode"
        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_ALIGNRIGHT
        .JoinCells 0, 3, 1, 3, True

        .TextMatrix(0, 4) = "单价"
        .ColAlignment(4) = UG_ALIGNRIGHT
        .JoinCells 0, 4, 1, 4, True

        .TextMatrix(0, 5) = "计提基线"
        .ColAlignment(5) = UG_ALIGNRIGHT
        .JoinCells 0, 5, 1, 5, True

        .TextMatrix(0, 6) = "备注"
        .ColAlignment(6) = UG_ALIGNLEFT
        .JoinCells 0, 6, 1, 6, True

        .HeadForeColor = &H404040
        .HeadFont.Name = "宋体"
        .HeadFont.Size = 9
        .HeadFont.Bold = True
    End With
    InitPrnGrid = True
End Function

Private Sub treStyle_Collapse(ByVal Node As MSComctlLib.Node)
    Node.Image = 1
End Sub

Private Sub treStyle_Expand(ByVal Node As MSComctlLib.Node)
    Node.Image = 2
End Sub

Private Sub treStyle_NodeClick(ByVal Node As MSComctlLib.Node)
    Dim iAnswer As Long
    Dim objSettlePriceBI As New U8FDBso.clsSettlePriceBI
    Dim objOID           As New U8FDEso.OIDObject
    
    If IsNumeric(mID(Node.key, 2)) Then
        If NodeKey <> Node.key Then
            If Me.picView.Enabled = True Then
                iAnswer = MsgBox("放弃当前工作吗?", vbQuestion + vbYesNo)
                If iAnswer = vbNo Then
                    Me.treStyle.Nodes(NodeKey).Selected = True
                    Me.picView.SetFocus
                    Exit Sub
                Else
                    m_EditStatus = False
                    CancelDo
                    Me.picView.Enabled = False
                End If
            End If

            NodeKey = Node.key
            
            If Len(NodeKey) < 15 Then
                Set m_EO = objSettlePriceBI.FindByCode(g_sDataSourceName, mID(NodeKey, 2))
            Else
                Set m_EO = objSettlePriceBI.FindByCode(g_sDataSourceName, mID(Node.Parent.key, 2))
            End If
            
            Set objSettlePriceBI = Nothing
            Set objOID = Nothing
            SetUI
        End If
    End If
End Sub