01. marts 2002 - 15:04
#1
'Prøv koden, og klikke på vindue ikonet på Form1 (system menu)
'-------------------------------------------- Form1 --------------------------------------------
Private Sub Form_Load()
Call StartHwnd(Me.Caption)
End Sub
Private Sub Form_Unload(Cancel As Integer)
Call SlutHwnd(Me.Caption)
End Sub
'-------------------------------------------- Form1 --------------------------------------------
'-------------------------------------------- Module1 --------------------------------------------
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
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public pOldProc As Long
Public ontop As Boolean
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
Dim mii As MENUITEMINFO
Dim retval As Long
Select Case uMsg
Case WM_INITMENU
hSysMenu = GetSystemMenu(hwnd, 0)
With mii
.cbSize = Len(mii)
.fMask = MIIM_STATE
.fState = MFS_ENABLED Or IIf(ontop, MFS_CHECKED, 0)
End With
retval = SetMenuItemInfo(hSysMenu, 1, 0, mii)
WindowProc = 0
Case WM_SYSCOMMAND
If wParam = 1 Then
ontop = Not ontop
retval = SetWindowPos(hwnd, IIf(ontop, HWND_TOPMOST, HWND_NOTOPMOST), 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
WindowProc = 0
Else
WindowProc = CallWindowProc(pOldProc, hwnd, uMsg, wParam, lParam)
End If
Case Else
WindowProc = CallWindowProc(pOldProc, hwnd, uMsg, wParam, lParam)
End Select
End Function
Public Function StartHwnd(snavn As String) As Boolean
Dim hSysMenu As Long
Dim count As Long
Dim mii As MENUITEMINFO
Dim retval As Long
Dim lhWnd As Long
lhWnd = FindWindow(vbNullString, snavn)
If lhWnd <> 0 Then
hSysMenu = GetSystemMenu(lhWnd, 0)
count = GetMenuItemCount(hSysMenu)
With mii
.cbSize = Len(mii)
.fMask = MIIM_ID Or MIIM_TYPE
.fType = MFT_SEPARATOR
.wID = 0
End With
retval = InsertMenuItem(hSysMenu, count, 1, mii)
With mii
.fMask = MIIM_STATE Or MIIM_ID Or MIIM_TYPE
.fType = MFT_STRING
.fState = MFS_ENABLED
.wID = 1
.dwTypeData = "&Always On Top"
.cch = Len(.dwTypeData)
End With
retval = InsertMenuItem(hSysMenu, count + 1, 1, mii)
ontop = False
pOldProc = SetWindowLong(lhWnd, GWL_WNDPROC, AddressOf WindowProc)
StartHwnd = True
Else
StartHwnd = False
End If
End Function
Public Function SlutHwnd(snavn As String) As Boolean
Dim retval As Long
Dim lhWnd As Long
lhWnd = FindWindow(vbNullString, snavn)
If lhWnd <> 0 Then
retval = SetWindowLong(lhWnd, GWL_WNDPROC, pOldProc)
retval = GetSystemMenu(lhWnd, 1)
SlutHwnd = True
Else
SlutHwnd = False
End If
End Function
'-------------------------------------------- Module1 --------------------------------------------
