一个简单的VB窗体类（修正版）

    又有一段时间没更新博客了，恰好刚才在写代码时，想起以前写的一个VB窗体类的代码，于是扒了出来：

'* ************************************************** * '* 模块名称：MYWindow.cls '* 模块功能：自定义窗口类 '* 编码：lyserver '* 联系方式：http://blog.youkuaiyun.com/lyserver '* ************************************************** * Option Explicit '---------------------------------------------------- 'API声明 '---------------------------------------------------- Private Type POINTAPI x As Long y As Long End Type Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type 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 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 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 = &H80000000 Private Const WS_CHILD = &H40000000 Private Const WS_VISIBLE = &H10000000 Private Const WS_CLIPSIBLINGS = &H4000000 Private Const WS_CLIPCHILDREN = &H2000000 Private Const WS_OVERLAPPED = &H0& Private Const WS_CAPTION = &HC00000 ' WS_BORDER Or WS_DLGFRAME Private Const WS_SYSMENU = &H80000 Private Const WS_THICKFRAME = &H40000 Private Const WS_MINIMIZEBOX = &H20000 Private Const WS_MAXIMIZEBOX = &H10000 Private Const WS_OVERLAPPEDWINDOW = (WS_OVERLAPPED Or WS_CAPTION Or WS_SYSMENU Or WS_THICKFRAME Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX) Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long Private Const SW_HIDE = 0 Private Const SW_SHOW = 5 Private Declare Function UpdateWindow Lib "user32" (ByVal hwnd As Long) 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 DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long Private Const WM_PAINT = &HF Private Const WM_ERASEBKGND = &H14 Private Const WM_SIZE = &H5 Private Const WM_DESTROY = &H2 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 MoveWindow Lib "user32" (ByVal hwnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint 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 SWP_NOMOVE = &H2 Private Const SWP_NOSIZE = &H1 Private Const SWP_NOZORDER = &H4 Private Const SWP_SHOWWINDOW = &H40 Private Const SWP_HIDEWINDOW = &H80 Private Const HWND_TOPMOST = -1 Private Const HWND_BOTTOM = 1 Private Declare Function BringWindowToTop Lib "user32" (ByVal hwnd As Long) As Long Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long) Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long Private Const DT_LEFT = &H0 Private Const DT_CENTER = &H1 Private Const DT_VCENTER = &H4 Private Const DT_SINGLELINE = &H20 Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long Private Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long Private Const WHITE_BRUSH = 0 Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long Private Type PAINTSTRUCT hdc As Long fErase As Long rcPaint As RECT fRestore As Long fIncUpdate As Long rgbReserved(32) As Byte End Type Private Declare Function BeginPaint Lib "user32" (ByVal hwnd As Long, lpPaint As PAINTSTRUCT) As Long Private Declare Function EndPaint Lib "user32" (ByVal hwnd As Long, lpPaint As PAINTSTRUCT) As Long Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long Private Declare Sub PostQuitMessage Lib "user32" (ByVal nExitCode As Long) Private Declare Function CreateFileMapping Lib "kernel32" Alias "CreateFileMappingA" (ByVal hFile As Long, ByVal lpFileMappigAttributes As Long, ByVal flProtect As Long, ByVal dwMaximumSizeHigh As Long, ByVal dwMaximumSizeLow As Long, ByVal lpName As String) As Long Private Declare Function OpenFileMapping Lib "kernel32" Alias "OpenFileMappingA" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal lpName As String) As Long Private Declare Function MapViewOfFile Lib "kernel32" (ByVal hFileMappingObject As Long, ByVal dwDesiredAccess As Long, ByVal dwFileOffsetHigh As Long, ByVal dwFileOffsetLow As Long, ByVal dwNumberOfBytesToMap As Long) As Long Private Declare Function FlushViewOfFile Lib "kernel32" (lpBaseAddress As Any, ByVal dwNumberOfBytesToFlush As Long) As Long Private Declare Function UnmapViewOfFile Lib "kernel32" (lpBaseAddress As Any) As Long Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long Private Const INVALID_HANDLE_VALUE = -1 Private Const PAGE_READWRITE As Long = 4 Private Const FILE_MAP_ALL_ACCESS = &HF001F Private Const MYCLASSNAME As String = "MYWNDCLASS" Dim m_hMap As Long Dim m_lpData As Long Dim m_hWnd As Long Dim m_hBrush As Long '---------------------------------------------------- ' 过程说明：类初始化 '---------------------------------------------------- Private Sub Class_Initialize() Dim wc As WNDCLASS wc.style = CS_HREDRAW Or CS_VREDRAW wc.lpfnwndproc = GetClassProcAddr(11, 4, True) wc.hInstance = App.hInstance wc.hbrBackground = COLOR_WINDOW wc.lpszClassName = MYCLASSNAME wc.hCursor = LoadCursor(0, IDC_ARROW) RegisterClass wc '以下使用共享内存来保存窗口数量，以便窗口数量为0时执行PostQuitMessage命令结束消息循环 m_hMap = OpenFileMapping(FILE_MAP_ALL_ACCESS, 0, "nWindows" & App.ThreadID) If m_hMap = 0 Then m_hMap = CreateFileMapping(INVALID_HANDLE_VALUE, 0, PAGE_READWRITE, 0, 10, "nWindows" & App.ThreadID) m_lpData = MapViewOfFile(m_hMap, FILE_MAP_ALL_ACCESS, 0, 0, 0) End Sub '---------------------------------------------------- ' 过程说明：类销毁 '---------------------------------------------------- Private Sub Class_Terminate() Destroy UnregisterClass MYCLASSNAME, App.hInstance UnmapViewOfFile m_lpData CloseHandle m_hMap End Sub '---------------------------------------------------- ' 类方法说明：创建窗体 '---------------------------------------------------- Public Function Create(ByVal strName As String, Optional ByVal nWidth As Long = 400, Optional ByVal nHeight As Long = 300, Optional ByVal lStyle As Long = WS_VISIBLE Or WS_OVERLAPPEDWINDOW Or WS_CLIPSIBLINGS Or WS_CLIPCHILDREN) As Long If m_hWnd = 0 Then m_hWnd = CreateWindowEx(0, MYCLASSNAME, strName, lStyle, CW_USEDEFAULT, CW_USEDEFAULT, nWidth, nHeight, 0, 0, App.hInstance, ByVal 0&) UpdateWindow m_hWnd If m_hWnd <> 0 And m_lpData <> 0 Then Dim nWindows As Long CopyMemory nWindows, ByVal m_lpData, Len(nWindows) nWindows = nWindows + 1 CopyMemory ByVal m_lpData, nWindows, Len(nWindows) FlushViewOfFile ByVal m_lpData, Len(nWindows) End If End If Create = m_hWnd End Function '---------------------------------------------------- ' 类方法说明：销毁窗体 '---------------------------------------------------- Public Sub Destroy() If m_hWnd <> 0 Then DestroyWindow m_hWnd m_hWnd = 0 End If End Sub '---------------------------------------------------- ' 类方法说明：设置窗体大小 '---------------------------------------------------- Public Sub Size(ByVal nWidth As Long, ByVal nHeight As Long) If m_hWnd <> 0 Then SetWindowPos m_hWnd, 0, 0, 0, nWidth, nHeight, SWP_NOMOVE End If End Sub '---------------------------------------------------- ' 类方法说明：移动窗体位置 '---------------------------------------------------- Public Sub Move(ByVal nLeft As Long, ByVal nTop As Long, ByVal nWidth As Long, ByVal nHeight As Long) If m_hWnd <> 0 Then MoveWindow m_hWnd, nLeft, nTop, nWidth, nHeight, 1 End If End Sub '---------------------------------------------------- ' 类方法说明：显示窗体 '---------------------------------------------------- Public Sub Show() If m_hWnd <> 0 Then ShowWindow m_hWnd, SW_SHOW End If End Sub '---------------------------------------------------- ' 类方法说明：隐藏窗体 '---------------------------------------------------- Public Sub Hide() If m_hWnd <> 0 Then ShowWindow m_hWnd, SW_HIDE End If End Sub '---------------------------------------------------- ' 类方法说明：改变窗体ZOrder顺序 '---------------------------------------------------- Public Sub ZOrder(Optional ByVal nPosition As Long) If m_hWnd <> 0 Then If nPosition >= 0 Then BringWindowToTop m_hWnd Else SetWindowPos HWND_BOTTOM, 0, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE End If End If End Sub '---------------------------------------------------- ' 自定义函数说明：获得类成员函数指针 '---------------------------------------------------- Private Function GetClassProcAddr(ByVal Index As Long, Optional ParamCount As Long = 4, Optional HasReturnValue As Boolean) As Long Static lReturn As Long, pReturn As Long Static AsmCode(50) As Byte Dim i As Long, pThis As Long, pVtbl As Long, pFunc As Long pThis = ObjPtr(Me) CopyMemory pVtbl, ByVal pThis, 4 CopyMemory pFunc, ByVal pVtbl + (6 + Index) * 4, 4 pReturn = VarPtr(lReturn) For i = 0 To UBound(AsmCode) AsmCode(i) = &H90 Next AsmCode(0) = &H55 AsmCode(1) = &H8B: AsmCode(2) = &HEC AsmCode(3) = &H53 AsmCode(4) = &H56 AsmCode(5) = &H57 If HasReturnValue Then AsmCode(6) = &HB8 CopyMemory AsmCode(7), pReturn, 4 AsmCode(11) = &H50 End If For i = 0 To ParamCount - 1 AsmCode(12 + i * 3) = &HFF AsmCode(13 + i * 3) = &H75 AsmCode(14 + i * 3) = (ParamCount - i) * 4 + 4 Next i = i * 3 + 12 AsmCode(i) = &HB9 CopyMemory AsmCode(i + 1), pThis, 4 AsmCode(i + 5) = &H51 AsmCode(i + 6) = &HE8 CopyMemory AsmCode(i + 7), pFunc - VarPtr(AsmCode(i + 6)) - 5, 4 If HasReturnValue Then AsmCode(i + 11) = &HB8 CopyMemory AsmCode(i + 12), pReturn, 4 AsmCode(i + 16) = &H8B AsmCode(i + 17) = &H0 End If AsmCode(i + 18) = &H5F AsmCode(i + 19) = &H5E AsmCode(i + 20) = &H5B AsmCode(i + 21) = &H8B: AsmCode(i + 22) = &HE5 AsmCode(i + 23) = &H5D AsmCode(i + 24) = &HC3 GetClassProcAddr = VarPtr(AsmCode(0)) End Function '---------------------------------------------------- ' 自定义函数说明：窗体消息处理函数 '---------------------------------------------------- Private Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Dim ps As PAINTSTRUCT Dim strText As String Dim rcClientArea As RECT Dim hBrush As Long Dim nWindows As Long Select Case uMsg Case WM_ERASEBKGND WindowProc = 1 Case WM_PAINT strText = "这是一个简单的VB窗口类" hBrush = GetStockObject(WHITE_BRUSH) GetClientRect hwnd, rcClientArea BeginPaint hwnd, ps FillRect ps.hdc, rcClientArea, hBrush DrawText ps.hdc, strText, lstrlen(strText), rcClientArea, DT_CENTER Or DT_VCENTER Or DT_SINGLELINE EndPaint hwnd, ps WindowProc = 0 Case WM_DESTROY WindowProc = DefWindowProc(hwnd, uMsg, wParam, lParam) CopyMemory nWindows, ByVal m_lpData, Len(nWindows) nWindows = nWindows - 1 CopyMemory ByVal m_lpData, nWindows, Len(nWindows) FlushViewOfFile ByVal m_lpData, Len(nWindows) If nWindows = 0 And Forms.Count = 0 Then PostQuitMessage 0 Case Else WindowProc = DefWindowProc(hwnd, uMsg, wParam, lParam) End Select End Function

测试代码：

Option Explicit Private Type MSG hwnd As Long message As Long wParam As Long lParam As Long time As Long x As Long y As Long 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 Sub Main() Dim uMsg As MSG Dim MyWin As New MyWindow MyWin.Create "我的窗口" Do While GetMessage(uMsg, 0, 0, 0) TranslateMessage uMsg DispatchMessage uMsg Loop MyWin.Destroy Set MyWin = Nothing End Sub

    需要说明的是，由于要运行本窗体类时，工程中不存在标准的VB窗体，因此编译器将忽略消息循环泵，需要我们自己写一个，当然，如果有VB窗体，则不用实现消息循环泵。