frmmenu.frm

会自动隐藏的菜单,比较酷,占用空间很小,希望大家喜欢.

VERSION 5.00
Begin VB.Form frmMenu 
   Caption         =   "Form1"
   ClientHeight    =   2535
   ClientLeft      =   60
   ClientTop       =   405
   ClientWidth     =   4680
   LinkTopic       =   "Form1"
   ScaleHeight     =   2535
   ScaleWidth      =   4680
   StartUpPosition =   3  '窗口缺省
   Begin VB.TextBox Text1 
      BackColor       =   &H80000004&
      BorderStyle     =   0  'None
      Height          =   285
      Left            =   120
      Locked          =   -1  'True
      TabIndex        =   6
      Text            =   "E-Mail: [e-mail]"
      Top             =   2280
      Width           =   3135
   End
   Begin VB.PictureBox picMenu 
      BackColor       =   &H80000004&
      BorderStyle     =   0  'None
      Height          =   480
      Left            =   0
      ScaleHeight     =   480
      ScaleWidth      =   4680
      TabIndex        =   0
      Top             =   0
      Width           =   4680
      Begin VB.Line Lines 
         BorderColor     =   &H00C0C0C0&
         Index           =   0
         Visible         =   0   'False
         X1              =   1680
         X2              =   2640
         Y1              =   120
         Y2              =   120
      End
      Begin VB.Line Lines 
         BorderColor     =   &H00C0C0C0&
         Index           =   2
         Visible         =   0   'False
         X1              =   1560
         X2              =   2760
         Y1              =   240
         Y2              =   240
      End
      Begin VB.Line Lines 
         BorderColor     =   &H00636363&
         Index           =   3
         Visible         =   0   'False
         X1              =   3120
         X2              =   3960
         Y1              =   120
         Y2              =   120
      End
      Begin VB.Line Lines 
         BorderColor     =   &H00636363&
         Index           =   1
         Visible         =   0   'False
         X1              =   3000
         X2              =   4080
         Y1              =   240
         Y2              =   240
      End
      Begin VB.Label mnu 
         Caption         =   " &Edit"
         BeginProperty Font 
            Name            =   "MS Sans Serif"
            Size            =   9.75
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   255
         Index           =   1
         Left            =   600
         TabIndex        =   2
         Top             =   60
         Width           =   495
      End
      Begin VB.Label mnu 
         Caption         =   " &File"
         BeginProperty Font 
            Name            =   "MS Sans Serif"
            Size            =   9.75
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   255
         Index           =   0
         Left            =   60
         TabIndex        =   1
         Top             =   60
         Width           =   495
      End
   End
   Begin VB.Label Label3 
      AutoSize        =   -1  'True
      Caption         =   "President && C.E.O. of S.S. Software"
      Height          =   180
      Left            =   120
      TabIndex        =   5
      Top             =   1980
      Width           =   3150
   End
   Begin VB.Label Label2 
      Caption         =   "Sami Samhuri"
      Height          =   255
      Left            =   120
      TabIndex        =   4
      Top             =   1680
      Width           =   4455
   End
   Begin VB.Label Label1 
      Height          =   1095
      Left            =   120
      TabIndex        =   3
      Top             =   600
      Width           =   4455
   End
   Begin VB.Menu mnumnu 
      Caption         =   "&File"
      Index           =   0
      Visible         =   0   'False
      Begin VB.Menu mnuFileNew 
         Caption         =   "&New..."
      End
      Begin VB.Menu nmuFileOpen 
         Caption         =   "&Open..."
      End
      Begin VB.Menu mnuFileSave 
         Caption         =   "&Save..."
      End
      Begin VB.Menu mnuFileSaveAs 
         Caption         =   "Save &As..."
      End
   End
   Begin VB.Menu mnumnu 
      Caption         =   "&Edit"
      Index           =   1
      Visible         =   0   'False
      Begin VB.Menu mnuEditCut 
         Caption         =   "&Cut"
      End
      Begin VB.Menu mnuEditCopy 
         Caption         =   "Co&py"
      End
      Begin VB.Menu mnuEditPaste 
         Caption         =   "&Paste"
      End
   End
   Begin VB.Menu mnuBar 
      Caption         =   "BarMenu"
      Visible         =   0   'False
      Begin VB.Menu mnuBarAutoHide 
         Caption         =   "&Auto Hide"
         Checked         =   -1  'True
      End
      Begin VB.Menu mnuBarBorder 
         Caption         =   "&Menu Border"
      End
   End
