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

叶帆
博客专家认证
业界专家认证
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
...全文
588 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)
资源下载链接为: https://pan.quark.cn/s/9e7ef05254f8 【久久在线FLASH系统】是一款专为久久在线网站打造的交互式Flash平台,集成了前台展示与后台管理功能,满足内容发布、管理和用户互动的需求。Flash技术曾广泛应用于网页动画和互动内容,尤其在早期互联网时代,在游戏、广告和多媒体教学等领域发挥了重要作用。该系统的核心包括以下几个关键方面: Flash技术:系统利用Flash创建动态图形、动画和交互内容,依赖Adobe Flash Player运行。其编程语言ActionScript支持面向对象开发,便于实现复杂逻辑和交互效果。 后台管理系统:作为系统的控制中心,后台支持内容上传、编辑、分类、权限设置、用户管理及数据分析,确保内容的有序更新与发布。 产品演示模块:用户可在线预览和体验产品功能,无需下载,通过交互式演示了解产品操作流程和优势。 数据库集成:系统与数据库紧密结合,用于存储Flash文件信息、用户数据及访问记录,实现高效的数据管理与检索。 安全性与优:系统具备防止非法访问和数据泄露的安全机制,并对Flash内容进行优,提升加载速度与用户体验。 响应式设计:尽管Flash主要用于桌面端,系统仍考虑多设备兼容性,通过响应式设计适配不同屏幕尺寸,提供一致体验。 API接口:系统支持与其他平台或服务通过API进行数据交互,如社交媒体分享、数据分析等,拓展功能边界。 用户体验:界面设计注重交互性与视觉效果,提升用户满意度和停留时间,增强平台吸引力。 版本控制:系统支持内容版本管理,便于追踪更新历史,方便内容维护与回滚。 性能监控:内置性能监控工具,实时跟踪系统负载与资源使用情况,及时发现并解决问题,保障系统稳定运行。 【久久在线FLASH系统】是一个综合性解决方案,融合了前端展示、后台管理、互动体验和数据分析等功能,体现了当时Web
资源下载链接为: https://pan.quark.cn/s/f989b9092fc5 BP神经网络轴承故障诊断系统是一种基于人工神经网络技术的智能诊断工具,专门用于识别和分析机械设备中轴承的故障情况。该系统的核心是BP神经网络(即反向传播神经网络),它能够模拟人脑的工作方式,通过学习和训练来处理复杂的非线性问题,从而对轴承的健康状态进行精准评估。 BP神经网络的基本结构由输入层、隐藏层和输出层构成。输入层接收来自传感器的信号,如振动数据或声音频率,这些信号反映了轴承的运行状态。隐藏层负责对输入数据进行特征提取和转换,将原始信号转为更具价值的信息。输出层则输出最终的诊断结果,例如轴承是否正常、轻微磨损或严重损坏等。 在诊断过程中,数据预处理是至关重要的步骤。原始的振动或声学数据通常含有噪声,且不同传感器的数据可能缺乏可比性。因此,需要对这些数据进行滤波、归一等处理,以提高数据质量。预处理后的数据随后被输入到BP神经网络中。在训练阶段,网络通过反向传播算法调整权重和阈值,使预测结果尽可能接近实际故障类型。这一过程利用了梯度下降法,通过计算误差梯度来更新网络参数,以最小损失函数(通常是均方误差,用于衡量预测值与真实值之间的差异)。 BP神经网络的性能受到多种因素的影响,包括网络结构(如隐藏层的数量和每层的神经元数量)、学习率以及训练迭代次数等。优这些参数对于提升诊断精度和速度至关重要。此外,为了验证和提升模型的泛能力,通常采用交叉验证方法,将数据集分为训练集、验证集和测试集。其中,训练集用于训练网络,验证集用于调整网络参数,测试集则用于评估模型在未知数据上的表现。 总体而言,BP神经网络轴承故障诊断系统凭借其强大的学习和泛能力,通过对机械设备振动和噪声数据的分析,能够实现对轴承故障的精确识别。该系统有助于提前发现设备故障隐患,减少停机时间,提高生产效率,对工业领域

1,488

社区成员

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

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