【VB6】在VB6里实现“指针类型”——像C语言的[]那样用()来读写内存中的数组！

0xAA55 · 发表于 2017-10-18 05:10:34

欢迎访问技术宅的结界，请注册或者登录吧。

您需要登录才可以下载或查看，没有账号？立即注册→加入我们

×

以前我提到过各种VB6里面使用指针的方法比如用VarPtr取得变量的地址然后用CopyMemory（实际上是RtlMoveMemory）来把指定地址的数据复制到自己的地方或者把自己的数据复制到指定地方。现在可以不用那么麻烦了：通过设置SAFEARRAY来直接像访问自家数组一样去读写一个指定的内存区域的数据。

VB6的数组是SAFEARRAY安全数组，而实际的数组的数据是存储在SAFEARRAY结构体的pvData成员指向的地方的。SAFEARRAY的结构如下：

typedef struct tagSAFEARRAYBOUND {
ULONG cElements;
LONG lLbound;
} SAFEARRAYBOUND, *LPSAFEARRAYBOUND;
typedef struct tagSAFEARRAY {
USHORT cDims;
USHORT fFeatures;
ULONG cbElements;
ULONG cLocks;
PVOID pvData;
SAFEARRAYBOUND rgsabound[1];
} SAFEARRAY, *LPSAFEARRAY;

复制代码

我就想：如果我自己搞个傀儡数组，然后我修改它的pvData成员的值，是不是可以指哪打哪了？经过我的测试发现它还真是这样。

那么在VB6里面如何才能找出一个数组它的SAFEARRAY结构体的存储位置呢？经过多次尝试我发现：

声明API的时候，如果你把某个参数的定义写成“xxxx() As Any”，那么VB6就会在调用这个API的时候把你提供的数组它的SAFEARRAY结构体的地址传给这个API。所以又到了使用某个傀儡函数的时候：VarPtr。
VB6的msvbvm60.dll导出了一个傀儡函数VarPtr，它的实现其实就是把自己参数列表的第一个参数原样返回给你。IDA里面已经看到了，这个VarPtr的反汇编是这么写的：

mov eax,[esp+4]
ret 4

复制代码

所以我们可以手动声明它的API，并且修改它的名字（别名）和参数的定义。我是这样写的：

Declare Function ArrayPtr Lib "msvbvm60.dll" Alias "VarPtr" (ptr() As Any) As Long

复制代码

为了观察VB6自身是如何分配地址存储SAFEARRAY结构体的内容和数据的内容，我写了个测试程序，用了这样的代码来测试：

Private Sub Command3_Click()
Cls
Dim Arr_Int_Fixed(111) As Integer '固定大小Integer数组
Dim Arr_Int_Alloc() As Integer '可变大小Integer数组
ReDim Arr_Int_Alloc(111)
Dim Arr_Long_Fixed(111) As Integer '固定大小Long数组
Dim Arr_Long_Alloc() As Integer '可变大小Long数组
ReDim Arr_Long_Alloc(111)
Dim Arr_Long_Member As TestType '在结构体里定义固定大小Long数组
'结构体声明：
'Private Type TestType
' Something As Long
' SomeArr(111) As Long
'End Type
Dim Arr_VarPtr As Long '数组变量自身的地址
Dim Arr_Ptr As Long 'SAFEARRAY结构体的地址
Dim Arr_Body As SAFEARRAY 'SAFEARRAY结构体的内容
Arr_VarPtr = ArrayPtr(Arr_Int_Fixed)
CopyMemory Arr_Ptr, ByVal Arr_VarPtr, 4
CopyMemory Arr_Body, ByVal Arr_Ptr, Len(Arr_Body)
Print "Arr_Int_Fixed:"
GoSub PrintArrData
Arr_VarPtr = ArrayPtr(Arr_Int_Alloc)
CopyMemory Arr_Ptr, ByVal Arr_VarPtr, 4
CopyMemory Arr_Body, ByVal Arr_Ptr, Len(Arr_Body)
Print "Arr_Int_Alloc:"
GoSub PrintArrData
Arr_VarPtr = ArrayPtr(Arr_Long_Fixed)
CopyMemory Arr_Ptr, ByVal Arr_VarPtr, 4
CopyMemory Arr_Body, ByVal Arr_Ptr, Len(Arr_Body)
Print "Arr_Long_Fixed:"
GoSub PrintArrData
Arr_VarPtr = ArrayPtr(Arr_Long_Alloc)
CopyMemory Arr_Ptr, ByVal Arr_VarPtr, 4
CopyMemory Arr_Body, ByVal Arr_Ptr, Len(Arr_Body)
Print "Arr_Long_Alloc:"
GoSub PrintArrData
Arr_VarPtr = ArrayPtr(Arr_Long_Member.SomeArr)
CopyMemory Arr_Ptr, ByVal Arr_VarPtr, 4
CopyMemory Arr_Body, ByVal Arr_Ptr, Len(Arr_Body)
Print "Arr_Long_Member:"
GoSub PrintArrData
Exit Sub
PrintArrData:
'打印数组变量自身的地址和这个数组变量所描述的SAFEARRAY结构体的地址
Print "Address", Hex$(Arr_VarPtr); "->"; Hex$(Arr_Ptr)
Print "cDims", Arr_Body.cDims '维数
Print "fFeatures", Hex$(Arr_Body.fFeatures) '特性
Print "cbElements", Arr_Body.cbElements '单个元素的大小
Print "cLocks", Arr_Body.cLocks '是否有锁
Print "pvData", Hex$(Arr_Body.pvData) '实际的数据的指针
Print "cElements(0)", Arr_Body.rgsabound(0).cElements '1维元素总数
Print "lLbound(0)", Arr_Body.rgsabound(0).lLbound '上标
Return
End Sub

