وب سايت رسمي شركت راهكار نوين

Const MF_CHECKED = &H8&
Const MF_APPEND = &H100&
Const TPM_LEFTALIGN = &H0&
Const MF_DISABLED = &H2&
Const MF_GRAYED = &H1&
Const MF_SEPARATOR = &H800&
Const MF_STRING = &H0&
Private Type POINTAPI
    x As Long
    y As Long
End Type
Private Declare Function CreatePopupMenu Lib "user32" () As Long
Private Declare Function TrackPopupMenu Lib "user32" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal x As Long, ByVal y As Long, ByVal nReserved As Long, ByVal hwnd As Long, ByVal lprc As Any) As Long
Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
Private Declare Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As Any) As Long
Private Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Dim hMenu As Long
Private Sub Form_Load()
    'Create an empty popupmenu
    hMenu = CreatePopupMenu()
    'Append a few menu items
    AppendMenu hMenu, MF_STRING, ByVal 0&, "Hello !"
    AppendMenu hMenu, MF_GRAYED Or MF_DISABLED, ByVal 0&, "Testing ..."
    AppendMenu hMenu, MF_SEPARATOR, ByVal 0&, ByVal 0&
    AppendMenu hMenu, MF_CHECKED, ByVal 0&, "TrackPopupMenu"
End Sub
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    Dim Pt As POINTAPI
    'Get the position of the mouse cursor
    GetCursorPos Pt
    If Button = 1 Then
        'Show our popupmenu
        TrackPopupMenu hMenu, TPM_LEFTALIGN, Pt.x, Pt.y, 0, Me.hwnd, ByVal 0&
    Else
        'Show our form's default popup menu
        TrackPopupMenu GetSystemMenu(Me.hwnd, False), TPM_LEFTALIGN, Pt.x, Pt.y, 0, Me.hwnd, ByVal 0&
    End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
    'Destroy our menu
    DestroyMenu hMenu
End Sub
 

Before running this example, use the Menu Editor utility to create a small menu system on Form1. It doesn't matter what the menus look like, but some sort of menus are necessary. 
' Declarations and such needed for the example: 
' (Copy them to the (declarations) section of a module.)

Public Declare Function GetMenu Lib "user32.dll" (ByVal hWnd As Long) As Long

Public Declare Function GetMenuItemCount Lib "user32.dll" (ByVal hMenu As Long) As Long

Public Type MENUITEMINFO

    cbSize As Long

    fMask As Long

    fType As Long

    fState As Long

    wID As Long

    hSubMenu As Long

    hbmpChecked As Long

    hbmpUnchecked As Long

    dwItemData As Long

    dwTypeData As String

    cch As Long

End Type

Public Const MIIM_STATE = &H1

Public Const MIIM_SUBMENU = &H4

Public Const MIIM_TYPE = &H10

Public Const MFT_SEPARATOR = &H800

Public Const MFS_CHECKED = &H8

Public Declare Function GetMenuItemInfo Lib "user32.dll" Alias "GetMenuItemInfoA" (ByVal _

    hMenu As Long, ByVal uItem As Long, ByVal fByPosition As Long, lpmii As _

    MENUITEMINFO) As Long

 

' When button Command1 is pressed, output the structure of the entire menu system 
' of Form1 to the Debug window.  The entire menu heirarchy is displayed, and any items 
' that are checked are identified.  A recursive subroutine is used to output the contents 
' of each individual menu, calling itself whenever a submenu is found.

 

' *** Place the following code inside a module. ***

' This function performs the recursive output of the menu structure.

Public Sub IterateThroughItems(ByVal hMenu As Long, ByVal level As Long)

    ' hMenu is a handle to the menu to output 
    ' level is the level of recursion, used to indent submenu items

    Dim itemcount As Long    ' the number of items in the specified menu

    Dim c As Long            ' loop counter variable

    Dim mii As MENUITEMINFO  ' receives information about each item

    Dim retval As Long       ' return value

    

    ' Count the number of items in the menu passed to this subroutine.

    itemcount = GetMenuItemCount(hMenu)

    

    ' Loop through the items, getting information about each one.    

    With mii

        .cbSize = Len(mii)

        .fMask = MIIM_STATE Or MIIM_TYPE Or MIIM_SUBMENU

        For c = 0 To itemcount - 1

            ' Make room in the string buffer.

            .dwTypeData = Space(256)

            .cch = 256

            ' Get information about the item.

            retval = GetMenuItemInfo(hMenu, c, 1, mii)

            ' Output a line of information about this item.

            If mii.fType = MFT_SEPARATOR Then

               ' This is a separator bar.

               Debug.Print "   " & String(3 * level, ".") & "-----"

            Else

               ' This is a text item. 
               ' If this is checked, display (X) in the margin.

               Debug.Print IIf(.fState And MFS_CHECKED, "(X)", "   ");

               ' Display the text of the item.

               Debug.Print String(3 * level, ".") & Left(.dwTypeData, .cch)

               ' If this item opens a submenu, display its contents.

               If .hSubMenu <> 0 Then

                   IterateThroughItems .hSubMenu, level + 1

               End If

            End If

        Next c

    End With

