Publish a VB written in VB. (API+class+module implements VB prototype.)

stapow

'A total of 6 files

'Project file ClassWindow.vbp
Type=Exe
Module=ModuleMain; ModuleMain.bas
Class=Class_Form; Class_Form.cls
Class=Class_Screen; Class_Screen.cls
Module=ModuleTrusteeship; ModuleTrusteeship.bas
Class=Class_Main; Class_Main.cls
Startup="Sub Main"
HelpFile=""
Title="ClassWindow"
ExeName32="ClassWindow.exe"
Command32=""
Name="ClassWindow"
HelpContextID="0"
CompatibleMode="0"
MajorVer=1
MinorVer=0
RevisionVer=0
AutoIncrementVer=0
ServerSupportFiles=0
VersionCompanyName="FREE"
CompilationType=0
OptimizationType=0
FavorPentiumPro(tm)=-1
CodeViewDebugInfo=0
NoAliasing=-1
BoundsCheck=-1
OverflowCheck=-1
FlPointCheck=-1
FDIVCheck=-1
UnroundedFP=-1
StartMode=0
Unattended=0
Retained=0
ThreadPerObject=0
MaxNumberOfThreads=1

[MS Transaction Server]
AutoRefresh=1

'Standard module ModuleTrusteeship.bas
Attribute VB_Name = "ModuleTrusteeship"
'Management module
Option Explicit
'Structure
Private Type WNDCLASS'form structure
        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 Type POINTAPI'Coordinate structure
        x As Long
        y As Long
End Type
Private Type Msg'message structure
        hWnd As Long
        message As Long
        wParam As Long
        lParam As Long
        time As Long
        pt As POINTAPI
End Type
'API function
Private Declare Function GetModuleHandle Lib "kernel32" Alias ​​"GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Function GetCommandLine Lib "kernel32" Alias ​​"GetCommandLineA" () As String
Private Declare Function RegisterClass Lib "user32" Alias ​​"RegisterClassA" (Class As WNDCLASS) As Long
Private Declare Function CreateWindowEx Lib "user32.dll" 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 GetDC Lib "user32.dll" (ByVal hWnd As Long) As Long
Private Declare Function GetMessage Lib "user32.dll" 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.dll" (lpMsg As Msg) As Long
Private Declare Function DispatchMessage Lib "user32.dll" Alias ​​"DispatchMessageA" (lpMsg As Msg) As Long
Private Declare Function DefWindowProc Lib "user32.dll" 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

'Attributes
Public CommandLine As String'Command line
Public hInstance As Long'Instance
Public ErrDescription As String'error description

'Event hosting form
Private IForm As Class_Form

'Managed function
Public Function Trusteeship(ByRef EventForm As Class_Form) As Boolean
        'Class instantiation
        Set IForm = EventForm
        hInstance = GetModuleHandle(vbNull)'Get the module handle
        CommandLine = GetCommandLine()'Get command line parameters
        Const WinClassName = "MyWinClass"'Define the window class name
        
        Dim WC As WNDCLASS'Set form parameters
        With WC
                .hIcon = 0'The form icon Use LoadIcon(hInstance, ID) to load the RES icon
                .hCursor = 0'The form cursor uses LoadCursor(hInstance, ID) to load the RES cursor
                .lpszMenuName = vbNullString'The form menu uses LoadMenu(hInstance,ID) to load the RES menu
                .hInstance = hInstance'instance
                .cbClsextra = 0
                .cbWndExtra2 = 0
                .style = 0
                .hbrBackground = 16
                .lpszClassName = WinClassName'Class name
                .lpfnwndproc = GetAddress(AddressOf WinProc)'message function address
        End With
        'Registration form class
        If RegisterClass(WC) = 0 Then ErrDescription = "RegisterClass Faild.": Exit Function
        'Get the form handle
        With IForm
                .hWnd = CreateWindowEx(0&, WinClassName, .Caption, .WindowStyle, .Left, .Top, .Width, .Height, 0, 0, hInstance, ByVal 0&)
                If .hWnd = 0 Then ErrDescription = "CreateWindowEx Faild.": Exit Function
                .hDC = GetDC(.hWnd)'Get the GDI handle of the form
                .Visible = True'Display form
               
                Dim WinMsg As Msg'message structure
                'Message loop
                Do While GetMessage(WinMsg, .hWnd, 0, 0)> 0
                        TranslateMessage WinMsg
                        DispatchMessage WinMsg
                        DoEvents
                Loop
        End With
        
        'return value
        Trusteeship = True
End Function