复制代码

注意在VB6里面你的数组变量本身相当于一个SAFEARRAY*，也就是一个指针，指向一个SAFEARRAY结构体。但你自己声明的结构体内的固定大小数组则不是这样的情况。

这个测试的结果如下图所示：

可以发现以下特征：（有些虽然看不出，但结合我的测试它就是这种效果）

固定大小数组变量自身和它指向的SAFEARRAY结构体都在栈上，但数据在堆上。
可变大小数组变量在栈上，但它指向的SAFEARRAY结构体在堆上，经过测试我发现VB6会在这个数组变量生命周期结束后对这个SAFEARRAY结构体所占的内存进行了释放内存的操作，也就是类似C语言的“free()”的操作。此外可变大小数组的数据也是在堆上的，并且是单独分配的，而不是和SAFEARRAY结构体一起分配的。
对于结构体内的固定大小数组，这个变量自身和它指向的SAFEARRAY结构体都在栈上，而数据则在结构体里。图中可以看到这个结构体自身是在栈上的。

其中我说的在堆上的玩意儿，经过我的测试就是不停地点按钮的话，那几个值特别大的数字它是不停地变化的。也就是它确实有个内存的分配和释放的操作在里面。

那么……如果我在某个地址上有个数据但我想要直接访问它而不经过CopyMemory的话，我是不是可以自己构建一个傀儡SAFEARRAY，来让我的数组“一出生”它就指向我要的数据，并且可以直接读写呢？经过我的尝试：这是完全可行的！
但要注意VB6会对生命周期结束的SAFEARRAY进行回收操作，一个阻止回收操作的方法就是把cLocks成员的值设为非零。这样它就会因为上了锁而不再尝试回收它。

我写了个一个Module，照抄里面的代码就能构建自己的指针类型。实测还是很方便的。

我通过构造一个结构体，前面做了个傀儡SAFEARRAY结构，后面是数组变量。用法就是直接用对应的函数初始化就行。对应的函数是xxxxPtr_Setup，其中xxxx表示类型。你自己可以通过照葫芦画瓢的方式抄我的结构体和这个函数的实现来实现自己的自定义类型的指针类型。

modArrayPtr.bas (3.67 KB, 下载次数: 9)

