frmmenu.frm

100个vb编程实例,什么都有

VERSION 5.00
Begin VB.Form frmMenu 
   Appearance      =   0  'Flat
   AutoRedraw      =   -1  'True
   Caption         =   "菜单的竖向分列"
   ClientHeight    =   2550
   ClientLeft      =   3135
   ClientTop       =   1965
   ClientWidth     =   4080
   ForeColor       =   &H80000008&
   LinkTopic       =   "Form1"
   PaletteMode     =   1  'UseZOrder
   ScaleHeight     =   170
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   272
   Begin VB.Menu mnuTwo 
      Caption         =   "二级菜单"
      Begin VB.Menu mnuList1 
         Caption         =   "菜单项 1"
         Index           =   0
      End
      Begin VB.Menu mnuPopUp 
         Caption         =   "更多的下级菜单"
         Begin VB.Menu mnuList4 
            Caption         =   "菜单项  1"
            Index           =   0
         End
      End
   End
   Begin VB.Menu mnuThree 
      Caption         =   "三级菜单"
      Begin VB.Menu mnuSub1 
         Caption         =   "带有竖向分隔条"
         Begin VB.Menu mnuList2 
            Caption         =   "菜单项1"
            Index           =   0
         End
      End
      Begin VB.Menu mnuSub2 
         Caption         =   "不带有竖向分隔条"
         Begin VB.Menu mnuList3 
            Caption         =   "菜单项1"
            Index           =   0
         End
      End
   End
End
Attribute VB_Name = "frmMenu"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
  Option Explicit
   Private Declare Function GetMenu& Lib "user32" (ByVal hwnd&)
  Private Declare Function GetSubMenu& Lib "user32" (ByVal hMenu&, ByVal nPos&)
  Private Declare Function GetMenuItemID& Lib "user32" (ByVal hMenu&, ByVal nPos&)
  Private Declare Function ModifyMenu& Lib "user32" Alias "ModifyMenuA" (ByVal hMenu&, _
                          ByVal nPosition&, ByVal wFlags&, ByVal wIDNewItem&, ByVal lpString$)
  Private Declare Function GetSystemMetrics& Lib "user32" (ByVal nIndex&)

