Main Page
Search
Blog
FAQ
TOP 10
Links
Awards
Pad Files
Contact
About...

All Utilities
Password Tools
Browser Tools
Programmer Tools
Network Tools
Components
Panel
Code Samples
Articles
Registering and using a new window class 

'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