Option Explicit
Private Type SAFEARRAYBOUND
cElements As Long
lLbound As Long
End Type
Private Type SAFEARRAY
cDims As Integer
fFeatures As Integer
cbElements As Long
cLocks As Long
pvData As Long
rgsabound(0) As SAFEARRAYBOUND
End Type
Private Declare Function ArrayPtr Lib "msvbvm60.dll" Alias "VarPtr" (ptr() As Any) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Const FADF_AUTO = &H1 'An array that is allocated on the stack.
Private Const FADF_STATIC = &H2 'An array that is statically allocated.
Private Const FADF_EMBEDDED = &H4 'An array that is embedded in a structure.
Private Const FADF_FIXEDSIZE = &H10 'An array that may not be resized or reallocated.
Private Const FADF_RECORD = &H20 'An array that contains records. When set, there will be a pointer to the IRecordInfo interface at negative offset 4 in the array descriptor.
Private Const FADF_HAVEIID = &H40 'An array that has an IID identifying interface. When set, there will be a GUID at negative offset 16 in the safe array descriptor. Flag is set only when Private Const FADF_DISPATCH or Private Const FADF_UNKNOWN is also set.
Private Const FADF_HAVEVARTYPE = &H80 'An array that has a variant type. The variant type can be retrieved with SafeArrayGetVartype.
Private Const FADF_BSTR = &H100 'An array of BSTRs.
Private Const FADF_UNKNOWN = &H200 'An array of IUnknown*.
Private Const FADF_DISPATCH = &H400 'An array of IDispatch*.
Private Const FADF_VARIANT = &H800 'An array of VARIANTs.
Private Const FADF_RESERVED = &HF008 'Bits reserved for future use.
Type IntegerPtr
Dimensions As Integer
MustBe0x96 As Integer
MustBe2 As Long
MustBeOne As Long
Pointer As Long
MustBeIntMax As Long
LBound As Long
Value() As Integer
End Type
Type LongPtr
Dimensions As Integer
MustBe0x96 As Integer
MustBe4 As Long
MustBeOne As Long
Pointer As Long
MustBeIntMax As Long
LBound As Long
Value() As Long
End Type
Type SinglePtr
Dimensions As Integer
MustBe0x96 As Integer
MustBe4 As Long
MustBeOne As Long
Pointer As Long
MustBeIntMax As Long
LBound As Long
Value() As Single
End Type
Type DoublePtr
Dimensions As Integer
MustBe0x96 As Integer
MustBe8 As Long
MustBeOne As Long
Pointer As Long
MustBeIntMax As Long
LBound As Long
Value() As Double
End Type
Sub IntegerPtr_Setup(Thing As IntegerPtr, ByVal InitPtr As Long)
Thing.Dimensions = 1
Thing.MustBe0x96 = &H96
Thing.MustBe2 = 2
Thing.MustBeOne = 1
Thing.Pointer = InitPtr
Thing.MustBeIntMax = -1
Thing.LBound = 0
CopyMemory ByVal ArrayPtr(Thing.Value()), VarPtr(Thing), 4
End Sub
Sub LongPtr_Setup(Thing As LongPtr, ByVal InitPtr As Long)
Thing.Dimensions = 1
Thing.MustBe0x96 = &H96
Thing.MustBe4 = 4
Thing.MustBeOne = 1
Thing.Pointer = InitPtr
Thing.MustBeIntMax = -1
Thing.LBound = 0
CopyMemory ByVal ArrayPtr(Thing.Value()), VarPtr(Thing), 4
End Sub
Sub SinglePtr_Setup(Thing As SinglePtr, ByVal InitPtr As Long)
Thing.Dimensions = 1
Thing.MustBe0x96 = &H96
Thing.MustBe4 = 4
Thing.MustBeOne = 1
Thing.Pointer = InitPtr
Thing.MustBeIntMax = -1
Thing.LBound = 0
CopyMemory ByVal ArrayPtr(Thing.Value()), VarPtr(Thing), 4
End Sub
Sub DoublePtr_Setup(Thing As DoublePtr, ByVal InitPtr As Long)
Thing.Dimensions = 1
Thing.MustBe0x96 = &H96
Thing.MustBe8 = 8
Thing.MustBeOne = 1
Thing.Pointer = InitPtr
Thing.MustBeIntMax = -1
Thing.LBound = 0
CopyMemory ByVal ArrayPtr(Thing.Value()), VarPtr(Thing), 4
End Sub

复制代码

这里用到了CopyMemory来强行把自己用结构体模拟的“指针类型”中的Value成员指向自己的SAFEARRAY结构体地址——Value成员的“值”一开始就是NULL所以不用担心内存泄漏。

代码里，你可以看到我用MustBe0x96、MustBe8、MustBeOne等方式来提示对傀儡SAFEARRAY结构体的操作。这些钦定的值其实就是为了制造一个能骗过VB6、使其不做多余的free动作的SAFEARRAY结构体，来让VB6对它“不闻不问”。这样我操作数组的时候VB6就会直接按照指针的值去走了。

MustBeIntMax这个是“数组元素个数”，为了不限制你的访问长度，我把它设为-1.你可以通过将其改成你的缓冲区的大小，来让VB6自己的下标越界检测生效。这是一个不错的做法，但我知道你不喜欢。

使用方法不用多说了吧？先定义一个这样的类型，然后用它的对应函数来初始化。最后就是：设置指针，然后操作Value。