'Form process
Private Function WinProc(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
        Const WM_CREATE =&H1
        Const WM_COMMAND =&H111
        Const WM_CLOSE =&H10
        Const WM_MOUSEMOVE =&H200
        Const WM_SIZE =&H5

        Dim bRet As Boolean'Get the return value
        With IForm
                Select Case wMsg
                Case WM_CREATE
                        Call .ICreate
                Case WM_COMMAND
                        Call .ICommand(wParam, lParam)
                Case WM_CLOSE
                        Call .IUnload(bRet)
                        If bRet = True Then Exit Function
                        DestroyWindow .hWnd'Destroy the window
                Case WM_MOUSEMOVE
                        Call .IMouseMove(LoWord(lParam), HiWord(lParam))
                Case WM_SIZE
                        Call .IResize
                Case Else
                        WinProc = DefWindowProc(hWnd, wMsg, wParam, lParam)
                End Select
        End With
End Function

'Take address
Private Function GetAddress(Address) As Long
        GetAddress = Address
End Function

'Low word
Private Function LoWord(ByVal DWord As Long) As Integer
        If DWord And&H8000&Then
                LoWord = DWord Or&HFFFF0000
        Else
                LoWord = DWord And&HFFFF&
        End If
End Function

'High word
Private Function HiWord(ByVal DWord As Long) As Integer
        HiWord = (DWord And&HFFFF0000)\65536
End Function

stapow

'Standard module ModuleMain.bas

Attribute VB_Name = "ModuleMain"
Option Explicit

Sub Main()
        Dim CMain As Class_Main
        Set CMain = New Class_Main
End Sub

'Class module Class_Main.cls
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1'True
  Persistable = 0'NotPersistable
  DataBindingBehavior = 0'vbNone
  DataSourceBehavior = 0'vbNone
  MTSTransactionMode = 0'NotAnMTSObject
END
Attribute VB_Name = "Class_Main"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

'Event output class
Private WithEvents CForm As Class_Form
Attribute CForm.VB_VarHelpID = -1

'Main class constructor
Private Sub Class_Initialize()
        'Class instantiation
        Set CForm = New Class_Form
        'Setting parameters
        With CForm
                .Width = 200
                .Height = 200
                .Center = True
                .Caption = "Hello!"
        End With
        'Hosted form class
        If Trusteeship(CForm) = False Then Debug.Print ErrDescription
End Sub

'Main class destructor
Private Sub Class_Terminate()
        'Release class
        Set CForm = Nothing
End Sub

'------------------------------------------------- -------------------------------------------------- ------------
'Form event
'------------------------------------------------- -------------------------------------------------- ------------

Private Sub CForm_Create()
        MsgBox CommandLine
        CForm.MostTop = True
End Sub

Private Sub CForm_MouseMove(ByVal x As Integer, ByVal y As Integer)
        CForm.Caption = CStr(x)&"/"&CStr(y)
End Sub

Private Sub CForm_Unload(Cancel As Boolean)
        If MsgBox("Exit?", vbYesNo, "Prompt:") = vbNo Then
                Cancel = True
        Else
                MsgBox "Bye!"
        End If
End Sub

'Class module Class_Screen.cls
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1'True
  Persistable = 0'NotPersistable
  DataBindingBehavior = 0'vbNone
  DataSourceBehavior = 0'vbNone
  MTSTransactionMode = 0'NotAnMTSObject
END
Attribute VB_Name = "Class_Screen"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long

'Screen width
Public Function Width() As Long
        Const SM_CXSCREEN = 0
        Width = GetSystemMetrics(SM_CXSCREEN)
End Function

'Screen height
Public Function Height() As Long
        Const SM_CYSCREEN = 1
        Height = GetSystemMetrics(SM_CYSCREEN)
End Function

stapow

'Class module Class_Form.cls
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1'True
  Persistable = 0'NotPersistable
  DataBindingBehavior = 0'vbNone
  DataSourceBehavior = 0'vbNone
  MTSTransactionMode = 0'NotAnMTSObject
END
Attribute VB_Name = "Class_Form"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'Is the handle valid
Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
'visible
Private Declare Function ShowWindow Lib "user32.dll" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function UpdateWindow Lib "user32.dll" (ByVal hwnd As Long) As Long
'title
Private Declare Function SetWindowText Lib "user32" Alias ​​"SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As Long
'coordinate
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
'style
Private Declare Function SetWindowLong Lib "user32" Alias ​​"SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
'------------------------------------------------- -------------------------------------------------- -------------
'Form style
Public Enum eWindowStyle
        None =&H6000000
        Fixed_Single =&H6C80000
        Sizable =&H6CF0000
        Fixed_Dialog =&H6C80080
        Fixed_ToolWindow =&H6C80000
        Sizable_ToolWindow =&H6CC0000
End Enum

Private mVisible As Boolean'Visible
Private mCaption As String'Title
Private mHeight As Long'Height
Private mWidth As Long'Width
Private mTop As Long'Top side
Private mLeft As Long'Left
Private mMostTop As Boolean'level
Private mCenter As Boolean'Centered
Private mWindowStyle As eWindowStyle'style

Public hwnd As Long'Form handle
Public hDC As Long'Device handle

'event
Public Event Create()
Public Event Resize()
Public Event MouseMove(ByVal x As Integer, ByVal y As Integer)
Public Event Unload(ByRef Cancel As Boolean)
Public Event Command(ByVal wParam As Long, ByVal lParam As Long)

'Screen Object
Private CScreen As Class_Screen

'Constructor
Private Sub Class_Initialize()
        'Class instantiation
        Set CScreen = New Class_Screen
        'Default value
        mWidth = 200
        mHeight = 200
        mWindowStyle = Sizable
        mCaption = "Windows GUI App"
End Sub

'Destructor
Private Sub Class_Terminate()
        'Release class
        Set CScreen = Nothing
End Sub

'=====Event interface======================================== ========================================
Public Sub ICreate()
        RaiseEvent Create
End Sub

Public Sub IMouseMove(ByVal x As Integer, ByVal y As Integer)
        RaiseEvent MouseMove(x, y)
End Sub

Public Function IResize()
        RaiseEvent Resize
End Function

Public Function IUnload(ByRef Cancel As Boolean)
        RaiseEvent Unload(Cancel)
End Function

Public Function ICommand(ByVal wParam As Long, ByVal lParam As Long)
        RaiseEvent Command(wParam, lParam)
End Function


'=====Is it visible======================================== ========================================
Public Property Get Visible() As Boolean
        Visible = mVisible
End Property
Public Property Let Visible(ByVal State As Boolean)
        mVisible = State
        If IsWindow(hwnd) <> 0 Then
                Const SW_NORMAL As Long = 1
                Const SW_HIDE = 0
               
                'Show/hide form
                If State = True Then
                        ShowWindow hwnd, SW_NORMAL
                Else
                        ShowWindow hwnd, SW_HIDE
                End If
                'Update form
                UpdateWindow hwnd
        End If
End Property

'=====Title text======================================== ========================================
Public Property Get Caption() As String
        Caption = mCaption
End Property

Public Property Let Caption(ByVal Text As String)
        mCaption = Text
        If IsWindow(hwnd) <> 0 Then SetWindowText hwnd, Text
End Property


'=====Form height======================================= =========================================
Public Property Get Height() As Long
        Height = mHeight
End Property

Public Property Let Height(ByVal Value As Long)
        mHeight = Value
        Call SetWinPos
End Property

'=====Form width======================================= =========================================
Public Property Get Width() As Long
        Width = mWidth
End Property

Public Property Let Width(ByVal Value As Long)
        mWidth = Value
        Call SetWinPos
End Property

'=====The top edge of the form ====================================== ==========================================
Public Property Get Top() As Long
        Top = mTop
End Property

Public Property Let Top(ByVal Value As Long)
        mTop = Value
        Call SetWinPos
End Property

'=====Left side of the form ======================================= =========================================
Public Property Get Left() As Long
        Left = mLeft
End Property

Public Property Let Left(ByVal Value As Long)
        mLeft = Value
        Call SetWinPos
End Property

'=====Top of the form ======================================= =========================================
Public Property Get MostTop() As Boolean
        MostTop = mMostTop
End Property

Public Property Let MostTop(ByVal Value As Boolean)
        mMostTop = Value
        Call SetWinPos
End Property

'=====Form centered======================================== =========================================
Public Property Get Center() As Boolean
        Center = mCenter
End Property

Public Property Let Center(ByVal Value As Boolean)
        mCenter = Value
        mLeft = (CScreen.Width-mWidth)\2
        mTop = (CScreen.Height-mHeight)\2
        Call SetWinPos
End Property

'=====Tool function======================================== ========================================
Private Sub SetWinPos()
        Const HWND_TOPMOST As Long = -1
        Const SWP_SHOWWINDOW =&H40
        If IsWindow(hwnd) <> 0 Then
                SetWindowPos hwnd, IIf(mMostTop = True, HWND_TOPMOST, 0), mLeft, mTop, mWidth, mHeight, SWP_SHOWWINDOW
                'Update form
                UpdateWindow hwnd
        End If
End Sub

'=====Form style======================================= =========================================
Public Property Get WindowStyle() As eWindowStyle
        WindowStyle = mWindowStyle
End Property

Public Property Let WindowStyle(ByVal Value As eWindowStyle)
        mWindowStyle = Value
        
        Const GWL_STYLE = (-16)
        If IsWindow(hwnd) <> 0 Then
                SetWindowLong hwnd, GWL_STYLE, mWindowStyle
                'Update form
                UpdateWindow hwnd
        End If
End Property


'================================================ =================================
'Note: Because VB cannot support multithreading, this file cannot run normally after compilation (for COM reasons), but,
'Because it is interpreted and executed in the IDE, it can run normally. This example demonstrates an idea and proves that VB can also do
'It's a completely class-based approach like C++ and Delphi.
'================================================ =================================

minlichao

Great～fun～don’t understand～o.o

Looks like SDK programming similar to VC

But where is multithreading? And I have always been scared of COM

zzclark

When calling API "GetCommandLine", VB illegal operation...

In the Trusteeship function~

yangmier

Admire, pay attention

namezhangyu

What is it for

waftwind

vb written by vb? Haven't heard of it. Collect it first and watch it slowly.

zombiema

Just use API to encapsulate a form.

stapow

to: upstairs,
Yes, the same can be said,
However, encapsulating the form class is not as easy as encapsulating other controls.
Mainly to solve the problem of message blocking and thread conflicts
I haven't thought of a better way to solve these two points.
There is really no time now, I plan to write in C++ when I have time, see if I can
Solve this problem.