《VB實(shí)現(xiàn)在窗口的標(biāo)題欄上添加一個(gè)按鈕的功能實(shí)現(xiàn)程序最小化到系統(tǒng)托盤(pán)》由會(huì)員分享，可在線閱讀，更多相關(guān)《VB實(shí)現(xiàn)在窗口的標(biāo)題欄上添加一個(gè)按鈕的功能實(shí)現(xiàn)程序最小化到系統(tǒng)托盤(pán)（19頁(yè)珍藏版）》請(qǐng)?jiān)谘b配圖網(wǎng)上搜索。

1、程序運(yùn)行窗口 右鍵菜單 在窗口的標(biāo)題欄上添加了一個(gè)按鈕，實(shí)現(xiàn)最小化到系統(tǒng)托盤(pán) 1、復(fù)制以下程序段到記事本中另存為文件：Project1.vbp Type=Exe Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#C:\WINDOWS\system32\stdole2.tlb#OLE Automation Module=FormHook; FormHook.bas Module=DrawButton; DrawButton.bas Form=frmMain.frm Module=Tra

2、yNotify; TrayNotify.bas Module=ToolTip; ToolTip.bas Startup="frmMain" HelpFile="" ExeName32="Project1.exe" Path32="..\..\..\..\..\..\WINDOWS\Desktop" Command32="" Name="Project1" HelpContextID="0" CompatibleMode="0" MajorVer=1 MinorVer=0 RevisionVer=0 AutoIncrementVer=0 ServerSupportFi

3、les=0 VersionCompanyName="None" CompilationType=0 OptimizationType=0 FavorPentiumPro(tm)=0 CodeViewDebugInfo=0 NoAliasing=0 BoundsCheck=0 OverflowCheck=0 FlPointCheck=0 FDIVCheck=0 UnroundedFP=0 StartMode=0 Unattended=0 Retained=0 ThreadPerObject=0 MaxNumberOfThreads=1 [MS Transac

4、tion Server] AutoRefresh=1 2、復(fù)制以下程序段到記事本中另存為文件：frmMain.frm VERSION 5.00 Begin VB.Form frmMain AutoRedraw = -1 True Caption = "TitleBar Tray Button Demo" ClientHeight = 2040 ClientLeft = 60 ClientTop = 345 ClientWidth = 4680

5、 LinkTopic = "Form1" ScaleHeight = 2040 ScaleWidth = 4680 StartUpPosition = 3 窗口缺省 Begin VB.Menu mnuPopUp Caption = "" Visible = 0 False Begin VB.Menu mnuRestore Caption = "Restore" End

6、 End End Attribute VB_Name = "frmMain" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Private Sub Form_Load() Print "Right Click For Menu" Me.Show Me.ScaleMode = vbPixels The API works in

7、pixels Hook Me FormHook Hook() End Sub Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single) If Button = 2 Then TrayMenu Me TrayNotify TrayMneu() End Sub Private Sub Form_Unload(Cancel As Integer) UnHook FormHook UnHook() End Sub 3、復(fù)制以

8、下程序段到記事本中另存為文件：ToolTip.bas Attribute VB_Name = "ToolTip" Const WS_EX_TOPMOST = &H8& Const TTS_ALWAYSTIP = &H1 Const HWND_TOPMOST = -1 Const SWP_NOACTIVATE = &H10 Const SWP_NOMOVE = &H2 Const SWP_NOSIZE = &H1 Const WM_USER = &H400 Const TTM_ADDTOOLA = (WM_USER + 4) Const TTF_SUBCLASS =

9、&H10 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 hMen

10、u As Long, ByVal hInstance As Long, lpParam As Any) As Long Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long 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,

11、ByVal wFlags 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 Type TOOLINFO cbSize As Long uFlags As Long hwnd As Long uid As Long RECT As RECT