Private Sub Command1_Click()
Cls
Dim TheString As String
TheString = "asdfghjkl" '某需要修改的字符串
Dim ThePointer As IntegerPtr '某Integer指针，让它指向这个字符串
IntegerPtr_Setup ThePointer, StrPtr(TheString)
ThePointer.Value(0) = &HFF21 '把第一个字符设为全角Ａ
Print TheString
End Sub

复制代码

Private Sub Command2_Click()
Cls
Dim foo As IntegerPtr '某Integer指针
Dim Str1 As String, Str2 As String, Str3 As String '仨字符串
Str1 = "abc" '各自赋值
Str2 = "def"
Str3 = "ghi"
'让指针指向字符串1
IntegerPtr_Setup foo, StrPtr(Str1)
foo.Value(2) = &HFF23 '第三个字符设为全角Ｃ
'指向字符串2
foo.Pointer = StrPtr(Str2)
foo.Value(1) = &HFF25 '第二个字符设为全角Ｅ
'指向字符串3
foo.Pointer = StrPtr(Str3)
foo.Value(0) = &HFF27 '第一个字符设为全角Ｇ
Print Str1
Print Str2
Print Str3
End Sub

复制代码

可以看到通过操作指针，字符串里面存储的字符确实被篡改了。

来个实际的：直接用这玩意儿读写一个内存DIB如何？
我做了个例子在这。

图上这个玩意儿是用CPU写颜色数据到DIB上实现的。也就是用VB6通过这个“指针类型”来操作位图的RGB数据实现的。

图片是静止的，但实际这个立方体它是翻来翻去的。动态的。

分辨率调大的话就有点卡了。

顺带一提这玩意儿它还实现了一个粗略的透视投影和一个欧拉角矩阵的生成代码，建议参考使用。