End Sub

 

' *** Place the following code inside Form1. *** 
' When Command1 is clicked, output the entire contents of Form1's menu system.

Private Sub Command1_Click()

    Dim hMenu As Long  ' handle to the menu bar of Form1

    

    ' Get a handle to Form1's menu bar.

    hMenu = GetMenu(Form1.hWnd)

    ' Use the above function to output its contents.

    IterateThroughItems hMenu, 0

End Sub
 

 Declarations and such needed for the example: 
' (Copy them to the (declarations) section of a module.) 
' There's quite a few declarations for this example, but it's worth it!

Public Declare Function GetSystemMenu Lib "user32.dll" (ByVal hWnd As Long, ByVal bRevert _

    As Long) As Long

Public Declare Function GetMenuItemCount Lib "user32.dll" (ByVal hMenu As Long) As Long

Public Type MENUITEMINFO

    cbSize As Long

    fMask As Long

    fType As Long

    fState As Long

    wID As Long

    hSubMenu As Long

    hbmpChecked As Long

    hbmpUnchecked As Long

    dwItemData As Long

    dwTypeData As String

    cch As Long

End Type

Public Const MIIM_STATE = &H1

Public Const MIIM_ID = &H2

Public Const MIIM_TYPE = &H10

Public Const MFT_SEPARATOR = &H800

Public Const MFT_STRING = &H0

Public Const MFS_ENABLED = &H0

Public Const MFS_CHECKED = &H8

Public Declare Function InsertMenuItem Lib "user32.dll" Alias "InsertMenuItemA" (ByVal _

    hMenu As Long, ByVal uItem As Long, ByVal fByPosition As Long, lpmii _

    As MENUITEMINFO) As Long

Public Declare Function SetMenuItemInfo Lib "user32.dll" Alias "SetMenuItemInfoA" (ByVal _

    hMenu As Long, ByVal uItem As Long, ByVal fByPosition As Long, lpmii _

    As MENUITEMINFO) As Long

 

Public Declare Function SetWindowPos Lib "user32.dll" (ByVal hWnd As Long, ByVal _

    hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal _

    cy As Long, ByVal wFlags As Long) As Long

Public Const HWND_TOPMOST = -1

Public Const HWND_NOTOPMOST = -2

Public Const SWP_NOMOVE = &H2

Public Const SWP_NOSIZE = &H1

Public Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hWnd _

    As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Public Const GWL_WNDPROC = -4

Public Declare Function CallWindowProc Lib "user32.dll" Alias "CallWindowProcA" (ByVal _

    lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam _

    As Long, ByVal lParam As Long) As Long

Public Const WM_SYSCOMMAND = &H112

Public Const WM_INITMENU = &H116

 

' Add an option to make window Form1 "Always On Top" to the bottom of its system 
' menu.  A check mark appears next to this option when active.  The menu item acts as a toggle. 
' Note how subclassing the window is necessary to process the two messages needed 
' to give the added system menu item its full functionality.

 

' *** Place the following code in a module. ***

 

Public pOldProc As Long  ' pointer to Form1's previous window procedure

Public ontop As Boolean  ' identifies if Form1 is always on top or not

 

' The following function acts as Form1's window procedure to process messages.

