发布一个VB写的VB.(API+类+模块实现VB原型.)

stapow · 发表于 2020-9-25 17:00:01

'共6个文件

'工程文件 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

'标准模块 ModuleTrusteeship.bas
Attribute VB_Name = "ModuleTrusteeship"
'托管模块
Option Explicit
'结构体
Private Type WNDCLASS '窗体结构
      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 '坐标结构
      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
'API函数
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

'属性
Public CommandLine As String '命令行
Public hInstance       As Long '实例
Public ErrDescription As String '错误描述

'事件托管窗体
Private IForm As Class_Form

'托管函数
Public Function Trusteeship(ByRef EventForm As Class_Form) As Boolean
      '类实例化
      Set IForm = EventForm
      hInstance = GetModuleHandle(vbNull)    '获取模块句柄
      CommandLine = GetCommandLine()       '获取命令行参数
      Const WinClassName = "MyWinClass"    '定义窗口类名

      Dim WC As WNDCLASS '设置窗体参数
      With WC
            .hIcon = 0                                     '窗体图标使用 LoadIcon(hInstance, ID) 加载RES图标
            .hCursor = 0                                  '窗体光标使用 LoadCursor(hInstance, ID) 加载RES光标
            .lpszMenuName = vbNullString                   '窗体菜单使用 LoadMenu(hInstance,ID) 加载RES菜单
            .hInstance = hInstance                         '实例
            .cbClsextra = 0
            .cbWndExtra2 = 0
            .style = 0
            .hbrBackground = 16
            .lpszClassName = WinClassName                '类名
            .lpfnwndproc = GetAddress(AddressOf WinProc) '消息函数地址
      End With
      '注册窗体类
      If RegisterClass(WC) = 0 Then ErrDescription = "RegisterClass Faild.": Exit Function
      '获取窗体句柄
      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)    '获取窗体GDI句柄
            .Visible = True       '显示窗体

            Dim WinMsg As Msg    '消息结构
            '消息循环
            Do While GetMessage(WinMsg, .hWnd, 0, 0) > 0
                     TranslateMessage WinMsg
                     DispatchMessage WinMsg
                     DoEvents
            Loop
      End With

      '返回值
      Trusteeship = True
End Function

'窗体过程
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 '取返回值
      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 '销毁窗体
            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

'取地址
Private Function GetAddress(Address) As Long
      GetAddress = Address
End Function

'低字
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

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

stapow · 发表于 2020-9-25 17:15:01

'标准模块 ModuleMain.bas

Attribute VB_Name = "ModuleMain"
Option Explicit

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

'类模块 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

'事件输出类
Private WithEvents CForm As Class_Form
Attribute CForm.VB_VarHelpID = -1

'主类构造函数
Private Sub Class_Initialize()
      '类实例化
      Set CForm = New Class_Form
      '设置参数
      With CForm
            .Width = 200
            .Height = 200
            .Center = True
            .Caption = "Hello!"
      End With
      '托管窗体类
      If Trusteeship(CForm) = False Then Debug.Print ErrDescription
End Sub

'主类析构函数
Private Sub Class_Terminate()
      '释放类
      Set CForm = Nothing
End Sub

'---------------------------------------------------------------------------------------------------------------
'窗体类事件
'---------------------------------------------------------------------------------------------------------------

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_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

'屏幕宽度
Public Function Width() As Long
      Const SM_CXSCREEN = 0
      Width = GetSystemMetrics(SM_CXSCREEN)
End Function

'屏幕高度
Public Function Height() As Long
      Const SM_CYSCREEN = 1
      Height = GetSystemMetrics(SM_CYSCREEN)
End Function

stapow · 发表于 2020-9-25 18:30:01

'类模块 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
'句柄是否有效
Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
'可见
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
'标题
Private Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As Long
'坐标
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
'样式
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
'----------------------------------------------------------------------------------------------------------------
'窗体样式
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    '可见
Private mCaption       As String    '标题
Private mHeight       As Long       '高度
Private mWidth       As Long       '宽度
Private mTop          As Long       '顶边
Private mLeft          As Long       '左边
Private mMostTop       As Boolean    '层次
Private mCenter       As Boolean    '居中
Private mWindowStyle As eWindowStyle '样式

Public hwnd          As Long       '窗体句柄
Public hDC             As Long       '设备句柄

'事件
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)

'屏幕对象
Private CScreen As Class_Screen

'构造函数
Private Sub Class_Initialize()
      '类实例化
      Set CScreen = New Class_Screen
      '缺省值
      mWidth = 200
      mHeight = 200
      mWindowStyle = Sizable
      mCaption = "Windows GUI App"
End Sub

'析构函数
Private Sub Class_Terminate()
      '释放类
      Set CScreen = Nothing
End Sub

'=====事件接口===================================================================================
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

'=====是否可见===================================================================================
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

            '显示/隐藏窗体
            If State = True Then
                     ShowWindow hwnd, SW_NORMAL
            Else
                     ShowWindow hwnd, SW_HIDE
            End If
            '更新窗体
            UpdateWindow hwnd
      End If
End Property

'=====标题文字===================================================================================
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

'=====窗体高度===================================================================================
Public Property Get Height() As Long
      Height = mHeight
End Property

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

'=====窗体宽度===================================================================================
Public Property Get Width() As Long
      Width = mWidth
End Property

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

'=====窗体顶边===================================================================================
Public Property Get Top() As Long
      Top = mTop
End Property

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

'=====窗体左边===================================================================================
Public Property Get Left() As Long
      Left = mLeft
End Property

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

'=====窗体置顶===================================================================================
Public Property Get MostTop() As Boolean
      MostTop = mMostTop
End Property

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

'=====窗体居中===================================================================================
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

'=====工具函数===================================================================================
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
            '更新窗体
            UpdateWindow hwnd
      End If
End Sub

'=====窗体样式===================================================================================
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
            '更新窗体
            UpdateWindow hwnd
      End If
End Property

'==================================================================================
'说明:由于VB不能支持多线程,所以这个文件在编译以后不能正常运行(COM的原因),不过,
'在IDE中由于是解释执行,是可以正常运行的,这个例子是演示了一种思想,证明VB也可以做
'成和C++,Delphi一样的完全基于类的方式.
'==================================================================================

minlichao · 发表于 2020-9-26 00:15:01

厉害～好玩～看不懂～o.o

貌似是类似VC的SDK编程

可是多线程是哪里啊？还有我一直对COM很恐惧

zzclark · 发表于 2020-9-26 14:45:01

在调用API"GetCommandLine"的时候，VB非法操作了...

在Trusteeship函数里~

yangmier · 发表于 2020-9-26 15:15:01

佩服啊,关注

namezhangyu · 发表于 2020-9-26 16:00:02

做什么用的啊

waftwind · 发表于 2020-9-26 19:00:02

vb寫的vb?沒聽過呢。先收藏了，慢慢看。

zombiema · 发表于 2020-9-27 17:00:01

只是用API封装一个窗体而已吧

stapow · 发表于 2020-9-27 17:15:01

to:楼上的,
是的,也可以这么说,
但是,封装窗体类没有封装别的控件那么容易,
主要是要解决消息阻塞的问题,还有线程冲突
这两点我都还没有想到比较好的方法解决,
现在实在没空,有空打算用C++写,看能不能
解决这方面的问题.

		自动登录	找回密码
密码			立即注册