Option Explicit
Private Type BITMAPINFOHEADER '40 bytes
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 Declare Function GetLastError Lib "kernel32" () As Long
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hDC As Long, pBitmapInfo As Any, ByVal un As Long, lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function ArrayPtr Lib "msvbvm60.dll" Alias "VarPtr" (ptr() As Any) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" (dest As Any, ByVal numBytes As Long)
Private Const DIB_RGB_COLORS = 0 ' color table in RGBs
Private Type RGB_t
B As Byte
G As Byte
R As Byte
End Type
Private Type RGBPtr_t
Dimensions As Integer
MustBe0x96 As Integer
MustBe3 As Long
MustBeOne As Long
Pointer As Long
MustBeIntMax As Long
LBound As Long
Value() As RGB_t
End Type
Private m_hDC_canv As Long '画布hDC
Private m_bmp_canv As Long '画布位图
Private m_bmp_canv_ptr As Long '位图指针
Private m_bmp_canv_pitch As Long '每行像素的字节数
'画布的钦定尺寸
Private Const m_canv_width As Long = 320
Private Const m_canv_height As Long = 240
Private Const m_fov As Single = 0.5
Private Const m_light_x As Single = 0.577350269189626
Private Const m_light_y As Single = -0.577350269189626
Private Const m_light_z As Single = 0.577350269189626
'每一行像素的指针
Private m_line_ptrs(m_canv_height - 1) As Long
Private Const Pi As Double = 3.14159265358979
'设置指针的函数
Private Sub RGBPtr_Setup(Thing As RGBPtr_t, ByVal InitPtr As Long)
Thing.Dimensions = 1
Thing.MustBe0x96 = &H96
Thing.MustBe3 = 3 '每个像素3字节
Thing.MustBeOne = 1
Thing.Pointer = InitPtr
Thing.MustBeIntMax = -1
Thing.LBound = 0
CopyMemory ByVal ArrayPtr(Thing.Value()), VarPtr(Thing), 4
End Sub
'设置画板
Private Sub Canv_Setup()
width = (width \ Screen.TwipsPerPixelX + m_canv_width - ScaleWidth) * Screen.TwipsPerPixelX
height = (height \ Screen.TwipsPerPixelY + m_canv_height - ScaleHeight) * Screen.TwipsPerPixelY
Dim BMIF As BITMAPINFOHEADER
With BMIF
.biSize = 40
.biWidth = m_canv_width
.biHeight = m_canv_height
.biPlanes = 1
.biBitCount = 24 '其实用32位它能跑更快
End With
'每行像素字节数
m_bmp_canv_pitch = ((BMIF.biWidth * BMIF.biBitCount - 1) \ 32 + 1) * 4
m_hDC_canv = CreateCompatibleDC(hDC)
If m_hDC_canv = 0 Then GoTo ErrOccur
m_bmp_canv = CreateDIBSection(hDC, BMIF, DIB_RGB_COLORS, m_bmp_canv_ptr, 0, 0)
If m_bmp_canv = 0 Then GoTo ErrOccur
DeleteObject SelectObject(m_hDC_canv, m_bmp_canv)
'制作一个数组存储行指针
Dim y As Long, LinePtr As Long
LinePtr = m_bmp_canv_ptr + (m_canv_height - 1) * m_bmp_canv_pitch
For y = 0 To m_canv_height - 1
m_line_ptrs(y) = LinePtr
LinePtr = LinePtr - m_bmp_canv_pitch
Next
Exit Sub
ErrOccur: '出错处理
MsgBox "GetLastError = " & GetLastError, vbCritical, "GDI错误"
Unload Me
End Sub
'销毁画板
Private Sub Canv_Unload()
If m_bmp_canv Then DeleteObject m_bmp_canv
If m_hDC_canv Then DeleteDC m_hDC_canv
m_bmp_canv_ptr = 0
m_hDC_canv = 0
m_bmp_canv = 0
Dim y As Long
For y = 0 To m_canv_height - 1
m_line_ptrs(y) = 0 '把行指针清空。虽然我其实也根本就没打算在代码里判定行指针是否能用
Next
End Sub
Private Sub Form_Load()
Canv_Setup '设置画板
Show '显示窗口
Do
'绘图
DrawCanv
'刷新屏幕
BitBlt hDC, 0, 0, m_canv_width, m_canv_height, m_hDC_canv, 0, 0, vbSrcCopy
Loop While DoEvents
End Sub
Private Sub DrawTri(ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long, ByVal x3 As Long, ByVal y3 As Long, Optional ByVal R As Long, Optional ByVal G As Long, Optional ByVal B As Long)
'绘制三角形
If R < 0 Then R = 0
If G < 0 Then G = 0
If B < 0 Then B = 0
If R > 255 Then R = 255
If G > 255 Then G = 255
If B > 255 Then B = 255
Dim t As Long
Dim x4 As Long, y4 As Long
'排序，让点1在最上，点2在中间，点3在最下
If y2 < y1 Then
t = x1
x1 = x2
x2 = t
t = y1
y1 = y2
y2 = t
End If
If y3 < y1 Then
t = x1
x1 = x3
x3 = t
t = y1
y1 = y3
y3 = t
End If
If y2 > y3 Then
t = x2
x2 = x3
x3 = t
t = y2
y2 = y3
y3 = t
End If
'将这个三角形一分为二，得到上半部分和下半部分
'然后取交点，排序
y4 = y2
x4 = x1 + (x3 - x1) * (y2 - y1) \ (y3 - y1)
If x2 > x4 Then
t = x2
x2 = x4
x4 = t
t = y2
y2 = y4
y4 = t
End If
'现在的状况：
'p1在最上，p3在最下，p2和p4在同一行，p2靠左。
' * p1
' /\
' /" \
' / \
' /" \
' / \
' /" \
' / \
' /" \
' / \
' /" \
' p2 *-------------------------* p4
' ~-,_ \
' ~-,_ \
' ~-,_ \
' ~-,_ \
' ~-,_ \
' ~-,_ \
' ~-,_ \
' ~-,_ \
' ~-\
' * p3
Dim Pixels As RGBPtr_t '像素指针
Dim x As Long
RGBPtr_Setup Pixels, 0
Dim slices As Long, cur_slice As Long
Dim xleft As Long, xmove As Long, xwidth As Long, curwidth As Long
'绘制上半个三角形（p1-p2-p4）
slices = y2 - y1
xmove = x2 - x1
xwidth = x4 - x2
For cur_slice = 0 To slices - 1
If slices > 1 Then
xleft = cur_slice * xmove \ (slices - 1) 'X偏移
curwidth = cur_slice * xwidth \ (slices - 1) '横线的长度
Else
xleft = xmove
curwidth = xwidth
End If
'一条条画横线
Pixels.Pointer = m_line_ptrs(y1 + cur_slice)
For x = x1 + xleft To x1 + xleft + curwidth + 1
Pixels.Value(x).R = R
Pixels.Value(x).G = G
Pixels.Value(x).B = B
Next
Next
'绘制下半个三角形（p2-p4-p3）
slices = y3 - y2
xmove = x3 - x2
xwidth = x4 - x2
For cur_slice = 0 To slices - 1
If slices > 1 Then
xleft = cur_slice * xmove \ (slices - 1) 'X偏移
curwidth = xwidth - cur_slice * xwidth \ (slices - 1) '横线的长度
Else
xleft = xmove
curwidth = 0
End If
'一条条画横线
Pixels.Pointer = m_line_ptrs(y2 + cur_slice)
For x = x2 + xleft To x2 + xleft + curwidth + 1
Pixels.Value(x).R = R
Pixels.Value(x).G = G
Pixels.Value(x).B = B
Next
Next
End Sub
Private Sub Proj(ByVal x As Single, ByVal y As Single, ByVal z As Single, xout As Long, yout As Long)
'随手来个透视投影，不带近平面切割
x = x / (z * m_fov)
y = -y / (z * m_fov)
'坐标系变换到屏幕
xout = m_canv_width \ 2 + x * (m_canv_height / 2)
yout = (y + 1) * 0.5 * m_canv_height
End Sub
Private Sub DrawBack()
'绘制背景
Dim x As Long, y As Long
Dim Pixels As RGBPtr_t
RGBPtr_Setup Pixels, 0
Dim lum As Long
'省去这步、直接用ZeroMemory涂黑背景比这快得多
For y = 0 To m_canv_height - 1
Pixels.Pointer = m_line_ptrs(y)
For x = 0 To m_canv_width - 1
lum = Sin(Timer * 20 + (x + y) * Pi * 0.5) * 10 + 100 '斜纹
Pixels.Value(x).R = lum
Pixels.Value(x).G = lum
Pixels.Value(x).B = lum
Next
Next
End Sub
'画一个立方体
Private Sub DrawCube(ByVal c_x As Single, ByVal c_y As Single, ByVal c_z As Single, ByVal yaw As Single, ByVal pitch As Single, ByVal roll As Single, Optional ByVal box_width As Single = 1, Optional ByVal box_height As Single = 1, Optional ByVal box_depth As Single = 1)
's表示Sin，c表示Cos，r p y是roll pitch yaw的缩写
Dim sr As Single, cr As Single
Dim sp As Single, cp As Single
Dim sy As Single, cy As Single
sy = Sin(yaw)
cy = Cos(yaw)
sp = Sin(pitch)
cp = Cos(pitch)
sr = Sin(roll)
cr = Cos(roll)
'某些组合的乘积
Dim srcp As Single, srsp As Single
Dim crcp As Single, crsp As Single
srcp = sr * cp
srsp = sr * sp
crcp = cr * cp
crsp = cr * sp
'旋转矩阵
Dim dxx As Single, dxy As Single, dxz As Single 'x轴
Dim dyx As Single, dyy As Single, dyz As Single 'y轴
Dim dzx As Single, dzy As Single, dzz As Single 'z轴
'roll:
'c,-s, 0
's, c, 0
'0, 0, 1
'
'pitch:
'1, 0, 0
'0, c,-s
'0, s, c
'
'yaw:
'c, 0,-s
'0, 1, 0
's, 0, c
'
'rp
'cr, -sr cp, sr sp
'sr, cr cp, -cr sp
'0, sp, cp
'
'rpy
'cr cy + sr sp sy, -sr cp, -sy cr + sr sp cy
'sr cy - cr sp sy, cr cp, -sy sr - cr sp cy
' sy cp, sp, cp cy
'欧拉角矩阵
dxx = (cr * cy + srsp * sy) * box_width
dxy = (-sr * cp) * box_width
dxz = (-sy * cr + srsp * cy) * box_width
dyx = (sr * cy - crsp * sy) * box_height
dyy = (crcp) * box_height
dyz = (-sy * sr - crsp * cy) * box_height
dzx = (sy * cp) * box_depth
dzy = (sp) * box_depth
dzz = (cp * cy) * box_depth
'把三轴都弄成不背对镜头方向
If dxz > 0 Then
dxx = -dxx
dxy = -dxy
dxz = -dxz
End If
If dyz > 0 Then
dyx = -dyx
dyy = -dyy
dyz = -dyz
End If
If dzz > 0 Then
dzx = -dzx
dzy = -dzy
dzz = -dzz
End If
Dim p1x As Long, p1y As Long
Dim p2x As Long, p2y As Long
Dim p3x As Long, p3y As Long
Dim p4x As Long, p4y As Long
Dim r_ As Long, g_ As Long, b_ As Long
Dim bright As Single
'如果x面是正面
If (c_x + dxx) * dxx + (c_y + dxy) * dxy + (c_z + dxz) * dxz <= 0 Then
'亮度
bright = -(dxx * m_light_x + dxy * m_light_y + dxz * m_light_z)
If bright < 0 Then bright = 0
'颜色
r_ = 10 + bright * 102
g_ = 20 + bright * 204
b_ = 25 + bright * 255
'投影
Proj c_x + dxx + dyx + dzx, c_y + dxy + dyy + dzy, c_z + dxz + dyz + dzz, p1x, p1y
Proj c_x + dxx + dyx - dzx, c_y + dxy + dyy - dzy, c_z + dxz + dyz - dzz, p2x, p2y
Proj c_x + dxx - dyx + dzx, c_y + dxy - dyy + dzy, c_z + dxz - dyz + dzz, p3x, p3y
Proj c_x + dxx - dyx - dzx, c_y + dxy - dyy - dzy, c_z + dxz - dyz - dzz, p4x, p4y
'绘制x面
GoSub DrawFace
End If
'如果y面是正面
If (c_x + dyx) * dyx + (c_y + dyy) * dyy + (c_z + dyz) * dyz <= 0 Then
'亮度
bright = -(dyx * m_light_x + dyy * m_light_y + dyz * m_light_z)
If bright < 0 Then bright = 0
'颜色
r_ = 60 + bright * 60
g_ = 0
b_ = 120 + bright * 120
'投影
Proj c_x + dyx + dxx + dzx, c_y + dyy + dxy + dzy, c_z + dyz + dxz + dzz, p1x, p1y
Proj c_x + dyx + dxx - dzx, c_y + dyy + dxy - dzy, c_z + dyz + dxz - dzz, p2x, p2y
Proj c_x + dyx - dxx + dzx, c_y + dyy - dxy + dzy, c_z + dyz - dxz + dzz, p3x, p3y
Proj c_x + dyx - dxx - dzx, c_y + dyy - dxy - dzy, c_z + dyz - dxz - dzz, p4x, p4y
'绘制y面
GoSub DrawFace
End If
'如果z面是正面
If (c_x + dzx) * dzx + (c_y + dzy) * dzy + (c_z + dzz) * dzz <= 0 Then
'亮度
bright = -(dzx * m_light_x + dzy * m_light_y + dzz * m_light_z)
If bright < 0 Then bright = 0
'颜色
r_ = 5 + bright * 5
g_ = 100 + bright * 100
b_ = 5 + bright * 5
'投影
Proj c_x + dzx + dyx + dxx, c_y + dzy + dyy + dxy, c_z + dzz + dyz + dxz, p1x, p1y
Proj c_x + dzx + dyx - dxx, c_y + dzy + dyy - dxy, c_z + dzz + dyz - dxz, p2x, p2y
Proj c_x + dzx - dyx + dxx, c_y + dzy - dyy + dxy, c_z + dzz - dyz + dxz, p3x, p3y
Proj c_x + dzx - dyx - dxx, c_y + dzy - dyy - dxy, c_z + dzz - dyz - dxz, p4x, p4y
'绘制z面
GoSub DrawFace
End If
Exit Sub
DrawFace:
'一个面其实是俩三角形面片
DrawTri p1x, p1y, p2x, p2y, p3x, p3y, r_, g_, b_
DrawTri p2x, p2y, p4x, p4y, p3x, p3y, r_, g_, b_
Return
End Sub
Private Sub DrawCanv()
'画背景
DrawBack
'画立方体
DrawCube 0, 0, 4, Timer * 2, Timer, Timer, 1, 1, 1
End Sub
Private Sub Form_Unload(Cancel As Integer)
Canv_Unload
End Sub