End
Attribute VB_Name = "frmMenu"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'------------------------------------------------------'
'  Create a menu with a picturebox and some labels,    '
'The lines give it a nice effect tht you only get with '
'   Win98, or the fancy MS products for Win95/WinNT    '
'                          -----                       '
'Sami Samhuri - S.S. Software                          '
'www.geocities.com/SiliconValley/Ridge/6656/index.html '
'E-Mail: [e-mail]                        '
'------------------------------------------------------'

Option Explicit
Dim Shown As Boolean
Dim ctr As Integer
Dim Autohide, Border As Boolean

' Constants used for line colors
Private Const LC1 = &HC0C0C0
Private Const LC2 = &H636363

Sub ShowBorder(Ctrl As Control, Optional Reverse As Boolean = False)
    Dim Corner1, Corner2, Corner3, Corner4 As Long

    ' If mnu is "pressed down" then reverse colors
    If Reverse Then
        Lines(0).BorderColor = LC2
        Lines(1).BorderColor = LC1
        Lines(2).BorderColor = LC2
        Lines(3).BorderColor = LC1
    Else
    ' Otherwise change them back to normal
        Lines(0).BorderColor = LC1
        Lines(1).BorderColor = LC2
        Lines(2).BorderColor = LC1
        Lines(3).BorderColor = LC2
    End If

    ' Set variables for positioning the lines around control
    Corner1 = Ctrl.Left - 10
    Corner2 = Ctrl.Left + Ctrl.Width + 10
    Corner3 = Ctrl.Top - 10
    Corner4 = Ctrl.Top + Ctrl.Height + 10

    ' Adding 15 to the width/height makes the lines meet _
        the second one needs 20 for some reason though

    ' Position Top line
    Lines(0).X1 = Corner1
    Lines(0).X2 = Corner2 + 15
    Lines(0).Y1 = Corner3
    Lines(0).Y2 = Corner3

    ' Position Bottom line
    Lines(1).X1 = Corner1
    Lines(1).X2 = Corner2 + 20
    Lines(1).Y1 = Corner4
    Lines(1).Y2 = Corner4

    ' Position Left line
    Lines(2).X1 = Corner1
    Lines(2).X2 = Corner1
    Lines(2).Y1 = Corner3
    Lines(2).Y2 = Corner4 + 15

    ' Position Right line
    Lines(3).X1 = Corner2
    Lines(3).X2 = Corner2
    Lines(3).Y1 = Corner3
    Lines(3).Y2 = Corner4 + 15

    ' Show the border(lines)
    For ctr = 0 To 3
        Lines(ctr).Visible = True
    Next ctr
End Sub

Sub HideBorder()
    ' Hide the border(lines)
    For ctr = 0 To 3
        Lines(ctr).Visible = False
    Next ctr
    
    ' Make sure the line colors are back to normal
    Lines(0).BorderColor = LC1
    Lines(1).BorderColor = LC2
    Lines(2).BorderColor = LC1
    Lines(3).BorderColor = LC2
End Sub

