一個簡單的VB窗體類（修正版）

    又有一段時間沒更新博客了，恰好剛纔在寫代碼時，想起以前寫的一個VB窗體類的代碼，於是扒了出來：

'* ************************************************** * '* 模塊名稱：MYWindow.cls '* 模塊功能：自定義窗口類 '* 編碼：lyserver '* 聯繫方式：http://blog.csdn.net/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窗體，則不用實現消息循環泵。