vbAccelerator - Contents of code file: mfrmTest.frm

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Object = "{3D800911-77E3-43DE-82EA-7FC87C713180}#1.0#0"; "cPopMenu6.ocx"
Begin VB.MDIForm mfrmMDITest 
   BackColor       =   &H8000000C&
   Caption         =   "Test PopMenu Control in MDI Form"
   ClientHeight    =   5040
   ClientLeft      =   4920
   ClientTop       =   3150
   ClientWidth     =   6870
   Icon            =   "mfrmTest.frx":0000
   LinkTopic       =   "MDIForm1"
   Begin cPopMenu6.PopMenu ctlPopMenu 
      Left            =   540
      Top             =   0
      _ExtentX        =   1058
      _ExtentY        =   1058
      HighlightCheckedItems=   0   'False
      TickIconIndex   =   0
   End
   Begin VB.PictureBox picStatus 
      Align           =   2  'Align Bottom
      BorderStyle     =   0  'None
      Height          =   315
      Left            =   0
      ScaleHeight     =   315
      ScaleWidth      =   6870
      TabIndex        =   0
      Top             =   4725
      Width           =   6870
      Begin VB.Label lblStatus 
         Height          =   255
         Left            =   60
         TabIndex        =   1
         Top             =   60
         Width           =   6795
      End
   End
   Begin MSComctlLib.ImageList ilsIcons 
      Left            =   0
      Top             =   0
      _ExtentX        =   1005
      _ExtentY        =   1005
      BackColor       =   -2147483643
      ImageWidth      =   16
      ImageHeight     =   16
      MaskColor       =   12632256
      _Version        =   393216
      BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628} 
         NumListImages   =   22
         BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "mfrmTest.frx":030A
            Key             =   "NULL"
         EndProperty
         BeginProperty ListImage2 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "mfrmTest.frx":0624
            Key             =   "OPEN"
         EndProperty
         BeginProperty ListImage3 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "mfrmTest.frx":093E
            Key             =   "SAVE"
         EndProperty
         BeginProperty ListImage4 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "mfrmTest.frx":0C58
            Key             =   "PRINT"
         EndProperty
         BeginProperty ListImage5 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "mfrmTest.frx":0F72
            Key             =   "CUT"
         EndProperty
         BeginProperty ListImage6 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "mfrmTest.frx":128C
            Key             =   "COPY"
         EndProperty
         BeginProperty ListImage7 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "mfrmTest.frx":15A6
            Key             =   "PASTE"
         EndProperty
         BeginProperty ListImage8 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "mfrmTest.frx":18C0
            Key             =   "FIND"
         EndProperty
         BeginProperty ListImage9 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "mfrmTest.frx":1BDA
            Key             =   "BACK"
         EndProperty
         BeginProperty ListImage10 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "mfrmTest.frx":1EF4
            Key             =   "NEXT"
         EndProperty
         BeginProperty ListImage11 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "mfrmTest.frx":220E
            Key             =   "FAVE"
         EndProperty
         BeginProperty ListImage12 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "mfrmTest.frx":2528
            Key             =   "HELP"
         EndProperty
         BeginProperty ListImage13 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "mfrmTest.frx":2842
            Key             =   "NET"
         EndProperty
         BeginProperty ListImage14 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "mfrmTest.frx":2B5C
            Key             =   "FOLDER"
         EndProperty
         BeginProperty ListImage15 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "mfrmTest.frx":2E76
            Key             =   "DOCUMENT"
         EndProperty
         BeginProperty ListImage16 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "mfrmTest.frx":3190
            Key             =   "TICK"
         EndProperty
         BeginProperty ListImage17 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "mfrmTest.frx":34AA
            Key             =   "CASCADEH"
         EndProperty
         BeginProperty ListImage18 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "mfrmTest.frx":3604
            Key             =   "CASCADE"
         EndProperty
         BeginProperty ListImage19 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "mfrmTest.frx":375E
            Key             =   "MINIMISE"
         EndProperty
         BeginProperty ListImage20 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "mfrmTest.frx":38B8
            Key             =   "MAXIMISE"
         EndProperty
         BeginProperty ListImage21 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "mfrmTest.frx":3A12
            Key             =   "NEXTWIN"
         EndProperty
         BeginProperty ListImage22 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "mfrmTest.frx":3B6C
            Key             =   "PREVWIN"
         EndProperty
      EndProperty
   End
   Begin VB.Menu mnuF0MAIN 
      Caption         =   "&File"
      Begin VB.Menu mnuFile 
         Caption         =   "&Open..."
         Index           =   0
      End
      Begin VB.Menu mnuFile 
         Caption         =   "&Save..."
         Index           =   1
      End
      Begin VB.Menu mnuFile 
         Caption         =   "-"
         Index           =   2
      End
      Begin VB.Menu mnuFile 
         Caption         =   "E&xit"
         Index           =   3
      End
   End
   Begin VB.Menu mnuWindowTOP 
      Caption         =   "&Window"
      Begin VB.Menu mnuWindow 
         Caption         =   ""
         Index           =   0
      End
   End
