home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Controls / Visual Basic Controls.iso / vbcontrol / fsmsg20d / FORM1.FRM (.txt) < prev    next >
Encoding:
Visual Basic Form  |  1999-04-03  |  14.7 KB  |  390 lines
  1. VERSION 5.00
  2. Object=  "{90BE51A2-EA01-11D2-A3B6-000000000000}#1.0#0"; "fsMsgHook5D.ocx"
  3. Begin VB.Form Form1 
  4.    BorderStyle     =   3  'Fixed Dialog
  5.    Caption         =   "fsMsgHook Demo - Fun with menus"
  6.    ClientHeight    =   3180
  7.    ClientLeft      =   150
  8.    ClientTop       =   720
  9.    ClientWidth     =   4755
  10.    LinkTopic       =   "Form1"
  11.    MaxButton       =   0   'False
  12.    MinButton       =   0   'False
  13.    ScaleHeight     =   3180
  14.    ScaleWidth      =   4755
  15.    ShowInTaskbar   =   0   'False
  16.    StartUpPosition =   3  'Windows Default
  17.    Begin FishheadMsgHook.fsMsgHook fsMsgHook1 
  18.       Left            =   1320
  19.       Top             =   930
  20.       _ExtentX        =   741
  21.       _ExtentY        =   741
  22.    End
  23.    Begin VB.Label lbl 
  24.       BorderStyle     =   1  'Fixed Single
  25.       Height          =   315
  26.       Left            =   0
  27.       TabIndex        =   0
  28.       Top             =   2850
  29.       Width           =   4755
  30.    End
  31.    Begin VB.Menu mnu_File 
  32.       Caption         =   "&File"
  33.       Begin VB.Menu mnuF_Exit 
  34.          Caption         =   "E&xit"
  35.       End
  36.    End
  37.    Begin VB.Menu mnu_Now 
  38.       Caption         =   "&Now"
  39.       Begin VB.Menu mnuN_Caption 
  40.          Caption         =   "?"
  41.       End
  42.    End
  43.    Begin VB.Menu mnu_Colors 
  44.       Caption         =   "&Colors"
  45.       Begin VB.Menu mnuC_Red 
  46.          Caption         =   "&Red"
  47.       End
  48.       Begin VB.Menu mnuC_White 
  49.          Caption         =   "&White"
  50.       End
  51.       Begin VB.Menu mnuC_Blue 
  52.          Caption         =   "&Blue"
  53.       End
  54.    End
  55. Attribute VB_Name = "Form1"
  56. Attribute VB_GlobalNameSpace = False
  57. Attribute VB_Creatable = False
  58. Attribute VB_PredeclaredId = True
  59. Attribute VB_Exposed = False
  60. ' **************************************************************
  61. ' ** Created by:  Fishhead Software
  62. ' ** URL:         http://www.fishware.com
  63. ' **              mailto://support@fishware.com
  64. ' **------------------------------------------------------------
  65. ' ** Project:     fsMsgHook Demo
  66. ' ** Version:     1.00
  67. ' ** Description: Fun with menus
  68. ' ** This demo shows some of the neat menu tricks you can do if
  69. ' ** you have access to Windows messaging.  fsMsgHook gives you
  70. ' ** just that capability.  With fsMsgHook you can access almost
  71. ' ** any window message for any window.  All you need is the
  72. ' ** window handle, the message, and little information about
  73. ' ** wParam and lParam for the message.
  74. ' ** This demo includes the following four examples:
  75. ' ** - How to add an item and respond to the forms system menu;
  76. ' ** - Display a message as the user changes the menu selection;
  77. ' ** - Change the width of menu item and have it displayed correctly;
  78. ' ** - Add ownerdraw of a submenu;
  79. ' ** Of course there are more things you can do with messages than
  80. ' ** just change the way menus work.  For example: you can limit the
  81. ' ** form size, change how it paints, add multicolor to listboxes
  82. ' ** to name a few.
  83. ' **------------------------------------------------------------
  84. ' ** Notes:       July 24, 1998 Created
  85. ' **************************************************************
  86. Option Explicit
  87. 'Windows constants
  88. Private Const COLOR_HIGHLIGHT = 13
  89. Private Const COLOR_MENU = 4
  90. Private Const COLOR_WINDOW = 5
  91. Private Const MF_BYCOMMAND = &H0
  92. Private Const MF_OWNERDRAW = &H100
  93. Private Const MF_SEPARATOR = &H800
  94. Private Const MF_STRING = &H0
  95. Private Const ODS_SELECTED = &H1
  96. Private Const ODT_MENU = 1
  97. Private Const SM_CYMENU = 15
  98. Private Const SC_CLOSE = &HF060
  99. Private Const SC_MAXIMIZE = &HF030
  100. Private Const SC_MINIMIZE = &HF020
  101. Private Const SC_MOVE = &HF010
  102. Private Const SC_RESTORE = &HF120
  103. Private Const SC_SIZE = &HF000
  104. ' Menu messages
  105. Private Const WM_DRAWITEM = &H2B
  106. Private Const WM_INITMENUPOPUP = &H117
  107. Private Const WM_MEASUREITEM = &H2C
  108. Private Const WM_MENUSELECT = &H11F
  109. Private Const WM_SYSCOMMAND = &H112
  110. Private Type Rect
  111.     Left As Long
  112.     Top As Long
  113.     Right As Long
  114.     Bottom As Long
  115. End Type
  116. Private Type DRAWITEMSTRUCT
  117.     CtlType As Long
  118.     CtlID As Long
  119.     ItemID As Long
  120.     ItemAction As Long
  121.     ItemState As Long
  122.     hwndItem As Long
  123.     hDC As Long
  124.     rcItem As Rect
  125.     ItemData As Long
  126. End Type
  127. Private Type MEASUREITEMSTRUCT
  128.     CtlType As Long
  129.     CtlID As Long
  130.     ItemID As Long
  131.     ItemWidth As Long
  132.     ItemHeight As Long
  133.     ItemData As Long
  134. End Type
  135. ' Windows declarations
  136. Private Declare Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As String) As Long
  137. Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
  138. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  139. Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, lpRect As Rect, ByVal hBrush As Long) As Long
  140. Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
  141. Private Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
  142. Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
  143. Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
  144. Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
  145. Private Declare Function InflateRect Lib "user32" (lpRect As Rect, ByVal x As Long, ByVal y As Long) As Long
  146. Private Declare Function ModifyMenu Lib "user32" Alias "ModifyMenuA" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal nValue As Any) As Long
  147. Private Declare Function Rectangle Lib "gdi32" (ByVal hDC As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
  148. Private Declare Sub RtlMoveMemory Lib "Kernel32" (lpDest As Any, lpSource As Any, ByVal nCount As Long)
  149. Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
  150. ' ********************************
  151. ' ** fsMsgHook Demo variables
  152. ' ********************************
  153. Private Const menuRed = 6
  154. Private Const menuWhite = 7
  155. Private Const menuBlue = 8
  156. ' fsMsgHook about system menu id
  157. Private Const IDM_ABOUT = 10
  158. Private Const SC_ABOUT = &HA
  159. Private m_hSysMenu As Long
  160. Private m_hMenu As Long
  161. Private m_Counter As Integer
  162. Private Sub Form_Load()
  163.     Dim hCMenu As Long
  164.     ' Add separator and fsMsgHook About menu item
  165.     m_hSysMenu = GetSystemMenu(Me.hwnd, False)
  166.     Call AppendMenu(m_hSysMenu, MF_SEPARATOR, 0, 0&)
  167.     Call AppendMenu(m_hSysMenu, MF_STRING, IDM_ABOUT, "&About...")
  168.     ' Get handle to "Colors" menu
  169.     m_hMenu = GetMenu(Me.hwnd)
  170.     hCMenu = GetSubMenu(m_hMenu, 2)
  171.     ' Make the colors
  172.     Call ModifyMenu(hCMenu, menuRed, MF_BYCOMMAND Or MF_OWNERDRAW, menuRed, vbRed)
  173.     Call ModifyMenu(hCMenu, menuWhite, MF_BYCOMMAND Or MF_OWNERDRAW, menuWhite, vbWhite)
  174.     Call ModifyMenu(hCMenu, menuBlue, MF_BYCOMMAND Or MF_OWNERDRAW, menuBlue, vbBlue)
  175.     fsMsgHook1.Add hwnd
  176.     ' **************************************************
  177.     ' ** Now add the messages for this window that needs
  178.     ' ** to be act on.  Of course, this is optional,
  179.     ' ** because in the WindProc event, the code is
  180.     ' ** using a select case which will filter out
  181.     ' ** unwanted messages.
  182.     ' *************************************************
  183.     fsMsgHook1.Messages().Add WM_DRAWITEM
  184.     fsMsgHook1.Messages().Add WM_INITMENUPOPUP
  185.     fsMsgHook1.Messages().Add WM_MEASUREITEM
  186.     fsMsgHook1.Messages().Add WM_MENUSELECT
  187.     fsMsgHook1.Messages().Add WM_SYSCOMMAND
  188. End Sub
  189. Private Sub fsMsgHook1_WndProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long, bForward As Boolean, Result As Long)
  190.     Dim DrawItem As DRAWITEMSTRUCT
  191.     Dim MeasureItem As MEASUREITEMSTRUCT
  192.     Dim hBrush As Long, hOldBrush As Long
  193.     Dim menuItemRect As Rect
  194.     Dim adjust As Long
  195.     Dim i As Long
  196.     Dim width As Long
  197.     Select Case uMsg
  198.     Case WM_INITMENUPOPUP
  199.         ' *********************************
  200.         ' ** Adjust the NOW menu contents
  201.         ' ** before windows calculates the
  202.         ' ** menu width, otherwise the menu
  203.         ' ** may not be wide enough.
  204.         ' *********************************
  205.         
  206.         Select Case fsLoWord(lParam)
  207.         
  208.         Case 1  ' NOW menu item
  209.             m_Counter = m_Counter + 1
  210.             Select Case m_Counter
  211.             Case 1
  212.                 mnuN_Caption.Caption = Date
  213.             Case 2
  214.                 mnuN_Caption.Caption = Time
  215.             Case 3
  216.                 mnuN_Caption.Caption = Now
  217.                 m_Counter = 0
  218.             End Select
  219.             
  220.             ' Tell fsMsgHook to get rid of the message
  221.             bForward = False
  222.             
  223.         End Select
  224.     Case WM_DRAWITEM
  225.         If wParam = 0 Then
  226.         
  227.             ' Get DrawItemStruct
  228.             Call RtlMoveMemory(DrawItem, ByVal lParam, Len(DrawItem))
  229.             
  230.             ' Determine if it is for the menu and which menu items
  231.             If DrawItem.CtlType = ODT_MENU Then
  232.                 If DrawItem.ItemID >= menuRed And DrawItem.ItemID <= menuBlue Then
  233.                     
  234.                     menuItemRect = DrawItem.rcItem
  235.                     
  236.                     ' Paint background color first
  237.                     If DrawItem.ItemState And ODS_SELECTED Then
  238.                         hBrush = CreateSolidBrush(vbGreen)
  239.                     Else
  240.                         hBrush = CreateSolidBrush(GetSysColor(COLOR_MENU))
  241.                     End If
  242.                     
  243.                     Call FillRect(DrawItem.hDC, menuItemRect, hBrush)
  244.                     Call DeleteObject(hBrush)
  245.                     
  246.                     ' Now draw color item sub bar
  247.                     hBrush = CreateSolidBrush(DrawItem.ItemData)
  248.                     hOldBrush = SelectObject(DrawItem.hDC, hBrush)
  249.                       
  250.                     adjust = (menuItemRect.Bottom - menuItemRect.Top) / 4
  251.                     Call InflateRect(menuItemRect, -adjust, -adjust)
  252.                     width = menuItemRect.Right - menuItemRect.Left
  253.                     
  254.                     ' Make six boxes for each menu item
  255.                     For i = 0 To 5
  256.                         menuItemRect.Right = menuItemRect.Left + (width \ 6) - 6
  257.                         Call Rectangle(DrawItem.hDC, menuItemRect.Left, menuItemRect.Top, menuItemRect.Right, menuItemRect.Bottom)
  258.                         menuItemRect.Left = menuItemRect.Right + 6
  259.                     Next
  260.                     
  261.                     ' Clean up
  262.                     Call SelectObject(DrawItem.hDC, hOldBrush)
  263.                     Call DeleteObject(hBrush)
  264.                     
  265.                     ' Tell fsMsgHook to get rid of the message
  266.                     bForward = False
  267.                 End If
  268.             End If
  269.         End If
  270.     Case WM_MEASUREITEM
  271.         
  272.         ' Get MEASUREITEMSTRUCT
  273.         Call RtlMoveMemory(MeasureItem, ByVal lParam, Len(MeasureItem))
  274.         
  275.         ' Make the menu items big
  276.         MeasureItem.ItemWidth = 200
  277.         MeasureItem.ItemHeight = GetSystemMetrics(SM_CYMENU) * 2
  278.         
  279.         'Save MEASUREITEMSTRUCT
  280.         Call RtlMoveMemory(ByVal lParam, MeasureItem, Len(MeasureItem))
  281.         
  282.         ' Tell fsMsgHook to get rid of the message
  283.         bForward = False
  284.     Case WM_SYSCOMMAND
  285.         If wParam = IDM_ABOUT Then
  286.             fsMsgHook1.About
  287.         End If
  288.     Case WM_MENUSELECT
  289.         
  290.         Select Case lParam
  291.         
  292.         Case m_hSysMenu
  293.               
  294.             Select Case fsLoWord(wParam)
  295.                 
  296.                Case SC_RESTORE
  297.                    lbl.Caption = "Restore this window to normal size."
  298.                   
  299.                Case SC_MOVE
  300.                    lbl.Caption = "Move this window."
  301.                   
  302.                Case SC_SIZE
  303.                    lbl.Caption = "Resize this window."
  304.                   
  305.                Case SC_MINIMIZE
  306.                    lbl.Caption = "Minimize this window."
  307.                   
  308.                Case SC_MAXIMIZE
  309.                    lbl.Caption = "Maximize this window."
  310.                   
  311.                Case SC_CLOSE
  312.                    lbl.Caption = "Exit fsMsgHook demo."
  313.                       
  314.                Case IDM_ABOUT
  315.                    lbl.Caption = "fsMsgHook About dialog."
  316.             
  317.             End Select
  318.              
  319.         Case m_hMenu
  320.             Select Case fsLoWord(wParam)
  321.                
  322.             Case 0
  323.                 lbl.Caption = mnu_File.Caption
  324.                 
  325.             Case 1
  326.                 lbl.Caption = mnu_Now.Caption
  327.                 
  328.             Case 2
  329.                 lbl.Caption = mnu_Colors.Caption
  330.                 
  331.             End Select
  332.             
  333.         Case Else
  334.             
  335.             Select Case fsLoWord(wParam)
  336.                
  337.             Case 2
  338.                 lbl.Caption = "Exit fsMsgHook demo."
  339.             
  340.             Case 4
  341.                 Select Case m_Counter
  342.                 Case 1
  343.                     lbl.Caption = "Date"
  344.                 Case 2
  345.                     lbl.Caption = "Time"
  346.                 Case Else
  347.                     lbl.Caption = "Now"
  348.                 End Select
  349.                 
  350.             Case menuRed
  351.                 lbl.Caption = "Red"
  352.                 
  353.             Case menuWhite
  354.                 lbl.Caption = "White"
  355.                 
  356.             Case menuBlue
  357.                 lbl.Caption = "Blue"
  358.             
  359.             End Select
  360.             
  361.         End Select
  362.         
  363.     End Select
  364. End Sub
  365. ' *********************************************************
  366. ' **  fsHiWord  This routine will return the first two bytes
  367. ' **            of a DWord or Long;
  368. ' ** ------------------------------------------------------
  369. ' **  Value     The DWord or Long value
  370. ' *********************************************************
  371. Public Function fsHiWord(Value As Long) As Long
  372.     fsHiWord = (Value And &HFFFF0000) \ 65536
  373. End Function
  374. ' *********************************************************
  375. ' **  fsLoWord  This routine will return the last two bytes
  376. ' **            of a DWord or Long;
  377. ' ** ------------------------------------------------------
  378. ' **  Value     The DWord or Long value
  379. ' *********************************************************
  380. Public Function fsLoWord(Value As Long) As Long
  381.     If Value And &H8000& Then
  382.         fsLoWord = Value Or &HFFFF0000
  383.     Else
  384.         fsLoWord = Value And &HFFFF&
  385.     End If
  386. End Function
  387. Private Sub mnuF_Exit_Click()
  388.     Unload Me
  389. End Sub
  390.