VB常用代码

 用Mid$命令超速字符串添加操作

大家都知道，&操作符的执行速度是相当慢的，特别是处理长字符串时。当必须重复地在同一变量上附加字符时，有一个基于Mid$命令的技巧可以使用。基本思路就是：预留一个足够长的空间存放操作的结果。下面是应用这个技术的一个例子。

假设要建立一个字符串，它要附加从1开始的10000个整数："1 2 3 4 5 6 7 ... 9999

10000"。下面是最简单的实现代码：
res = ""
For i = 1 to 10000: res = res & Str(i): Next

<>
face=宋体>代码虽然简单，但问题也很明显：Res变量将被重分配10000次。下面的代码实现同样的目的，但效果明显好转：

Dim res As String
Dim i As Long
Dim index As Long

’预留足够长的缓冲空间
res = Space(90000)

’指针变量，指出在哪里插入字符串
index = 1

’循环开始
For i = 1 to 10000
substr = Str(i)
length = Len(substr)

’填充字符串的相应区间段数值
Mid$(res, index, length) = substr

’调整指针变量
index = index + length

Next

’删除多余字符
res = Left$(res, index - 1)

测试表明：在一个333MHz的计算机上，前段代码执行时间为2.2秒，后者仅仅为0.08秒！代码虽然长了些，可是速度却提高了25倍之多。呵呵，由此看来：代码也不可貌相啊

从头开始删除集合项目

删除集合中的所有内容有许多方法，其中有些非常得迅速。来看看一个包含10,000个项目的集合：
Dim col As New Collection, i As Long
For i = 1 To 10000
　　 col.Add i, CStr(i)
Next

可以从末尾位置为起点删除集合内容，如下：

For i = col.Count To 1 Step -1
col.Remove i

Next

也可以从开始位置为起点删除集合内容，如下：

For i = 1 To col.Count Step 1
col.Remove i
Next

<>
face=宋体>试验证明，后者要快于前者百倍多，比如0.06秒比4.1秒。原因在于：当引用接近末尾位置的集合项目时，VB必须要从第1个项目开始遍历整个的项目链。 <>
face=宋体>更有趣的是，如果集合项目的数量加倍，那么从末尾开始删除与从头开始删除，前者要比后者花费的时间将成倍增长，比如前者是24秒，后者可能为0.12秒这么短！
最后提醒您：删除集合的所有内容的最快方法就是“毁灭”它，使用下面的语句： Set col = New Collection

对于一个包含20,000个项目的集合，上述操作仅仅耗时0.05秒，这比使用最快的循环操作进行删除也要快2倍左右。

用InStr函数实现代码减肥 可以采用“旁门左道”的方式使用Instr函数实现代码的简练。下面是一个典型的例子，检测字符串中是否包含一个元音字母：

1、普通的方法：

If UCase$(char) = "A" Or UCase$(char) = "E" Or UCase$(char) = "I" Or UCase$(char) = "O" Or UCase$(char) = "U" Then

’ it is a vowel

End If

2、更加简练的方法：

If InStr("AaEeIiOoUu", char) Then

’ it is a vowel

End If

同样，通过单词中没有的字符作为分界符，使用InStr来检查变量的内容。下面的例子检查Word中是否包含一个季节的名字： 1、普通的方法：

If LCase$(word) = "winter" Or LCase$(word) = "spring" Or LCase$(word) = _ "summer" Or LCase$(word) = "fall" Then

’ it is a season’s name

End If

2、更加简练的方法：

If Instr(";winter;spring;summer;fall;", ";" & word & ";") Then

’ it is a season’s name

End If

有时候，甚至可以使用InStr来替代Select

Case代码段，但一定要注意参数中的字符数目。下面的例子中，转换数字0到9的相应英文名称为阿拉伯数字： 1、普通的方法：

Select Case LCase$(word)

Case "zero"

result = 0

Case "one"

result = 1

Case "two"

result = 2

Case "three"

result = 3

Case "four"

result = 4

Case "five"

result = 5

Case "six"

result = 6

Case "seven"

result = 7

Case "eight"

result = 8

Case "nine"

result = 9

End Select

2、更加简练的方法：

result = InStr(";zero;;one;;;two;;;three;four;;five;;six;;;seven;eight;nine;", _

";" & LCase$(word) & ";") / 6

精用Boolean表达式，让代码再减肥

当设置基于表达式结果的Boolean型数值时，要避免使用多余的If/Then/Else语句结果。比如：

If SomeVar > SomeOtherVar Then

BoolVal = True

Else

BoolVal = False

End If

上面这段代码就很烦琐，它们完全可以使用下面的一行代码来替代：

BoolVal = (SomeVar > SomeOtherVar)

括号不是必须的，但可以增加可读性。根据表达式中的操作数不同，后者比前者执行起来大约快50%到85%。后者中的括号对速度没有影响。

有时，使用这个技术实现代码的简练并非很明显。关键是要牢记：所有的比较操作结果或者是0（false），或者是－1（True）。所以，下面例子中的2段代码是完全相同的，但是第2段要运行得快些：

1、传统方法： If SomeVar > SomeOtherVar Then

x = x + 1

End If

2、更简练的方法

x = x - (SomeVar > SomeOtherVar)
函数名巧做局部变量

很多程序员都没有认识到“在函数本身中使用函数名”的妙处，这就象对待一个局部变量一样。应用这个技巧可以起到临时变量的作用，有时还能加速程序运行。看看下面的代码：

Function Max(arr() As Long) As Long

Dim res As Long, i As Long

res = arr(LBound(arr))

For i = LBound(arr) + 1 To UBound(arr)

If arr(i) > res Then res = arr(i)

Next

Max = res

End Function

去掉res变量，使用函数名称本身这个局部变量，可以使程序更加简练：

Function Max(arr() As Long) As Long

Dim i As Long

Max = arr(LBound(arr))

For i = LBound(arr) + 1 To UBound(arr)

If arr(i) > Max Then Max = arr(i)

Next

End Function

火眼识破隐藏的Variant变量

如果没有用As语句声明变量，默认类型就是Variants，比如：

Dim name ’ this is a variant

或者，当前模块下没有声明Option Explicit语句时，任何变量都是Variants类型。

许多开发者，特别是那些先前是C程序员的人，都会深信下面的语句将声明2个Interger类型变量：

Dim x, y As Integer

而实际上，x被声明为了variant类型。由于variant类型变量要比Integer类型慢很多，所以要特别注意这种情况。正确的一行声明方法是：