Private Sub Form_Load()

  ' It seems that there is a limit to the number of menus that may be added
  ' in any VB application.  I discovered this by setting the number of menus
  ' in each menu array ever higher until I received an 'Out of Memory' error.
  ' The error occurred at 337 items between all three menu arrays.  This does
  ' not take into account the other higher level menus in the application.
  
  ' position the form
  Move (Screen.Width \ 2) - (Width \ 2), 0

  Const MF_BYPOSITION As Long = &H400&   '<--** tells modifymenu to act on the menu at the specified position
  Const MF_MENUBARBREAK As Long = &H20&  '<--** tells modifymenu to add another column with a vertical separator
  Const MF_MENUBREAK As Long = &H40&     '<--** tells modifymenu to add another column without a vertical separator
  Const SM_CYFULLSCREEN As Long = 17&    '<--** height of client area of a maximized window
  Const SM_CYMENU  As Long = 15&         '<--** height of menu

  Dim menuheight&, breakpoint&, menuhWnd&, submenuhWnd&, nextsubmenuhWnd&
  Dim i&, loopnum&, loopstr$, msg$

  ' get the client area height and divide it by the height of a menu
  ' to get the point where we need to *wrap* the menu to a new column
  menuheight = GetSystemMetrics(SM_CYMENU)
  breakpoint = (GetSystemMetrics(SM_CYFULLSCREEN) - menuheight) \ menuheight

  menuhWnd = GetMenu(hwnd) ' get the handle of the menu for *this* form

  submenuhWnd = GetSubMenu(menuhWnd, 0) ' get the handle of the first sub menu

  For i = 1 To 30  ' load the first menu array (rember, zero is already loaded)
    On Error GoTo TooManyMenus
    Load mnuList1(i)
    On Error GoTo 0
    mnuList1(i).Caption = "菜单项" & CStr(i + 1)

                     ' if we've reached the breakpoint then add a new column with
    If i Mod breakpoint = 0 Then   ' a vertical bar the proper ID must be specified

      Call ModifyMenu(submenuhWnd, i, MF_BYPOSITION Or MF_MENUBARBREAK, _
                              GetMenuItemID(submenuhWnd, i), "Menu Item " & CStr(i + 1))
    End If
  Next
                    
                    ' get the handle of the popup menu that is in the position
  submenuhWnd = GetSubMenu(submenuhWnd, i) ' at AFTER the menus we just loaded

  For i = 1 To 30   ' load the popup sub menu array of the first menu array (rember, zero is already loaded)
    On Error GoTo TooManyMenus
    Load mnuList4(i)
    On Error GoTo 0
    mnuList4(i).Caption = "菜单项" & CStr(i + 1)

                     ' if we've reached the breakpoint then add a new column with a vertical bar
    If i Mod 5 = 0 Then                          ' the proper ID must be specified
      Call ModifyMenu(submenuhWnd, i, MF_BYPOSITION Or MF_MENUBARBREAK, _
                                GetMenuItemID(submenuhWnd, i), "Menu Item " & CStr(i + 1))
    End If
  Next


  submenuhWnd = GetSubMenu(menuhWnd, 1) ' get the sub menu of the second top level menu (position 1)

  nextsubmenuhWnd = GetSubMenu(submenuhWnd, False) ' get the first sub menu of the sub menu

  loopnum = 1 ' set variable for trapped errors

  For i = 1 To 30  ' load the second menu array (rember, zero is already loaded)
    On Error GoTo TooManyMenus
    Load mnuList2(i)
    On Error GoTo 0
    mnuList2(i).Caption = "菜单项" & CStr(i + 1)

                     ' if we've reached the breakpoint then add a new column with a vertical bar
    If i Mod breakpoint = 0 Then                        ' the proper ID must be specified
      Call ModifyMenu(nextsubmenuhWnd, i, MF_BYPOSITION Or MF_MENUBARBREAK, _
                               GetMenuItemID(nextsubmenuhWnd, i), "Menu Item " & CStr(i + 1))
    End If
  Next

  nextsubmenuhWnd = GetSubMenu(submenuhWnd, 1) ' get the second sub menu of the sub menu
  
  loopnum = 2 ' set variable for trapped errors

  For i = 1 To 30   ' load the third menu array (rember, zero is already loaded)
    On Error GoTo TooManyMenus
    Load mnuList3(i)
    On Error GoTo 0
    mnuList3(i).Caption = "菜单项" & CStr(i + 1)

                      ' if we've reached the breakpoint then add a new column without a vertical bar
    If i Mod breakpoint = 0 Then                       ' the proper ID must be specified
      Call ModifyMenu(nextsubmenuhWnd, i, MF_BYPOSITION Or MF_MENUBREAK, _
                                GetMenuItemID(nextsubmenuhWnd, i), "Menu Item " & CStr(i + 1))
    End If
  Next

Exit Sub

TooManyMenus:

  ' display message telling where the error occurred
  Select Case loopnum
    Case 0
      loopstr$ = "first"
    Case 1
      loopstr$ = "second"
    Case 2
      loopstr$ = "third"
  End Select
  
  msg$ = "Ran out of menu space while loading sub menu number " & CStr(i) & " in the " & loopstr$ & " loop."

  MsgBox msg$, 48, "ERROR!"

  On Error GoTo 0

  Exit Sub

End Sub

Private Sub mnuList1_Click(index As Integer)

  ' report the menu that was chosen
  Dim msg$

  msg$ = "You chose item number " & CStr(index + 1) & " from the Two Level Menu"

  MsgBox msg$, 64, "Menu Columns Demo"

End Sub

Private Sub mnuList2_Click(index As Integer)

  ' report the menu that was chosen
  Dim msg$

  msg$ = "You chose item number " & CStr(index + 1) & " from the first sub menu of the Three Level Menu"

  MsgBox msg$, 64, "Menu Columns Demo"

End Sub

Private Sub mnuList3_Click(index As Integer)

  ' report the menu that was chosen
  Dim msg$

  msg$ = "You chose item number " & CStr(index + 1) & " from the second sub menu of the Three Level Menu"

  MsgBox msg$, 64, "Menu Columns Demo"

End Sub

Private Sub mnuList4_Click(index As Integer)

  ' report the menu that was chosen
  Dim msg$

  msg$ = "You chose item number " & CStr(index + 1) & " from the popup sub menu of the Two Level Menu"

  MsgBox msg$, 64, "Menu Columns Demo"

End Sub