View Code Snippet

Author: Haeresis
Date Submitted: 4/2/2002
Category: Other
Compatibility: VB 6
This code has been accessed 8002 times.

Task: This code add a button in the Title Bar. This code work with Windows 9* and Windows NT/2000 ! (about a month ago I've posted a code like this, but it didn't work with a NT system)

Declarations

Code

'''' '''' Add this code into a MODULE '''' Option Explicit Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long Private Declare Function SetWindowPos Lib "user32" (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 Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long Public Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long Private Declare Function GetVersionEx Lib "kernel32.dll" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long Private Type OSVERSIONINFO dwOSVersionInfoSize As Long dwMajorVersion As Long dwMinorVersion As Long dwBuildNumber As Long dwPlatformId As Long szCSDVersion As String * 128 End Type Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Type CWPSTRUCT lParam As Long wParam As Long Message As Long hwnd As Long End Type Private Const WM_MOVE As Long = &H3 Private Const WM_SETCURSOR As Long = &H20 Public Const WM_NCPAINT As Long = &H85 Private Const WM_COMMAND As Long = &H111 Private Const BM_SETSTATE As Long = &HF3 Private Const SWP_FRAMECHANGED As Long = &H20 Private Const GWL_EXSTYLE As Long = -20 Private Const WS_CHILD As Long = &H40000000 Private Const WS_VISIBLE As Long = &H10000000 Private Const WS_EX_TOOLWINDOW As Long = &H80 Public Const VER_PLATFORM_WIN32_WINDOWS As Long = 1 Public Const VER_PLATFORM_WIN32_NT As Long = 2 ' MiaForm Private MyForm As Form ' GiàIntercettato Private GiàIntercettato As Boolean ' Versione di Windows Private sysVar00_lOSVersion As Long ' handle alla procedura di hook Private WHook As Long ' handle al bottone Public ButtonHwnd As Long ' riferimento alla form Private frmButt As Form ' numero di pixel di scarto dal margine destro della form Private lButtXPos As Long ' 75 è il valore di default (posiziona il bottone di help ' alla sinistra dei tre bottoni ControlBox standard) Public Sub InitButton(frmObj As Form, Optional XPosition As Long = 75) Dim os As OSVERSIONINFO ' receives version information Dim retval As Long ' return value os.dwOSVersionInfoSize = Len(os) ' set the size of the structure retval = GetVersionEx(os) ' read Windows's version information sysVar00_lOSVersion = os.dwPlatformId Set MyForm = frmObj GiàIntercettato = False ' rimuove il precedente hooking, se c'è Call UnHookButton ' memorizza i riferimenti di lavoro Set frmButt = frmObj lButtXPos = XPosition ' crea il bottone da posizionare nella Titlebar ButtonHwnd = CreateWindowEx(WS_EX_TOOLWINDOW, "Button", "?", WS_CHILD + WS_VISIBLE, _ 50, 50, 14, 14, frmObj.hwnd, 0, App.hInstance, 0) ' mostra il bottone (è invisible alla creazione) ''Call ShowWindow(ButtonHwnd, 1) ' imposta l'hooking del bottone WHook = SetWindowsHookEx(4, AddressOf HookProc, 0, App.ThreadID) ''Call SetWindowLong(ButtonHwnd, GWL_EXSTYLE, WS_EX_TOOLWINDOW) Call SetParent(ButtonHwnd, GetParent(frmObj.hwnd)) End Sub Public Sub UnHookButton() If lButtXPos > 0 Then ' sgancia l'hook del bottone lButtXPos = 0 Call UnhookWindowsHookEx(WHook) ' distrugge il bottone ''Call SetParent(ButtonHwnd, frmButt.hwnd) Call DestroyWindow(ButtonHwnd) End If End Sub '---------------------------------------------------------------------------------------------- ' PROCEDURA DI HOOKING DEI MESSAGGI RELATIVI AL BOTTONE. '---------------------------------------------------------------------------------------------- Public Function HookProc(ByVal ncode As Long, ByVal wParam As Long, Inf As CWPSTRUCT) As Long Dim FormRect As RECT Static LastParam As Long Static lCont As Long If Inf.hwnd = GetParent(ButtonHwnd) And sysVar00_lOSVersion = VER_PLATFORM_WIN32_WINDOWS Then If Inf.Message = WM_COMMAND Then Select Case LastParam ' intercetta il click sul bottone (per Win9x) Case ButtonHwnd Call frmButt.Aiuto_Click End Select ElseIf Inf.Message = WM_SETCURSOR Then LastParam = Inf.wParam End If ElseIf Inf.hwnd = frmButt.hwnd Then If Inf.Message = WM_NCPAINT Or Inf.Message = WM_MOVE Then ' legge le dimensioni della form Call GetWindowRect(frmButt.hwnd, FormRect) ' disegna il bottone nella Titlebar Call SetWindowPos(ButtonHwnd, 0, FormRect.Right - lButtXPos, _ FormRect.Top + 5, 17, 14, SWP_FRAMECHANGED) End If ElseIf Inf.hwnd = ButtonHwnd And sysVar00_lOSVersion = VER_PLATFORM_WIN32_NT Then ' click sul bottone (per Win NT) If Inf.Message = BM_SETSTATE And Inf.wParam = 0 Then If GiàIntercettato = False Then GiàIntercettato = True Call MyForm.Aiuto_Click Else GiàIntercettato = False End If End If End If ' passa il controllo alla successiva procedura nella catena di hooking HookProc = CallNextHookEx(WHook, ncode, wParam, Inf.lParam) End Function