Dim x As Integer, y As Integer

GoSub在编译程序中速度变慢

编译为本地代码的VB应用程序中，如果使用 GoSubs 命令，就会比通常的 Subs 或者 Function 调用慢5-6倍；相反，如果是p-code模式，就会相当快。
减少DoEvents语句的数量

不要在代码中放置不必要的DoEvents语句，尤其是在时间要求高的循环中。遵循这个原则，至少能在循环中的每N次反复时才执行DoEvents语句，从而增强效率。比如使用下面的语句：

If (loopNdx Mod 10) = 0 Then DoEvents

如果只是使用DoEvents来屏蔽鼠标以及键盘操作，那么就可以在事件队列中存在待处理项目时调用它。通过API函数GetInputState来检查这个条件的发生：

Declare Function GetInputState Lib "user32" Alias "GetInputState" () As Long

’ ...

If GetInputState() Then DoEvents

为常量定义合适的类型

VB在内部使用最简单、最可能的数据类型保存符号数值，这意味着最通常的数字类型－比如0或者1－都按照Integer类型存储。如果在浮点表达式中使用这些常量，可以通过常量的合适类型来加速程序运行，就象下面的代码： value# = value# + 1#.

这个语句强迫编译器按照Double格式存储常量，这样就省却了运行时的隐含转换工作。还有另外的一种处理方法就是：在常量声明时就进行相应类型的定义，代码如下：

Const ONE As Double = 1

And、Or和Xor：让我们来优化表达式

要检测一个整数值的最高有效位是否有数值，通常要使用如下的代码（有二种情况：第一组If判断表明对Integer类型，第二组对Long类型）：

If intvalue And &H8000 Then

’ most significant bit is set

End If

If lngvalue And &H80000000 Then

’ most significant bit is set

End If

但由于所有的VB变量都是有符号的，因此，最高有效位也是符号位，不管处理什么类型的数值，通过下面的代码就可以实现检测目的：

If anyvalue < 0 Then

’ most significant bit is set

End If

另外，要检测2个或者更多个数值的符号，只需要通过一个Bit位与符号位的简单表达式就可以完成。下面是应用这个技术的几段具体代码：

1、判断X和Y是否为同符号数值：

If (x < 0 And y < 0) Or (x >= 0 And y >=0) Then ...

’ the optimized approach

If (x Xor y) >= 0 Then

2、判断X、Y和Z是否都为正数

If x >= 0 And y >= 0 And z >= 0 Then ...

’ the optimized approach

If (x Or y Or z) >= 0 Then ...

3、判断X、Y和Z是否都为负数

If x < 0 And y < 0 And z < 0 Then ...

’ the optimized approach

If (x And y And z) < 0 Then ...

4、判断X、Y和Z是否都为0

If x = 0 And y = 0 And z = 0 Then ...

’ the optimized approach

If (x Or y Or z) = 0 Then ...

5、判断X、Y和Z是否都不为0

If x = 0 And y = 0 And z = 0 Then ...

’ the optimized approach

If (x Or y Or z) = 0 Then ...

要使用这些来简单化一个复杂的表达式，必须要完全理解boolean型的操作原理。比如，你可能会认为下面的2行代码在功能上是一致的：

If x <> 0 And y <> 0 Then

If (x And y) Then ...

然而我们可以轻易地证明他们是不同的，比如X＝3（二进制＝0011），Y＝4（二进制＝0100）。不过没有关系，遇到这种情况时，我们可以对上面的代码进行局部优化，就能实现目的。代码如下：

If (x <> 0) And y Then ...

　

静态变量慢于动态变量

在过程中引用静态局部变量要比引用常规局部动态变量慢2－3倍。要想真正地加速过程的执行速度，最彻底的方法就是将所有的静态变量转换为模块级别变量。

这种方法的唯一不足是：过程很少是自包含的，如果要在其他工程中重用，就必须同时拷贝并粘贴这些模块级别变量。

另外的一种处理方法是：在时间要求高的循环前，将静态变量数值装入动态变量中。

善用"Assume No Aliasing"编译选项

据说，如果过程能够2次或多次引用同样的内存地址，那么过程就会包含别名数值。一个典型的例子如下：

Dim g_GlobalVariable As Long

...

Sub ProcWithAliases(x As Long)

x = x + 1

g_GlobalVariable = g_GlobalVariable + 1

End Sub

如果传递给这个过程g_GlobalVariable变量，则将通过一个直接引用以及x参数两种方式修改变量的数值2次。

别名数值经常是不良编程习惯的产物，对于程序优化有害无益。事实上，如果能够完全确认应用程序从来没有使用到别名变量，就可以打开"Assume No Aliasing"高级编译选项，这将告知编译器没有过程可以修改同一内存地址，使编译器产生更加有效率的汇编代码。更特别的是，编译程序将试图缓冲这些数据到CPU的寄存器中，从而明显地加速了程序运行。

总结一下，当遇到以下情况时，就不会有别名数值：(1) 过程不引用任何全局变量 (2) 过程引用了全局变量，但从来不通过ByRef参数类型传递同一变量给过程 (3) 过程含有多个ByRef参数类型，但从来不传递同一变量到其中的2个或者多个之中。

你真正理解"Allow Unrounded Floating Point Operations"选项的含义吗？

来自微软的资料鼓吹：高级优化对话框中的所有编译选项都被认为是不稳定的，它们可能导致不正确的结果，甚至程序崩溃。对于其中的大多数，这种说法是正确的，但是经常有一个叫做"Allow Unrounded Floating Point Operations"的选项能够给予正确的结果，防止应用程序产生bug。考虑下面的代码段： Dim x As Double, y As Double, i As Integer

x = 10 ^ 18

y = x + 1 ’ this can’t be expressed with 64 bits

MsgBox (y = x) ’ 显示 "True" (不正确的结果)

严格地说，由于X和Y变量不包含相同的数值，MsgBox将显示False。可问题是，由于数值1E18与1E18＋1都以相同的64位浮点Double类型来表示，它们最终包含了几乎相同的数值，最后的MsgBox结果将是True。

如果打开了"Allow Unrounded Floating Point Operations"编译选项，VB就能重用已在数学协处理器堆栈中的数值，而不是内存中的数值（比如：变量）。因为FPU堆栈具备80位的精度，因此就可以区分出这2个数值的不同：

’ if the program is compiled using the

’ "Allow Unrounded Floating Point Operations" compiler option

MsgBox (y = x) ’ 显示 "False" (正确的结果)

