VB使用大全 - 4

60、如何利用API实现代码延时执行

声明:
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

调用:
Sleep 3000 '延时3秒执行

61、若画面上 ListBox 中可显示的项目数量为 5 条，而 ListBox 中的资料总数已超过 5 条，如何让新加入 ListBox 的项目能够马上显示在 ListBox 的最后一条〈画面上显示最后 5 条，含新加入之资料〉？
使用 TopIndex 配合 ListCount 属性即可，而且不会更改原来的选取状态。
List1.AddItem "xxx" 'xxx 指新加入之资料
List1.TopIndex = List1.ListCount - n 'n=5 就是画面上 ListBox 可看到的条数
62、如何事先选定 ListBox 或 ComboBox 的某一个 Item？
有二个方法：
方法1: 使用 For Loop 一一比对，再设定 ListIndex 即可，只是项目多时比方法2慢。例如：
Dim i As Integer
For i = 0 To List1.ListCount - 1
If List1.List(i) = "搜寻的字串" Then
List1.ListIndex = i
Exit For
End If
Next
方法2: '16位版本：
Declare Function SendMessage Lib "User" (ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, lParam As Any) As Long
Const WM_USER = &H400
Const LB_SELECTSTRING = (WM_USER + 13)
Const CB_SELECTSTRING = (WM_USER + 13)
'32 位版本： ( Integer 改成 Long )
Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Const WM_USER = &H400
Const LB_SELECTSTRING = &H18C
Const CB_SELECTSTRING = &H14D
Sub SelectListItem(lst As Control, Idx As String)
Dim i As Long
If TypeOf lst Is ComboBox Then
i = SendMessage(lst.hwnd, CB_SELECTSTRING, -1, ByVal Idx)
Else
i = SendMessage(lst.hwnd, LB_SELECTSTRING, -1, ByVal Idx)
End If
End Sub
在必要的时候，例如 Form_Load，只要 call SelectListItem(ControlName, StringToFind) 即可，不管是 ListBox 或 Combobox，本范例都适用。
63、模拟 IE 的 地址栏：智慧型下拉式 Combo
不知您是否有注意到？您在 IE 的地址栏直接输入地址的时候，如果您输入的地址前面几位和下拉式 Combo 中现存的地址相同时，IE 便会自动带出该地址资料放在 Combo 的 Text 框中，而且这串字有一个特性，在滑鼠游标之前的字是未选定反白的，而在滑鼠游标之后的字则是已经选定反白的，它的目的有二个：
1. 如果您要输入的整串字和它带出的字完全一样，就可以不用再输入，可以节省时间。
2. 如果您要输入的整串字和它带出的字不一样，您还是可以继续输入，继续输入的字串会自动取代后面那串已经选定反白的字串。
以下的范例，只处理英文字，若要处理其他情形如数字，请自行略加更改，请先在 Form1 中放一个 Combo，然后将以下程式直接 Copy 进去即可：
Dim strCombo As String
Const WM_SETREDRAW = &HB
Const KEY_A = 65
Const KEY_Z = 90
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Sub combo1_KeyUp(KeyCode As Integer, Shift As Integer)
Dim x%
Dim strTemp$
Dim nRet&