Public Function WindowProc (ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam _

        As Long, ByVal lParam As Long) As Long

    Dim hSysMenu As Long     ' handle to Form1's system menu

    Dim mii As MENUITEMINFO  ' menu item information for Always On Top

    Dim retval As Long       ' return value

    

    Select Case uMsg

    Case WM_INITMENU

        ' Before displaying the system menu, make sure that the Always On Top 
        ' option is properly checked.

        hSysMenu = GetSystemMenu(hwnd, 0)

        With mii

            ' Size of the structure.

            .cbSize = Len(mii)

            ' Only use what needs to be changed.

            .fMask = MIIM_STATE

            ' If Form1 is now always on top, check the item.

            .fState = MFS_ENABLED Or IIf(ontop, MFS_CHECKED, 0)

        End With

        retval = SetMenuItemInfo(hSysMenu, 1, 0, mii)

        WindowProc = 0

    Case WM_SYSCOMMAND

        ' If Always On Top (ID = 1) was selected, change the on top/not on top 
        ' setting of Form1 to match.

        If wParam = 1 Then

            ' Reverse the setting and make it the current one.

            ontop = Not ontop

            retval = SetWindowPos(hwnd, IIf(ontop, HWND_TOPMOST, HWND_NOTOPMOST), _

               0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)

            WindowProc = 0

        Else

            ' Some other item was selected.  Let the previous window procedure 
            ' process it.

            WindowProc = CallWindowProc(pOldProc, hwnd, uMsg, wParam, lParam)

        End If

    Case Else

        ' If this is some other message, let the previous procedure handle it.

        WindowProc = CallWindowProc(pOldProc, hwnd, uMsg, wParam, lParam)

    End Select

End Function

 

' *** Place the following code inside Form1. ***

 

' When Form1 loads, add Always On Top to the system menu and set up the 
' new window procedure.

Private Sub Form_Load()

    Dim hSysMenu As Long     ' handle to the system menu

    Dim count As Long        ' the number of items initially on the menu

    Dim mii As MENUITEMINFO  ' describes a menu item to add

    Dim retval As Long       ' return value

    

    ' Get a handle to the system menu.

    hSysMenu = GetSystemMenu(Form1.hWnd, 0)

    ' See how many items are currently in it.

    count = GetMenuItemCount(hSysMenu)

    

    ' Add a separator bar and then Always On Top to the system menu.

    With mii

        ' The size of the structure.

        .cbSize = Len(mii)

        ' What parts of the structure to use.

        .fMask = MIIM_ID Or MIIM_TYPE

        ' This is a separator.

        .fType = MFT_SEPARATOR

        ' It has an ID of 0.

        .wID = 0

    End With

    ' Add the separator to the end of the system menu.

    retval = InsertMenuItem(hSysMenu, count, 1, mii)

    

    ' Likewise, add the Always On Top command.

    With mii

        .fMask = MIIM_STATE Or MIIM_ID Or MIIM_TYPE

        ' This is a regular text item.

        .fType = MFT_STRING

        ' The option is enabled.

        .fState = MFS_ENABLED

        ' It has an ID of 1 (this identifies it in the window procedure).

        .wID = 1

        ' The text to place in the menu item.

        .dwTypeData = "&Always On Top"

        .cch = Len(.dwTypeData)

    End With

    ' Add this to the bottom of the system menu.

    retval = InsertMenuItem(hSysMenu, count + 1, 1, mii)

    

    ' Set the custom window procedure to process Form1's messages.

    ontop = False

    pOldProc = SetWindowLong(Form1.hWnd, GWL_WNDPROC, AddressOf WindowProc)

End Sub

 

' Before unloading, restore the default system menu and remove the 
' custom window procedure.

Private Sub Form_Unload(Cancel As Integer)

    Dim retval As Long  ' return value

    

    ' Replace the previous window procedure to prevent crashing.

    retval = SetWindowLong(Form1.hWnd, GWL_WNDPROC, pOldProc)

    ' Remove the modifications made to the system menu.

    retval = GetSystemMenu(Form1.hWnd, 1)

End Sub
 

Before running this example, use the Menu Editor utility to create a small menu system on Form1. It doesn't matter what the menus look like, but some sort of menus are necessary. 
' Declarations and such needed for the example: 
' (Copy them to the (declarations) section of a module.)

Public Declare Function GetMenu Lib "user32.dll" (ByVal hWnd As Long) As Long

Public Declare Function GetMenuItemCount Lib "user32.dll" (ByVal hMenu As Long) As Long

Public Type MENUITEMINFO

    cbSize As Long

    fMask As Long

    fType As Long

    fState As Long

    wID As Long

    hSubMenu As Long

    hbmpChecked As Long

    hbmpUnchecked As Long

    dwItemData As Long

    dwTypeData As String

    cch As Long

End Type

Public Const MIIM_STATE = &H1

Public Const MIIM_SUBMENU = &H4

Public Const MIIM_TYPE = &H10

Public Const MFT_SEPARATOR = &H800

Public Const MFS_CHECKED = &H8

Public Declare Function GetMenuItemInfo Lib "user32.dll" Alias "GetMenuItemInfoA" (ByVal _

    hMenu As Long, ByVal uItem As Long, ByVal fByPosition As Long, lpmii As _

    MENUITEMINFO) As Long

 