复制代码

Bin:

sa.exe (28.04 KB, 下载次数: 12)
校验信息
名称：sa.exe
SHA256：AC8674730044CA074562EE05EBE907FA7F169E567FEFE129E07BC45002D423EA
养成下载exe时校验哈希值的习惯。

Golden Blonde · 发表于 2017-10-18 10:47:32

膜拜LZ的超神技术。

PASSOK · 发表于 2017-10-18 15:57:18

大神好腻害！

元始天尊 · 发表于 2017-10-19 21:34:16

厉害，创造了一个VB-C语言！！

‬‫K · 发表于 2017-10-19 21:35:55

元始天尊发表于 2017-10-19 21:34
厉害，创造了一个VB-C语言！！

我过来看看学长们在干啥

cxx · 发表于 2017-10-21 18:12:53

学习一下

watermelon · 发表于 2019-8-26 22:02:16

厉害，看不懂！

系统消息 · 发表于 2019-9-2 20:42:30

这个太麻烦了点，msvbvm60.dll其实导出了GetMemX、PutMemX、SetMemX这些函数（X对应字节数或类型，比如读写4字节整数和浮点数都是用GetMem4和PutMem4，而同为4字节的字符串用GetMemStr和PutMemStr），GetMemX即内存取值函数，PutMemX即内存Let赋值函数，SetMemX即内存Set赋值函数，VB6在类模块中定义的Public成员变量，编译器就是用这三类函数去分别实现它们的Property Get、Property Let、Property Set三个过程。
根据这个原理，我在2015年的时候写过一个msvbvm60.tlb，把这三类函数声明进去了，并把它们声明成了带参属性，用它们来实现模拟指针操作：
地址 = VarPtr(变量) '取变量地址
旧值 = PtrLng(地址) '读取地址指向的Long值（VB6取地址函数名称是Ptr在后面，反过来Ptr放前面表示反向操作）
PtrLng(地址) = 新值 '给地址指向内存赋一个Long值
地址 = StrPtr(字符串) '取字符串的缓冲区地址
旧地址 = StrPtrEx(字符串变量) '取字符串变量的缓冲区地址扩展版（扩展的是赋值功能，不是取值功能）
StrPtrEx(字符串变量) = 新地址 '修改字符串变量的缓冲区地址（跟StrPtr的区别是，StrPtr不支持修改地址）
字符串变量地址 = VarPtr(字符串变量) '取字符串的变量地址
字符串缓冲区地址 = StrPtr(字符串) '取字符串的缓冲区地址
旧值 = PtrStr(字符串变量地址) '读取地址指向的String值（注意：PtrStr同PtrLng是对VarPtr的反向，不是对StrPtr的反向）
PtrStr(字符串变量地址) = 新值 '给地址指向内存赋一个String值
字符串值 = GetPtrStr(字符串缓冲区地址) '读取地址指向的字符串缓冲区值（这个才是对StrPtr的反向，但是这个不能赋值，所以就干脆加个Get前缀来区分）

