找回密码
 立即注册→加入我们

QQ登录

只需一步,快速开始

搜索
热搜: 下载 VB C 实现 编写
查看: 6165|回复: 13

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

[复制链接]
发表于 2017-10-18 05:10:34 | 显示全部楼层 |阅读模式

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

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

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

VB6的数组是SAFEARRAY安全数组,而实际的数组的数据是存储在SAFEARRAY结构体的pvData成员指向的地方的。SAFEARRAY的结构如下:
  1. typedef struct tagSAFEARRAYBOUND {
  2.   ULONG cElements;
  3.   LONG  lLbound;
  4. } SAFEARRAYBOUND, *LPSAFEARRAYBOUND;

  5. typedef struct tagSAFEARRAY {
  6.   USHORT         cDims;
  7.   USHORT         fFeatures;
  8.   ULONG          cbElements;
  9.   ULONG          cLocks;
  10.   PVOID          pvData;
  11.   SAFEARRAYBOUND rgsabound[1];
  12. } SAFEARRAY, *LPSAFEARRAY;
复制代码
我就想:如果我自己搞个傀儡数组,然后我修改它的pvData成员的值,是不是可以指哪打哪了?经过我的测试发现它还真是这样。

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

声明API的时候,如果你把某个参数的定义写成“xxxx() As Any”,那么VB6就会在调用这个API的时候把你提供的数组它的SAFEARRAY结构体的地址传给这个API。所以又到了使用某个傀儡函数的时候:VarPtr。
VB6的msvbvm60.dll导出了一个傀儡函数VarPtr,它的实现其实就是把自己参数列表的第一个参数原样返回给你。IDA里面已经看到了,这个VarPtr的反汇编是这么写的:
  1. mov eax,[esp+4]
  2. ret 4
复制代码
所以我们可以手动声明它的API,并且修改它的名字(别名)和参数的定义。我是这样写的:
  1. Declare Function ArrayPtr Lib "msvbvm60.dll" Alias "VarPtr" (ptr() As Any) As Long
复制代码
为了观察VB6自身是如何分配地址存储SAFEARRAY结构体的内容和数据的内容,我写了个测试程序,用了这样的代码来测试:
  1. Private Sub Command3_Click()
  2. Cls

  3. Dim Arr_Int_Fixed(111) As Integer '固定大小Integer数组
  4. Dim Arr_Int_Alloc() As Integer '可变大小Integer数组
  5. ReDim Arr_Int_Alloc(111)

  6. Dim Arr_Long_Fixed(111) As Integer '固定大小Long数组
  7. Dim Arr_Long_Alloc() As Integer '可变大小Long数组
  8. ReDim Arr_Long_Alloc(111)

  9. Dim Arr_Long_Member As TestType '在结构体里定义固定大小Long数组
  10. '结构体声明:
  11. 'Private Type TestType
  12. '    Something As Long
  13. '    SomeArr(111) As Long
  14. 'End Type

  15. Dim Arr_VarPtr As Long '数组变量自身的地址
  16. Dim Arr_Ptr As Long 'SAFEARRAY结构体的地址
  17. Dim Arr_Body As SAFEARRAY 'SAFEARRAY结构体的内容

  18. Arr_VarPtr = ArrayPtr(Arr_Int_Fixed)
  19. CopyMemory Arr_Ptr, ByVal Arr_VarPtr, 4
  20. CopyMemory Arr_Body, ByVal Arr_Ptr, Len(Arr_Body)

  21. Print "Arr_Int_Fixed:"
  22. GoSub PrintArrData

  23. Arr_VarPtr = ArrayPtr(Arr_Int_Alloc)
  24. CopyMemory Arr_Ptr, ByVal Arr_VarPtr, 4
  25. CopyMemory Arr_Body, ByVal Arr_Ptr, Len(Arr_Body)

  26. Print "Arr_Int_Alloc:"
  27. GoSub PrintArrData

  28. Arr_VarPtr = ArrayPtr(Arr_Long_Fixed)
  29. CopyMemory Arr_Ptr, ByVal Arr_VarPtr, 4
  30. CopyMemory Arr_Body, ByVal Arr_Ptr, Len(Arr_Body)

  31. Print "Arr_Long_Fixed:"
  32. GoSub PrintArrData

  33. Arr_VarPtr = ArrayPtr(Arr_Long_Alloc)
  34. CopyMemory Arr_Ptr, ByVal Arr_VarPtr, 4
  35. CopyMemory Arr_Body, ByVal Arr_Ptr, Len(Arr_Body)

  36. Print "Arr_Long_Alloc:"
  37. GoSub PrintArrData

  38. Arr_VarPtr = ArrayPtr(Arr_Long_Member.SomeArr)
  39. CopyMemory Arr_Ptr, ByVal Arr_VarPtr, 4
  40. CopyMemory Arr_Body, ByVal Arr_Ptr, Len(Arr_Body)

  41. Print "Arr_Long_Member:"
  42. GoSub PrintArrData

  43. Exit Sub
  44. PrintArrData:
  45.     '打印数组变量自身的地址和这个数组变量所描述的SAFEARRAY结构体的地址
  46.     Print "Address", Hex$(Arr_VarPtr); "->"; Hex$(Arr_Ptr)
  47.     Print "cDims", Arr_Body.cDims '维数
  48.     Print "fFeatures", Hex$(Arr_Body.fFeatures) '特性
  49.     Print "cbElements", Arr_Body.cbElements '单个元素的大小
  50.     Print "cLocks", Arr_Body.cLocks '是否有锁
  51.     Print "pvData", Hex$(Arr_Body.pvData) '实际的数据的指针
  52.     Print "cElements(0)", Arr_Body.rgsabound(0).cElements '1维元素总数
  53.     Print "lLbound(0)", Arr_Body.rgsabound(0).lLbound '上标
  54.     Return
  55. End Sub
