背景.frm

用友U8财务软件VB源程序, 本版本为2002年版本

   Begin VB.Image imgDesktopTop 
      Height          =   945
      Left            =   0
      Picture         =   "背景.frx":52642
      Top             =   0
      Width           =   15345
   End
   Begin VB.Image Img_Background 
      Height          =   5985
      Left            =   1380
      Picture         =   "背景.frx":62686
      Top             =   840
      Width           =   8760
   End
End
Attribute VB_Name = "frmBackground"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'软件著作权: 北京用友软件集团有限公司
'系统名称: 资金管理8.0
'功能说明: 桌面
'作者: 魏小黎
Option Explicit
Private lSecondFunctionPerHeight     As Long    '二级功能单位间距
Private iPreCtlRightIndex           As Integer
Private iPreFirstFunctionIndex      As Integer
Private iPreMoveFirstFunctionIndex  As Integer
Private iSecondFunctionsCount       As Integer  '二级功能数量
Private sSecondFunctions            As String   '二级功能字符串
Private lLinLength                  As Long     '直线宽度

Private iCurrentFirstFunctionIndex  As Integer  '当前被选定的一级索引

Private Sub Form_Activate()
    Me.ZOrder 1
End Sub

'cuidong 2001.04.09
'取得一个路径的上级路径
Private Function GetParentPath(ByVal sPath As String) As String
    Dim i As Long
    Dim bFlag As Boolean
    
    sPath = Trim(sPath)
    
    If Right$(sPath, 1) = "\" Then
       sPath = Left$(sPath, Len(sPath) - 1)
    End If
    
    bFlag = False
    For i = Len(sPath) To 1 Step -1
        If mID$(sPath, i, 1) = "\" Then
           bFlag = True
           Exit For
        End If
    Next i
    
    If bFlag And i > 1 Then
       GetParentPath = Left$(sPath, i - 1)
    Else
       GetParentPath = sPath
    End If
End Function

'cuidong 2001.04.09
'从文件中载入一个图片，返回是否成功
Private Function LoadPictureFile(ByVal sPathFile As String) As Boolean
    On Error GoTo Err_LoadPictureFile
    LoadPictureFile = False
    Set Pic_Load.Picture = LoadPicture()
    Set Pic_Load.Picture = LoadPicture(sPathFile)
    LoadPictureFile = True
    
Err_LoadPictureFile:
End Function

Private Sub Form_Load()

    'cuidong 2001.04.09
    '--------------------------------------------------
    Dim sResPath As String
    
    sResPath = GetParentPath(App.Path) & "\Res\"
    
    '桌面顶部条
    If LoadPictureFile(sResPath & "DeskTop.bmp") Then
       Set imgDesktopTop.Picture = Pic_Load.Picture
    End If
    
    '桌面快捷功能条
    If LoadPictureFile(sResPath & "DeskStart.bmp") Then
       Set imgCtlMain.Picture = Pic_Load.Picture
    End If
    
    '桌面中心
    If LoadPictureFile(sResPath & "DeskCenter.bmp") Then
       Set Img_Background.Picture = Pic_Load.Picture
    End If
    
    '----zcl add 2001.6.22
    '----装载二级菜单图片
    If LoadPictureFile(sResPath & "DeskMenu.bmp") Then
       Set imgCtlRight(0).Picture = Pic_Load.Picture
    End If
    '--------------------------------------------------
     
lLinLength = Me.linRight(0).x2 - Me.linRight(0).x1
iPreCtlRightIndex = -1
iPreFirstFunctionIndex = -1
iPreMoveFirstFunctionIndex = -1
''----------------  一级功能最多为13项

    With Me.imgCtlRight(0):
        .Left = 0
        .Top = 0
        picCtlRight(0).Height = .Height
        picCtlRight(0).Width = .Width
    End With
    Me.Top = 0
    Me.Left = 0
    Me.Height = frmMain.ScaleHeight
    Me.Width = frmMain.ScaleWidth
    Me.imgButton(0).Picture = LoadResPicture(101, vbResIcon)
    Me.imgButton(1).Picture = LoadResPicture(102, vbResIcon)
    Me.imgButton(2).Picture = LoadResPicture(103, vbResIcon)
    Me.imgButton(3).Picture = LoadResPicture(104, vbResIcon)
    Me.imgButton(4).Picture = LoadResPicture(105, vbResIcon)
    Me.imgButton(5).Picture = LoadResPicture(106, vbResIcon)
    Me.imgButton(6).Picture = LoadResPicture(107, vbResIcon)
    Me.imgButton(7).Picture = LoadResPicture(108, vbResIcon)
    
    TunePosition