竹笋大师 · 发表于 2020-1-6 23:37:05

Sub LongPtr_Setup(Thing As LongPtr, ByVal InitPtr As Long)，可以把一个指针和数组绑定。
如何把3个数组中的2个绑定到另一个上？
dim a(10) as long,b() as long ,c() as long
a有11个数据，如何让b和C的地址都改成A的？改B就是A改了，改C也是A改了，b和A相同,C和A相同的内容。
或者只有2个数组时把B数组地址改成A的，目标就是改了B就是改了A，改了A，B也能读出变动的数据。

竹笋大师 · 发表于 2020-1-6 23:38:56

如果只是2个变量：A AS LONG,B AS LONG，c as long ，如何把B的地址改成A,c的地址改成A，达到最终A,B,C相等？

勇芳软件 · 发表于 2020-1-14 23:14:21

VisualFreeBasic 里及其简单而基础的指针功能，到了VB里如此麻烦和高技术，
时代在进步，科技在进步，VB6 也应该进步了， VisualFreeBasic 了解一下。

gujin163 · 发表于 2024-2-6 16:01:53

啥也不说了，帖子就是带劲！

QZhi · 发表于 2024-2-22 21:00:57

如果觉得卡可以试试 SetDIBitsToDevice。
在我的电脑上用 SetDIBitsToDevice 渲染 640*400 的图像（同一张）的效率是 BitBlt 的 4 ~ 7 倍。
SetDIBitsToDevice frmCanvas.hdc, 0, 0, Width, Height, 0, 0, 0, Height, mCanvas(0, 0), biCanvasInfo, DIB_RGB_COLORS

tlwh163 · 发表于 2024-4-21 09:01:54

竹笋大师发表于 2020-1-6 23:38
如果只是2个变量：A AS LONG,B AS LONG，c as long ，如何把B的地址改成A,c的地址改成A，达到最终A,B,C相 ...

dim a as long的意思是在函数栈里分配4个字节的内存用来存储字面量a的实际数据

账号		自动登录	找回密码
密码			立即注册→加入我们

【VB6】在VB6里实现“指针类型”——像C语言的[]那样用()来读写内存中的数组！

欢迎访问技术宅的结界，请注册或者登录吧。

本帖被以下淘专辑推荐:

相关帖子