想出一种VB也能生成汇编的方法，有心者看能不能再发扬光大了

[homezj]

VB做SubClass一般都不得不带上个标准模块，但有时在自己的类中也要做SubClass处理，带模块的就不方便了，我想试过的都有点感触，我就不多说了。
不带模块，在网上也见过不少代码，方法就是写一段像天书一样的16进制码到全局内存中，显得非常神秘，虽然有些不用劳神拿来就能用，但毕竟不知源码处理方法，有时很难与自己的需求配合好！VB能不能做出那些古怪的东东呢？我今天突然想出了个办法，拿出来与大家分享，也希望能抛砖引玉，完善这种方法。

那种汇编码说起来也不神秘，无非就是写一个公用过程，将过程编译后的机器码转成字符串，放到程序中，它的作用相当于一个标准模块，可只为类的一个实例独享，绝不会引起冲突。但这个过程要调用对象的方法，又要绕过VB的对象引用计数。突破VB的重重封锁，真是让我犯了难。
据我测试，VB的引用计数，是与Set语句相关联的，不用Set，直接将对象指针Copy给对象变量，就不会计数。基于这点认识我写了个简单的汇编码生成程序，虽然功能有限，但却可自己控制程序流向，应该是有利用价值的。

1、先加个类Class2，它没功能，目的就了为了绕过编译时的类型检查，代码如下：
Public Function WndProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wp As Long, ByVal lp As Long) As Long

End Function


2、加个标准模块，代码如下：
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private obj As Class2
Public Function WndProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wp As Long, ByVal lp As Long) As Long
'这是要生成汇编的过程，以后就要靠它为我们的类服务了
'这个过程内容暂时不支持其它函数调用，不然又要动态取函数地址，很麻烦
'想做什么处理，全部放到类里的WndProc函数中去
WndProc = obj.WndProc(hwnd, Msg, wp, lp)
End Function

Public Sub Main()
Dim i As Long, a() As Byte, s As String, b(3) As Byte, s1 As String
Const CodeLen As Long = 200 '复制汇编码的长度，可大致估算一下汇编码的容量，只能多不能少！
ReDim a(CodeLen - 1)
i = GetAddress(AddressOf WndProc) '取WndProc函数地址
CopyMemory a(0), ByVal i, CodeLen '将函数的汇编码复制到字节数组中
For i = 0 To CodeLen - 1
If i < CodeLen - 1 Then
If a(i) = &H90 And a(i + 1) = &H90 Then Exit For '判断过程码是否结束的标志之一
End If
If a(i) > 15 Then
s = s & Hex$(a(i))
Else
s = s & "0" & Hex$(a(i))
End If
If i > 10 Then
If a(i - 1) = &HC2 And a(i) = &H10 Then Exit For '判断过程码是否结束的标志之二
End If
Next
CopyMemory b(0), VarPtr(obj), 4 '取对象变量的地址，因为它是动态的，我没法在VB中用对象指针直接调用对象的方法，只好这样变通了
For i = 0 To 3
If b(i) > 15 Then
s1 = s1 & Hex$(b(i))
Else
s1 = s1 & "0" & Hex$(b(i))
End If
Next
s = Replace$(s, s1, "xxxxxxxx") '把汇编码中保存对象变量的地址的4个字节，用“x”标出，便于加载时替换。
Debug.Print s
If Dir(App.Path & "\1.txt") <> "" Then Kill App.Path & "\1.txt"
Open App.Path & "\1.txt" For Binary As #1 '写入程序目录下“1.txt”文件
Put #1, , s
Close #1
End Sub
Public Function GetAddress(ByVal a As Long) As Long
GetAddress = a
End Function

把工程用本机码（记住不能用p代码）编译成EXE，编译速度优化选项包括高级选项，最好全部选上。
动行Exe，呵呵，VB生成的汇编码就写入“1.txt”中了。
至于怎么调用，我要睡觉了，明天再写。。。

[homezj]

想尽所有欺骗办法，终于得逞了！为了便于不了解汇编的朋友也能接受与修改这个代码，我尽可能注释详细些，同时也没有直接写机器码，基本是通过算法解决的。智能化与灵活性都算比较令人满意了！

'生成机器码有工程
'这个工程需编译后使用，编译请采用本机码编译，
'选中：代码速度代化、针对Pentium Pro优化、并将所有“高级优化”打上勾
'还不能说完全通用，不过在读懂这个代码的基础上，各种过程码应该都可编出来
'变量、函数、API、对象都能处理，应有尽有，我想够用了

