偶写的一个基于类的Basic[欢迎大家同共研究,共同完善]

Question

一开始是想写一个像Java一样的基于类的Basic,现在写得还不是很完善,
我想把VB中的通用组件都封装成独立的类,在需要使用的时候添加到工程
中就行了,可是,在做Hook回钓时出现了一点麻烦,写的代码在IDE中运行
正常,编译出来就不行了,现在用的是一个标准模块实现的子类,希望那位
大侠能指点一下.这个代码只实现了窗体,前一个版本的还写出Screen(屏幕)类,Button(按钮)
....希望大家能共同努力,让VB能走得更远.

Answer 1

'Module_Main [标准模块] 程序入口
Option Explicit
'定义主类
Private CMain As Class_MainSub main()
        '主类实例化
        Set CMain = New Class_Main
End Sub
'标准模块 [子类化过程]
Option Explicit
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
'窗体消息
Public Function WinProc(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
        '消息返回原地址
        WinProc = DefWindowProc(hwnd, wMsg, wParam, lParam)
End Function'Class_Main [类模块] 相当于VBIDE中的事件和属性
Option Explicit
'窗体类事件接管
Private WithEvents CWindow As Class_Form'构造函数
Private Sub Class_Initialize()
        '类实例化
        Set CWindow = New Class_Form
        
        With CWindow
                '创建窗体
                .Create
                '设置属性
                .Width = 320
                .Height = 240
        End With
End Sub'析构函数
Private Sub Class_Terminate()
        '释放类
        Set CWindow = Nothing
End Sub'鼠标移动
Private Sub CWindow_MouseMove(ByVal Button As Integer, ByVal X As Single, ByVal Y As Single)
'        Debug.Print Button, X, Y
        CWindow.Caption = X & "/" & Y
End Sub'窗体卸载
Private Sub CWindow_Unload(Cancel As Boolean)
        Cancel = True
End Sub

Answer 2

'Class_Form 窗体类[未完善]
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
Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type
'================================================================================
'                               外部常数
'================================================================================
Private Const WS_SYSMENU As Long = &H80000
Private Const WS_CAPTION As Long = &HC00000
Private Const WS_MINIMIZE As Long = &H20000000
Private Const WS_MINIMIZEBOX As Long = &H20000
Private Const WS_MAXIMIZEBOX As Long = &H10000
Private Const WS_THICKFRAME As Long = &H40000
Private Const WS_SIZEBOX As Long = WS_THICKFRAMEPrivate Const WindowStyle = WS_SYSMENU + WS_CAPTION + WS_MINIMIZEBOX + WS_MAXIMIZEBOX + WS_SIZEBOXPrivate Const SW_NORMAL As Long = 1
Private Const HWND_TOPMOST As Long = -1
Private WinHwnd As Long, WndDC As Long
Private WC As WNDCLASS
Private WinMsg As MsgPrivate Const WM_CLOSE As Long = &H10
Private Const WM_DESTROY As Long = &H2
Private Const WM_MOUSEMOVE As Long = &H200
Private Const WM_SIZE As Long = &H5
Private Const WM_CREATE As Long = &H1
Private Const WM_COMMAND As Long = &H111Private Const MF_POPUP As Long = &H10&
Private Const MF_APPEND As Long = &H100&
Private Const MF_STRING As Long = &H0&
Private Const MF_SEPARATOR As Long = &H800&
'================================================================================
'                               外部函数
'================================================================================
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 ShowWindow Lib "user32.dll" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function CreateMenu Lib "user32.dll" () As Long
Private Declare Function CreatePopupMenu Lib "user32.dll" () As Long
Private Declare Function AppendMenu Lib "user32.dll" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As Any) As Long
Private Declare Function SetMenu Lib "user32.dll" (ByVal hwnd As Long, ByVal hMenu As Long) As LongPrivate Declare Function UpdateWindow Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function DestroyWindow Lib "user32.dll" (ByVal hwnd As Long) As LongPrivate 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 Sub PostQuitMessage Lib "user32.dll" (ByVal nExitCode 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 SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As LongPrivate Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As Long
'================================================================================
'                               事件定义
'================================================================================
Event MouseMove(ByVal Button As Integer, ByVal X As Single, ByVal Y As Single)
Event Unload(ByRef Cancel As Boolean)'================================================================================
'                               属性变量
'================================================================================
Private mCaption As String
Private mLeft As Long
Private mTop As Long
Private mWidth As Long
Private mHeight As Long
Private mVisible As Boolean
Private mTopMost As Boolean'================================================================================
'                               公有函数
'================================================================================
'创建窗体
Public Sub Create()
        Const WinClassName As String = "From"
        
        '窗体结构
        With WC
                .lpfnwndproc = GetAddress(AddressOf WinProc)
                .cbClsextra = 0
                .cbWndExtra2 = 0
                .hInstance = App.hInstance
                .lpszMenuName = vbNullString
                .style = 0
                .hbrBackground = 16
                .lpszClassName = WinClassName
        End With
        
        '注册窗体类
        If RegisterClass(WC) = 0 Then
                Debug.Print "RegisterClass Faild."
                Exit Sub
        Else
                '创建窗体
                WinHwnd = CreateWindowEx(0&, WinClassName, Caption, WindowStyle, Left, Top, Width, Height, 0, 0, App.hInstance, ByVal 0&)
                If WinHwnd = 0 Then
                        Debug.Print "CreateWindowEx Faild."
                Else
                        '获取窗体设备句柄
                        WndDC = GetDC(WinHwnd)
                        '显示窗体及置顶
                        ShowWindow WinHwnd, SW_NORMAL Or IIf(TopMost = True, HWND_TOPMOST, 0)
                        '更新窗体
                        UpdateWindow WinHwnd
                        '消息循环
                        Do While GetMessage(WinMsg, WinHwnd, 0, 0) > 0  '获取消息
                                TranslateMessage WinMsg                 '翻译消息
                                
                                With WinMsg
                                        WinMsg = Proc(.hwnd, .message, .wParam, .lParam)
                                End With
                                
                                DispatchMessage WinMsg                  '发送消息
                                DoEvents                                '等待完成
                        Loop
                End If
        End If
End Sub

Answer 3

'================================================================================
'                               私有函数
'================================================================================
'取地址
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 FunctionPrivate Function HiWord(ByVal DWord As Long) As Integer
        HiWord = (DWord And &HFFFF0000) \ 65536
End Function'销毁消息
Private Function DelMsg(Optional ByVal wMsg As Long = 0, Optional ByVal wParam As Long = 0, Optional ByVal lParam As Long = 0) As Msg
        With DelMsg
                .message = wMsg
                .wParam = wParam
                .lParam = lParam
        End With
End Function'窗体消息
Private Function Proc(ByVal hwnd As Long, ByRef wMsg As Long, ByRef wParam As Long, ByRef lParam As Long) As Msg
        Dim RetParam As Boolean
        
        Select Case wMsg
        Case WM_CREATE          '窗体创建
        
'                '创建菜单
'                '定义菜单项常数
'                Const DM_MENU_ABOUT = 1
'                Const DM_MENU_EXIT = 2
'                Dim hMenu As Long, hSubMenu As Long
'                '创建菜单
'                hMenu = CreateMenu()
'                '创建子菜单
'                hSubMenu = CreatePopupMenu()
'                '主菜单内容
'                AppendMenu hMenu, MF_STRING Or MF_POPUP, hSubMenu, "&File"
'                '子菜单内容
'                AppendMenu hSubMenu, MF_STRING, DM_MENU_ABOUT, "&About"
'                AppendMenu hSubMenu, MF_STRING, DM_MENU_EXIT, "E&xit.."
'                '分隔线
'                AppendMenu hSubMenu, MF_SEPARATOR, -1, 0&
'                AppendMenu hSubMenu, MF_STRING, 3, "Add other items here"
'                '将菜单置入窗体
'                SetMenu hwnd, hMenu
        Case WM_COMMAND         '窗体消息
'                '判断菜单消息
'                Select Case wParam
'                Case DM_MENU_EXIT '退出菜单项
'                        '向窗体发送退出消息
'                        SendMessage hwnd, WM_CLOSE, ByVal 0&, ByVal 0&
'                Case DM_MENU_ABOUT'关于菜单项'                End Select
        Case WM_CLOSE           '窗体关闭
                Stop
                
                '触发事件
                RaiseEvent Unload(RetParam)
                
                If RetParam = True Then
                        With DelMsg
                                wMsg = .message
                                wParam = .wParam
                                lParam = .lParam
                        End With
                Else
                        '销毁窗体
                        DestroyWindow WinHwnd
                End If
        Case WM_DESTROY         '窗体销毁
                PostQuitMessage 0
        Case WM_MOUSEMOVE       '鼠标移动
                '更新窗体
                UpdateWindow WinHwnd
                'wParam = 鼠标按键
                'LoWord(lParam) = 光标X坐标
                'HiWord(lParam) = 光标Y坐标
                
                '触发事件
                RaiseEvent MouseMove(wParam, LoWord(lParam), HiWord(lParam))
                
                
                
        Case WM_SIZE            '调整大小事件
                
'        Case Else
'                '消息返回原地址
'                WinProc = DefWindowProc(hwnd, wMsg, wParam, lParam)
        End Select
        
        
        With Proc
                .hwnd = hwnd
                .message = wMsg
                .wParam = wParam
                .lParam = lParam
        End With
End Function
'================================================================================
'                               成员函数
'================================================================================
'构造函数
Private Sub Class_Initialize()
        '属性初始化
        Caption = "Form"
        Left = 0
        Top = 0
        Width = 240
        Height = 120
        Visible = True
        TopMost = False
End Sub
'析构函数
Private Sub Class_Terminate()
        '
End Sub
'================================================================================
'                               属性接口
'================================================================================
'标题
Public Property Let Caption(ByVal NewValue As String)
        mCaption = NewValue
        SetWindowText WinHwnd, mCaption
End Property
Public Property Get Caption() As String
        Caption = mCaption
End Property'左边距
Public Property Let Left(ByVal NewValue As Long)
        mLeft = NewValue
End Property
Public Property Get Left() As Long
        Left = mLeft
End Property'顶边距
Public Property Let Top(ByVal NewValue As Long)
        mTop = NewValue
End Property
Public Property Get Top() As Long
        Top = mTop
End Property'宽度
Public Property Let Width(ByVal NewValue As Long)
        mWidth = NewValue
End Property
Public Property Get Width() As Long
        Width = mWidth
End Property'高度
Public Property Let Height(ByVal NewValue As Long)
        mHeight = NewValue
End Property
Public Property Get Height() As Long
        Height = mHeight
End Property'可见
Public Property Let Visible(ByVal NewValue As Boolean)
        mVisible = NewValue
End Property
Public Property Get Visible() As Boolean
        Visible = mVisible
End Property'置顶
Public Property Let TopMost(ByVal NewValue As Boolean)
        mTopMost = NewValue
End Property
Public Property Get TopMost() As Boolean
        TopMost = mTopMost
End Property

Answer 4

每个窗体的winproc都是在自己的独立线程的,你在raiseevent的同时也阻塞下当前的窗口线程

Answer 5

Private CMain As Class_Main  'Class_Main  呢?

Answer 6

我的想法是,做一个窗体类,类的内部实现WinProc,消息截获以后封装成事件,按钮和基它控件也都这样.如果能实现的话,就成为了一种Basic语法的类Java的纯API程序了.

Answer 7

对了,昨天发的这一个好像是GetMessage实现的,可以编译,以前写的一个用 机器码+VB实现的子类化可以实现我的想法,不过,不能编译,只能运行在IDE中。

Answer 8

正如 ：supergreenbean(超级绿豆(MSMVP - VB) 所说的，每个窗体的winproc部分对应一个线程，
但在类中封装好一个安全的线程还是不容易的。关注中...

Answer 9

豆子,以前我看过一个叶帆写的无崩溃子类化的类好像也是在类中用ASM码实现的子类化,原理是让子类工作在机器码中,用CallWindowProc执行,如果发生错误,也是在机器码里,不会让VB的IDE挂掉,那个程序我还看不太懂,能不能帮我看看?麻烦你了,每次都很麻烦你.

Answer 10

我记得看过的无崩溃子类化好象是用EbMode判断目前是否在IDE中而选择跳过或者暂停子类处理,你要么把那段给插进来好了，呵呵

Answer 11

很让人感动,一定费了很多劲吧?为啥不用 VB.NET呢?加油!

Answer 12

http://blog.csdn.net/yefanqiu/archive/2006/01/03/569208.aspx豆子,看看这个,我说的就是这段代码,叶帆写的
用汇编代码实现了窗口消息处理函数，然后编译成二进制码，由VB程序进行调用

Answer 13

换了个思路,变相的解决了这个问题,现在在写一些基本的组件(Form,Button,Menu,Option,Check,List.....)过一阵有时间了发布出来给大家看看.  ;D