用VB实现Photoshop浮动工具栏

    一般来说，用子窗口实现浮动工具栏是一个不错的选择，但Photoshop真的很变态，它的工具栏窗口居然可以移出容器窗口的客户区，那么它是如何实现的呢？总结起来，Photoshop浮动工具栏具有以下两个特点：

    一、像一般的子窗口一样，点击工具栏时不改变容器窗口的活动状态，且工具栏窗口终始位于容器窗口的上层。

    二、但与一般的子窗口不同的是，工具栏窗口不受容器窗口客户区的限制，可以移出容器窗口的客户区。

    由此可以看出，使用子窗口的方案是行不通了，只有采用所有者窗口这种方案才能较好地实现，其中的关键在于设置窗口的活动状态，以保证第二个特点能够完美地实现。具体代码如下：

Option Explicit '* ************************************************************** * '* 程序名称：Demo.bas '* 程序功能：演示VB如何创建类似Photoshop工具栏浮动窗口 '* 作者：lyserver '* 联系方式：http://blog.csdn.net/lyserver '* ************************************************************** * Private Type WNDCLASS style As Long lpfnWndProc As Long cbClsExtra As Long cbWndExtra2 As Long hInstance As Long hIcon As Long hCursor As Long hbrBackground As Long lpszMenuName As String lpszClassName As String End Type Private Declare Function RegisterClass Lib "user32" Alias "RegisterClassA" (Class As WNDCLASS) As Long Private Const CS_VREDRAW As Long = &H1 Private Const CS_HREDRAW As Long = &H2 Private Const COLOR_WINDOW As Long = 5 Private Declare Function UnregisterClass Lib "user32" Alias "UnregisterClassA" (ByVal lpClassName As String, ByVal hInstance As Long) 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 Private Const CW_USEDEFAULT As Long = &H80000000 Private Const WS_OVERLAPPEDWINDOW As Long = &HCF0000 Private Const WS_CHILD As Long = &H40000000 Private Const WS_EX_TOOLWINDOW As Long = &H80 Private Declare Function UpdateWindow Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long Private Const SW_HIDE As Long = 0 Private Const SW_SHOWNORMAL As Long = 1 Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Type POINTAPI x As Long y As Long End Type Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long Private Type MSG hwnd As Long message As Long wParam As Long lParam As Long time As Long pt As POINTAPI End Type Private Declare Function GetMessage Lib "user32" Alias "GetMessageA" (lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As Long Private Declare Function TranslateMessage Lib "user32" (lpMsg As MSG) As Long Private Declare Function DispatchMessage Lib "user32" Alias "DispatchMessageA" (lpMsg As MSG) As Long Private Const WM_CLOSE As Long = &H10 Private Const WM_DESTROY As Long = &H2 Private Const WM_NCACTIVATE As Long = &H86 Private Declare Sub PostQuitMessage Lib "user32" (ByVal nExitCode As Long) Private Declare Function DefWindowProc Lib "user32" Alias "DefWindowProcA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Private Declare Function CloseWindow Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long Private 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 LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Long) As Long Private Const IDC_ARROW = 32512& Private m_hOwner As Long, m_hTool As Long Sub Main() Dim wc As WNDCLASS Dim uMsg As MSG Dim rtOwner As RECT, ptOwner As POINTAPI '注册窗口类 wc.style = CS_VREDRAW Or CS_HREDRAW wc.lpfnWndProc = GetFuncAddr(AddressOf WindowProc) wc.hInstance = App.hInstance wc.hCursor = LoadCursor(0, IDC_ARROW) wc.hbrBackground = COLOR_WINDOW wc.lpszClassName = "MyWindowClass" If RegisterClass(wc) = 0 Then Exit Sub '创建所有者窗口 m_hOwner = CreateWindowEx(0, wc.lpszClassName, "OwnerWindow", _ WS_OVERLAPPEDWINDOW, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, 0, 0, App.hInstance, ByVal 0&) UpdateWindow m_hOwner ShowWindow m_hOwner, SW_SHOWNORMAL '获得所有者窗口的客户区左上角坐标 GetClientRect m_hOwner, rtOwner ptOwner.x = rtOwner.Left ptOwner.y = rtOwner.Top ClientToScreen m_hOwner, ptOwner '创建所有者为m_hOwner的窗口，起始位置为所有者窗口客户区左上角 m_hTool = CreateWindowEx(WS_EX_TOOLWINDOW, wc.lpszClassName, "ToolWindow", _ WS_OVERLAPPEDWINDOW, ptOwner.x, ptOwner.y, 200, 55, m_hOwner, 0, App.hInstance, ByVal 0&) UpdateWindow m_hTool ShowWindow m_hTool, SW_SHOWNORMAL SendMessage m_hTool, WM_NCACTIVATE, 1, ByVal 0& '进入消息循环 Do While GetMessage(uMsg, 0, 0, 0) <> 0 TranslateMessage uMsg DispatchMessage uMsg Loop '取消窗口类注册 UnregisterClass wc.lpszClassName, App.hInstance End Sub Function GetFuncAddr(ByVal lpFuncAddr As Long) As Long GetFuncAddr = lpFuncAddr End Function Function WindowProc(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Select Case wMsg Case WM_CLOSE '关闭窗口 If hwnd = m_hOwner Then DestroyWindow m_hTool DestroyWindow m_hOwner End If Case WM_NCACTIVATE '保持窗口活动状态 If wParam = 0 Then SendMessage m_hOwner, WM_NCACTIVATE, 1, ByVal 0& Exit Function End If Case WM_DESTROY '结束消息循环 If hwnd = m_hOwner Then PostQuitMessage 0 Exit Function End If End Select WindowProc = DefWindowProc(hwnd, wMsg, wParam, lParam) End Function