12、 hinst As Long lpszText As String lParam As Long End Type Public hWndTT As Long Public Sub CreateTip(hwndForm As Long, szText As String, rct As RECT) hWndTT = CreateWindowEx(WS_EX_TOPMOST, "tooltips_class32", "", TTS_ALWAYSTIP, _ 0, 0, 0, 0

13、, 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 .h

14、inst = App.hInstance .uid = 1& .lpszText = szText & vbNullChar .RECT = rct End With SendMessage hWndTT, TTM_ADDTOOLA, 0, TI End Sub Public Sub KillTip() DestroyWindow hWndTT End Sub 4、復(fù)制以下程序段到記事本中另存為文件：DrawButton.bas Attribute VB_Name = "Dr

15、awButton" Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long Declare Function DrawFrameControl Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal un1 As Long, ByVal un2 As Long) As Long Declare Function GetTitleBarInfo Lib "user32" (ByVal hwnd As Long, pti As TitleBarInfo)

16、 As Boolean Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long Declare Function GetSysColorBrush Lib "user32" (ByVal nIndex As Long) As Long Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long

17、 Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Type 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 elem

18、ent of the title bar End 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

19、 STATE_SYSTEM_FOCUSABLE = &H00100000 STATE_SYSTEM_INVISIBLE = &H00008000 STATE_SYSTEM_OFFSCREEN = &H00010000 STATE_SYSTEM_PRESSED = &H00000008 STATE_SYSTEM_UNAVAILABLE = &H00000001 Const DFC_BUTTON = 4 Const DFCS_BUTTONPUSH = &H10

20、 Const DFCS_PUSHED = &H200 Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long Public Declare Function PtInRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long P

21、ublic Type POINTAPI x As Long y As Long End Type Const SM_CXFRAME = 32 Const COLOR_BTNTEXT = 18 Dim lDC As Long Public R As RECT Public Sub ButtonDraw(frm As Form, bState As Boolean) Dim TBButtons As Integer Dim TBarHeight As Integer Dim TBButtonHeight As Inte

22、ger 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

23、 ----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

24、 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 TBBut

25、tons = 3 If .ControlBox And .MaxButton And .BorderStyle = 5 Then TBButtons = 1 ------------------------------------------------------------------------ ----Get height of Titlebar---------------------------------------------- Using this method gets the he

26、ight 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 = GetTitleBa

27、rInfo(.hwnd, TBI) TBIRect = TBI.rcTitleBar TBarHeight = TBIRect.Bottom - TBIRect.Top - 1 ----------------------------------------------------------------------- ----Get WindowBorder Size---------------------------------------------- If .BorderSt

28、yle = 2 Or .BorderStyle = 5 Then R.Top = GetSystemMetrics(32) + 2 WinBorder = R.Top - 6 Else R.Top = 5 WinBorder = -1 End If End With ---------------------------------------------------------------------------

29、 ----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 --------------------------------------------------------

30、------------------- ----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

31、= 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 ---------------------------

32、----------------------------------------------- ----Get the Widow DC so that we may draw in the title bar----------------- lDC = GetWindowDC(frm.hwnd) -------------------------------------------------------------------------- ----Determin the position of the dot------

33、-------------------------------- 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

34、 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

35、 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

36、+ StartXY) rDot.Right = R.Right - (2 + EndXY): rDot.Bottom = R.Bottom - (2 + EndXY) End If FillRect lDC, rDot, GetSysColorBrush(COLOR_BTNTEXT) --------------------------------------------------------------------------- ----Set Tooltip-------------------------

37、----------------------------------- 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) + Wi

38、nBorder + 5)) KillTip ToolTip KillTip() CreateTip appForm.hwnd, "System Tray", TTRect ToolTip CreateTip() End Sub 5、復(fù)制以下程序段到記事本中另存為文件：TrayNotify.bas Attribute VB_Name = "TrayNotify" Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessag

39、e As Long, lpData As NOTIFYICONDATA) As Long Declare Function CreatePopupMenu Lib "user32" () As Long 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

40、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 Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long Type NOTIFYICONDATA cbSize As Long hwnd As

41、Long uid As Long uFlags As Long uCallbackMessage As Long hIcon As Long sztip As String * 64 End Type Const NIM_ADD = &H0 Const NIM_DELETE = &H2 Const NIM_MODIFY = &H1 Const NIF_MESSAGE = &H1 Const NIF_ICON = &H2 Const NIF_TIP = &H4 Const MF_

42、GRAYED = &H1& Const MF_STRING = &H0& Const MF_SEPARATOR = &H800& Const TPM_NONOTIFY = &H80& Const TPM_RETURNCMD = &H100& Public bTraySet As Boolean Dim lMenu As Long Public Sub TraySet(frm As Form, sztip As String, hIcon As Long) Dim NID As NOTIFYICONDATA With NID

43、 .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.Hi

44、de bTraySet = True End Sub Public 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 = Fals

45、e End Sub Public 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_STRIN

