巧用Win32 API函数增强VB位操作功能
（作者：刘琦）
摘要：Visual Basic 的位操作功能较弱，甚至连最常用的移位运算都不支持，因此在使用ＶＢ开发诸如数据加密、压缩、通信之类的程序时往往困难重重。针对这一问题，本文详细地阐释了位操作的本质，并利用Ｗｉｎ32 ＡＰＩ函数实现了整型变量的拆分、合并、移位等ＶＢ不支持的位操作功能。
关键词：Visual Basic、位操作、移位
一 引言
笔者在编程实践中发现，ＶＢ对位操作的支持仅限于AND、OR、XOR几种位运算，远远不如其他的开发工具那样全面（如Visual C++、C++Builder、Delphi等开发工具都提供了整形变量的移位、拆分、合并的运算），因此在使用ＶＢ编写诸如加密之类的通用数据处理程序时往往困难重重。为了使以后的开发工作不再陷入僵局，我开始寻求增强VB位操作功能的通用方法，以达到一劳永逸的效果。
ＶＢ的数据类型不够丰富，整形数只包括Byte、Integer、Long三种类型，分别对应C++中的 unsigned char、short 和 long 类型，而我们常用的二字节无符号整形unsigned short(也叫“字”、Word)、四字节无符号整形unsigned long(也叫“双字”、DWord)在VB中却没有被支持。 但好在无符号数和有符号数在二进制的层次上没有任何差别，不同之处仅在于编译器对变量的理解。在进行位操作时我们只关心变量的二进制位，因此ＶＢ中的Integer类型可以当作Word类型使用，Long类型则对应DWord。（此后文中提及的Integer类型均指VB Integer类型，Long类型均指VB Long类型，Word 、DWord类型则是不依赖于特定编译器的对二字节、四字节整形值的通用称呼）再来看位运算方面，可以看出VB不支持整型变量的左移、右移、拆分、合并等操作。
经过上述的分析之后，已经确定了工作的可行性和工作目标，于是笔者决定开发一个通用模块来增强VB的位操作功能，这个模块是可重用的，只要把这个模块加入工程中，就可以象使用VB的内置函数一样透明的使用模块中的函数，非常方便。如果使用大量的可重用模块来开发程序，则开发周期短，代码可读性好，易于维护，不容易出错。
二设计思路
1. 实现整形变量的拆分、合并
整型变量的拆分、合并是经常要用到的操作，比如IP地址就是一个四字节的双字，有时候为了以点分十进制的方式显示IP地址，就需要单独取出每个字节的值，而有时候为了把点分十进制的IP地址转换为计算机内部的双字，又需要把四个字节组合成一个双字。VB没有提供这样的功能，所以整型变量的拆分、合并也是我们这次要实现的功能。另外整型变量的拆分、合并也是实现Integer、Long类型变量移位的前提条件(后面“分而治之策略”将会提到)，只要实现了整型变量的拆分合并，移位问题就完全解决了。
方法1：利用API函数Copymemory实现
在这里笔者利用Win32 API 函数CopyMemory实现了整形变量的拆分、合并操作。在VB中使用API函数必须要声明，CopyMemory函数的声明代码如下：
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(Destination As Any， Source As Any， ByVal Length As Long)
其中的参数Destination是目标内存的第一个字节地址，参数Source是被复制内存的第一个字节地址，参数Length是需要复制的字节数。
实现原理很简单：要实现拆分，就用CopyMemory函数把一个整形变量的一部分拷贝到另一个更小的整形变量的地址空间中；而实现合并，则利用CopyMemory函数把两个待合并的小变量拷贝到另一个大整形变量的地址空间中。见示例代码：
Public Function Hi(ByVal Word As Integer) As Byte
'取一个字（Word）的高字节（Byte）
'INPUT-------------------------------------------
'Word 字（Word）
'OUTPUT------------------------------------------
'返回值 Word参数的高字节
'Last updated by Liu Qi 2004-3-20。
Dim bytRet As Byte
CopyMemory bytRet， ByVal VarPtr(Word) + 1， 1’把Word的高字节的内容烤入bytRet的地址处
Hi = bytRet’返回结果
End Function
根据数据类型的不同需要，笔者共设计了6个函数，HI（）函数用来获得一个单字的高字节，LO（）函数获得单字的低字节，HIWORD（）函数获得双字的高位字，LOWORD（）函数双字的低位字。ＣＯＮ（）函数把两个字节组合成字，CONWORD（）函数把两个字组合成双字。只要把这６个函数组合应用就可以随意的拆分、组合各种整型变量。例如前面提到的ＩＰ地址，ＩＰ地址是用一个ＤＷＯＲＤ类型变量存储的，在ＶＢ中则对应Long类型变量，假设一个ＩＰ地址存储在长整型变量中，就可以这样提取一个ＩＰ地址的最高字节：ＨＩ（ＨＩＷＯＲＤ（lngＩＰ））。
由于代码较长，故没有在文章中写出全部代码，全部代码请到编辑部网站下载。
方法2：利用安全数组借用内存的方法实现
方法1虽然用起来简单方便，但是要执行API函数调用，函数调用时要保存现场、恢复现场，时间开销很大，效率太低，因此不适合大数据量密集运算的场合。笔者在开发加密软件时曾使用方法1来处理文件数据，效果很不理想，速度奇慢。其实有一种方法可以巧妙的骗过VB，让一个数组直接访问其他变量的内存空间，从而达到拆分、合并整形变量的目的。由于这种方法省去了API函数调用，因此效率非常高。下面就让我们认识一下VB中的安全数组。VB中的安全数组与C语言中的数组有很大的差别，虽然在VB和C语言中数组变量都是指针，但C语言中的数组变量直接指向数组元素，而 VB中的数组变量却是指向一个SafeArray结构，这个SafeArray结构中的pvData域才指向数组元素。见图
那么这个SafeArray结构是做什么用的呢？它存储着数组的上界、下界、维数、元素大小等一系列的信息，正是SafeArray结构的存在，使得VB程序能够对数组的访问做越界检查，这就是为什么VB中的数组叫做安全数组的原因，而C语言中的数组显然不具备越界检查的能力。当然安全数组的缺点就是没有C语言的数组灵活，但尽管如此，我们还是有办法操纵它，通过对安全数组的操纵，可以让它访问任意的内存位置，甚至包括其他变量的内存空间。对于一维数组来说，它的SafeArray结构如下：
Type SafeArray1d '1维数组的 SafeArray 定义
cDims As Integer '维数
fFeatures As Integer '标志
cbElements As Long '单个元素的字节数
clocks As Long '锁定计数
pvData As Long '指向数组元素的指针
cElements As Long '维定义，该维的元素个数
Lbound As Long '该维的下界
End Type
如果显式的给一个数组变量赋值，让它指向我们自己创建的SafeArray结构，就可以通过设置SafeArray结构的pvData域来访问任意内存位置。请看示例代码：
Public Declare Function VarPtrArray 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 Sub Command2_Click()
Dim pBytesInLong() As Byte
Dim SA1D As SafeArray1d
Dim i As Long
With SA1D
.cDims = 1
.fFeatures = 17
.cbElements = 1
.clocks = 0
.pvData = VarPtr(i) '使数组的数据指针指向长整形变量 i
.cElements = 4
.Lbound = 0
End With
'使数组变量（其实就是个指针）指向我们自己创建的 SafeArray1d 结构
CopyMemory ByVal VarPtrArray(pBytesInLong)， VarPtr(SA1D)， 4
i = &HFFFFFFFF
MsgBox pBytesInLong(1) '访问长整形变量的第2个字节（从低处开始数）
pBytesInLong(3) = 0 '把全部数组元素设为0
pBytesInLong(2) = 0
pBytesInLong(1) = 0
pBytesInLong(0) = 0
MsgBox i '你会发现 i 也变成了 0
'把数组变量（其实就是个指针）指向 0，既 C 语言中的 NULL
CopyMemory ByVal VarPtrArray(pBytesInLong)， 0&， 4
End Sub
从代码中可以看到我们用一个字节数组借用了长整形变量i的地址空间，从而可以通过数组元素访问变量i的各个字节。这样也实现了拆分、组合整形变量的目的，和方法1殊途同归，但很显然方法2不需要函数调用，不需要数据复制，因此效率非常高。用这种方法，我专门构筑了一个模块：FastBitEx模块，实现了方法1中提及的6个函数的Fast版本，代码很长，不在这里给出，请读者参阅代码。
2．移位运算的设计实现
在很多VB的资料和代码中都用乘以2的方法实现左移，除以2的方法实现右移。这是可行的，也是有理论依据的。下图是一个BYTE类型的权值表：
位序号
7
6
5
4
3
2
1
0
权值
27
26
25
24
23
22
21
20
可以看出每一位的权值都是比它低一位的那一位的权值的2倍，对一个BYTE变量左移一位相当于每一个二进制位都向高位移动，则每一位的权值变为原来的两倍（最高位除外），由于BYTE变量的十进制值等于它的每个二进制位的值和该位权值的乘积的总和，所以把一个BYTE变量左移和把它的十进制值乘以2是等效的，唯一的区别就是如果BYTE变量的最高位为 1，乘以2会溢出，我们要使用一个小技巧防止溢出：先把最高位屏蔽为0，再乘以2就不会溢出了。据此我们可以写出把BYTE类型变量左移1位的函数：
Private Function ShLB_By1Bit(ByVal Byt As Byte) As Byte
‘把BYTE类型变量左移1位的函数，参数Byt是待移位的字节，函数返回移位结果
‘(Byt And &H7F)的作用是屏蔽最高位。 *2：左移一位
ShLB_By1Bit = (Byt And &H7F) * 2
End Function
类似的把BYTE类型变量右移1位时采用除以2的方法 ，这时要注意舍去小数位，以免VB按照四舍五入的方法处理小数位而引起结果不正确。据此我们可以写出把BYTE类型变量右移1位的函数：
Private Function ShRB_By1Bit(ByVal Byt As Byte) As Byte
‘把BYTE类型变量右移1位的函数，参数Byt是待移位的字节，函数返回移位结果
‘/2：右移一位
ShRB_By1Bit = Fix(Byt / 2)
End Function
有了移一位的函数，那么移任意位数的函数就不难写出了：只要反复的调用ShLB_By1Bit()或ShRB_By1Bit()就可以了，参见代码中的函数ShLB() 和 ShRB()。
至此字节变量的移位问题已经得到解决，现在再来看单字和双字的移位，它们分别对应VB中的Integer和Long类型。用乘以2和除以2的方法还行吗？用几个数试验一下就会发现，这个方法失灵了。请看各种运算结果的对比：
A=1001’0111’1110’1100
右移一位： 0100’1011’1111’0110
（A/2）：1100’1011’1111’0110
问题好象变的有点复杂了，其实导致这个方法失灵的最根本的原因是VB把Integer和Long类型当做有符号数理解，把一个有符号数乘以2或除以2，最高位（即符号位）根本就没有参与运算，这一点从上面的运算结果对比就可以看出来：把A除以2 以后最高位还是1，根本就没有变，而右移一位后最高位补入的是0，两种运算的结果自然是相去甚远。不只是符号位的问题，如果选用其它的数据来对比还会发现更多的问题，这里就不再赘述了。难道就真的没有办法了吗？办法当然是有的，既然已经实现了字节的移位操作，那么可以 用“分而治之”的策略，把Integer变量一分为二，拆成两个字节，把这两个字节交给ShLB（）或ＳhＲＢ（），把它俩各移一位，最后把移位后的两字节重新组合成一个Integer变量就是移位后的结果了，这不就实现了Integer类型变量的移位了吗。这种方法完全绕过了有符号数的符号位给我们带来的众多麻烦，顺利的实现了目的。用这种方法需要注意一点：如果是左移，要保证把低字节的最高位移入高字节的最低位，反之如果是右移，要把高字节的最低位移入低字节的最高位。从下面的代码中可以看到实现的过程：
Private Function ShLW_By1Bit(ByVal Word As Integer) As Integer
'把一个字左移一位的函数， 参数Word是待移位的字，函数返回移位结果
'INPUT-------------------------------
'Word 源操作数
'OUTPUT------------------------------
'返回值 移位结果
'last updated by Liu Qi 2004-3-24
Dim HiByte As Byte， LoByte As Byte
'把字拆分为字节
HiByte = Hi(Word)： LoByte = Lo(Word)
'把高字节左移一位，保证把低字节的最高位移入高字节的最低位
HiByte = ShLB_By1Bit(HiByte) Or IIf((LoByte And &H80) = &H80， &H1， &H0)
LoByte = ShLB_By1Bit(LoByte) '低字节左移一位
'把移位后的字节再重新组合成字
ShLW_By1Bit = Con(HiByte， LoByte)
End Function
至于Long类型，和Integer类型一样，属于有符号数，也不能用乘以2和除以2的方法实现移位。我们只好和处理Integer类型一样如法炮制，用分而治之的方法实现移位。具体过程不再赘述，请参看代码。
3.移位运算的性能优化
本文中的移位实现方法偏重于代码的可读性，没有优化代码的性能，因此不适用于对性能要求苛刻的场合。为了优化性能，可以用查表法来优化执行速度，这是一种拿空间换时间的方案，移位结果可以事先都计算出来，保存在移位表中，用的时候查表，比用*2，/2快多了。比如，字节类型的移位表数组定义如下：
dim aSHLB(0 to 255,1 to 7) as byte'字节左移表
dim aSHRB(0 to 255,1 to 7) as byte'字节右移表
使用方法也很简单，比如想要求字节变量x左移一位的结果，只需使用aSHLB(x,1)就可得到，和函数调用很相似。当然，与函数调用不同的是，使用移位表之前一定要初始化移位表的所有元素，否则会得到错误的结果。
Integer类型的移位也可以用查表法，移位表占用 65535 * 15 * 2 * 2 个字节的内存空间。
移位表数组定义如下：
aSHLW(0 to &Hffff&,1 to 15) as integer'单字的左移表
aSHRW(0 to &Hffff&,1 to 15) as integer'单字的右移表
注意：Integer是有符号类型，造表的时候要用它的无符号值来造表，同样查表的时候也要用它的无符号值来查表。（因为数组下标是不允许负数的。）
求Integer类型无符号值的方法是：(Int and &hFFFF&),注意，不等同于CLng(Int)
遗憾的是，Long类型无法造表，因为Long类型的值的范围是 4 GB,如果对它造表，那么表的大小就会超出总的内存地址空间。
查表移位的代码请参见本文附带的代码，这里就不给出了。
三 结语
要想实现本文所述的那些位操作函数其实有很多方法，本文所用的方式未必是最好的，主要是为了提供一种解决问题的思路：在编程过程中遇到难以解决的问题时，想一想能不能把大问题分解成能解决或已解决的小问题，这就是“分而治之”的策略。因笔者水平有限，本文难免会有疏漏和不足之处，欢迎批评指正，有意见或建议给我发电子邮件liuqi5521@sina.com。
本程序在 Win2000+VB6.0下调试通过。
------------------------------------------------------------
本文相关代码：
-----------------------BitEx.Bas----------------------------
Option Explicit
'说明----------------------------------------
'这是一个增强 vb 的位操作功能的模块，主要包含
'有左右移位，取字节，字节连接等通用例程
'兼容性：VB5.0 ,6.0
'--------------------------------------------
'作者：刘琦 ，2005-1-11
'个人主页：http://LQweb.crcoo.com
'e-Mail：liuqi5521@hotmail.com
'api函数 拷贝内存
Private Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" _
(Destination As Any, Source As Any, ByVal Length As Long)
'-----------------------下面这些例程实现整型变量的拆分，合并操作-------------
Public Function Con(ByVal HiByte As Byte, ByVal LoByte As Byte) As Integer
'把两个字节 (Byte) 连成一个字 （word）
'INPUT--------------------------------------------------------------------
'HiByte 参与连结的高字节
'LoByte 参与连结的低字节
'OUTPUT-------------------------------------------------------------------
'返回值 连结的结果
'Last updated by Liu Qi 2004-3-20.
Dim iRet As Integer
'用到的函数 varptr() 说明：取一个变量的地址。
CopyMemory ByVal VarPtr(iRet), LoByte, 1
CopyMemory ByVal VarPtr(iRet) + 1, HiByte, 1
Con = iRet
End Function
Public Function ConWord(ByVal HiWord As Integer, ByVal LoWord As Integer) As Long
'把两个字（Word）连成一个双字（DWord）
'INPUT--------------------------------------------------------------------
'HiWord 参与连结的高位字
'LoWord 参与连结的低位字
'OUTPUT-------------------------------------------------------------------
'返回值 连结的结果
'Last updated by Liu Qi 2004-3-20.
Dim lRet As Long
CopyMemory ByVal VarPtr(lRet), LoWord, 2
CopyMemory ByVal VarPtr(lRet) + 2, HiWord, 2
ConWord = lRet
End Function
Public Function Hi(ByVal Word As Integer) As Byte
'取一个字（Word）的高字节（Byte）
'INPUT-------------------------------------------
'Word 字（Word）
'OUTPUT------------------------------------------
'返回值 Word参数的高字节
'Last updated by Liu Qi 2004-3-20.
Dim bytRet As Byte
CopyMemory bytRet, ByVal VarPtr(Word) + 1, 1
Hi = bytRet
End Function
Public Function Lo(ByVal Word As Integer) As Byte
'取一个字（Word）的低字节（Byte）
'INPUT-------------------------------------------
'Word 字（Word）
'OUTPUT------------------------------------------
'返回值 Word参数的低字节
'Last updated by Liu Qi 2004-3-20.
Dim bytRet As Byte
CopyMemory bytRet, ByVal VarPtr(Word), 1
Lo = bytRet
End Function
Public Function HiWord(ByVal DWord As Long) As Integer
'取一个双字（DWord）的高位字
'INPUT-------------------------------------------
'DWord 双字
'OUTPUT------------------------------------------
'返回值 DWord参数的高位字
'Last updated by Liu Qi 2004-3-20.
Dim intRet As Integer
CopyMemory intRet, ByVal VarPtr(DWord) + 2, 2
HiWord = intRet
End Function
Public Function LoWord(ByVal DWord As Long) As Integer
'取一个双字（DWord）的低位字
'INPUT-------------------------------------------
'DWord 双字
'OUTPUT------------------------------------------
'返回值 DWord参数的低位字
'Last updated by Liu Qi 2004-3-20.
Dim intRet As Integer
CopyMemory intRet, ByVal VarPtr(DWord), 2
LoWord = intRet
End Function
'-------------------------下面这些例程实现整形变量的移位-------------------
Public Function ShLB(ByVal Byt As Byte, Optional ByVal BitsNum As Long = 1) As Byte
'字节的左移函数
'INPUT-----------------------------
'Byt 源操作数
'BitsNum 移位的位数
'OUTPUT----------------------------
'返回值 移位结果
'last updated by Liu Qi 2004-3-23
Dim i&
For i = 1 To BitsNum
Byt = ShLB_By1Bit(Byt)
Next i
ShLB = Byt
End Function
Public Function ShRB(ByVal Byt As Byte, Optional ByVal BitsNum As Long = 1) As Byte
'字节的右移函数
'INPUT-----------------------------
'Byt 源操作数
'BitsNum 移位的位数
'OUTPUT----------------------------
'返回值 移位结果
'last updated by Liu Qi 2004-3-23
Dim i&
For i = 1 To BitsNum
Byt = ShRB_By1Bit(Byt)
Next i
ShRB = Byt
End Function
Private Function ShLB_By1Bit(ByVal Byt As Byte) As Byte
'把字节左移一位的函数,为 ShlB 服务.
'INPUT-----------------------------
'Byt 源操作数
'OUTPUT----------------------------
'返回值 移位结果
'last updated by Liu Qi 2004-3-23
'(Byt And &H7F): 屏蔽最高位. *2:左移一位
ShLB_By1Bit = (Byt And &H7F) * 2
'ShlB_By1Bit = Byt * 2'溢出测试
End Function
Private Function ShRB_By1Bit(ByVal Byt As Byte) As Byte
'把字节右移一位的函数,为 ShrB 服务.
'INPUT-----------------------------
'Byt 源操作数
'OUTPUT----------------------------
'返回值 移位结果
'last updated by Liu Qi 2004-3-24
'/2:右移一位
ShRB_By1Bit = Fix(Byt / 2)
End Function
Public Function ShLW(ByVal Word As Integer, Optional ByVal BitsNum As Long = 1) As Integer
'字的左移函数
'INPUT-------------------------------
'Word 源操作数
'BitsNum 移位的位数
'OUTPUT------------------------------
'返回值 移位结果
'last updated by Liu Qi 2004-3-24
Dim i&
For i = 1 To BitsNum
Word = ShLW_By1Bit(Word)
Next i
ShLW = Word
End Function
Public Function ShRW(ByVal Word As Integer, Optional ByVal BitsNum As Long = 1) As Integer
'字的右移函数
'INPUT-------------------------------
'Word 源操作数
'BitsNum 移位的位数
'OUTPUT------------------------------
'返回值 移位结果
'last updated by Liu Qi 2004-3-24
Dim i&
For i = 1 To BitsNum
Word = ShRW_By1Bit(Word)
Next i
ShRW = Word
End Function
Private Function ShLW_By1Bit(ByVal Word As Integer) As Integer
'把一个字左移一位的函数
'INPUT-------------------------------
'Word 源操作数
'OUTPUT------------------------------
'返回值 移位结果
'last updated by Liu Qi 2004-3-24
Dim HiByte As Byte, LoByte As Byte
'把字拆分为字节
HiByte = Hi(Word): LoByte = Lo(Word)
'把高字节左移一位,保证把低字节的最高位移入高字节的最低位
HiByte = ShLB_By1Bit(HiByte) Or IIf((LoByte And &H80) = &H80, &H1, &H0)
LoByte = ShLB_By1Bit(LoByte) '低字节左移一位
'把移位后的字节再重新组合成字
ShLW_By1Bit = Con(HiByte, LoByte)
End Function
Private Function ShRW_By1Bit(ByVal Word As Integer) As Integer
'把一个字右移一位的函数
'INPUT-------------------------------
'Word 源操作数
'OUTPUT------------------------------
'返回值 移位结果
'last updated by Liu Qi 2004-3-27
Dim HiByte As Byte, LoByte As Byte
'把字拆分为字节
HiByte = Hi(Word): LoByte = Lo(Word)
'低字节右移一位,保证把高字节的最低位移入低字节的最高位
LoByte = ShRB_By1Bit(LoByte) Or IIf((HiByte And &H1) = &H1, &H80, &H0)
'把高字节右移一位,
HiByte = ShRB_By1Bit(HiByte)
'把移位后的字节再重新组合成字
ShRW_By1Bit = Con(HiByte, LoByte)
End Function
Public Function ShLD(ByVal DWord As Long, Optional ByVal BitsNum As Long = 1) As Long
'把一个双字左移的函数
'INPUT-------------------------------
'DWord 源操作数
'BitsNum 移位的位数
'OUTPUT------------------------------
'返回值 移位结果
'last updated by Liu Qi 2004-3-28
Dim i&
For i = 1 To BitsNum
DWord = ShLD_By1Bit(DWord)
Next i
ShLD = DWord
End Function
Public Function ShRD(ByVal DWord As Long, Optional ByVal BitsNum As Long = 1) As Long
'把一个双字右移的函数
'INPUT-------------------------------
'DWord 源操作数
'BitsNum 移位的位数
'OUTPUT------------------------------
'返回值 移位结果
'last updated by Liu Qi 2004-3-28
Dim i&
For i = 1 To BitsNum
DWord = ShRD_By1Bit(DWord)
Next i
ShRD = DWord
End Function
Public Function ShLD_By1Bit(ByVal DWord As Long) As Long
'把一个双字左移一位的函数，为 ShlD() 服务
'INPUT-------------------------------
'DWord 源操作数
'OUTPUT------------------------------
'返回值 移位结果
'last updated by Liu Qi 2004-3-29
Dim iHiWord%, iLoWord%
'把双字拆分为两个单字
iHiWord = HiWord(DWord): iLoWord = LoWord(DWord)
'高位字左移一位,要把低位字的最高位移到高位字的最低位
iHiWord = ShLW_By1Bit(iHiWord) Or IIf((iLoWord And &H8000) = &H8000, &H1, &H0)
'低位字左移一位
iLoWord = ShLW_By1Bit(iLoWord)
ShLD_By1Bit = ConWord(iHiWord, iLoWord) '重新连接成双字返回结果
End Function
Public Function ShRD_By1Bit(ByVal DWord As Long) As Long
'把一个双字右移一位的函数,为 ShrD() 服务
'INPUT-------------------------------
'DWord 源操作数
'OUTPUT------------------------------
'返回值 移位结果
'last updated by Liu Qi 2004-3-29
Dim iHiWord%, iLoWord%
'把双字拆分为两个单字
iHiWord = HiWord(DWord): iLoWord = LoWord(DWord)
'把低位字右移一位，要把高位字的最低位移到低位字的最高位
iLoWord = ShRW_By1Bit(iLoWord) Or IIf((iHiWord And &H1) = &H1, &H8000, &H0)
'把高位字右移一位
iHiWord = ShRW_By1Bit(iHiWord)
ShRD_By1Bit = ConWord(iHiWord, iLoWord) '重新连接成双字返回结果
End Function
Public Function ShLB_C_By1Bit(ByVal Byt As Byte) As Byte
'把字节<<循环>>左移一位的函数.C 表示 Cycle,循环
'INPUT-----------------------------
'Byt :源操作数
'OUTPUT----------------------------
'返回值 : 移位结果
'last updated by Liu Qi 2004-8-8
'(Byt And &H7F): 屏蔽最高位. *2:左移一位
ShLB_C_By1Bit = ((Byt And &H7F) * 2) Or IIf((Byt And &H80) = &H80, &H1, &H0)
End Function
Public Function ShRB_C_By1Bit(ByVal Byt As Byte) As Byte
'把字节<<循环>>右移一位的函数。
'INPUT-----------------------------
'Byt :源操作数
'OUTPUT----------------------------
'返回值 : 移位结果
'last updated by Liu Qi 2004-8-8
'(Byt And &H7F): 屏蔽最高位. *2:左移一位
ShRB_C_By1Bit = Fix(Byt / 2) Or IIf((Byt And &H1) = &H1, &H80, &H0)
End Function
Public Function U2F(ByVal UnsignedLong As Long) As Double
'把一个长整形按照无符号数转化成一个浮点数值
If (UnsignedLong And &H80000000) = &H80000000 Then
'如果最高位（符号位）为1，
'则把它的屏蔽符号位后的值加上最高位无符号表示法的权值(权值校正)
U2F = (UnsignedLong And &H7FFFFFFF) + 2 ^ 31
Else '如果最高位为 0，则不需特殊处理
U2F = UnsignedLong
End If
End Function
Public Function F2U(ByVal Float As Double) As Long
'把一个浮点数值按照无符号数转化成一个长整形
If Float > 2 ^ 32 - 1 Or Float < 0 Then
'无符号数不能容纳的值
Err.Raise 6 '引发溢出错误
ElseIf Float > &H7FFFFFFF Then '最高位为1,则先屏蔽最高位以顺利完成向整形的转化，最后再把最高位的1添上
F2U = CLng(Float - 2 ^ 31) Or &H80000000
Else '如果最高位为 0，则不需特殊处理
F2U = Float
End If
End Function
Public Function UAdd(ByVal UnsignedLong1 As Long, ByVal UnsignedLong2 As Long) As Long
'把VB中的长整形按照无符号加法相加
UAdd = F2U(U2F(UnsignedLong1) + U2F(UnsignedLong2))
End Function
Public Function UDif(ByVal UnsignedLong1 As Long, ByVal UnsignedLong2 As Long) As Long
'把VB中的长整形按照无符号减法相减
UDif = F2U(U2F(UnsignedLong1) - U2F(UnsignedLong2))
End Function
-----------------------------------------------------------------
-------------------------------FastBit.Bas-----------------------
Option Explicit
'-----------------------------------------------------
'这个模块使用安全数组技术实现了以下六个函数的Fast版本：
'Hi(),Lo(),HiWord(),LoWord(),Con(),ConWord()
'经试验，Fast版本的函数性能提高1倍以上
'-----------------------------------------------------
'作者：刘琦 ，2005-1-11
'个人主页：http://LQweb.crcoo.com
'e-Mail：liuqi5521@hotmail.com
Private Type SafeArray1d '1维数组的 SafeArray 定义
cDims As Integer '维数
fFeatures As Integer '标志
cbElements As Long '单个元素的字节数
clocks As Long '锁定计数
pvData As Long '指向数组元素的指针
cElements As Long '维定义，该维的元素个数
Lbound As Long '该维的下界
End Type
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 Declare Function VarPtrArray Lib "msvbvm60.dll" _
Alias "VarPtr" (ptr() As Any) As Long
Const FADF_AUTO = &H1
Const FADF_FIXEDSIZE = &H10
Private m_lSharedLong As Long '要被共享的长整形变量
Private m_aiIntsInLong() As Integer '要共享长整形变量的地址空间的整形数组
Private m_SA1D_IntArr As SafeArray1d '整形数组的SafeArray结构
Private m_iSharedInt As Integer '要被共享的整形变量
Private m_aBytesInInt() As Byte '要共享整形变量的地址空间的字节数组
Private m_SA1D_ByteArr As SafeArray1d '字节数组的SafeArray结构
'位操作前初使化动作,主要是初使化，如果不进行初使化，将会出现不可预计错误
Public Sub BitOperatorInit()
With m_SA1D_IntArr
.cDims = 1 '维数：1维
.fFeatures = 17 '标志：Auto or FixedSize
.cbElements = 2 '元素大小：2个字节
.clocks = 0
.pvData = VarPtr(m_lSharedLong) '使数组的数据指针指向长整形变量m_lSharedLong
.cElements = 2 '元素个数：2个
.Lbound = 0 '下界：0
End With
'使数组变量m_aiIntsInLong指向我们自己创建的 SafeArray1d 结构
CopyMemory ByVal VarPtrArray(m_aiIntsInLong), VarPtr(m_SA1D_IntArr), 4
With m_SA1D_ByteArr
.cDims = 1 '维数：1维
.fFeatures = 17 '标志：Auto or FixedSize
.cbElements = 1 '元素大小：1个字节
.clocks = 0
.pvData = VarPtr(m_iSharedInt) '使数组的数据指针指向整形变量m_iSharedInt
.cElements = 2 '元素个数：2个
.Lbound = 0 '下界：0
End With
'使数组变量m_aBytesInInt指向我们自己创建的 SafeArray1d 结构
CopyMemory ByVal VarPtrArray(m_aBytesInInt), VarPtr(m_SA1D_ByteArr), 4
End Sub
Public Sub BitOperatorEnd()
'释放资源，程序结束前一定要调用
'把数组变量m_aiIntsInLong指向 0,既 C 语言中的 NULL
CopyMemory ByVal VarPtrArray(m_aiIntsInLong), 0&, 4
'把数组变量m_aBytesInInt指向 0,既 C 语言中的 NULL
CopyMemory ByVal VarPtrArray(m_aBytesInInt), 0&, 4
End Sub
'-----------------------下面这些例程实现整型变量的拆分，合并操作,Fast版本-------------
Public Function fastCon(ByVal HiByte As Byte, ByVal LoByte As Byte) As Integer
'把两个字节 (Byte) 连成一个字 （word）
'INPUT--------------------------------------------------------------------
'HiByte 参与连结的高字节
'LoByte 参与连结的低字节
'OUTPUT-------------------------------------------------------------------
'返回值 连结的结果
'Last updated by Liu Qi 2004-3-20.
m_aBytesInInt(1) = HiByte
m_aBytesInInt(0) = LoByte
fastCon = m_iSharedInt
End Function
Public Function fastConWord(ByVal HiWord As Integer, ByVal LoWord As Integer) As Long
'把两个字（Word）连成一个双字（DWord）
'INPUT--------------------------------------------------------------------
'HiWord 参与连结的高位字
'LoWord 参与连结的低位字
'OUTPUT-------------------------------------------------------------------
'返回值 连结的结果
'Last updated by Liu Qi 2004-3-20.
m_aiIntsInLong(1) = HiWord
m_aiIntsInLong(0) = LoWord
fastConWord = m_lSharedLong
End Function
Public Function fastHi(ByVal Word As Integer) As Byte
'取一个字（Word）的高字节（Byte）
'INPUT-------------------------------------------
'Word 字（Word）
'OUTPUT------------------------------------------
'返回值 Word参数的高字节
'Last updated by Liu Qi 2004-3-20.
m_iSharedInt = Word
fastHi = m_aBytesInInt(1)
End Function
Public Function fastLo(ByVal Word As Integer) As Byte
'取一个字（Word）的低字节（Byte）
'INPUT-------------------------------------------
'Word 字（Word）
'OUTPUT------------------------------------------
'返回值 Word参数的低字节
'Last updated by Liu Qi 2004-3-20.
m_iSharedInt = Word
fastLo = m_aBytesInInt(0)
End Function
Public Function fastHiWord(ByVal DWord As Long) As Integer
'取一个双字（DWord）的高位字
'INPUT-------------------------------------------
'DWord 双字
'OUTPUT------------------------------------------
'返回值 DWord参数的高位字
'Last updated by Liu Qi 2004-3-20.
m_lSharedLong = DWord
fastHiWord = m_aiIntsInLong(1)
End Function
Public Function fastLoWord(ByVal DWord As Long) As Integer
'取一个双字（DWord）的低位字
'INPUT-------------------------------------------
'DWord 双字
'OUTPUT------------------------------------------
'返回值 DWord参数的低位字
'Last updated by Liu Qi 2004-3-20.
m_lSharedLong = DWord
fastLoWord = m_aiIntsInLong(0)
End Function
--------------------------------------------------------------
---------------------------modShiftBitByte.bas---------------]
Option Explicit
'这是为字节类型变量提供快速的移位操作的模块，可以使用本模块中的快表实现高速的移位运算
'这是纯VB实现的，不需要任何DLL
'需要 BitEx.Bas
'刘琦，作于2005-1-26
Const MAX_BYTE = &HFF&
'下面是移位表
Public g_aShLB() As Byte '字节左移的快表，第1维是待移位的字节，第2维是移位位数
Public g_aShRB() As Byte '字节右移的快表，第1维是待移位的字节，第2维是移位位数
'------------------------------------------------------------------------------------
Public Function IsInitialized() As Boolean
'判断是否已经初始化过移位表的函数
On Error GoTo hanlder
g_aShLB(1, 1) = g_aShLB(1, 1)
IsInitialized = True '没出错，说明初始化过了
Exit Function
hanlder:
IsInitialized = False '出错说明还没有初始化
End Function
Public Sub ShiftBitByteInit()
'初始化移位表
If IsInitialized Then Exit Sub ' 如果已经初始化过了，不必再初始化了
'分配空间
ReDim g_aShLB(0 To MAX_BYTE, 1 To 7) As Byte '左移表
ReDim g_aShRB(0 To MAX_BYTE, 1 To 7) As Byte '右移表
Dim i As Long, j As Long
For i = 0 To MAX_BYTE
For j = 1 To 7
g_aShLB(i, j) = ShLB(i, j)
g_aShRB(i, j) = ShRB(i, j)
Next j
Next i
End Sub
Public Sub DestoryShiftBitByteTable()
'销毁字节类型的移位表，以释放内存
ReDim g_aShLB(0)
Erase g_aShLB
ReDim g_aShRB(0)
Erase g_aShRB
End Sub
-------------------------------------------------------
---------------------------SafeArray.bas--------------------------
'***************************************************************
' (c) Copyright 2000 Matthew J. Curland
'
' This file is from the CD-ROM accompanying the book:
' Advanced Visual Basic 6: Power Techniques for Everyday Programs
' Author: Matthew Curland
' Published by: Addison-Wesley, July 2000
' ISBN: 0-201-70712-8
'
' You are entitled to license free distribution of any application
' that uses this file if you own a copy of the book, or if you
' have obtained the file from a source approved by the author. You
' may redistribute this file only with express written permission
' of the author.
'
' This file depends on:
' References:（不再需要VBoostTypes6.olb，可直接在任何地方使用）
' VBoostTypes6.olb (VBoost Object Types (6.0))'
' Files:
' None
' Minimal VBoost conditionals:
' None
' Conditional Compilation Values:
' None
'
' This file is discussed in Chapter 2.
'***************************************************************
'***************************************************************
'说明：这个模块是 Matthew J. Curland 的作品，我根据自己的实际需要
'作了一些微小的改动（不再需要VBoostTypes6.olb，可直接在任何地方使用）
'，添加了中文的注释。
'
'使用这个模块，可以像 C 语言一样用数组访问任意的内存位置
'作者：刘琦 ，2005-1-11
'个人主页：http://LQweb.crcoo.com
'e-Mail：liuqi5521@hotmail.com
'***************************************************************
Option Explicit
Public Type SafeArray1d '1维数组的 SafeArray 定义
cDims As Integer '维数
fFeatures As Integer '标志
cbElements As Long '单个元素的字节数
clocks As Long '锁定计数
pvData As Long '指向数组元素的指针
cElements As Long '维定义，该维的元素个数
Lbound As Long '该维的下界
End Type
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)
Public Declare Function VarPtrArray Lib "msvbvm60.dll" _
Alias "VarPtr" (ptr() As Any) As Long
Public Const FADF_AUTO = &H1
Public Const FADF_FIXEDSIZE = &H10
Public Sub ShareMemoryViaArray(ByVal ArrayPtr As Long, _
ByVal MemPtr As Long, SA1D As SafeArray1d, _
ByVal ElemByteLen As Long, ByVal ElemCount As Long)
'INPUT---------------------------------------------------------------------
'ByVal ArrayPtr As Long 指向数组变量的指针，用 VarPtrArray(数组名)获取
'ByVal MemPtr As Long 指向要借用的内存块的指针(就是起始地址)。
'SA1D As SafeArray1d 通过引用传递来的SafeArray1d结构变量
'ByVal ElemByteLen As Long 指出数组要使用的元素大小
'ByVal ElemCount As Long 指出数组要使用的元素个数
'
'OUTPUT--------------------------------------------------------------------
'N/A
'前条件--------------------------------------------------------------------
'要求数组变量必须是未分配的
'后条件--------------------------------------------------------------------
'N/A
With SA1D
'cbElements is optional because this is a 1 element array,
'so cbElements is not needed to walk the array. If Erase
'is called on an array with .cbElements = 0, VB will still
'free all pointer types, but non-pointer types will not get
'zeroed out. Note that the compiler calculates the length
'of a structure at compile time, so LenB(MyStruct(0)) is
'valid regardless of whether or not MyStruct is actually allocated.
.cbElements = ElemByteLen '元素大小
.cDims = 1 '维数
'This means that if the
'array goes out of scope, then the pointed
'to memory will be cleaned, but no attempt
'will be made to free the array pointer
'or descriptor.
.fFeatures = FADF_AUTO Or FADF_FIXEDSIZE '特征
.pvData = MemPtr '指向要借用的内存块
.cElements = ElemCount '元素个数
.Lbound = 0 ' 下界
End With
'把 SafeArray 结构的首地址赋给数组变量
CopyMemory ByVal ArrayPtr, VarPtr(SA1D), 4
End Sub
Public Sub UnshareMemory(ByVal ArrayPtr As Long)
'INPUT---------------------------------------------------------------------
'ByVal ArrayPtr As Long 指向数组变量的指针，用 VarPtrArray(数组名)获取
'
'OUTPUT--------------------------------------------------------------------
'N/A
'前条件--------------------------------------------------------------------
'要求数组变量必须是用ShareMemoryViaArray分配的，不能用于VB分配的数组
'后条件--------------------------------------------------------------------
'N/A
''把数组变量的值置为0
ZeroMemory ByVal ArrayPtr, 4
End Sub
------------------------------------------------------------------
------------------------------ ShiftBitInt16.bas -----------------
Option Explicit
'这是为Integer类型变量提供超高速移位运算的模块，由于Integer类型的范围较大，比较占内存，所以
'用的是动态表，用时分配，用完可以尽快销毁。（还有个好处，可以避免忘记初始化数组）
'这是纯VB版的，与原来那个需要DLL的版本相比，使用更方便。
'刘琦，作于2005-1-26
'需要：BitEx10.Bas SafeArray.Bas modShiftBitByte.Bas
'另外：使用这两个快表一定要注意一点，要做一个长整形无符号扩展之后再查表，不然会出错，像这样：
'g_aShL16(SomeInt and &HFFFF&,1)
'为什么？对最高位为1的Integer,VB会把它解释为一个负值,做了长整形扩展，VB才会把它理解为一个正值,
'由于数组无法接受负值索引，所以我们是用Integer的无符号值来造表
'所以说，查表的时候当然要用Integer的无符号值来查表
'整形变量的移位表----------------------------------------------------------------------------------------
Public g_aShL16() As Integer
Public g_aShR16() As Integer
'--------------------------------------------------------------------------------------------------------
Public Const MAX_UINT16 = &HFFFF& 'max unsigned int16,注意：这是一个用Long存储的65535,无符号字的最大值
Private m_iSharedInt As Integer '地址空间要被共享的长整形
Private m_aBytesInInt() As Byte '要共享长整形地址空间的字节数组
Private m_SA1D As SafeArray1d '安全数组结构
Public Sub InitShL16Table() '初始化左移表，（为啥和右移表分开呢？按需分配，省内存，需要哪个分配哪个。）
Dim i As Long, j As Long
If ShiftLeftTableIsInitialized Then Exit Sub '如果左移表已经初始化过了，就退出
ShiftBitByteInit '初始化字节类型的移位表
modSafeArray.ShareMemoryViaArray VarPtrArray(m_aBytesInInt), VarPtr(m_iSharedInt), m_SA1D, _
1, 2 '共享内存
If VarPtr(m_iSharedInt) <> VarPtr(m_aBytesInInt(0)) Then MsgBox "共享内存失败!"
ReDim g_aShL16(0 To MAX_UINT16, 1 To 15) '为移位表分配空间，0-ffff,1-15
For i = 0 To MAX_UINT16
For j = 1 To 15
g_aShL16(i, j) = ShL16_Internal(LoWord(i), j)
Next j
Next i
UnshareMemory VarPtrArray(m_aBytesInInt) '取消共享的内存
End Sub
Public Sub DestroyShL16Table() '销毁左移表，释放内存
ReDim g_aShL16(0)
Erase g_aShL16
End Sub
Public Sub InitShR16Table() '初始化右移表
Dim i As Long, j As Long
If ShiftRightTableIsInitialized Then Exit Sub '如果右移表已经初始化过了，那么退出
ShiftBitByteInit '初始化字节类型的移位表
modSafeArray.ShareMemoryViaArray VarPtrArray(m_aBytesInInt), VarPtr(m_iSharedInt), m_SA1D, _
1, 2 '共享内存
If VarPtr(m_iSharedInt) <> VarPtr(m_aBytesInInt(0)) Then MsgBox "共享内存失败!"
ReDim g_aShR16(0 To MAX_UINT16, 1 To 15) '为移位表分配空间，0-ffff,1-15
For i = 0 To MAX_UINT16
For j = 1 To 15
g_aShR16(i, j) = ShR16_Internal(LoWord(i), j)
Next j
Next i
UnshareMemory VarPtrArray(m_aBytesInInt) '取消共享的内存
End Sub
Public Sub DestroyShR16Table() '销毁右移表，释放内存
ReDim g_aShR16(0)
Erase g_aShR16
End Sub
Public Function ShL16_Internal(ByVal Word As Integer, Optional ByVal BitNum As Long = 1) As Integer
'字的左移函数，速度一般,仅供内部使用,用来初始化移位表还可以，用在实际运算中就毫无优势可言了。
'INPUT-------------------------------
'Word 源操作数
'BitsNum 移位的位数
'OUTPUT------------------------------
'返回值 移位结果
m_iSharedInt = Word '把待移位的值赋给被共享的整形
If BitNum = 8 Then '如果等于8，直接把低字节搬到高字节去就OK了
m_aBytesInInt(1) = m_aBytesInInt(0)
m_aBytesInInt(0) = 0
ElseIf BitNum > 8 Then '如果大于8，那么就先移8位，再移剩下的
m_aBytesInInt(1) = m_aBytesInInt(0)
m_aBytesInInt(0) = 0
m_aBytesInInt(1) = g_aShLB(m_aBytesInInt(1), BitNum - 8)
Else '小于8
'把高字节左移，并把低字节相应的位移到高字节上
m_aBytesInInt(1) = g_aShLB(m_aBytesInInt(1), BitNum) Or g_aShRB(m_aBytesInInt(0), 8 - BitNum)
'低字节左移
m_aBytesInInt(0) = g_aShLB(m_aBytesInInt(0), BitNum)
End If
'返回结果
ShL16_Internal = m_iSharedInt
End Function
Private Function ShR16_Internal(ByVal Word As Integer, Optional ByVal BitNum As Long = 1) As Integer
'字的右移函数,仅供内部使用
'INPUT-------------------------------
'Word 源操作数
'BitsNum 移位的位数
'OUTPUT------------------------------
'返回值 移位结果
m_iSharedInt = Word '把待移位的值赋给被共享的整形
If BitNum = 8 Then '如果移位位数等于8，右移8位就等价于直接把高字节搬到低字节,高字节清零
m_aBytesInInt(0) = m_aBytesInInt(1)
m_aBytesInInt(1) = 0
ElseIf BitNum > 8 Then '如果移位位数大于8，那么先右移8位，在把低字节右移剩下的位数
m_aBytesInInt(0) = m_aBytesInInt(1)
m_aBytesInInt(1) = 0
m_aBytesInInt(0) = g_aShRB(m_aBytesInInt(0), BitNum - 8)
Else '小于8
'低字节右移，并把高字节相应的位移动到低字节
m_aBytesInInt(0) = g_aShRB(m_aBytesInInt(0), BitNum) Or g_aShLB(m_aBytesInInt(1), 8 - BitNum)
'高字节右移
m_aBytesInInt(1) = g_aShRB(m_aBytesInInt(1), BitNum)
End If
ShR16_Internal = m_iSharedInt
End Function
Private Function ShiftLeftTableIsInitialized() As Boolean
'判断左移表是否已经初始化过的函数，初始化过返回真，没有初始化返回假
On Error GoTo handler
g_aShL16(1, 1) = g_aShL16(1, 1)
ShiftLeftTableIsInitialized = True
Exit Function
handler:
ShiftLeftTableIsInitialized = False
End Function
Private Function ShiftRightTableIsInitialized() As Boolean
'判断右移表是否已经初始化过的函数，初始化过返回真，否则返回假
On Error GoTo handler
g_aShR16(1, 1) = g_aShR16(1, 1)
ShiftRightTableIsInitialized = True
Exit Function
handler:
ShiftRightTableIsInitialized = False
End Function
-----------------------------------------------------------------
