- 1) Создайте проект и удалите из него Form1.
- Код: Выделить всё
Private Declare Function RegisterClassEx Lib "user32" Alias "RegisterClassExA" (pcWndClassEx As WNDCLASSEX) As Integer
Private Declare Function UnregisterClass Lib "user32" Alias "UnregisterClassA" (ByVal lpClassName As String, ByVal hInstance As Long) As Long
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, ByVal lpParam As Long) As Long
Private Declare Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Long) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) 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 LoadIcon Lib "user32" Alias "LoadIconA" (ByVal hInstance As Long, ByVal lpIconName As Long) As Long
Private Declare Function TranslateMessage Lib "user32" (lpMsg As MSG) As Long
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 DispatchMessage Lib "user32" Alias "DispatchMessageA" (lpMsg As MSG) As Long
Private Declare Sub PostQuitMessage Lib "user32" (ByVal nExitCode As Long)
Private Const WS_OVERLAPPEDWINDOW = &HC00000 Or &H80000 Or &H40000 Or &H10000 Or &H20000
Public Enum WindowCmd
Show = 5&
Hide = 0&
Maximize = 3&
Minimize = 6&
ShowMaximized = 3&
ShowMinimized = 2&
ShowDefault = 10&
ShowNormal = 1&
End Enum
Public Enum DefaultCursors
Arrow = 100&
Arrow2 = 32512&
Beam = 101&
Beam2 = 32513&
Hourglass = 102&
Hourglass2 = 32514&
Cross = 103&
Cross2 = 32515&
UpArrow = 104&
UpArrow2 = 32516&
Pen = 113&
Pen2 = 32631&
SizeNWSE = 105&
SizeNWSE2 = 32642&
SizeNESW = 106&
SizeNESW2 = 32643&
SizeWE = 107&
SizeWE2 = 32644&
SizeNS = 108&
SizeNS2 = 32645&
SizeAll = 109&
SizeAll2 = 132646
NoDrop = 110&
NoDrop2 = 32648&
SelectLink = 114&
SelectLink2 = 32649&
ArrowHourglass = 111&
ArrowHourglass2 = 32650&
ArrowQuestion = 112&
ArrowQuestion2 = 32651&
Rectable = 115&
ArrowCD = 116&
ArrowCD2 = 32663&
ScrollNS = 32652&
ScrollWE = 32653&
ScrollAll = 32654&
ScrollN = 32655&
ScrollS = 32656&
ScrollW = 32657&
ScrollE = 32658&
ScrollNW = 32659&
ScrollNE = 32660&
ScrollSW = 32661&
ScrollSE = 32662&
End Enum
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 LOGBRUSH
lbStyle As Long
lbColor As Long
lbHatch As Long
End Type
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type MSG
hwnd As Long
message As Long
wParam As Long
lParam As Long
time As Long
pt As POINTAPI
End Type
Public Sub Main()
Dim tMsg As MSG
Create "vbapiform", "ApiWindow", &H808080, Arrow2, 0, 0, 0, 300, 200, ShowNormal
Do While CBool(GetMessage(tMsg, 0, 0, 0))
TranslateMessage tMsg
DispatchMessage tMsg
Loop
UnregClass "vbapiform"
End Sub
Public Function Create(ByVal sClassName As String, ByVal Caption As String, ByVal BackColor As Long, ByVal Cursor As DefaultCursors, ByVal Icon As Long, ByVal x As Long, ByVal y As Long, ByVal Width As Long, ByVal Height As Long, ByVal wCmd As WindowCmd)
If Not RegClass(sClassName, BackColor, Cursor, Icon, AddressOf SetWinProc) Then Exit Function
Create = CreateWindow(sClassName, Caption, x, y, Width, Height)
If Create = 0 Then
UnregClass sClassName
Exit Function
End If
ShowWindow Create, wCmd
End Function
Private Function SetWinProc(ByVal hwnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Select Case MSG
Case 2
PostQuitMessage 0
End Select
SetWinProc = DefWindowProc(hwnd, MSG, wParam, lParam)
End Function
Private Function CreateWindow(ByVal sClassName As String, ByVal Caption As String, ByVal x As Long, ByVal y As Long, ByVal Width As Long, ByVal Height As Long) As Long
CreateWindow = CreateWindowEx(0, sClassName, Caption, WS_OVERLAPPEDWINDOW, x, y, Width, Height, 0, 0, App.hInstance, 0)
End Function
Private Function RegClass(ByVal sClassName As String, ByVal BackColor As Long, ByVal Cursor As Long, ByVal Icon As Long, ByVal WndProc As Long) As Boolean
Dim pcWnd As WNDCLASSEX
Dim cBrush As LOGBRUSH
cBrush.lbColor = BackColor
With pcWnd
.cbSize = Len(pcWnd)
.hInstance = App.hInstance
.lpszClassName = sClassName
.hCursor = LoadCursor(0, Cursor)
.hbrBackground = CreateBrushIndirect(cBrush)
.lpfnWndProc = WndProc
.Style = 3
If Icon = 0 Then
.hIcon = LoadIcon(0, 100)
Else
.hIcon = Icon
End If
End With
RegClass = CBool(RegisterClassEx(pcWnd))
End Function
Private Sub UnregClass(ByVal sClassName As String)
n = UnregisterClass(sClassName & Chr$(0), App.hInstance)
End Sub
2) Создайте Модуль и скопируйте туда этот код:
3) Запускаемый объект: поставьте Sub Main, запустите проект.
