【叶帆文章】无崩溃子类化技术实现

叶帆
博客专家认证
业界专家认证
2006-01-03 01:44:41
凡是用VB做相对高深一些的东西的时候,不可避免都会或多或少用到子类技术,我上一篇文章介绍的www.vbaccelerator.com 网站,上面关于控件、图形等等几乎都用到了子类技术。

但是如果简单的用几个API来实现子类,那么只要你非正常关闭窗体或者加入中断点调试,不好意思,VB IDE崩溃,所有的一切都要重来。

有没有无崩溃的子类技术呢?我这里目前不光有一种,还有两种:)

第一种,也就是www.vbaccelerator.com 网站常用的技术,就是用VB做了一个进程内组件DLL(SSubTmr6.dll),由它实现子类。效果不错,但是需要挂接一个COM组件,有背绿色软件之道,所以这个技术就不介绍了(详细代码,请上vba...网站,上面有源码)。

第二种,其实这是我看 HookMenu源码的心得,是高手的结晶,这里不敢夺爱。HookMenu作者高就高在,用汇编代码实现了窗口消息处理函数,然后编译成二进制码,由VB程序进行调用,这样仅需要在程序中添加一个类(外引用一个该类的接口文件SubclassingSink.tlb),就可以很绿色,并且无崩溃的实现了子类化,由于作者原代码包含内容较多,所以我简化了一下,自己重新封装了一个类,然后又做了一个示例。这样让高端技术平民化,让每一个VB爱好者都会使用。

示例代码如下:

'*************************************************************************
'**模 块 名:frmDemo
'**说 明:Sky Walker(天行者) 版权所有2006 - 2007(C)
'**创 建 人:叶帆
'**日 期:2006-01-02 17:29:24
'**修 改 人:
'**日 期:
'**描 述:窗口子类化示例(无崩溃)
'** :叶帆Blog:http://blog.csdn.net/yefanqiu
'**版 本:V1.0.0
'*************************************************************************
Option Explicit
Implements ISubclassingSink '接口定义 需引用接口文件SubclassingSink.tlb
Private mSubclass As CSubclass '实现类

Private Const WM_SIZE = &H5
Private Const WM_MOUSEWHEEL = &H20A
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_LBUTTONUP = &H202
Private Const WM_LBUTTONDBLCLK = &H203
Private Const WM_RBUTTONDOWN = &H204
Private Const WM_RBUTTONUP = &H205

'*************************************************************************
'**函 数 名:Form_Load
'**输 入:无
'**输 出:无
'**功能描述:初始化子类
'**全局变量:
'**调用模块:
'**作 者:叶帆
'**日 期:2006-01-02 17:33:02
'**修 改 人:
'**日 期:
'**版 本:V1.0.0
'*************************************************************************
Private Sub Form_Load()
Set mSubclass = New CSubclass '初始化一个子类
'添加消息 (前截获)
mSubclass.AddBeforeMsgs WM_MOUSEWHEEL, WM_SIZE, WM_LBUTTONDOWN, WM_LBUTTONUP, WM_LBUTTONDBLCLK
'添加消息 (后截获)
mSubclass.AddAfterMsgs WM_MOUSEWHEEL, WM_RBUTTONDOWN, WM_RBUTTONUP

'获取全部的消息
'mSubclass.AllAfterMsgs = True
'mSubclass.AllBeforeMsgs = True
...全文
591 34 打赏 收藏 转发到动态 举报
AI 作业
写回复
用AI写文章
34 条回复
切换为时间正序
请发表友善的回复…
发表回复
叶帆 2006-01-17
  • 打赏
  • 举报
回复
to songyaowu

这个dll指的是COM组件,它需要在注册表注册,非绿色
tlb文件仅仅是一个接口问题,便于你在VB中访问。正常情况下一个tlb(或多个)必须对应一个DLL(COM),但这一个特殊一些,它与Exe文件合在一起了,编译后,直接拷贝就可以使用,不需要注册,也不需要tlb文件。

proer9988 2006-01-11
  • 打赏
  • 举报
回复
good!
boyzhang 2006-01-11
  • 打赏
  • 举报
回复
to:yefanqiu(叶帆:http://blog.csdn.net/yefanqiu)

呵呵,现丑了,COM我基本上不会.

这个代码也是看了几个老外的代码以后自己写的.

班门弄斧了. :)
rise139 2006-01-10
  • 打赏
  • 举报
回复
好 这个无崩溃子类可否用来截获其他系统消息 如外壳消息 添加删除文件等等
韧恒 2006-01-10
  • 打赏
  • 举报
