VB实现在窗口的标题栏上添加一个按钮的功能实现程序最小化到系统托盘

程序运行窗口右键菜单在窗口的标题栏上添加了一个按钮，实现最小化到系统托盘1、复制以下程序段到记事本中另存为文件：Project1.vbpType=ExeReference=*G00020430-0000-0000-C000-000000000046#2.0#0#C:WINDOWSsystem32stdole2.tlb#OLE AutomationModule=FormHook; FormHook.basModule=DrawButton; DrawButton.basForm=frmMain.frmModule=TrayNotify; TrayNotify.basModule=ToolTip; ToolTip.basStartup=frmMainHelpFile=ExeName32=Project1.exePath32=.WINDOWSDesktopCommand32=Name=Project1HelpContextID=0CompatibleMode=0MajorVer=1MinorVer=0RevisionVer=0AutoIncrementVer=0ServerSupportFiles=0VersionCompanyName=NoneCompilationType=0OptimizationType=0FavorPentiumPro(tm)=0CodeViewDebugInfo=0NoAliasing=0BoundsCheck=0OverflowCheck=0FlPointCheck=0FDIVCheck=0UnroundedFP=0StartMode=0Unattended=0Retained=0ThreadPerObject=0MaxNumberOfThreads=1MS Transaction ServerAutoRefresh=12、复制以下程序段到记事本中另存为文件：frmMain.frmVERSION 5.00Begin VB.Form frmMain AutoRedraw = -1 True Caption = TitleBar Tray Button Demo ClientHeight = 2040 ClientLeft = 60 ClientTop = 345 ClientWidth = 4680 LinkTopic = Form1 ScaleHeight = 2040 ScaleWidth = 4680 StartUpPosition = 3 窗口缺省 Begin VB.Menu mnuPopUp Caption = Visible = 0 False Begin VB.Menu mnuRestore Caption = Restore End EndEndAttribute VB_Name = frmMainAttribute VB_GlobalNameSpace = FalseAttribute VB_Creatable = FalseAttribute VB_PredeclaredId = TrueAttribute VB_Exposed = FalsePrivate Sub Form_Load() Print Right Click For Menu Me.Show Me.ScaleMode = vbPixels The API works in pixels Hook Me FormHook Hook()End SubPrivate Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single) If Button = 2 Then TrayMenu Me TrayNotify TrayMneu()End SubPrivate Sub Form_Unload(Cancel As Integer) UnHook FormHook UnHook()End Sub3、复制以下程序段到记事本中另存为文件：ToolTip.basAttribute VB_Name = ToolTipConst WS_EX_TOPMOST = &H8&Const TTS_ALWAYSTIP = &H1Const HWND_TOPMOST = -1Const SWP_NOACTIVATE = &H10Const SWP_NOMOVE = &H2Const SWP_NOSIZE = &H1Const WM_USER = &H400Const TTM_ADDTOOLA = (WM_USER + 4)Const TTF_SUBCLASS = &H10Declare 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 LongDeclare Function DestroyWindow Lib user32 (ByVal hwnd As Long) As LongDeclare 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 LongPublic Declare Function SendMessage Lib user32 Alias SendMessageA (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As LongType TOOLINFO cbSize As Long uFlags As Long hwnd As Long uid As Long RECT As RECT hinst As Long lpszText As String lParam As LongEnd TypePublic hWndTT As LongPublic Sub CreateTip(hwndForm As Long, szText As String, rct As RECT) hWndTT = CreateWindowEx(WS_EX_TOPMOST, tooltips_class32, , TTS_ALWAYSTIP, _ 0, 0, 0, 0, hwndForm, 0&, App.hInstance, 0&) SetWindowPos hWndTT, HWND_TOPMOST, 0, 0, 0, 0, _ SWP_NOMOVE Or SWP_NOSIZE Or SWP_NOACTIVATE Dim TI As TOOLINFO With TI .cbSize = Len(TI) .uFlags = TTF_SUBCLASS .hwnd = hwndForm .hinst = App.hInstance .uid = 1& .lpszText = szText & vbNullChar .RECT = rct End With SendMessage hWndTT, TTM_ADDTOOLA, 0, TIEnd SubPublic Sub KillTip() DestroyWindow hWndTTEnd Sub4、复制以下程序段到记事本中另存为文件：DrawButton.basAttribute VB_Name = DrawButtonDeclare Function GetWindowDC Lib user32 (ByVal hwnd As Long) As LongDeclare Function DrawFrameControl Lib user32 (ByVal hdc As Long, lpRect As RECT, ByVal un1 As Long, ByVal un2 As Long) As LongDeclare Function GetTitleBarInfo Lib user32 (ByVal hwnd As Long, pti As TitleBarInfo) As BooleanDeclare Function FillRect Lib user32 (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As LongDeclare Function GetSysColorBrush Lib user32 (ByVal nIndex As Long) As LongDeclare Function OffsetRect Lib user32 (lpRect As RECT, ByVal x As Long, ByVal y As Long) As LongType RECT Left As Long Top As Long Right As Long Bottom As LongEnd TypeType TitleBarInfo cbSize As Long rcTitleBar As RECT A RECT structure that receives the coordinates of the title bar rgState(5) As Long An array that receives a DWORD value for each element of the title barEnd Type rgState array Values 0 The titlebar Itself 1 Reserved 2 Min button 3 Max button 4 Help button 5 Close button rgstate return constatnts STATE_SYSTEM_FOCUSABLE = &H00100000 STATE_SYSTEM_INVISIBLE = &H00008000 STATE_SYSTEM_OFFSCREEN = &H00010000 STATE_SYSTEM_PRESSED = &H00000008 STATE_SYSTEM_UNAVAILABLE = &H00000001 Const DFC_BUTTON = 4Const DFCS_BUTTONPUSH = &H10Const DFCS_PUSHED = &H200Declare Function GetSystemMetrics Lib user32 (ByVal nIndex As Long) As LongPublic Declare Function PtInRect Lib user32 (lpRect As RECT, ByVal x As Long, ByVal y As Long) As LongPublic Declare Function GetCursorPos Lib user32 (lpPoint As POINTAPI) As LongPublic Type POINTAPI x As Long y As LongEnd TypeConst SM_CXFRAME = 32 Const COLOR_BTNTEXT = 18Dim lDC As LongPublic R As RECTPublic Sub ButtonDraw(frm As Form, bState As Boolean) Dim TBButtons As Integer Dim TBarHeight As Integer Dim TBButtonHeight As Integer Dim TBButtonWidth As Integer Dim DrawWidth As Integer Dim TBI As TitleBarInfo Dim TBIRect As RECT Dim bRslt As Boolean Dim WinBorder As Integer With frm If .BorderStyle = 0 Then Exit Sub Dont draw a button if there is no titlebar -How Many Buttons in TitleBar- If Not .ControlBox Then TBButtons = 0 If .ControlBox Then TBButtons = 1 If .ControlBox And .WhatsThisButton Then If .BorderStyle 4 Then TBButtons = 2 Else tButtons = 1 End If End If If .ControlBox And .MinButton And .BorderStyle = 2 Then TBButtons = 3 If .ControlBox And .MinButton And .BorderStyle = 5 Then TBButtons = 1 If .ControlBox And .MaxButton And .BorderStyle = 2 Then TBButtons = 3 If .ControlBox And .MaxButton And .BorderStyle = 5 Then TBButtons = 1 - -Get height of Titlebar- Using this method gets the height of the titlebar regardless of the window style. It does, however, restrict its use to Win98/2000. So if you want to use this code in Win95, then call GetSystemMetrics to find the windowstyle and titlebar size. TBI.cbSize = Len(TBI) bRslt = GetTitleBarInfo(.hwnd, TBI) TBIRect = TBI.rcTitleBar TBarHeight = TBIRect.Bottom - TBIRect.Top - 1 - -Get WindowBorder Size- If .BorderStyle = 2 Or .BorderStyle = 5 Then R.Top = GetSystemMetrics(32) + 2 WinBorder = R.Top - 6 Else R.Top = 5 WinBorder = -1 End If End With - -Use Titlebar Height to determin button size- TBButtonHeight = TBarHeight - 4 TBButtonWidth = TBButtonHeight + 2 and the size and space of the dot on the button DrawWidth = TBarHeight / 8 - -Determin the position of our button- R.Bottom = R.Top + TBButtonHeight Select Case TBButtons Case 1 R.Right = frm.ScaleWidth - (TBButtonWidth) + WinBorder Case 2 R.Right = frm.ScaleWidth - (TBButtonWidth * 2) + 2) + WinBorder Case 3 R.Right = frm.ScaleWidth - (TBButtonWidth * 3) + 2) + WinBorder Case Else R.Right = frm.ScaleWidth End Select R.Left = R.Right - TBButtonWidth - -Get the Widow DC so that we may draw in the title bar- lDC = GetWindowDC(frm.hwnd) - -Determin the position of the dot- Dim StartXY As Integer, EndXY As Integer Select Case TBarHeight Case Is 20 StartXY = DrawWidth + 1 EndXY = DrawWidth - 1 Case Else StartXY = (DrawWidth * 2) EndXY = DrawWidth End Select - -We have all the information we need So Draw the button- Dim rDot As RECT If bState Then DrawFrameControl lDC, R, DFC_BUTTON, DFCS_BUTTONPUSH Or DFCS_PUSHED rDot.Left = R.Right - (1 + StartXY): rDot.Top = R.Bottom - (1 + StartXY) rDot.Right = R.Right - (1 + EndXY): rDot.Bottom = R.Bottom - (1 + EndXY) Else DrawFrameControl lDC, R, DFC_BUTTON, DFCS_BUTTONPUSH rDot.Left = R.Right - (2 + StartXY): rDot.Top = R.Bottom - (2 + StartXY) rDot.Right = R.Right - (2 + EndXY): rDot.Bottom = R.Bottom - (2 + EndXY) End If FillRect lDC, rDot, GetSysColorBrush(COLOR_BTNTEXT) - -Set Tooltip- Dim TTRect As RECT TTRect.Bottom = R.Bottom + (TBarHeight - (TBarHeight * 2) + WinBorder + 5) TTRect.Left = R.Left - (4 - WinBorder) TTRect.Right = R.Right - (4 - WinBorder) TTRect.Top = R.Top + (TBarHeight - (TBarHeight * 2) + WinBorder + 5) KillTip ToolTip KillTip() CreateTip appForm.hwnd, System Tray, TTRect ToolTip CreateTip()End Sub5、复制以下程序段到记事本中另存为文件：TrayNotify.basAttribute VB_Name = TrayNotifyDeclare Function Shell_NotifyIcon Lib shell32.dll Alias Shell_NotifyIconA (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As LongDeclare Function CreatePopupMenu Lib user32 () As LongDeclare 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 LongDeclare Function AppendMenu Lib user32 Alias AppendMenuA (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As Any) As LongDeclare Function DestroyMenu Lib user32 (ByVal hMenu As Long) As LongType NOTIFYICONDATA cbSize As Long hwnd As Long uid As Long uFlags As Long uCallbackMessage As Long hIcon As Long sztip As String * 64End TypeConst NIM_ADD = &H0Const NIM_DELETE = &H2Const NIM_MODIFY = &H1Const NIF_MESSAGE = &H1Const NIF_ICON = &H2Const NIF_TIP = &H4Const MF_GRAYED = &H1&Const MF_STRING = &H0&Const MF_SEPARATOR = &H800&Const TPM_NONOTIFY = &H80&Const TPM_RETURNCMD = &H100&Public bTraySet As BooleanDim lMenu As LongPublic Sub TraySet(frm As Form, sztip As String, hIcon As Long) Dim NID As NOTIFYICONDATA With NID .cbSize = Len(NID) .hIcon = hIcon .hwnd = frm.hwnd .sztip = sztip & vbNullChar .uCallbackMessage = WM_LBUTTONUP .uFlags = NIF_MESSAGE Or NIF_ICON Or NIF_TIP .uid = 1& End With Shell_NotifyIcon NIM_ADD, NID frm.Hide bTraySet = True End SubPublic Sub TrayRestore(frm As Form) Dim NID As NOTIFYICONDATA With NID .cbSize = Len(NID) .hwnd = frm.hwnd .uid = 1& End With Shell_NotifyIcon NIM_DELETE, NID frm.Show bTraySet = False End SubPublic Sub TrayMenu(frm As Form) Dim hMenu As Long, tMenu As Long Dim MP As POINTAPI GetCursorPos MP hMenu = CreatePopupMenu() If bTraySet Then AppendMenu hMenu, MF_STRING, 1000, Restore Else AppendMenu hMenu, MF_STRING Or MF_GRAYED, 1000, Restore End If AppendMenu hMenu, MF_SEPARATOR, 0&, 0& AppendMenu hMenu, MF_STRING, 1010, Exit tMenu = TrackPopupMenu(hMenu, TPM_NONOTIFY Or TPM_RETURNCMD, MP.x, MP.y, 0&, frm.hwnd, 0&) Select Case tMenu Case 1000 TrayRestore frm Case 1010 TrayRestore frm UnHook Unload frm Case Else do nothing End Select DestroyMenu hMenu End Sub6、复制以下程序段到记事本中另存为文件：FormHook.basAttribute VB_Name = FormHookDeclare Function CallWindowProc Lib user32 Alias CallWindowProcA _ (ByVal lpPrevWndFunc As Long, _ ByVal hwnd As Long, _ ByVal Msg As Long, _ ByVal wParam As Long, _ ByVal lParam As Long) As LongDeclare Function SetWindowLong Lib user32 Alias SetWindowLongA _ (ByVal hwnd As Long, _ ByVal nIndex As Long, _ ByVal dwNewLong As Long) As LongDeclare Function GetAsyncKeyState Lib user32 (ByVal vKey As Long) As IntegerPublic Const GWL_WNDPROC = -4Public Const WM_LBUTTONDOWN = &H201Public Const WM_LBUTTONUP = &H202Public Const WM_MOUSEMOVE = &H200Public Const WM_NCMOUSEMOVE = &HA0Public Const WM_NCLBUTTONDOWN = &HA1Public Const WM_NCLBUTTONUP = &HA2Public Const WM_NCLBUTTONDBLCLK = &HA3Public Const WM_NCRBUTTONDOWN = &HA4Public Const WM_NCRBUTTONUP = &HA5Public Const WM_ACTIVATE = &H6Public Const WM_NCPAINT = &H85Public Const WM_PAINT = &HFPublic Const WM_ACTIVATEAPP = &H1CPublic Const WM_MOUSEACTIVATE = &H21Public Const WM_COMMAND = &H111Public Const WM_NCACTIVATE = &H86Public Const WM_DESTROY = &H2Public Const WM_SIZE = &H5Global lpPrevWndProc As LongGlobal gHW As LongGlobal appForm As FormPrivate Function MakePoints(lParam As Long) As POINTAPI Dim hexstr As String hexstr = Right(00000000 & Hex(lParam), 8) MakePoints.x = CLng(&H & Right(hexstr, 4) - (appForm.Left / Screen.TwipsPerPixelX) MakePoints.y = CLng(&H & Left(hexstr, 4) - (appForm.Top / Screen.TwipsPerPixelY)End FunctionPublic Sub Hook(frm As Form) gHW = frm.hwnd Set appForm = frm lpPrevWndProc = SetWindowLong(gHW, GWL_WNDPROC, AddressOf WindowProc)End SubPublic Sub UnHook() Dim lngReturnValue As Long lngReturnValue = SetWindowLong(gHW, GWL_WNDPROC, lpPrevWndProc)End SubFunction WindowProc(ByVal hwnd As Long, _ ByVal uMsg As Long, _ ByVal wParam As Long, _ ByVal lParam As Long) As Long - Messing around in here can cause allsorts of problems. So, if you must, make sure you save everytihing you want to keep before you run the program. Dont run anything outside of a message selection as it will be executed so many times per second that it will slow down system response. Dim lRslt As Long Dim retProc As Boolean Static STButtonState As Boolean Static Toggle As Boolean Static i As Integer On Error Resume Next Select Case uMsg Case WM_DESTROY TrayRestore appForm KillTip ToolTip KillTip() UnHook retProc = True Case WM_NCMOUSEMOVE Only draw the button when necessary If GetAsyncKeyState(vbLeftButton) 0 Then If OverButton(lParam) Then If Toggle = False Then Toggle = True ButtonDraw appForm, Toggle DrawButton ButtonDraw()