If KeyCode >= KEY_A And KeyCode <= KEY_Z Then
'only look at letters A-Z
strTemp = Combo1.Text
If Len(strTemp) = 1 Then strCombo = strTemp
nRet& = SendMessage(Combo1.hwnd, WM_SETREDRAW, False, 0&)
For x = 0 To (Combo1.ListCount - 1)
If UCase((strTemp & Mid$(Combo1.List(x), Len(strTemp) + 1))) = UCase(Combo1.List(x)) Then
Combo1.ListIndex = x
Combo1.Text = Combo1.List(x)
Combo1.SelStart = Len(strTemp)
Combo1.SelLength = Len(Combo1.Text) - (Len(strTemp))
strCombo = strCombo & Mid$(strTemp, Len(strCombo) + 1)
Exit For
Else
If InStr(UCase(strTemp), UCase(strCombo)) Then
strCombo = strCombo & Mid$(strTemp, Len(strCombo) + 1)
Combo1.Text = strCombo
Combo1.SelStart = Len(Combo1.Text)
Else
strCombo = strTemp
End If
End If
Next
nRet& = SendMessage(Combo1.hwnd, WM_SETREDRAW, True, 0&)
End If
End Sub
Private Sub Form_Load()
Combo1.AddItem "AAAAAAAA"
Combo1.AddItem "ABBBBBBB"
Combo1.AddItem "ABCCCCCC"
Combo1.AddItem "ABCDDDDD"
Combo1.AddItem "ABCDEEEE"
Combo1.AddItem "ABCDEFFF"
Combo1.AddItem "ABCDEFGG"
Combo1.AddItem "ABCDEFGH"
End Sub
64、如何让 ListBox 同一列显示二栏以上的栏位？
要让 ListBox 显示二栏以上，有很多方法：
有人用二个字串中间加上空白来 AddItem，但是这样有一个很大的缺点，就是第二栏常常无法对齐！有人说可以加上 Format 来强迫留白，以便对齐，但是这些方法都比较麻烦，没有效率！
有一个很简单，又保证不用伤脑筋就可以对　的方法，就是使用 vbTab！作法如下：
lstMyListBox.AddItem "0001" & vbTab & "王一" & vbTab & "广州市"
lstMyListBox.AddItem "0002" & vbTab & "丁二" & vbTab & "上海市"
lstMyListBox.AddItem "0003" & vbTab & "张三" & vbTab & "北京市"
lstMyListBox.AddItem "0004" & vbTab & "李四" & vbTab & "重庆市"
65、如何控制二栏以上 ListBox 之各栏位宽度？
使用 vbTab 来设定 ListBox 的多栏显示，效果不错，但是若以 vbTab 来做，每栏长度是固定的，只有 8，我的资料有些字串很长，有些很短，如果可以逐栏设定宽度，那就太完美了！但是单用 VB 的基本函数，是做不到的！不过我们可以 Call API：
假设要放到 ListBox 的资料有四个栏位，如下：
1、员工编号 (长度为6)
2、员工姓名 (长度为6)
3、员工住址 (长度为38)
4、员工性别 [长为4]
Const LB_SETTABSTOPS = &H192
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Sub SetListTabStops(iListHandle As Long)
' 设定四个栏位, 长度各为 6,6,38,4
' iListHandle = the window handle of the list box
Dim iNumColumns As Long
Dim iListTabs(3) As Long
Dim Ret As Long
iNumColumns = 4
iListTabs(0) = 24 ' 24/4 = 6 (第1-第6字节)
iListTabs(1) = 48 ' 48/4 = 12 (第7-第12字节)
iListTabs(2) = 200 ' 200/4 = 50 (第13-第50字节)
iListTabs(3) = 216 ' 216/4 = 54 (第51-第54字节)
Ret = SendMessage(iListHandle, LB_SETTABSTOPS, _
iNumColumns, iListTabs(0))
End Sub
Private Sub Form_Load()
Call SetListTabStops(List1.hwnd)
List1.AddItem "0001" & vbTab & "王一" & vbTab & "广州市市体育东路二段120巷176号" & vbTab & "男"
List1.AddItem "0002" & vbTab & "丁二" & vbTab & "北京市中关村路100号" & vbTab & "男"
List1.AddItem "0003" & vbTab & "张三" & vbTab & "上海市中山路150巷26号" & vbTab & "女"
List1.AddItem "0004" & vbTab & "李四" & vbTab & "重庆市福州路99号" & vbTab & "男"
End Sub　

66、ListBox 选项资料太长，如何设定 ListBox 的水平卷动轴？
VB 的 ListBox 并没有水平卷动轴的功能，如果遇到某一个资料项很长时， 使用者就无法看到这一个资料项的所有内容，要如何设定水平卷动轴给 ListBox?
可利用 SendMessage 传送 LB_SETHORIZONTALEXTENT 讯息给 ListBox，此一讯息的作用就是要求ListBox 设定水平卷动轴，细节如下：
1. API 的声明：
'16位
Const WM_USER = &H400
Const LB_SETHORIZONTALEXTENT = (WM_USER + 21)
Private Declare Function SendMessage Lib "User" (ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, lParam As Any) As Long
'32位
Const LB_SETHORIZONTALEXTENT = &H194
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
2. 程序范例：
' List1 为 ListBox 的名称
Call SendMessage(List1.hwnd, LB_SETHORIZONTALEXTENT, 水平卷动轴的宽度, ByVal 0&)