'    If Me.Height >= 6330 Then imgCtlMain.Top = 1102 + Me.Height - 6330
'    If Me.Height < 6330 Then imgCtlMain.Top = 1102 - (6330 - Me.Height)
    If imgCtlMain.Top < 0 Then imgCtlMain.Top = 0
    
    '使用菜单控件
'    Dim objDOM As New DOMDocument
'    Me.CMenu.SetSubSys "FD"
'    Set objDOM = Me.CMenu.GetMenu
'    Me.CMenu.SetMenu objDOM
    
    Me.ZOrder 1
End Sub

Private Sub TunePosition()
   Dim sngOffset  As Single
   Dim intLoop    As Long
   
   sngOffset = Screen.TwipsPerPixelX / 15
   
   'imgCtlMain.Height = 5800 * sngOffset  'cuidong 2001.04.09
   If imgCtlMain.Height > Me.ScaleHeight - imgDesktopTop.Height Then  'cuidong 2001.04.09
      imgCtlMain.Height = Me.ScaleHeight - imgDesktopTop.Height       'cuidong 2001.04.09
   End If                                                             'cuidong 2001.04.09
   
   imgCtlMain.Top = Me.ScaleHeight - imgCtlMain.Height
   
   For intLoop = 0 To 7
      imgButton(intLoop).Left = imgButton(intLoop).Left * sngOffset
      imgButton(intLoop).Top = imgButton(intLoop).Top * sngOffset
      lblFirstFunction(intLoop).Left = lblFirstFunction(intLoop).Left * sngOffset
      lblFirstFunction(intLoop).Top = lblFirstFunction(intLoop).Top * sngOffset
      If intLoop <> 3 And intLoop <> 4 And intLoop <> 5 Then
         imgArrow(intLoop).Left = imgArrow(intLoop).Left * sngOffset
         imgArrow(intLoop).Top = imgArrow(intLoop).Top * sngOffset
      End If
   Next intLoop
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    NoUnderline
End Sub
'去掉下划线
Private Sub NoUnderline()
Dim i As Byte
On Error Resume Next
If Not iPreMoveFirstFunctionIndex = -1 Then
    With Me.lblFirstFunction(iPreMoveFirstFunctionIndex):
        If .FontUnderline Then
            .FontUnderline = False
            .ForeColor = RGB(0, 0, 0)
            iPreMoveFirstFunctionIndex = -1
        End If
    End With
End If
If Me.picCtlRight(0).Visible Then
    For i = 0 To Me.lblSecondFunction2.Count - 1
        With Me.lblSecondFunction2(i):
            If .Visible Then
                If .ForeColor = RGB(0, 0, 255) Then
                    .ForeColor = RGB(0, 0, 0)
                End If
            End If
        End With
    Next
End If
On Error GoTo 0

End Sub
'排列二级功能列表
Private Sub SortSecondFunction(s As String)

Dim i As Long
For i = 0 To Me.lblSecondFunction2.Count - 1
    Me.lblSecondFunction2(i).Visible = False
    Me.linRight(i).Visible = False
    With Me.lblSecondFunction2(i)
        .MouseIcon = Me.lblFirstFunction(0).MouseIcon
        .MousePointer = Me.lblFirstFunction(0).MousePointer
        .ForeColor = RGB(0, 0, 0)
    End With
