'Window Class Sample 'Copyright (c) 2002 Nir Sofer 'Web site: http://nirsoft.mirrorz.com ' 'The following module shows you how to register a new window class in Visual Basic and 'use that class to create new windows, and show them on a form. 'Be aware that this example is designated for advanced Visual Basic programmers. 'If you don't have extensive knowledge in Win32 API, you won't understand this source code. Public Type WNDCLASS style As Long lpfnwndproc As Long cbClsextra As Long cbWndExtra As Long hInstance As Long hIcon As Long hCursor As Long hbrBackground As Long lpszMenuName As Long lpszClassName As Long End Type Public Const COLOR_WINDOW = 5 Public Declare Function UnregisterClass Lib "user32" Alias "UnregisterClassA" _ (ByVal lpClassName As String, ByVal hInstance As Long) As Long Public Declare Function RegisterClass Lib "user32" Alias "RegisterClassA" _ (Class As WNDCLASS) As Long Public 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 Public 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 Public Const WS_CHILD = &H40000000 Public Const WS_BORDER = &H800000 Public Const WS_VISIBLE = &H10000000 Public Const TEST_CLASS As String = "TestClass" Public Const WM_PAINT = &HF Public Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Public Declare Function GetClientRect Lib "user32" _ (ByVal hwnd As Long, lpRect As RECT) As Long Public Declare Function Rectangle Lib "gdi32" _ (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, _ ByVal X2 As Long, ByVal Y2 As Long) As Long Public Declare Function SelectObject Lib "gdi32" _ (ByVal hdc As Long, ByVal hObject As Long) As Long Public Declare Function DeleteObject Lib "gdi32" _ (ByVal hObject As Long) As Long Public Declare Function CreateSolidBrush Lib "gdi32" _ (ByVal crColor As Long) As Long Public Declare Function CreatePen Lib "gdi32" _ (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long Public Const PS_SOLID = 0 Public Type PAINTSTRUCT hdc As Long fErase As Long rcPaint As RECT fRestore As Long fIncUpdate As Long rgbReserved(32) As Byte End Type Public Declare Function GetDC Lib "user32" _ (ByVal hwnd As Long) As Long Public Declare Function ReleaseDC Lib "user32" _ (ByVal hwnd As Long, ByVal hdc As Long) As Long Public Declare Function DrawTextEx Lib "user32" Alias "DrawTextExA" _ (ByVal hdc As Long, ByVal lpsz As String, ByVal n As Long, _ lpRect As RECT, ByVal un As Long, lpDrawTextParams As Any) As Long Public Declare Function SetTextColor Lib "gdi32" _ (ByVal hdc As Long, ByVal crColor As Long) As Long Public Declare Function SetBkMode Lib "gdi32" _ (ByVal hdc As Long, ByVal nBkMode As Long) As Long Public Const TRANSPARENT = 1 Public Const DT_CENTER = &H1 Public Const DT_VCENTER = &H4 Public Const DT_SINGLELINE = &H20 Public Const WM_LBUTTONDOWN = &H201 Public Const WM_LBUTTONUP = &H202 Private Function GetAddressOf(A As Long) As Long GetAddressOf = A End Function Public Sub UnregisterWindowClass() UnregisterClass TEST_CLASS, App.hInstance End Sub Public Sub RegisterWindowClass() Dim wc As WNDCLASS Dim hAtom As Long Dim BytesArray() As Byte 'The following code fills the WNDCLASS structure: wc.style = 0 wc.lpfnwndproc = GetAddressOf(AddressOf MyWndProc) wc.cbClsextra = 0 wc.cbWndExtra = 0 wc.hInstance = App.hInstance wc.hIcon = 0 wc.hCursor = 0 wc.hbrBackground = COLOR_WINDOW wc.lpszMenuName = 0 'Convert the class name from Unicode to array of bytes. BytesArray = StrConv(TEST_CLASS & Chr$(0), vbFromUnicode) wc.lpszClassName = VarPtr(BytesArray(0)) 'Register the new class hAtom = RegisterClass(wc) End Sub 'The following function draws a rectangle with 'ABC' letters in it. Private Sub DrawWin(hdc As Long, hwnd As Long) Dim rcWin As RECT Dim hBrush As Long Dim hPen As Long Dim hOldBrush As Long Dim hOldPen As Long GetClientRect hwnd, rcWin 'Create and select new brush and new pen. hBrush = CreateSolidBrush(RGB(240, 240, 255)) hPen = CreatePen(PS_SOLID, 2, RGB(255, 0, 255)) hOldBrush = SelectObject(hdc, hBrush) hOldPen = SelectObject(hdc, hPen) 'Draw the rectangle Rectangle hdc, rcWin.Left + 1, rcWin.Top + 1, rcWin.Right, rcWin.Bottom 'Deselect and delete the pen and brush objects. SelectObject hdc, hOldBrush DeleteObject hPen DeleteObject hBrush SelectObject hdc, hOldPen 'Set the text mode to transparent. SetBkMode hdc, TRANSPARENT 'Select the color of the text SetTextColor hdc, RGB(0, 128, 255) 'Draw the "ABC" letters DrawTextEx hdc, "ABC", 3, rcWin, DT_CENTER Or DT_VCENTER Or DT_SINGLELINE, ByVal 0 End Sub 'MyWndProc is the window procedure of the new window class that we create. 'This procedure receives all messages of the windows we create from the new window class. Public Function MyWndProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Dim hdc As Long Dim ps As PAINTSTRUCT 'Call the default window procedure. MyWndProc = DefWindowProc(hwnd, uMsg, wParam, lParam) If uMsg = WM_PAINT Then 'When we receive the WM_PAINT message, repaint the entire window. hdc = GetDC(hwnd) DrawWin hdc, hwnd ReleaseDC hwnd, hdc End If If uMsg = WM_LBUTTONUP Then 'When you click the left mouse button, the "click !" message will be shown. MsgBox "click !", vbOKOnly End If End Function Public Function CreateMyWindow(x As Long, y As Long, Width As Long, Height As Long, hParent As Long) As Long CreateMyWindow = CreateWindowEx(0, TEST_CLASS, "", WS_CHILD Or WS_BORDER Or WS_VISIBLE, _ x, y, Width, Height, hParent, 0, App.hInstance, ByVal 0) End Function

Download this sample project