' When button Command1 is pressed, output the structure of the entire menu system 
' of Form1 to the Debug window.  The entire menu heirarchy is displayed, and any items 
' that are checked are identified.  A recursive subroutine is used to output the contents 
' of each individual menu, calling itself whenever a submenu is found.

 

' *** Place the following code inside a module. ***

' This function performs the recursive output of the menu structure.

Public Sub IterateThroughItems(ByVal hMenu As Long, ByVal level As Long)

    ' hMenu is a handle to the menu to output 
    ' level is the level of recursion, used to indent submenu items

    Dim itemcount As Long    ' the number of items in the specified menu

    Dim c As Long            ' loop counter variable

    Dim mii As MENUITEMINFO  ' receives information about each item

    Dim retval As Long       ' return value

    

    ' Count the number of items in the menu passed to this subroutine.

    itemcount = GetMenuItemCount(hMenu)

    

    ' Loop through the items, getting information about each one.    

    With mii

        .cbSize = Len(mii)

        .fMask = MIIM_STATE Or MIIM_TYPE Or MIIM_SUBMENU

        For c = 0 To itemcount - 1

            ' Make room in the string buffer.

            .dwTypeData = Space(256)

            .cch = 256

            ' Get information about the item.

            retval = GetMenuItemInfo(hMenu, c, 1, mii)

            ' Output a line of information about this item.

            If mii.fType = MFT_SEPARATOR Then

               ' This is a separator bar.

               Debug.Print "   " & String(3 * level, ".") & "-----"

            Else

               ' This is a text item. 
               ' If this is checked, display (X) in the margin.

               Debug.Print IIf(.fState And MFS_CHECKED, "(X)", "   ");

               ' Display the text of the item.

               Debug.Print String(3 * level, ".") & Left(.dwTypeData, .cch)

               ' If this item opens a submenu, display its contents.

               If .hSubMenu <> 0 Then

                   IterateThroughItems .hSubMenu, level + 1

               End If

            End If

        Next c

    End With

End Sub

 

' *** Place the following code inside Form1. *** 
' When Command1 is clicked, output the entire contents of Form1's menu system.

Private Sub Command1_Click()

    Dim hMenu As Long  ' handle to the menu bar of Form1

    

    ' Get a handle to Form1's menu bar.

    hMenu = GetMenu(Form1.hWnd)

    ' Use the above function to output its contents.

    IterateThroughItems hMenu, 0

End Sub
 

' Declarations and such needed for the example: 
' (Copy them to the (declarations) section of a module.) 
'There's quite a few declarations for this example,but it's worth it!

Public Declare Function GetSystemMenu Lib "user32.dll" (ByVal hWnd As Long, ByVal bRevert As Long) As Long

Public Declare Function GetMenuItemCount Lib "user32.dll" (ByVal hMenu As Long) As Long

Public Type MENUITEMINFO

    cbSize As Long

    fMask As Long

    fType As Long

    fState As Long

    wID As Long

    hSubMenu As Long

    hbmpChecked As Long

    hbmpUnchecked As Long

    dwItemData As Long

    dwTypeData As String

    cch As Long

End Type

Public Const MIIM_STATE = &H1

Public Const MIIM_ID = &H2

Public Const MIIM_TYPE = &H10

Public Const MFT_SEPARATOR = &H800

Public Const MFT_STRING = &H0

Public Const MFS_ENABLED = &H0

Public Const MFS_CHECKED = &H8

Public Declare Function InsertMenuItem Lib "user32.dll" Alias "InsertMenuItemA" (ByVal _

    hMenu As Long, ByVal uItem As Long, ByVal fByPosition As Long, lpmii _

    As MENUITEMINFO) As Long

Public Declare Function SetMenuItemInfo Lib "user32.dll" Alias "SetMenuItemInfoA" (ByVal _

    hMenu As Long, ByVal uItem As Long, ByVal fByPosition As Long, lpmii As MENUITEMINFO) As Long

Public Declare Function SetWindowPos Lib "user32.dll" (ByVal hWnd As Long, ByVal _

    hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal _

    cy As Long, ByVal wFlags As Long) As Long

Public Const HWND_TOPMOST = -1

Public Const HWND_NOTOPMOST = -2

Public Const SWP_NOMOVE = &H2

Public Const SWP_NOSIZE = &H1

Public Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hWnd _

    As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Public Const GWL_WNDPROC = -4

Public Declare Function CallWindowProc Lib "user32.dll" Alias "CallWindowProcA" (ByVal _

    lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam _

    As Long, ByVal lParam As Long) As Long

