爱华网-- VB编程小技巧
如何获取系统字体列表问题
-- 防止将重复项目添加到列表框中
我也来一个:
防止将重复项目添加到列表框中:(当然用循环也可以实现)
-- 自动选定TextBox中原有字符
当窗体上的TextBox得到输入焦点时，自动选定TextBox中原有字符的技巧：
在标准模块中申明过程SelectAllTxt
1
-- 截屏代码(可截屏整个Screen/当前活动界面)
-- VB中控制光驱弹出和关闭的方法
VB中控制光驱弹出和关闭的方法
使用MCI命令实现：
使用API函数mciSendString,设有窗体Form1,上面有一个按钮Command1，Command1.Caption="弹出"。下面为代码：
-- 显示和隐藏鼠标
2
-- 延时函数
-- 增强型Len Left Right Mid 函数(可对中英字串)
3
-- 取得SQL服务器的当前时间
4
-- 在Visual Basic使用帮助文件(*.chm *.hlp)
-- 如何判断剪贴板有无数据
-- 动态生成―关于‖对话框(API应用)
-- 快速选择List全部项目
-- 保存Image/PIC为图片
本例使用 SavePicture 语句保存画在 Form 对象的 Picture 属性中的图形。要试用此例，可将以下代码粘贴到 Form 对象的声明部分，然后运行此例，单击 Form 对象。
5
-- 防止退出EXCEL时"询问是否要保存所作修改
有时在打开EXCEL文件操作后,退出EXCEL时系统会提示"询问是否要保存所作修改" 为防止这一情况出现有两种方法可实现:
1.在使用 Quit 方法前保存所有的工作簿
2.将 DisplayAlerts 属性设置为 False。如果该属性为 False，则 Microsoft Excel 退出时，即使存在未保存的工作簿退出，也不会显示对话框，而且不保存就退出。
代码如下:
第二种方法一般用于临时打开Execl ,操作后不用保存,如打开后写入数据只为了打印预览之类的操作
-- StrConv 函数的应用
6
-- 控件与界面大小等比变化
下面代码将实现界面上的控件与界面大小等比变化:
7
-- 向外部程序发出按键消息
8
-- 启动可执行并等待该文件执行结束
用于启动可执行文件或用关联程序打开文档，并等待该文件执行结束。
用法：新建一个类模块RunExe，贴上这段代码。
9
使用时，先定义对象：
Dim Run As RunExe
然后：
Set Run = New RunExe
If Run.RunProc(文件名) Then
'正常执行并关闭
Else
'出错
End If
-- 用API实现超链接
'声明API使用ShellExecute函数
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
ByVal hwnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
Private Sub Label1_Click()
Dim ret&
ret& = ShellExecute(Me.hwnd, "Open", "录入超链接网址", "", App.Path, 1)
End Sub
-- 交换鼠标按钮
声明：
Declare Function SwapMouseButton Lib "user32" Alias "SwapMouseButton" (ByVal bSwap As Long) As Long 使用：
bSwsp 值为 True ， 为交换状态，即左手习惯。
bSwsp 值为 False， 为正常状态，即右手习惯。
-- 使程序的标题条闪烁
10
-- 得到鼠标位置
声明：
例子：
Dim p As POINTAPI
Call GetCursorPos( p )' ( p.x, p.y )为鼠标位置
-- 设定鼠标位置
声明：
Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
例子：
ret = SetCursorPos( X, Y) '(X,Y)为坐标，单位为 Pixel(像素)
--
突破 SendKeys 的限制
SendKeys 不能实现一些特殊的键， 如 Alt+PrintScr 。 不过使用 API ，可以改变这样的状况。
声明：
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
使用：
' 一个抓屏的例子
Const VK_SNAPSHOT As Byte = &H2C
' 把应用窗口图象放到剪贴板：
Call keybd_event(VK_SNAPSHOT, 0, 0, 0)
' 把整个屏幕抓到剪贴板：
Call keybd_event(VK_SNAPSHOT, 1, 0, 0)
可以用该方法抓 AVI 图象。
-- 得到以某字符分隔的字符串
VB提供了Split函数,可以方便的实现上述问题：
描述：返回一个下标从零开始的一维数组，它包含指定数目的子字符串。
11
语法：Split(expression[, delimiter[, count[, compare]]])
compare参数的设置值如下：
常数 值 描述
vbUseCompareOption –1 用Option Compare语句中的设置值执行比较。 vbBinaryCompare 0 执行二进制比较。
vbTextCompare 1 执行文字比较。
vbDatabaseCompare 2 仅用于Microsoft Access。基于您的数据库的信息执行比较 例如：
StrTmp = "AAAAA" & vbTab & "BBBBB" & "AAAAA" & vbTab & "BBBBB" ArrTmp = Split(StrTmp, vbTab)
得到:
ArrTmp(0)="AAAAA"
ArrTmp(1)="BBBBBAAAAA"
ArrTmp(2)="BBBBB"
-- 怎样实现快速Excel导出导入?
技巧:
1 少用select动作 和 selection对象(这是最费时间的)
2 可以这样写
range(xls_Range).Borders().LineStyle = xlContinuous
3 要写入很多数据的话 不要用循环写到Excel
先把数据写到数组里
用数组可以一次性写入(数组大小要和区域一样大)
Eg: range("a1:c100") = Arr
Arr是一个(1 to 100, 1 to 3 ) 的数组
反之 : Arr = range("a1:c100").value
----------------------------------------------------------------------------------------
例子:
12
13
说明：
1、使用range.value一次性填充数据，可以极大地加快速度
2、ScreenUpdating 设为false可以加快速度
3、对不可见列不打印，并且根据grid来设置对齐方式
14
4、迟绑定可以减少去excel版本的依赖性
为什么使用这种方法而不是其它更快速的方法
1、copyformrecordset
这样的话就需要一个ado的结果集才可以操作，而且对列的对齐、列头文本、不可见列的操作都无法进行
2、querytable
由于在三层开发中客户端并没有办法直接访问数据库，同时它还存在着和上面一样的缺陷
3、bcp
这个是最快的了 可是局限性同上
-- 得到字符串的拼音韵母
15
16
17
18
19
20
-- 利用注册表获得"我的文档"的目录
大家都知道注册表的强大功能吧！其实很多默认的路径都在“hkey_current_user\software\microsoft\windows\currentversion\explorer\shell folders‖之中，大家可以看看。下面就是利用注册表获得我的文档的源代码。
option explicit
' 这个模块用于读和写注册表关键字。
' 不同于vb 的内部注册表访问方法，它可以
' 通过字符串的值来读和写任何注册表关键字。
'---------------------------------------------------------------
'-注册表 api 声明...
'---------------------------------------------------------------
private declare function regclosekey lib "advapi32" (byval hkey as long) as long
private declare function regcreatekeyex lib "advapi32" alias "regcreatekeyexa" (byval hkey as long, byval lpsubkey as string, byval reserved as long, byval lpclass as string, byval dwoptions as long, byval samdesired as long, byref lpsecurityattributes as security_attributes, byref phkresult as long, byref lpdwdisposition as long) as long
private declare function regopenkeyex lib "advapi32" alias "regopenkeyexa" (byval hkey as long, byval lpsubkey as string, byval uloptions as long, byval samdesired as long, byref phkresult as long) as long
private declare function regqueryvalueex lib "advapi32" alias "regqueryvalueexa" (byval hkey as long, byval lpvaluename as string, byval lpreserved as long, byref lptype as long, byval lpdata as string, byref lpcbdata as long) as long
private declare function regsetvalueex lib "advapi32" alias "regsetvalueexa" (byval hkey as long, byval lpvaluename as string, byval reserved as long, byval dwtype as long, byval lpdata as string, byval cbdata as long) as long
'---------------------------------------------------------------
'- 注册表 api 常数...
'---------------------------------------------------------------
' reg data types...
const reg_sz = 1 ' unicode空终结字符串
const reg_expand_sz = 2 ' unicode空终结字符串
const reg_dword = 4 ' 32-bit 数字
' 注册表创建类型值...
const reg_option_non_volatile = 0 ' 当系统重新启动时，关键字被保留
' 注册表关键字安全选项...
const read_control = &h20000
const key_query_value = &h1
const key_set_value = &h2
const key_create_sub_key = &h4
const key_enumerate_sub_keys = &h8
const key_notify = &h10
const key_create_link = &h20
const key_read = key_query_value + key_enumerate_sub_keys + key_notify + read_control
const key_write = key_set_value + key_create_sub_key + read_control
const key_execute = key_read
const key_all_access = key_query_value + key_set_value + _
key_create_sub_key + key_enumerate_sub_keys + _
key_notify + key_create_link + read_control
' 注册表关键字根类型...
const hkey_classes_root = &h80000000
const hkey_current_user = &h80000001
const hkey_local_machine = &h80000002
21
const hkey_users = &h80000003
const hkey_performance_data = &h80000004
' 返回值...
const error_none = 0
const error_badkey = 2
const error_access_denied = 8
const error_success = 0
'---------------------------------------------------------------
'- 注册表安全属性类型...
'---------------------------------------------------------------
private type security_attributes
nlength as long
lpsecuritydescriptor as long
binherithandle as boolean
end type
'-------------------------------------------------------------------------------------------------
'sample usage - debug.print getkeyvalue(hkey_classes_root, "comctl.listviewctrl.1\clsid", "") '-------------------------------------------------------------------------------------------------
public function getkeyvalue(keyroot as long, keyname as string, subkeyref as string) as string dim i as long ' 循环计数器
dim rc as long ' 返回代码
dim hkey as long ' 处理打开的注册表关键字
dim hdepth as long
dim skeyval as string
dim lkeyvaltype as long ' 注册表关键字数据类型
dim tmpval as string ' 注册表关键字的临时存储器
dim keyvalsize as long ' 注册表关键字变量尺寸
' 在 keyroot {hkey_local_machine...} 下打开注册表关键字
'------------------------------------------------------------
rc = regopenkeyex(keyroot, keyname, 0, key_all_access, hkey) ' 打开注册表关键字 if (rc <> error_success) then goto getkeyerror ' 处理错误...
tmpval = string$(1024, 0) ' 分配变量空间
keyvalsize = 1024 ' 标记变量尺寸
'------------------------------------------------------------
' 检索注册表关键字的值...
'------------------------------------------------------------
rc = regqueryvalueex(hkey, subkeyref, 0, _
lkeyvaltype, tmpval, keyvalsize) ' 获得/创建关键字的值
if (rc <> error_success) then goto getkeyerror ' 错误处理
tmpval = left$(tmpval, instr(tmpval, chr(0)) - 1)
'------------------------------------------------------------
' 决定关键字值的转换类型...
'------------------------------------------------------------
select case lkeyvaltype ' 搜索数据类型...
case reg_sz, reg_expand_sz ' 字符串注册表关键字数据类型
skeyval = tmpval ' 复制字符串的值
case reg_dword ' 四字节注册表关键字数据类型
for i = len(tmpval) to 1 step -1 ' 转换每一位
skeyval = skeyval + hex(asc(mid(tmpval, i, 1))) ' 一个字符一个字符地生成值。 22
next
skeyval = format$("&h" + skeyval) ' 转换四字节为字符串
end select
getkeyvalue = skeyval ' 返回值
rc = regclosekey(hkey) ' 关闭注册表关键字
exit function ' 退出
getkeyerror: ' 错误发生过后进行清除...
getkeyvalue = vbnullstring ' 设置返回值为空字符串
rc = regclosekey(hkey) ' 关闭注册表关键字
end function
public function getmydocumentspath() as string
getmydocumentspath = getkeyvalue(hkey_current_user, "software\microsoft\windows\currentversion\explorer\shell folders", "personal")
end function
-- 获得Win的系统安装路径
使用 getwindowsdirectory 和 getsystemdirectory 可以分别获得 windows 目录和 windows 系统目录。
下面是获得的具体源代码，在粘贴源代码之前必须新建一个模块。粘贴后，在整个工程中都可以使用 getwindir 和 getsysdir 函数。
23
-- 使用VB获得一页的HTML代码
加入WebBrowser、Timer、CommandButton控件各一个，然后使用以下代码：
-- 将数字金额转成大写金额
24
以下算法未处理零的习惯叫法
25
以下算法处理零的习惯叫法
26
27
-- 利用API函数SendMessage在Richtextbox控件中插入图片（类似MSN的聊天表情）
-- 得到word文件内容及字体
environ("windir")
28
得到windows系统目录
-- 如何取消 TextBox 鼠标右键的 PopupMenu 功能
自从 Microsoft Windows 进入 Windows95 之后，有一个很方便的功能，很多软件都有提供，就是鼠标右键的 PopupMenu 功能，它确实很方便，但是有时却是梦魇，那就是您不需要它的时候，它还是会自动出现！本例中的 TextBox 就是明显的例子。 但是这个梦魇从 VB5.0 以后就可以解决了，因为 VB5.0 提供了 AdressOf 这个运算子，可以做回呼(callback)处理！
请将以下的程序码放在 .bas 模组中，呼叫 Hook 这个 Sub 并传入 TextBox 的 hWnd 当作参数，但是切记您在 Unload Form 之前一定要呼叫 UnHook 这个 Sub，否则会产生一个 General Protection Fault！
Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Const GWL_WNDPROC = -4
Public Const WM_RBUTTONUP = &H205
Public lpPrevWndProc As Long
Private lngHWnd As Long
Public Sub Hook(hWnd As Long)
lngHWnd = hWnd
lpPrevWndProc = SetWindowLong(lngHWnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub
Public Sub UnHook()
Dim lngReturnValue As Long
lngReturnValue = SetWindowLong(lngHWnd, GWL_WNDPROC, lpPrevWndProc)
End Sub
Function WindowProc(ByVal hw As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Select Case uMsg
Case WM_RBUTTONUP
'Do nothing
'Or popup you own menuCase Else
WindowProc = CallWindowProc(lpPrevWndProc, hw, uMsg, wParam, lParam)
End Select
End Function
在 Form_Load 事件中加入以下程序码：
Call Hook(Text1.hWnd)
在 Form_Unload 中加入以下程序码：
Call UnHook
-- 用VB编写键盘拦截程序
我们知道，在一些程序中，有一些快捷方式(如：Shift键最小化、ESC键退出、Ctrl＋S存盘、Alt＋x退出等等)。以前有一些介绍使用Win32 API可以做到，但过于繁琐，其实VB本身已经给我们提供了这个功能。
我们来新建一个窗体Form1，对于键盘操作可以看到有三个事件KeyPress()，KeyDown和KeyUp，下面我对它们分别介绍： KeyPress()事件是当用户按下和松开一个 ANSI 键时发生(ANSI是可见ASCII字符1－127)。
语法
Private Sub object_KeyPress([index As Integer,]keyascii As Integer)
KeyPress 事件语法包含下列部分：
部分 描述
object 一个对象表达式，其值是―应用于‖列表中的一个对象。
29
index 一个整数，它用来唯一标识一个在控件数组中的控件（仅有控件数组时才有）。
keyascii 是返回一个标准数字 ANSI 键代码的整数。Keyascii 通过引用传递，对它进行改变可给对象
发送一个不同的字符。将 keyascii 改变为 0 时可取消击键，这样一来对象便接收不到字符。
说明
具有焦点的对象接收该事件。一个窗体仅在KeyPreview 属性被设置为 True 时才能接收该事件。一个 KeyPress 事件可以引用任何可打印的键盘字符，一个来自标准字母表的字符或少数几个特殊字符之一的字符与 CTRL 键的组合，以及 ENTER 或BACKSPACE键。KeyPress()事件过程在截取 TextBox 或 ComboBox 控件所输入的击键时是非常有用的。它可立即测试击键的有效性或在字符输入时对其进行格式处理。改变 keyascii 参数的值会改变所显示的字符。
可使用下列表达式将 keyascii 参数转变为一个字符：
Chr(KeyAscii)
然后执行字符串操作，并将该字符反译成一个控件可通过该表达式解释的 ANSI 数字：
KeyAscii = Asc(char)
在KeyPress()处理不了的功能可以由KeyDown()和KeyUp()事件来处理：
语法
Private Sub object_KeyDown([index As Integer,]keycode As Integer, shift As Integer)
Private Sub object_KeyUp([index As Integer,]keycode As Integer, shift As Integer)
KeyDown 和 KeyUp 事件包括下列部分：
部分 描述
object 一个对象表达式，其值是“应用于”列表中的一个对象。
index 是一个整数，它用来唯一标识一个在控件数组中的控件（仅有控件数组时才有）。
keycode 是一个键代码，诸如 vbKeyF1 （ F1 键）或 vbKeyHome （ HOME 键）。
shift 是在该事件发生时响应 SHIFT ,CTRL 和 ALT 键的状态的一个整数。shift、CTRL、ALT 键在这些位分别对应于值 1、2 和 4。例如：如果 CTRL 和 ALT 这两个键都被按下，则 shift 的值为 6。
说明
对于这两个事件来说，带焦点的对象都接收所有击键。一个窗体只有在不具有可视的和有效的控件时才可以获得焦点。虽然KeyDown()和KeyUp()事件可应用于大多数键，它们最经常地还是应用于：扩展的字符键如功能键、定位键、键盘修饰键和按键的组合、区别数字小键盘和常规数字键；在需要对按下和松开一个键都响应时，可使用 KeyDown 和 KeyUp 事件过程。 下列情况不能引用 KeyDown 和 KeyUp 事件：窗体有一个 CommandButton 控件，并且 Default 属性设置为 True 时的 ENTER 键。窗体有一个 CommandButton 控件，并且 Cancel 属性设置为 True 时的 ESC 键、TAB键，KeyDown 和 KeyUp 用两种参数解释每个字符的大写形式和小写形式：keycode —显示物理的键（将 A 和 a 作为同一个键返回）和shift—显示shift＋key键的状态而且返回A或a其中之一。
如果需要测试 shift 参数，可使用该参数中定义各位的 shift 常数。该常数有下列值：
常数 值 描述
vbShiftMask 1 HIFT 键的位
屏蔽。
VbCtrlMask 2 CTRL 键的
位屏蔽。
VbAltMask 4 ALT 键的位
屏蔽。
该常数用作位屏蔽，它可被用来测试任何键组合。
注意：如果 KeyPreview 属性被设置为 True，则一个窗体先于该窗体上的控件接收到此事件。可用 KeyPreview 属性来创建全局键盘处理例程。
了解了以上知识，我们可以制作出非常完美而且带有快捷键的程序，例如我们在一个程序中要用Ctrl＋S存盘，Shift最小化，Alt＋X和ESC退出：
首先启动vb选择新建EXE文件，在Form1窗体上拉一个TextBox，并把Form1的KeyPreview属性设为True,双击Form1,选择Form的KeyPress事件，输入如下代码：
Private Sub Form_KeyPress(KeyAscii as Integer) 'Esc键退出，VbEscape可以用27代替
If KeyAscii=VbEscape then End
End Sub
在Form的KeyDown事件中输入如下代码：
30
Private Sub Form_KeyDown(KeyCode as Integer,Shift as Integer) '处理Ctrl＋X,Shift,Alt＋X
If Shift=2 And KeyCode=VbKeyS Then Print ＃FileNum,Form1.Text1.Text 'Ctrl＋S存盘，VbKeyS=83 If shift=2 then Form1.WindowState=1 'Shift最小化
If Shift=4 And KeyCode=VbKeyX Then End 'Alt＋X退出，VbkeyX=88
End Sub
在Form的Load事件中输入如下代码：
Private Sub Form_load()
Dim FileNum as integer
FileNum=FreeFile
Open App.Path＋―\Sample.txt" For Append As ＃FileNum
End Sub
运行它就可以实现我们所要求的功能了，举这个例子只是抛砖引玉的作用，利用它我们还可以编写 -- 实现在FlexGrid控件的栅格中加入文本框、下拉框的功能
在窗体上放一个TEXT,COMBO,还有LABEL控件，当然少不了MSFlexGrid控件，然后再放代码！ Option Explicit
Private Sub Combo1_KeyPress(KeyAscii As Integer)
Dim i As Integer, bSame As Boolean
If KeyAscii = vbKeyEscape Then
Combo1.Visible = False
MSFlexGrid1.SetFocus
Exit Sub
End If
If KeyAscii = vbKeyReturn Then
MSFlexGrid1.Text = Combo1.Text
Combo1.Visible = False
MSFlexGrid1.SetFocus
With Combo1
bSame = False
For i = 0 To .ListCount
If .Text = .List(i) Then bSame = True
Next i
If Not bSame Then .AddItem .Text
End With
End If
End Sub
Private Sub Combo1_LostFocus()
Combo1.Visible = False
MSFlexGrid1.SetFocus
End Sub
Private Sub Form_Load()
Dim i As Integer
With MSFlexGrid1
.Cols = 5
.Rows = 5
For i = 0 To 4
.RowHeight(i) = 300
Next i
End With
For i = 1 To 10
Combo1.AddItem i
31
Next i
Label1.Caption = "在第一、二行中，双击左键，会出现一文字框(TextBox)..." & vbCr & _ "而第三、四行，会出现选择类表单(ComboBox)..." & vbCr & _
"输入完毕后按下Enter键，资料即可保留于MSFlexGrid中，" & vbCr & _ "而按下Esc键则取消输入..."
End Sub
Private Sub MSFlexGrid1_DblClick()
Dim c As Integer, r As Integer
With MSFlexGrid1
c = .Col: r = .Row
If c <= 2 Then
Text1.Left = .Left + .ColPos(c)
Text1.Top = .Top + .RowPos(r)
Text1.Width = .ColWidth(c)
Text1.Height = .RowHeight(r)
Text1 = .Text
Text1.Visible = True
Text1.SetFocus
Else
Combo1.Left = .Left + .ColPos(c)
Combo1.Top = .Top + .RowPos(r)
Combo1.Width = .ColWidth(c)
Combo1.Text = .Text
Combo1.Visible = True
Combo1.SetFocus
End If
End With
End Sub
Private Sub MSFlexGrid1_KeyPress(KeyAscii As Integer)
If KeyAscii = vbKeyReturn Then
Call MSFlexGrid1_DblClick
End If
End Sub
Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii = vbKeyEscape Then
Text1.Visible = False
MSFlexGrid1.SetFocus
Exit Sub
End If
If KeyAscii = vbKeyReturn Then
MSFlexGrid1.Text = Text1.Text
Text1.Visible = False
MSFlexGrid1.SetFocus
End If
End Sub
Private Sub Text1_LostFocus()
Text1.Visible = False
MSFlexGrid1.SetFocus
End Sub
-- 窗口事件的发生顺序
32
-- 强制关闭计算机
用API函数ExitWindowsEx可以实现强制关机，即便是您的应用程序尚未保存文件。
Private Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags As Long, ByVal dwReserved As Long) As Long Const EWX_SHUTDOWN =2
Const EWX_LOGOFF = 1
Const EWX_REBOOT = 4
Const EWX_FORCE = 0
Private Sub Command1_Click()
Dim a
a = ExitWindowsEx(EWX_LOGOFF or EWX_FORCE or EWX_SHUTDOWN, 0)
End Sub
如果将
a = ExitWindowsEx(EWX_LOGOFF or EWX_FORCE or EWX_SHUTDOWN, 0)
改换为
a = ExitWindowsEx(EWX_LOGOFF or EWX_REBOOT, 0)
即可实现强制重启计算机！
-- VB自带打包程序实现"卸载程序"
在“启动菜单项”你可以设置在“开始菜单”中显示哪些项目，你可以加卸载程序项：
选择“新建项”按钮，然后在“目标”栏中输入$(WinPath)\st6unst.exe -n "$(AppPath)\ST6UNST.LOG"，包括双引号。在“开始”项目中选择“$(WinPath)”，不包括双引号。
-- 快速读取 TextBox 第 N 行的资料
TextBox 是以 vbCr+vbLf 为分行符号， 如果我们要逐一读取 TextBox 每一行，
无非是寻找 vbCr+vbLf 的所在位置， 然后取出每一行的字串， 不过这个方法真
的不快，而且如果我们要读取第 N 行资料， 还是要从第 1、2、┅N-1 行逐一读
起， 实在麻烦。
还好 Windows API 提供有读取 TextBox 第 N 行的功能， 细节如下：
33
-- VB中使用正则表达式
正则表达式使用的例子，比如要将所有“<>”括起来的标记(比如<html>)替换成{} 先引用Microsoft VBScript Regular Expressions
Dim re As New RegExp
re.IgnoreCase = True
re.Global = True
re.Pattern = "<[^>]+>"
text1.Text = re.Replace(text1.Text, "{}")
'声明API使用ShellExecute函数
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _ ByVal hwnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
Private Sub Label1_Click()
Dim ret&
ret& = ShellExecute(Me.hwnd, "Open", "127.0.0.1/w.htm", "", App.Path, 1)
End Sub
我引用了这个程序打开了一个本机的html网页；然后怎么实现对它的关闭控制和刷新呢？ 34
-- [原创]用VB在NT上发传真
先将NT的传真服务设置好,在VB中引用faxcom就可以实现传真发送了.
数字排序小游戏
Option Explicit
Dim Label2X As Integer '记录标签控件数组中要移动的标签控件左上角X的位置 Dim Label2Y As Integer '记录标签控件数组中要移动的标签控件左上角Y的位置 '让标签数组中的每个标签控件上显示的数字是随机的，无重复的
Private Sub Init()
Randomize
Dim a(7) As Integer
Dim i As Integer, k As Integer
Label1.Caption = ""
For i = 0 To 7
a(i) = i
35
Next
For i = 0 To 7
k = Int(Rnd * 8)
Do While a(k) = -1 'a(k)=-1表示该数组元素对应的数字已经被使用过了
k = Int(Rnd * 8) '重新生成k的值，直到a(k)的值不等于-1
Loop
Label2(i).Caption = Trim(Str(a(k)))
a(k) = -1 'a(k)的值已经使用了，不能再用，重新赋值为-1与其他的元素值相区别
Next i
End Sub
Private Sub Command1_Click()
Dim x As Integer, y As Integer
Dim z As Integer
Init
Picture1.Enabled = True
'让空白标签Label1出现的位置随机
Randomize
'记录下空白标签Label1的位置
x = Label1.Left
y = Label1.Top
z = Int(Rnd * 8)
'将空白标签Label1和标签控件数组任一控件交换位置
Label1.Move Label2(z).Left, Label2(z).Top
Label2(z).Move x, y
Command1.Enabled = False
End Sub
Private Sub Command2_Click()
End
End Sub
Private Sub Form_Load()
Dim i As Integer
Picture1.Enabled = False
'在标签中显示游戏说明信息
Label3.Caption = "如左图所示，将数字按0-7顺" & vbCrLf & vbCrLf & "序依次排列，即取得胜利。" '在标签中显示排列规则后的数字顺序
Label1.Caption = 0
For i = 0 To 6
Label2(i).Caption = i + 1
Next
End Sub
Private Sub Label1_DragDrop(Source As Control, x As Single, y As Single)
Dim Label1X As Integer '记录空白控件Label1左上角X的位置
Dim Label1Y As Integer '记录空白控件Label1左上角Y的位置
Dim flag(3) As Boolean
'获取空白控件Label1的位置
Label1X = Label1.Left
Label1Y = Label1.Top
'要移动的控件位于空白控件Label1的正左侧
flag(0) = (Label2X = Label1X - Source.Width) And (Label2Y = Label1Y)
36
'要移动的控件位于空白控件Label1的正右侧
flag(1) = (Label2X = Label1X + Source.Width) And (Label2Y = Label1Y)
'要移动的控件位于空白控件Label1的正上方
flag(2) = (Label2X = Label1X) And (Label2Y = Label1Y - Source.Height)
'要移动的控件位于空白控件Label1的正下方
flag(3) = (Label2X = Label1X) And (Label2Y = Label1Y + Source.Height)
If flag(0) Or flag(1) Or flag(2) Or flag(3) Then
Label1.Move Label2X, Label2Y
Source.Move Label1X, Label1Y
End If
Win
End Sub
Private Sub Label2_MouseDown(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single) If Button = vbLeftButton Then '如果按下鼠标左键
'记录下要拖动控件的位置
Label2X = Label2(Index).Left
Label2Y = Label2(Index).Top
Label2(Index).Drag 1 '启动拖动操作
End If
End Sub
Private Sub Label2_MouseUp(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single) Label2(Index).Drag 2 '结束拖动操作
End Sub
Private Sub Win()
Dim winner As Integer
Dim i As Integer
Dim answer As Integer
'对于给定的标签控件数组中的任一标签控件，可以落在符合要求(对应位置应显示对应数字） '的八个位置中的任一位置
'利用循环语句对标签控件数组中的每个标签控件进行检查，如果其落在某一符号要求的位置， '则变量winner的值加1，如果所有标签控件都落在符号要求的位置，则变量winner的值应为8 For i = 0 To 7
If Label2(i).Left = 0 And Label2(i).Top = 0 And _
Label2(i).Caption = 0 Then
winner = winner + 1
ElseIf Label2(i).Left = Label2(i).Width And Label2(i).Top = 0 And _
Label2(i).Caption = 1 Then
winner = winner + 1
ElseIf Label2(i).Left = 2 * Label2(i).Width And Label2(i).Top = 0 And _
Label2(i).Caption = 2 Then
winner = winner + 1
ElseIf Label2(i).Left = 0 And Label2(i).Top = Label2(i).Height And _
Label2(i).Caption = 3 Then
winner = winner + 1
ElseIf Label2(i).Left = Label2(i).Width And Label2(i).Top = Label2(i).Height And _
Label2(i).Caption = 4 Then
winner = winner + 1
ElseIf Label2(i).Left = 2 * Label2(i).Width And Label2(i).Top = Label2(i).Height And _
Label2(i).Caption = 5 Then
winner = winner + 1
37
ElseIf Label2(i).Left = 0 And Label2(i).Top = 2 * Label2(i).Height And _
Label2(i).Caption = 6 Then
winner = winner + 1
ElseIf Label2(i).Left = Label2(i).Width And Label2(i).Top = 2 * Label2(i).Height And _ Label2(i).Caption = 7 Then
winner = winner + 1
End If
Next i
If winner = 8 Then
MsgBox " 恭喜您，胜利了！", 0 + 64 + 0, "提示"
Picture1.Enabled = False
answer = MsgBox("还继续吗？", 4 + 32 + 0, "提示")
If answer = vbYes Then
Command1.Enabled = True
Else
End
End If
End If
End Sub
弹球游戏
Dim x_step As Integer
Dim y_step As Integer
Private Sub command1_Click()
If Timer1.Enabled = True Then
Timer1.Enabled = False
Else
Timer1.Enabled = True
End If
If command1.Caption = "暂停" Then
command1.Caption = "继续"
Else
command1.Caption = "暂停"
38
End If
End Sub
Private Sub Form_Load()
x_step = 200
y_step = 200
End Sub
Private Sub Picture1_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = 37 Then
If Line1.X1 < 0 Then
Line1.X1 = 0: Line1.X2 = 2000
Else
Line1.X1 = Line1.X1 - 100: Line1.X2 = Line1.X2 - 100
End If
End If
If KeyCode = 39 Then
If Line1.X1 > Picture1.Width Then
Line1.X1 = Picture1.Width - 2000: line2.X2 = Picture.Width
Else
Line1.X1 = Line1.X1 + 100: Line1.X2 = Line1.X2 + 100
End If
End If
End Sub
Private Sub Timer1_Timer()
If Shape1.Top < 0 Then
Shape1.Top = 0: y_step = -y_step
End If
If Shape1.Left < 0 Then
Shape1.Left = 0
x_step = -x_step
End If
If Shape1.Left > Picture1.Width - Shape1.Width Then
Shape1.Left = Picture1.Width - Shape1.Width
x_step = -x_step
End If
If Shape1.Left >= Line1.X1 And Shape1.Left <= Line1.X2 And Shape1.Top >= Line1.Y1 - Shape1.Height Then Shape1.Top = Line1.Y1 - Shape1.Height
y_step = -y_step * 1.01
x_step = x_step * 1.01
Label2.Caption = Label2.Caption + 1
End If
39
Shape1.Top = Shape1.Top + y_step
Shape1.Left = Shape1.Left + x_step
If Shape1.Top >= Picture1.Height - Shape1.Height Then
MsgBox "游戏结束"
command1.Caption = "开始"
Timer1.Enabled = False
Shape1.Top = 1000
Label2.Caption = 0
End If
End Sub
打字游戏
Dim score As Integer
Dim speed As Integer
Dim typetime As Integer
Private Sub init()
Randomize
lblletter1.Caption = Chr(Int(Rnd * 42) + 48)
lblletter1.Left = Int(Rnd * 2800) + 1
lblletter1.Top = 0
End Sub
Private Sub init1()
Randomize
lblletter2.Caption = Chr(Int(Rnd * 25) + 97)
lblletter2.Left = Int(Rnd * 2800) + 1
lblletter2.Top = 0
End Sub
Private Sub Command1_Click()
score = Int(lblscore.Text)
init
40
init1
Timer1 = True
Timer2 = True
HScroll1.Enabled = False
Command1.Enabled = False
Command2.Enabled = False
HScroll1.Enabled = False
If lbltime.Text <= 0 Then
Timer1 = False
Timer2 = False
lblletter1.Caption = ""
lblletter2.Caption = ""
End If
End Sub
Private Sub Command2_Click()
typetime = InputBox("请输入打字时间。", "时间设置") If typetime <= 0 Then
lbltime.Text = 60
End If
lbltime.Text = typetime
End Sub
Private Sub Form_KeyPress(KeyAscii As Integer) If Chr(KeyAscii) = lblletter1.Caption Then
score = score + 1
lblscore.Text = score
init
End If
If Chr(KeyAscii) = lblletter2.Caption Then
score = score + 1
lblscore.Text = score
init1
End If
End Sub
Private Sub Form_Load()
Timer1.Enabled = False
Timer2.Enabled = False
lblletter1.AutoSize = True
lblletter2.AutoSize = True
lblletter1.Caption = ""
lblletter2.Caption = ""
lblscore.Text = 0
lblspeed.Caption = 100
lbltime.Text = 60
HScroll1.Max = 200
HScroll1.Min = 20
HScroll1.SmallChange = 5
HScroll1.LargeChange = 20
HScroll1.Value = 100
End Sub
41
Private Sub HScroll1_Change()
lblspeed.Caption = HScroll1.Value
End Sub
Private Sub Timer1_Timer()
lblletter1.Top = lblletter1.Top + lblspeed.Caption
If lblletter1.Top >= 4335 Then
Call init
End If
lblletter2.Top = lblletter2.Top + lblspeed.Caption
If lblletter2.Top >= 4335 Then
Call init1
End If
End Sub
Private Sub Timer2_Timer()
If lbltime.Text > 0 Then
lbltime.Text = lbltime.Text - 1
Else: Select Case score / (typetime / 60)
Case Is <= 40
MsgBox ("不要放弃再试一次！")
Case 40 To 80
MsgBox ("太棒了，继续努力！")
Case 80 To 120
MsgBox ("坚持下去，你将成为一个打字高手！") Case Is > 120
MsgBox ("祝贺你！你已经是一个打字高手！") End Select
Timer1 = False
Timer2 = False
HScroll1.Enabled = True
Command1.Enabled = True
Command2.Enabled = True
HScroll1.Enabled = True
init
init1
End If
End Sub
点灯游戏
42
Private Sub Form_Load()
Form1.Scale (0, 12)-(12, 0)
For i = 1 To 11
Line (1, i)-(11, i)
Line (i, 1)-(i, 11)
Next i
End Sub
Sub fill_color(X, Y)
If Point(X, Y) = vbWhite Then
Line (Int(X), Int(Y))-(Int(X + 1), Int(Y + 1)), vbBlack, BF
Else
Line (Int(X), Int(Y))-(Int(X + 1), Int(Y + 1)), vbWhite, BF
End If
End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) If X >= 1 And X <= 11 And Y >= 1 And Y <= 11 Then
Call fill_color(X, Y)
If X >= 1 And X <= 11 And Y + 1 >= 1 And Y + 1 <= 11 Then
Call fill_color(X, Y + 1)
End If
If X >= 1 And X <= 11 And Y - 1 >= 1 And Y - 1 <= 11 Then
Call fill_color(X, Y - 1)
End If
If X + 1 >= 1 And X + 1 <= 11 And Y >= 1 And Y <= 11 Then
Call fill_color(X + 1, Y)
End If
If X - 1 >= 1 And X - 1 <= 11 And Y >= 1 And Y <= 11 Then
Call fill_color(X - 1, Y)
End If
End If
Call Form_Load
43
End Sub
猜数字
Dim number As Integer
Private Sub Command1_Click()
Dim guess As Integer, diff As Integer
guess = Val(Text1.Text)
If guess = -1 Then
MsgBox ("要猜的数是" & number)
Text1.Text = ""
Text1.SetFocus
Exit Sub
End If
diff = Abs(number - guess)
Select Case diff
Case 0
MsgBox ("恭喜你猜对了！")
Case 2, Is < 2
MsgBox ("接近了，再努力！")
Case 10, Is < 12
MsgBox ("有些远，再努力！")
Case Else
MsgBox ("太远了，继续努力！")
End Select
Select Case diff
Case Is <> 0
Text1.Text = ""
Text1.SetFocus
End Select
End Sub
Private Sub Form_Load()
MsgBox ("计算机产生了一个1~100之间的整数，" & Chr(10) & "请您猜出这个数是多少。" & Chr(10) & "如果输入-1，则停止猜数，并输出要猜的数。")
number = Int(100 * Rnd) + 1
End Sub
Private Sub Label1_Click()
End Sub
猜笑脸
Private Sub Command1_Click(Index As Integer)
Dim a As Integer, i As Integer
Randomize
a = Int(Rnd * 4)
Command1(a).Enabled = False
Command1(a).DisabledPicture = LoadPicture("267.gif")
If a = Index Then
Label1.Caption = "你猜对啦，真棒！"
Else
Label1.Caption = "你猜错啦，我在这哩！"
End If
44
For i = 0 To 3
Command1(i).Enabled = False
Next i
End Sub
Private Sub Command2_Click()
Dim i As Integer
For i = 0 To 3
Command1(i).Enabled = True
Command1(i).DisabledPicture = LoadPicture("") Next i
Label1.Caption = "猜猜我在哪儿？"
End Sub
Private Sub Command3_Click()
End
End Sub
45