特别注意：
以上的水平卷动轴宽度的单位是 pixel(像素)，或许您会认为这个宽度就是 ListBox 的宽度，但是结果却不是这样的，它真正指的是这个卷动轴要卷动的文字的宽度，所以您要预留可能放到 ListBox 内的资料最长的长度，若留得太短，可能出现以下二种情形：
1、 水平卷动轴的宽度设的比 ListBox 本身的宽度还短，VB会认为不需要卷动轴，而不产生卷动轴！
2、 水平卷动轴的宽度设的比 ListBox 内的资料宽度还短，则只能卷动一半，还是看不到完整内容！
67、ListBox 选项资料太长，如何使用 ToolTip 来显示内容？
ListBox 选项资料太长，虽然可以加上水平卷动轴，但卷来卷去还是有点麻烦，如果可以出现 Popup ToolTip 就更正点了！当然，您若想要二种功能一起使用，也是可以的。
关于这个主题，我看过很多范例都是使用 API 来做，但是以下这个方法既简单，又不必使用任何 API，帅吧！
Private Sub List1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim YPos As Integer, iOldFontSize As Integer
iOldFontSize = Me.Font.Size
Me.Font.Size = List1.Font.Size
YPos = Y \ Me.TextHeight("Xyz") + List1.TopIndex
Me.Font.Size = iOldFontSize
If YPos < List1.ListCount Then
List1.ToolTipText = List1.List(YPos)
Else
List1.ToolTipText = ""
End If
End Sub
68、如何加长 ComboBox 的下拉选单？
Combo 预设的下拉长度只有 5,6 个选项，当选项很多时，要卷老半天才能找到资料，很不方便！要加长 ComboBox 的下拉选单，方法如下：
在声明区中放入以下声明及 Subroutine
Private Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
Public Sub SetComboHeight(oComboBox As ComboBox, lNewHeight As Long)
Dim oldscalemode As Integer
' This procedure does not work with frames: you
' cannot set the ScaleMode to vbPixels, because
' the frame does not have a ScaleMode Property.
' To get round this, you could set the parent control
' to be the form while you run this procedure.
If TypeOf oComboBox.Parent Is Frame Then Exit Sub
' Change the ScaleMode on the parent to Pixels.
oldscalemode = oComboBox.Parent.ScaleMode
oComboBox.Parent.ScaleMode = vbPixels
' Resize the combo box window.
MoveWindow oComboBox.hwnd, oComboBox.Left, oComboBox.Top, oComboBox.Width, lNewHeight, 1
' Replace the old ScaleMode
oComboBox.Parent.ScaleMode = oldscalemode

69、如何加宽 ComboBox 的下拉选单？
和 ListBox 一样， ComboBox 也会有宽度不够的情形， Combo 下拉之后资料看不完整，当 Form 上的物件不多时，还可以拉长一点，但有时候也没办法！这时候，还是得靠 API 了！
在声明区中放入以下声明及 Subroutine
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long
Const CB_SETDROPPEDWIDTH = &H160
Public Sub SetComboWidth(oComboBox As ComboBox, lWidth As Long)
' lWidth 是宽度，单位是 pixels
SendMessage oComboBox.hwnd, CB_SETDROPPEDWIDTH, lWidth, 0
End Sub
在任何时候 (不一定是 Form_Load 或 Combo_DropDown)，想要加宽 ComboBox 的下拉选单时，只要加入以下程序即可 (若设定的宽度小于 Combo 原来的宽度则无效)：
Call SetComboWidth(Combo1, 270) '设定的单位是 Pixels
70、如何用程序控制滑鼠游标 (Mouse Cursor) 到指定位置？
以下这个例子，当 User 在 Text1 中按下 'Enter' 键后，滑鼠游标会自动移到 Command2 按钮上方
请在声明区中加入以下声明：
'16 位版本： ( Sub 无传回值 )
Declare Sub SetCursorPos Lib "User" (ByVal X As Integer, ByVal Y As Integer)
'32 位版本： ( Function 有传回值，Integer 改成 Long )
Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
'在 Form1 中加入以下程序码：
Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
x% = (Form1.Left + Command2.Left + Command2.Width / 2 + 60) / Screen.TwipsPerPixelX
y% = (Form1.Top + Command2.Top + Command2.Height / 2 + 360) / Screen.TwipsPerPixelY
SetCursorPos x%, y%
End If
End Sub