Public Const WM_SYSCOMMAND = &H112

Public Const WM_INITMENU = &H116

' Add an option to make window Form1 "Always On Top" to the bottom of its system 
' menu.  A check mark appears next to this option when active.  The menu item acts as a toggle. 
' Note how subclassing the window is necessary to process the two messages needed 
' to give the added system menu item its full functionality.

 

' *** Place the following code in a module. ***

 

Public pOldProc As Long  ' pointer to Form1's previous window procedure

Public ontop As Boolean  ' identifies if Form1 is always on top or not

 

' The following function acts as Form1's window procedure to process messages.

Public Function WindowProc (ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Dim hSysMenu As Long     ' handle to Form1's system menu

Dim mii As MENUITEMINFO  ' menu item information for Always On Top

Dim retval As Long       ' return value

    

    Select Case uMsg

    Case WM_INITMENU

        ' Before displaying the system menu, make sure that the Always On Top 
        ' option is properly checked.

        hSysMenu = GetSystemMenu(hwnd, 0)

        With mii

            ' Size of the structure.

            .cbSize = Len(mii)

            ' Only use what needs to be changed.

            .fMask = MIIM_STATE

            ' If Form1 is now always on top, check the item.

            .fState = MFS_ENABLED Or IIf(ontop, MFS_CHECKED, 0)

        End With

        retval = SetMenuItemInfo(hSysMenu, 1, 0, mii)

        WindowProc = 0

    Case WM_SYSCOMMAND

        ' If Always On Top (ID = 1) was selected, change the on top/not on top 
        ' setting of Form1 to match.

        If wParam = 1 Then

            ' Reverse the setting and make it the current one.

            ontop = Not ontop

            retval = SetWindowPos(hwnd, IIf(ontop, HWND_TOPMOST, HWND_NOTOPMOST), _

               0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)

            WindowProc = 0

        Else

            ' Some other item was selected.  Let the previous window procedure 
            ' process it.

            WindowProc = CallWindowProc(pOldProc, hwnd, uMsg, wParam, lParam)

        End If

    Case Else

        ' If this is some other message, let the previous procedure handle it.

        WindowProc = CallWindowProc(pOldProc, hwnd, uMsg, wParam, lParam)

    End Select

End Function

 

' *** Place the following code inside Form1. ***

 

' When Form1 loads, add Always On Top to the system menu and set up the 
' new window procedure.

Private Sub Form_Load()

    Dim hSysMenu As Long     ' handle to the system menu

    Dim count As Long        ' the number of items initially on the menu

    Dim mii As MENUITEMINFO  ' describes a menu item to add

    Dim retval As Long       ' return value

    ' Get a handle to the system menu.

    hSysMenu = GetSystemMenu(Form1.hWnd, 0)

    ' See how many items are currently in it.

    count = GetMenuItemCount(hSysMenu)

    

    ' Add a separator bar and then Always On Top to the system menu.

    With mii

        ' The size of the structure.

        .cbSize = Len(mii)

        ' What parts of the structure to use.

        .fMask = MIIM_ID Or MIIM_TYPE

        ' This is a separator.

        .fType = MFT_SEPARATOR

        ' It has an ID of 0.

        .wID = 0

    End With

    ' Add the separator to the end of the system menu.

    retval = InsertMenuItem(hSysMenu, count, 1, mii)

    ' Likewise, add the Always On Top command.

    With mii

        .fMask = MIIM_STATE Or MIIM_ID Or MIIM_TYPE

        ' This is a regular text item.

        .fType = MFT_STRING

        ' The option is enabled.

        .fState = MFS_ENABLED

        ' It has an ID of 1 (this identifies it in the window procedure).

        .wID = 1

        ' The text to place in the menu item.

        .dwTypeData = "&Always On Top"

        .cch = Len(.dwTypeData)

    End With

    ' Add this to the bottom of the system menu.

    retval = InsertMenuItem(hSysMenu, count + 1, 1, mii)

    ' Set the custom window procedure to process Form1's messages.

    ontop = False

    pOldProc = SetWindowLong(Form1.hWnd, GWL_WNDPROC, AddressOf WindowProc)

End Sub

' Before unloading, restore the default system menu and remove the 
' custom window procedure.

Private Sub Form_Unload(Cancel As Integer)

    Dim retval As Long  ' return value

    

    ' Replace the previous window procedure to prevent crashing.

    retval = SetWindowLong(Form1.hWnd, GWL_WNDPROC, pOldProc)

    ' Remove the modifications made to the system menu.

    retval = GetSystemMenu(Form1.hWnd, 1)

End Sub