Visual Basic Programming Code Examples

Creating windows and controls using API calls The following code demonstrates how to create a form and a two labels using only API calls. Note, on NT/2000 machines VBA programmers can replace App.hInstance with the value 0&. The code demonstrates several useful techiques including subclassing. Option Explicit 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 Declare Function LoadIcon Lib "user32" Alias "LoadIconA" (ByVal hInstance As Long, ByVal lpIconName As String) As Long Private Declare Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As String) As Long Private Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long Private Declare Function RegisterClassEx Lib "user32" Alias "RegisterClassExA" (pcWndClassEx As WNDCLASSEX) As Integer Private Declare Function ShowWindow Lib "user32" (ByVal lhwnd As Long, ByVal nCmdShow As Long) As Long Private Declare Function UpdateWindow Lib "user32" (ByVal lhwnd As Long) As Long Private Declare Function SetFocus Lib "user32" (ByVal lhwnd As Long) As Long Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal lhwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Private Declare Function DefWindowProc Lib "user32" Alias "DefWindowProcA" (ByVal lhwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Private Declare Function GetMessage Lib "user32" Alias "GetMessageA" (lpMsg As MSG, ByVal lhwnd 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 Declare Function BeginPaint Lib "user32" (ByVal lhwnd As Long, lpPaint As PAINTSTRUCT) As Long Private Declare Function EndPaint Lib "user32" (ByVal lhwnd As Long, lpPaint As PAINTSTRUCT) As Long Private Declare Function GetClientRect Lib "user32" (ByVal lhwnd As Long, lpRect As RECT) 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 Type WNDCLASSEX cbSize As Long 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 String lpszClassName As String hIconSm As Long End Type Private Type CREATESTRUCT lpCreateParams As Long hInstance As Long hMenu As Long hWndParent As Long cy As Long cx As Long y As Long x As Long style As Long lpszName As String lpszClass As String ExStyle As Long End Type Private Type POINTAPI x As Long y As Long End Type Private Type MSG lhwnd As Long tMessage As Long wParam As Long lParam As Long time As Long pt As POINTAPI End Type Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Type PAINTSTRUCT hdc As Long fErase As Long rcPaint As RECT fRestore As Long fIncUpdate As Long rgbReserved(32) As Byte 'this was declared incorrectly in VB API viewer End Type Private Const WS_VISIBLE As Long = &H10000000 Private Const WS_VSCROLL As Long = &H200000 Private Const WS_TABSTOP As Long = &H10000 Private Const WS_THICKFRAME As Long = &H40000 Private Const WS_MAXIMIZE As Long = &H1000000 Private Const WS_MAXIMIZEBOX As Long = &H10000 Private Const WS_MINIMIZE As Long = &H20000000 Private Const WS_MINIMIZEBOX As Long = &H20000 Private Const WS_SYSMENU As Long = &H80000 Private Const WS_BORDER As Long = &H800000 Private Const WS_CAPTION As Long = &HC00000 ' WS_BORDER Or WS_DLGFRAME Private Const WS_CHILD As Long = &H40000000 Private Const WS_CHILDWINDOW As Long = (WS_CHILD) Private Const WS_CLIPCHILDREN As Long = &H2000000 Private Const WS_CLIPSIBLINGS As Long = &H4000000 Private Const WS_DISABLED As Long = &H8000000 Private Const WS_DLGFRAME As Long = &H400000 Private Const WS_EX_ACCEPTFILES As Long = &H10& Private Const WS_EX_DLGMODALFRAME As Long = &H1& Private Const WS_EX_NOPARENTNOTIFY As Long = &H4& Private Const WS_EX_TOPMOST As Long = &H8& Private Const WS_EX_TRANSPARENT As Long = &H20& Private Const WS_GROUP As Long = &H20000 Private Const WS_HSCROLL As Long = &H100000 Private Const WS_ICONIC As Long = WS_MINIMIZE Private Const WS_OVERLAPPED As Long = &H0& Private Const WS_OVERLAPPEDWINDOW As Long = (WS_OVERLAPPED Or WS_CAPTION Or WS_SYSMENU Or WS_THICKFRAME Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX) Private Const WS_POPUP As Long = &H80000000 Private Const WS_POPUPWINDOW As Long = (WS_POPUP Or WS_BORDER Or WS_SYSMENU) Private Const WS_SIZEBOX As Long = WS_THICKFRAME Private Const WS_TILED As Long = WS_OVERLAPPED Private Const WS_TILEDWINDOW As Long = WS_OVERLAPPEDWINDOW Private Const CW_USEDEFAULT As Long = &H80000000 Private Const CS_HREDRAW As Long = &H2 Private Const CS_VREDRAW As Long = &H1 Private Const IDI_APPLICATION As Long = 32512& Private Const IDC_ARROW As Long = 32512& Private Const WHITE_BRUSH As Integer = 0 Private Const BLACK_BRUSH As Integer = 4 Private Const WM_KEYDOWN As Long = &H100 Private Const WM_CLOSE As Long = &H10 Private Const WM_DESTROY As Long = &H2 Private Const WM_PAINT As Long = &HF Private Const SW_SHOWNORMAL As Long = 1 Private Const DT_CENTER As Long = &H1 Private Const DT_SINGLELINE As Long = &H20 Private Const DT_VCENTER As Long = &H4 Private Const WS_EX_STATICEDGE = &H20000 Private Const SW_NORMAL = 1 'Start running the routine from here Sub Main() CreateForm End Sub Private Sub CreateForm() Const CLASSNAME = "Custom_Form" Const TITLE = "TITLE" Dim lhwndWindow As Long, lHwndLabel As Long Dim tCreate As CREATESTRUCT Dim tWinClass As WNDCLASSEX Dim tMessage As MSG 'Set up and register window class tWinClass.cbSize = Len(tWinClass) tWinClass.style = CS_HREDRAW Or CS_VREDRAW tWinClass.lpfnWndProc = FunctionPointer(AddressOf WindowProc) tWinClass.cbClsExtra = 0& tWinClass.cbWndExtra = 0& tWinClass.hInstance = App.hInstance tWinClass.hIcon = LoadIcon(App.hInstance, IDI_APPLICATION) tWinClass.hCursor = LoadCursor(App.hInstance, IDC_ARROW) tWinClass.hbrBackground = GetStockObject(WHITE_BRUSH) tWinClass.lpszMenuName = 0& tWinClass.lpszClassName = CLASSNAME tWinClass.hIconSm = LoadIcon(App.hInstance, IDI_APPLICATION) RegisterClassEx tWinClass 'Create a window lhwndWindow = CreateWindowEx(0&, CLASSNAME, TITLE, WS_OVERLAPPEDWINDOW, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, 0&, 0&, App.hInstance, 0&) 'Show the window ShowWindow lhwndWindow, SW_SHOWNORMAL UpdateWindow lhwndWindow SetFocus lhwndWindow 'Create a label lHwndLabel = CreateWindowEx(WS_EX_STATICEDGE Or WS_EX_TRANSPARENT, "STATIC", "Label Created on Window", WS_CHILD, 200, 0, 300, 50, lhwndWindow, 0, App.hInstance, tCreate) 'Show label ShowWindow lHwndLabel, SW_NORMAL 'Message loop Do While 0 <> GetMessage(tMessage, 0&, 0&, 0&) 'Retrieve a message from the calling thread�s message queue TranslateMessage tMessage 'Translate virtual-key messages into character messages (character messages are posted to the calling thread's message queue). DispatchMessage tMessage 'Dispatch message to window procedure (WindowProc) Loop End Sub 'Message handler for this window Private Function WindowProc(ByVal lhwnd As Long, ByVal tMessage As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Dim tPaint As PAINTSTRUCT Dim tRect As RECT Dim lHdc As Long Dim sCaption As String Select Case tMessage Case WM_PAINT lHdc = BeginPaint(lhwnd, tPaint) Call GetClientRect(lhwnd, tRect) sCaption = "Label Printed on Window" Call DrawText(lHdc, sCaption, Len(sCaption), tRect, DT_SINGLELINE Or DT_CENTER Or DT_VCENTER) Call EndPaint(lhwnd, tPaint) Exit Function Case WM_KEYDOWN 'Close window when the user presses a key Call PostMessage(lhwnd, WM_CLOSE, 0, 0) Exit Function Case WM_DESTROY 'Fired when the X button is pressed PostQuitMessage 0& Exit Function End Select 'pass all other messages to default window procedure WindowProc = DefWindowProc(lhwnd, tMessage, wParam, lParam) End Function 'Returns the value from the AddressOf unary operator. Function FunctionPointer(ByVal lPtr As Long) As Long FunctionPointer = lPtr End Function