复制代码
注意在VB6里面你的数组变量本身相当于一个SAFEARRAY*,也就是一个指针,指向一个SAFEARRAY结构体。但你自己声明的结构体内的固定大小数组则不是这样的情况。

这个测试的结果如下图所示:
20171016223631.png

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

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

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

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

我通过构造一个结构体,前面做了个傀儡SAFEARRAY结构,后面是数组变量。用法就是直接用对应的函数初始化就行。对应的函数是xxxxPtr_Setup,其中xxxx表示类型。你自己可以通过照葫芦画瓢的方式抄我的结构体和这个函数的实现来实现自己的自定义类型的指针类型。
modArrayPtr.bas (3.67 KB, 下载次数: 9)
  1. Option Explicit

  2. Private Type SAFEARRAYBOUND
  3.     cElements As Long
  4.     lLbound As Long
  5. End Type

  6. Private Type SAFEARRAY
  7.     cDims As Integer
  8.     fFeatures As Integer
  9.     cbElements As Long
  10.     cLocks As Long
  11.     pvData As Long
  12.     rgsabound(0) As SAFEARRAYBOUND
  13. End Type
  14. Private Declare Function ArrayPtr Lib "msvbvm60.dll" Alias "VarPtr" (ptr() As Any) As Long
  15. Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

  16. Private Const FADF_AUTO = &H1 'An array that is allocated on the stack.
  17. Private Const FADF_STATIC = &H2 'An array that is statically allocated.
  18. Private Const FADF_EMBEDDED = &H4 'An array that is embedded in a structure.
  19. Private Const FADF_FIXEDSIZE = &H10 'An array that may not be resized or reallocated.
  20. 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.
  21. 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.
  22. Private Const FADF_HAVEVARTYPE = &H80 'An array that has a variant type. The variant type can be retrieved with SafeArrayGetVartype.
  23. Private Const FADF_BSTR = &H100 'An array of BSTRs.
  24. Private Const FADF_UNKNOWN = &H200 'An array of IUnknown*.
  25. Private Const FADF_DISPATCH = &H400 'An array of IDispatch*.
  26. Private Const FADF_VARIANT = &H800 'An array of VARIANTs.
  27. Private Const FADF_RESERVED = &HF008 'Bits reserved for future use.

  28. Type IntegerPtr
  29.     Dimensions As Integer
  30.     MustBe0x96 As Integer
  31.     MustBe2 As Long
  32.     MustBeOne As Long
  33.     Pointer As Long
  34.     MustBeIntMax As Long
  35.     LBound As Long

  36.     Value() As Integer
  37. End Type

  38. Type LongPtr
  39.     Dimensions As Integer
  40.     MustBe0x96 As Integer
  41.     MustBe4 As Long
  42.     MustBeOne As Long
  43.     Pointer As Long
  44.     MustBeIntMax As Long
  45.     LBound As Long

  46.     Value() As Long
  47. End Type

  48. Type SinglePtr
  49.     Dimensions As Integer
  50.     MustBe0x96 As Integer
  51.     MustBe4 As Long
  52.     MustBeOne As Long
  53.     Pointer As Long
  54.     MustBeIntMax As Long
  55.     LBound As Long

  56.     Value() As Single
  57. End Type

  58. Type DoublePtr
  59.     Dimensions As Integer
  60.     MustBe0x96 As Integer
  61.     MustBe8 As Long
  62.     MustBeOne As Long
  63.     Pointer As Long
  64.     MustBeIntMax As Long
  65.     LBound As Long

  66.     Value() As Double
  67. End Type

  68. Sub IntegerPtr_Setup(Thing As IntegerPtr, ByVal InitPtr As Long)
  69. Thing.Dimensions = 1
  70. Thing.MustBe0x96 = &H96
  71. Thing.MustBe2 = 2
  72. Thing.MustBeOne = 1
  73. Thing.Pointer = InitPtr
  74. Thing.MustBeIntMax = -1
  75. Thing.LBound = 0

  76. CopyMemory ByVal ArrayPtr(Thing.Value()), VarPtr(Thing), 4
  77. End Sub

  78. Sub LongPtr_Setup(Thing As LongPtr, ByVal InitPtr As Long)
  79. Thing.Dimensions = 1
  80. Thing.MustBe0x96 = &H96
  81. Thing.MustBe4 = 4
  82. Thing.MustBeOne = 1
  83. Thing.Pointer = InitPtr
  84. Thing.MustBeIntMax = -1
  85. Thing.LBound = 0

  86. CopyMemory ByVal ArrayPtr(Thing.Value()), VarPtr(Thing), 4
  87. End Sub

  88. Sub SinglePtr_Setup(Thing As SinglePtr, ByVal InitPtr As Long)
  89. Thing.Dimensions = 1
  90. Thing.MustBe0x96 = &H96
  91. Thing.MustBe4 = 4
  92. Thing.MustBeOne = 1
  93. Thing.Pointer = InitPtr
  94. Thing.MustBeIntMax = -1
  95. Thing.LBound = 0

  96. CopyMemory ByVal ArrayPtr(Thing.Value()), VarPtr(Thing), 4
  97. End Sub

  98. Sub DoublePtr_Setup(Thing As DoublePtr, ByVal InitPtr As Long)
  99. Thing.Dimensions = 1
  100. Thing.MustBe0x96 = &H96
  101. Thing.MustBe8 = 8
  102. Thing.MustBeOne = 1
  103. Thing.Pointer = InitPtr
  104. Thing.MustBeIntMax = -1
  105. Thing.LBound = 0

  106. CopyMemory ByVal ArrayPtr(Thing.Value()), VarPtr(Thing), 4
  107. End Sub