'----------------------------------------------------------------------------------------
'类名Class2，它没功能，目的就了为了绕过编译时的类型检查，并实现对象的前期绑定，代码如下：
Option Explicit
Public Function WndProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wp As Long, ByVal lp As Long) As Long

End Function

'----------------------------------------------------------------------------------------
'标准模块
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private mobjTemp As Class2, mblnInIDE As Boolean
Public Function WndProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wp As Long, ByVal lp As Long) As Long
'这是要生成机器码的过程，以后就要靠它为我们的类服务了
'这个过程增加其它函数调用，请参照Main过程中的方法，修改才能使用。
'想做什么处理，尽量全部放到类里的WndProc函数中去
Dim ProcOK As Long
'原可以用Goto在这里跳到后面，结果VB在这里却没有生成&HEB（jmp），想在IDE环境下，用两个nop改写它的希望破灭了
If mblnInIDE Then '是否在IDE中运行的标志，调用时需更改它的地址,用这个变量的目的，是为了防止非IDE环境下出错
'这里VB用mblnInIDE与0比较，然后&H74(je)跳转，若改成mblnInIDE=True，则变成与&HFF比较，然后&H75(jne)跳转，很有趣！
If EbMode = 2 Then '调用API函数EbMode，判断若处于中断状态，则将窗体消息全部交给原处理过程
'EbMode可参考的资料太少，我也不知等于2代表什么，反正就在这个值时，能在中断时执行下面内容
WndProc = CallWindowProc(&H55555555, hwnd, Msg, wp, lp) '&H55555555是随便用来冒充旧窗体过程地址的，调用时要先替换
Exit Function
End If
End If
'调用类中的公共方法。
'要注意编译这里时会采用前期绑定，类中的WndProc函数必须放在代码段的第一位，参数个数及类型要与这里一致。
'类声明部分若有Public变量或对象变量，请将类中的声明部分全部复制到这个工程的Class2中后，再编译。
ProcOK = mobjTemp.WndProc(hwnd, Msg, wp, lp)
If ProcOK = 0 Then
WndProc = CallWindowProc(&H55555555, hwnd, Msg, wp, lp)
Else
WndProc = ProcOK
End If
End Function
Public Sub Main()
Dim i As Long, a() As Byte, s As String, addr As Long
Const CodeLen As Long = 200 '复制机器码的长度，可大致估算一下机器码的容量，只能多不能少！
ReDim a(CodeLen - 1)
addr = GetAddress(AddressOf WndProc) '取WndProc函数地址
CopyMemory a(0), ByVal addr, CodeLen '将函数的机器码复制到字节数组中
For i = 0 To CodeLen - 1
If a(i) > 15 Then
s = s & Hex$(a(i))
Else
s = s & "0" & Hex$(a(i))
End If
If i > 10 Then
If a(i - 1) = &H90 And a(i) = &H90 Then Exit For '判断过程码是否结束的标志之一
'绿豆提醒我，ret n与参数个数有关，所以&HC210不能做为结束标志，至少应该是&HC2与参数个数*4吧
'而且若函数分支多，会有多个ret，想来想去只有用两个nop了，不过有可能不准确。这一点还请各位指正
End If
Next
s = Replace$(s, LongToStr(VarPtr(mobjTemp)), String(8, "x")) '把机器码中保存对象变量的地址的4个字节，用“x”标出，便于加载时替换。
s = Replace$(s, LongToStr(VarPtr(mblnInIDE)), String(8, "y")) '把机器码中保存InIDE变量的地址的4个字节，用“y”标出，便于加载时替换。
ReplaceFuncAddr s, a, addr, AddressOf EbMode, "m" '把机器码中保存EbMode函数的相对地址的4个字节，用“m”标出，便于加载时替换。
ReplaceFuncAddr s, a, addr, AddressOf CallWindowProc, "w" '把机器码中保存CallWindowProc函数的相对地址的4个字节，用“w”标出，便于加载时替换。
'我觉得在过程复杂度不高时，也可用操作码&HE8(call)来做函数标记，与数据码重复的可能性也不大
If Dir(App.Path & "\1.txt") <> "" Then Kill App.Path & "\1.txt"
Open App.Path & "\1.txt" For Binary As #1 '写入程序目录下“1.txt”文件
Put #1, , s
Close #1
End Sub
Private Function GetAddress(ByVal a As Long) As Long
GetAddress = a
End Function
Private Function LongToStr(ByVal a As Long) As String
Dim s As String, b(3) As Byte, i As Long
CopyMemory b(0), a, 4
For i = 0 To 3
If b(i) > 15 Then
s = s & Hex$(b(i))
Else
s = s & "0" & Hex$(b(i))
End If
Next
LongToStr = s
End Function
Private Sub ReplaceFuncAddr(CodeStr As String, CodeData() As Byte, BaseAddr As Long, ByVal FuncAddr As Long, ReplaceStr As String)
'按函数地址的值查找其在过程码中的位置，这个值在过程码中的值是调用位置地址与函数地址的相对差值
'具体算法参见另一工程中的说明
Dim k As Long, i As Long, fd As Long
k = FuncAddr - BaseAddr - 4
For i = 1 To UBound(CodeData) - 3
CopyMemory fd, CodeData(i), 4
If fd + i = k Then
Mid(CodeStr, i * 2 + 1, 8) = String(8, ReplaceStr)
End If
Next
End Sub
'下面两个是与API函数参数声明完全一样的自定义公共函数，没功能，就是为了欺骗VB，把API做为自己的函数调用。
Public Function CallWindowProc(ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

End Function
Public Function EbMode() As Long

End Function

[homezj]

'调用示例工程
'WinXP SP2 + VB6 SP6下调试通过
'我测试了，不管用P或N代码编译，都可以使用。
'现在支持IDE环境下的任意中断，只要断点不设在WndProc函数中，就没问题。
'------------------------------------------------------------------------------
'窗体代码
Option Explicit
Private obj As Class1
Private Sub Form_Load()
Set obj = New Class1
obj.SubClass Me.hwnd
End Sub
Private Sub Form_Unload(Cancel As Integer)
Set obj = Nothing
End Sub

'---------------------------------------------------------------------------
'类代码，随便取个名Class1
Option Explicit
Private Const WM_DESTROY = &H2
Private Const WM_SIZE = &H5
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_PAINT = &HF
Private Const WM_SYSCOMMAND = &H112
Private Const SC_MAXIMIZE = &HF030&
Private Const SC_MINIMIZE = &HF020&
Private Const GWL_WNDPROC = (-4)
Private mlngFuncBaseAddr As Long, mlngVarAddr As Long, mlngHwnd As Long, mlngOldFuncAddr As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length 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 GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
'这个过程必须放在紧跟声明的后面，若上面声明出现了Public或对象变量，请将上面声明全部复制到另一个工程的Class2中，并重新生成机器码。
'名称随便，可以是Sub也可以是Function，参数个数与类型也可变，只要声明与另一个工程的Class2中的过程声明一致就行。
Public Function WndProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'对所挂窗体的全部消息进行处理。
On Error Resume Next
Dim ProcOK As Long
Select Case uMsg
Case WM_SIZE
Debug.Print "SIZE"
Case WM_LBUTTONDOWN
Debug.Print "LBUTTONDOWN"
Case WM_PAINT
Debug.Print "PAINT"
Case WM_DESTROY
Debug.Print "DESTROY"
Case WM_SYSCOMMAND
Debug.Print "SYSCOMMAND"
If wParam = SC_MAXIMIZE Or wParam = SC_MINIMIZE Then ProcOK = 1 '让最大化与最小化按钮有效但无用，总得试验一下拦截的效果吧^_^
Case &H113
Debug.Print "timer"
End Select
WndProc = ProcOK
End Function
Public Sub SubClass(hwd As Long)
Dim sHex As String, nLen As Long
Dim sCode() As Byte, i As Long, ide As Boolean
If mlngHwnd <> 0 Then Exit Sub
Open App.Path & "\1.txt" For Binary As #1 '实际程序当然不用再读文件，直接把代码放入变量就行了
sHex = Input(LOF(1), 1)
Close #1
'sHex = "5166833Dyyyyyyyy0053555657C7442410000000007430E8mmmmmmmm83F80275268B4424248B4C24208B54241C508B44241C5152506855555555E8wwwwwwww5F5E5D5B59C210008B7424248B7C24208B5C241CA1xxxxxxxx8B6C24188B088D542410525657535550FF511CDBE285C07D158B0Dxxxxxxxx6A1C68E81740005150FF15241040008B44241085C0750E565753556855555555E8wwwwwwww5F5E5D5B59C210009090"
nLen = Len(sHex) \ 2
ReDim sCode(nLen - 1)
mlngFuncBaseAddr = GlobalAlloc(0&, nLen) '申请一个全局内存块，放入我们的机器码,这也是函数基地址
mlngVarAddr = GlobalAlloc(0&, 6&) '申请一个全局内存块，用于存入本类的对象指针（4 bytes）及InIDE变量（2 bytes），用它们冒充公共变量，同时绕过引用计数
mlngOldFuncAddr = GetWindowLong(hwd, GWL_WNDPROC) '取得原窗体处理过程地址
CopyMemory ByVal mlngVarAddr, ObjPtr(Me), 4 '将对象指针放入上面内存的头4个字节中
sHex = Replace$(sHex, String(8, "x"), LongToStr(mlngVarAddr)) '用上面存放对象指针的Long变量地址替换机器码中标记的对象变量位置

ide = IsInIDE '判断是否在IDE环境下
CopyMemory ByVal mlngVarAddr + 4, ide, 2 '将InIDE变量放入上面内存块的后2个字节中
sHex = Replace$(sHex, String(8, "y"), LongToStr(mlngVarAddr + 4)) '用上面存放Bool变量的地址替换机器码中标记的位置

If ide Then ConvFuncAddr sHex, "vba6", "EbMode", "m" '用算出的函数相对地址替换机器码中标记的位置
ConvFuncAddr sHex, "user32", "CallWindowProcA", "w"

sHex = Replace$(sHex, String(8, "5"), LongToStr(mlngOldFuncAddr))
For i = 0 To nLen - 1
sCode(i) = Val("&H" & Mid$(sHex, i * 2 + 1, 2))
Next
CopyMemory ByVal mlngFuncBaseAddr, sCode(0), nLen
SetWindowLong hwd, GWL_WNDPROC, mlngFuncBaseAddr '用我们的过程挂上窗体
mlngHwnd = hwd
End Sub
Private Sub ConvFuncAddr(CodeStr As String, ModuleName As String, FuncName As String, TagStr As String)
'将函数的真实地址，换算成相对地址，
'换算方法就是：相对地址 = 真实地址 - 函数基地址 - 相对地址位于函数中的偏移量 - 4
'换种说法，从这个地址4字节之后再向后数n个字节，就是函数的真实地址，则这地址的值就是n，可以为负，代表向前数
Dim i As Long, s As String, TagAddr As Long, APIFuncAddr As Long
APIFuncAddr = GetProcAddress(GetModuleHandle(ModuleName), FuncName)
s = String(8, TagStr)
i = InStr(1, CodeStr, s) '找出函数标记的位置,这就是相对地址位于函数中的偏移量
Do While i > 0
TagAddr = APIFuncAddr - mlngFuncBaseAddr - (i - 1) \ 2 - 4
Mid(CodeStr, i, 8) = LongToStr(TagAddr)
i = InStr(i + 8, CodeStr, s)
Loop
End Sub
Public Sub UnSubClass()
If mlngHwnd <> 0 Then
SetWindowLong mlngHwnd, GWL_WNDPROC, mlngOldFuncAddr
mlngHwnd = 0
End If
If mlngFuncBaseAddr <> 0 Then
GlobalFree mlngFuncBaseAddr
mlngFuncBaseAddr = 0
End If
If mlngVarAddr <> 0 Then
GlobalFree mlngVarAddr
mlngVarAddr = 0
End If
End Sub
Private Sub Class_Terminate()
UnSubClass
End Sub
Private Function LongToStr(ByVal a As Long) As String
Dim s As String, b(3) As Byte, i As Long
CopyMemory b(0), a, 4
For i = 0 To 3
If b(i) > 15 Then
s = s & Hex$(b(i))
Else
s = s & "0" & Hex$(b(i))
End If
Next
LongToStr = s
End Function
'利用Debug对象，判断是否处于IDE环境下
Private Function IsInIDE() As Boolean
Debug.Assert SetTrue(IsInIDE)
End Function
Private Function SetTrue(bValue As Boolean) As Boolean
SetTrue = True
bValue = True
End Function

[zjhome]

不能连续发三贴，只好动作后备马甲了，绝无参与倒分之意^_^
这里我要重点感谢绿豆、僵哥、vbangle、张郎等几位朋友的提醒与帮助，因为几位哪怕仅是只言片语，却都从不同侧面点醒了我。

绿豆说的DllFunctionCall问题，困惑了很久，仔细跟踪后证实调用API时VB真是要Call两次，现在想想，这纯粹是出于安全考虑，DllFunctionCall中应该只是做些调用前的检查与类型转换工作，绕过它直接调用API，也毫无问题。当然有些类型（如String）可能要自己转换了！

绿豆说的ret n问题，新代码已修正，不过，觉得可能还有点小毛病。

僵哥说的COM中某些函數位置的相對固定性问题，我没找到太多资料，除了几个示例外，就是在 张郎的代码中，发现了
lng_ptx = lng_vtable + 28 + (lng_varnum * 2 * 4) + (lng_objvarnum * 3 * 4) + lng_funcnum * 4
这句，与我最初的推测达到一些吻合。也希望张郎能对这句的依据，做些说明。

vbangle推荐的代码，绝对精彩，从中吸收了不少思想，最重要的是让我恢复了突破这个难题的信心。因为我看到，VB连这么细致的代码都能写出来，我这还算难吗？

[rainstormmaster]

//发现每加一个Public普通变量，偏移量就会加8

定义一个Public普通变量，VB会自动为你实现PROPERTY GET，PROPERTY PUT，即：
public x as long后
vb会处理为：
Public Property Get x() As Long

End Property

Public Property Let x(ByVal vNewValue As Long)

End Property

这一点你用oleview看一下就知道了

[VBAdvisor]

'VB怎样用汇编

'***********************************************************
'* Rotating 24Bit Bitmaps in 90° steps *very* fast via asm *
'* *
'* *
'* USE ENTIRELY AT YOUR OWN RISK. *
'* *
'***********************************************************

Option Explicit

Private Declare Function CreateDIBSection Lib "gdi32.dll" ( _
ByVal hdc As Long, _
pBitmapInfo As BITMAPINFO, _
ByVal un As Long, _
ByVal lplpVoid As Long, _
ByVal handle As Long, _
ByVal dw As Long) As Long

Private Declare Function CallWindowProc Lib "user32.dll" Alias "CallWindowProcA" _
(ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal msg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long

Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject _
As Long) As Long

Private Declare Function GetObject Lib "gdi32.dll" Alias "GetObjectA" ( _
ByVal hObject As Long, _
ByVal nCount As Long, _
lpObject As Any) As Long

Private Declare Function SetDIBits Lib "gdi32" ( _
ByVal hdc As Long, ByVal hBitmap As Long, _
ByVal nStartScan As Long, ByVal nNumScans As Long, _
lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) _
As Long

Private Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type

Private Type BITMAPINFOHEADER
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type

Private Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type

Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors As RGBQUAD
End Type

Private Const BI_RGB = 0&
Private Const BI_RLE4 = 2&
Private Const BI_RLE8 = 1&
Private Const DIB_RGB_COLORS = 0

Private Const ASM_ROTATE90 = 0
Private Const ASM_ROTATE180 = 1
Private Const ASM_ROTATE270 = 2
Private Const ASM_ROTATESPECIAL = 3

Sub DoASMRotate(Angle)
Dim SourceBMP As BITMAP
Dim DestBMP As BITMAP

Call GetObject(SourceP.Picture, Len(SourceBMP), SourceBMP)

If SourceBMP.bmBitsPixel <> 24 Then
MsgBox "Geht nur mit 24bit Grafiken!"
Exit Sub
End If

If (SourceBMP.bmWidthBytes And 3) <> 0 Then
SourceBMP.bmWidthBytes = SourceBMP.bmWidthBytes + 2
End If


Dim DestBmpInfo As BITMAPINFO
Dim PtrData As Long
Dim hDib As Long

With DestBmpInfo.bmiHeader
.biSize = Len(DestBmpInfo.bmiHeader)

If Angle = 90 Or Angle = 270 Then
.biWidth = SourceBMP.bmHeight
.biHeight = SourceBMP.bmWidth

ElseIf Angle = 180 Then
.biWidth = SourceBMP.bmWidth
.biHeight = SourceBMP.bmHeight

Else
.biWidth = SourceBMP.bmWidth
.biHeight = SourceBMP.bmHeight * 2

End If

.biPlanes = 1
.biBitCount = 24
.biCompression = BI_RGB
.biSizeImage = ((.biWidth * 3 + 3) And &HFFFFFFFC) * .biHeight
End With

hDib = CreateDIBSection(0, DestBmpInfo, DIB_RGB_COLORS, VarPtr(PtrData), 0, 0)
Call GetObject(hDib, Len(DestBMP), DestBMP)

If (DestBMP.bmWidthBytes And 3) <> 0 Then

DestBMP.bmWidthBytes = DestBMP.bmWidthBytes + 2
End If

Dim AsmPara(8) As Long

AsmPara(0) = SourceBMP.bmBits

AsmPara(1) = PtrData

AsmPara(2) = SourceBMP.bmWidth

AsmPara(3) = SourceBMP.bmHeight

AsmPara(4) = SourceBMP.bmWidthBytes

AsmPara(5) = DestBMP.bmWidthBytes

Select Case Angle
Case 90
AsmPara(6) = ASM_ROTATE90
AsmPara(7) = 0
AsmPara(8) = 0
Case 180
AsmPara(6) = ASM_ROTATE180
AsmPara(7) = 0
AsmPara(8) = 0

Case 270
AsmPara(6) = ASM_ROTATE270
AsmPara(7) = 0
AsmPara(8) = 0

Case Else
AsmPara(6) = ASM_ROTATESPECIAL
AsmPara(7) = -6
AsmPara(8) = -DestBMP.bmWidthBytes * 2
AsmPara(1) = PtrData + DestBMP.bmWidthBytes * DestBMP.bmHeight - _
(DestBMP.bmWidthBytes - DestBMP.bmWidth * 3) - 3
End Select


'ASM code initialise
Dim asm(51) As Long

'check asm.txt for the source
asm(0) = &H90EC8B55: asm(1) = &H8B535657
asm(2) = &H428B0855: asm(3) = &HF88318
asm(4) = &HF8831C74: asm(5) = &H83367401
asm(6) = &H5C7402F8: asm(7) = &H7403F883
asm(8) = &H5F5E5B72: asm(9) = &HFFFFB85D
asm(10) = &HC290FFFF: asm(11) = &H7A8B0010
asm(12) = &H8428B04: asm(13) = &H42AF0F48
asm(14) = &HBBF80314: asm(15) = &H3&
asm(16) = &HB8&: asm(17) = &H14422B00
asm(18) = &HEB03E883: asm(19) = &H47A8B4F
asm(20) = &HF0C428B: asm(21) = &H31442AF
asm(22) = &H85A8BF8: asm(23) = &H8B5B0C8D
asm(24) = &HD92B145A: asm(25) = &HEF83FB2B
asm(26) = &HBB03&: asm(27) = &H5A2B0000
asm(28) = &HFFFAB814: asm(29) = &H24EBFFFF
asm(30) = &H8B047A8B: asm(31) = &H48D0C5A
asm(32) = &H83F8035B: asm(33) = &HFDBB03EF
asm(34) = &H8BFFFFFF: asm(35) = &HE8831442
asm(36) = &H8B09EB03: asm(37) = &H5A8B047A
asm(38) = &H1C428B20: asm(39) = &H51104A8B
asm(40) = &H51084A8B: asm(41) = &H528B328B
asm(42) = &H240C8B0C: asm(43) = &HA4A45756
asm(44) = &HE2F803A4: asm(45) = &H35E5FF9
asm(46) = &H247403FB: asm(47) = &HE9754A04
asm(48) = &H5E5B5858: asm(49) = &HB85D5F
asm(50) = &H90000000: asm(51) = &H10C2&

Dim Result As Long
Result = CallWindowProc(VarPtr(asm(0)), VarPtr(AsmPara(0)), 0, 0, 0)

If Result <> 0 Then
MsgBox "Wrong in ASM Parameter!"
End If

Dim bw As Integer
DestP.AutoRedraw = True ' wichtig
DestP.ScaleMode = 3
Me.ScaleMode = 3
bw = DestP.Width - DestP.ScaleWidth
DestP.Width = DestBmpInfo.bmiHeader.biWidth + bw
DestP.Height = DestBmpInfo.bmiHeader.biHeight + bw

DestP.Cls
'Blit in picturebox :
Result = SetDIBits(DestP.hdc, DestP.Image.handle, 0, DestBmpInfo.bmiHeader.biHeight, ByVal PtrData,
DestBmpInfo, DIB_RGB_COLORS)
DestP.Refresh
DeleteObject (hDib)
End Sub

Private Sub Command1_Click()
DoASMRotate Combo1.Text
End Sub

[VBAdvisor]

'附录
ASM Source:

push ebp
mov ebp,esp

nop ;technical reason (was once Int 3)

push edi
push esi
push ebx

mov edx,[ebp+8] ;get Pointer to Parameter Struct

mov eax,[edx+24]

cmp eax,0
je degree90
cmp eax,1
je degree180
cmp eax,2
je degree270
cmp eax,3
je special

;else: wrong Parameter, exit with error:
pop ebx
pop esi
pop edi
pop ebp
mov eax,-1
nop ;technical reason (was a leave once)
ret 16

degree90: ;***********************************************
;********** calculate destination start Point
mov edi,[edx+4] ;Pointer to Dest Bitmap
mov eax,[edx+8] ;Source Width
dec eax ;-1
imul eax,[edx+20] ;multiply Source Width-1 with dest width in Bytes
add edi,eax ;edi points now to the top right pixel in the Dest Bitmap

;********** calculate destination per line Offset
mov ebx,3

;********** calculate destination per Pixel Offset
mov eax,0
sub eax,[edx+20] ;-Dest Width in Bytes
sub eax,3

jmp dorotate

degree180: ;***********************************************
;********** calculate destination start Point
mov edi,[edx+4] ;Pointer to Dest Bitmap
mov eax,[edx+12] ;Source Height
imul eax,[edx+20] ;multiply Source Height with dest width in Bytes
add edi,eax ;add to start of Dest Bitmap
mov ebx,[edx+8] ;Source Width
lea ecx,[2*ebx+ebx] ;Source Width * 3
mov ebx,[edx+20] ;Dest Width in Bytes
sub ebx,ecx ;ebx contains now the number of PadBytes if there are any
sub edi,ebx ;sub PadBytes
sub edi,3 ;edi points now to the bottom right pixel in the Dest Bitmap

;********** calculate destination per line Offset
mov ebx,0
sub ebx,[edx+20]

;********** calculate destination per Pixel Offset
mov eax,-6

jmp dorotate


degree270: ;***********************************************
;********** calculate destination start Point
mov edi,[edx+4] ;Pointer to Dest Bitmap
mov ebx,[edx+12] ;Source Height
lea eax,[2*ebx+ebx] ;*3
add edi,eax
sub edi,3 ;edi points now to the bottom left pixel in the Dest Bitmap

;********** calculate destination per line Offset
mov ebx,-3

;********** calculate destination per Pixel Offset
mov eax, [edx+20] ;dest width in Bytes
sub eax,3

jmp dorotate

special: ;***********************************************
;********** take destination start Point as defined by user
mov edi,[edx+4] ;Pointer to Dest Bitmap
;********** take destination per line Offset as defined by user
mov ebx,[edx+32]
;********** take destination per Pixel Offset as defined by user
mov eax,[edx+28]

dorotate:
mov ecx,[edx+16] ;Bytes per Source Line
push ecx ;we access this via [ESP+4] and pop it at the end of copying
mov ecx,[edx+8] ;Source Width
push ecx ;we access this via [ESP] and pop it at the end of copying
mov esi,[edx] ;Source Start: top left Pixel
mov edx,[edx+12] ;Source Height
RotateLoop2:
mov ecx,[esp] ;Source Width
push esi
push edi
RotateLoop1:
movsb
movsb
movsb
add edi,eax ;move to next Pixel in the Dest Bitmap
loop RotateLoop1

pop edi
pop esi
add edi,ebx ;move to next Line in the Dest Bitmap
add esi,[esp+4] ;move to next Line in the Source Bitmap

dec edx
jnz RotateLoop2

pop eax ;pop Bytes per Source Line away from Stack
pop eax ;pop Source Width away from Stack

pop ebx
pop esi
pop edi
pop ebp
mov eax,0
nop ;technical reason (was a leave once)
ret 16

[rainstormmaster]

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


说实话，我没细看张郎的代码，不过就上述代码而言，lng_varnum ，lng_objvarnum ，lng_funcnum 定义后都没赋值，它等价于lng_ptx = lng_vtable + 28


我想应该是这样的：
lng_varnum * 2 * 4:属性(公有变量）不为对象时，其实现需要2个方法（PROPERTY GET，PROPERTY PUT）
lng_objvarnum * 3 * 4：属性（公有变量）为对象时，其实现需要3个方法（PROPERTY GET，
PROPERTY PUT，PROPERTY PUTREF）
lng_funcnum * 4：作为方法，就不用说了吧


ps：以上也只是猜测，其结论来在用TLI分析对象

[proer9988]

mark

[junki]

关注

[迈克揉索芙特]

坐在楼下看星星，听故事。

[homezj]

谢谢暴风雨带来的对2*4与3*4的解释，你的猜测也帮我验证了自已猜测的准确性，而且你还为我细化了对2与3的理解。当然，如僵哥所言，这种结论并不敢下得太早，我也看到过说明：不同语言对COM封装的二进制格式并不一定相同，只希望VB是固定的就好。

lng_ptx = lng_vtable + 28...这句，是我在张郎代码中最注意的一个地方，因为，在这之前，我通过实验，曾简单的以为偏移28(&H1C)是固定的，所以看到后，当时就又做了实验，发现每加一个Public普通变量，偏移量就会加8，下面是借用vbangle代码分析的部分结果：
...
401C78 FF511C CALL DWORD PTR [ECX+1C] '这是调用对象方法对象地址加上&H1C的偏移，若加个Public变量，就会是&H24了。
401C7B .. FNCLEX
401C7D .. TEST EAX,EAX
401C7F .. JGE 401C96
'下面应该是VB调用对象方法出错时的标准处理，不过，这段机器码若执行，程序肯定是要崩溃，因为它调用的地址可能并不正确
401C81 .. MOV ECX,DWORD PTR [403010]'这个地址调用时需自己替换为对象指针地址
401C87 6A1C PUSH 1C
...
401C90 .. CALL DWORD PTR [401028] '这个Call应该是VB的标准错误处理段，没处理这个地址，因为若执行到这里，我们的程序也就死定了
401C96 .. MOV EAX,DWORD PTR [ESP+10]'回到正常处理
....

并不是所有Public声明都会增加偏移，至少我已证实Public Enum及Public Event不会。

[supergreenbean]

hoho,同志动作挺快啊~~

[boyzhang]

顶上去.
'--------------------------
最近忙得连放屁的时间都没有.

[ft1000]

记号

[verywzm]

刚注册，觉得这个比较有意思
mark~~~~~~~~

[西雀]

我陪雪貂数星星****

[VBAdvisor]

"实现子类的无崩溃调试，VB程序员不用再羡慕C程序员那么方便的处理消息了，因为VB不仅也可放心处理，还有更直观的界面、更快捷的调试。。。"

无崩溃???
Have you tested on Win98,NT,2000,XP...?
VB crashed when hit END button in IDE on my XP.

[homezj]

经测试，这个方法同样适用为窗体生成公共回调过程机器码，窗体首函数地址，是窗体对象地址偏移&H6F8，若存在公共变量同样会增加偏移（呵呵，只是好奇，我们的程序可自动生成，不用记它）。

'为提高消息处理效率，我把公共过程改成这样的形式，其它基本不动，测试也一次通过
Public Function WndProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wp As Long, ByVal lp As Long) As Long
Dim ProcOK As Long
If mblnInIDE Then
If EbMode = 2 Then
WndProc = CallWindowProc(&H55555555, hwnd, Msg, wp, lp)
Exit Function
End If
End If
Select Case Msg
Case WM_LBUTTONDOWN, WM_PAINT, WM_SYSCOMMAND'这里可随便列出自己要处理的消息，这样会大提高处理效率。
ProcOK = mobjTemp.WndProc(hwnd, Msg, wp, lp)'不需要原窗体处理的返回非零即可
If ProcOK = 0 Then
WndProc = CallWindowProc(&H55555555, hwnd, Msg, wp, lp)
Else
WndProc = ProcOK
End If
Case Else
WndProc = CallWindowProc(&H55555555, hwnd, Msg, wp, lp)
End Select
End Function

这个函数比较长，取机器码的那个常量，Const CodeLen As Long = 300 才够


大致总结了一下，这种方法的好处：
1、可用VB直接做公共过程，随时修改，比固定的机器码方便得多，对不同的窗体与类可以量身定制子类过程，从而可以实现VB中最高效的消息处理机制；
2、这里的应用并仅不限于子类，它只是一种方法，可改编的余地丰常大，凡是需回调函数的地方，都可考虑使用，如对话框回调函数、多线程启动函数、无窗体定时器回调等...

//上面两条是本方法的好处，下面两条，应该说是这种使用机器码全局过程原理的好处。

3、窗体或类的每个实例，都可以有自己独立的子类过程，互不干扰，互不冲突；
4、实现子类的无崩溃调试，VB程序员不用再羡慕C程序员那么方便的处理消息了，因为VB不仅也可放心处理，还有更直观的界面、更快捷的调试。。。

[迈克揉索芙特]

偶继续支持老猩猩们的力做，继续数星星听故事.....

[homezj]

哎！忙了几天，没空结贴，对不住各位！