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

Question

'共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

Answer 1

'标准模块 ModuleMain.basAttribute VB_Name = "ModuleMain"
Option ExplicitSub 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 SubPrivate Sub CForm_MouseMove(ByVal x As Integer, ByVal y As Integer)
        CForm.Caption = CStr(x) & "/" & CStr(y)
End SubPrivate 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

Answer 2

'类模块 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 EnumPrivate 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 SubPublic Sub IMouseMove(ByVal x As Integer, ByVal y As Integer)
        RaiseEvent MouseMove(x, y)
End SubPublic Function IResize()
        RaiseEvent Resize
End FunctionPublic Function IUnload(ByRef Cancel As Boolean)
        RaiseEvent Unload(Cancel)
End FunctionPublic 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 PropertyPublic 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 PropertyPublic Property Let Height(ByVal Value As Long)
        mHeight = Value
        Call SetWinPos
End Property'=====窗体宽度===================================================================================
Public Property Get Width() As Long
        Width = mWidth
End PropertyPublic Property Let Width(ByVal Value As Long)
        mWidth = Value
        Call SetWinPos
End Property'=====窗体顶边===================================================================================
Public Property Get Top() As Long
        Top = mTop
End PropertyPublic Property Let Top(ByVal Value As Long)
        mTop = Value
        Call SetWinPos
End Property'=====窗体左边===================================================================================
Public Property Get Left() As Long
        Left = mLeft
End PropertyPublic Property Let Left(ByVal Value As Long)
        mLeft = Value
        Call SetWinPos
End Property'=====窗体置顶===================================================================================
Public Property Get MostTop() As Boolean
        MostTop = mMostTop
End PropertyPublic Property Let MostTop(ByVal Value As Boolean)
        mMostTop = Value
        Call SetWinPos
End Property'=====窗体居中===================================================================================
Public Property Get Center() As Boolean
        Center = mCenter
End PropertyPublic 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 PropertyPublic 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一样的完全基于类的方式.
'==================================================================================

Answer 3

厉害～好玩～看不懂～o.o貌似是类似VC的SDK编程可是多线程是哪里啊？还有我一直对COM很恐惧

Answer 4

在调用API"GetCommandLine"的时候，VB非法操作了...在Trusteeship函数里~

Answer 5

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

Answer 6

NB帮着打了个包:http://www.m5home.com/soft/ClassWindow.rar

Answer 7

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

Answer 8

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

Answer 9

VB主程序应该就是用VC++写的吧

Answer 10

VB6的IDE的确是VC++编译的,使用的是C++语言这样说应该没错吧.

Answer 11

程序报错了:C:\DOCUME~1\acmilan\LOCALS~1\Temp\d62e_appcompat.txt

Answer 12

NB 帮着打了个包: http://www.m5home.com/soft/ClassWindow.rar这个网站怎么打不开了啊

Answer 13

这里面哪有多线程哦：），LZ用VB写了一个窗体，但这个窗体在事件方面好像没有写完全，
还是LZ在那里遇到了什么问题呢：），

Answer 14

http://download.pchome.net/development/developtools/debug/10946.html用VB6开发的VB！具有跟VB一样的开发环境IDE，里面也有窗体编辑器、代码编辑器、类查看器等等，在里面写一个表达式计算器只需要一行代码，而且这个IDE主要是用来控制另一个程序运作的！可以编译成EXE文件哦！（使用BASIC语言写代码）看看VB6的厉害吧！