复制代码
这里用到了CopyMemory来强行把自己用结构体模拟的“指针类型”中的Value成员指向自己的SAFEARRAY结构体地址——Value成员的“值”一开始就是NULL所以不用担心内存泄漏。

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

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

使用方法不用多说了吧?先定义一个这样的类型,然后用它的对应函数来初始化。最后就是:设置指针,然后操作Value。
  1. Private Sub Command1_Click()
  2. Cls

  3. Dim TheString As String
  4. TheString = "asdfghjkl" '某需要修改的字符串

  5. Dim ThePointer As IntegerPtr '某Integer指针,让它指向这个字符串
  6. IntegerPtr_Setup ThePointer, StrPtr(TheString)

  7. ThePointer.Value(0) = &HFF21 '把第一个字符设为全角A

  8. Print TheString
  9. End Sub
复制代码
20171017235328.png
  1. Private Sub Command2_Click()
  2. Cls

  3. Dim foo As IntegerPtr '某Integer指针
  4. Dim Str1 As String, Str2 As String, Str3 As String '仨字符串

  5. Str1 = "abc" '各自赋值
  6. Str2 = "def"
  7. Str3 = "ghi"

  8. '让指针指向字符串1
  9. IntegerPtr_Setup foo, StrPtr(Str1)
  10. foo.Value(2) = &HFF23 '第三个字符设为全角C

  11. '指向字符串2
  12. foo.Pointer = StrPtr(Str2)
  13. foo.Value(1) = &HFF25 '第二个字符设为全角E

  14. '指向字符串3
  15. foo.Pointer = StrPtr(Str3)
  16. foo.Value(0) = &HFF27 '第一个字符设为全角G

  17. Print Str1
  18. Print Str2
  19. Print Str3

  20. End Sub