总结一下：当以解释模式、或者编译的p－code模式、或者编译的native代码模式但关掉"Allow Unrounded Floating Point Operations"选项这3种方式运行一个程序时，所有浮点数字运算在内部都以80位的精度进行处理。但如果有一个数值是存储在64位Double变量中，结果就是接近的了，并且，随后使用那个变量的表达式也将产生近似的结果，而不是绝对正确的结果。

相反，如果打开"Allow Unrounded Floating Point Operations"编译选项后运行一段native编译代码，在随后的表达式中VB就经常能重用内部的80位数值，而忽略存储在变量中的当前数值。注意：我们并不能完全控制这个功能，VB也许对此生效，也许就不生效，这要取决于表达式的复杂程度以及最初分配数值语句与随后产生结果的表达式语句的距离远近。

除法运算符"/"与"/"的区别

整数间执行除法运算时，要使用 "/" 而不是 "/"。 "/" 运算符要求返回一个单一数值，所以，表面上看似简单的一行代码：

C% = A% / B%

实际上包含了3个隐含的转换操作：2个为除法运算做准备，从Integer转换到Single；一个完成最后的赋值操作，从Integer转换到Single。但是如果使用了"/"操作符，情况就大不相同了！不仅不会有这么多中间步骤，而且执行速度大大提高。

同时请记住：使用"/"操作符做除法运算时，如果其中之一是Double类型，那么结果就将是Double类型。所以，当2个Integer或者Single类型数值做除法运算时，如果想得到高精度的结果，就需要手工强迫其中之一转换为Double类型：

’结果为 0.3333333

Print 1 / 3

’结果为 0,333333333333333

Print 1 / 3#

使用"$-类型"字符串函数会更快

VB官方文档似乎很鼓励使用"无$"类字符串函数，比如：Left、LTrim或者UCase，而不是实现同样功能的Left$、LTrim$和UCase$函数。但是我们必须认识到：前者返回variant类型的数值，当用于字符串表达式中时，最终必须要转换为字符串（string）类型。

因此，在严格要求时间的代码段中，我们应该使用后者，它们将快5-10%。

妙用Replace函数替代字符串连接操作符&

你大概不知道Replace函数还能这么用吧？比如下面的语句：

MsgBox "Disk not ready." & vbCr & vbCr & _

"Please check that the diskette is in the drive" & vbCr & _

"and that the drive’s door is closed."

可以看出，为了显示完整的字符串含义，要将可打印字符与非打印字符（比如：回车符vbCr）用&符号连接在一起。结果是：长长的字符连接串变得难于阅读。但是，使用Replace函数，可以巧妙地解决这个问题。方法就是：将非打印字符以字符串中不出现的一个可打印字符表示，这样完整地写出整个字符串，然后使用Replace函数替换那个特别的打印字符为非打印字符（比如：回车符vbCr）。代码如下：

MsgBox Replace("Disk not ready.§§Please check that the diskette is in the " _

& "drive§and that the drive’s door is closed.", "§", vbCr)

固定长度字符串数组：赋值快，释放快！

固定长度字符串的处理速度通常慢于可变长度字符串，这是因为所有的VB字符串函数和命令只能识别可变长度字符串。因此，所有固定长度字符串比然被转换为可变长度字符串。

但是，由于固定长度字符串数组占据着一块连续的内存区域，因此在被分配以及释放时，速度明显快于可变长度的数组。比如：在一个Pentium 233MHz机器上，对于一个固定长度为100,000的数组，给其中30个位置分配数值，大约只花费半秒种的时间。而如果是可变长度的数组，同样的操作要耗费8秒之多！后者的删除操作耗时大约0.35秒，但固定长度的数组几乎可以立即“毙命”！如果应用程序中涉及到这么大的一个数组操作，选择固定长度方式数组绝对是确定无疑的了，无论是分配数值，还是释放操作，都可以风驰电掣般完成。
未公开的返回数组型函数加速秘诀

在VB6中，函数是能够返回数组对象的。这种情况下，我们不能象返回对象或者数值的其他函数一样使用函数名当做局部变量来存储中间结果，因此不得不生成一个临时局部数组，函数退出前再分配这个数组给函数名，就象下面的代码一样：

’ 返回一个数组，其中含有N个随即元素

’ 并且将平均值保存在AVG中

Function GetRandomArray(ByVal n As Long, avg As Single) As Single()

Dim i As Long, sum As Single

ReDim res(1 To n) As Single

’ 以随机数填充数组，并计算总和

Randomize Timer

For i = 1 To n

res(i) = Rnd

sum = sum + res(i)

Next

’ 赋值结果数组，计算平均值

GetRandomArray = res

avg = sum / n

End Function

难以置信的是，只需要简单地颠倒最后2条语句的顺序，就能使上面这段程序变得快些：

’ ... ’ 赋值结果数组，计算平均值

avg = sum / n

GetRandomArray = res

End Function

例如，在一个Pentium II 333MHz 机器上，当N＝100,000时，前段程序运行时间为0.72秒，后段程序则为0.66秒，前后相差10%。

原因何在呢？前段程序中，VB将拷贝res数组到GetRandomArray对应的结果中，当数组很大时，花费的时间是很长的。后段程序中，由于GetRandomArray = res是过程的最后一条语句，VB编译器就能确认res数组不会被再使用，因此将直接交换res和GetRandomArray的地址数值，从而节省了数组元素的物理拷贝操作以及随后的res数组释放操作。

总结如下：当编写返回数组的函数时，一定要将分配临时数组到函数名的语句放在最后，就是其后紧挨者Exit Function 或者End Function的位置。

--------------------------------------------------------------------------------
Dim i As Long

ReDim res(0 To UBound(values)) As Integer

For i = 0 To UBound(values)

res(i) = values(i)

Next

ArrayInt = res()

End Function

同时，也可以创建一个子程序段来检测传递给它的数值的类型，并返回正确类型的数组。这种情况下，函数应该定义为返回Variant。

访问简单变量总是快于数组元素值

读写数组中的元素速度通常都慢于访问一个简单变量，因此，如果在一个循环中要重复使用同一数组元素值，就应该分配数组元素值到临时变量中并使用这个变量。下面举一个例子，检测整数数组中是否存在重复项：

Function AnyDuplicates(intArray() As Integer) As Boolean

’如果数组包含重复项，返回True

Dim i As Long, j As Long,

Dim lastItem As Long

Dim value As Integer

’只计算机UBound()一次

lastItem = UBound(intArray)