Sub HideBar()
    ' Disabled the menus
    For ctr = 0 To mnu.UBound
        mnu(ctr).Enabled = False
    Next ctr
    
    ' Make sure the border is hidden
    HideBorder
    
    ' Set menubar flag
    Shown = False
    
    ' Make the menu "fold up" but leave a bit visible _
        so we can access the menu, looks ugly with _
        a border around the menu
    For ctr = picMenu.Top To ((-1 * picMenu.Height) + 60) Step -5
        picMenu.Top = ctr
        
        ' This ensures that it shows the menu "folding"
        DoEvents
    Next ctr
End Sub

Sub ShowBar()
    ' Make sure the border is hidden
    HideBorder
    
    ' Set menubar flag
    Shown = True
    
    ' Make the menu "fold down"
    For ctr = picMenu.Top To 0 Step 5
        picMenu.Top = ctr
        
        ' This ensures that it shows the menu "folding"
        DoEvents
    Next ctr
    
    ' Re-enabled the menus
    For ctr = 0 To mnu.UBound
        mnu(ctr).Enabled = True
    Next ctr
End Sub

Private Sub Form_Load()
    ' Hide the menu bar
    HideBar
    
    ' Set the autohide flag
    Autohide = True
    
    ' Set the menu to show autohide is on
    mnuBarAutoHide.Checked = Autohide
    
    ' Set the border flag, not nessecary
    Border = False
    
    ' Set the menu to show there's no border _
        also not nessecary
    mnuBarBorder.Checked = Border
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    ' If the border is on the hide it
    If Lines(0).Visible Then _
        HideBorder
    
    ' If the menu is visible and autohide is on _
        then hide the menu
    If Shown And Autohide Then _
        HideBar
End Sub

Private Sub Form_Resize()
    ' Size the menu to fit the screen
    picMenu.Width = ScaleWidth
    
    ' Make sure it stays at the left edge
    picMenu.Left = 0
End Sub

Private Sub Form_Unload(Cancel As Integer)
    ' Program wouldn't close right away while the menu _
        was folding
    ' You also could set a variable so when it's _
        unloading if it's folding it just stops but _
        whatever works...I thought this was easier _
        although not always recommended..."End" does _
        some strange things sometimes
    End
End Sub

Private Sub mnu_Click(Index As Integer)
    ' If it's hidden then don't do anything
    If Not Shown And Autohide Then Exit Sub
    
    ' Make the menu appear to be "pressed down"
    ShowBorder mnu(Index), True
    
    ' Show the proper menu. It was easier to have menus _
        with corresponding indexes than to do a _
        "Select Case Index" etc. etc...
    ' Make sure the submenu appears under the menu
    PopupMenu mnumnu(Index), , mnu(Index).Left, _
        mnu(Index).Top + mnu(Index).Height + 10
End Sub

Private Sub mnu_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
    ' If it's hidden then don't do anything
    If Not Shown And Autohide Then Exit Sub
    
    ' If the border is already on the right control _
        don't let it flash
    If Lines(0).X1 + 10 = mnu(Index).Left _
        And Lines(0).Visible Then Exit Sub
    
    ' Otherwise show the border
    ShowBorder mnu(Index)
End Sub

Private Sub mnuBarAutoHide_Click()
    ' Toggle autohide flag
    Autohide = Not Autohide
    
    ' Update menu check to match
    mnuBarAutoHide.Checked = Autohide
End Sub

Private Sub mnuBarBorder_Click()
    ' Toggle border flag
    Border = Not Border
    
    ' Set menu to show checked or not
    mnuBarBorder.Checked = Border
    
    ' Show/Hide the border, I prefer it with no border
    If Border Then
        picMenu.BorderStyle = 1
    Else
        picMenu.BorderStyle = 0
    End If
End Sub

Private Sub picMenu_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    ' If it's not the right button don't do anything
    If Button <> 2 Then Exit Sub
    
    ' If it's the right button then show the menu
    PopupMenu mnuBar
End Sub

Private Sub picMenu_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    ' If the border is on the hide it
    If Lines(0).Visible Then _
        HideBorder
    
    ' If the menu's hidden then show it
    If Not Shown Then _
        ShowBar
End Sub