回复
唉,怎么说呢,我见过的所有的方法都无可避免地出现一些问题,也许这已经是VB的极限了吧。恐怕与VB本身的实现结构有关。
另外还有个问题,引用叶兄的主题“第一种,也就是www.... 但是需要挂接一个COM组件,有背绿色软件之道....”,不明白叶兄所说的绿色软件是怎样的概念呢?如果挂接一个dll就不算绿色软件的话,那么第二种方法带上一个tlb就算绿色了么?
我一直在寻找一个将tlb移入VB中的方案,当然,如果tlb中仅是几个API声明到罢了,但要是声明了一些ole对象我们将如何在vb中创建它呢?
kmlxk0 2006-01-09
  • 打赏
  • 举报
回复
强~!顶顶顶顶顶!

叶帆 2006-01-09
  • 打赏
  • 举报
回复
思路比较好,但是加中断点调试的时候,还是有崩溃和无法终止程序的现象。
这是我的调试代码 XP Sp2+VB6
Option Explicit
Dim WithEvents ISubClass As Class_Hook

Private Sub Command1_Click()
MsgBox "dsfasd"
End Sub

Private Sub Form_Load()
Set ISubClass = New Class_Hook
ISubClass.Hook Me.hWnd
End Sub

Private Sub Form_Unload(Cancel As Integer)
ISubClass.UnHook
Set ISubClass = Nothing
End Sub

Private Sub ISubClass_NewMessage(ByVal hWnd As Long, FunctionPtr As Long, uMsg As Long, wParam As Long, lParam As Long, Cancel As Boolean)
Debug.Print Timer, uMsg, wParam, lParam
End Sub
VBAHZ 2006-01-05
  • 打赏
  • 举报
回复
楼主的这个不就是类吗?
boyzhang 2006-01-05
  • 打赏
  • 举报
回复
呵呵,我的子类化类是用函数指针写的,

用了一段时间,感觉还可以.

脱钩时如果出错的话,也可以正常停止,

只是,如果再次运行的话,就有可能会挂掉.

不过. :) 一般我都保存以后退出VB后再

进入. 呵呵,主要是一个类就实现了,

结构简单,调试起来也方便.
daixinhou 2006-01-05
  • 打赏
  • 举报
回复
用这种技术调用类的时候,就不会出现崩溃的情况了?有点怀疑,不过先去试试。
RayLynn 2006-01-05
  • 打赏
  • 举报