46、G 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 Tr

47、ayRestore frm Case 1010 TrayRestore frm UnHook Unload frm Case Else do nothing End Select DestroyMenu hMenu End Sub 6、復(fù)制以下程序段到記事本中另存為文件：FormHook.bas Attribute VB_Name = "FormHook" Declare Function Call

48、WindowProc 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 Long Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _

49、 (ByVal hwnd As Long, _ ByVal nIndex As Long, _ ByVal dwNewLong As Long) As Long Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer Public Const GWL_WNDPROC = -4 Public Const WM_LBUTTONDOWN = &H201 Public Const WM_LBUTTONUP = &H202 Public

50、Const WM_MOUSEMOVE = &H200 Public Const WM_NCMOUSEMOVE = &HA0 Public Const WM_NCLBUTTONDOWN = &HA1 Public Const WM_NCLBUTTONUP = &HA2 Public Const WM_NCLBUTTONDBLCLK = &HA3 Public Const WM_NCRBUTTONDOWN = &HA4 Public Const WM_NCRBUTTONUP = &HA5 Public Const WM_ACTIVATE = &H6 Public Const

51、 WM_NCPAINT = &H85 Public Const WM_PAINT = &HF Public Const WM_ACTIVATEAPP = &H1C Public Const WM_MOUSEACTIVATE = &H21 Public Const WM_COMMAND = &H111 Public Const WM_NCACTIVATE = &H86 Public Const WM_DESTROY = &H2 Public Const WM_SIZE = &H5 Global lpPrevWndProc As Long Global gHW As Lo

52、ng Global appForm As Form Private 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

53、)) - (appForm.Top / Screen.TwipsPerPixelY) End Function Public Sub Hook(frm As Form) gHW = frm.hwnd Set appForm = frm lpPrevWndProc = SetWindowLong(gHW, GWL_WNDPROC, AddressOf WindowProc) End Sub Public Sub UnHook() Dim lngReturnValue As Long lngReturnValue = SetWind

54、owLong(gHW, GWL_WNDPROC, lpPrevWndProc) End Sub Function WindowProc(ByVal hwnd As Long, _ ByVal uMsg As Long, _ ByVal wParam As Long, _ ByVal lParam As Long) As Long ------------------------------------------------------------------------------

55、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 respo

56、nse. 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 KillT

57、ip 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

58、Then Toggle = True ButtonDraw appForm, Toggle DrawButton ButtonDraw() End If Else If Toggle = True Then Toggle = False ButtonDraw appForm, To

59、ggle DrawButton ButtonDraw() End If End If Else STButtonState = False retProc = True End If Case WM_NCLBUTTONDOWN If OverButton(lParam) Then STButtonStat

60、e = True ButtonDraw appForm, True DrawButton ButtonDraw() Else STButtonState = False retProc = True End If Case WM_NCLBUTTONUP STButtonState = False If OverButton(lParam) T

61、hen TraySet appForm, appForm.Caption, appForm.Icon TrayNotify TraySet() ButtonDraw appForm, False DrawButton ButtonDraw() retProc = False Else retProc = True End If Case WM_LBUTTONUP

62、 STButtonState = False ButtonDraw appForm, False DrawButton ButtonDraw() If GetAsyncKeyState(vbLeftButton) < 0 And bTraySet Then TrayMenu appForm TrayNotify TrayMenu() End If retProc = True Case WM_NCLBUTTONDB

63、LCLK, WM_NCRBUTTONDOWN If Not OverButton(lParam) Then retProc = True End If Case WM_SIZE, WM_NCPAINT, WM_PAINT, WM_COMMAND ButtonDraw appForm, False DrawButton ButtonDraw() retProc = True

64、 Case WM_ACTIVATEAPP, WM_NCACTIVATE, WM_ACTIVATE, WM_MOUSEACTIVATE ButtonDraw appForm, False DrawButton ButtonDraw() retProc = True Case Else retProc = True End Select If retProc Then WindowProc =

65、 CallWindowProc(lpPrevWndProc, hwnd, uMsg, wParam, lParam) Else WindowProc = 0 End If End Function Private Function OverButton(lParam As Long) As Boolean Dim MP As POINTAPI MP = MakePoints(lParam) If PtInRect(R, MP.x, MP.y) Then OverButton = True End Function 雙擊工程文件：Project1.vbp運(yùn)行，就可以看到效果。