End
Attribute VB_Name = "mfrmMDITest"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private m_lAboutId As Long
Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA"
 (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As
 Long) As Long
Private Const WM_MDIACTIVATE = &H222
Private Const WM_MDICASCADE = &H227
Private Const WM_MDIGETACTIVE = &H229
Private Const WM_MDIICONARRANGE = &H228
Private Const WM_MDIMAXIMIZE = &H225
Private Const WM_MDINEXT = &H224
Private Const WM_MDIRESTORE = &H223
Private Const WM_MDITILE = &H226
Private Const MDITILE_HORIZONTAL = &H1
Private Const MDITILE_VERTICAL = &H0
Private Const GW_CHILD = 5
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd
 As Long) As Long

Private Function GetMDIClienthWnd() As Long
   GetMDIClienthWnd = GetWindow(Me.hwnd, GW_CHILD)
End Function

Private Sub ctlPopMenu_Click(ItemNumber As Long)
Dim sKey As String
Dim lhWnd As Long
Dim lhWndChild As Long
Dim iFrm As Long
Dim eState As FormWindowStateConstants

   sKey = ctlPopMenu.MenuKey(ItemNumber)
   Select Case sKey
   Case "winTILE"
      lhWnd = GetMDIClienthWnd()
      SendMessageLong lhWnd, WM_MDITILE, MDITILE_HORIZONTAL, 0
   Case "winCASCADE"
      lhWnd = GetMDIClienthWnd()
      SendMessageLong lhWnd, WM_MDICASCADE, 0, 0
   Case "winMAXIMISE"
      lhWnd = GetMDIClienthWnd()
      lhWndChild = Me.ActiveForm.hwnd
      SendMessageLong lhWnd, WM_MDIMAXIMIZE, lhWndChild, 0
   Case "winMINIMISE"
      lhWnd = GetMDIClienthWnd()
      For iFrm = 0 To Forms.Count
         On Error Resume Next
         Err.Clear
         If (Forms(iFrm).MDIChild) Then
            If (Err.Number = 0) Then
               Forms(iFrm).WindowState = vbMinimized
            End If
         End If
      Next iFrm
      SendMessageLong lhWnd, WM_MDIICONARRANGE, 0, 0
   Case "winNEXT"
      On Error Resume Next
      eState = Me.ActiveForm.WindowState
      lhWnd = GetMDIClienthWnd()
      lhWndChild = Me.ActiveForm.hwnd
      SendMessageLong lhWnd, WM_MDINEXT, lhWndChild, 1
      If (eState <> vbMaximized) Then
         If (Me.ActiveForm.WindowState = vbMinimized) Then
            Me.ActiveForm.WindowState = vbNormal
         End If
      End If
   Case "winPREVIOUS"
      On Error Resume Next
      eState = Me.ActiveForm.WindowState
      lhWnd = GetMDIClienthWnd()
      lhWndChild = Me.ActiveForm.hwnd
      SendMessageLong lhWnd, WM_MDINEXT, lhWndChild, 0
      If (eState <> vbMaximized) Then
         If (Me.ActiveForm.WindowState = vbMinimized) Then
            Me.ActiveForm.WindowState = vbNormal
         End If
      End If
   Case Else
      If left$(sKey, 8) = "winFORM:" Then
         iFrm = CLng(Mid$(sKey, 9))
         Forms(iFrm).ZOrder
      End If
   End Select
End Sub

