用鼠标实现屏幕绘图

    一般说来，在屏幕上绘图，许多朋友首先想到的是先抓取屏幕图形到窗口，然后在窗口中进行绘图，这种思路最大的缺点是，当窗口切换时，会出现明显的闪烁现象（因为屏幕抓图和应用程序窗口再置顶这些操作比较费时），有没有更好的解决办法，从而实现更快捷的屏幕绘图呢？

    其实，既然窗口支持半透明，为什么不利用此特点，创建一个置顶的接近完全透明的窗口，然后再在此窗口内绘图呢？为此，我写下了这个代码，经测试，基本达到了设计目的：

Option Explicit '* ************************************************************** * '* 程序名称：modDrawInScreen.bas '* 程序功能：用鼠标实现屏幕绘图 '* 程序用法：按Ctrol+B开始绘图、Ctrl+E停止绘图、Ctrl+Q结束 '* 作者：lyserver '* 联系方式：http://blog.csdn.net/lyserver '* ************************************************************** * Private Declare Function RegisterClass Lib "user32" Alias "RegisterClassA" (Class As WNDCLASS) As Long Private Declare Function UnregisterClass Lib "user32" Alias "UnregisterClassA" (ByVal lpClassName As String, ByVal hInstance As Long) As Long Private Const CS_HREDRAW = &H2 Private Const CS_VREDRAW = &H1 Private Const COLOR_WINDOW = 5 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 LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Long) As Long Private Const IDC_ARROW = 32512& Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) 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 WS_POPUP = &H80000000 Private Const WS_BORDER = &H800000 Private Const WS_SYSMENU = &H80000 Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long Private Const SW_HIDE = 0 Private Declare Function UpdateWindow Lib "user32" (ByVal hwnd 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 Const HWND_TOPMOST = -1 Private Const SWP_NOSIZE = &H1 Private Const SWP_NOMOVE = &H2 Private Const SWP_SHOWWINDOW = &H40 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 DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long 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 Declare Sub PostQuitMessage Lib "user32" (ByVal nExitCode As Long) Private Const WM_SETCURSOR = &H20 Private Const WM_LBUTTONDOWN = &H201 Private Const WM_LBUTTONUP = &H202 Private Const WM_MOUSEMOVE = &H200 Private Const WM_HOTKEY = &H312 Private Const WM_DESTROY = &H2 Private Type POINTAPI x As Long y As Long End Type 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 GetDC Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpPoint As Long) As Long Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long Private Const WS_EX_LAYERED = &H80000 Private Const GWL_EXSTYLE = (-20) Private Const LWA_ALPHA = &H2 Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long Private Const SM_CXFULLSCREEN = 16 Private Const SM_CYFULLSCREEN = 17 Private Const SM_CYCAPTION = 4 Private Declare Function RegisterHotKey Lib "user32" (ByVal hwnd As Long, ByVal id As Long, ByVal fsModifiers As Long, ByVal vk As Long) As Long Private Const MOD_CONTROL = &H2 Private Declare Function UnregisterHotKey Lib "user32" (ByVal hwnd As Long, ByVal id As Long) As Long Private Const MyClassName As String = "MyClassName" Sub Main() Dim wc As WNDCLASS Dim hwnd As Long If App.PrevInstance Then Exit Sub wc.style = CS_HREDRAW Or CS_VREDRAW wc.lpfnwndproc = GetFuncAddr(AddressOf WindowProc) wc.hInstance = App.hInstance wc.hIcon = 0 wc.hCursor = LoadCursor(0, IDC_ARROW) wc.hbrBackground = COLOR_WINDOW wc.lpszClassName = MyClassName If RegisterClass(wc) = 0 Then Exit Sub hwnd = CreateWindowEx(WS_EX_LAYERED, MyClassName, "MyWindow", WS_POPUP Or WS_BORDER Or WS_SYSMENU, _ 0, 0, GetSystemMetrics(SM_CXFULLSCREEN), GetSystemMetrics(SM_CYFULLSCREEN) + GetSystemMetrics(SM_CYCAPTION), _ 0, 0, App.hInstance, ByVal 0&) If hwnd = 0 Then Exit Sub UpdateWindow hwnd SetLayeredWindowAttributes hwnd, 0, 1, LWA_ALPHA RegisterHotKey hwnd, 1, MOD_CONTROL, vbKeyB '开始绘图 RegisterHotKey hwnd, 2, MOD_CONTROL, vbKeyE '停止绘图 RegisterHotKey hwnd, 3, MOD_CONTROL, vbKeyQ '结束程序 Dim uMsg As MSG Do While GetMessage(uMsg, 0, 0, 0) TranslateMessage uMsg DispatchMessage uMsg Loop UnregisterClass MyClassName, App.hInstance End Sub Private Function GetFuncAddr(ByVal lpfnFunc As Long) As Long GetFuncAddr = lpfnFunc End Function Private Function WindowProc(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Dim pt As POINTAPI Static hdc As Long Select Case wMsg Case WM_HOTKEY If wParam = 1 Then SetWindowPos hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOSIZE Or SWP_NOMOVE Or SWP_SHOWWINDOW ElseIf wParam = 2 Then ShowWindow hwnd, SW_HIDE ElseIf wParam = 3 Then DestroyWindow hwnd End If Exit Function Case WM_LBUTTONDOWN GetCursorPos pt hdc = GetDC(0) MoveToEx hdc, pt.x, pt.y, 0 Case WM_MOUSEMOVE If hdc <> 0 And wParam = 1 Then GetCursorPos pt LineTo hdc, pt.x, pt.y End If Case WM_LBUTTONUP If hdc <> 0 Then ReleaseDC 0, hdc hdc = 0 Case WM_DESTROY UnregisterHotKey hwnd, 1 UnregisterHotKey hwnd, 2 UnregisterHotKey hwnd, 3 PostQuitMessage 0 End Select WindowProc = DefWindowProc(hwnd, wMsg, wParam, lParam) End Function