+

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

Dim minleft As Single, maxleft As Single


Private Sub cmdOK_Click()
   On Error GoTo okErr 'zycEdit
            clsUnit.save_change
    Exit Sub
okErr:
     MsgBox "编码冲突，或有其他工作站正在保存，请重试！", vbCritical, zjGl_Name
End Sub

Private Sub cobtype_KeyUp(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyReturn Then
        txt(0).SetFocus
    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 vbKeyF
            If Shift = 2 Then
                Gen_Key "find"
                KeyCode = 0
            End If
        Case vbKeyI
            If Shift = 2 Then
                Gen_Key "import"
                KeyCode = 0
            End If
        Case vbKeyF5    '增加时间段
            If Shift = 0 Then
                Gen_Key "add"
            End If
        Case vbKeyY
            If Shift = 2 And tlb_dwdy.Buttons("del").Enabled Then
                Gen_Key "del"
                KeyCode = 0
            End If
        Case vbKeyR    '刷新
            If Shift = 2 Then
                Gen_Key "refresh"
                KeyCode = 0
            End If
        Case vbKeyF4    '退出
            If Shift = 2 Then
                Gen_Key "exit"
            End If
    End Select
End Sub

Private Sub Form_Load()
    Screen.MousePointer = vbHourglass
    Me.Width = 9060
    Me.Height = 4800
    CenterForm Me
    Me.Icon = LoadResPicture(109, vbResIcon)
    ImageList_Initialize ImageList1
    ToolBar_Initialize tlb_dwdy, "Print", TB_PRINT
    ToolBar_Initialize tlb_dwdy, "Preview", TB_PREVIEW
    ToolBar_Initialize tlb_dwdy, "Dataout", TB_DATAOUT
    ToolBar_Initialize tlb_dwdy, "add", TB_ADD
    ToolBar_Initialize tlb_dwdy, "del", TB_DEL
    ToolBar_Initialize tlb_dwdy, "refresh", TB_REFRESH
    ToolBar_Initialize tlb_dwdy, "import", TB_IMPORT
    ToolBar_Initialize tlb_dwdy, "find", TB_FIND
    ToolBar_Initialize tlb_dwdy, "help", TB_HELP
    ToolBar_Initialize tlb_dwdy, "exit", TB_EXIT
    cmdOK.Picture = LoadResPicture(103, vbResBitmap)
    cobtype.AddItem "个人"
    cobtype.AddItem "部门"
    cobtype.AddItem "银行"
    cobtype.AddItem "客户"
    cobtype.AddItem "供应商"
    cobtype.AddItem "项目"
    cobtype.ListIndex = 0
    clsUnit.load_data
    Screen.MousePointer = vbDefault
    Me.Show
End Sub


Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
RightMenu Me, Button, frmRightMenu.mnuAccUnitR, Me, X, Y
End Sub

Private Sub Form_Resize()
    ResizeForm Me, Me.tvEnt, Picture1, Resize, FRM_ENTDEF_WIDTH, FRM_ENTDEF_HEIGHT
    minleft = Width * 0.05
    maxleft = Width * 0.95
End Sub

Private Sub Form_Unload(Cancel As Integer)
    On Error Resume Next
  
    Set clsUnit = Nothing
    zjLogInfo.TaskExec "FD0102", 0, zjLogInfo.cIYear
    zjLogInfo.ClearError
    zjGen_arr.FD0102 = False
End Sub

Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RightMenu Me, Button, frmRightMenu.mnuAccUnitR, Picture1, X, Y
End Sub

Private Sub Resize_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = vbLeftButton Then
        drag = True
        startx = Resize.Left
    End If
End Sub

Private Sub Resize_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If drag Then
        If X + Resize.Left > maxleft Or X + Resize.Left < minleft Then Exit Sub
        Resize.Move X + Resize.Left
    End If
End Sub

Private Sub Resize_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = vbLeftButton Then
        drag = False
        endx = Resize.Left
        tvEnt.Width = tvEnt.Width + endx - startx
        Picture1.Left = Picture1.Left - startx + endx
        Picture1.Width = Picture1.Width + startx - endx
    End If
End Sub

Private Sub tlb_dwdy_ButtonClick(ByVal Button As ComctlLib.Button)
    Gen_Key Button.key
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_UNITDEF
        Case "add"
            clsUnit.genadd
        Case "del"
            clsUnit.GenDel
        Case "find"
            frmEntDefSer.Show 1
        Case "refresh"
            clsUnit.load_data
        Case "import"
            clsUnit.GenImport
        Case "help"
            SendKeys "{F1}"
        Case "exit"
            clsUnit.GenExit
    End Select
End Sub

Private Function InitPrnGrid() As Boolean
    InitPrnGrid = False
    With frmRightMenu.GrdPrn
        frmRightMenu.TabFlg = TAB_UNITDEF
        .Redraw = False
        .Cols = 4
        .FixedCols = 0
        .ColWidth(0) = 2000
        .ColWidth(1) = 5000
        .ColWidth(2) = 800
        .ColWidth(3) = 3000
        
        Dim vt As Variant
        Dim rsl As New UfRecordset
        Dim sql As String
        
'        sql = "Select cUnitCode, cUnitName, iType as zd1, cMark " & _
              "From FD_AccUnit " & _
              "order by iType, cUnitCode" 'cuidong 2001.02.13
        sql = "Select cUnitCode, cUnitName, " & _
              "(Case When iType=0 Then '个人' Else " & _
                "(Case When iType=1 Then '部门' Else " & _
                  "(Case When iType=2 Then '银行' Else " & _
                    "(Case When iType=3 Then '客户' Else " & _
                      "(Case When iType=4 Then '供应商' Else '项目' END)" & _
                    " END)" & _
                  " END)" & _
                " END)" & _
              " END)" & _
              " As TypeName, cMark " & _
              "From FD_AccUnit " & _
              "order by iType, cUnitCode" 'cuidong 2001.02.13
              
        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_ALIGNVCENTER
        .JoinCells 0, 2, 1, 2, True
                    
        .TextMatrix(0, 3) = "备注"
        .ColAlignment(3) = UG_ALIGNLEFT
        .JoinCells 0, 3, 1, 3, True
                
        .HeadForeColor = &H404040
        .HeadFont.Name = "宋体"
        .HeadFont.Size = 12
        .HeadFont.Bold = True
    End With
    InitPrnGrid = True
End Function

Private Sub tlb_dwdy_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RightMenu Me, Button, frmRightMenu.mnuAccUnitR, tlb_dwdy, X, Y
End Sub

Private Sub tvEnt_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RightMenu Me, Button, frmRightMenu.mnuAccUnitR, tvEnt, X, Y
End Sub

Private Sub tvEnt_NodeClick(ByVal Node As ComctlLib.Node)
    clsUnit.GenMove
End Sub

Private Sub txt_Change(Index As Integer)
    cmdOK.Enabled = True
End Sub

Private Sub txt_CustKeyDown(Index As Integer, ByVal key As EDITLib.KeyTypes)
    If key = KeyRet Or key = KeyDown Then
        Select Case Index
            Case 0
                SetEdtTxtFocus txt(1)
            Case 1
                SetEdtTxtFocus txt(2)
            Case 2
                If cmdOK.Enabled Then cmdOK.SetFocus
        End Select
    ElseIf key = KeyUp Then
        Select Case Index
            Case 0
                cobtype.SetFocus
            Case 1
                SetEdtTxtFocus txt(0)
            Case 2
                SetEdtTxtFocus txt(1)
        End Select
    End If
End Sub