For i = LBound(intArray) To lastItem

’ 保存intArray(i)到非数组变量中

value = intArray(i)

For j = i + 1 To lastItem

If value = intArray(j) Then

AnyDuplicates = True

Exit Function

End If

Next

Next

’没有发现重复项

AnyDuplicates = False

End Function

上述程序有2层循环，通过缓存intArray(i)的数值到一个普通的、非数组变量中，节省了CPU运行时间。经测试，这将提高80%的速度。

创建新表时，快速拷贝字段

在VB6中，无需离开开发环境就可以创建新的SQL Server和Oracle表。方法很简单：打开DataView窗口，用鼠标右键单击数据库的表文件夹，再选择新表格菜单命令。

当处理相似表格时，就是说具有许多相同字段的表格，我们完全可以在很短的时间内容完成设定操作。具体步骤是：在设计模式下打开源表格，加亮选择要拷贝字段对应的行，按Ctrl-C拷贝信息到粘贴板；然后，在设计模式打开目标表格，将光标置于要粘贴字段所在的位置，按Ctrl-V。

这样，就拷贝了所有的字段名称以及它们所带的属性。 无闪烁地快速附加字符串到textbox控件

附加文本到TextBox或者RichTextBox控件的通常方法是在当前内容上连接上新的字符串：

Text1.Text = Text1.Text & newString

但还有一个更快的方法，并且会减少连接操作的闪烁感，代码如下：

Text1.SelStart = Len(Text1.Text)

Text1.SelText = newString

快速找到选中的OptionButton

OptionButton控件经常是作为控件数组存在的，要快速找到其中的哪一个被选中，可以使用下面的代码：

’假设控件数组包含3个OptionButton控件

intSelected = Option(0).value * 0 - Option(1).value * 1 - Option(2).value * 2

注意，因为第一个操作数总是0，所以上述代码可以精简如下：

intSelected = -Option(1).value - Option(2).value * 2

表单及控件的引用阻止了表单的卸载

当指派表单或者表单上的控件到该表单模块以外的一个对象变量中时，如果要卸载表单，就必须首先将那个变量设置为 to Nothing。也就是说，如果不设置为Nothing，即使看不到这个对象了，但它仍旧是保存在内存中的。

注意：这并非是一个bug，这仅仅是COM引用规则的一个结果。唯一要注意的就是引用的这个控件将阻止整个表单的卸载操作，它将依赖于它的父表单而存在。 重定义编译DLL文件的基地址

许多VB开发者都知道应该在工程属性对话框的“编译”功能页面中定义一个DLL基地址数值。这不同于工程中任何其他DLL或OCX的基地址。

当操作没有源代码的编译DLL或者OCX文件时，可以使用EDITBIN程序修改它的基地址。EDITBIN程序随Visual Studio安装后就有了，可以在主Visual Studio目录的VC98/BIN目录下找到它。比如，以下代码重新设定一个编译DLL文件的基地址为12000000（16进制）：

EDITBIN /REBASE:BASE=0x12000000 myfile.dll