回复
梦里寻她千白度```
boyzhang 2006-01-05
  • 打赏
  • 举报
回复
偶的类.
献丑了.

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_Hook"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'模块描述
'---------------------------------------------------------------------------------------
' Date-Time : 2006-01-02 23:10:43
' Author : boyzhang[QQ:20437023]
' Purpose : 挂钩类
'---------------------------------------------------------------------------------------
'结构体
Private Type FunctionSPointerS
FunctionPtr As Long
FunctionAddress As Long
End Type
'API函数
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32.dll" (ByVal HMEM As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32.dll" (ByVal HMEM As Long) As Long
Private Declare Function GlobalFree Lib "kernel32.dll" (ByVal HMEM 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
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'常数
Private Const GMEM_MOVEABLE As Long = &H2
Private Const GMEM_ZEROINIT As Long = &H40
'变量
Private mb_running As Boolean
Private mlng_memhandle As Long
Private mlng_proc As Long
Private mlng_handle As Long
Private mlng_hwnd As Long
'事件
Public Event NewMessage(ByVal hWnd As Long, ByRef FunctionPtr As Long, ByRef uMsg As Long, ByRef wParam As Long, ByRef lParam As Long, ByRef Cancel As Boolean)

'子类过程
Public Function SubClassProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim Bool As Boolean
'触发事件
RaiseEvent NewMessage(hWnd, SubClassProc, uMsg, wParam, lParam, Bool)
'消息是否返回原地址
If Bool = True Then Exit Function
'返回原地址
SubClassProc = CallWindowProc(mlng_handle, hWnd, uMsg, wParam, lParam)
End Function

'传函数指针
Public Function GetFunctionPtr()
GetFunctionPtr = mlng_proc
End Function

'挂钩
Public Sub Hook(ByVal hWnd As Long, Optional Style As Long = -4)
mlng_hwnd = hWnd
If Not mb_running Then
mb_running = True
mlng_handle = SetWindowLong(mlng_hwnd, Style, mlng_proc)
End If
End Sub

'脱钩
Public Sub UnHook()
If mb_running Then
SetWindowLong mlng_hwnd, (-4), mlng_handle
mb_running = False
End If
End Sub

'构造函数
Private Sub Class_Initialize()
'生成函数指针
Dim lng_fncptr As Long
Dim lng_objptr As Long
Dim lng_vtable As Long
Dim lng_ptx As Long
Dim lng_proc As Long
Dim lng_varnum As Long
Dim lng_objvarnum As Long
Dim lng_funcnum As Long
lng_objptr = ObjPtr(Me)
CopyMemory lng_vtable, ByVal lng_objptr, 4
lng_ptx = lng_vtable + 28 + (lng_varnum * 2 * 4) + (lng_objvarnum * 3 * 4) + lng_funcnum * 4
CopyMemory lng_fncptr, ByVal lng_ptx, 4
mlng_memhandle = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, 105)
mlng_proc = GlobalLock(mlng_memhandle)
DelegateFunction mlng_proc, Me, lng_fncptr, 4
End Sub

'析构函数
Private Sub Class_Terminate()
If mb_running Then UnHook
Call GlobalUnlock(mlng_memhandle)
Call GlobalFree(mlng_memhandle)
End Sub

'托管函数
Private Function DelegateFunction(ByVal CallingADR As Long, Obj As Object, ByVal MethodAddress As Long, ByVal NumberOfParameters As Byte)
Dim TmpA As Long
Dim u As Long
TmpA = CallingADR
CopyMemory ByVal CallingADR, &H68EC8B55, 4
CallingADR = CallingADR + 4
CopyMemory ByVal CallingADR, TmpA + 31 + (NumberOfParameters * 3) - 4, 4
CallingADR = CallingADR + 4
Dim StackP As Byte
StackP = 4 + 4 * NumberOfParameters
For u = 1 To NumberOfParameters
CopyMemory ByVal CallingADR, CInt(&H75FF), 2
CallingADR = CallingADR + 2
CopyMemory ByVal CallingADR, StackP, 1
CallingADR = CallingADR + 1
StackP = StackP - 4
Next u
CopyMemory ByVal CallingADR, CByte(&H68), 1
CallingADR = CallingADR + 1
CopyMemory ByVal CallingADR, ObjPtr(Obj), 4
CallingADR = CallingADR + 4
CopyMemory ByVal CallingADR, CByte(&HE8), 1
CallingADR = CallingADR + 1
Dim PERFCALL As Long
PERFCALL = CallingADR - TmpA - 1
PERFCALL = MethodAddress - (TmpA + (CallingADR - TmpA - 1)) - 5
CopyMemory ByVal CallingADR, PERFCALL, 4
CallingADR = CallingADR + 4
CopyMemory ByVal CallingADR, CByte(&HA1), 1
CallingADR = CallingADR + 1
CopyMemory ByVal CallingADR, TmpA + 31 + (NumberOfParameters * 3) - 4, 4
CallingADR = CallingADR + 4
CopyMemory ByVal CallingADR, CInt(&HC2C9), 2
CallingADR = CallingADR + 2
CopyMemory ByVal CallingADR, CInt(NumberOfParameters * 4), 2
End Function
boyzhang 2006-01-05
  • 打赏
  • 举报
回复
@_@ #

不好意思,我以为楼主用的是PSCODE上的那个内嵌ASM的

子类化类模块.
VBAHZ 2006-01-05
  • 打赏
  • 举报
回复
To boyzhang(张郎)(爱你爱到Windows没BUG的那天) :

除了CSubclass类模块再加一个演示窗体frmDemo外,哪里有第二个类?

也许楼主太不负责了,为什么只有一个类呢?

还请麻烦张郎老兄,把另一个类传上来看看,谢谢!
boyzhang 2006-01-05
  • 打赏
  • 举报
回复
用汇编的那种方法是用了两个类模块实现的.

我的只有一个类.
mndsoft 2006-01-04
  • 打赏
  • 举报
回复
嗯,好,把复杂的东西简单化,这就是高手!
rainstormmaster 2006-01-04
  • 打赏
  • 举报
回复
//关键在无崩溃,不知道,你的是否能实现

呵呵:),说的不错


其实无崩溃的话,处理消息循环也可以,不过开销太大了
jinjazz 2006-01-04
  • 打赏
  • 举报
回复
ms咋不管呢
叶帆 2006-01-04
  • 打赏
  • 举报
回复
关键在无崩溃,不知道,你的是否能实现
Summer006 2006-01-04
  • 打赏
  • 举报
回复
唉。。悲哀,看了半天都不知道what talk about。。。太打击我了
加载更多回复(14)
在CAD(计算机辅助设计)软件中,线性是构建采矿工程图的重要元素。"cad采矿用各种线性"指的是在CAD环境下,为了精确地表示采矿工程的地质结构、开采路径、巷道布局等,所使用的一系列特定线型。这些线型通常包括连续线、虚线、点划线以及定制的特殊线型,以便清晰地标识不同类型的地质特征、开采边界和安全区域。 线型在CAD中起到区分和标识不同对象的作用。例如,连续线可能用于表示巷道的实际走向,虚线可能用于表示规划中的巷道或尚未施工的部分,点划线则可能用于显示支撑结构或危险区域。通过选择合适的线型,工程师们可以更直观地理解采矿工程的设计和进度。 `.lin`文件是CAD中的线型文件,它包含了线型的定义。用户可以自定义线型,如设置线型的比例因子、每个线段的长度和间隔,以及它们的组合方式。`.lin`文件可以被CAD软件读取,使得用户在绘图时能够选择并应用这些预定义的线型。 `.shp`和`.shx`文件则是与CAD中的形状文件相关的。`.shp`文件是一种存储地理空间数据的标准格式,通常包含几何对象(如点、线和多边形)的信息。在采矿领域,这些文件可能用于表示矿体的边界、巷道的位置或其他地质特征。`.shx`文件是`.shp`文件的索引,用于快速访问和处理数据,提高软件的性能。 结合这些文件,我们可以创建一个全面的采矿工程图,其中包括了各种定制的线性表示,使设计和分析工作更为准确高效。在实际操作中,工程师首先会根据需求定义或导入`.lin`文件,然后在绘制巷道、矿体和其他元素时选择相应的线型。同时,他们会利用`.shp`和`.shx`文件来加载和管理地理空间数据,以便在CAD环境中呈现采矿区域的三维视图和二维平面图。 通过熟练掌握CAD中的线性操作,采矿工程师能够更好地进行规划、模拟和沟通,确保采矿作业的安全性和经济性。此外,这些技术也可以应用于其他工程领域,如土木工程、地质调查等,因为线型的使用是通用的,旨在提供清晰的视觉表示和专业信息的传递。因此,深入理解和应用CAD中的线性是现代工程设计不可或缺的一部分。
资源下载链接为: https://pan.quark.cn/s/f989b9092fc5 以下是关于“LUST中文操作手册-s.pdf”文档的知识点解析: 标题与描述:文档标题为“LUST中文操作手册-s.pdf”,从标题来看,这是一份关于LUST系统的中文操作手册,其描述与标题相同,推测是直接以文件名作为描述。 标签:“11”可能是手册中的章节编号或特定功能模块编号,需结合文档内容确定具体含义。 内容分析:手册涉及LUST系统的多个方面,如伺服控制、系统配置、参数设置等。以下是详细解析: 1.1部分:介绍LUST系统的基本概念或功能特性。提到夜晚的概念,可能指系统工作环境或某种工作模式;还涉及操作或配置命令,以及电源或供电部分,如230V/460V电压等级,推测在介绍硬件基础配置。 2.1至2.2.2部分:涉及系统内部功能模块,包括驱动控制等。提到驱动器或控制器的电源部分,以及具体的配置步骤或参数设置指南。 4部分:提到伺服控制系统(ServoC),是手册的重要内容之一。详细介绍了如何配置和使用伺服控制系统,包括不同配置步骤或使用场景。 3部分:关于系统的总体配置或设置指南。可能提供了系统核心组件或主要配置项的设定方法。 5.1至5.2.3部分:涉及系统的工作原理或操作流程。可能详细介绍了系统的具体工作流程或操作模式。 6部分:介绍LUST系统中某个特定功能模块的操作指南,例如高级设置或特定应用场景下的操作指导。 7.1至7.3.4部分:涉及系统的配置管理或特定组件的使用指南,详细介绍了配置管理的不同方面,包括配置工具的使用、特定组件的配置指南等。 8.1至8.5.1部分:涵盖系统的其他高级功能或特定应用场景下的操作指南。 综上所述,LUST系统是一套复杂的自动控制系统,涉及伺服控制、系统配置等多个方面。该手册详细地介绍了如何使用和配置这套系统,是用户宝贵的参考资料。

1,488

社区成员

发帖
与我相关
我的任务
社区描述
VB API
社区管理员
  • API
加入社区
  • 近7日
  • 近30日
  • 至今
社区公告
暂无公告

试试用AI创作助手写篇文章吧