Private Sub ctlPopMenu_InitPopupMenu(ParentItemNumber As Long)
Dim lIcon As Long
Dim i As Long
Dim sKey As String
Dim iCount As Long
Dim bCheck As Boolean
Dim bFIrst As Boolean
Dim iWInCOunt As Long
Dim sCap As String

    If (ctlPopMenu.MenuKey(ParentItemNumber) = "mnuWindowTOP") Then
        ' build a window menu:
        With ctlPopMenu
            .ClearSubMenusOfItem ParentItemNumber
            
            lIcon = ilsIcons.ListImages("CASCADEH").Index - 1
            .AddItem "&Tile", "winTILE", , -8001, ParentItemNumber, lIcon,
             False, True
            lIcon = ilsIcons.ListImages("CASCADE").Index - 1
            .AddItem "&Cascade", "winCASCADE", , -8002, ParentItemNumber,
             lIcon, False, True
            lIcon = ilsIcons.ListImages("MAXIMISE").Index - 1
            .AddItem "Maximise &All", "winMAXIMISE", , -8003, ParentItemNumber,
             lIcon, False, True
            lIcon = ilsIcons.ListImages("MINIMISE").Index - 1
            .AddItem "Mini&mise All", "winMINIMISE", , -8004, ParentItemNumber,
             lIcon, False, True
            For i = 0 To Forms.Count - 1
               If Not (Forms(i) Is Me) Then
                  If (Forms(i).Visible And Forms(i).MDIChild) Then
                     iCount = iCount + 1
                  End If
               End If
            Next i
            .AddItem "-", , , -8005, ParentItemNumber
            lIcon = ilsIcons.ListImages("NEXTWIN").Index - 1
            .AddItem "Ne&xt" & vbTab & "Ctrl-F6", "winNEXT", , -8006,
             ParentItemNumber, lIcon, False, (iCount > 1)
            lIcon = ilsIcons.ListImages("PREVWIN").Index - 1
            .AddItem "Pre&vious" & vbTab & "Shift-Ctrl-F6", "winPREVIOUS", ,
             -8007, ParentItemNumber, lIcon, False, (iCount > 1)
            
            bFIrst = True
            For i = 0 To Forms.Count - 1
               If Not (Forms(i) Is Me) Then
                  If (Forms(i).Visible) And (Forms(i).MDIChild) Then
                     If (Forms(i) Is Me.ActiveForm) Then
                        bCheck = True
                     Else
                        bCheck = False
                     End If
                     sKey = Forms(i).Name
                     On Error Resume Next
                     lIcon = ilsIcons.ListImages(sKey).Index - 1
                     If (Err.Number <> 0) Then
                        Err.Clear
                        ilsIcons.ListImages.Add , Forms(i).Name, Forms(i).Icon
                        lIcon = ilsIcons.ListImages(Forms(i).Name).Index - 1
                     End If
                     If (bFIrst) Then
                        .AddItem "-", , , -8008, ParentItemNumber
                        bFIrst = False
                     End If
                     iWInCOunt = iWInCOunt + 1
                     sCap = GetCaption(Forms(i).Caption)
                     .AddItem "&" & CStr(iWInCOunt) & " )  " & sCap, "winFORM:"
                      & (i), , (-8009 - i), ParentItemNumber, lIcon, bCheck,
                      True
                  End If
               End If
            Next i
      End With
    End If
End Sub
Private Function GetCaption(ByVal sCaption As String) As String
Dim iNextPos As Long
Dim iPos As Long
Dim sOut As String
    If (Len(sCaption) > 32) Then sCaption = left$(sCaption, 32) & "..."
    iPos = 1
    iNextPos = InStr(sCaption, "&")
    Do While iNextPos <> 0
        sOut = sOut & Mid$(sCaption, iPos, iNextPos - iPos)
        iPos = iNextPos + 1
        iNextPos = InStr(iPos, sCaption, "&")
    Loop
    If iNextPos = 0 Then iNextPos = 1
    sOut = sOut & Mid$(sCaption, iNextPos)
    GetCaption = sOut
            
End Function

Private Sub ctlPopMenu_ItemHighlight(ItemNumber As Long, bEnabled As Boolean,
 bSeparator As Boolean)
   If Not (bSeparator) Then
      lblStatus.Caption = "Highlighted " & ctlPopMenu.Caption(ItemNumber)
   End If
End Sub

Private Sub ctlPopMenu_MenuExit()
   lblStatus.Caption = ""
End Sub

Private Sub ctlPopMenu_SystemMenuClick(ItemNumber As Long)
    If (ItemNumber = m_lAboutId) Then
        MsgBox "vbAccelerator PopMenu component MDI demonstration.",
         vbInformation
    End If
End Sub

Private Sub MDIForm_Load()
Dim l As Long
Dim lIndex As Long
Dim lC As Long

    With ctlPopMenu
        ' Remove the close item from the system menu:
        lC = .SystemMenuCount
        .SystemMenuRemoveItem lC
        ' Add a new about item to the system menu:
        m_lAboutId = .SystemMenuAppendItem("&About...")
        
        ' Associate the image list:
        .ImageList = ilsIcons
        
        ' Parse through the VB designed menu and sub class the items:
        .SubClassMenu Me
                
         ' Add the icons:
        pSetIcon "OPEN", "mnuFile(0)"
        pSetIcon "SAVE", "mnuFile(1)"
   End With
   mnuFile_Click 0
End Sub
Private Sub pSetIcon( _
        ByVal sKey As String, _
        ByVal sMenuKey As String _
    )
Dim lIconIndex As Long
    lIconIndex = plGetIconIndex(sKey)
    ctlPopMenu.ItemIcon(sMenuKey) = lIconIndex
End Sub


Private Function plGetIconIndex( _
        ByVal sKey As String _
    ) As Long
    plGetIconIndex = ilsIcons.ListImages.Item(sKey).Index - 1
End Function


Private Sub mnuFile_Click(Index As Integer)
   If (Index = 0) Then
      Dim f As frmMDIChild
      Set f = New frmMDIChild
      f.Show
   End If
   If (Index = 3) Then
      Unload Me
   End If
End Sub