同样，EDITBIN程序对可执行文件也有一些处理技巧。 以下是该程序支持的完整功能选项列表(使用EDITBIN /? 可以列出这些）：

/BIND[:PATH=path]

/HEAP:reserve[,commit]

/LARGEADDRESSAWARE[:NO]

/NOLOGO

/REBASE[:[BASE=address][,BASEFILE][,DOWN]]

/RELEASE

/SECTION:name[=newname][,[[!]{cdeikomprsuw}][a{1248ptsx}]]

/STACK:reserve[,commit]

/SUBSYSTEM:{NATIVE|WINDOWS|CONSOLE|WINDOWSCE|POSIX}[,#[.##]]

/SWAPRUN:{[!]CD|[!]NET}

/VERSION:#[.#]

/WS:[!]AGGRESSIVE

快速调入TreeView控件以及ListView控件的子项内容

有一个简单但仍未发现的技巧可用于在TreeView控件中装载多个节点，或者在ListView控件中装载多个ListItems。这种方法要比传统做法快。先看看下面这个传统方法：

For i = 1 To 5000

TreeView1.Nodes.Add , , , "Node " & i

Next

改进一下，代替重复引用TreeView1对象的Nodes集合，我们可以先将之保存在临时对象变量中：

Dim nods As MSComctlLib.Nodes

Set nods = TreeView1.Nodes

For i = 1 To 5000

nods.Add , , , "Node " & i

Next

甚至，如果使用With代码块，还可以不需要临时变量：

With TreeView1.Nodes

For i = 1 To 5000

.Add , , , "Node " & i

Next

End With

经测试，优化的循环代码要比传统方法执行速度快40%左右。原因在于：将Nodes集合对象保存在临时变量中，或者应用With代码块后VB将使用隐藏的临时变量后，就可以避免在循环中重复绑定Nodes对象到它的父TreeView1对象上。由于这种绑定是低效率的，因此省却它就能节省大量的执行时间。

同样的道理对于其他ActiveX控件也生效：

ListView控件的ListItems、ListSubItems以及ColumnHeaders集合

Toolbar控件的Buttons和ButtonMenus集合

ImageList的ListImages集合
StatusBar控件的Panels集合
TabStrip控件的Tabs集合

Friend过程快于Public过程

你可能会非常惊奇：Friend类型过程的执行速度要明显快于Public类型。这可以通过创建一个带有Private类和Public类 (设定Instancing = MultiUse)的ActiveX EXE工程看到，在2个类模块中添加下面的代码：

Public Sub PublicSub(ByVal value As Long)

’

End Sub

Public Function PublicFunction(ByVal value As Long) As Long

’

End Function

Friend Sub FriendSub(ByVal value As Long)

’

End Sub

Friend Function FriendFunction(ByVal value As Long) As Long

’ End Function

然后，在表单模块中创建一个循环，执行每个例程许多次。比如，要在一个Pentium II机器上查看执行时间上的区别，可以调用每个例程1,000,000次。下面是测试的结果：

Private类模块中，反复调用1,000,000次Public Sub或者Function耗费了0.46秒，而调用内容相同的Friend类型模块则分别只有0.05秒和0.06秒。前后竟然相差了8-9倍之多！对于MultiUse类型的Public类模块，也是一样的结果。

对于这个不可思议的结果的可能解释是：Friend型过程没有处理汇集和拆装代码的消耗(Public过程可以从当前工程外被调用，因此COM必须要来回地汇集数据）。 但是在多数情况下，这些时间差别是不明显的，特别是程序中包含一些复杂和耗时的语句时。

即使这样，Friend型过程仍有其他的优势高于Public类型，比如：接受和返回在BAS模块中定义的UDT变量的能力。
使用Objptr函数快速查找集合中的对象

ObjPtr函数的一个最简单但是却最有效的用途就是提供快速寻找集合中对象的关键字。假设有一个对象集合，它没有可以当做关键字以从集合中取回的属性。那么，我们就可以使用ObjPtr函数的返回值作为集合中的关键字：

Dim col As New Collection

Dim obj As CPerson

’创建新的CPerson对象，并添加到集合中

Set obj = New CPerson

obj.Name = "John Smith"

col.Add obj, CStr(ObjPtr(obj)) ’关键字必须是字符串

因为任何对象都有一个明确的ObjPtr数值，而且它是不变的，所以，我们可以容易地、快速地从集合中取回它：

’ 删除集合中的对象

col.Remove CStr(ObjPtr(obj))

这个技巧可以适用于任何类型的对象，包括VB中的表单和控件，以及外部对象。

使用ObjPtr检测2个对象变量是否指向同一对象

判断2个对象变量释放指向同一对象的方法是使用Is操作符，代码如下：

If obj1 Is obj2 Then ...

但当2个对象是同一类型时，或者指向同一个二级接口时，我们就可以利用ObjPtr（）函数对代码进行一些优化处理：

If ObjPtr(obj1) = ObjPtr(obj2) Then ...

后者的执行速度将比前种方法快40%多。但是请注意，2种方法原本就是很有效率的，只有在时间要求非常严格的上百成千次的循环中，才会体现出这种差别。

读取文件内容的简洁方法

读取text文件的最快方法是使用Input$函数，就象下面的过程：

Function FileText (filename$) As String

Dim handle As Integer

handle = FreeFile

Open filename$ For Input As #handle

FileText = Input$(LOF(handle), handle)

Close #handle

End Function

使用上述方法要比使用Input命令读取文件每一行的方法快很多。下面是应用这个函数读取Autoexec.bat的内容到多行textbox控件的例子：

Text1.Text = FileText("c:/autoexec.bat")

但请注意：当文件包含Ctrl－Z（EOF）字符时，上面的函数代码可能会发生错误。因此，要修改一下代码：

Function FileText(ByVal filename As String) As String

Dim handle As Integer

’ 判断文件存在性

If Len(Dir$(filename)) = 0 Then

Err.Raise 53 ’文件没有找到 End If

’ 以binary模式打开文件

handle = FreeFile

Open filename$ For Binary As #handle

’ 读取内容，关闭文件

FileText = Space$(LOF(handle))

Get #handle, , FileText

Close #handle

End Function

字体对象克隆招法

当要应用一个控件的字体到另一控件时，最直接的方法就是直接赋值：

Set Text2.Font = Text1.Font

但多数情况下这种方法并不奏效，因为这实际上是将同一字体的引用分配给了2个控件。换言之，当随后修改其中之一控件的字体时，另外一个控件也受到影响。因此，要实现我们的目的，需要做的就是克隆字体对象并赋值给需要的控件。

最简单的克隆字体的方法是手工地拷贝所有单独的字体属性，就象下面一样：

Function CloneFont(Font As StdFont) As StdFont

Set CloneFont = New StdFont

CloneFont.Name = Font.Name

CloneFont.Size = Font.Size

CloneFont.Bold = Font.Bold

CloneFont.Italic = Font.Italic

CloneFont.Underline = Font.Underline

CloneFont.Strikethrough = Font.Strikethrough

End Function

’函数的应用

Set Text2.Font = CloneFont(Text1.Font)

如果使用VB6，就可以使用PropertyBag对象快速拷贝所有字体属性，并且代码会很简练、速度也快2倍：

Function CloneFont(Font As StdFont) As StdFont

Dim pb As New PropertyBag

’拷贝字体到PropertyBag对象中

pb.WriteProperty "Font", Font

’恢复字体对象到新控件

Set CloneFont = pb.ReadProperty("Font")

End Function

但是我们还能进一步地对代码进行优化，方法就是使用可被所有StdFont对象识别的隐藏IFont接口。这个接口具有一个Clone方法，用它就可以精确地实现我们的目的。它以非正常方式执行：创建一个克隆Font对象，然后返回相应的引用。这可能是实现克隆目的的最简洁代码了，而且，执行速度也是这里列举的3种方法中最快的一个，要比使用PropertyBag对象的方法快大约3倍左右。来看看具体代码：

Function CloneFont(Font As IFont) As StdFont

Font.Clone CloneFont

End Function

--------------------------------------------------------------------------------
API程序源代码（多种功能）
＇ 本人收集了一些技巧供大家参考，希望斑竹能多放一些时间。
＇------------------------------------------------------------
＇按字母或数字顺序排列列表框中的列表项.
＇将以下代码加入到你的程序中.
Sub ReSort(L As Control)
Dim P%, PP%, c%, Pre$, s$, V&, NewPos%, CheckIt%
Dim TempL$, TempItemData&, S1$
For P = 0 To L.ListCount - 1
s = L.List(P)
For c = 1 To Len(s)
V = Val(Mid$(s, c))
If V > 0 Then Exit For
Next
If V > 0 Then
If c > 1 Then Pre = Left$(s, c - 1)
NewPos = -1
For PP = P + 1 To L.ListCount - 1
CheckIt = False
S1 = L.List(PP)
If Pre <> "" Then
If InStr(S1, Pre) = 1 Then CheckIt = True
Else
If Val(S1) > 0 Then CheckIt = True
End If
If CheckIt Then
If Val(Mid$(S1, c)) < V Then NewPos = PP
Else
Exit For
End If
Next
If NewPos > -1 Then
TempL = L.List(P)
TempItemData = L.ItemData(P)
L.RemoveItem (P)
L.AddItem TempL, NewPos
L.ItemData(L.NewIndex) = TempItemData
P = P - 1
End If
End If
Next
Exit Sub
＇---------------------------------------------------
＇Tag属性的妙用.
＇在VB编程中,我们经常要动态的控制很多不同控件的属性,例如我们要将一个CommandButton阵列共20各控件中的第1、4、6、7、8、11、18、20号删除。该怎么半呢？这时只要将要删除的控件的Tag属性设置为1，然后加入以下代码就可以了。
For i = 1 To 20
If command1(i).Tag = 1 Then
Unload command1(i)
End If
Next i
＇-----------------------------------------------------
＇利用VB产生屏幕变暗的效果.
＇想利用VB编程实现屏幕变暗的效果（向关闭Win95时的效果），只要按下面的步骤来做
＇1、在FORM1中加入两个CommandButton和一个PictureBox.
＇2 Print 在FORM1的代码窗口中添加以下代码:
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function CreatePatternBrush Lib "gdi32" (ByVal hBitmap As Long) As Long
Private Declare Function PatBlt Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, ByVal lpRect As Long, ByVal bErase As Long) As Long
Private bybits(1 To 16) As Byte
Private hBitmap As Long, hBrush As Long
Private hDesktopWnd As Long
Private Sub Command1_Click()
Dim rop As Long, res As Long
Dim hdc5 As Long, width5 As Long, height5 As Long
hdc5 = GetDC(0)
width5 = Screen.Width / Screen.TwipsPerPixelX
height5 = Screen.Height / Screen.TwipsPerPixelY
rop = &HA000C9
Call SelectObject(hdc5, hBrush)
res = PatBlt(hdc5, 0, 0, width5, height5, rop)
Call DeleteObject(hBrush)
res = ReleaseDC(0, hdc5)
End Sub
Private Sub Command2_Click()
Dim aa As Long

aa = InvalidateRect(0, 0, 1)
End Sub
Private Sub FORM_Load()
Dim ary
Dim i As Long
ary = Array(&H55, &H0, &HAA, &H0, _
&H55, &H0, &HAA, &H0, _
&H55, &H0, &HAA, &H0, _
&H55, &H0, &HAA, &H0)
For i = 1 To 16
bybits(i) = ary(i - 1)
Next i
hBitmap = CreateBitmap(8, 8, 1, 1, bybits(1))
hBrush = CreatePatternBrush(hBitmap)
Picture1.ForeColor = RGB(0, 0, 0)
Picture1.BackColor = RGB(255, 255, 255)
Picture1.ScaleMode = 3
End Sub
＇运行程序，按Command1就可以使屏幕暗下来，按Command2恢复。
＇--------------------------------------------------
＇使两个列表框(ListBox)的选项同步步骤1
＇在FORM中添加两个ListBox和一个CommandButton一个Timer,不要改动他们的属性.
步骤2
在FORM中添加如下代码:
Private Sub FORM_Load()
Dim x As Integer
For x = 1 To 26
list1.AddItem Chr$(x + 64)
Next x
For x = 1 To 26
List2.AddItem Chr$(x + 64)
Next x
Timer1.INTERVAL = 1
Timer1.Enabled = True
End Sub
Private Sub Command1_Click()
End
End Sub
Private Sub Timer1_Timer()
Static PrevList1
Dim TopIndex_List1 As Integer
TopIndex_List1 = list1.TopIndex
If TopIndex_List1 <> PrevList1 Then
List2.TopIndex = TopIndex_List1
PrevList1 = TopIndex_List1
End If
If list1.ListIndex <> List2.ListIndex Then
List2.ListIndex = list1.ListIndex
End If
End Sub
＇运行程序,当选中其中一个列表框中的某一项后,另外一个列表框中的相应项就会被选中.
＇-------------------------------------------------
＇获得Win9X下文件的短文件名(8.3文件名)
＇步骤一　在FORM中加入一个FileListBox,一个DirListBox,一个Label.
＇步骤二 在FORM中加入以下代码:
＇Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal
＇lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
Private Sub Dir1_Change()
File1 = dir1.path
End Sub
Private Sub Drive1_Change()
dir1 = drive1
End Sub
Private Sub File1_Click()
Label1.Caption = GetShortFileName(dir1 & "/" & File1)
End Sub
Public Function GetShortFileName(ByVal FileName As String) As String
＇converts a long file and path name to old DOS FORMat
＇PARAMETERS
＇ FileName = the path or filename to convert
＇RETURNS
＇ String = the DOS compatible name for that particular FileName
Dim rc As Long
Dim ShortPath As String
Const PATH_LEN& = 164
＇get the short filename
ShortPath = String$(PATH_LEN + 1, 0)
rc = GetShortPathName(FileName, ShortPath, PATH_LEN)
GetShortFileName = Left$(ShortPath, rc)
End Function
＇---------------------------------------------------------------------
使指定窗口总处于其他窗口之上
＇将以下代码加入到FORM中,这个FORM就成为一个在其他所有窗口之上的窗口了.
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Const HWND_TOPMOST = -1
Private Sub FORM_Load()
SetWindowPos Me.hwnd, HWND_TOPMOST, Me.Left / Screen.TwipsPerPixelX _
, Me.Top / Screen.TwipsPerPixelY, Me.Width / Screen.TwipsPerPixelX, _
Me.Height / Screen.TwipsPerPixelY, 0
End Sub
＇--------------------------------------------------
获得位图文件的信息
在FORM中添加一个Picture控件和一个CommandButton控件 , 在Picture控件中加入一个位图文件, 将下面代码加入其中:
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) 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 Sub Command1_Click()
Dim hBitmap As Long
Dim res As Long
Dim bmp As BITMAP
Dim byteAry() As Byte
Dim totbyte As Long, i As Long
hBitmap = Picture1.Picture.Handle
res = GetObject(hBitmap, Len(bmp), bmp) ＇取得BITMAP的结构
totbyte = bmp.bmWidthBytes * bmp.bmHeight ＇总共要多少BYTE来存图
ReDim byteAry(totbyte - 1)
＇将Picture1中的图信息存到ByteAry
res = GetBitmapBits(hBitmap, totbyte, byteAry(0))
Debug.Print "Total Bytes Copied :"; res
Debug.Print "bmp.bmBits "; bmp.bmBits
Debug.Print "bmp.bmBitsPixel "; bmp.bmBitsPixel ＇每相素位数
Debug.Print "bmp.bmHeight "; bmp.bmHeight ＇以相素计算图象高度
Debug.Print "bmp.bmPlanes "; bmp.bmPlanes
Debug.Print "bmp.bmType "; bmp.bmType
Debug.Print "bmp.bmWidth "; bmp.bmWidth ＇以相素计算图形宽度
Debug.Print "bmp.bmWidthBytes "; bmp.bmWidthBytes ＇以字节计算的每扫描线长度
End Sub
＇---------------------------------------------------
＇获得驱动器的卷标
＇在FORM中添加一个CommandButton控件 , 再加入一下一段代码:
Private Declare Function GetVolumeInFORMation Lib "kernel32" Alias "GetVolumeInFORMationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long
Const FILE_VOLUME_IS_COMPRESSED = &H8000
Public Sub GetVolInfo(ByVal path As String)
Dim aa As Long
Dim VolName As String
Dim fsysName As String
Dim VolSeri As Long, compress As Long
Dim Sysflag As Long, Maxlen As Long
＇初试化字符串的长度
VolName = String(255, 0)
fsysName = String(255, 0)
aa = GetVolumeInFORMation(path, VolName, 256, VolSeri, Maxlen, Sysflag, fsysName, 256)
VolName = Left(VolName, InStr(1, VolName, Chr(0)) - 1)
fsysName = Left(fsysName, InStr(1, fsysName, Chr(0)) - 1)
compress = Sysflag And FILE_VOLUME_IS_COMPRESSED
If compress = 0 Then
Me.Print "未压缩驱动器"
Else
Me.Print "压缩驱动器"
End If
Me.Print "驱动器卷标 :", VolName
Me.Print "驱动器标号 : ", Hex(VolSeri)
Me.Print "驱动器文件系统 (FAT, HPFS, or NTFS)", fsysName
Me.Print "支持的文件名长度", Maxlen
End Sub
Private Sub Command1_Click()
FORM1.Caption = "c:驱动器信息"
Call GetVolInfo("c:/")
End Sub
＇---------------------------------------------------
将包含有Null结尾的字符串转换为VB字符串
在VB编程调用Windows API函数时, 经常会碰到以Null结尾的字符串, 下面是一段将Null结尾字符串转换到VB字符串的函数:
Public Function LPSTRToVBString$(ByVal s$)
Dim nullpos&
nullpos& = InStr(s$, Chr$(0))
If nullpos > 0 Then
LPSTRToVBString = Left$(s$, nullpos - 1)
Else
LPSTRToVBString = ""
End If
End Function
＇---------------------------------------------------
启动控制面板命令
控制面板
模块: Control.Exe
命令: rundll32.Exe shell32.dll, Control_RunDLL
结果: 显示控制面板窗口?
例子:
Dim x
x = Shell("rundll32.exe shell32.dll,Control_RunDLL")
辅助选项
模块: access.cpl
＇命令： rundll32.exe shell32.dll,Control_RunDLL access.cpl,,5
＇结果： 显示辅助选项/常规。
＇命令： rundll32.exe shell32.dll,Control_RunDLL access.cpl,,1
＇结果： 显示辅助选项/键盘。
＇命令： rundll32.exe shell32.dll,Control_RunDLL access.cpl,,2
＇结果： 显示辅助选项/声音。
＇命令： rundll32.exe shell32.dll,Control_RunDLL access.cpl,,3
＇结果： 显示辅助选项/显示。
＇命令： rundll32.exe shell32.dll,Control_RunDLL access.cpl,,4
＇结果： 显示辅助选项/鼠标。
＇添加新硬件
＇模块: sysdm.cpl
＇命令：rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl @1
＇增加新的打印机
＇模块: shell32.dll
＇命令：rundll32.exe shell32.dll,SHHelpShortcuts_RunDLL AddPrinter
＇添加/删除程序
＇模块: appwiz.cpl
＇命令：rundll32.exe shell32.dll,Control_RunDLL appwiz.cpl,,1
＇结果：显示安装/卸载。
＇命令：rundll32.exe shell32.dll,Control_RunDLL appwiz.cpl,,1
＇结果：显示安装/卸载。
＇命令：rundll32.exe shell32.dll,Control_RunDLL appwiz.cpl,,2
＇结果: 显示Windows 安装?
＇命令：rundll32.exe shell32.dll,Control_RunDLL appwiz.cpl,,3
＇结果: 显示启动盘?
＇复制磁盘
＇模块: diskcopy.dll
＇命令: rundll32.Exe diskcopy.dll, DiskCopyRunDll
＇时间/日期
＇模块: timedate.cpl
＇命令： rundll32.exe shell32.dll,Control_RunDLL timedate.cpl,,0
＇结果： 显示设置日期/时间。
＇命令： rundll32.exe shell32.dll,Control_RunDLL timedate.cpl,,1
＇结果: 显示设置时间区域?
＇拨号连接 (DUN)
＇模块: rnaui.dll
＇命令： rundll32.exe rnaui.dll,RnaDial 连接_名称
＇结果: 打开指定的拨号连接?
＇例子:
x = Shell("rundll32.exe rnaui.dll,RnaDial " & "连接_名称", 1)
＇显示器
＇模块: desk.cpl
＇命令： rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,0
＇结果: 背景设置?
＇命令： rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,1
＇结果: 屏幕保护设置?
＇命令： rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,2
＇结果: 外观设置?
＇命令： rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,3
＇结果: 设置窗口?
＇操纵杆
＇模块: joy.cpl
＇命令： rundll32.exe shell32.dll,Control_RunDLL joy.cpl
＇邮件/传真
＇模块: mlcfg32.cpl
＇命令： rundll32.exe shell32.dll,Control_RunDLL mlcfg32.cpl
＇结果： 出现 MS Exchange 属性设置。
＇邮局设置
＇模块: wgpocpl.cpl
＇命令： rundll32.exe shell32.dll,Control_RunDLL wgpocpl.cpl
＇结果： 显示 MS Postoffice Workgroup Admin 设置。
＇主设置
＇模块: Main.cpl
＇命令： rundll32.exe shell32.dll,Control_RunDLL main.cpl @0
＇结果: 显示鼠标属性?
＇命令： rundll32.exe shell32.dll,Control_RunDLL main.cpl @1
＇结果： 显示键盘/速度属性。
＇命令： rundll32.exe shell32.dll,Control_RunDLL main.cpl @1,,1
＇结果： 显示键盘/语言属性。
＇命令： rundll32.exe shell32.dll,Control_RunDLL main.cpl @1,,2
＇结果： 显示键盘/常规属性。
＇命令： rundll32.exe shell32.dll,Control_RunDLL main.cpl @2
＇结果: 显示打印机属性?
＇命令： rundll32.exe shell32.dll,Control_RunDLL main.cpl @3
＇结果: 显示字体属性?
＇命令： rundll32.exe shell32.dll,Control_RunDLL main.cpl @4
＇结果: 显示电源管理属性?
＇增加 modem
＇模块: modem.cpl
＇命令：rundll32.exe shell32.dll,Control_RunDLL modem.cpl,,add
＇多媒体
＇模块: mmsys.cpl
＇命令： rundll32.exe shell32.dll,Control_RunDLL mmsys.cpl,,0
＇结果: 声音?
＇命令： rundll32.exe shell32.dll,Control_RunDLL mmsys.cpl,,1
＇结果: 视频?
＇命令： rundll32.exe shell32.dll,Control_RunDLL mmsys.cpl,,2
＇结果: 声音 MIDI?
＇命令： rundll32.exe shell32.dll,Control_RunDLL mmsys.cpl,,3
＇结果：CD/音乐。
＇命令： rundll32.exe shell32.dll,Control_RunDLL mmsys.cpl,,4
＇结果: 高级?
＇命令： rundll32.exe shell32.dll,Control_RunDLL mmsys.cpl @1
＇结果: 声音?
＇网络
＇模块: netcpl.cpl
＇命令：rundll32.exe shell32.dll,Control_RunDLL netcpl.cpl
＇打开方式窗口(Open With)
＇模块: shell32.dll
＇命令：rundll32.exe shell32.dll,OpenAs_RunDLL path/filename
＇口令
＇模块: password.cpl
＇命令： rundll32.exe shell32.dll,Control_RunDLL password.cpl
＇区域设置
＇模块: intl.cpl
＇命令： rundll32.exe shell32.dll,Control_RunDLL intl.cpl,,0
＇结果: 区域设置?
＇命令： rundll32.exe shell32.dll,Control_RunDLL intl.cpl,,1
＇结果: 数字格式设置?
＇命令： rundll32.exe shell32.dll,Control_RunDLL intl.cpl,,2
＇结果: 金额格式设置?
＇命令： rundll32.exe shell32.dll,Control_RunDLL intl.cpl,,3
＇结果: 时间格式设置?
＇命令： rundll32.exe shell32.dll,Control_RunDLL intl.cpl,,4
＇结果: 日期格式设置?
＇屏幕保护
＇模块: appwiz.cpl
＇命令： rundll32.exe desk.cpl,InstallScreenSaver c:/win/system/Flying Windows.scr
＇结果: 安装屏幕保护并显示预览属性页?
＇系统设置
＇模块: sysdm.cpl
＇命令： rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl,,0
＇结果: 显示常规设置?
＇命令： rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl,,1
＇结果: 显示设备管理设置?
＇命令： rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl,,2
＇结果: 显示硬件设置?
＇命令： rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl,,3
＇结果: 显示性能设置?
＇IE4 设置
＇模块: inetcpl.cpl
＇命令： rundll32.exe shell32.dll,Control_RunDLL inetcpl.cpl

--------------------------------------------------------------------------------
怎样检查声卡的存在
Declare Function auxGetNumDevs% Lib "MMSYSTEM" ()
＇ In the appropriate routine:
Dim i As Integer
i = auxGetNumDevs()
If i > 0 Then ＇ There is at least one sound card on the system
MsgBox "A Sound Card has been detected."
Else ＇ auxGetNumDevs returns a 0 if there is no sound card
MsgBox "There is no Sound Card on this system."
End If
＇---------------------------------------------------
如何用API及MMSYSTEM.DLL播放AVI文件
Declare Function mciSendString& Lib "MMSYSTEM" (ByVal pstrCommand$, ByVal lpstrReturnStr As Any, ByVal wReturnLen%, ByVal CallBack%)
＇Add this code to the appropriate event:
Dim CmdStr$
Dim ReturnVal&
＇ Modify path and filename as necessary
CmdStr$ = "play G:/VFW_CINE/AK1.AVI"
ReturnVal& = mciSendString(CmdStr$, 0&, 0, 0&)
＇ To play the AVI ＇fullscreen＇ append to CmdStr$:
CmdStr$ = "play G:/VFW_CINE/AK1.AVI fullscreen"
＇----------------------------------------------------
＇如何从"SOUND.DRV"中提取声音
Declare Function OpenSound% Lib "sound.drv" ()
Declare Function VoiceQueueSize% Lib "sound.drv" (ByVal nVoice%, ByVal nByteS)
Declare Function SetVoiceSound% Lib "sound.drv" (ByVal nSource%, ByVal Freq&, ByVal nDuration%)
Declare Function StartSound% Lib "sound.drv" ()
Declare Function CloseSound% Lib "sound.drv" ()
Declare Function WaitSoundState% Lib "sound.drv" (ByVal State%)
＇ Add this routine, to be used with SirenSound1 routine
Sub Sound(ByVal Freq As Long, ByVal Duration As Integer)
Dim s As Integer
＇ Shift frequency to high byte.
Freq = Freq * 2 ^ 16
s = SetVoiceSound(1, Freq, Duration)
s = StartSound()
While (WaitSoundState(1) <> 0): Wend
End Sub
＇ Here are the 4 sound routines:
＇* Attention Sound #1 *
Sub AttenSound1()
Dim Succ, s As Integer
Succ = OpenSound()
s = SetVoiceSound(1, 1500 * 2 ^ 16, 50)
s = SetVoiceSound(1, 1000 * 2 ^ 16, 50)
s = SetVoiceSound(1, 1500 * 2 ^ 16, 100)
s = SetVoiceSound(1, 1000 * 2 ^ 16, 100)
s = SetVoiceSound(1, 800 * 2 ^ 16, 40)
s = StartSound()
While (WaitSoundState(1) <> 0): Wend
Succ = CloseSound()
End Sub
＇* Click Sound #1 *
Sub ClickSound1()
Dim Succ, s As Integer
Succ = OpenSound()
s = SetVoiceSound(1, 200 * 2 ^ 16, 2)
s = StartSound()
While (WaitSoundState(1) <> 0): Wend
Succ = CloseSound()
End Sub
＇* Error Sound #1 *
Sub ErrorSound1()
Dim Succ, s As Integer
Succ = OpenSound()
s = SetVoiceSound(1, 200 * 2 ^ 16, 150)
s = SetVoiceSound(1, 100 * 2 ^ 16, 100)
s = SetVoiceSound(1, 80 * 2 ^ 16, 90)
s = StartSound()
While (WaitSoundState(1) <> 0): Wend
Succ = CloseSound()
End Sub
＇* SirenSound #1 *
Sub SirenSound1()
Dim Succ As Integer
Dim j As Long
Succ = OpenSound()
For j = 440 To 1000 Step 5
Call Sound(j, j / 100)
Next j
For j = 1000 To 440 Step -5
Call Sound(j, j / 100)
Next  

Trackback: http://tb.blog.csdn.net/TrackBack.aspx?PostId=1502082