复制代码
20171017235827.png
可以看到通过操作指针,字符串里面存储的字符确实被篡改了。

来个实际的:直接用这玩意儿读写一个内存DIB如何?
我做了个例子在这。
20171018054957.png

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

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

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

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

  2. Private Type BITMAPINFOHEADER '40 bytes
  3.     biSize As Long
  4.     biWidth As Long
  5.     biHeight As Long
  6.     biPlanes As Integer
  7.     biBitCount As Integer
  8.     biCompression As Long
  9.     biSizeImage As Long
  10.     biXPelsPerMeter As Long
  11.     biYPelsPerMeter As Long
  12.     biClrUsed As Long
  13.     biClrImportant As Long
  14. End Type
  15. Private Declare Function GetLastError Lib "kernel32" () As Long
  16. Private Declare Function GetTickCount Lib "kernel32" () As Long
  17. Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
  18. 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
  19. Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
  20. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  21. Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
  22. 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
  23. Private Declare Function ArrayPtr Lib "msvbvm60.dll" Alias "VarPtr" (ptr() As Any) As Long
  24. Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
  25. Private Declare Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" (dest As Any, ByVal numBytes As Long)
  26. Private Const DIB_RGB_COLORS = 0 '  color table in RGBs

  27. Private Type RGB_t
  28.     B As Byte
  29.     G As Byte
  30.     R As Byte
  31. End Type

  32. Private Type RGBPtr_t
  33.     Dimensions As Integer
  34.     MustBe0x96 As Integer
  35.     MustBe3 As Long
  36.     MustBeOne As Long
  37.     Pointer As Long
  38.     MustBeIntMax As Long
  39.     LBound As Long

  40.     Value() As RGB_t
  41. End Type

  42. Private m_hDC_canv As Long '画布hDC
  43. Private m_bmp_canv As Long '画布位图
  44. Private m_bmp_canv_ptr As Long '位图指针
  45. Private m_bmp_canv_pitch As Long '每行像素的字节数

  46. '画布的钦定尺寸
  47. Private Const m_canv_width As Long = 320
  48. Private Const m_canv_height As Long = 240

  49. Private Const m_fov As Single = 0.5
  50. Private Const m_light_x As Single = 0.577350269189626
  51. Private Const m_light_y As Single = -0.577350269189626
  52. Private Const m_light_z As Single = 0.577350269189626

  53. '每一行像素的指针
  54. Private m_line_ptrs(m_canv_height - 1) As Long

  55. Private Const Pi As Double = 3.14159265358979

  56. '设置指针的函数
  57. Private Sub RGBPtr_Setup(Thing As RGBPtr_t, ByVal InitPtr As Long)
  58. Thing.Dimensions = 1
  59. Thing.MustBe0x96 = &H96
  60. Thing.MustBe3 = 3 '每个像素3字节
  61. Thing.MustBeOne = 1
  62. Thing.Pointer = InitPtr
  63. Thing.MustBeIntMax = -1
  64. Thing.LBound = 0

  65. CopyMemory ByVal ArrayPtr(Thing.Value()), VarPtr(Thing), 4
  66. End Sub

  67. '设置画板
  68. Private Sub Canv_Setup()
  69. width = (width \ Screen.TwipsPerPixelX + m_canv_width - ScaleWidth) * Screen.TwipsPerPixelX
  70. height = (height \ Screen.TwipsPerPixelY + m_canv_height - ScaleHeight) * Screen.TwipsPerPixelY

  71. Dim BMIF As BITMAPINFOHEADER
  72. With BMIF
  73.     .biSize = 40
  74.     .biWidth = m_canv_width
  75.     .biHeight = m_canv_height
  76.     .biPlanes = 1
  77.     .biBitCount = 24 '其实用32位它能跑更快
  78. End With

  79. '每行像素字节数
  80. m_bmp_canv_pitch = ((BMIF.biWidth * BMIF.biBitCount - 1) \ 32 + 1) * 4

  81. m_hDC_canv = CreateCompatibleDC(hDC)
  82. If m_hDC_canv = 0 Then GoTo ErrOccur

  83. m_bmp_canv = CreateDIBSection(hDC, BMIF, DIB_RGB_COLORS, m_bmp_canv_ptr, 0, 0)
  84. If m_bmp_canv = 0 Then GoTo ErrOccur

  85. DeleteObject SelectObject(m_hDC_canv, m_bmp_canv)

  86. '制作一个数组存储行指针
  87. Dim y As Long, LinePtr As Long
  88. LinePtr = m_bmp_canv_ptr + (m_canv_height - 1) * m_bmp_canv_pitch
  89. For y = 0 To m_canv_height - 1
  90.     m_line_ptrs(y) = LinePtr
  91.     LinePtr = LinePtr - m_bmp_canv_pitch
  92. Next

  93. Exit Sub
  94. ErrOccur: '出错处理
  95. MsgBox "GetLastError = " & GetLastError, vbCritical, "GDI错误"
  96. Unload Me
  97. End Sub

  98. '销毁画板
  99. Private Sub Canv_Unload()
  100. If m_bmp_canv Then DeleteObject m_bmp_canv
  101. If m_hDC_canv Then DeleteDC m_hDC_canv
  102. m_bmp_canv_ptr = 0
  103. m_hDC_canv = 0
  104. m_bmp_canv = 0

  105. Dim y As Long
  106. For y = 0 To m_canv_height - 1
  107.     m_line_ptrs(y) = 0 '把行指针清空。虽然我其实也根本就没打算在代码里判定行指针是否能用
  108. Next
  109. End Sub

  110. Private Sub Form_Load()
  111. Canv_Setup '设置画板
  112. Show '显示窗口

  113. Do
  114.     '绘图
  115.     DrawCanv
  116.     '刷新屏幕
  117.     BitBlt hDC, 0, 0, m_canv_width, m_canv_height, m_hDC_canv, 0, 0, vbSrcCopy
  118. Loop While DoEvents
  119. End Sub

  120. 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)

  121. '绘制三角形
  122. If R < 0 Then R = 0
  123. If G < 0 Then G = 0
  124. If B < 0 Then B = 0
  125. If R > 255 Then R = 255
  126. If G > 255 Then G = 255
  127. If B > 255 Then B = 255

  128. Dim t As Long
  129. Dim x4 As Long, y4 As Long

  130. '排序,让点1在最上,点2在中间,点3在最下
  131. If y2 < y1 Then
  132.     t = x1
  133.     x1 = x2
  134.     x2 = t
  135.     t = y1
  136.     y1 = y2
  137.     y2 = t
  138. End If

  139. If y3 < y1 Then
  140.     t = x1
  141.     x1 = x3
  142.     x3 = t
  143.     t = y1
  144.     y1 = y3
  145.     y3 = t
  146. End If

  147. If y2 > y3 Then
  148.     t = x2
  149.     x2 = x3
  150.     x3 = t
  151.     t = y2
  152.     y2 = y3
  153.     y3 = t
  154. End If

  155. '将这个三角形一分为二,得到上半部分和下半部分
  156. '然后取交点,排序
  157. y4 = y2
  158. x4 = x1 + (x3 - x1) * (y2 - y1) \ (y3 - y1)

  159. If x2 > x4 Then
  160.     t = x2
  161.     x2 = x4
  162.     x4 = t
  163.     t = y2
  164.     y2 = y4
  165.     y4 = t
  166. End If

  167. '现在的状况:
  168. 'p1在最上,p3在最下,p2和p4在同一行,p2靠左。

  169. '                     * p1
  170. '                    /\
  171. '                  /"  \
  172. '                 /     \
  173. '               /"       \
  174. '              /          \
  175. '            /"            \
  176. '           /               \
  177. '         /"                 \
  178. '        /                    \
  179. '      /"                      \
  180. ' p2  *-------------------------*  p4
  181. '      ~-,_                      \
  182. '          ~-,_                   \
  183. '              ~-,_                \
  184. '                  ~-,_             \
  185. '                      ~-,_          \
  186. '                          ~-,_       \
  187. '                              ~-,_    \
  188. '                                  ~-,_ \
  189. '                                      ~-\
  190. '                                         * p3

  191. Dim Pixels As RGBPtr_t '像素指针
  192. Dim x As Long

  193. RGBPtr_Setup Pixels, 0

  194. Dim slices As Long, cur_slice As Long
  195. Dim xleft As Long, xmove As Long, xwidth As Long, curwidth As Long


  196. '绘制上半个三角形(p1-p2-p4)
  197. slices = y2 - y1
  198. xmove = x2 - x1
  199. xwidth = x4 - x2
  200. For cur_slice = 0 To slices - 1
  201.     If slices > 1 Then
  202.         xleft = cur_slice * xmove \ (slices - 1) 'X偏移
  203.         curwidth = cur_slice * xwidth \ (slices - 1) '横线的长度
  204.     Else
  205.         xleft = xmove
  206.         curwidth = xwidth
  207.     End If
  208.    
  209.     '一条条画横线
  210.     Pixels.Pointer = m_line_ptrs(y1 + cur_slice)
  211.     For x = x1 + xleft To x1 + xleft + curwidth + 1
  212.         Pixels.Value(x).R = R
  213.         Pixels.Value(x).G = G
  214.         Pixels.Value(x).B = B
  215.     Next
  216. Next

  217. '绘制下半个三角形(p2-p4-p3)
  218. slices = y3 - y2
  219. xmove = x3 - x2
  220. xwidth = x4 - x2
  221. For cur_slice = 0 To slices - 1
  222.     If slices > 1 Then
  223.         xleft = cur_slice * xmove \ (slices - 1) 'X偏移
  224.         curwidth = xwidth - cur_slice * xwidth \ (slices - 1) '横线的长度
  225.     Else
  226.         xleft = xmove
  227.         curwidth = 0
  228.     End If
  229.    
  230.     '一条条画横线
  231.     Pixels.Pointer = m_line_ptrs(y2 + cur_slice)
  232.     For x = x2 + xleft To x2 + xleft + curwidth + 1
  233.         Pixels.Value(x).R = R
  234.         Pixels.Value(x).G = G
  235.         Pixels.Value(x).B = B
  236.     Next
  237. Next

  238. End Sub

  239. Private Sub Proj(ByVal x As Single, ByVal y As Single, ByVal z As Single, xout As Long, yout As Long)
  240. '随手来个透视投影,不带近平面切割
  241. x = x / (z * m_fov)
  242. y = -y / (z * m_fov)

  243. '坐标系变换到屏幕
  244. xout = m_canv_width \ 2 + x * (m_canv_height / 2)
  245. yout = (y + 1) * 0.5 * m_canv_height
  246. End Sub

  247. Private Sub DrawBack()
  248. '绘制背景
  249. Dim x As Long, y As Long
  250. Dim Pixels As RGBPtr_t

  251. RGBPtr_Setup Pixels, 0

  252. Dim lum As Long

  253. '省去这步、直接用ZeroMemory涂黑背景比这快得多
  254. For y = 0 To m_canv_height - 1
  255.     Pixels.Pointer = m_line_ptrs(y)
  256.     For x = 0 To m_canv_width - 1
  257.         lum = Sin(Timer * 20 + (x + y) * Pi * 0.5) * 10 + 100 '斜纹
  258.         Pixels.Value(x).R = lum
  259.         Pixels.Value(x).G = lum
  260.         Pixels.Value(x).B = lum
  261.     Next
  262. Next
  263. End Sub

  264. '画一个立方体
  265. 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)

  266. 's表示Sin,c表示Cos,r p y是roll pitch yaw的缩写
  267. Dim sr As Single, cr As Single
  268. Dim sp As Single, cp As Single
  269. Dim sy As Single, cy As Single
  270. sy = Sin(yaw)
  271. cy = Cos(yaw)
  272. sp = Sin(pitch)
  273. cp = Cos(pitch)
  274. sr = Sin(roll)
  275. cr = Cos(roll)

  276. '某些组合的乘积
  277. Dim srcp As Single, srsp As Single
  278. Dim crcp As Single, crsp As Single
  279. srcp = sr * cp
  280. srsp = sr * sp
  281. crcp = cr * cp
  282. crsp = cr * sp

  283. '旋转矩阵
  284. Dim dxx As Single, dxy As Single, dxz As Single 'x轴
  285. Dim dyx As Single, dyy As Single, dyz As Single 'y轴
  286. Dim dzx As Single, dzy As Single, dzz As Single 'z轴

  287. 'roll:
  288. 'c,-s, 0
  289. 's, c, 0
  290. '0, 0, 1
  291. '
  292. 'pitch:
  293. '1, 0, 0
  294. '0, c,-s
  295. '0, s, c
  296. '
  297. 'yaw:
  298. 'c, 0,-s
  299. '0, 1, 0
  300. 's, 0, c
  301. '
  302. 'rp
  303. 'cr, -sr cp,  sr sp
  304. 'sr,  cr cp, -cr sp
  305. '0,      sp,     cp
  306. '
  307. 'rpy
  308. 'cr cy + sr sp sy, -sr cp, -sy cr + sr sp cy
  309. 'sr cy - cr sp sy,  cr cp, -sy sr - cr sp cy
  310. '           sy cp,     sp,             cp cy

  311. '欧拉角矩阵
  312. dxx = (cr * cy + srsp * sy) * box_width
  313. dxy = (-sr * cp) * box_width
  314. dxz = (-sy * cr + srsp * cy) * box_width

  315. dyx = (sr * cy - crsp * sy) * box_height
  316. dyy = (crcp) * box_height
  317. dyz = (-sy * sr - crsp * cy) * box_height

  318. dzx = (sy * cp) * box_depth
  319. dzy = (sp) * box_depth
  320. dzz = (cp * cy) * box_depth

  321. '把三轴都弄成不背对镜头方向
  322. If dxz > 0 Then
  323.     dxx = -dxx
  324.     dxy = -dxy
  325.     dxz = -dxz
  326. End If

  327. If dyz > 0 Then
  328.     dyx = -dyx
  329.     dyy = -dyy
  330.     dyz = -dyz
  331. End If

  332. If dzz > 0 Then
  333.     dzx = -dzx
  334.     dzy = -dzy
  335.     dzz = -dzz
  336. End If

  337. Dim p1x As Long, p1y As Long
  338. Dim p2x As Long, p2y As Long
  339. Dim p3x As Long, p3y As Long
  340. Dim p4x As Long, p4y As Long
  341. Dim r_ As Long, g_ As Long, b_ As Long
  342. Dim bright As Single

  343. '如果x面是正面
  344. If (c_x + dxx) * dxx + (c_y + dxy) * dxy + (c_z + dxz) * dxz <= 0 Then
  345.    
  346.     '亮度
  347.     bright = -(dxx * m_light_x + dxy * m_light_y + dxz * m_light_z)
  348.     If bright < 0 Then bright = 0
  349.     '颜色
  350.     r_ = 10 + bright * 102
  351.     g_ = 20 + bright * 204
  352.     b_ = 25 + bright * 255
  353.     '投影
  354.     Proj c_x + dxx + dyx + dzx, c_y + dxy + dyy + dzy, c_z + dxz + dyz + dzz, p1x, p1y
  355.     Proj c_x + dxx + dyx - dzx, c_y + dxy + dyy - dzy, c_z + dxz + dyz - dzz, p2x, p2y
  356.     Proj c_x + dxx - dyx + dzx, c_y + dxy - dyy + dzy, c_z + dxz - dyz + dzz, p3x, p3y
  357.     Proj c_x + dxx - dyx - dzx, c_y + dxy - dyy - dzy, c_z + dxz - dyz - dzz, p4x, p4y
  358.     '绘制x面
  359.     GoSub DrawFace
  360. End If

  361. '如果y面是正面
  362. If (c_x + dyx) * dyx + (c_y + dyy) * dyy + (c_z + dyz) * dyz <= 0 Then
  363.    
  364.     '亮度
  365.     bright = -(dyx * m_light_x + dyy * m_light_y + dyz * m_light_z)
  366.     If bright < 0 Then bright = 0
  367.     '颜色
  368.     r_ = 60 + bright * 60
  369.     g_ = 0
  370.     b_ = 120 + bright * 120
  371.     '投影
  372.     Proj c_x + dyx + dxx + dzx, c_y + dyy + dxy + dzy, c_z + dyz + dxz + dzz, p1x, p1y
  373.     Proj c_x + dyx + dxx - dzx, c_y + dyy + dxy - dzy, c_z + dyz + dxz - dzz, p2x, p2y
  374.     Proj c_x + dyx - dxx + dzx, c_y + dyy - dxy + dzy, c_z + dyz - dxz + dzz, p3x, p3y
  375.     Proj c_x + dyx - dxx - dzx, c_y + dyy - dxy - dzy, c_z + dyz - dxz - dzz, p4x, p4y
  376.     '绘制y面
  377.     GoSub DrawFace
  378. End If

  379. '如果z面是正面
  380. If (c_x + dzx) * dzx + (c_y + dzy) * dzy + (c_z + dzz) * dzz <= 0 Then
  381.    
  382.     '亮度
  383.     bright = -(dzx * m_light_x + dzy * m_light_y + dzz * m_light_z)
  384.     If bright < 0 Then bright = 0
  385.     '颜色
  386.     r_ = 5 + bright * 5
  387.     g_ = 100 + bright * 100
  388.     b_ = 5 + bright * 5
  389.     '投影
  390.     Proj c_x + dzx + dyx + dxx, c_y + dzy + dyy + dxy, c_z + dzz + dyz + dxz, p1x, p1y
  391.     Proj c_x + dzx + dyx - dxx, c_y + dzy + dyy - dxy, c_z + dzz + dyz - dxz, p2x, p2y
  392.     Proj c_x + dzx - dyx + dxx, c_y + dzy - dyy + dxy, c_z + dzz - dyz + dxz, p3x, p3y
  393.     Proj c_x + dzx - dyx - dxx, c_y + dzy - dyy - dxy, c_z + dzz - dyz - dxz, p4x, p4y
  394.     '绘制z面
  395.     GoSub DrawFace
  396. End If

  397. Exit Sub
  398. DrawFace:
  399.    
  400.     '一个面其实是俩三角形面片
  401.     DrawTri p1x, p1y, p2x, p2y, p3x, p3y, r_, g_, b_
  402.     DrawTri p2x, p2y, p4x, p4y, p3x, p3y, r_, g_, b_
  403.    
  404.     Return
  405. End Sub

  406. Private Sub DrawCanv()
  407. '画背景
  408. DrawBack

  409. '画立方体
  410. DrawCube 0, 0, 4, Timer * 2, Timer, Timer, 1, 1, 1
  411. End Sub

  412. Private Sub Form_Unload(Cancel As Integer)
  413. Canv_Unload
  414. End Sub