Next
i = 0
If s <> "" Then
    Dim iInstr As Long
    Dim sTmp As String
    iInstr = InStr(1, s, Chr(9))
    If iInstr > 0 Then
        Do While iInstr > 0
            Me.lblSecondFunction2(i).Caption = "· " & Left(s, iInstr - 1)
            Me.lblSecondFunction2(i).Visible = True
            Me.linRight(i).Visible = True
            s = mID(s, iInstr + 1)
            i = i + 1
            iInstr = InStr(1, s, Chr(9))
        Loop
        If s <> "" Then
            Me.lblSecondFunction2(i).Caption = "· " & s
            Me.lblSecondFunction2(i).Visible = True
            Me.linRight(i).Visible = True
        End If
    Else
        With Me.lblSecondFunction2(0):
            .Caption = "· " & s
            .Visible = True
        End With
    End If
    '排序
    iSecondFunctionsCount = i + 1
    lSecondFunctionPerHeight = Me.picCtlRight(0).Height / (iSecondFunctionsCount + 1)
    Me.linRight(0).Y1 = lSecondFunctionPerHeight
    Me.linRight(0).Y2 = Me.linRight(0).Y1
    
    For i = 0 To iSecondFunctionsCount - 1
        If i > 0 Then
            Me.linRight(i).Y1 = Me.linRight(i - 1).Y1 + lSecondFunctionPerHeight
            Me.linRight(i).Y2 = Me.linRight(i).Y1
        End If
        Me.lblSecondFunction2(i).Top = Me.linRight(i).Y1 - Me.lblSecondFunction2(i).Height
        Me.linRight(i).Visible = True
        Me.lblSecondFunction2(i).Visible = True
    Next
End If

End Sub

Private Sub Form_Resize()                                 'Cuidong 2000/06/20
    On Error Resume Next                                  'Cuidong 2000/06/20
    'Img_Background.Move 0, 0, ScaleWidth, ScaleHeight    '满屏
    With Img_Background                                   'Cuidong 2000/06/20
        .Move ScaleWidth - .Width, ScaleHeight - .Height  '居右下角
    End With                                              'Cuidong 2000/06/20
End Sub

Private Sub Img_Background_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    NoUnderline
End Sub

Private Sub imgCtlMain_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    NoUnderline
End Sub

Private Sub imgCtlRight_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
    NoUnderline
End Sub

Private Sub lblFirstFunction_Click(Index As Integer)

    Dim lPerWidth As Long
    Dim bColor As Boolean
    bColor = True
    Dim i As Long
    ''--------------根据Index更换二级功能字符串(已chr(9)分隔)
    Select Case Index
        Case Is = 0
            sSecondFunctions = "利率设置" _
                        & Chr(9) & "结息日定义" _
                        & Chr(9) & "单位定义" _
                        & Chr(9) & "账户定义" _
                        & Chr(9) & "账户科目" _
                        & Chr(9) & "常用单据" _
                        & Chr(9) & "选项"
        Case Is = 1
            sSecondFunctions = "银行存款单" _
                        & Chr(9) & "银行取款单" _
                        & Chr(9) & "内部存款单" _
                        & Chr(9) & "内部取款单" _
                        & Chr(9) & "银行贷款单" _
                        & Chr(9) & "内部贷款单" _
                        & Chr(9) & "内部拆借单" _
                        & Chr(9) & "银行贷款本金还款单" _
                        & Chr(9) & "内部贷款本金还款单" _
                        & Chr(9) & "内部拆借本金还款单" _
                        & Chr(9) & "银行贷款利息还款单" _
                        & Chr(9) & "内部贷款利息还款单" _
                        & Chr(9) & "内部拆借利息还款单" _
                        & Chr(9) & "对外结算单" _
                        & Chr(9) & "内部结算单" _
                        & Chr(9) & "利息单" _
                        & Chr(9) & "催款单"
        Case Is = 2
            sSecondFunctions = "银行存款单" _
                        & Chr(9) & "银行取款单" _
                        & Chr(9) & "内部存款单" _
                        & Chr(9) & "内部取款单" _
                        & Chr(9) & "银行贷款单" _
                        & Chr(9) & "内部贷款单" _
                        & Chr(9) & "内部拆借单" _
                        & Chr(9) & "银行贷款本金还款单" _
                        & Chr(9) & "内部贷款本金还款单" _
                        & Chr(9) & "内部拆借本金还款单" _
                        & Chr(9) & "银行贷款利息还款单" _
                        & Chr(9) & "内部贷款利息还款单" _
                        & Chr(9) & "内部拆借利息还款单" _
                        & Chr(9) & "对外结算单" _
                        & Chr(9) & "内部结算单" _
                        & Chr(9) & "利息单" _
                        & Chr(9) & "利息通知单" _
                        & Chr(9) & "催款单"
        Case Is = 3
            sSecondFunctions = ""
            If mnu_right(3, 0) Then