71、如何用鼠标移动没有标题的 Form，或移动 Form 中的控制项？
在声明区中放入以下声明：
'16 位版本： ( Sub 无返回值 )
Private Declare Sub ReleaseCapture Lib "User" ()
Private Declare Sub SendMessage Lib "User" (ByVal hwnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, lParam As Long)
'32 位版本： ( Function 有返回值，Integer 改成 Long )
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
'共用常数：
Const WM_SYSCOMMAND = &H112
Const SC_MOVE = &HF012
'若要移动 Form，程序码如下：
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim i As Long
i = ReleaseCapture
i = SendMessage(Form1.hwnd, WM_SYSCOMMAND, SC_MOVE, 0)
End Sub
'以上功能也适用于用鼠标在 Form 中移动控制项，程序码如下：
Private Sub Command1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim i As Long
i = ReleaseCapture
i = SendMessage(Command1.hwnd, WM_SYSCOMMAND, SC_MOVE, 0)
End Sub
72、如何判断目前电脑中所有磁盘之型态？

在 Form 中放置一个 ListBox 名称为 List1
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Private Sub Form_Load()
Dim i As Integer
Dim ret As Long '返回值
Dim wtype As String '磁盘型态
For i = 65 To 90 'ASC(A) ~ ASC(Z)
wtype = ""
ret = GetDriveType(Chr$(i) & ":\") '传入磁盘代号
Select Case ret
Case 2
wtype = "软盘"
Case 3
wtype = "硬盘"
Case 4
wtype = "网路磁盘"
Case 5
wtype = "光盘"
End Select
If wtype <> "" Then List1.AddItem Chr$(i) & ":\" & vbTab & wtype
Next
End Sub
若是 16 位程序，声明略有不同，如下：
Private Declare Function GetDriveType Lib "Kernel" (ByVal nDrive As Integer) As Integer
传入的参数型态是 Integer，0 代表 A 磁盘，依次加 1，2 代表 C 磁盘。
73、检查文件是否存在？
Function FileExists(filename As String) As Integer
Dim i As Integer
On Error Resume Next
i = Len(Dir$(filename))
If Err Or i = 0 Then FileExists = False Else FileExists = True

End Sub
在任何时候 (不一定是 Form_Load 或 Combo_DropDown)，想要加长 ComboBox 的下拉选单时，只要加入以下程序即可：
Call SetComboHeight(Combo1, 270) '设定的单位是 Pixels

76、同一个 Form 中若要将 OptionButton 分组，该如何做？

在同一个 Container 中，只能放置一组 OptionButton，所以若要在一个 Form 中放置一组以上之 OptionButton 时，必须以不同之 Container 区隔。

而在 VB 中可当作 Container 的物件有 Form / PictureBox / Frame ...等。

77、VB 32-bits 之后的版本，无论用 Len 或是 LenB 都无法正确的计算中英文混合字串的长度，有没有解决的办法？

这是由于 VB 32-bits 都是采 Unicode，Unicode 的储存方式无论中英文字，均是以 2bytes 来储存，有两个方式可以解决：

解法1:

'假设欲计算字串 str1 的长度
Dim str1 As String
Dim i As Long
Dim c As Long
Dim n As Long
For i = 1 To Len(str1)
      c = Asc(Mid(Str, i, 1))
      If c >= 0 And c < 128 Then
          n = n + 1 '计算英文
      Else
          n = n + 2 '计算中文
      End If
Next i

解法2:

Lenb(Strconv("abcd中英文混合字efg", vbFromUnicode))

78、Visual Basic 程式开发完成后，可否把执行时相关的文档一并销售？

在下列条件下可以不须支付权利金便可以重制并散布 Run-time Modules (限于可执行文档、安装文档、ISAM 和Rebuild文档)：

1.将 Run-time Modules 配合作为您的软件的一部份一同散布。
2.不使用微软的名称，标章或商标来行销您的软体。
3.附加一个您软件的有效著作权通知。
4.同意对微软或其供应商因为您软体的散布和使用所导致的请求、诉讼，包括律师费、赔偿、为微软或其供应商辩护使其不受损害。

79、我想知道某一部电脑出现在 "网路上的芳邻" 时的名称，也就是"电脑名称"，该如何做？

其实出现在 "网路上的芳邻" 中的名称, 就是我们在 "控制面板" --> "网路" --> "个人资料" --> "电脑名称" , 要抓这个名称, 有好几个方法, 但有的比较复杂, 例如, 直接从注册表抓, 以下的方法则比较简单. (　 VB4-32 以上)

请在声明区中放入以下声明 :

Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Public Function ComputerName() As String
Dim cn As String
Dim ls As Long
Dim res As Long
cn = String(1024, 0)
ls = 1024
res = GetComputerName(cn, ls)
If res <> 0 Then
ComputerName = Mid(cn, 1, InStr(cn, Chr(0)) - 1)
Else
ComputerName = ""
End If
End Function

程序中要使用时只要直接 call 即可.

例 : Msgbox "ComputerName=" & ComputerName

80、我想知道某一部电脑目前的 Login User 是谁，该如何做？

请在声明区中放入以下声明 :

Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Public Function UserName() As String
Dim cn As String
Dim ls As Long
Dim res As Long
cn = String(1024, 0)
ls = 1024
res = GetUserName(cn, ls)
If res <> 0 Then
UserName = Mid(cn, 1, InStr(cn, Chr(0)) - 1)
Else
UserName = ""
End If
End Function

程序中要使用时只要直接 call 即可.

例 : Msgbox "UserName=" & UserName

81、我已经知道 "电脑名称" 及 "LoginUser" 的抓法了, 我可以将电脑名称改成 LoginUser 吗？
可以的, 请在声明区中放入以下声明:
Private Declare Function SetComputerName Lib "kernel32" Alias "SetComputerNameA" (ByVal lpComputerName As String) As Long
程序中要使用时只要直接 call 即可. 例如: 要将电脑名称改成员工编号 "RT000588"
Private Sub Command1_Click()
Dim res As Long
res = SetComputerName("RT000588")
If res <> 0 Then
MsgBox "成功!!!"
Else
MsgBox "有问题!!!"
End If
End Sub
虽然已经更改成功，但并不会马上有作用，所以在网路上的芳邻中，还会是旧的电脑名称，一直要等到重新开机之后才有作用。
82、反向思考---怎样让程序跑慢一点？
大部份时间，我们都希望我们自己开发的程序跑得越快越好，但是有些状况，我们却希望它能够稍微停一下，等待某一个返回值或某一个动作做完了，才继续执行下一个指令，可是偏偏 VB 没有提供这样的指令，我要怎样延迟一个VB程序呢 　
在声明区中加入以下声明:
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
在事件中只要 call 它即可
Call Sleep(1000) '1000代表延迟1秒
不过很抱歉，它只在 32位元中才有提供, 所以要在 VB4-32 位元以上才可使用 !!!
83、《打砖块》一颗在画面上跳动碰撞的小球
这个范例加以引申，就可以做出像一样的游戏！
'在 Form 中放一个 Shape，Shape 属性设成 3-圆形，长宽设成 60
'在 Form 中放一个 Timer，Interval 属性设成 48
'声明二个 Form Level 或 Global 变数 (此范例声明在 Form 中)
Dim horizan As Integer
Dim vertical As Integer
'在 Form_Load 设定每次水平或垂直移动的距离
Private Sub Form_Load()
horizan = 50 '水平移动的距离
vertical = 50 '垂直移动的距离
End Sub
'移动小球并检查是否超出四个边界 ? 若超过则改变方向.
'注意: Me.Width 包含 Form 左右二边 Border 的宽度
' Me.Height 包含 Form 上方 TitleBar 的高度及下方 Border 的高度
Private Sub Timer1_Timer()
ball.Move ball.Left + horizan, ball.Top + vertical
If ball.Top <= 0 Then vertical = -vertical
If ball.Top + ball.Height >= Me.Height - 420 Then vertical = -vertical
'扣除 420 是指 Form 上方 TitleBar 的高度 + 下方 Border 的高度
If ball.Left <= 0 Then horizan = -horizan
If ball.Left + ball.Width >= Me.Width - 100 Then horizan = -horizan
'扣除 120 是指 Form 左右二边 Border 的宽度
End Sub
如果是固定的 Form，以上的程序代码就已经完成了，但是如果 Form 的大小是可以调整的话，当您调整 Form 的大小后，小球的位置可能有一段时间会跑到荧幕外，要预防这种情形，必须再加上以下的程序代码：
Private Sub Form_Resize()
If ball.Top <= 0 Then
ball.Top = -25
vertical = -vertical
End If
If ball.Top >= (Me.Height - 420) Then
ball.Top = (Me.Height - 445) - ball.Height
vertical = -vertical
End If
If ball.Left <= 0 Then
ball.Left = -25
horizan = -horizan
End If
If ball.Left >= (Me.Width - 100) Then
ball.Left = (Me.Width - 125) - ball.Width
horizan = -horizan
End If
End Sub
运用时要做调整，主要就是调整以下二个因素：
1、每次水平或垂直移动的距离，就是 horizan / vertical
2、Timer 的间距，就是 Timer 的 Interval
注：其实要完整一点的话，还需要用 API 去抓出 Form 上方 TitleBar 的高度四方 Border 的宽度。