复制代码
Bin: sa.exe (28.04 KB, 下载次数: 11)
校验信息
名称:sa.exe
SHA256:AC8674730044CA074562EE05EBE907FA7F169E567FEFE129E07BC45002D423EA
养成下载exe时校验哈希值的习惯。

本帖被以下淘专辑推荐:

回复

使用道具 举报

发表于 2017-10-18 10:47:32 | 显示全部楼层
膜拜LZ的超神技术。
回复 赞! 靠!

使用道具 举报

发表于 2017-10-18 15:57:18 | 显示全部楼层
大神好腻害!
回复 赞! 靠!

使用道具 举报

发表于 2017-10-19 21:34:16 | 显示全部楼层
厉害,创造了一个VB-C语言!!
回复 赞! 靠!

使用道具 举报

发表于 2017-10-19 21:35:55 | 显示全部楼层
元始天尊 发表于 2017-10-19 21:34
厉害,创造了一个VB-C语言!!

我过来看看学长们在干啥
回复 赞! 靠!

使用道具 举报

发表于 2017-10-21 18:12:53 | 显示全部楼层
学习一下
回复

使用道具 举报

发表于 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 了解一下。
回复 赞! 靠!

使用道具 举报

发表于 2024-2-6 16:01:53 | 显示全部楼层
啥也不说了,帖子就是带劲!
回复 赞! 靠!

使用道具 举报

发表于 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
回复 赞! 靠!

使用道具 举报

发表于 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的实际数据
回复 赞! 靠!

使用道具 举报

本版积分规则

QQ|Archiver|小黑屋|技术宅的结界 ( 滇ICP备16008837号 )|网站地图

GMT+8, 2024-5-25 04:45 , Processed in 0.043867 second(s), 29 queries , Gzip On.

Powered by Discuz! X3.5

© 2001-2024 Discuz! Team.

快速回复 返回顶部 返回列表