如何优化VB程序

最新推荐文章于 2024-07-23 13:16:28 发布

kyu16866

最新推荐文章于 2024-07-23 13:16:28 发布

阅读量6k

点赞数

文章标签： vb 优化 integer function microsoft string

如何去优化你的VB程序帮助

1、如何去优化你的VB程序
Visual Basic 作为一种高级编程语言，它也有着不可避免的缺点---开发出的应用程序运行速度慢。如果我们能够程序做一些优化，那么情况将会大大改善。要优化程序运行的实际速度，常用的方法有三种：
1.尽量避免使用 Variant 变量。由于VB不能确定 Variant 变量的具体类型，所以它会给该类型变量分配16个字节的空间，而且在用变量进行运算时还要考虑到数据类型的转换。这既占用内存，又影响了速度，会使涉及到复杂运算的程序慢。注意，一个变量的缺省类型就是 Variant，其它类型的变量要用Dim语句单独声明。
2.在遇到整型数据时尽量使用Long变量。因为Long变量是32位CPU的本机数据类型，所以处理速度会很快，尤其是在循环体中。
3.将控件的常用属性保存在变量中。一般控件存在于DLL或OCX这类的外部程序中。众所周知，调用DLL远比访问内存慢。所以对于那些放在循环体中的常用属性，如果将它们保存在变量中，那么速度将会有成百上千倍提升。
我们在编写程序时应注意到，在进行长时间等待操作时，可以做一些动画之类的效果，好让用户知道程序运行正常。下面是几个常用优化方法：
（1）使用 Splash 屏幕。也就是我们常见的欢迎窗口。大的应用程序在启动时，往往会主动或被动地载入一大堆DLL，这要花费很长时间。所以我们在启动时可以先显示一个简单的窗口，上面只放一些作者、版权之类的信息，在这个窗口的Form_Load事件中用Load方法读入那些最常用的窗体模块。这样，虽然实际等待的时间延长了，但用户所看到的屏幕总是变化的，所以感觉下程序启动加快了。而且由于常用窗体模块事先已载入内存，以后只需用Show方法来显示它，跳过了载入过程，在程序运行过程中也会很快的。
（2）使用Timer控件。由于Timer控件的出现，使得后台作业有了可能。我们可以在每次Timer事件中完成一小部分任务。这样，由于Timer中的事件能够在很短的时间内完成，用户一般查觉不到速度的变化。如果一定要在一个循环内完成某个任务，那么不要忘了用DoEvents来释放用户。
（3）使用进度条。要使用进度条，需要事先知道数据量，所以它很适合用于对已知数据的操作，如数据库的排序。
总之，优化程序要从自己、从用户等多方面考虑，使程序开发周期短，且高效易用。
2、在VB中如何创建闪烁(标语)屏
大型应用系统启动运行的时间需要很长时间,其时间会根据需要初始化的数量和用户系统的速度变化,因此在主窗口显示前,应显示一个初始化窗口,使应用程序看起来更具吸引力,因为当装载程序时不断可以向用户显示一些信息，而且可产生美观的视觉效果。例如vb、delphi在启动时均在主界面前显示一splash窗口.
---- 1. 下面是显示闪烁(标语)屏splash的一种简单方法:
option explicit
private sub form_load()
'显示主窗口
me.show
'显示splash窗口
frmsplash.show
doevents
'执行应用程序初始化
initialize
'关闭splash窗口
unload spalsh
end sub
---- 该过程代码应放在应用程序的启动窗体中。第一个show方法可使windows在屏幕上显示主窗体，下一个show方法显示闪烁屏，它是你设计的名为frmsplash的窗体.在利用show方法之后，再利用Doevents函数，以确保闪烁屏窗体的所有元数立即绘制完。Initialize函数执行应用程序在启动时需要执行的费时任务，例如，从文件中装载数据，将窗体装入内存等等。这时一切都准备就绪.
---- 2.闪烁窗体模板
---- Visual Basic 中含有许多摸板窗体，其中之一是闪烁屏。要为项目添加Splash screen 窗体，需要从project菜单中选择Add Form.在Add Form 对话框的New标签上选择Splash Screen图标，并单击Open.这样Splash Screen窗体就被添加到项目中.
---- 下列代码显示了如何定制Splash Screen 窗体摸板的实例:
option explicit
private sub form_load()
frmsplash.lbllicenseto=app.legaltrademarks
frmsplash.lblcompanyproduct=app.productname
frmsplash.lblplatform="window 98"
frmsplash.lblcopyright=app.legalcopyright
frmsplash.lblcompany=app.companyname
frmsplash.lblwarning="Warning:this program is protected" & _
"by copyright law,so don't copy "
frmsplash.show
doevents
initialize
unload frmsplash
end sub
---- 注意这里使用了app对象，该对象可以访问有关你的应用程序的信息;
---- splash screen 窗体摸板代码模块的代码如下所示:
Private Sub Form_keypress(keyascii as integer)
unload me
End sub
Private sub form_load()
lblversion.caption="version"&app.major&".
"app.minor"."app.revision
lblproductname.caption=app.title
end sub
private sub frame1_click()
unload me
End Sub
3、如何用VB建立快捷方式
Private Declare Function fCreateShellLink Lib "STKIT432.DLL" (ByVal lpstrFolderName As String, ByVal lpstrLinkName As String, ByVal lpstrLinkPath As String, ByVal lpstrLinkArgs As String) As Long
Sub Command1_Click()
Dim lReturn As Long
'添加到桌面
lReturn = fCreateShellLink("../../Desktop", "Shortcut to Calculator", "c:/windows/calc.exe", "")
'添加到程序组
lReturn = fCreateShellLink("", "Shortcut to Calculator", "c:/windows/calc.exe", "")
'添加到启动组
lReturn = fCreateShellLink("/Startup", "Shortcut to Calculator", "c:/windows/calc.exe", "")
End Sub
4、如何在VB中判断Windows9x的运行模式
在Windows下编程，经常发现有不少功能Windows系统已经做了，如果能够直接调用，就可省去不少程序的编写，并能提高程序的运行效率。在很多情况下，我们都可以用“Ctrl ＋ X”、“Ctrl ＋ C”、 “Ctrl ＋ V”和“Ctrl ＋ Z”分别进行“剪切”、“复制”、“粘贴”和“撤消”操作，由此想到，如果我们能够在程序中调用系统的这些功能，就无需为如何实现这些操作而操心了。经过不断的探索，终于发现SendMessage和PostMessage能够担此重任，真是如获至宝，于是迫不及待地把它们介绍给各位朋友。
　　用VB5的“API浏览器”可以很容易地找到这两个API 函数：
Declare Function SendMessage Lib “user32” Alias “SendMessageA” _(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _lParam As Any) As Long
Declare Function PostMessage Lib “user32” Alias “PostMessageA” _(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _ByVal lParam As Long) As Long
　　这两个函数的功能几乎是一样的，只是SendMessage是直接调用Windows函数来发送消息，只有这个消息完全被处理后此函数才返回，而PostMessage则给窗体的消息队列增加一个消息，这个消息将在未来某个时候进行正常事件处理时得到处理。以下仅以SendMessage为例。
　　函数中虽然有四个参数，但关键的是前两个：hwnd 和wMsg。Hwnd是句柄，Microsoft Windows应用程序中的每个窗体和控件都拥有一个句柄，通过句柄可以指明函数的操作对象；wMsg是一个十六进制数，代表了函数要发送的具体消息。
　　下面以具体例子说明如何用SendMessage实现“剪切”、“复制”、“粘贴”、“撤消” 和“删除”功能:
　　在窗体中放置一个文本框Text1和五个按钮，分别执行以上五种功能，编写以下程序。
Option Explicit
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_CUT = ＆H300
　　Const WM_COPY = ＆H301
　　Const WM_PAST = ＆H302
　　Const WM_CLEAR = ＆H303
　　Const WM_UNDO = ＆H304
　　Dim fb As Long
　　
　　Private Sub cmdClear_Click()
　　 fb = PostMessage(Text1.hwnd, WM_CLEAR, 0, 0)
　　End Sub
　　Private Sub cmdCopy_Click()
　　 fb = SendMessage(Text1.hwnd, WM_COPY, 0, 0)
　　End Sub
　　Private Sub cmdCut_Click()
　　 fb = SendMessage(Text1.hwnd, WM_CUT, 0, 0)
　　End Sub
　　Private Sub cmdPast_Click()
　　 fb=SendMessage(Text1.hwnd, WM_PAST, 0, 0)
　　End Sub
　　Private Sub cmdUndo_Click()
　　 fb=SendMessage(Text1.hwnd, WM_UNDO, 0, 0)
　　End Sub
　　除了TextBox外SendMessage 还可以对RitchTextBox和ComboBox等进行操作,只要相应改变hwnd参数即可。
5、如何在Windows操作系统中改变文件打开方式
在Windows 95／NT／98操作系统中改变文件打开方式的问题，又可称为改变文件类型关联的问题，即把某类型（扩展名）的文件与某应用程序关联，例如通常当双击＊.txt文件时系统自动调用Notepad.exe。本文介绍利用Windows注册表编辑器Regedit.exe手工或编程改变文件打开方式的方法，并提供程序实例。
　　一、基本思路：
　　1、注册表编辑器Regedit.exe是用于更改系统注册表设置的高级工具，包含了关于系统配置及运行的重要信息，默认访问路径为C:/Windows/Regedit.exe。双击Regedit.exe图标，运行注册表编辑器。在左侧显示栏内看到HKEY_CLASSES_ROOT、KEY_CURRENT_USER、HKEY_LOCAL_MACHINE等主键。与文件类型有关的所有主键、键名、键值都存放在HKEY_CLASSES_ROOT下。
　　◆双击HKEY_CLASSES_ROOT，向下拖动滚动条，找到.txt主键，右侧显示栏内“txtfile”说明：在HKEY_CLASSES_ROOT下有一txtfile主键，其下存放了打开＊.txt文件应用程序的有关信息。
　　◆向下拖动滚动条，找到txtfile主键，右侧显示栏内“文本文档”为文件类型描述。双击txtfile，DefaultIcon右侧显示栏内“shell32.dll,－152”为＊.txt文件的图标；shell/open/command，右侧显示栏内“C:/WINDOWS/NOTEPAD.EXE ％1”为打开＊.txt文件的应用程序名称及参数。　　改变打开文件方式的方法（例如用VISIO打开＊.exc文件）：
　　◆手工：打开系统注册表，在HKEY_CLASSES_ROOT下找到.exc及另一主键名，找到此主键，将shell/open/command右侧显示栏内“C:/WINDOWS/NOTEPAD.EXE ％1”改为“C:/VISIO.EXE ％1”（假设VISIO.EXE的访问路径是C:/，具体视情况而定），按F5刷新系统注册表。
　　◆编程：利用VB、Delphi、C＋＋Builder等读写系统注册表，可自动改变文件打开方式。本文提供VB、Delphi编程实例。
　　二、编程实例：
　　㈠利用VB编程
　　1、在VB5.0 IDE中，新建工程Project1，在Form1上添加命令按钮Command1。
　　2、选择菜单“工程”—“添加模块”—“模块”—“打开”，在Project1中添加模块Moudle1。
　　3、在Moudle1“通用—声明”部分声明API函数和常量。
　　Const REG_SZ = 1
　　Global Const HKEY_CLASSES_ROOT = ＆H80000000
Declare Function OSRegQueryValueEx Lib “advapi32”Alias “RegQueryValueExA”(ByVal hKey As Long, ByVal lpszValueName As String,
ByVal dwReserved As Long, lpdwType As Long, lpbData As Any, cbData As Long) As Long
Declare Function OSRegOpenKey Lib “advapi32”Alias “RegOpenKeyA”(ByVal hKey As Long, ByVal lpszSubKey As String, phkResult As Long) As Long
Declare Function OSRegSetValueEx Lib“advapi32”Alias “RegSetValueExA”（ByVal hKey As Long, ByVal lpszValueName As String,
ByVal dwReserved As Long, ByVal fdwType As Long, lpbData As Any, ByVal cbData As Long) As Long
Declare Function OSRegCloseKey Lib“advapi32”Alias “RegCloseKey”(ByVal hKey As Long) As Long
　　4、在Moudle 1中编写函数。
　　Function RegOpenKey(ByVal hKey As Long, ByVal lpszSubKey As String,
phkResult As Long) As Boolean
　　 Dim lResult As Long
　　 On Error GoTo 0 ` 关闭错误陷阱
　　 lResult = OSRegOpenKey(hKey, lpszSubKey, phkResult)
　　 If lResult = 0 Then
　　 RegOpenKey = True
　　 Else
　　 RegOpenKey = False
　　 End If
　　End Function
　　Function RegSetStringValue(ByVal hKey As Long, ByVal strValueName As String,
ByVal strData As String, Optional ByVal fLog) As Boolean
　　 Dim lResult As Long
　　 On Error GoTo 0
　　 lResult = OSRegSetValueEx(hKey, strValueName, 0＆, REG_SZ, ByVal strData,
LenB(StrConv(strData, vbFromUnicode)) ＋ 1)
　　 If lResult = 0 Then
　　 RegSetStringValue = True
　　 Else
　　 RegSetStringValue = False
　　 End If
　　End Function
　　Function StripTerminator(ByVal strString As String) As String
　　 Dim intZeroPos As Integer
　　 intZeroPos = InStr(strString, Chr＄(0))
　　 If intZeroPos > 0 Then
　　StripTerminator=Left＄(strString, intZeroPos － 1)
　　 Else
　　 StripTerminator = strString
　　 End If
　　End Function
　　Function RegQueryStringValue(ByVal hKey As Long, ByVal strValueName As String,
strData As String) As Boolean
　　 Dim lResult As Long
　　 Dim lValueType As Long
　　 Dim strBuf As String
　　 Dim lDataBufSize As Long
　　 RegQueryStringValue = False
　　 On Error GoTo 0
　　 lResult = OSRegQueryValueEx(hKey, strValueName, 0＆, lValueType, ByVal 0＆,
lDataBufSize)
　　 If lResult = ERROR_SUCCESS Then
　　 If lValueType = REG_SZ Then
　　 strBuf = String(lDataBufSize, “”)
　　 lResult = OSRegQueryValueEx(hKey, strValueName, 0＆, 0＆, ByVal strBuf,
lDataBufSize)
　　 If lResult = ERROR_SUCCESS Then
　　 RegQueryStringValue = True
　　 strData = StripTerminator(strBuf)
　　 End If
　　 End If
　　 End If
　　End Function
　　5、双击Command1，编写Click事件代码。
　　Private Sub Command1_Click()
　　 Dim hKey As Long
　　 Dim MyReturn As Long
　　 Dim MyData As String
　　 MyReturn = OSRegOpenKey(HKEY_CLASSES_ROOT, “.exc”, hKey)
　　MyReturn=RegQueryStringValue(hKey,“”,MyData)
　　MyReturn=OSRegOpenKey(HKEY_CLASSES_ROOT, MyData＋“/shell/open/command”,hKey)
　　 MyReturn = RegSetStringValue(hKey,“”,“c:/visio.exe 1％”, False)
　　 If MyReturn Then
　　 MsgBox “改变文件打开方式成功！”,vbInformation,“请注意”
　　 Else
　　 MsgBox “改变文件打开方式失败！”,vbExclamation,“请注意”
　　 End If
　　 OSRegCloseKey (hKey)
　　End Sub
　　6、按F5运行程序，在简体中文Windows95／NT／98、VB5.0／6.0环境中调试通过。
　　㈡利用Delphi编程
　　1、在Delphi3.0 IDE中，新建工程Project1，在Form1上添加按钮Button1。
　　2、在uses子句中添加Registry。
　　3、双击Button1，编写Click事件代码。
　　procedure TForm1.Button1Click(Sender: Tobject);
　　var
　　 MyRegistry : TRegINIFile;
　　 Return:string;
　　begin
　　 try
　　 MyRegistry := TRegINIFile.Create(``);
　　MyRegistry.RootKey := HKEY_CLASSES_ROOT;
　　 Return:=MyRegistry.ReadString (`.gid`,``,`No! Not Found the Key!`);
　　 MyRegistry.WriteString(Return,``,`这只是一个演示！`);
　　 MyRegistry.WriteString(Return＋`/DefaultIcon`,``,`c:/visio.exe,1`);
　　 MyRegistry.WriteString(Return＋`/shell/open/command`,``,`c:/visio.exe ％1`);
　　 finally
　　 MyRegistry.Free;
　　 end;
　　 ShowMessage(`改变文件打开方式成功！`);
　　end;
　　4、按F9运行程序，在简体中文Windows95／NT／98、Delphi3.0／4.0环境中调试通过。
6、用VB开发应用程序如何使用INI文件
为了方便用户使用和使系统具有灵活性，大多数Win-dows应用程序将用户所做的选择以及各种变化的系统信息记录在初始化(INI)文件中。因此，当系统的环境发生变化时，可以直接修改INI文件，而无需修改程序。由此可见，INI文件对系统功能是至关重要的。本文将介绍采用VisualBasicforWindows(下称VB)开发Windows应用程序时如何读写INI文件。
INI文件是文本文件，由若干部分(section)组成，在每个带括号的标题下面，是若干个以单个单词开头的关键词(keyword)和一个等号，每个关键词会控制应用程序某个功能的工作方式，等号右边的值(value)指定关键词的操作方式。其一般形式如下:
[section1]
keyword1=valuel
keyword2=value2
……
[section2]
keyword1=value1
keyword2=value2
……
其中，如果等号右边无任何内容(即value为空)，那就表示Windows应用程序已为该关键词指定了缺省值，如果在整个文件中找不到某个关键词(或整个一部分)，那同样表示为它们指定了缺省值。各个部分所出现的顺序是无关紧要的，在每一个部分里，各个关键词的顺序同样也无关紧要。
读写INI文件通常有两种方式:一是在Windows中用"记事本"(Notepad)对其进行编辑，比较简单，无需赘述;二是由Windows应用程序读写INI文件，通常是应用程序运行时读取INI文件中的信息，退出应用程序时保存用户对运行环境的某些修改。
关键词的值的类型多为字符串或整数型，应分两种情况读写。为了使程序具有可维护性和可移植性，最好把对INI文件的读写封装在一个模块(RWINI.BAS)中，在RWI-NI.BAS中构造GetIniS和GetIniN函数以及SetIniS和Se-tIniN过程，在这些函数和过程中需要使用WindowsAPI的"GetPrivateprofileString"、"GetPrivateProfileInt"和"WritePrivateProfileString"函数。
RWINI.BAS模块的程序代码如下:
在General-Declearation部分中声明使用到的WindowsAPI函数:
Declare Function GetprivateprofileString Lib"Ker-nel"(ByVallpAppName As String，ByVallpKeyName As String，ByVallpDefault As String，ByVal lpRetrm-String As String，ByVal cbReturnString As Integer，ByVal Filename As String)As Integer
Declare FunctionGetPrivatePfileInt Lib "Kernel"(ByVal lpAppName As String，ByVal lpKeyName As String，ByVal lpDefault As Integer，ByVal Filename As String)As Integer
Declare FuncitonWritePrivateprofileString Lib "Kernel"(ByVal lpApplicationName As String，ByVal lpKeyName As String，ByVal lpString As String，ByVal lplFileName As String)As Integer
Function GetIniS(ByVal SectionName As String，ByVal KeyWord As String，ByVal DefString As String)As String
Dim ResultString As String * 144，Temp As Integer
Dims As String，i As Integer
Temp%=GetPrivateProfileString(SectionName，KeyWord，""，ResultString，144，AppProfileName())
'检索关键词的值
IfTemp%＞0Then'关键词的值不为空
s=""
Fori=1To144
IfAsc(Mid$(ResultString，I，1))=0Then
ExitFor
Else
s=s&Mid$(ResultString，I，1)
EndIf
Next
Else
Temp%=WritePrivateProfilesString(sectionname，KeyWord，DefString，ppProfileName())
'将缺省值写入INI文件
s=DefString
EndIf
GetIniS=s
EndFunction
FunctionGetIniN(ByValSectionNameAsString，ByValKeyWordAsString，ByValDefValue
AsIneger)AsInteger
DimdAsLong，sAsString
d=DefValue
GetIniN=GetPrivateProfileInt(SectionName，
KeyWord，DefValue，ppProfileName())
Ifd＜＞DefValueThen
s=""&d
d=WritePrivateProfileString(SectionName，
KeyWord，s，AppProfileName())
EndIf
EndFunction
SubSetIniS(ByValSectionNameAsString，BtVaKeyWordAsString，ByValValStr
AsString)
Dimres%
res%=WritePrivateprofileString(SectionName，KeyWord，ValStr，AppProfileName())
EndSub
SubSetIniN(ByValSectionNameAsString，ByValKeyWordAsString，ByValValInt
AsInteger)
Dimres%，s$
s$=Str$(ValInt)
res%=WriteprivateProfileString(SectionName，KeyWord，s$，AppProfileName())
EndSub
SectionName为每一部分的标题，KeyWord为关键词，GetIniS和GetIniN中的DefValue为关键词的缺省值，SetIniS和SetIniN的ValStr和ValInt为要写入INI文件的关键词的值。为了能更好地说明如何使用以上函数和过程，下面举两个实例。
实例1:
开发应用程序通常要使用数据库和其它一些文件，这些文件的目录(包括路径和文件名)不应在程序中固定，而是保存在INI文件中，程序运行时由INI文件中读入。读入数据库文件的代码如下:
DimDatabasenameAsString
Databasename=GetIniS("数据库"，"职工"，"")
IfDatabaseName=""ThenDatabaseName=InputBox("请输入数据库《职工》的目录")，
App.Title)’也可通过"文件对话框"进行选择
OnErrorResumeNext
Setdb=OpenDatabas(DatabaseName)
IfErr＜＞0Then
MsgBox"打开数据库失败!"，MB-
ICONSTOP，App.Title:GotoErrorProcessing
Else
SetIniS"数据库"，"职工"，DatabaseName
EndIf
OnErrorGoTo0
……
实例2:
为了方便用户操作，有时需要保存用户界面的某些信息，例如窗口的高度和宽度等。装载窗体时，从INI文件中读入窗体高度和宽度，卸载窗体时将窗体当前高度和宽度存入INI文件，代码如下:
Sub Form1_Load()
……
Forml.Height=GetIniN("窗体1"，"高度"，6000)
Form1.Width=GetIniN("窗体1"，"高度"，4500)
EndSub
……
Sub Form1_Unload()
……
SetIniN"窗体1"，"高度"，Me.Height
SetIniN"窗体1，"宽度"，Me.Width
……
End Sub
7、程序中如何启动默认的拨号连接
随着因特网的迅猛发展，现在编程常需要在程序中直接联网来处理一些事项，如在线注册和在线帮助，这就要求我们要在程序中建立某些连接。很多软件在不知用户是否联网的情况下不管三七二十一就启动浏览器查找网址，费了九牛二虎之力只能查出一错误页来（当然不可能有什么好的结果）。如果我们在程序编写时能自动判断用户是否已经联网，如已经联网则打开联接，如没有则启动默认的拨号连接，这样是不是让人觉得你的软件更胜人一处呢？判断是否已联网很多地方都有介绍，这里我们只介绍如何启动默认的拨号连接。
---- 在介绍之前让我们首先看看如何打开拨号网络。由于拨号网络不是一个可执行文件，所以不能用 “Shell 可执行文件”的方式来打开。要启动拨号网络，需借助 Explorer ，方法如下：
Shell "Explorer ::{20D04FE0-3AEA-1069-A2D8-08002B30309D}/" & "::{992CFFA0-F557-101A-88EC-00DD010CCC48}", vbNormalFocus
---- 但若是要启动拨号网络中的某一个连接，则需借助rundll.exe 及 rnaui.dll来启动，方法如下（假定连接名称为163）：
Shell "rundll rnaui.dll,RnaDial 163", vbNormalFocus
---- 说明：在以上叙述中，“,RnaDial 163”这部分不要插入额外的空格，大小写也不要任意更改。
---- 上面仅仅假定了连接名称，但实际编程中我们是不知道其名称的，如何取得默认的连接名称并启动它呢？这里我们可利用注册表来达到目的。完整程序如下：
---- 在窗体上放置一个命令按钮（名称为 cmdCallConnect)，下面为代码部份：
Option Explicit
'有关注册的API声明
Private Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, 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 szData As String, ByRef lpcbData As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long
'常数
Const HKEY_CURRENT_USER = &H80000001
Const ERROR_SUCCESS = 0&
Private Sub cmdCallConnect_Click()
'启动默认拨号连接
Shell "rundll rnaui.dll,RnaDial " + GetConnect, vbNormalFocus
End Sub
Public Function GetConnect() As String
Dim hKey As Long
Dim SubKey As String
hKey = HKEY_CURRENT_USER '主键
SubKey = "RemoteAccess" '子键
'取得默认连接名
GetConnect = GetRegValue(hKey, SubKey, "Default")
End Function
Public Function GetRegValue(hKey As Long, lpszSubKey As String, szKey As String) As Variant
On Error GoTo ErrorRoutineErr:
Dim phkResult As Long
Dim lResult As Long
Dim szBuffer As String
Dim lBuffSize As Long
'创建缓冲区
szBuffer = Space(255)
lBuffSize = Len(szBuffer)
'打开注册键
RegOpenKeyEx hKey, lpszSubKey, 0, 1, phkResult
'查询结果
lResult = RegQueryValueEx(phkResult,szKey, 0, 0, szBuffer,lBuffSize)
'关闭注册键
RegCloseKey phkResult
'返回结果
If lResult = ERROR_SUCCESS Then
GetRegValue = Left(szBuffer, lBuffSize - 1)
Else
GetRegValue = ""
End If
Exit Function
ErrorRoutineErr:
GetRegValue = ""
End Function
以上程序在 WIN98,VB6.0 下调试通过。
8、如何通过VB获取网卡地址
[功能描述] IPX和NETBIOS接口需要网络地址。该文通过详细的步骤演示了如何通过VB获取网卡地址。
步骤：
1)在Visual Basic生成标准的EXE文件。缺省创建 Form1。
2)在Form1中添加一命令按钮，缺省名为Command1。
3)把下列代码放到Form1中说明部分。
Option Explicit
Private Const NCBASTAT = &H33
Private Const NCBNAMSZ = 16
Private Const HEAP_ZERO_MEMORY = &H8
Private Const HEAP_GENERATE_EXCEPTIONS = &H4
Private Const NCBRESET = &H32
Private Type NCB
　　ncb_command As Byte 'Integer
　　ncb_retcode As Byte 'Integer
　　ncb_lsn As Byte 'Integer
　　ncb_num As Byte ' Integer
　　ncb_buffer As Long 'String
　　ncb_length As Integer
　　ncb_callname As String * NCBNAMSZ
　　ncb_name As String * NCBNAMSZ
　　ncb_rto As Byte 'Integer
　　ncb_sto As Byte ' Integer
　　ncb_post As Long
　　ncb_lana_num As Byte 'Integer
　　ncb_cmd_cplt As Byte 'Integer
　　ncb_reserve(9) As Byte ' Reserved, must be 0
　　ncb_event As Long
End Type
Private Type ADAPTER_STATUS
　　adapter_address(5) As Byte 'As String * 6
　　rev_major As Byte 'Integer
　　reserved0 As Byte 'Integer
　　adapter_type As Byte 'Integer
　　rev_minor As Byte 'Integer
　　duration As Integer
　　frmr_recv As Integer
　　frmr_xmit As Integer
　　iframe_recv_err As Integer
　　xmit_aborts As Integer
　　xmit_success As Long
　　recv_success As Long
　　iframe_xmit_err As Integer
　　recv_buff_unavail As Integer
　　t1_timeouts As Integer
　　ti_timeouts As Integer
　　Reserved1 As Long
　　free_ncbs As Integer
　　max_cfg_ncbs As Integer
　　max_ncbs As Integer
　　xmit_buf_unavail As Integer
　　max_dgram_size As Integer
　　pending_sess As Integer
　　max_cfg_sess As Integer
　　max_sess As Integer
　　max_sess_pkt_size As Integer
　　name_count As Integer
End Type
Private Type NAME_BUFFER
　　name As String * NCBNAMSZ
　　name_num As Integer
　　name_flags As Integer
End Type
Private Type ASTAT
　　adapt As ADAPTER_STATUS
　　NameBuff(30) As NAME_BUFFER
End Type
Private Declare Function Netbios Lib "netapi32.dll" (pncb As NCB) As Byte
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
Private Declare Function GetProcessHeap Lib "kernel32" () As Long
Private Declare Function HeapAlloc Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function HeapFree Lib "kernel32" (ByVal hHeap As Long,ByVal dwFlags As Long, lpMem As Any) As Long
把下面的代码放入Command1_Click的事件中：
Private Sub Command1_Click()
　　Dim myNcb As NCB
　　Dim bRet As Byte
　　myNcb.ncb_command = NCBRESET
　　bRet = Netbios(myNcb)
　　myNcb.ncb_command = NCBASTAT
　　myNcb.ncb_lana_num = 0
　　myNcb.ncb_callname = "*　　　　　　 "
　　Dim myASTAT As ASTAT, tempASTAT As ASTAT
　　Dim pASTAT As Long
　　myNcb.ncb_length = Len(myASTAT)
　　Debug.Print Err.LastDllError
　　pASTAT = HeapAlloc(GetProcessHeap(), HEAP_GENERATE_EXCEPTIONS Or HEAP_ZERO_MEMORY, myNcb.ncb_length)
　　If pASTAT = 0 Then
　　　　Debug.Print "memory allcoation failed!"
　　　　Exit Sub
　　End If
　　myNcb.ncb_buffer = pASTAT
　　bRet = Netbios(myNcb)
　　Debug.Print Err.LastDllError
　　CopyMemory myASTAT, myNcb.ncb_buffer, Len(myASTAT)
　　MsgBox Hex(myASTAT.adapt.adapter_address(0)) & " " & Hex(myASTAT.adapt.adapter_address(1)) _
　　　　& " " & Hex(myASTAT.adapt.adapter_address(2)) & " " _
　　　　& Hex(myASTAT.adapt.adapter_address(3)) _
　　　　& " " & Hex(myASTAT.adapt.adapter_address(4)) & " " _
　　　　& Hex(myASTAT.adapt.adapter_address(5))
　　HeapFree GetProcessHeap(), 0, pASTAT
End Sub
4)按F5，运行该程序。
5)点击Command1。注意，网卡地址将在一信息框中显示出来。
9、如何使用 ADO 來压缩或修复 Microsoft Access 文件
以前使用 DAO 時，Microsoft 有提供 CompactDatabase Method 來压缩 Microsoft Access 文件，RepairDatabase Method 來修复损坏的 Microsoft Access 文件，。可是自从 ADO 出來之后，好像忘了提供相对的压缩及修复 Microsoft Access 文件的功能。
現在 Microsoft 发现了这个问题了，也提供了解決方法，不过有版本上的限制！限制說明如下：
ActiveX Data Objects (ADO), version 2.1
Microsoft OLE DB Provider for Jet, version 4.0
這是 Microsoft 提出的 ADO 的延伸功能：Microsoft Jet OLE DB Provider and Replication Objects (JRO)
这个功能在 JET OLE DB Provider version 4.0 (Msjetoledb40.dll) 及 JRO version 2.1 (Msjro.dll) 中第一次被提出！
這些必要的 DLL 文件在您安裝了 MDAC 2.1 之后就有了，您可以在以下的网页中下载 MDAC 的最新版本！
Universal Data Access Web Site
在下载之前先到 VB6 中檢查一下，【控件】【設定引用項目】中的 Microsoft Jet and Replication Objects X.X library 如果已经是 2.1 以上的版本，您就可以不用下载了！
在您安裝了 MDAC 2.1 或以上的版本之后，您就可以使用 ADO 來压缩或修复 Microsoft Access 文件，下面的步骤告訴您如何使用 CompactDatabase Method 來压缩 Microsoft Access 文件：
1、新建一個新表单，选择功能表中的【控件】【設定引用項目】。
2、加入 Microsoft Jet and Replication Objects X.X library，其中 ( X.X 大于或等于 2.1 )。
3、在适当的地方加入以下的程序代码，記得要修改 data source 的內容及目地文件的路径：
Dim jro As jro.JetEngine
Set jro = New jro.JetEngine
jro.CompactDatabase "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=d://nwind2.mdb", _ '來源文件
"Provider=Microsoft.Jet.OLEDB.4.0;Data Source=d://abbc2.mdb;Jet OLEDB:Engine Type=4" '目的文件
在 DAO 3.60 之后，RepairDatabase Method 已经无法使用了，以上的程序代码显示了 ADO CompactDatabase Method 的用法，而它也取代了 DAO 3.5 時的 RepairDatabase method！
10、如何设置对VB数据库连接的动态路径
我个人因为经常作一些数据库方面的程序，对于程序间如何与数据库进行接口的问题之烦是深有体会，因为VB在数据库链接的时候，一般是静态，即数据库存放的路径是固定的，如用VB的DATA，adodc,DataEnvironment 等到作数据库链接时，如果存放数据库的路径被改变的话，就会找不到路经，真是一个特别烦的事。
笔者的解决方法是利用app.path 来解决这个问题。
一、用data控件进行数据库链接，可以这样：
在form_load()过程中放入：
private form_load()
Dim str As String '定义
str = App.Path
If Right(str, 1) <> "/" Then
str = str + "/"
End If
data1.databasename=str & "/数据库名"
data1.recordsource="数据表名"
data1.refresh
sub end
这几句话的意为，打开当前程序运行的目录下的数据库。
你只要保证你的数据库在你程序所在的目录之下就行了。
二、利用adodc（ADO Data Control)进行数据库链接：
private form_load ()
Dim str As String '定义
str = App.Path
If Right(str, 1) <> "/" Then
str = str + "/"
End If
str = "Provider=Microsoft.Jet.OLEDB.3.51;Persist Security Info=False;Data Source=" & str & "/tsl.mdb"
Adodc1.ConnectionString = str
Adodc1.CommandType = adCmdText
Adodc1.RecordSource = "select * from table3"
Adodc1.Refresh
end sub
三、利用DataEnvironment进行数据库链接
可在过程中放入：
On Error Resume Next
If DataEnvironment1.rsCommand1.State <> adStateClosed Then
DataEnvironment1.rsCommand1.Close '如果打开，则关闭
End If
'i = InputBox("请输入友人编号:", "输入")
'If i = "" Then Exit Sub
DataEnvironment1.Connection1.Open App.Path & "/userdatabase/tsl.mdb"
DataEnvironment1.rsCommand1.Open "select * from table3 where 编号='" & i & "'"
'Set DataReport2.DataSource = DataEnvironment1
'DataReport2.DataMember = "command1"
'DataReport2.show
end sub
四、利用ADO(ActiveX Data Objects)进行编程：
建立连接：
dim conn as new adodb.connection
dim rs as new adodb.recordset
dim str
str = App.Path
If Right(str, 1) <> "/" Then
str = str + "/"
End If
str = "Provider=Microsoft.Jet.OLEDB.3.51;Persist Security Info=False;Data Source=" & str & "/tsl.mdb"
conn.open str
rs.cursorlocation=aduseclient
rs.open "数据表名",conn,adopenkeyset.adlockpessimistic
用完之后关闭数据库：
conn.close
set conn=nothing
11、如何让用户自行输入方程式，并计算其结果？
假设我们要让使用者在“方程式”栏位中自由输入方程式，然后利用方程式进行计算，则引用ScriptControl控件可以很方便地做到。
( ScriptControl 控件附属于VB 6.0，如果安装后没有看到此一控件，可在光盘的 /Common/Tools/VB/Script 目录底下找此一控件，其.文件名为Msscript.ocx。) 假设放在窗体上的ScriptControl控件名称为ScriptControl1，则在“计算”按钮的Click事件中编写如下代码： Dim Statement As String Statement = "X=" + Text1.Text + vbCrLf + _ "Y=" + Text2.Text + vbCrLf + _ "MsgBox ""计算结果="" & Y " ScriptControl1.ExecuteStatement( Statement )
12、如何解决VB中的Grid控件的打印问题
---- Grid 控件是Visual Basic最常见控件之一，从VB3.0 到VB5.0 都有该控件。也是VB爱好者最喜爱的工具之一。用它可以以表格的形式显示、浏览数据，特别是数据库应用，直接绑定即可显示浏览数据库信息。然而，美中不足的是Grid 没有编辑和打印功能，列与列的位置不能相互交换。笔者曾尝试着给Grid 增添了这些功能，使之锦上添花，功能更强大。下面给出改进方法及源程序，读者只需按步骤写下源程序即可使你的Grid 具有打印功能。该程序笔者在HP5/100Window95环境下用VB5.0 调试通过。
---- 给Grid 控件增加打印方法有三种：1 是直接打印控件的方法，2 是通过 printer 来实现打印功能，3 是通过调用MS-WORD 及MS-EXCEl 来实现打印。
---- 首先，打开一个应用，在FORM1中增加DATA 控件DATA1,把DATA1的CONNECT 属性设为dBASE III，再把DATABASENAME属性设为D:/PJXM.DBF。然后再在FORM1中增加MSFLEXGRID空间GRID1，并把GRID1的DATASOURCE 属性设为DATA1。这样数据库PJXM.DBF 的信息就会在GRID1中显示出来。
---- 方法一：直接打印窗体法，在FORM1中增加命令按钮(command)，CAPTION属性设为直接打印，再写入下列编码：
Sub command_click
Form1.printform
End sub
---- 这样即可通过打印窗体FORM1的方法把GRID1的数据打印出来，遗憾的是只能打印GRID1中显示的数据部分，显示不出来的则无法打印，而且这种打印方法很象屏幕硬拷贝把其他控件也打印出来。也不能灵活的控制字体等。
---- 方法二：通过PRINTER实现打印。这种方法
---- 1、加入打印命令按钮(command1)、函数(print1)即可实现打印功能，写入下面代码，读者稍加改动可写成标准的函数或过程。
Function prnt1 (x As Integer, y As Integer,
font As Single, txt As String)
printer.CurrentX = x
printer.CurrentY = y
printer.FontBold = False
printer.FontSize = font
printer.Print txt
End Function
Sub command1_click
Dim fnt As Single
Dim pp as integer
Pp=0'设置开始页码0
Dim stry,strx,strx1,stry1,linw,page1,p As Integer
Static a(8) As Integer'定义打印的列数
ss$ = "内部结算存入款对帐单"'定义表头
kan = 0
For i = 0 To 8
a(i) = 1500'定义每列宽
kan = kan + a(i)'计算表格总宽度
Next
page1 = 50'定义每页行数
strx = 200
strx1 = 200'定义X方向起始位置
stry = 1400
stry1 = 1400'定义Y方向起始位置
linw = 240'定义行宽
fnt = 8'定义字体大小
printer.fontname = "宋体"'定义字体
dd = prnt1(4000, 700, 18, ss$)'打印标题
printer.Line (strx - 50, stry - 30)
-(strx + kan - 10, stry - 30)
For j = 0 To gridrow - 1'gridrow为所要打印的行数
grid1.row = j
strx = strx1
printer.Line (strx - 50, stry - 30)
-(strx + kan - 10, stry - 30)
p = p + 1
For i = 0 To 8
grid1.col = i
dd = prnt1(strx, stry, fnt, grid1.text)
strx = strx + a(i)
Next
If p > page1 Then'next page
p = 0
strx = strx1
'line last line
printer.Line (strx - 50, stry + linw)
-(strx + kan - 10, stry + linw)
stry = stry1
'line col
For n = 0 To 8
printer.Line (strx - 30, stry - 30)
-(strx - 30, stry + (page1 + 2) * linw)
strx = strx + a(n)
Next
printer.Line (strx - 30, stry - 30)
-(strx - 30, stry + (page1 + 2) * linw)
pp=pp+1
foot$="第 "+cstr(pp)+"页"
dd = prnt1(strx - 30-1000, stry + (page1 + 2)
* linw+100, 10, foot$)'打印页角码
printer.NewPage'next page
dd = prnt1(4000, 700, 18, ss$) '打印标题
strx = strx1
stry = stry1
printer.Line (strx - 50, stry - 30)-
(strx + kan - 10, stry - 30)' print first row
Else
stry = stry + linw
End If
Next
st = stry
If p < page1 Then '在最后页剩余划空行
For o = p To page1 + 1
strx = strx1
printer.Line (strx - 50, stry - 30)
-(strx + kan - 10, stry - 30)
stry = stry + linw
Next
End If
stry = stry1
strx = strx1
stry = stry1 'line col
For n = 0 To 8
printer.Line (strx - 30, stry - 30)-
(strx - 30, stry + (page1 + 2) * linw)
strx = strx + a(n)
Next
printer.Line (strx - 30, stry - 30)-
(strx - 30, stry + (page1 + 2) * linw)
pp=pp+1
foot$="第 "+cstr(pp)+"页"
dd = prnt1(strx - 30-1000, stry + (page1 + 2)
* linw+100, 10, foot$)'打印页角码
printer.EndDoc'打印结束
Endsub
---- 这种方法通过灵活的编程可以方便地调整字体、字型、线形、页面、纸张大小等。可打印出比较满意的效果。如果你的计算机上装有MICROSOFT WORD 和MICRO EXCEL，最精彩的用法还是把GRID 的表格通过VB发送到MICROSOFT WORD 及MICRO EXCEL。生成MICROSOFT WORD 和MICRO EXCEL 表格。这样就可以充分利用MICROSOFT WORD 和MICRO EXCEL的打印、编辑功能打印出更理想的效果。下面逐一介绍。
---- 方法三：通过生成MICROSOFT WORD表格打印
---- 1、在declaration 中写入: Dim msword As Object
---- 2、加入打印命令按钮(command2)，CAPTION 设为"生成WORD 表格"，写入下面代码，
Private Sub command2_Click()
screen.MousePointer = 11
Set msword = CreateObject("word.basic")
Dim AppID, ReturnValue
appID = Shell("d:/office97/office/WINWORD.EXE", 1)
' Run Microsoft Word.
msword.AppActivate "Microsoft Word"
'msword.AppActivate "Microsoft Word", 1
full
Screen.MousePointer = 0
End Sub
---- 2、写入以下过程full()
Sub full()
Dim i As Integer, j As Integer,
col As Integer, row As Integer
Dim cellcontent As String
Me.Hide
cols = 4'表格的列数
row = gridrow'打印表的行数
msword.filenewdefault
msword.MsgBox "正在建立MS_WORD报表，
请稍候.......", "", -1
msword.leftpara
msword.screenupdating 0
msword.tableinserttable , col, row, , , 16, 167
msword.startofdocument
for j=0 to gridrow' 表格的行数
grid1.row=j
For i = 1 To cols
Gri1d.col=i
If IsNull(grid1.text) Then
cellcontent$ = ""
Else
cellcontent$ = grid1.text
End If
msword.Insert cellcontent$
msword.nextcell
Next i
Next j
msword.tabledeleterow
msword.startofdocument
msword.tableselectrow
msword.tableheadings 1
msword.centerpara
'msword.startdocument
msword.screenrefresh
msword.screenupdating 1
msword.MsgBox " 结束", "", -1
Me.Show
End Sub
---- 方法四：通过发送到MICROSOFT EXCEL实现表格打印
---- 1、加入打印命令按钮(command3)，CAPTION 设为"生成EXCEL 表格"，写入下面代码
Private Sub command3_Click()
Dim i As Integer
Dim j As Integer
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
'Set xlBook = xlApp.Workbooks.Add
'On Error Resume Next
Set xlBook = xlApp.Workbooks.Add 'Open("d:/text2.xls")
Set xlSheet = xlBook.Worksheets(1)
xlSheet.Cells(6, 1) = "i"
For i = 0 To gridrow
grid1.Row = i
For j = 0 To 6
Grid1.Col = j
If IsNull(Grid1.Text) = False Then
xlSheet.Cells(i + 5, j + 1) = Grid1.Text
End If
Next j
Next i
Exit Sub
13、如何在VB中实现绘图区的大十字光标
有时，我们需要用VB快速开发一个试验数据绘图处理程序，将绘图控件内的鼠标光标改变成与AutoCAD软件中使用的大十字光标的形式，将可以比普通的箭头光标达到更好的效果。那么我们如何实现这样的大十字光标呢？
---- 首先，我们明确一下要达到的效果，假若我们在一个Picture控件中绘图，那么，鼠标移动到这个控件上时，鼠标光标立即改变为大十字形状，光标中的横线从控件的左边界到右边界，竖线从控件的上边界到下边界，即大十字光标将绘图控件分割为四个象限。当鼠标移动到控件外时，光标则又恢复成原来的形式。
---- 要实现这样的光标，得我们自己通过画线的方式实现。如鼠标在绘图控件内，先在鼠标的当前位置画上光标的横线和竖线；当鼠标位置移动，先擦除原先的光标横线和竖线，然后再在新的位置画光标的横线和竖线，那么我们就要响应绘图控件的MouseMove事件。当然，绘图控件内无论有什么内容，我们擦除光标线和重画光标线时都不能破坏原先的内容，因此我们要将绘图控件的DrawMode设置为vbXorPen（异或方式），绘制光标的横线和竖线时，用异或的方式将横线和竖线的象素点颜色设为光标的颜色和原先的象素点色彩的异或值，再用异或的方式在同样的位置绘制一遍竖线和横线，横线和竖线上的象素点再一次和光标颜色进行异或操作，就擦除了光标的横线和竖线，且又恢复了绘图控件内原先的内容。
---- 我们还得保证鼠标移动到绘图控件内时，普通的鼠标光标消失，只有绘制的大十字光标出现，因此还应该设置绘图控件的MousePointer属性为vbCuntom，即用户自定义。绘图控件的MousePointer属性设置为vbCustom后，其MouseIcon属性中应装入相应的用户自定义图形，因为我们希望绘图控件内只有我们绘制的光标，而没有其它的光标，故应该装入一个空的（透明的）光标图形。可以任找一个光标文件，通过任意一个资源编辑器对其进行编辑，用透明的方式填充整个光标图形，保存成我们所需的NoIcon.cur即可。
---- 通过以上的关键设置和操作，我们就可以实现大十字光标了。利用异或方式进行绘图，我们还可以实现一般绘图软件中常有的“橡皮筋”效果，即用鼠标定义一个点后，动态拖动鼠标来定义另外一个点，动态拖动鼠标过程中，所要绘的图形也动态相应变化。
---- 以下我们通过一个示例来完整实现绘图控件中的大十字光标，还演示如何实现用“橡皮筋”效果来画矩形：
---- 在VB中新建一个标准EXE工程，在Form1中加入一个Picture控件，其Name设为PicDraw，可以装入一个图象文件，PicDraw的大小和其中的图象大小基本上覆盖大部分的Form1即可。实现代码如下所示。此程序在VB5.0中运行通过。
Option Explicit
Private Old_X As Single
Private Old_Y As Single
Private isMouseDown As Boolean
Private Box_X0 As Single
Private Box_Y0 As Single
Private Box_X1 As Single
Private Box_Y1 As Single
Private PenColor As Long
Private CrossColor As Long
Private Sub Form_Load()
CrossColor = QBColor(8)
PenColor = QBColor(15)
picDraw.DrawMode = vbXorPen
picDraw.MouseIcon = LoadPicture
(App.Path & "/no.cur")
picDraw.MousePointer = vbCustom
isMouseDown = False
Box_X0 = Box_X1 = Box_Y0 = Box_Y1 = 0
End Sub
Private Sub picDraw_MouseDown
(Button As Integer,
Shift As Integer, X As Single, Y As Single)
If isMouseDown = True Then
'先前已经用鼠标定义了一个点
Box_X1 = X
Box_Y1 = Y
isMouseDown = False
picDraw.DrawMode = vbCopyPen
picDraw.Line (Box_X0, Box_Y0)-
(Box_X1, Box_Y1),
PenColor, B
picDraw.DrawMode = vbXorPen
'画一个光标
picDraw.Line (0, Y)-(picDraw.ScaleWidth, Y),
CrossColor
picDraw.Line (X, 0)-(X, picDraw.ScaleHeight),
CrossColor
Old_X = X
Old_Y = Y
Else
'定义了一个矩形的第一个顶点，则擦除光标
picDraw.Line (0, Y)-(picDraw.ScaleWidth, Y),
CrossColor
picDraw.Line (X, 0)-(X, picDraw.ScaleHeight),
CrossColor
Box_X0 = X
Box_Y0 = Y
isMouseDown = True
End If
End Sub
Private Sub picDraw_MouseMove(Button As Integer,
Shift As Integer, X As Single, Y As Single)
If isMouseDown = True Then
'拖动鼠标来定义矩形的另外一个顶点，
此时擦除前一个矩形，绘制新的矩形
picDraw.Line (Box_X0, Box_Y0)-(Old_X, Old_Y),
PenColor, B
picDraw.Line (Box_X0, Box_Y0)-(X, Y), PenColor, B
Else
'消除旧光标线
picDraw.Line (0, Old_Y)-(picDraw.ScaleWidth, Old_Y),
CrossColor
picDraw.Line (Old_X, 0)-(Old_X, picDraw.ScaleHeight),
CrossColor
'画新的光标线
picDraw.Line (0, Y)-(picDraw.ScaleWidth, Y),
CrossColor
picDraw.Line (X, 0)-(X, picDraw.ScaleHeight),
CrossColor
End If
Old_X = X
Old_Y = Y
End Sub
14、如何充分扩充VB功能
Visual Basic for Windowss3.0（简称VB）是目前开发WINDOWS应用软件的最有效工具之一，它综合运用了BAIC语言和新的可视化设计工具，不仅功能强大，而且简单易学。其次，VB具有事件驱动的编程机制，它充分利用WINDOWS图形环境的特点，能让开发人员快速地构造强大的应用程序。
那么在开发VB应用软件时，如何充分地扩充VB的功能呢？这就要求在不同的层次上要很好地利用VB最具威力和特色的部分：
●在函数层调用动态链接库。
●在控件层使用VBX。●在应用层执行其他应用程序。
一、在函数层调用功能态链接库（DLL）
WINDOWS操作系统实际上是由许多功能强大的动态链接库（DLL）组合而成。VB考虑到有些工作超过自身语言所及的能力范围，所以提供了直接调用操作系统中这些DLL子程序的能力。例如：在正常情况下，窗口的控制菜单提供了七种功能：还原、移动、大小、最小化、最大化、关闭和切换。而在实际应用中，我们希望窗口按设计时的大小显示，不允许用户随意改变窗口大小，也不允许切换到其他窗口，这就要求在设计时必须删除控制菜单中除“移动”和“关闭”选项以外的所有控制菜单项。要完成这一任务，我们首先可把窗体的MaxButton属性和MinButton属性设置为False，不允许窗体最小化和最大化，窗体也就不能还原。然后再把窗体的BorderSstyle属性设置为1－Fixed Single或3－Fixed Double，不允许窗体改变大小。但VB本身却无法删除“切换”选项和两条分隔线。幸运的是，通过调用WINDOWS DLL就很容易做到。
通常，要使用WINDOWS DLL，首先必须说明要使用的DLL子程序，我们可在两个地方说明所使用的DLL子程序，即在全局模块中说明，或者在窗体层的说明部分中说明。其格式是：
Declare Sub子程序名Lib“库名”［Alias“别名”］［（［参数］）］
Declare Function子程序名Lib“库名”［Aliass“别名”］［（［参数］）］［AS数据类型］
第一种格式表示过程没有返回值，第二种格式表示过程返回一个值，该值可用于表达式中，库名如果用的是WINDOWS操作环境（在System目录下）中的库，如“USER.EXE”，“KERNEL.EXE”或者“GDI.EXE”等，就用此名作为库名。如果用的是其他来源的DLL，则用包括路径的文件名称（如：“C：＼WINDOWS＼BRUSH.DLL”）。别名（Alias）是允许另外使用别的名称来称呼子程序，尤其是当外来子程序名与VB保留字相同时，它就显得特别有用，参数指要被传递到子程序的参数值，数据类型指的是函数返回值的数据类型，它可能是Integer，Long，Single，Double，Currency或String。下面就是所要使用的DLL子程序的说明：
Declare Function GetSystemMenu％ Lib＂User＂（ByValhWnd％，ByValbRevert％）
Declare ＼function ＼RemoveMenu％ Lib＂User＂（ByValhMenu％，ByValnPosition％，ByValwFlags％）
当说明完DLL子程序后，执行DLL子程序的方法，就象在VB中执行通用过程（函数）一样。下面我们编写一个名为Remove－Items－From－System的过程来完成上面例子中提到的功能，过程中调用了上述说明过的两个DLL子程序：
Sub remove－Items－From－Sysmenu（A－Form As Form）
'获取窗体系统菜单句炳
HSysMenu＝GetSystemMenu（A－Form.hWnd，0）
'删除除“移动”和“关闭”外的所有菜单项，删除时必须从最后一个菜单项开始
R＝RemoveMenu（HSysMenu，8，MF－BYPOSITION） '删除切换
R＝RemoveMenu（HSysMenu，7，MF－BYPOSITION） '删除第一条分隔线
R＝RemoveMenu（HSysMenu，5，MF－BYPOSITION） '删除第二条分隔线
End Sub
有了这个过程，在任一窗体的Form－Load事件中加入下面一行代码就可以删除该窗体除“移动”和“关闭”选项以外的所有控制菜单项：
Remove－Items－From－Sysmenu Me
二、在控件层使用VBX
VB功能强大的第二个部分是VBX的使用，即其开放及无限扩增的特性。虽然VB工具箱（ToolBox）已经尽量将设计应用软件所需的工具包括在内，但是，为了不断扩充VB的功能，VB提供了一套开发工具（Custom Control Development Kit）供第三方开发者来设计所需要的控件。当设计完控件文件后（其文件扩展名为“.VBX”）可以从菜单“file”项下选“Add File...”命令，结果画面上出现一个＂Add File＂对话框，双击所需的VBX文件名即可将该VBX加入到VB中，这些控件装入VB后，VB会将这些外来控件加到原有工具箱中，与其他控件一起合并使用。正是因为有了这一技术，VB才能够不断发展，使用VB编程也更为方便、迅速和有效，这是VB区别于其他程序开发环境的主要特色之一。自从VB推出以来，第三方软件公司设计了大量的新控件，下面是开发WINDOWS应用程序时几个非常有用的VBX：
●三维控件Threed.vbx
它提供了包括命令按钮、复选框、单选钮、框架、下推按钮和面板在内的六种三维控件，使用这些控件可使窗体更具有立体感。
●图形控件Graph.vbx
向图形控件发送数据后，图形控件可绘制二维或三维饼图，、直方图、趋势图，并且可以打印或拷贝到剪贴板上。
●通讯控件Mscomm.vbx
它提供了串行通讯的能力，可用于串行端口之间传送和接收数据。
●数据网格控件Truegrid.vbx
它既可以作为一般的数据显示表格，也可把一个数据库和一个网格联系起来，它是制作数据库浏览器或数据显示的理想工具。
二、在应用层执行其他应用程序
在编制复杂的大型软件时，我们经常会需要有一些功能相对独立和完善的专用程序，如编辑程序，而这些程序通常是通用和流行并经实践检验的。如果由开发者重新编制这些程序，不仅大大增加了程序工作量以及调试过程，而且功能上很难比得上这些通用程序。显然，如果我们能直接调用这些程序是最为理想的。令人欣喜的是，VB提供了一个可用来调用其他应用程序的Shell函数，使VB的某些功能可直接由其他应用程序来完成，从而大大地减少了编程任务。
格式是Shell（命令字符串［，窗口类型］）
其中的命令字符串是欲执行的应用程序名，可执行文件的扩展名只限于“.COM”，“.EXE”，“.BAT”，“.PIF”，缺省扩展名为.EXE文件，窗口类型是一整数值，它对应于程序执行时的显示窗口风格，是可选的，共有下列5种选择：
窗口类型值
窗口类型 1，5，9
正常窗口，具有指针 2
最小窗口，具有指针（缺省） 3
最大窗口，具有指针 4，8
正常窗口，不具指针 6，7
最小窗口，不具指针
当Shell函数成功地调用某一个应用程序时，返回一个任务标识（Task ID），该ID表示正在执行的程序的唯一标识。
［例］
X＝Shell（"C：/WINDOWS/NOTEPAD.EXE",1）
该语句调用WINDOWS附件中的记事本NOTEPAD.EXE作为编辑程序来使用，并返回1个ID值到X。
15、成组更新控件属性
Sub EnableAll(Enabled As Boolean, ParamArray objs() As Variant)
Dim obj As Variant
For Each obj In objs
obj.Enabled = Enabled
Next obj
End Sub
应用：
EnableAll True, Text1, Text2, Command1, Command2
VB问题全功略（4） [查找本页请按Ctrl+F]
［上一页］（4）［下一页］
16、如何避免程式重复执行？（侦测是否存在前一副本，若有，则结束目前新启动的程式）
17、如何让一个 App 永远保持在最上层 ( Always on Top )
18、表单配置视窗和解析度
19、连续变量的声明 Dim a, b, c as string * 4
20、正确的除错 (Debug) 方式
16、如何避免程式重复执行？（侦测是否存在前一副本，若有，则结束目前新启动的程式）
使用者在启动程式后，有时会将程式缩小在工作列上，之后要用时，又会重新启动一次程式，资料库程式有时会因此造成资料错乱！若您不希望使用者重复启动程式，您可以使用 APP 物件来判断，方法如下：
Private Sub Form_Load()
If App.PrevInstance Then '检视前一版本
MsgBox "此程式已经在执行中！", 48
End
End If
End Sub
17、如何让一个 App 永远保持在最上层 ( Always on Top )
请在声明区中加入以下声明
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 SWP_NOMOVE = &H2 '不更动目前视窗位置
Const SWP_NOSIZE = &H1 '不更动目前视窗大小
Const HWND_TOPMOST = -1 '设定为最上层
Const HWND_NOTOPMOST = -2 '取消最上层设定
Const FLAGS = SWP_NOMOVE Or SWP_NOSIZE
'将 APP 视窗设定成永远保持在最上层
SetWindowPos Me.hwnd, HWND_TOPMOST, 0, 0, 0, 0, FLAGS
'取消最上层设定
SetWindowPos Me.hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, FLAGS
18、表单配置视窗和解析度
这个地方不是要告诉您如何写出一支程式，会自动根据使用者荧幕的解析度调整 Form 及各控制项的大小，也就是适用于各种解析度的程式。那是另一个主题！
由于我在集团式的公司资讯中心上班，在我的开发过程中，我的使用者依不同公司别，分成几个族群，有的公司都是使用 640x480 的解析度，有的都用 800x600，设计公司则是 1024x768，为了替这些公司开发软件，在 VB5.0 以前，写各家公司的程式以前就必须先调整荧幕的解析度 (否则在解析度 800x600 的电脑上开发的程式，在 640x480 解析度的电脑中执行时，右方和下方的画面会跑出荧幕外面)，有的电脑一改变解析度就必须重新开机，更是麻烦！
VB5.0 以后，VB 多提供了一个功能，就是【表单配置视窗】，从此以后，您可以在高解析度的荧幕中，开发低解析度的程式，要怎么做呢？《假设您的电脑解析度是 1024x768》
很简单！在【表单配置视窗】上的荧幕上按滑数右键，选择【解析度】。看到了吗！在【表单配置视窗】上的荧幕上，出现了二个虚线框，上面各标明了 640x480 及 800x600。好了！现在您可以开始开发各种不同解析度的系统了！
例如您要开发的系统，解析度是 640x480，您只要注意不要让您的表单超出 640x480 的虚线框就可以了！
19、连续变量的声明 Dim a, b, c as string * 4
我想声明 a,b,c 三个字串变量
Dim a, b, c as string * 4 (错的)
这样的声明在 VB 中，结果可能和您要的不同！
有些程式语言，例如 C，类似以上的声明表示三个字串变量。
但是在 VB 中却不是如此！
以上的声明在 VB 中表示声明了 a,b 2 个 variant (不定形态变量)，以及 c 这个字串变量。
要声明 a,b,c 三个字串变量，正确的写法如下：
Dim a as string * 4
Dim b as string * 4
Dim c as string * 4
若想写在同一行，也可以，写法如下：
Dim a as string * 4, b as string * 4, c as string * 4
20、正确的除错 (Debug) 方式
当程式执行起来怪怪的，很多人在除错 (Debug) 时，都喜欢在程式中使用中断点 (Break) 加上 MsgBox 来看执行结果，但有些时候，这样子的作法会造成某些事件 (Event) 无法触发，甚至改变事件原来触发的顺序！
比较正确的作法是在程式中使用 Debug.Print "事件名称/要显示的讯息" ，而不要用中断点 (Break)。
21、Move Method 速度较快
当我们要移动控制项 (Control) 或表单 (Form) 时，很多人习惯这样写：
frmCustomer.Left = frmCustomer.Left + 100
frmCustomer.Top = frmCustomer.Top + 50
但是若使用 Move Method ，可以加快 40%：
frmCustomer.Move frmCustomer.Left + 100, frmCustomer.Top + 50
22、哇！我的变量名称变成了保留字！
当我们升级 VB 的版本时，有时候会因为以前程序中使用的变量名称或函数名称变成了保留字，而使程序跑起来完全不正常，例如：
print：VB3 时不是保留字，但到了 VB4 却变成了保留字。
array：VB4 时不是保留字，但到了 VB5 却变成了保留字。
遇到这种情形，其实也很简单！只要在 VB 中叫出该工程，打开任何一个表单的程序码，选择【编辑功能表】中的【取代】，搜寻范围设定成【整个工程】，并将【全字拼写须符合】选项打勾，然后将该工程中该字串改成另一个新字串，再重新 Make 成执行档即可。
下一次您升级 VB 的版本时，若原来正常的程序跑起来变得怪怪的，别忘了检查一下您自己定义的变数名称或函数名称是否也变成了保留字！
23、快捷键 -- 找寻 Function/Subroutine
当您的 APP 愈来愈大时，或是您要维护别人开发的大系统时，是否曾经有过一种情形，程序中 call 了某一个 Function/Subroutine，您要找寻这个 Function/Subroutine，除了一个一个 Module 找之外，大部份的人都是使用【编辑功能表】的【搜寻】功能。
其实您可以使用【Shift + F2】快捷键！很简单，方法如下：
只要将鼠标停留在程序中该 Function/Subroutine Name 上，再使用【Shift + F2】快捷键即可！
24、我上一次程序写到那里呢？
有时候您会同时写几个不同的程序，或因为某种原因，程序停了一段时间，当您下一次要再继续写时，已经忘了上次写到那里了，其实有一个很简单的方法，可以马上唤起您的记忆！
在您在写程序中要停下时，先随便写一行注解，但是拿掉注解符号〈'〉后存档，下一次您载入工程后，马上使用【执行功能表】中的【全部编译后开始】，此时第一个错误的地方使是上次程序中断的地方！
25、不方便的 Msdn -- VB6.0 的 Help
很多 VB 程序设计师抱怨为了存取 VB6.0 的 Help，必须一直将 Msdn 光碟放在光碟机中，否则就必须安装 680MB 的 Help 到硬盘中！
其实还有一个比较人性化的方法，就是在安装 Msdn 时，选择【自订安装】，然后只要选择 Visual Basic 文件 (13792K) 即可。
如此您便可以直接由硬盘存取 VB 的相关主题，若您想看其他非 VB 主题，再由光碟存取。
VB问题全功略（6） [查找本页请按Ctrl+F]
［上一页］（6）［下一页］
26、如何快速设定 Form 上所有控制项的 TabIndex 顺序
27、Boolean 值的转换
28、呼叫子程序（Subroutine）
29、输入时，自动转换成大写？
30、输入时，自动转换成小写？
26、如何快速设定 Form 上所有控制项的 TabIndex 顺序
由于在设计 Form 上的控制项时，不一定会依照输入的顺序，在完成设计之后，我们通常会重设各控制项的 TabIndex 顺序，当 Form 上的控制项比较多时，设定起来相当麻烦，常常还会设错。
有一个很简单又不容易出错的方法，是从画面上的右下角往左上角 (方向是先向左再往上)，逐一的将控制项的 TabIndex 属性设成 0。
1：右手用滑鼠点一下右下角的控制项，左手按 F4，将 TabIndex 设成 0。
2：右手往左用滑鼠点一下倒数第二个控制项，左手按 F4，左手按 0。
3：右手往左用滑鼠点一下倒数第三个控制项，左手按 F4，左手按 0。
4：重复以上动作直到左上角第一个控制项为止。
好了，您已经设定好整个 Form 上所有控制项的 TabIndex 顺序了！其原理就是当您设定一个控制项的 TabIndex 为 0 时，原来 TabIndex 为 0 的控制项，TabIndex 就变成了 1、而 1 的变成 2...依序 +1 改变。
27、Boolean 值的转换
我们都知道 Boolean 这个资料形态只有 True/False 二种值，但是当我们要存到资料库时，我们常常会将它转成数值，您可以直接设定 True=-1 / False =0，若您必须使用函数转换，很可能会用 Val()，但是小心，其结果是错的！
您必须使用 Abs() 或 CInt()，为什么呢？看结果就知道了！
Val(True) 结果是 0
CInt(True) 结果是 -1
Abs(True) 结果是 1
28、呼叫子程序（Subroutine）
当我们呼叫子程序 (Subroutine) 时，有二种方法：
1、Call MyRoutine(参数)
2、MyRoutine 参数
注意第二个方法不可以使用括号 ()，否则 VB 会误认为是运算子，本来应该是传址 (Reference)，就会变成了传值 (Value)！看看以下的例子就知道了：
Call MyRoutine(Text1) 正确
意思是要将 Text1 这个控制项传入 MyRoutine 中，但是如果拿掉 Call 这个字，VB 传给 MyRoutine 的却变成了 Text1 的内含值了！也就是 Text1.text。
MyRoutine(Text1) 错误
MyRoutine 要的本来是一个控制项，结果却传入了一个字串，您会得到一个《type-mismatch / 资料型态不符》
29、输入时，自动转换成大写？
要自动转换大小写，很多人首先想到的一定是 UCase$ 及 LCase$，但是要使用这二个函数，一定不可以在 Key_Press 事件中使用，否则您若输入《abc》，结果却变成《CBA》，为什么呢？
因为当您输入 a 之后，UCase$ 会替您转换成 A，但是转换完后，滑鼠的游标会停在 A 的前面，您继续输入 b，变成了 bA，UCase$ 又替您转换成 BA，转换完后，滑鼠的游标又停在 BA 的前面，您继续输入 c，变成了 cBA，UCase$ 又替您转换成 CBA！　若您不相信，可以自己试试　
在 Key_Press 中正确的作法，是判断它的参数 KeyAscii ！a 的 Asc 值是 97，A 的 Asc 值是 65，所以要自动将小写转成大写，写法如下：
Private Sub Text2_KeyPress(KeyAscii As Integer)
If KeyAscii >= 97 And KeyAscii <= 122 Then
KeyAscii = KeyAscii - 32
End If
30、输入时，自动转换成小写？
要自动转换大小写，很多人首先想到的一定是 UCase$ 及 LCase$，但是要使用这二个函数，一定不可以在 Key_Press 事件中使用，否则您若输入《ABC》，结果却变成《cba》，为什么呢？
因为当您输入 A 之后，LCase$ 会替您转换成 a，但是转换完后，滑鼠的游标会停在 a 的前面，您继续输入 B，变成了 Ba，LCase$ 又替您转换成 ba，转换完后，滑鼠的游标又停在 ba 的前面，您继续输入 C，变成了 Cba，LCase$ 又替您转换成 cba！　若您不相信，可以自己试试　
在 Key_Press 中正确的作法，是判断它的参数 KeyAscii ！a 的 Asc 值是 97，A 的 Asc 值是 65，所以要自动将大写转成小写，写法如下：
Private Sub Text2_KeyPress(KeyAscii As Integer)
If KeyAscii >= 65 And KeyAscii <= 90 Then
KeyAscii = KeyAscii + 32
End If
VB问题全功略（7） [查找本页请按Ctrl+F]
［上一页］（7）［下一页］
31、某一天的下 (上) 一个星期几是那一天？
32、移除字串中不要的字元
33、通往 Internet 的捷径---捷径档的结构
34、Bug：维护 Internet Transfer Control 之 Username 及 Password
35、我要如何在程序中开启网页？
31、某一天的下 (上) 一个星期几是那一天？
参数 : 您相信吗？这个模组的写法比用任何其他的方法快几十倍！参数如下：
1：以那一天为基准日？
2：(Optional) 要找的是星期几？若不指定，预设值为星期六
3：(Optional) 要往前 (过去) 找或往后 (未来) 找？
若不指定，预设值为往后 (未来) 找
程序码
Public Function SpecificWeekday(ByVal D As Date, Optional ByVal WhatDay As VbDayOfWeek = vbSaturday, Optional GetNext As Boolean = True) As Date
SpecificWeekday = (((D - WhatDay + GetNext) / 7) - GetNext) * 7 + WhatDay
End Function
或许您想知道程序为什么这样写？
您知道吗？在 VB 中，其所有日期函数的基准日 (第0天) 是 1899年12月30日 (星期六)，第一天就是 1899年12月31日 (星期日)，所以 VB 的 WeekDay 函数算法其实就是 (Date - 1) Mod 7 + 1。
返回值
日期
实例 :
我想知道以下日子各是那一天？
上个星期一：SpecificWeekday(Now, vbMonday, False)
下个星期六：SpecificWeekday(Now)
2000年9月9日的下一个星期五：SpecificWeekday("09/09/2000", vbFriday)
32、移除字串中不要的字符
参数 : 1：要检查的字串 [准备移除其中某些字符]
2：要移除的字符 (数字/中英文)
程序码
Function StringCleaner(s As String, Search As String) As String
Dim i As Integer, res As String
res = s
Do While InStr(res, Search)
i = InStr(res, Search)
res = Left(res, i - 1) & Mid(res, i + 1)
Loop
StringCleaner = res
End Function
返回值移除某些字符后的字串
实例 :
我想移除 Text1 中的字符 "A"
Text1 = StringCleaner(Text1, "A")
33、通往 Internet 的捷径---捷径档的结构
有些软件 Setup 完后, 会在程序集或桌面上产生一个 "捷径" (ShortCut), 直接一点就可以进到特定的网页, 用 VB 要如何做才可以做到? 难吗?
不难!! 其实只要稍为观查一下该捷径的档案内容, 就可以做到了.
捷径档的副档名是 .url, 当然, 如果您直接用记事本去开启 .url 档, 一定会很失望, 因为很多软件的捷径档, 都是存成 Binary 的档案 (不知是否故意的), 不过别担心, 那只是障眼法而已.
捷径档和 VB 的 .Frm 档一样, 不管是 AscII / Binary 都可以.我们自己要产生的, 只要做成一般文字档就可以了, 而捷径档的格式如下 :
[InternetShortcut]
URL=http://网址 (Internet/ Intranet 通用)
然后随便存一个档名, 例如 "润泰网站.url", 只要副档名是 .url 即可.
而且 Win95/Win98 很聪明, 会自动将副档名拿掉. 只 Show 出 "润泰网站"
很简单吧!!! 就算您的机器不能连上 Internet, 您也可以马上感受一下 Intranet 的功能.
[InternetShortcut]
URL=http://Intranet主机/目录
如果您连用 VB 写文字档都懒的话, 直接用记事本编辑也可以体验一下的 !!!
34、Bug：维护 Internet Transfer Control 之 Username 及 Password
由于 Bug，在使用 Internet Transfer Control 时，Username 及 Password 必须设定在 URL 之后，否则无效！以下的程序码是错的：
Inet1.Password = "Chicken_Feet"
Inet1.UserName = "JohnnyW"
Inet1.URL = FTP://ftp.32X.com
Inet1.Text = Inet1.OpenURL
但是如果改成以下之程序，将 URL 放到最前面，就可以正常执行：
Inet1.URL = FTP://ftp.32X.com
Inet1.Password = "Chicken_Feet"
Inet1.UserName = "JohnnyW"
Inet1.Text = Inet1.OpenURL
35、我要如何在程序中开启网页？
在声明区中声明如下 (在 .bas 档中用 Public, 在 Form 中用 Private)
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
在程序中
Intranet：
ShellExecute Me.hWnd, "open", "http://Intranet主机/目录", "", "", 5
Internet：
ShellExecute Me.hWnd, "open", "http://www.ruentex.com.tw", "", "", 5
很简单吧!!! 就算您的机器不能连上 Internet, 您也可以马上感受一下 Intranet 的功能.
36、如何让表单一开始就显示在荧幕中央？（含工作列）
共有二种方法
方法1: VB3/VB4之版本，可于 Form_Load() 程序中加入下列程式码：
Me.Move (Screen.Width-Width)/2, (Screen.Height-Height)/2
方法2:
VB5以上之版本，则直接将 Form 之 StartUpPosition 设成 (2-荧幕中央) 即可
37、如何让表单一开始就显示在荧幕中央？（不含工作列）
以下之程序在计算时会扣除工作列所占的高度 (或宽度)，如果有启动 Microsoft Office 的快捷列的话，也会扣除快捷列所占的高度 (或宽度)。
Public Const SM_CXFULLSCREEN = 16
Public Const SM_CYFULLSCREEN = 17
#If Win32 Then
Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
#Else
Declare Function GetSystemMetrics Lib "User" (ByVal nIndex As Integer) As Integer
#End If
Public Sub CenterForm(frm As Form)
frm.Left = Screen.TwipsPerPixelX * GetSystemMetrics(SM_CXFULLSCREEN) / 2 - frm.Width / 2
frm.Top = Screen.TwipsPerPixelY * GetSystemMetrics(SM_CYFULLSCREEN) / 2 - frm.Height / 2
End Sub
只要在 Form_Load 中使用 CenterForm Me 即可
38、MDI Form可否跟一般的表单一样设定背景颜色 (BackColor)？
VB3 以前的版本：不行。MDI Form没有此一功能。
VB4 / VB5 / VB6 ：可以直接在属性表中设定！
39、VB可以产生四角形以外其他形状的 Form 吗？
这个问题，您一定无法想像有多容易，您可以产生任何形状的 Form，但必须借助 CreateEllipticRgn 及 SetWindowRgn 二个 API ，例如：
Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Sub Form_Load()
Dim lReturn As Long
Me.Show
lReturn = SetWindowRgn(hWnd, CreateEllipticRgn(10, 10, 340, 150), True)
End Sub
执行结果图片
CreateEllipticRgn 之四个参数说明如下：
X1：椭圆中心点之X轴位置，但以 Form 的实№边界为限。
Y1：椭圆中心点之Y轴位置，但以 Form 的实№边界为限。
X2：椭圆长边的长度
Y2：椭圆短边的长度的
40、如何让一个 Form 出现在另一个非 MDIForm 的 Form 中？
假设要将 Form2 放在 Form1 中，请在宣告区中宣告：
Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
在 Form2 中的 Form_Load 中加入 SetParent(Me.hWnd, Form1.hWnd) 即可。
但有一点要注意的是，在 Unload Form1 之前一定要先 Unload Form2。
VB问题全功略（9） [查找本页请按Ctrl+F]
［上一页］（9）［下一页］
41、如何产生渐层的 Form 背景？
42、Set FormName = Nothing
43、如何移除 Form 右上方之『X』按钮？
44、如何制作透明的表单 (Form)？
45、在抓取资料库之资料前先计算资料总笔数
41、如何产生渐层的 Form 背景？
在 Form_Load 中加入以下程序码
Sub Form_Load()
Form1.AutoRedraw = True
'使 Form 物件的自动重绘有效
Form1.DrawStyle = 6
'直线的样式为内实线 (6-vbInsideSolid)
Form1.DrawMode = 13
'copy Pen-由 ForeColor 属性指定的颜色。(13-vbCopyPen)
Form1.DrawWidth = 2
'输出的线宽为 2 像素 (Pixel)
'为绘图或列印建立一自订的座标比例尺
'图形像素为显示器或印表机解析度的最小单位
Form1.ScaleMode = 3
'设定物件座标的量测单位为像素 (3-VbPixels)
Form1.ScaleHeight = (256 * 2)
'设定垂直量测单位值为 512
For i = 0 To 255
Form1.Line (0, Y)-(Form1.Width, Y + 2), RGB(0, 0, i), BF
Y = Y + 2
Next i
'RGB(red, green, blue)
'B : 使一方块用一指定方块对角的座标画出
'F : 指定此方块系以用来画方块的色彩来加以填满 (有B才可用F)
End Sub
42、Set FormName = Nothing
语法：Set objectvar = {[New] objectexpression | Nothing}
Nothing 为选择性引数。停止 objectvar 和任何特定物件的关连。指定 objectvar 为 Nothing，会在没有其它变数引用时，释放所有与先前物件有关的系统和内存资源。
当 objectvar 设定成 FormName 时，会将该 Form 中所有占用内存的物件所占用的内存通通释放。
虽然有人说 VB 在 Form Unload 时会自动释放内存，但是并不是全部!!
就像有人说, VB 程序要 Make EXE 之前最好先结束 VB, 重新载入该 Project 再 Make EXE, 结果执行档会比较小, 为什么 ? 就是少了一些在内存中的垃圾 !!
43、如何移除 Form 右上方之『X』按钮？
其实 Form 右上方之三个按钮分别对应到 Form 左上方控制盒 (ControlBox) 中的几个选项 (缩到最小 / 放到最大 / 关闭)，而其中的最大化 (MaxButton) 及最小化 (Minbutton) 都可以直接在 Form 的属性中设定，但是 VB 并没有提供设定『X』按钮的功能！要达到这个功能，必须借助 API：
由于『X』按钮对应到 ControlBox 的关闭选项，所以我们只要移除系统 Menu (就是ControlBox) 的关闭选项即可！您自己可以先看看您现在使用的 Browser 左上方的系统 Menu，【关闭】选项是在第几个，不是第 6 个！是第 7 个，分隔线也算一个！分隔线才是第 6 个！
当我们移除了关闭选项之後，会留下一条很奇怪的分隔线，所以最好连分隔线也一并移除。而 Menu 的 Index 是从 0 开始，分隔线是第 6 个，所以 Index = 5。
修正：为了让程序码在 Windows NT 也能运作正常，将各 Integer 型态改成 Long。 89.05.04
'抓取系统 Menu 的 hwnd
Private Declare Function GetSystemMenu Lib "user32" Alias "GetSystemMenu" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
'移除系统 Menu 的 API
Private Declare Function RemoveMenu Lib "user32" Alias "RemoveMenu" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
'第一个参数是系统 Menu 的 hwnd
'第二个参数是要移除选项的 Index
44、如何制作透明的表单 (Form)？
请在声明区中放入以下声明
Const GWL_EXSTYLE = (-20)
Const WS_EX_TRANSPARENT = &H20&
Const SWP_FRAMECHANGED = &H20
Const SWP_NOMOVE = &H2
Const SWP_NOSIZE = &H1
Const SWP_SHOWME = SWP_FRAMECHANGED Or SWP_NOMOVE Or SWP_NOSIZE
Const HWND_NOTOPMOST = -2
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
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
在 Form_Load 使用的范例如下：
Private Sub Form_Load()
SetWindowLong Me.hwnd, GWL_EXSTYLE, WS_EX_TRANSPARENT
SetWindowPos Me.hwnd, HWND_NOTOPMOST, 0&, 0&, 0&, 0&, SWP_SHOWME
Me.Refresh
End Sub
45、在抓取资料库之资料前先计算资料总笔数
Sub Form1_Load()
Dim db As Database
Dim ds As Snapshot
Dim iNum As Integer '总笔数
Dim wsql As String 'SQL字串
wsql = "Select Count (*) from Authors Where AU_ID > 10"
Set db = OpenDatabase("c:/vb/biblio.mdb")
Set ds = db.CreateSnapshot(wsql)
iNum = ds(0)
MsgBox "总笔数为 " + Str$(iNum)
End Sub
怎么样，是不是一样呢，只差在一个是 ADO，一个是 DAO 而已！
46、程序启动时，如何自动判断 Access 资料库是否损毁并自动修复？
若程序使用 Access 资料库开发，当 Access 资料库损毁时，一进入程序，便会出现以下讯息：
Can't open database 'name'. It may not be a database that your application recognizes, or the file may be corrupt. (Error 3049)
若是程序中未加入错误判断，程序便会中断跳出，这会给予使用者极不好的印象，要避免这种情形，甚至不让使用者发现资料库损毁，便要加入以下之程序码加以判断：
Private Sub Form_Load()
Dim db As Database
On Error GoTo error1
Set db = OpenDatabase("c:/test.mdb")
On Error GoTo 0
: '正常程序开始
:
Exit Sub
error1:
If Err = 3049 Then '资料库损毁
DBEngine.RepairDatabase "C:/test.mdb"
Resume
Else
MsgBox Err & Error(Err)
End If
47、如何让程序在 Windows 启动时自动执行？
有以下二个方法：
方法1: 直接将快捷方式放到启动群组中。
方法2:
在注册档 HKEY_LOCAL_MACHINE 中找到以下机码
/Software/Microsoft/Windows/CurrentVersion/Run
新增一个字串值，包括二个部份
1. 名称部份：自己取名，可设定为 AP 名称。
2. 资料部份：则是包含 '全路径档案名称' 及 '执行参数'
例如：
Value Name = Notepad
Value Data = c:/windows/notepad.exe
48、如何让程序在新 User Login 时自动执行？
在注册表中 HKEY_CURRENT_USER 找到以下代码
/Software/Microsoft/Windows/CurrentVersion/Run
新增一个字串值，包括二个部份
1. 名称部份：自己取名，可设定为 AP 名称。
2. 资料部份：则是包含 '全路径档案名称' 及 '执行参数'
例如：
Value Name = Notepad
Value Data = c:/windows/notepad.exe
49、已将 TextBox 的 Alignment 属性设为「1-靠右对」(1-RightJustify)，但文字却未向右靠？
欲将 TextBox 内的文字向右靠，除了将 Alignment 属性设为「1-靠右对　」之外，亦　将 MultiLine 属性设为 True。
但是若您希望只有单行，不要多行，则必须判断 User 是否按了 Enter Key，那只好在 TextBox 的 KeyPress 中加入以下程序码，以去除 Enter 的作用：
Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii = vbKeyReturn Then
KeyAscii = 0
End If
50、在 TextBox 中如何限制只能输入数字？
参考下列程序：
Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii < 48 Or KeyAscii > 57 Then
KeyAscii = 0
End If
End Sub
51、我希望 TextBox 中能不接受某些特定字符，例如 '@#$%"，有没有简单一点的写法？
方法有好几种, 以下列举二种：
方法1: 可以使用 IF 或 Select Case 一个个判断, 但如果不接受的字符多时, 较麻烦!
方法2: 将要剔除的字符统统放在一个字串中，只要一个 IF 判断即可 !! 如下：
Private Sub Text1_KeyPress(KeyAscii As Integer)
Dim sTemplate As String
sTemplate = "!@#$%^&*()_+-=" '用来存放不接受的字符
If InStr(1, sTemplate, Chr(KeyAscii)) > 0 Then
KeyAscii = 0
End If
End Sub
52、如何让鼠标进入 TextBox 时自动选定 TextBox 中之整串文字？
这个自动选定反白整串文字的动作，会使得输入的资料完全取代之前在 TextBox 中的所有字符。
Private Sub Text1_GotFocus()
Text1.SelStart = 0
Text1.SelLength = Len(Text1)
End Sub
53、如何让 TextBox 由 Insert 模式变成 Overwrite 模式？
Windows 的 TextBox 一直都只支援 Insert Mode，而不支援 OverStrike(OverWrite) Mode，其实，只要在 Key_Press 事件中加上几行指令，就可以做到 OverStrike 功能 !!
以下的程式码中，只设定 SelLength=1，而 SelStart 若未指定则会一直跟著滑鼠的游标所在处，设定 SelLength=1 会反白游标所在处的下一个字，但是由于您输入的字元会直接取代该反白的字元(都同时在 Key_Press 发生)，所以您并不会看到字符被选定反白 (Marked)，若是游标已在字串的最后面，则会直接忽略这个动作。
以下的程式码中同时也作了以下的错误判断及预防：
1. 当输入的是退格符，也就是 Backspace (character 8)。
2. 当输入的是 return 键 (character 13)。
3. 事先已作了选定动作 (Marked)。
Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii <> 8 And KeyAscii <> 13 And Text1.SelLength = 0 Then
Text1.SelLength = 1
End If
End Sub
54、如何使 TextBox 变成只读，卷动杆可卷动，但是不出现游标，也不可被选定反白？
在 Form 中放一个 TextBox，设定 Locked = True，MultiLine = True，ScrollBar = 2 - Vertical。另外再放一个 CommandButton (或其他任何可接受 Focus 的物件)，此物件可由您自行作其他用途，否则设定 Command1.left = -1000 将其移到 Form 的外面。
程式码如下：
Private Sub Text1_GotFocus()
'马上将 Text1 的 focus 转移到 Command1 或其他物件上
Command1.SetFocus
End Sub
55、文字框可以设定快捷键吗？
不行，要设定快捷键的先决条件，是该物件必须有 Caption 属性，但是 TextBox (文字框) 只有 Text 属性，并无 Caption 属性，所以文字框本身是不能设定快捷键的！完全没办法吗？
但是还是有办法的！人家说山不转路转，文字框本身不能设定快捷键，一般我们在文字框的左方都会放置说明用的 Label，那我们就借用 Label 来做到这个功能，作法如下：
1、将文字框的 TabIndex 设成说明用的 Label 物件的下一个。
2、设定 Label 物件的快捷键，奇怪吗？Label 物件没有 Focus 好像不要快捷键！没错，我们就是要利用 Label 物件不要快捷键的特性来达到我们的要求！
当您输入了 Label 物件的快捷键，由于 Label 物件没有 Focus 不接受快捷键，于是它立刻将 Focus 送到下一个 TabIndex 的物件，也就是 TextBox 文字框了！
56、如何检查软盘驱动器里是否有软盘？
使用：
Dim Flag As Boolean
Flag = Fun_FloppyDrive("A:")
If Flag = False Then MsgBox "A:驱没有准备好，请将磁盘插入驱动器！", vbCritical
'-------------------------------
'函数:检查软驱中是否有盘的存在
'-------------------------------
Private Function Fun_FloppyDrive(sDrive As String) As Boolean
On Error Resume Next
Fun_FloppyDrive = Dir(sDrive) <> ""
End Function
57、如何弹出和关闭光驱托盘？
Option Explicit
Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
Private Sub Command1_Click()
mciExecute "set cdaudio door open" '弹出光驱
Label2.Caption = "弹出"
End Sub
Private Sub Command2_Click()
Label2.Caption = "关闭"
mciExecute "set cdaudio door closed" '合上光驱
Unload Me
End
End Sub
58、如何计算出本月的最后一天
首先为下个月的第一天生成一个顺序数值，然后再减去一天
Private Sub Command1_Click()
Dim dtl As Date
dtl = DateSerial(Year(Now), Month(Now) + 1, 1) - 1
MsgBox dtl
End Sub
59、如何让你的程序在任务列表隐藏
Private Declare Function RegisterServiceProcess Lib "kernel32" (ByVal ProcessID As Long, ByVal ServiceFlags As Long) As Long
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
'请你试试 Ctrl+Alt+Del 是不是你的程序隐藏了
Private Sub Command1_Click()
i = RegisterServiceProcess(GetCurrentProcessId, 1)
End Sub
60、如何利用API实现代码延时执行
声明:
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
调用:
Sleep 3000 '延时3秒执行
VB问题全功略（13） [查找本页请按Ctrl+F]
［上一页］（13）［下一页］
61、若画面上 ListBox 中可显示的项目数量为 5 条，而 ListBox 中的资料总数已超过 5 条，如何让新加入 ListBox 的项目能够马上显示在 ListBox 的最后一条〈画面上显示最后 5 条，含新加入之资料〉？
62、如何事先选定 ListBox 或 ComboBox 的某一个 Item？
63、模拟 IE 的地址栏：智慧型下拉式 Combo
64、如何让 ListBox 同一列显示二栏以上的栏位？
65、如何控制二栏以上 ListBox 之各栏位宽度？
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 & "男"
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
End Sub
在任何时候 (不一定是 Form_Load 或 Combo_DropDown)，想要加长 ComboBox 的下拉选单时，只要加入以下程序即可：
Call SetComboHeight(Combo1, 270) '设定的单位是 Pixels
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 Function
传入之参数是含完整路径之文件名称，若文件存在，则传回 -1，否则返回 0。
74、如何用 Image 来做成带有图片的按钮，按下鼠标时如同按钮般会变换图片？
在 Form 中放三个 Image Control，名称分别为 Image1、LockOpen、LockClosed，并设定好 LockOpen 及 LockClosed 的 Picture 属性为开启及关闭的 Icon，然后
Sub Form_Load()
Image1.Picture = LockOpen.Picture
End Sub
Sub Image1_Click()
Static LockedFlag As Integer
If LockedFlag Then
Image1.Picture = LockOpen.Picture
Else
Image1.Picture = LockClosed.Picture
End If
LockedFlag = Not LockedFlag
End Sub
以上之程序代码虽然在 VB 的各个版本都适用，但 VB 6.0 的 CommandButton 已经可以放置图片了，所以 VB 6.0 可以直接使用 CommandButton 达到以上功能！
75、听说 VB 6.0 的 CommandButton 己经可放图片，要如何使用？
先将 Style 属性设成「1 - 图片外观」，再设定 Picture 属性即可。
若希望 Mouse_Down 时可改变图片，则需要再设定 DownPicture 属性。
若希望按钮 Disable 时可改变图片，则需要再设定 DisabledPicture 属性。
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 的宽度。
84、为什么有的程序的画面或控制项总是闪个不停，如何避免？
原因很多，但最主要的原因是 '不停地改变一些可能不需要改变的控制项属性'，这些属性通常是一些会造成控制项 Repaint 的属性，例如：Enabled, Visible, Contents 及 Text。如果某一个物件的属性已经是您要设定的值，那就不要再设定一次，如此便会大大降低控制项闪动的频率。例如：
If Not Command1.Enabled
Then Command1.Enabled=True
End If
以下是一个完成的 Module：
Sub SetEnabled (ctrlIn as Control, bSetting as Integer)
If ctrlIn.Enabled <> bSetting Then
ctrlIn.Enabled=bSetting
End If
End Sub
85、计算二个时间的时间差
VB 有提供一些好用的日期时间计算函数，但是没有一个计算时间差的功能，有些人会说有的，是 DateDiff，但是，DateDiff 功能却不够，您可以算出二个时间所差的总日数、总时数或总秒数，但您算不出是相差几天几小时几分钟又几秒钟！
以下这个模组的功能就是计算二个时间之时间差：
Function Convtime(date1 As Date, date2 As Date) As String
'
'功能 : 计算二个时间的时间差
'
'参数 : date1 是较早的时间, Variant (Date)。
' date2 是较晚的时间, Variant (Date)。
'
'若要计算两个日期之时间差，计算顺序是从 date1 到 date2
'
'返回值 : 时间差的组合字串, 例如 2年21天13小时5分钟3秒
'
Dim wsecond As Long '总秒数 / 剩余秒数
Dim wminute As Long '总分钟数 / 剩余分钟数
Dim whour As Long '总时数 / 剩余时数
Dim wday As Long '总天数 / 剩余天数
Dim wyear As Long '总年数
wsecond = DateDiff("s", date1, date2) '总秒数
If wsecond > 60 Then
wminute = wsecond / 60 '总分钟数
wsecond = wsecond Mod 60 '计算剩余秒数
End If
If wminute > 60 Then
whour = wminute / 60 '总时数
wminute = wminute Mod 60 '计算剩余分钟数
End If
If whour > 24 Then
wday = whour / 24 '总天数
whour = whour Mod 24 '计算剩余时数
End If
If wday > 365 Then
wyear = wday / 365 '总年数
wday = wday Mod 365 '计算剩余天数
End If
'拼凑计算结果字串
If wyear > 0 Then Convtime = Convtime & wyear & "年"
If wday > 0 Then Convtime = Convtime & wday & "天"
If whour > 0 Then Convtime = Convtime & whour & "小时"
If wminute > 0 Then Convtime = Convtime & wminute & "分钟"
If wsecond > 0 Then Convtime = Convtime & wsecond & "秒"
End Function
当然，或许您要的结果不是我算出的字串，可能要算几周！但是只要将以上的程序稍作修改，就可以得到您要的结果！
86、处理加了密码的 Access 资料库
当 Access 资料库加了密码，直接由 Access 开启资料库时，会出现密码问话框，询问密码。但是若要由 VB 程序中开启，必须更改 VB 程序中开启资料库的指令，否则会出现错误讯息！以下针对各种状况，分别加以说明：
1、使用 DAO 语法开启资料库：OpenDatabase
若要由程序中开启，语法如下：
Set DB = OpenDatabase(DatabaseName, False, False, ";Pwd=密码")
实例例如：
Dim db As Database
Set db = OpenDatabase("C:/db1.mdb", False, False, ";Pwd=1")
若要使用 Data 控制项，设定方法如下：
1、设定 DatabaseName 属性 (资料库名称 / 含路径)
2、设定 Connect 属性，将预设的字串 "Access" 改成 ";Pwd=密码" (不含双引号)
3、设定 RecordSource 属性 (资料集)
　
2、
　
使用 ADO 语法开启资料库：
在使用 ADODC 或 DataEnvironment 设定好连线之后，直接利用属性视窗修改 ConnectionString 属性(附属于 ADODC) 或 ConnectionSource 属性(附属于 DataEnvironment 的 Connection 物件)，修改的方法是在属性之后增加以下参数：
;Jet OLEDB:Database Password=密码
除了 ADODC 及 DataEnvironment 之外，直接使用 ADO 物件来开启含有密码的 mdb 资料库，设定参数的方法也是相同的。
　
3、
　
压缩加了密码的资料库：CompactDatabase
DBEngine.CompactDataBase "原资料库档名", "新资料库档名", , , ";pwd=密码"
实例例如：
DBEngine.CompactDatabase "C:/Db1.mdb", "C:/Db2.mdb", , , ";pwd=1"
　
4、
　
修复加了密码的资料库： RepairDatabase
不必理会资料库设定的密码！
DBEngine.RepairDataBase "资料库档名"
实例例如：
DBEngine.RepairDataBase "C:/Db1.mdb"
87、如何取消 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
88、如何在 Menu 中加入美美的图案？
在模组中加入以下程序码：
Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Declare Function GetMenuItemID Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Declare Function SetMenuItemBitmaps Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal hBitmapUnchecked As Long, ByVal hBitmapChecked As Long) As Long
Public Const MF_BITMAP = &H4&
Type MENUITEMINFO
cbSize As Long
fMask As Long
fType As Long
fState As Long
wID As Long
hSubMenu As Long
hbmpChecked As Long
hbmpUnchecked As Long
dwItemData As Long
dwTypeData As String
cch As Long
End Type
Declare Function GetMenuItemCount Lib "user32" (ByVal hMenu As Long) As Long
Declare Function GetMenuItemInfo Lib "user32" Alias "GetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, _
ByVal b As Boolean, lpMenuItemInfo As MENUITEMINFO) As Boolean
Public Const MIIM_ID = &H2
Public Const MIIM_TYPE = &H10
Public Const MFT_STRING = &H0&
在 Form 中加入一个 PictureBox，属性设定为：
AutoSize = True
Picture = .bmp (尺寸大小为 13x13，不可设定为 .ico)
在 Form_Load 中的程序码如下：
Private Sub Form_Load()
'取得程序中 Mennu 的 handle
hMenu& = GetMenu(Form1.hWnd)
'取得第一个 submenu 的 handle
hSubMenu& = GetSubMenu(hMenu&, 0)
'取得 Submenu 第一个选项的 menuId
hID& = GetMenuItemID(hSubMenu&, 0)
'加入图片
SetMenuItemBitmaps hMenu&, hID&, MF_BITMAP, Picture1.Picture, Picture1.Picture
'在一个 Menu 选项中您一共可以加入二张图片
'一张是 checked 状态用，一张是 unchecked 状态用
End Sub
89、如何把小图片填满 Form 成为背景图？
对于这个问题，我看过很多方法，有的方法很麻烦，要声明一大堆 Type，用一大堆的 API，但是有一个最笨但我认为最好的方法如下： (就好像拼磁砖一样，不用任何 API, 不必声明任何 Type)
在 Form 中放一个 PictureBox，Picture 属性设定为某一张小图，AutoSize 属性性设定 True，完成的模组如下：
Sub PictureTile(Frm As Form, Pic As PictureBox)
Dim i As Integer
Dim t As Integer
Frm.AutoRedraw = True
Pic.BorderStyle = 0
For t = 0 To Frm.Height Step Pic.ScaleHeight
For i = 0 To Frm.Width Step Pic.ScaleWidth
Frm.PaintPicture Pic.Picture, i, t
Next i
Next t
End Sub
PictureTile 这个模组共有二个参数，第一个是表单名称，第二个则是 PictureBox 的名称。以下为一应用实例：
Private Sub Form_Load()
PictureTile Me, Picture1
End Sub
90、如何把小图片填满 MDIForm 成为背景图？
以下这个范例，　要：
1、一个 MDIForm：不必设定任何属性。
2、一个 Form1：不一定是 MDIChild，最好 MDIChild 为 False，但是 AutoRedraw 设成 True。
3、Form1 上面放一个隐藏的 PictureBox：名称为 Picture1，不必设定 Picture 属性。
4、一张图片的完整路径。
'将以下模组放入 MDIForm 的声明区中：
Sub TileMDIBkgd(MDIForm As Form, bkgdtiler As Form, bkgdfile As String)
If bkgdfile = "" Then Exit Sub
Dim ScWidth%, ScHeight%
ScWidth% = Screen.Width / Screen.TwipsPerPixelX
ScHeight% = Screen.Height / Screen.TwipsPerPixelY
Load bkgdtiler
bkgdtiler.Height = Screen.Height
bkgdtiler.Width = Screen.Width
bkgdtiler.ScaleMode = 3
bkgdtiler!Picture1.Top = 0
bkgdtiler!Picture1.Left = 0
bkgdtiler!Picture1.Picture = LoadPicture(bkgdfile)
bkgdtiler!Picture1.ScaleMode = 3
For n% = 0 To ScHeight% Step bkgdtiler!Picture1.ScaleHeight
For o% = 0 To ScWidth% Step bkgdtiler!Picture1.ScaleWidth
bkgdtiler.PaintPicture bkgdtiler!Picture1.Picture, o%, n%
Next o%
Next n%
MDIForm.Picture = bkgdtiler.Image
Unload bkgdtiler
End Sub
以下为一应用实例：
Private Sub MDIForm_Load()
TileMDIBkgd Me, Form1, "c:/windows/Tiles.bmp"
End Sub
91、如何让一个 app 永远保持在最上层 ( Normal on Top )
请在 Form 中放一个 Timer，Interval = 1000 (或更小)，在 Timer 事件中加入以下程序码：
Private Sub Timer1_Timer()
Me.ZOrder
End Sub
不过这样子的 Form，只不过是一个 Normal Window。要产生真正 Topmost Window，就要使用 API 了！
92、关闭指定的程序
要做到像 Task Manager 一样，可以关闭指定的程序，方法如下：
在声明区中放入以下声明：(16位　改成 win31 API)
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Const WM_CLOSE = &H10
以下之范例示范如何关闭一个视窗标题 (Caption) 为【小算盘】的程序：
Dim winHwnd As Long
Dim RetVal As Long
winHwnd = FindWindow(vbNullString, "小算盘")
Debug.Print winHwnd
If winHwnd <> 0 Then
RetVal = PostMessage(winHwnd, WM_CLOSE, 0&, 0&)
If RetVal = 0 Then
MsgBox "Error posting message."
End If
Else
MsgBox "并未开启小算盘程序."
End If
93、开启及关闭CD－Rom的门
在声明区中加入以下声明：
Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" _
(ByVal lpstrCommand As String, ByVal lpstrReturnString As String, _
ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
开启的程序代码如下：
retvalue = mciSendString("set CDAudio door open", returnstring, 127, 0)
关闭的程序代码如下：
retvalue = mciSendString("set CDAudio door closed", returnstring, 127, 0)
94、如何知道您的机器中预设印表机的机型、驱动程序及连接埠
想要抓取您机器中软硬件的资料，其实最方便的，就是直接从注册表中抓取，但是有些人对注册表有畏惧感！觉得注册表好像高深的样子。
其实虽然从 Windows95 以后 Microsoft 已经将 Win.ini 及 System.ini 的资料写到注册表中，但是由于 INI 档之使用已根深蒂固，所以 Microsoft 也不敢冒然废除 INI 档的使用，直到 Windows98 为止，一直都是二者并用，也就是有些资料，在写到注册的同时，也写了一份到 INI 档中！
目前讨论的主题就是一个例子，这三种资料都可从 Win.ini 中直接读取，结构如下：
[windows]
device=HP LASERJET 6P (TRADITIONAL),HPCXLAB,//SUN/LJIIP2
device=印表机的机型, 驱动程序, 连接埠 (三种资料中间以逗点分开)
在声明区中加入以下声明： (16位　改成 win31 API)
Private Declare Function GetProfileString Lib "kernel32" Alias "GetProfileStringA" (ByVal lpAppName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long) As Long
程序代码如下：
AppName$ = "windows" 'Section 名称
KeyName$ = "device" 'Key 值名称
nSize% = 81 '预设返回值长度
RetStr$ = Space$(nSize%) '设定空白给预设返回值
NumChars% = GetProfileString(AppName$, KeyName$, NullStr$, RetStr$, nSize%)
' NumChars% 是实际返回值长度
koRetStr$ = Left$(RetStr$, NumChars%) '实际返回值
' Parse the string for specifics
'找寻第一个逗点的位置
CommaPos1% = InStr(1, RetStr$, ",")
'找寻第二个逗点的位置
CommaPos2% = InStr(CommaPos1% + 1, RetStr$, ",")
'印表机的机型
lblPrinter.Caption = Left$(RetStr$, CommaPos1% - 1)
'印表机的驱动程序
lblPrinterDriver.Caption = Mid$(RetStr$, CommaPos1% + 1, CommaPos2% - CommaPos1% - 1) & ".DRV"
'印表机的连接埠
lblPrinterPort.Caption = Mid$(RetStr$, CommaPos2% + 1)
95、如何判断二个日期是否为同一月份？
碰到这个问题，很多人第一个念头想到的就是『简单！只要使用 Month() 来判断就可以了』，但是这个方法却潜藏危机！为什么呢？例如：
Month(Date1) = 2
Month(Date2) = 2
以上的二个日期并不一定是同月份，就像 1999/02/01 和 2000/02/01 一样！
要怎样做才会正确呢？
要使用 DateDiff ("m", Date1, Date2) = 0 表示同一月份(年度当然也相同)
程序如下：
If DateDiff ("m", Date1, Date2) then
MsgBox "不同月份"
Else
MsgBox "同月份"
End If
96、如何让二个文字框同步联动？
要作到这个动作，有的人会想要用 KeyDown 或 KeyPress 事件来处理，但是这都是错的，虽然第二个文字框终究会动，但是总是比第一个文字框慢了一拍，永远会漏掉最后一个字！为什么呢？
因为由键盘输入时，程序接收的顺序为 KeyDown --> KeyPress --> KeyUp，而在 KeyPress 时，才会传入 Keyascii〈此点可由各事件中传入的参数得知〉转换成文字，所以在 KeyDown 时，还抓不到输入的字，在 KeyPress 时，只有 Keyascii 则需要转换才抓得到，但是中文比较麻烦！
在 KeyUp 时虽然已经可以抓到键入的值，但是我认为倒不如在 Change 事件中来得简单！不管 User 输入什么，只有第一个文字框资料异动时，才需要处理。
Private Sub Text1_Change()
Text2 = Text1
End Sub
如果不管第一个文字框输入什么，第二个文字框只要显示最后一个字，则程序要改成：
Private Sub Text1_Change()
Text2 = Right(Text1, 1)
End Sub
97、如何避免核取方块式的 ListBox 已选定的项目被更改？
当 ListBox 的 Style 设定成〈1-项目包含核取方块〉，ListBox 控制项以每一个文字项目跟随一个核取方块的方式显示。您可透过选取各项目边的核取方块以选择 ListBox 中的多个项目。
但有时候，您这样子设定的目的是为了显示一些事先选定的项目，例如从资料库中抓出的资料或是一些安装软件的设定选项确认画面。您不希望因为使用者再去点选 ListBox 的项目而更动原来设定的项目，这时候，您不能将 Enabled 属性设成 False，因为这样子卷动杆就无法卷动，使用者就无法看到 ListBox 的其他项目；您也无法像 TextBox 一样设定成 Lock 状态，因为 ListBox 没有 Lock 属性。
以下的程序代码可以解决这个问题，在 Form 中放一个 CommandButton 及一个 ListBox，将 ListBox 的 Style 设定成〈1-项目包含核取方块〉：
Dim isDisabled As Boolean '是否取消可选定状态
Private Sub Command1_Click()
isDisabled = Not isDisabled
End Sub
Private Sub List1_ItemCheck(Item As Integer)
If isDisabled Then
List1.Selected(Item) = Not List1.Selected(Item)
End If
End Sub
当 isDisabled 设定成 True 时，使用者一旦选定 ListBox 的某一个项目，程序会立即反转它的状态，看起来就像没改变过选定状态一样！而同时 ListBox 还是可以卷动！
98、如何隐藏及再显示鼠标
很简单，只用到了一个 ShowCursor API，参数也很简单，只有一个 bShow，设定值如下：
True：显示鼠标 / False：隐藏鼠标
Declare Function ShowCursor Lib "user32" Alias "ShowCursor" (ByVal bShow As Long) As Long
99、您是左撇子吗？交换鼠标的左右键！
很简单，只用到了一个 SwapMouseButton API，参数也很简单，只有一个 bSwap，设定值如下：
True：左右键互换 / False：恢复正常
Declare Function SwapMouseButton Lib "user32" Alias "SwapMouseButton" (ByVal bSwap As Long) As Long
假设我是左撇子，则程序为：
Dim RetVal As Long
RetVal = SwapMouseButton(True)
100、资料的加密 / 解密
以下二个模组，一个处理加密，一个处理解密，加密处理必须传入参数 (就是要加密的字串)，加密后将资料存到加密文件，要解密时，则从文件案中读出并解密：
(假设文件案名称为 C:/加密文件.qwe, 您可以自行更改文件名或路径)
'处理加密
Private Function Encrypt(varPass As String)
If Dir("C:/加密文件.qwe") <> "" Then: Kill "C:/加密文件.qwe"
Dim varEncrypt As String * 50
Dim varTmp As Double
Open "C:/加密文件.qwe" For Random As #1 Len = 50
For I = 1 To Len(varPass)
varTmp = Asc(Mid$(varPass, I, 1))
varEncrypt = Str$(((((varTmp * 1.5) / 2.1113) * 1.111119) * I))
Put #1, I, varEncrypt
Next I
Close #1
End Function
'处理解密
Private Function Decrypt() As String
Open "C:/加密文件.qwe" For Random As #1 Len = 50
Dim varReturn As String * 50
Dim varConvert As Double
VB问题全功略（21） [查找本页请按Ctrl+F]
［上一页］（21）［下一页］
101、如何让 ComboBox 可以自动下拉？
102、如何从您的应程序中结束 Windows 重开机？
103、我要如何用 VB 来拨电话？ (不用 MSCOMM32.OCX )
104、如何用 VB 启动其他程序或开启各类文件？
105、由程序中启动屏幕保护程序！(一)
101、如何让 ComboBox 可以自动下拉？
以下状况假设我在 Form_Load 中自动下拉 Combo1.
'以下声明用于16位
Const WM_USER = &H400
Const CB_SHOWDROPDOWN = (WM_USER + 15)
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 CB_SHOWDROPDOWN = &H14F
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 Form_Load()
Combo1.AddItem "11111"
Combo1.AddItem "22222"
Combo1.AddItem "33333"
Combo1.AddItem "44444"
Combo1.AddItem "55555"
Combo1.AddItem "66666"
'Form_Load 即自动下拉 Combo1
Dim nret As Long
nret = SendMessage(Combo1.hwnd, CB_SHOWDROPDOWN, 1, ByVal 0&)
End Sub
102、如何从您的应程序中结束 Windows 重开机？
很多软件在 Setup 完之后都会自动关机重开机，以便让某些设定值可以生效，其实这个功能很简单，只要几行指令就可以做到了！
关键就是要使用 ExitWindowsEx 这个 API，这个 API 只有二个参数，第一个参数是一个 Flag，目的是要告诉 Windows 要以什么方式关机，在下面的声明中会列出可用的 Flag 常数值，至于第二个参数则是一个保留值，只要设定成 0 就可以了。
很重要的一点是：如果您想要让关机动作更顺利，记得要 Unload 您的程序！
'在声明区中 (Bas Module / Form Module) 加入以下声明：
Public Const EWX_LOGOFF = 0 '这四个常数值可以并用
Public Const EWX_SHUTDOWN = 1
Public Const EWX_REBOOT = 2
Public Const EWX_FORCE = 4
Declare Function ExitWindowsEx Lib "user32" Alias "ExitWindowsEx" (ByVal uFlags As Long, ByVal dwReserved As Long) As Long
'实例：如果您想强迫关机重开机，程序码如下：
ret = ExitWindowsEx(EWX_FORCE OR EWX_REBOOT, 0)
103、我要如何用 VB 来拨电话？ (不用 MSCOMM32.OCX )
这个问题很多人问，也很多人回答，答案千篇一律，都说是使用 MSCOMM32.OCX，但是，您知道吗？如果您只是想拨号而已，根本就不用使用 MSCOMM32.OCX 这个控制项！
我忘了是从 Windows95 开始，或是 Windows3.1 就有了，Microsoft Windows 就提供了【电话拨号员】这个工具程序，在 Windows98 中的位置是【开始】【程序集】【附属应用程序】【通讯】【电话拨号员】，如果找不到的话，表示您在安装 Windows95/98 时并未选择安装【电话拨号员】，您只要再执行 Windows 安装程序，选择【通讯】【电话拨号员】即可！
没错！看完以上的说明，您应该知道我们就是要使用【电话拨号员】，请在声明区中加入以下声明及模组：
Private Declare Function tapiRequestMakeCall Lib "TAPI32.DLL" (ByVal Dest As String, ByVal AppName As String, ByVal CalledParty As String, ByVal Comment As String) As Long
Public Sub PhoneCall(sNumber As String, sName As String)
Dim lRetVal As Long
lRetVal = tapiRequestMakeCall(Trim$(sNumber), App.Title, Trim$(sName), "")
If lRetVal <> 0 Then
MsgBox "不能拨号, 请采取其他行动"
End If
End Sub
'以上的 PhoneCall 是一个已经完成的模组，就是用来拨号的，它有二个参数：
'第一个参数是电话号码，是指对方的电话号码。
'第二个参数是对方的姓名或代号。
'以下是一个应用实例，要拨号给电话号码为 "27058181" 的 "纪文和"：
Private Sub Command1_Click()
PhoneCall "27058181", "纪文和"
End Sub
104、如何用 VB 启动其他程序或开启各类文件？
要在 VB 中启动其他程序或开启各类文件，最简单的方法就是使用 Shell 函数，例如：要开启 C:/Test.txt 这个文字文件，则要启动记事本来开启这个文件案，程序如下：
Dim RetVal As Long
RetVal = Shell("C:/Windows/Notepad.exe C:/Test.txt", 3) '3代表视窗会最大化，并具有驻点，细节请查 Help
以上的语法虽然很简单，但有一个风险，若是我们不知道开启文件的执行文件位置，则程序便会有错误产生，尤其一般软件在安装的时候都可以让使用者自行选择安装目录，所以执行文件的路径不能写死在程序中，要解决这个问题，就是在注册文件中找到该副文件名之启动程序位置，再放入 Shell 中。
但是以上的作法必须熟悉注册文件，而且必须使用 Windows API 来 Call (注册文件的存取以后会有专文来说明)，如果您对注册文件的存取及 API 的使用都很纯熟的话，当然没问题，但是有些人对于注册文件会有畏惧，这时候，您可以使用下面的方法：
Shell("Start C:/Test.txt")
您完全不用知道这份文件的启动程序是什么？它放在什么地方？参数 Start 便会自动依照附文件名到注册文件中找到启动程序来开启该份文件案！不赖吧！
注一：在 Windows 95/98/NT 平台中, 什么副文件名之文件案, 该由什么执行文件来启动, 都设在关联中,
代码为 HKEY_LOCAL_MACHINE/SOFTWARE/Microsoft/Windows/CurrentVersion/Extensions
例如: 名称为 ".DOC" 之资料为 "C:/Progra~1/Micros~2/Office/WINWORD.EXE ^.DOC"
名称为 ".TXT" 之资料为 "notepad.exe ^.txt"
注二：使用 Start 之唯一缺点为 "会比直接指定执行文件稍为慢 0.5-1 秒钟."
注三：有一个例外就是屏幕保护程序，请看下面。
105、由程序中启动屏幕保护程序！(一)
如果您曾在民营企业的资讯中心待过，不知您是否曾遇过一种情形，某一个高阶主管 (或他的秘书) 要您帮他改一支报表，当他将有问题的报表交给您时，还千交待万交待，不可以让别人看到这份报表！这时您是不是觉得很好笑，其实在资讯中心，那里还有什么秘密可言？
话是如此说，但是如果您能够将程序写得让他们觉得很安全，您也会获得比较多的礼遇，而从程序中启动屏幕保护程序就是技巧之一，为什么呢？因为当他在作业中途要离开位置时，他可以不用结束作业中的程序，而直接启动屏幕保护程序，而在屏幕保护程序中他可以设定密码，这样就不会不小心给人看到资料了！
要启动屏幕保护程序可以直接使用 Shell 函数，但是上一个专题《问题 84》中我们讨论到的 Shell 二种作法对于屏幕保护程序却有不同的意义，分别说明如下：
错误的作法 ==> x = Shell("c:/windows/Sheep.scr") '这种作法只能开启屏幕保护程序的设定画面而已！
正确的作法 ==> Shell ("start c:/windows/sheep.scr") '这种作法才能正确启动屏幕保护程序
106、如何让您的电脑进入待命状态 (Win98) 或启动屏幕保护程序 (Win95)？
您的程序使用者会不会开启程序后不结束应用程序，结果就离开座位，久久不回座位？使用以下的方法，您可以做到：
1、在 Windows98 中，您可以在程序中让他的电脑进入待命状态！ (屏幕黑黑一片)
2、在 Windows95 中，您可以启动他电脑中预设的屏幕保护程序！
而要让电脑进入待命状态或启动屏幕保护程序，只要送一个讯息给桌面 (DeskTop Window) 就可以了！
'在声明区中加入以下声明：
Const WM_SYSCOMMAND = &H112&
Const SC_SCREENSAVE = &HF140&
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 Declare Function GetDesktopWindow Lib "user32" () As Long
Function gf_StartScreenSaver() As Boolean
Dim hWnd&
On Error Resume Next
hWnd& = GetDesktopWindow()
Call SendMessage(hWnd&, WM_SYSCOMMAND, SC_SCREENSAVE, 0&)
gf_StartScreenSaver = (Err.Number = 0)
End Function
'要使用时直接呼叫 gf_StartScreenSaver 即可！例如：
Private Sub Command1_Click()
gf_StartScreenSaver
End Sub
107、如何在程序中模拟按了 Windows95/98 屏幕左下方之【开始键】？
或许有人会问：这有什么意义？当然有，随便举个例子，有的程序在执行时会盖住开始任务栏，就算滑鼠移到屏幕下方，任务栏也不会出现，目前这个方法就可以强迫任务栏出现！当然也可以让使用者选择执行【开始工能表】中各群组之程序。
如果您看过了前一个问题 (86-如何让您的电脑进入待命状态 (Win98) 或启动屏幕保护程序 (Win95)？)，您一定会发现这个问题的答案和上一个范例好像！没错！要让程序模拟按了 Windows95/98 屏幕左下方之【开始键】，也只要送一个讯息给桌面 (DeskTop Window) 就可以了！差别只在传入的参数不同而已：
'在声明区中加入以下声明：
Const WM_SYSCOMMAND = &H112&
Const SC_TASKLIST = &HF130 '-------->只有这里不同而已
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 Declare Function GetDesktopWindow Lib "user32" () As Long
Function gf_StartButton() As Boolean
Dim hWnd&
On Error Resume Next
hWnd& = GetDesktopWindow()
Call SendMessage(hWnd&, WM_SYSCOMMAND, SC_TASKLIST, 0&)
gf_StartButton = (Err.Number = 0)
End Function
'要使用时直接呼叫 gf_StartButton 即可！例如：
Private Sub Command1_Click()
gf_StartButton
End Sub
108、如何让表单的标题列变成走马灯？
说穿了，这个功能就是标准的做苦工的程序！不过效果还算不错！
Dim C As String '存放现行视窗的标题列
Dim CO As Integer '存放标题的长度
Dim FS As Long '存放现行视窗的宽度
Private Sub Form_Load()
Timer1.Interval = 100
Me.Caption = "会移动的标题列"
C = Me.Caption
CO = Len(C) + 1
Me.Caption = ""
If Me.BorderStyle <> 2 Then
FS = Me.ScaleWidth + 250
Else
FS = Me.ScaleWidth + 500
End If
End Sub
Private Sub Form_Resize()
If Me.WindowState = 1 Then
FS = 3500
Else
FS = Me.ScaleWidth
End If
End Sub
Private Sub Timer1_Timer()
On Error GoTo ATH
Static C01 As Integer ' 第一个 Counter
Static CO2 As Integer ' 第二个 Counter
Static A As String ' to move caption
Dim R As String ' restore caption
Dim T As String ' restore caption
XX:
If CO > 0 Then
C01 = CO
T = Mid(C, C01, 1)
CO = CO - 1
R = " "
Mid(R, 1) = T
Me.Caption = R & Me.Caption
Else
A = A & " "
R = " "
Mid(R, 1) = A
Me.Caption = R & Me.Caption
End If
If CO2 >= FS Then
CO2 = 0
CO = Len(C)
Me.Caption = ""
GoTo XX
Else
CO2 = CO2 + 50
End If
Exit Sub
ATH:
End Sub
109、如何求出硬盘大小及剩余空间大小
在我们安装软体的时候，在安装选项的画面，常常会出现如下的一些叙述：
选择安装项目大小..............................................10,000,000 Bytes
C 硬盘总空间大小..........................................1,847,328,768 Bytes
C 硬盘剩余空间大小...........................................51,707,904 Bytes
后面的二项是我们硬盘的资讯，我们只要使用一个 API，就可以同时抓到这二个资讯！
请在声明区中放入以下声明：
Private Declare Function GetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceA" (ByVal lpRootPathName As String, lpSectorsPerCluster As Long, lpBytesPerSector As Long, lpNumberOfFreeClusters As Long, lpTotalNumberOfClusters As Long) As Long
'第一个参数是硬盘代号，其他参数如范例中说明
'在程序中呼叫范例如下：
Private Sub Command1_Click()
Dim SectorsPerCluster As Long '参数二：每个 Cluster 的 Sector 数
Dim BytesPerSector As Long '参数三：每个 Sector 的 Byte 数
Dim NumberOfFreeClusters As Long '参数四：剩余的 Cluster 数
Dim TotalNumberOfClusters As Long '参数五：Cluster 总数
Dim FreeBytes As Long '剩余的 Byte 数
Dim TotalBytes As Long '总 Byte 数
Dim dummy As Long '传回值
dummy = GetDiskFreeSpace("c:/", SectorsPerCluster, BytesPerSector, NumberOfFreeClusters, TotalNumberOfClusters)
FreeBytes = NumberOfFreeClusters * SectorsPerCluster * BytesPerSector
TotalBytes = TotalNumberOfClusters * SectorsPerCluster * BytesPerSector
剩余空间大小 = FreeBytes
硬盘大小 = TotalBytes
End Sub
注：在 VB6 以前的各版本 VB，只能使用这种方法来做，但是到了 VB6 已经有了更简单、不　要使用 API 的新作法，就是使用新物件 FileSystemObject，我们将在《问题 99》再来探讨。
110、如何新增、移除【文件功能表】的内容？
在 Windows95/98 环境中，当您开启一份文件后，Windows 便会将这份文件记录在最近开启的文件记录中 (其实是将它放在 Windows/Recent 目录下)。
下一次您要开启同一份文件时，有三种以上的方法：
1、选择【开始】【文件】，就可以看到【文件功能表】的文件清单，再选择文件名称即可！
2、在文件总管文件所在目录下，直接开启该份文件。
3、在文件总管 Windows/Recent 目录下选择该份文件。
若是您想清除这份文件清单，有二个方法：
1、在文件总管中，将 Windows/Recent 目录下的文件通通删除即可。
2、在任务栏上按滑鼠右键，选择【内容】，出现【任务栏内容】选单，选择【开始功能表程序集】，在【文件功能表】框中按【清除】按钮即可。
以上是人工的方法及 Windows 内部之作业流程，若是我们的 VB 程序中，要做到这样的功能，也是很简单的，但是它有什么作用呢？有的，举个例子：
今天 User 在操作我们的程序中，产生了几份文件，可能有文字档、Word 文件、Excel 文件...等，当然您可以事先和 User 约定好，产生的文件固定放在某一个目录下， User 再自行到该目录下去作处理，但是，如果您将产生的文件清单，直接放入【文件功能表】的文件清单中，User 根本不　知道文件放在那里，他只要在【文件功能表】中选择即可，是不是很方便！
'请在声明区中加入以下声明：
Private Declare Sub SHAddToRecentDocs Lib "shell32.dll" (ByVal uFlags As Long, ByVal pv As String)
'新增 (一次增加一笔)
Private Sub Command1_Click()
Dim NewFile As String
NewFile = "c:/doc/880730订购清单.doc" '<----- 要放到【文件功能表】文件清单的文件
Call SHAddToRecentDocs(2, NewFile)
End Sub
'清除 (一次全部清除)
Private Sub Command2_Click()
Call SHAddToRecentDocs(2, vbNullString)
End Sub
111、您认识 VB 的扩展名吗？
我不知道您已经使用 VB 多久时间了，但是今天当您面对一堆乱七八糟的文件时，您能由扩展名来判断那一个文件是属於 VB 的文件吗？恐怕不是每一个人都可以？
您知道以下这些扩展名都是 VB 指定给【设计阶段文件】的扩展名吗？
扩展名用於
VB6 VB5 VB4-32 VB4-16 VB3
.bas Basic 模组
* * * * *
.cls 物件类别模组
* * * * 　
.ctl 使用者控制项文件
* * 　　　
.ctx 使用者控制项二进位文件
* * 　　　
.dca 现用设计师快取文件
* * 　　　
.dep 安装精灵附属文件
* * 　　　
.dob 使用者文件表单
* * 　　　
.dox 使用者文件二进位表单文件
* * 　　　
.dsr 现用设计师文件
* * 　　　
.dsx 现用设计师二进位文件
* * 　　　
.frm 表单文件
* * * * *
.frx 二进位表单文件
* * * * *
.log 载入错误的记录档
* * * * *
.oca 控制项 Typelib 文件
* * * * 　
.pag 属性页文件
* * 　　　
.pgx 二进位属性页文件
* * 　　　
.res 资源档
* * * * 　
.swt Visual Basic 安装精灵范本文件
* * 　　　
.tlb Remote Automation Typelib 文件
* * 　　　
.vbg Visual Basic 群组专案
* * 　　　
.vbl 使用者控制项授权文件
* * 　　　
.vbp Visual Basic 专案
* * * * 　
.vbr Remote Automation 注册文件
* * * * 　
.vbw Visual Basic 专案工作区
* * 　　　
.vbz 精灵启动文件
* * * * *
.wct Webclass 范本文件
* 　　　　
.ocx 控制项文件 * * * * 　
.vbx 控制项文件　　　 * *
.mak Visual Basic 专案 * * * * *
112、完全模拟【开始】中的【运行...】功能
请您现在按下【开始】中的【运行...】，看看【运行...】问话框中的说明，是不是如下：
请输入程序、资料夹、文件或 Internet 资源的名称，Windows 会自动开启。
如果说您我也可以做到这种功能，只要是可开启的、可执行的，通通可以做到，您相信吗？不要怀疑！不但可以做到，而且更让您惊讶的，是程序竟然这么短，只要一行就可以了！
您一定认为要用 API，喔！不是！先别乱猜，这次不用声明 API！直接来看一个例子：
在 Form 中放一个 TextBox，名称为 Text1
Private Sub Command1_Click()
Call Shell("rundll32.exe url.dll,FileProtocolHandler " & Text1, 1)
End Sub
而其中的 Text1 可以输入程序、资料夹、文件或 Internet 资源的名称，也可以输入快捷方式 (shortcut file)，都可以正确执行！
113、模拟【网路上的芳邻】及【我的电脑】中的【连线 / 中断网路磁盘】
在【网路上的芳邻】及【我的电脑】中都有提供【连线网路磁盘】及【中断网路磁盘】的功能，在 VB 的程序中我们一样可以轻易做到。
'请在声明区中加入以下声明及模组：
Declare Function WNetAddConnection Lib "mpr.dll" Alias "WNetAddConnectionA" (ByVal lpszNetPath As String, ByVal lpszPassword As String, ByVal lpszLocalName As String) As Long
Declare Function WNetCancelConnection Lib "mpr.dll" Alias "WNetCancelConnectionA" _
(ByVal lpszName As String, ByVal bForce As Long) As Long
Function AddConnection(MyShareName As String, MyPWD As String, UseLetter As String) As Integer
On Local Error GoTo AddConnection1_Err
AddConnection = WNetAddConnection(MyShareName, MyPWD, UseLetter)
AddConnection_End:
Exit Function
AddConnection1_Err:
AddConnection = Err
MsgBox Error$
Resume AddConnection_End
End Function
Function CancelConnection(DriveLetter As String, Force As Integer) As Integer
On Local Error GoTo CancelConnection_Err
CancelConnection = WNetCancelConnection(DriveLetter, Force)
CancelConnection_End:
Exit Function
CancelConnection_Err:
CancelConnection = Err
MsgBox Error$
Resume CancelConnection_End
End Function
呼叫的方法如下：
连线网路磁盘：传回值 = AddConnection(<共享的路径>, <密码>, <磁盘代号>)
中断网路磁盘：传回值 = CancelConnection(<磁盘代号>, <强迫中断？>)
呼叫实例：
连线网路磁盘：X = AddConnection("//IO/io_c", "", "H:")
中断网路磁盘：X = CancelConnection("H:", True)
注：这个范例实际执行，连线时，NT 及 Novell 之速度相若，但是，在中断时，Novell 之速度明显较慢！
注：以上的方式乃是由程序中直接指定，另外的一个方法是显示问话框由使用者自行设定，这个方法我们在以后将再说明！
114、自制 Round 函数 (取小数点几位)
这一个问题，有网友反应在某些情形下，会造成误差 ( 连 VB6.0 提供的 Round 函数都会造成误差 )，我针对多种情形实际测试，结果很令人惊讶，让人怀疑如何做才会百分之百完全正确，根据测试结果，我原本想拿掉这个单元，但後来我重新写了一个比较笨，但是在有限小数位数内仍然会正确的式子，可是这个功能只支援小数点，不再支援整数以上的 Round 功能，如下：
'传入的参数和之前相同，第一个是要判断的数字，第二个是要取小数几位。
Public Function round(num As Double, pos As Integer) As Double
'整数以上不处理
If pos <= 0 Then
round = Format(num, "#")
Exit Function
End If
Dim i As Integer
Dim formatstr As String
'拼凑 Format 的格式
formatstr = "#."
For i = 1 To pos
formatstr = formatstr & "0"
Next
round = Format(num, formatstr)
End Function
115、如何找出 Windows 目录的正确路径？
有时候我们在程序中必须用到 Windows 的目录，以存取 Windows 目录下的文件，照理说，这应该是最简单的功能，前提是每个人在 Setup Windows 必须采用 Windows 的预设目录名称，也就是 C:/Windows，但是常常不是这样，有时候由於要使新旧版本共存，或者其他原因，有人会将 Windows 目录改成 c:/win95、c:/win98、Windows95 或 Windows98......
若是程序中必须用到 Windows 目录，要找到正确的路径，做法如下：
'在声明区中加入以下声明：
Const MAX_PATH = 260
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Public Function GetWinPath()
Dim strFolder As String
Dim lngResult As Long
strFolder = String(MAX_PATH, 0)
lngResult = GetWindowsDirectory(strFolder, MAX_PATH)
If lngResult <> 0 Then
GetWinPath = Left(strFolder, InStr(strFolder, Chr(0)) - 1)
Else
GetWinPath = ""
End If
End Function
'在程序中使用方法如下：
Private Sub Command1_Click()
Call MsgBox("您电脑中 Windows 目录的正确路径是： " & GetWinPath, vbInformation)
End Sub
VB问题全功略（24） [查找本页请按Ctrl+F]
［上一页］（24）［下一页］
116、让您的音乐 CD 动起来！
117、如何求出磁盘大小及剩余空间大小 (更简单的 VB6 新功能)
118、反向思考---怎样让程序跑慢一点？(二)
119、列出电脑中所有磁盘
120、模拟【网路上的芳邻】及【我的电脑】中的【连线 / 中断网路磁盘】(二)
116、让您的音乐 CD 动起来！
之前，我们讨论过，但是只会开启及关闭，用处还不太大，今天，我们来看看要怎么让您的音乐 CD 动起来！
'请在声明区中加入以下声明： ( 和 "开启及关闭CD－Rom的门" 相同的声明)
Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
'在 Form 中加入二个 CommandButton，分别命名为 cmdPlay 及 cmdStop 并加入以下程序码：
Sub cmdPlay_Click()
Dim lRet As Long
Dim nCurrentTrack As Integer
'开启装置
lRet = mciSendString("open cdaudio alias cd wait", 0&, 0, 0)
'设定时间格式为 Tracks ( 预设值是 milliseconds )
lRet = mciSendString("set cd time format tmsf", 0&, 0, 0)
'从头开始播放
lRet = mciSendString("play cd", 0&, 0, 0)
'您也可以指定要从第几首歌 (Track) 开始播放，例如以下指定从第 3 首歌开始播放
'nCurrentTrack = 3
lRet = mciSendString("play cd from" & Str(nCurrentTrack), 0&, 0, 0)
End Sub
' 记得在播放完毕时要关闭装置
Sub cmdStop_Click()
Dim lRet As Long
'停止播放
lRet = mciSendString("stop cd wait", 0&, 0, 0)
DoEvents '给 Windows一点时间去处理其他事件
'关闭装置
lRet = mciSendString("close cd", 0&, 0, 0)
End Sub
注：如果您想指定从第几首歌开始播放，只要将上面绿色那行程序之 Mark 拿掉，改掉数字即可！
注：原作者原来的声明是在 mmsystem.dll，现在要使用 winmm.dll 才可以！
117、如何求出磁盘大小及剩余空间大小 (更简单的 VB6 新功能)
在《问题 91》时，我们使用了 API 来求出磁盘大小及剩余空间大小，也就是下方资讯之后二项：
《在我们安装软体的时候，在安装选项的画面，常常会出现如下的一些叙述：》
选择安装项目大小..............................................10,000,000 Bytes
C 磁碟总空间大小..........................................1,847,328,768 Bytes
C 磁碟剩余空间大小...........................................51,707,904 Bytes
在 VB6 以前我们只能如此做，对于不熟悉 API 的人来说，很难，但是在 VB6 就变得很简单，因为在 VB6 中提供了一个新物件：FileSystemObject
让我们实№来自看例子：
Private Sub Command1_Click()
Dim fso As New FileSystemObject, drv As Drive
Set drv = fso.GetDrive(fso.GetDriveName("c:"))
剩余空间大小 = drv.FreeSpace
磁盘大小 = drv.TotalSize
End Sub
使用上面的方法算出的结果和使用 GetDiskFreeSpace API 算出的结果是完全一样的！
118、反向思考---怎样让程序跑慢一点？(二)
原来我们提到了使用 Sleep API 来达到让程序暂停的方法，方法很简单，程序码也很简短，但是美中不足的是，它只能用在 32 位元的环境中！
难道在 16 位元的环境中就没办法了吗？或者，一定要使用 API 吗？
还是有办法的，而且不用 API，最棒的是所有版本的 VB 都可使用！
'在您的程序中，加入以下的模组：
Public Sub Delay(HowLong As Date)
TempTime = DateAdd("s", HowLong, Now)
While TempTime > Now
DoEvents '让 windows 去处理其他事
Wend
End Sub
'在程序中只要如下使用即可：
Private Sub Command1_Click()
Delay 5
End Sub
119、列出电脑中所有磁盘
我们曾讨论过使用 GetDriveType API 再加上回圈一个一个判断磁盘的型态，再列在 ListBox 中供选择。但是在实际应用程序中，有时候我们根本不需要知道各个磁盘的型态，我们的目的只是很单纯地让使用者来挑选档案的位置而已！例如趋势科技的 Pccillin 要从磁盘 Upgrade 病毒码时，它会询问您磁盘代号，就是使用这种作法！
这时候，我们可以换一种更快的方式，(只是有人认为不能顺便列出磁盘型态仍是一种缺点) 如下：
'在声明区中加入以下声明：
Const LB_DIR = &H18D 'LB 即是 ListBox 的缩写
Const DDL_DRIVES = &H4000
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
Public Function AddDrives2ListBox(lhWnd As Long)
Call SendMessage(lhWnd, LB_DIR, DDL_DRIVES, "*")
End Function
'而程序中之使用方法如下：(只有一个参数，就是 ListBox 的 hwnd)
Private Sub Form_Load()
AddDrives2ListBox List1.hwnd
End Sub
有人问我，ListBox 的很多功能都和 ComboBox 很像，这个例子，可以使用 ComboBox 吗？
可以的，也不难，将声明区的声明改成：
Const CB_DIR = &H145 'CB 即是 ComboBox 的缩写
Const DDL_DRIVES = &H4000
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
Public Function AddDrives2ComboBox(lhWnd As Long)
Call SendMessage(lhWnd, CB_DIR, DDL_DRIVES, "*")
End Function
'而程序中之使用方法如下：(只有一个参数，就是 ComboBox 的 hwnd)
Private Sub Form_Load()
AddDrives2ComboBox Combo1.hwnd
End Sub
120、模拟【网路上的芳邻】及【我的电脑】中的【连线 / 中断网路磁盘】(二)
对于实际的网路作业，WNet API 是非常有用的，例如：我们在《问题93》模拟【网路上的芳邻】及【我的电脑】中的【连线 / 中断网路磁盘】中我们就使用了 WNetAddConnection 及 WNetCancelConnection 这二个 API 很有效地来处理连线及中断网路磁盘，但是我们不知道每一个使用者电脑中的实际设定，使用直接指定的强迫连线及中断，或许会影响使用者原本电脑中的设定。
下面的方法是一个比较中性的作法，就是出现【连线 / 中断网路磁盘】的问话框，让使用者根据自己电脑的情形，来决定要连线的网路磁盘要对应到自己的那一个磁盘？要中断的又是那一个对应的磁盘？其实，这个方法更接近实际模拟【网路上的芳邻】及【我的电脑】中的【连线 / 中断网路磁盘】！
请在声明区中加入以下声明及模组：
Private Declare Function WNetConnectionDialog Lib "mpr.dll" (ByVal hwnd As Long, ByVal dwType As Long) As Long
Private Declare Function WNetDisconnectDialog Lib "mpr.dll" (ByVal hwnd As Long, ByVal dwType As Long) As Long
Sub ShowMapDrives(hwnd As Long)
WNetConnectionDialog hwnd, 1
End Sub
Sub ShowUnMapDrives(hwnd As Long)
WNetDisconnectDialog hwnd, 1
End Sub
'程序中使用方式如下：
Private Sub Command1_Click()
'出现连线网路磁盘问话框
ShowMapDrives Me.hwnd
End Sub
Private Sub Command2_Click()
'出现中断网路磁盘问话框
ShowUnMapDrives Me.hwnd
End Sub
121、取得印表机的连接埠
在测试上一个《问题 100》模拟【网路上的芳邻】及【我的电脑】中的【连线 / 中断网路磁碟机】 (二) 时，我们用到了 WNetConnectionDialog API，这个 API 又让我想到了另一个小功能！
您设定过印表机吗，如果有，在设定印表机时，设定问话框中有一个 Tab 是【详细资料】页，在此页中有一个按钮是让我们《取得印表机连接埠》，WNetConnectionDialog 这个 API 的功能之一就是叫出《取得印表机连接埠》问话框！
'一样在声明区中加入以下声明：
Private Declare Function WNetConnectionDialog Lib "mpr.dll" (ByVal hWnd As Long, ByVal dwType As Long) As Long
Sub ShowPrinterPort(hWnd As Long)
WNetConnectionDialog hWnd, 2
End Sub
'在程序中使用方法如下：
Private Sub Command1_Click()
ShowPrinterPort Me.hWnd
End Sub
122、读取及设定文件的属性
当我们在任一个文件上按滑鼠右键，选择【内容】，在文件内容的【一般】页签中我们可以看到每一个文件有四个属性：保存、只读、隐藏及系统。
使用 GetFileAttributes 及 SetFileAttributes 二个 API 我们就可以读取及设定这四个属性。
'请在声明区中加入以下声明：
'设定文件属性
Private Declare Function SetFileAttributes Lib "kernel32" Alias "SetFileAttributesA" (ByVal lpFileName As String, ByVal dwFileAttributes As Long) As Long
'读取文件属性
Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long
Const FILE_ATTRIBUTE_READONLY = &H1 '设定为只读
Const FILE_ATTRIBUTE_HIDDEN = &H2 '设定为隐藏
Const FILE_ATTRIBUTE_SYSTEM = &H4 '设定为系统
Const FILE_ATTRIBUTE_ARCHIVE = &H20 '设定为保存
Const FILE_ATTRIBUTE_NORMAL = &H80 '设定为一般 (取消前四种属性)
'要设定二种以上的属性可以用 or 串联以上之属性，来看看例子：
'设定 db1.mdb 为只读
SetFileAttributes "c:/db1.mdb", FILE_ATTRIBUTE_READONLY
'设定 db1.mdb 为只读 + 隐藏
SetFileAttributes "c:/db1.mdb", FILE_ATTRIBUTE_READONLY Or FILE_ATTRIBUTE_HIDDEN
'设定 db1.mdb 为只读 + 隐藏 + 系统 + 保存
SetFileAttributes "c:/db1.mdb", FILE_ATTRIBUTE_READONLY Or FILE_ATTRIBUTE_HIDDEN _
Or FILE_ATTRIBUTE_SYSTEM Or FILE_ATTRIBUTE_ARCHIVE
'取消 db1.mdb 所有设定
SetFileAttributes "c:/db1.mdb", FILE_ATTRIBUTE_NORMAL
'要读取文件目前的属性，则是用 GetFileAttributes API，以读取 db1.mdb 为例：
MsgBox GetFileAttributes("c:/db1.mdb")
'返回值如上面的常数声明值，例如：
'若返回值为 6 ( =2+4 ) 表示此文件为隐藏 + 系统
'但是若返回值为 128 表示此文件未设定任何属
123、避免 Null 产生的错误
当我们从资料库读出资料时，有的栏位之内容可能为 Null，若不加以处理而要将资料搬给某一栏位时，会有错误产生，虽然 VB 本身有提供一个 IsNull 函数以供判断，但是您知道吗，我写了这么多年的 VB 资料库程序，从来没有用过 IsNull 来判断资料库栏位值，为什么呢？我又怎么做呢？
其实很简单，我不管从资料库读出来的是不是 Null，写法一律如下：
Text1.text = rs1("Field1") & ""
如果这个栏位的值是 Null，加上 ( ＆　〃 ) 之後就变成了 "" 了！
但是要小心，我的新同事们常常会犯一个错误，我们看看以下二个式子：
1、Text1.text = Trim(rs1("Field1")) & "" ' ( 可能是错的 )
2、Text1.text = Trim(rs1("Field1") & "") ' ( 这样写才对 )
第一个式子如果栏位值是 Null，使用 trim$ 便会产生错误，对於这些状况，其实只要记住一个原则即可：
不管从资料库读出之资料要做什么动作，不管三七二十一先加上 ( ＆　〃 ) 就对了
再来看看一个例子，以加深印象：
Text1.text = Format( (rs1("Field1") & ""), "yymmdd")
124、如何找出 Windows 目录的正确路径？
有时候我们在程序中必须用到 Windows 的目录，以存取 Windows 目录下的文件，照理说，这应该是最简单的功能，前提是每个人在 Setup Windows 必须采用 Windows 的预设目录名称，也就是 C:/Windows，但是常常不是这样，有时候由于要使新旧版本共存，或者其他原因，有人会将 Windows 目录改成 c:/win95、c:/win98、Windows95 或 Windows98......
若是程序中必须用到 Windows 目录，要找到正确的路径，做法如下：
'在声明区中加入以下声明：
Const MAX_PATH = 260
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Public Function GetWinPath()
Dim strFolder As String
Dim lngResult As Long
strFolder = String(MAX_PATH, 0)
lngResult = GetWindowsDirectory(strFolder, MAX_PATH)
If lngResult <> 0 Then
GetWinPath = Left(strFolder, InStr(strFolder, Chr(0)) - 1)
Else
GetWinPath = ""
End If
End Function
'在程序中使用方法如下：
Private Sub Command1_Click()
Call MsgBox("您电脑中 Windows 目录的正确路径是： " & GetWinPath, vbInformation)
End Sub
125、如何找出 System 目录的正确路径？
和《问题104》如何找出 Windows 目录的正确路径？一样，由于有很多系统文件都放在 System 目录下，有时候我们在程序中必须用到 System 的目录，以存取 System 目录下的文件，但是有时候由於要使新旧版本共存，或者其他原因，有人会将 Windows 目录改成 c:/win95、c:/win98、Windows95 或 Windows98......
若是程序中必须用到 System 目录，要找到正确的路径，做法如下：
'在声明区中加入以下声明：
Const MAX_PATH = 260
Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Public Function GetSystemPath()
Dim strFolder As String
Dim lngResult As Long
strFolder = String(MAX_PATH, 0)
lngResult = GetSystemDirectory(strFolder, MAX_PATH)
If lngResult <> 0 Then
GetSystemPath = Left(strFolder, InStr(strFolder, Chr(0)) - 1)
Else
GetSystemPath = ""
End If
End Function
'在程序中使用方法如下：
Private Sub Command1_Click()
Call MsgBox("您电脑中 System 目录的正确路径是：" & GetSystemPath, vbInformation)
End Sub
126、如何找出 Temp 目录的正确路径？
有时候，我们的 VB 程序在执行时，会产生一些文件，或许只是暂存档，这时您可以考虑放在 Windows 的 Temp 目录下，这个目录在预设的情形下是在 c:/windows/temp，但是， User 有时候由于要使新旧版本共存，或者其他原因，有人会将 Windows 目录改成 c:/win95、c:/win98、Windows95 或 Windows98......
若是程序中必须用到 Temp 目录，要找到正确的路径，做法如下：
'在声明区中加入以下声明：
Const MAX_PATH = 260
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Public Function GetTmpPath()
Dim strFolder As String
Dim lngResult As Long
strFolder = String(MAX_PATH, 0)
lngResult = GetTempPath(MAX_PATH, strFolder)
If lngResult <> 0 Then
GetTmpPath = Left(strFolder, InStr(strFolder, Chr(0)) - 1)
Else: GetTmpPath = ""
End If
End Function
'在程序中使用方法如下：
Private Sub Command1_Click()
Call MsgBox("您电脑中 Temp 目录的正确路径是" & GetTmpPath, vbInformation)
End Sub
127、建立 Windows95/98 的快捷方式
在前面我们提到过快捷方式，不过当时提到的快捷方式是专门用于连结 Internet 的网页使用的，现在我们要谈的则是在 Windows95/98 中的一般快捷方式，也就是要放在【开始】或【桌面】上，方便使用者启动程序的快捷方式！
'请在声明区中加入以下的声明：(以下为 VB4-32 / VB5)
'VB4-32
Declare Function fCreateShellLink Lib "STKIT432.DLL" (ByVal lpstrFolderName as String, ByVal lpstrLinkName as String, ByVal lpstrLinkPath as String, ByVal lpstrLinkArgs as String) As Long
'VB5
Declare Function OSfCreateShellLink Lib "VB5STKIT.DLL" Alias "fCreateShellLink" (ByVal lpstrFolderName As String, ByVal lpstrLinkName As String, ByVal lpstrLinkPath As String, ByVal lpstrLinkArguments As String) As Long
'参数说明：
lpstrFolderName 要放置快捷方式的位置，但是指的是对应到【开始】的【程序】的相对位置
【程序】的实际目录位置是 C:/Windows/Start Menu/Programs
【桌面】的实际目录位置是 C:/Windows/Desktop
所以如果想将快捷方式放在桌面上，此参数的设定值应为 "../../Desktop"
lpstrLinkName 快捷方式要显示出来的说明文字
lpstrLinkPath 快捷方式要开启或执行的文件的实际位置
lpstrLinkArgs 开启或执行的文件若需要参数，则放在这　
'在程序中使用的方法如下：
lngResult = fCreateShellLink("../../Desktop", "记事本捷径", " c:/windows/notepad.exe","")
128、如何用 VB 呼叫出在【查找：所有文件】中的【浏览资料夹】问话框？
相信大家都使用过 Windows 95/98 的【开始】【查找】【文件或资料夹...】功能，当然【查找】的功能不一定要从【开始】开始，在 Windows 的很多地方，例如【资源管理器】或【我的电脑】...等，都可以按下滑鼠右键来使用【查找】的功能。
在【查找：所有文件】问话框中，在【名称及位置】页中，有一个【浏览】的按钮，按下后会出现一个大家似曾相识的问话框，叫作【浏览资料夹】问话框，在这个问话框中，您可以看到电脑中所有的磁盘及资料夹，您知道在 VB中要如何呼叫它吗？
'请在声明区中加入以下声明：
Private Const BIF_RETURNONLYFSDIRS = 1
Private Const BIF_DONTGOBELOWDOMAIN = 2
Private Const MAX_PATH = 260
Private Declare Function SHBrowseForFolder Lib "shell32" _
(lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Type BrowseInfo
hWndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
'在 Form 中放一个 CommandButton，并加入以下程序：
Private Sub Command1_Click()
Dim lpIDList As Long
Dim sBuffer As String
Dim szTitle As String
Dim tBrowseInfo As BrowseInfo
szTitle = "请选择要开始搜寻的资料夹" '<-- 此标题可根据　要自行更改
With tBrowseInfo
.hWndOwner = Me.hWnd
.lpszTitle = lstrcat(szTitle, "")
.ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN
End With
lpIDList = SHBrowseForFolder(tBrowseInfo)
If (lpIDList) Then
sBuffer = Space(MAX_PATH)
SHGetPathFromIDList lpIDList, sBuffer
sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
MsgBox sBuffer
End If
End Sub
'好了，执行您的程序，按下按钮看看结果吧！
129、让您的文字框有 Undo / Redo 的功能
很多软件都有提供 Undo / Redo 的功能，Microsoft 的产品都可以提供多次 Undo 反悔，功能更强大！
在 VB 的程序中，我们也可以提供这样的功能！不过只能 Undo / Redo 一次
'在声明区中加入以下声明：
'32位元
'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 EM_UNDO = &HC7
'16位元
Private 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 EM_UNDO = WM_USER + 23
'在程序中使用的方式如下： ( Undo Text1 中的输入 )
Private Sub Command1_Click()
Dim UndoResult As Long
UndoResult = SendMessage(Text1.hwnd, EM_UNDO, 0, 0)
'传回值 UndoResult = -1 表示 Undo 不成功
End Sub
'使用以上的方法，第一次是 Undo ，第二次就等于是 Redo
130、如何使点矩阵印表机一次只印一行
VB 有提供一个 Printer 物件来帮我们做列印，但是，当我们使用点矩阵印表机列印时，若希望每次只列印一行资料后，印表机不要自动跳页，继续等待列印！这时候往往造成很多人的困扰，因为：若不使用 NewPage 和 EndDoc 方法就不会立刻印出，但是用了又会跳页。
这时候，我们就不能再使用 Printer 物件，然而我们可以用以前在 Dos 时代使用的方法如下：
Open "PRN" For Output As #1
Print #1,"列印内容"
但是有一点必须注意的是：上面这个方式绝对可以单行列印英文，但是若你想印中英文, 你的印表机必须有内建中文字体才行！
VB问题全功略（27） [查找本页请按Ctrl+F]
［上一页］（27）［下一页］
131、Printer 物件如何控制打印机跳页至指定的地方?
132、如何在按下 Enter 键之后，自动让 Focus 移到下一个物件？
133、如何隐藏及显示任务栏？
134、取得应用程序执行的路径
135、清除 ListBox 及 ComboBox 中重复的项目
131、Printer 物件如何控制打印机跳页至指定的地方?
在网站上有人提出这样的问题：
用 VB6 写一打印程序,打印机是点矩阵的,而纸张为公司特别定做的,所以当用 EndDoc 方法打印时,无法控制打印机跳页至指定的地方(就是可用手撕纸的那一条虚线)
VB 的 Printer 物件提供的 EndDoc 会自动根据我们设定的纸张大小，自动跳到下一页，但是当我们所使用的纸张是特殊大小时 (很多套印的表格都是特殊大小的尺寸)，若要让打印机的跳页正常，并不需更改我们的程序，要更改的是我们机器上该打印机的纸张大小的设定。
1、开启【我的电脑】，开启【打印机】(或由【开始】或【控制面板】开启打印机)。
2、在该点矩阵打印机上按鼠标右键选择【内容】，出现该打印机的【内容】问话框。
3、选择【纸张】页签。
4、纸张大小选择【自订】，会出现【使用者定义大小】问话框。
5、输入纸张的宽度和长度，单位有二种 ( 0.01英寸 / 0.1公　 )
用以上的方法设定好后，您就可以不用管纸张大小了，下一次它换页时就会自动跳页至指定的地方。
132、如何在按下 Enter 键之后，自动让 Focus 移到下一个物件？
如果您希望使用者在 TextBox 中按下 Enter 键之后，能够让 Focus 在各个物件之间游移，在 KeyPress 事件中您就必须判断是否有按下 Enter 键，如果有的话，您就必须取消 Enter 键，并送出一个 Tab 键。
在 VB 中，当您送出一个 Tab 键后，游标会依照 TabIndex 的顺序，在各物件之间移动。
若要照 TabIndex 顺序移动，指令为 SendKeys "{tab}"
若要照 TabIndex 反顺序移动，指令为 SendKeys "+{tab}"
其实以上的方法不只适用于 TextBox 物件，很多物件都适用这个原则，但是 CommandButton 就不行了！因为 CommandButton 根本就没有 KeyPress 事件！
以下是一段范例程序：
Sub Text1_KeyPress (KeyAscii As Integer)
If KeyAscii = 13 Then
SendKeys "{tab}"
KeyAscii = 0
End If
End Sub
133、如何隐藏及显示任务栏？
有时候，我们希望在我们的程序执行中，将任务栏隐藏，让桌面变得比较清爽，等到我们的程序执行完毕之后，再将任务栏显示出来，这时就要用到 SetWindowPos 这个 API 了！
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
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Const SWP_HIDEWINDOW = &H80 '隐藏视窗
Const SWP_SHOWWINDOW = &H40 '显示视窗
'在程序中若要隐藏任务栏
Private Sub Command1_Click()
Dim Thwnd As Long
Thwnd = FindWindow("Shell_traywnd", "")
Call SetWindowPos(Thwnd, 0, 0, 0, 0, 0, SWP_HIDEWINDOW)
End Sub
'在程序中若要再显示任务栏
Private Sub Command2_Click()
Dim Thwnd As Long
Thwnd = FindWindow("Shell_traywnd", "")
Call SetWindowPos(Thwnd, 0, 0, 0, 0, 0, SWP_SHOWWINDOW)
End Sub
134、取得应用程序执行的路径
有时候执行我们的应用程序时，会用到一些和应用程序相关的文件，例如资料库、图档、文字档...等，这些文件我们通常都会放在和应用程序相同的目录或子目录中，于是在我们的应用程序中便有抓取应用程序现行目录的　求，在此我们介绍二种方法：
1、App.Path：返回值自动转为大写。
2、CurDir：返回值为大小写混合。
使用范例如下：
Private Sub Command1_Click()
Text1.text = App.Path
Text2.text = CurDir
End Sub
135、清除 ListBox 及 ComboBox 中重复的项目
当我们要将一大堆资料加入 ListBox 或 ComboBox 时，为了不让 ListBox 或 ComboBox 中的项目重复，有些人会在将新项目加入 ListBox 或 ComboBox 时，就先作项目比对，资料没有重复时，才将资料加入 ListBox 或 ComboBox 中。
但是如果我们将资料统统加入 ListBox 或 ComboBox 之后，再来执行比对动作，不但程序容易维护，而且速度会加快一点点，以下的模组就是做项目比对，以清除 ListBox 或 ComboBox 中重复的项目。
模组中需要传入二个参数，说明如下：
1、控制项名称：可传入 ListBox 或 ComboBox 的名称。
2、是否分别大小写：True 表示要分别大小写，False 则不分大小写。
Sub RemoveDups(lst As Control, comptype As Boolean)
Dim lPos As Long '原始比对项目 index
Dim lCompPos As Long '待比对项目 index
Dim sComp As String '原始比对字串
Dim sComptype As Long '0(binary) / 1(textual) 比对
lPos = 0
If comptype Then sComptype = 0 Else sComptype = 1
Do While lPos < (lst.ListCount - 1)
sComp = lst.List(lPos)
lCompPos = lPos + 1
Do While lCompPos < lst.ListCount
If StrComp(sComp, lst.List(lCompPos), sComptype) = 0 Then
lst.RemoveItem lCompPos
lCompPos = lCompPos - 1
End If
lCompPos = lCompPos + 1
Loop
lPos = lPos + 1
Loop
End Sub
'在程序中使用方式如下：
'要分别大小写
Private Sub Command1_Click()
RemoveDups List1, True
RemoveDups Combo1, True
End Sub
'不分别大小写
Private Sub Command2_Click()
RemoveDups List1, False
RemoveDups Combo1, False
End Sub
136、找出电脑中已经安装的输入法
'在 Form 中加入一个 ListBox，在声明区中加入以下声明：
Private Declare Function GetKeyboardLayoutList Lib "user32" (ByVal nBuff As Long, lpList As Long) As Long
Private Declare Function ImmGetDescription Lib "imm32.dll" Alias "ImmGetDescriptionA" (ByVal HKL As Long, ByVal lpsz As String, ByVal uBufLen As Long) As Long
Private Declare Function ImmIsIME Lib "imm32.dll" (ByVal HKL As Long) As Long
'在 Form_Load 中加入以下程序码：
Private Sub Form_Load()
Dim No As Long, i As Long
Dim hKB(24) As Long, bufflen As Long
Dim buff As String, RetStr As String, RetCount As Long
buff = String(255, 0)
No = GetKeyboardLayoutList(25, hKB(0))
For i = 1 To No
If ImmIsIME(hKB(i - 1)) = 1 Then
bufflen = 255
RetCount = ImmGetDescription(hKB(i - 1), buff, bufflen)
RetStr = Left(buff, RetCount)
List1.AddItem RetStr
Else
RetStr = "English(American)"
List1.AddItem RetStr
End If
Next
End Sub
137、如何将一串阿拉伯数字转成中文数字字串？
在我们的应用系统中，有时候要产生一些比较正式的报表 (套表)，例如合约书、电脑开票....等，在这些报表中，关于数字的部份，尤其是金额的部份，为了防止纠纷的产生，通常都必须将阿拉伯数字转成中文大写数字，这种工作，人工做起来很简单，电脑来做，可就要花点工夫了！
以下几个 Function 就是用来处理这个工作的，其中最主要的就是 numbertoword 这个 Function，程序中要呼叫的也就是这个 Function，其他三个 Function 只是配合这个 Function 而已。
'在程序中只要如右使用即可：返回中文数字 = numbertoword( 阿拉伯数字 )
程序码如下：
Public Function numbertoword(number As String) As String
'-------------------------------------------------------------------
'目的:转换一串阿拉伯数字为中文数字
'参数:一串阿拉伯数字
'返回值:转换后的一串中文数字
'---------------------------------------------------------------------------------------------------------------------------------
'注: 此一 Function 必须包含以下三个 Function
'1.mapword:转换单一数字为国数字(0123456789->零壹贰参肆伍陆柒捌玖)
'2.StringCleaner:清除字串中不要的字元
'3.convtoword:将传入的四个数字转成中文数字字串(1234->壹仟贰佰参拾肆)
'---------------------------------------------------------------------------------------------------------------------------------
Dim wlength As Integer '数字字串总长度
Dim wsection As Integer '归属的段落 (0:万以下/1:万/2:亿/3:兆)
Dim wcount As Integer '剩余的数字字串长度
Dim wstr As String '暂存字串
Dim wstr1 As String '暂存字串-兆
Dim wstr2 As String '暂存字串-亿
Dim wstr3 As String '暂存字串-万
Dim wstr4 As String '暂存字串-万以下
'未输入或0不做
'-----------------------------------------------
If Trim(number) = "" Or Trim(number) = "0" Then
numbertoword = "零"
Exit Function
End If
'-----------------------------------------------
wlength = Len(number)
wsection = wlength / 4
wcount = wlength Mod 4
'-----------------------------------------------
'每四位一组, 分段 (兆/亿/万/万以下)
If wcount = 0 Then
wcount = 4
wsection = wsection - 1
End If
'----------------------------------------------
'大于兆的四位数转换
If wsection = 3 Then
'抓出大于兆的四位数
wstr = Left(Format(number, "0000000000000000"), 4)
'转换
wstr1 = convtoword(wstr)
If wstr1 <> "零" Then wstr1 = wstr1 & "兆"
End If
'----------------------------------------------
'大于亿的四位数转换
If wsection >= 2 Then
'抓出大于亿的四位数
If Len(number) > 12 Then
wstr = Left(Right(number, 12), 4)
Else
wstr = Left(Format(number, "000000000000"), 4)
End If
'转换
wstr2 = convtoword(wstr)
If wstr2 <> "零" Then wstr2 = wstr2 & "亿"
End If
'----------------------------------------------
'大于万的四位数转换
If wsection >= 1 Then
'抓出大于万的四位数
If Len(number) > 8 Then
wstr = Left(Right(number, 8), 4)
Else
wstr = Left(Format(number, "00000000"), 4)
End If
'转换
wstr3 = convtoword(wstr)
If wstr3 <> "零" Then wstr3 = wstr3 & "万"
End If
'----------------------------------------------
'万以下的四位数转换
'抓出万以下的四位数
If Len(number) > 4 Then
wstr = Right(number, 4)
Else
wstr = Format(number, "0000")
End If
'转换
wstr4 = convtoword(wstr)
'----------------------------------------------
'组合最多四组字串(兆/亿/万/万以下)
numbertoword = wstr1 & wstr2 & wstr3 & wstr4
'去除重复的零 ('零零'-->'零')
Do While InStr(1, numbertoword, "零零")
numbertoword = StringCleaner(numbertoword, "零零")
Loop
'----------------------------------------------
'去除最左边的零
If Left(numbertoword, 1) = "零" Then
numbertoword = Mid(numbertoword, 2)
End If
'----------------------------------------------
'去除最右边的零
If Right(numbertoword, 1) = "零" Then
numbertoword = Mid(numbertoword, 1, Len(numbertoword) - 1)
End If
End Function
Public Function mapword(no As String) As String
'-----------------------------------------------------------
'目的:转换单一数字为国数字(0123456789->零壹贰参肆伍陆柒捌玖)
'参数:数字(0123456789)
'返回值:国数字(零壹贰参肆伍陆柒捌玖)
'-----------------------------------------------------------
Select Case no
Case "0"
mapword = "零"
Case 1
mapword = "壹"
Case "2"
mapword = "贰"
Case "3"
mapword = "参"
Case "4"
mapword = "肆"
Case "5"
mapword = "伍"
Case "6"
mapword = "陆"
Case "7"
mapword = "柒"
Case "8"
mapword = "捌"
Case "9"
mapword = "玖"
End Select
End Function
Public Function StringCleaner(s As String, Search As String) As String
'-----------------------------------------------------------
'目的:清除字串中不要的字元
'参数:1.完整字串. 2.要清除的字元(可含多字元)
'返回值:清除后的字串
'''此段之主要目的在去除重复的 '零' ('零零'-->'零')
'-----------------------------------------------------------
Dim i As Integer, res As String
res = s
Do While InStr(res, Search)
i = InStr(res, Search)
res = Left(res, i - 1) & Mid(res, i + 1)
Loop
StringCleaner = res
End Function
Public Function convtoword(wstr As String) As String
'-----------------------------------------------------------
'目的:将传入的四个数字转成中文数字字串(1234->壹仟贰佰参拾肆)
'参数:4位数的数字 (前面空白补0)
'返回值:转换后的中文数字字串
'-----------------------------------------------------------
Dim tempword As String
'仟位数
tempword = mapword(Mid(wstr, 1, 1))
If tempword <> "零" Then tempword = tempword & "仟"
convtoword = convtoword & tempword
'佰位数
tempword = mapword(Mid(wstr, 2, 1))
If tempword <> "零" Then tempword = tempword & "佰"
convtoword = convtoword & tempword
'拾位数
tempword = mapword(Mid(wstr, 3, 1))
If tempword <> "零" Then tempword = tempword & "拾"
convtoword = convtoword & tempword
'个位数
tempword = mapword(Mid(wstr, 4, 1))
convtoword = convtoword & tempword
'去除最右边的零
Do While Right(convtoword, 1) = "零" And Len(convtoword) > 1
convtoword = Mid(convtoword, 1, Len(convtoword) - 1)
Loop
End Function
'在程序中只要如右使用即可：返回中文数字 = numbertoword( 阿拉伯数字 )
'-----------------------------------------------------------
'程序中使用实例 ( 加上错误判断 )
'在 Form 中放二个 TextBox 及一个 CommandButton
'Text1 输入数字, Text2 显示转换结果
'-----------------------------------------------------------
Private Sub Command1_Click()
Text2 = ""
'去除小数点
If InStr(1, Text1, ".") <> 0 Then
Text1 = Mid(Text1, 1, InStr(1, Text1, ".") - 1)
End If
'去除逗点
Text1 = StringCleaner(Text1, ",")
'判断不含非数字
Dim i As Integer
Dim werr As String
For i = 1 To Len(Text1)
If Asc(Mid(Text1, i, 1)) < 48 Or Asc(Mid(Text1, i, 1)) > 57 Then
werr = "Y"
Exit For
End If
Next
If werr = "Y" Then
MsgBox "不可含非数字"
'focus 回到 text1 方便输入
Text1.SetFocus
Text1.SelStart = 0
Text1.SelLength = Len(Text1)
Exit Sub
End If
'主要程序只一行-----------
Text2 = numbertoword(Text1)
'-------------------------
'focus 回到 text1 方便输入
Text1.SetFocus
Text1.SelStart = 0
Text1.SelLength = Len(Text1)
End Sub
138、如何将一串阿拉伯数字转成英文数字字串？
在在同样情形下，有些情况，我们也必须将阿拉伯数字转成英文数字，以下这个 Function 就是用来处理这个工作的。
'在程序中只要如右使用即可：返回英文数字 = numtoword( 阿拉伯数字 )
先看看结果：
程序码如下：
Public Function numtoword(numstr As Variant) As String
'----------------------------------------------------
' The best data type to feed in is
' Decimal, but it is up to you
'----------------------------------------------------
Dim tempstr As String
Dim newstr As String
numstr = CDec(numstr)
If numstr = 0 Then
numtoword = "zero "
Exit Function
End If
If numstr > 10 ^ 24 Then
numtoword = "Too big"
Exit Function
End If
If numstr >= 10 ^ 12 Then
newstr = numtoword(Int(numstr / 10 ^ 12))
numstr = ((numstr / 10 ^ 12) - Int(numstr / 10 ^ 12)) * 10 ^ 12
If numstr = 0 Then
tempstr = tempstr & newstr & "billion "
Else
tempstr = tempstr & newstr & "billion, "
End If
End If
If numstr >= 10 ^ 6 Then
newstr = numtoword(Int(numstr / 10 ^ 6))
numstr = ((numstr / 10 ^ 6) - Int(numstr / 10 ^ 6)) * 10 ^ 6
If numstr = 0 Then
tempstr = tempstr & newstr & "million "
Else
tempstr = tempstr & newstr & "million, "
End If
End If
If numstr >= 10 ^ 3 Then
newstr = numtoword(Int(numstr / 10 ^ 3))
numstr = ((numstr / 10 ^ 3) - Int(numstr / 10 ^ 3)) * 10 ^ 3
If numstr = 0 Then
tempstr = tempstr & newstr & "thousand "
Else
tempstr = tempstr & newstr & "thousand, "
End If
End If
If numstr >= 10 ^ 2 Then
newstr = numtoword(Int(numstr / 10 ^ 2))
numstr = ((numstr / 10 ^ 2) - Int(numstr / 10 ^ 2)) * 10 ^ 2
If numstr = 0 Then
tempstr = tempstr & newstr & "hundred "
Else
tempstr = tempstr & newstr & "hundred and "
End If
End If
If numstr >= 20 Then
Select Case Int(numstr / 10)
Case 2
tempstr = tempstr & "twenty "
Case 3
tempstr = tempstr & "thirty "
Case 4
tempstr = tempstr & "forty "
Case 5
tempstr = tempstr & "fifty "
Case 6
tempstr = tempstr & "sixty "
Case 7
tempstr = tempstr & "seventy "
Case 8
tempstr = tempstr & "eighty "
Case 9
tempstr = tempstr & "ninety "
End Select
numstr = ((numstr / 10) - Int(numstr / 10)) * 10
End If
If numstr > 0 Then
Select Case numstr
Case 1
tempstr = tempstr & "one "
Case 2
tempstr = tempstr & "two "
Case 3
tempstr = tempstr & "three "
Case 4
tempstr = tempstr & "four "
Case 5
tempstr = tempstr & "five "
Case 6
tempstr = tempstr & "six "
Case 7
tempstr = tempstr & "seven "
Case 8
tempstr = tempstr & "eight "
Case 9
tempstr = tempstr & "nine "
Case 10
tempstr = tempstr & "ten "
Case 11
tempstr = tempstr & "eleven "
Case 12
tempstr = tempstr & "twelve "
Case 13
tempstr = tempstr & "thirteen "
Case 14
tempstr = tempstr & "fourteen "
Case 15
tempstr = tempstr & "fifteen "
Case 16
tempstr = tempstr & "sixteen "
Case 17
tempstr = tempstr & "seventeen "
Case 18
tempstr = tempstr & "eighteen "
Case 19
tempstr = tempstr & "nineteen "
End Select
numstr = ((numstr / 10) - Int(numstr / 10)) * 10
End If
numtoword = tempstr
End Function
'在程序中使用实例：Text1是输入的阿拉伯数字，Text2 是返回的英文字
Text2 = numtoword(Text1)
139、如何取得屏幕字体
Private Sub Combo1_Click()
Label1.Font = Combo1.List(Combo1.ListIndex)
End Sub
Private Sub Combo1_KeyPress(KeyAscii As Integer)
KeyAscii = 0
End Sub
Private Sub Command1_Click()
Dim i As Integer
For i = 0 To Screen.FontCount - 1
Combo1.AddItem Screen.Fonts(i)
Next i
Combo1.Text = Combo1.List(0)
End Sub
140、如何得到某年每个月的第一天是星期几
Private Sub Command1_Click()
Dim i As Integer, A As Integer, B As Integer, C As String
A = InputBox("请输入年份", "某年每个月的第一天是星期几")
Form1.Cls
For i = 1 To 12
C = A & "-" & i & "-1"
B = Weekday(C)
Select Case B
Case vbSunday
Print A & "年" & i & "月1日是星期日"
Case vbMonday
Print A & "年" & i & "月1日是星期一"
Case vbTuesday
Print A & "年" & i & "月1日是星期二"
Case vbWednesday
Print A & "年" & i & "月1日是星期三"
Case vbThursday
Print A & "年" & i & "月1日是星期四"
Case vbFriday
Print A & "年" & i & "月1日是星期五"
Case vbSaturday
Print A & "年" & i & "月1日是星期六"
End Select
Next i
End Sub
141、在 VB 程序中做复制磁片 (DiskCopy) 的功能
下面这一段程序并不是实际在程序中就做复制磁片的功能，而是呼叫出 Windows 系统的复制磁片问话框！
'在声明区中加入以下声明
Private Declare Function SHFormatDrive Lib "shell32" (ByVal hwnd As Long, ByVal Drive As Long, ByVal fmtID As Long, ByVal options As Long) As Long
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
'在 Form 中加入一个 CommandButton 命名为 cmdDiskCopy，再加入一个 DriveListBox
Private Sub cmdDiskCopy_Click()
' DiskCopyRunDll takes two parameters- From and To
Dim DriveLetter$, DriveNumber&, DriveType&
Dim RetVal&, RetFromMsg&
DriveLetter = UCase(Drive1.Drive) '磁盘代号 ( A / B / C / D..... )
DriveNumber = (Asc(DriveLetter) - 65) '磁盘序号，从 0 开始：A=0，B=1....
DriveType = GetDriveType(DriveLetter) '磁盘型态 ( 软盘 / 硬盘 / 光盘 ... )
If DriveType = 2 Then '软盘
RetVal = Shell("rundll32.exe diskcopy.dll,DiskCopyRunDll " & DriveNumber & "," & DriveNumber, 1) 'Notice space after
Else '非软盘
RetFromMsg = MsgBox("只有磁盘片才可以复制磁片", 64, "复制磁片")
End If
End Sub
142、在 VB 程序中做制作格式 (Format) 的功能
下面这一段程序并不是实际在程序中就做制作格式的功能，而是呼叫出 Windows 系统的制作格式问话框！
这个范例程序是从网络上抓下来的，原作者特别注明，这一段程序也可以格式化硬盘，所以要小心控制，程序码中格式化硬盘的部份，我已经 Mark 起来了，若有需要，才将 Mark 拿掉吧！
软盘格式化的部份我已测试过没问题，硬盘的部份，我没有空硬盘所以没有测试，大家自己玩玩吧！若有问题再通知我！
'在声明区中加入以下声明
Private Declare Function SHFormatDrive Lib "shell32" (ByVal hwnd As Long, ByVal Drive As Long, ByVal fmtID As Long, ByVal options As Long) As Long
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
'在 Form 中加入一个 CommandButton 命名为 cmdFormatDrive，再加入一个 DriveListBox
Private Sub cmdFormatDrive_Click()
Dim DriveLetter$, DriveNumber&, DriveType&
Dim RetVal&, RetFromMsg%
DriveLetter = UCase(Drive1.Drive) '磁盘代号 ( A / B / C / D..... )
DriveNumber = (Asc(DriveLetter) - 65) '磁盘序号，从 0 开始：A=0，B=1....
DriveType = GetDriveType(DriveLetter) '磁盘型态 ( 软盘 / 硬盘 / 光盘 ... )
If DriveType = 2 Then '软盘
RetVal = SHFormatDrive(Me.hwnd, DriveNumber, 0&, 0&)
Else '非软盘
RetFromMsg = MsgBox("这一张磁盘不是软盘，可能是硬盘！" & vbCrLf & _
"您还要继续格式 (Format) 吗?", 276, "格式化")
Select Case RetFromMsg
Case 6 'Yes：表示要格式化硬盘
' UnComment to do it...
'RetVal = SHFormatDrive(Me.hwnd, DriveNumber, 0&, 0&)
Case 7 'No：表示要取消格式化
' Do nothing
End Select
End If
End Sub
143、简简单单做到【剪下 / 复制 / 贴上 / 复原】的功能
在很多软件的编辑功能表中，都有提供【剪下 / 复制 / 贴上 / 复原】的功能，在 VB 中我们只要借用 Windows 的系统功能，很容易也可以有这样的功能，看看以下的程序码便能了解了！
Sub mnuEditText_Click (Index As Integer)
' 我们只要使用 SendKeys，其他的就让 Windows 去做吧！
Select Case Index
Case 0 '复原/UNDO
SendKeys "^Z" 'Keys Ctrl+Z
Case 1 '剪下/CUT
SendKeys "^X" 'Keys Ctrl+X
Case 2 '复制/COPY
SendKeys "^C" 'Keys Ctrl+C
Case 3 '贴上/PASTE
SendKeys "^V" 'Keys Ctrl+V
End Select
End Sub
144、如何侦测电脑目前是否正在连线中？
有些应用程序在程序中有部份功能必须和 Internet 连结沟通，这时候，侦测电脑目前是否正在连线状态就显得很重要了，每当在 Windows 中拨接上网之后，Windows 系统会自动在注册表中做上一点记号 (改变注册表中某些键值的资料)，而我们在 VB 程序中就可以利用这些改变的键值来判断电脑目前是否正在连线状态！
'在模组的声明区中加入以下声明及模组：
Public Const ERROR_SUCCESS = 0&
Public Const APINULL = 0&
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public ReturnCode As Long
Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Public Function ActiveConnection() As Boolean
Dim hKey As Long
Dim lpSubKey As String
Dim phkResult As Long
Dim lpValueName As String
Dim lpReserved As Long
Dim lpType As Long
Dim lpData As Long
Dim lpcbData As Long
ActiveConnection = False
lpSubKey = "System/CurrentControlSet/Services/RemoteAccess"
ReturnCode = RegOpenKey(HKEY_LOCAL_MACHINE, lpSubKey, phkResult)
If ReturnCode = ERROR_SUCCESS Then
hKey = phkResult
lpValueName = "Remote Connection"
lpReserved = APINULL
lpType = APINULL
lpData = APINULL
lpcbData = APINULL
ReturnCode = RegQueryValueEx(hKey, lpValueName, lpReserved, lpType, ByVal lpData, lpcbData)
lpcbData = Len(lpData)
ReturnCode = RegQueryValueEx(hKey, lpValueName, lpReserved, lpType, lpData, lpcbData)
If ReturnCode = ERROR_SUCCESS Then
If lpData = 0 Then
ActiveConnection = False
Else
ActiveConnection = True
End If
End If
RegCloseKey (hKey)
End If
End Function
'而在程序中使用实例如下：
If ActiveConnection = True then
Call MsgBox("您的电脑目前正在连线中！",vbInformation)
Else
Call MsgBox("您的电脑目前在离线状态！.", vbInformation)
End If
145、如何在程序中启动【拨号网络连线】对话框？
要直接在 VB 程序中开启【拨号网络连线】对话框，要使用 Shell 函数：
Private Sub Command1_Click()
Dim res
res = Shell("rundll32.exe rnaui.dll,RnaDial " & "拨号网络连线名称", 1)
End Sub
其中 "拨号网络连线名称" 是我们事先在【拨号网络】中设定的【连线名称】，例如【Hinet】。
注：以上方法只适用于 Windows95/98。
146、如何中断【拨号网路连线】？
要在 VB 程序中中断【拨号网路连线】，可以使用 Remote Access Services Hangup 函数：
'在模组的声明区中加入以下声明及模组：
Public Const RAS_MAXENTRYNAME As Integer = 256
Public Const RAS_MAXDEVICETYPE As Integer = 16
Public Const RAS_MAXDEVICENAME As Integer = 128
Public Const RAS_RASCONNSIZE As Integer = 412
Public Const ERROR_SUCCESS = 0&
Public Type RasEntryName
dwSize As Long
szEntryName(RAS_MAXENTRYNAME) As Byte
End Type
Public Type RasConn
dwSize As Long
hRasConn As Long
szEntryName(RAS_MAXENTRYNAME) As Byte
szDeviceType(RAS_MAXDEVICETYPE) As Byte
szDeviceName(RAS_MAXDEVICENAME) As Byte
End Type
Public Declare Function RasEnumConnections Lib "rasapi32.dll" Alias "RasEnumConnectionsA" (lpRasConn As Any, lpcb As Long, lpcConnections As Long) As Long
Public Declare Function RasHangUp Lib "rasapi32.dll" Alias "RasHangUpA" (ByVal hRasConn As Long) As Long
Public gstrISPName As String
Public ReturnCode As Long
Public Sub HangUp()
Dim i As Long
Dim lpRasConn(255) As RasConn
Dim lpcb As Long
Dim lpcConnections As Long
Dim hRasConn As Long
lpRasConn(0).dwSize = RAS_RASCONNSIZE
lpcb = RAS_MAXENTRYNAME * lpRasConn(0).dwSize
lpcConnections = 0
ReturnCode = RasEnumConnections(lpRasConn(0), lpcb, lpcConnections)
If ReturnCode = ERROR_SUCCESS Then
For i = 0 To lpcConnections - 1
If Trim(ByteToString(lpRasConn(i).szEntryName)) = Trim(gstrISPName) Then
hRasConn = lpRasConn(i).hRasConn
ReturnCode = RasHangUp(ByVal hRasConn)
End If
Next i
End If
End Sub
Public Function ByteToString(bytString() As Byte) As String
Dim i As Integer
ByteToString = ""
i = 0
While bytString(i) = 0&
ByteToString = ByteToString & Chr(bytString(i))
i = i + 1
Wend
End Function
'在程序中使用实例为
Call HangUp
147、资料库的导出
在很多 VB 的资料库书籍中，都会很完整的提到：如何由其他种类的文件中将资料导入资料库，但是却很少有书提到：如何将资料库中的资料，导出到各种不同的文件类型的文件中，连 VB 的 Help 中也是这样！
或许是大家都认为资料库主题的重点是在资料库本身吧！
但是，在实际的资料库程序运用中，却常常需要将资料库导出到各种不同的文件类型的文件中，这些文件可能是 DBase文件、文字文件 (.Txt)、Excel 文件、Html 文件、Access 文件或其他类型的资料库文件 (ODBC)...等。
在本专题中，考虑到并不是每一个人都有 Oracle 或 SQL Server 的环境，为了让大家都能够实作，我们将以 Access 资料库来作练习，而练习的文件也使用 VB 本身提供的 Biblio.mdb (位于各版本 VB 的目录下)。
预计要练习导出的文件类型有五种：DBase文件、文字文件 (.Txt)、Html 文件、Excel 文件、Access 文件。除了这五种之外，下面的语法可以将资料库之资料导出到任一种 VB 支援的资料库或文件中。
在练习之前，要将导出文件的 SQL 语法先说明一下：
SELECT Table.Fields INTO [dbms type;DATABASE=path].[unqualified filename] FROM [Table or Tables]
SELECT Table.Fields INTO [资料库种类;DATABASE=资料库路径].[资料库文件名称] FROM [Table or Tables]
至于【资料库种类】及【资料库路径】，视资料库或文件类型之不同而异，详见【注一】。
如果上面说的都清楚了，那我们要开始这一个练习了！
在 Form 上放置一个 CommandButton，在【专案】【设定引用项目】中加入 Microsoft DAO 3.51 Object Library，我们将使用 Biblio.mdb 的 authors Table，在 Command1_Click 中加入以下程序码：
Dim db As Database
Set db = Workspaces(0).OpenDatabase(App.Path & "/biblio.mdb")
'db.execute "SELECT Table.Fields INTO [dbms type;DATABASE=path].[unqualified filename] FROM [Table or Tables]"
在以上程序中，db.execute 指令行之指令依资料库或文件的种类说明如下：
一、DBase文件
SQL 语法：SELECT * INTO [dBase III;DATABASE=资料库路径].[dbase文件名称] FROM [authors]
db.Execute "SELECT * INTO [dBase III;DATABASE=C:/test].[authors.DBF] FROM [authors]"
注意事项：
1、authors.DBF 事先不可存在，否则会产生错误！
2、若您没有 Dbase，您可以使用 Access 来连结这个 Table，以便观察结果！
二、文本文件 (.Txt)
SQL 语法：SELECT * INTO [Text;DATABASE=文本文件路径].[文本文件名称] FROM [authors]
db.Execute "SELECT * INTO [Text;DATABASE=C:/test].[authors.TXT] FROM [authors]"
注意事项：
1、authors.TXT 事先不可存在，否则会产生错误！
2、此动作会产生的文件有二个，第一个就是文本文件 authors.TXT，第二个是 Schema.ini。
3、文本文件之格式为 CSV 之文件格式，即各栏位间以逗点分开，实际呈现方式如下：
　　"Au_ID","Author","Year Born"
　　1,"Jacobs, Russell",1950
　　2,"Metzger, Philip W.",1942
4、Schema.ini 若事先不存在会新产生一个，若已存在，则会在原文件后面直接 Append。
5、至于 Schema.ini 的属性为此次导出的相关资讯，格式同一般的 Ini 文件，详细属性如下：
　　[authors.TXT]
　　ColNameHeader=True
　　CharacterSet=OEM
　　Format=CSVDelimited
　　Col1=Au_ID Integer
　　Col2=Author Char Width 50
　　Col3="Year Born" Short
三、Html 文件
SQL 语法：SELECT * INTO [Excel 8.0;DATABASE=Html文件路径].[Html文件名称] FROM [authors]
db.Execute "SELECT * INTO [HTML Export;DATABASE=C:/test].[authors.HTM] FROM [authors]"
注意事项：
1、authors.HTM 事先不可存在，否则会产生错误！
2、此动作会产生的文件有二个，第一个就是文本文件 authors.HTM，第二个是 Schema.ini。
3、Schema.ini 若事先不存在会新产生一个，若已存在，则会在原文件后面直接 Append。
4、至于 Schema.ini 的属性为此次导出的相关资讯，格式同一般的 Ini 文件，详细属性如下：
　　[authors.HTM]
　　ColNameHeader=True
　　CharacterSet=ANSI
　　Format=HTML
　　Col1=Au_ID Integer
　　Col2=Author Char Width 50
　　Col3="Year Born" Short
四、Excel 文件
SQL 语法：SELECT * INTO [Excel 8.0;DATABASE=文件路径+文件名].[工作表名称] FROM [authors]
db.Execute "SELECT * INTO [Excel 8.0;DATABASE=C:/test/authors.XLS].[authors] FROM [authors]"
注意事项：
1、authors.XLS 可事先存在，也可以不存在，会自动产生一个。
2、工作表 authors 事先不可存在，否则会产生错误！
五、Access 文件
SQL 语法：SELECT * INTO [新资料库路径+文件名][新资料表名称] FROM [authors]
'导出到同一资料库 ( 新 Table 为 authors1 )
'新 Table authors1 事先不可存在，否则会产生错误！
db.Execute "SELECT * INTO [authors1] FROM [authors]"
'导出到不同的资料库 ( 新资料库为 db1，新 Table 为 authors )
'新资料库 db1事先必须存在，否则会产生错误！
'但是其中新 Table authors 事先不可存在，否则会产生错误！
db.Execute "SELECT * INTO [C:/test/db1.mdb].[authors] FROM [authors]"
注一：各种可能的资料库种类 Connect 属性设定方式：
资料库种类资料库声明方式资料库路径 (或加上文件名)
Microsoft Jet Database [database]; drive:/path/filename.mdb
dBASE III dBASE III; drive:/path
dBASE IV dBASE IV; drive:/path
dBASE 5 dBASE 5.0; drive:/path
Paradox 3.x Paradox 3.x; drive:/path
Paradox 4.x Paradox 4.x; drive:/path
Paradox 5.x Paradox 5.x; drive:/path
Microsoft FoxPro 2.0 FoxPro 2.0; drive:/path
Microsoft FoxPro 2.5 FoxPro 2.5; drive:/path
Microsoft FoxPro 2.6 FoxPro 2.6; drive:/path
Microsoft Visual FoxPro 3.0 FoxPro 3.0; drive:/path
Microsoft Excel 3.0 Excel 3.0; drive:/path/filename.xls
Microsoft Excel 4.0 Excel 4.0; drive:/path/filename.xls
Microsoft Excel 5.0 or Microsoft Excel 95 Excel 5.0; drive:/path/filename.xls
Microsoft Excel 97 Excel 8.0; drive:/path/filename.xls
Lotus 1-2-3 WKS and WK1 Lotus WK1; drive:/path/filename.wk1
Lotus 1-2-3 WK3 Lotus WK3; drive:/path/filename.wk3
Lotus 1-2-3 WK4 Lotus WK4; drive:/path/filename.wk4
HTML Import HTML Import; drive:/path/filename
HTML Export HTML Export; drive:/path
Text Text; drive:/path
ODBC ODBC;
DATABASE=database;
UID=user;
PWD=password;
DSN= datasourcename;
[LOGINTIMEOUT=seconds;] None
Microsoft Exchange Exchange 4.0;
MAPILEVEL=folderpath; [TABLETYPE={ 0 | 1 }];[PROFILE=profile;]
[PWD=password;]
[DATABASE=database;] drive:/path/filename.mdb
148、模拟 Windows 的资源回收站！
您现在将屏幕上所有的视窗全部缩小，找到资源回收站，按鼠标右键，选择【属性】，便会出现【资源回收站】的属性问话框。
其中有几个选项如下：
1、不要将文件移到资源回收站，删除时立即移除文件。
2、显示删除确认对话框？
根据以上之状况，文件之删除有三种情形：
1、删除文件，出现确认对话框，文件移到资源回收站。
2、删除文件，出现确认对话框，文件不移到资源回收站。
3、删除文件，不出现确认对话框，文件也不移到资源回收站。
模拟程序如下：
'在模组的声明区中加入以下声明：
Public Type SHFILEOPSTRUCT
hwnd As Long
wFunc As Long
pFrom As String
pTo As String
fFlags As Integer
fAnyOperationsAborted As Long
hNameMappings As Long
lpszProgressTitle As Long
End Type
Public Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
Public Const FO_DELETE = &H3
Public Const FOF_ALLOWUNDO = &H40 '可以还原
Public Const FOF_NOCONFIRMATION = &H10 '不出现确认对话框
Public Const FOF_SILENT = &H4
'在程序中之使用方法如下：
'以下之例子会出现确认对话框，文件也会移到资源回收站。
Private Sub Command1_Click()
Dim SHop As SHFILEOPSTRUCT
Dim strFile As String '要删除的文件(含全路径)
strFile = "c:/test.txt"
With SHop
.wFunc = FO_DELETE
.pFrom = strFile
.fFlags = FOF_ALLOWUNDO
End With
SHFileOperation SHop
End Sub
'若要调整，只要更改 fFlags 之值即可，如下：
.fFlags = FOF_SILENT '删除文件，出现确认对话框，文件不移到资源回收站。
.fFlags = FOF_NOCONFIRMATION '删除文件，不出现确认对话框，文件也不移到资源回收站。
149、如何得到文件路径的文件名
Dim sFilePath As String
sFilePath = "C:/Windows/System/sytem.dll"
Dim lGetLen As Long, lNum As Long
Dim sGetFile As String, sTemp As String
lGetLen = Len(sFilePath) '得到文件路径长度
sTemp = lGetLen
For lNum = 1 To lGetLen
If Left(sGetFile, 1) = "/" Then Exit For
sGetFile = Mid(sFilePath, sTemp, lNum)
sTemp = sTemp - 1
Next lNum
sGetFile = Mid(sGetFile, 2) '得到文件名
MsgBox sGetFile
150、如何用VB准确计算年龄
Function CalcAge(datEmpDateOfBirth as Variant) as Integer
CalcAge = Int(DateDiff("y",datEmpDateOfBirth,Date())/365.25)
End Function
151、如何算出屏幕的分辨率？
如果不使用 Third Party 的控制项，而希望程序的画面能随著屏幕的分辨率而自动调整各个控制项的位置及大小，其中最重要的一件事，便是算出目前执行程序的屏幕之分辨率！
而分辨率要如何算呢？看看以下的程序便可知道！
ResWidth = Screen.Width / Screen.TwipsPerPixelX
ResHeight = Screen.Height / Screen.TwipsPerPixelY
ScreenRes = ResWidth & "x" & ResHeight
ResWidth 就是指屏幕分辨率中的宽
ResHeight 就是指屏幕分辨率中的长
而最后算出的 ScreenRes，格式会像 800x600 一样！
除了 800x600 之外，可能还有 640x480、1024x768....等。
152、如何产生一个多行式的提示框 (ToolTipText)？
VB5 以后的 VB 版本都有提供一个属性 -- ToolTipText，目的是让使用者在执行阶段，鼠标在物件上徘徊约一秒时，就将该物件的提示字串显示在该物件下面的一个小长方形中，以协助使用者做输入动作。
有时候说明字串太长了，于是就有人想将提示字串分行显示，而且自然而然的使用 vbNewLine (=vbCrLf 或 =vbCr ) 来换行，因为根据以往的经验，VB都是这样做换行的，可是这一次很多人都踢到铁板了！
VB 用来显示 ToolTipText 的提示框，其实是一个文字框，而且 MultiLine 属性并没有设为 True，您可以自己用一个单行式的文字框来做测试，就算您用 vbCrLf 来换行也不会有作用的！
既然 VB 提供的 Default 功能不能满足我们的需求，而我们又想提供使用者多行式的提示框，那要怎么办呢？其实也不难，我们自己动手 DIY 一下就有了，而且程序码也不长！
'首先在 Form 上放一个 Timer (如果需要的话)，以便于叫出突现式说明框
Private Function TimeOut(pInterval As Single)
Dim sngTimer As Single
sngTimer = Timer
Do While Timer < sngTimer + pInterval
DoEvents
Loop
End Function
'然后在 Form 上放一个 Label，取名为 lblToolTip，在 MouseMove 中加入以下程序：
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
lbltooltip.Visible = False
End Sub
'在您想显示说明框的物件加入以下程序码： ( Textbox, listbox etc. )
Private Sub Text1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
TimeOut 0.3 '鼠标移到物件上多久后,要显示提示框
lbltooltip.Caption = "大家好 !!" & vbCrLf & "" & vbCrLf & _
"您目前看到的黄色标签" & vbCrLf & "是一个多行式的提示框"
lbltooltip.Left = Text1.Left + lbltooltip.Width
lbltooltip.Top = Text1.Top + Text1.Height
lbltooltip.Visible = True
End Sub
153、如何改变屏幕的分辨率？
如果希望使用者在跑我们开发的应用程序时，看到的画面的样子和我们在 Design Time 时一样的话，我们往往需要处理屏幕分辨率的问题，才能使程序的画面能随著屏幕的分辨率而自动调整各个控制项的位置及大小，但是这样子往往会使程序复杂化！
除了以上这样子，将就使用者屏幕分辨率大小的民主式做法之外，您还有一个选择，那就是强制改掉使用者屏幕分辨率大小的暴权式做法，如果真的可以这么做，您根本就不用再去处理分辨率的问题了！
在讨论区中，不时有人问到如何改变屏幕分辨率的大小，这是因为在 VB 32位元的 API 检视员中漏掉了有关 EnumDisplaySettings、ChangeDisplaySettings 的常数及宣告。
'在模组中加入以下宣告、常数、型态：
Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As Long, ByVal iModeNum As Long, lpDevMode As Any) As Boolean
Declare Function ChangeDisplaySettings Lib "user32" Alias "ChangeDisplaySettingsA" (lpDevMode As Any, ByVal dwFlags As Long) As Long
Declare Function ExitWindowsEx Lib "user32" _
(ByVal uFlags As Long, ByVal dwReserved As Long) As Long
Public Const EWX_LOGOFF = 0
Public Const EWX_SHUTDOWN = 1
Public Const EWX_REBOOT = 2
Public Const EWX_FORCE = 4
Public Const CCDEVICENAME = 32
Public Const CCFORMNAME = 32
Public Const DM_BITSPERPEL = &H40000
Public Const DM_PELSWIDTH = &H80000
Public Const DM_PELSHEIGHT = &H100000
Public Const CDS_UPDATEREGISTRY = &H1
Public Const CDS_TEST = &H4
Public Const DISP_CHANGE_SUCCESSFUL = 0
Public Const DISP_CHANGE_RESTART = 1
Type DEVMODE
dmDeviceName As String * CCDEVICENAME
dmSpecVersion As Integer
dmDriverVersion As Integer
dmSize As Integer
dmDriverExtra As Integer
dmFields As Long
dmOrientation As Integer
dmPaperSize As Integer
dmPaperLength As Integer
dmPaperWidth As Integer
dmScale As Integer
dmCopies As Integer
dmDefaultSource As Integer
dmPrintQuality As Integer
dmColor As Integer
dmDuplex As Integer
dmYResolution As Integer
dmTTOption As Integer
dmCollate As Integer
dmFormName As String * CCFORMNAME
dmUnusedPadding As Integer
dmBitsPerPel As Integer
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFrequency As Long
End Type
'假设现在我们希望将分辨率改成 800X600，但是不要改变色板，程序如下：
'注：色板指的就是 16色 / 256色 / High Color (16Bit) / True Color (24Bit)
Private Sub Command1_Click()
Dim DevM As DEVMODE '将取得的讯息存放在 DevM
erg& = EnumDisplaySettings(0&, 0&, DevM)
DevM.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT 'Or DM_BITSPERPEL
DevM.dmPelsWidth = 800 '想要设定的屏幕宽度
DevM.dmPelsHeight = 600 '想要设定的屏幕高度
'我们不更改色板，因为一旦更改色板就必须重新开机！
'DevM.dmBitsPerPel = 32 (could be 8, 16, 32 or even 4) '此行可用于改变色板
'以下这行指令会暂时更改屏幕的分辨率，是测试性的，不一定成功，
'不过因为没将设定值写到注册表，所以虽然可能更改成功，
'但是一旦重新开机后，会自动恢复成更改前的设定值
erg& = ChangeDisplaySettings(DevM, CDS_TEST)
'上面的指令若成功，而且您想永久性的更改使用者的屏幕分辨率，
'您还必须使用下一行指令，将资料写到注册表
'erg& = ChangeDisplaySettings(DevM, CDS_UPDATEREGISTRY)
'但是如果您只是想暂时更改使用者的屏幕分辨率，就不需要了.
'当然并不是您随便设定一个值，就一定会成功的更改屏幕分辨率,
'所以还需要检查是否更改成功！下面的程序就是检查是否更改成功
Select Case erg&
Case DISP_CHANGE_RESTART
'通常如果有更改到色板，或者较老的板子，会要求重新开机
an = MsgBox("您必须重新开机！", vbYesNo + vbSystemModal, "讯息")
If an = vbYes Then
erg& = ExitWindowsEx(EWX_REBOOT, 0&)
End If
Case DISP_CHANGE_SUCCESSFUL
'如果更改成功且不需重新开机，您就可以将设定值写到注册表中
erg& = ChangeDisplaySettings(DevM, CDS_UPDATEREGISTRY)
MsgBox "分辨率更改成功！", vbOKOnly + vbSystemModal, "成功！"
Case Else
'更改不成功
MsgBox "不支持此一模式！", vbOKOnly + vbSystemModal, "错误！"
End Select
End Sub
154、如何在程序中启动 NT 的【拨号网络连接】对话框？
在【问题125】如何在程序中启动【拨号网络连接】对话框？我告诉大家如何在 VB 中用 Shell 去叫出【拨号网络连接】对话框，程序码如下：
Private Sub Command1_Click()
Dim res
res = Shell("rundll32.exe rnaui.dll,RnaDial " & "拨号网络连接名称", 1)
End Sub
但是有网友反应，用上述的方法只有在 Windows 95/98 中才行得通，一碰到 Windows NT 可就没辄了！今天，我要告诉大家在 Windows NT 中，要如何做到相同的事情。不难，方法如下：
Private Sub Command1_Click()
Dim res
res = Shell("rasphone.exe [-d 拨号网络连接名称]", 1)
End Sub
155、如何使用 ADO 來压缩或修复 Microsoft Access 文件
以前使用 DAO 時，Microsoft 有提供 CompactDatabase Method 來压缩 Microsoft Access 文件，RepairDatabase Method 來修复损坏的 Microsoft Access 文件，。可是自从 ADO 出來之后，好像忘了提供相对的压缩及修复 Microsoft Access 文件的功能。
現在 Microsoft 发现了这个问题了，也提供了解決方法，不过有版本上的限制！限制說明如下：
ActiveX Data Objects (ADO), version 2.1
Microsoft OLE DB Provider for Jet, version 4.0
這是 Microsoft 提出的 ADO 的延伸功能：Microsoft Jet OLE DB Provider and Replication Objects (JRO)
这个功能在 JET OLE DB Provider version 4.0 (Msjetoledb40.dll) 及 JRO version 2.1 (Msjro.dll) 中第一次被提出！
這些必要的 DLL 文件在您安裝了 MDAC 2.1 之后就有了，您可以在以下的网页中下载 MDAC 的最新版本！
Universal Data Access Web Site
在下载之前先到 VB6 中檢查一下，【控件】【設定引用項目】中的 Microsoft Jet and Replication Objects X.X library 如果已经是 2.1 以上的版本，您就可以不用下载了！
在您安裝了 MDAC 2.1 或以上的版本之后，您就可以使用 ADO 來压缩或修复 Microsoft Access 文件，下面的步骤告訴您如何使用 CompactDatabase Method 來压缩 Microsoft Access 文件：
1、新建一個新表单，选择功能表中的【控件】【設定引用項目】。
2、加入 Microsoft Jet and Replication Objects X.X library，其中 ( X.X 大于或等于 2.1 )。
3、在适当的地方加入以下的程序代码，記得要修改 data source 的內容及目地文件的路径：
Dim jro As jro.JetEngine
Set jro = New jro.JetEngine
jro.CompactDatabase "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=d://nwind2.mdb", _ '來源文件
"Provider=Microsoft.Jet.OLEDB.4.0;Data Source=d://abbc2.mdb;Jet OLEDB:Engine Type=4" '目的文件
在 DAO 3.60 之后，RepairDatabase Method 已经无法使用了，以上的程序代码显示了 ADO CompactDatabase Method 的用法，而它也取代了 DAO 3.5 時的 RepairDatabase method！
156、如何建立可卷动的图形框？
在各网站的讨论区中常有人问到这个问题，其实答案就在 Msdn 中！以下资料由 Msdn 节录：
除了图片方块控制项之外，也可用水平、垂直卷轴来建立可卷动的图形框应用程序。当所包含的图形超过控制项范围时，单独一个图片方块控制项无法制作卷动功能─ 因为图片方块控制项无法自动新增卷轴。应用程序使用两个图片方块。称第一个为平稳的父图片方块控制项。第二个为子图片方块控制项，它包含在父图片方块中。子图片方块中包含图形影像，可用卷轴控制项在父图片方块中搬动子图片方块。
先建立一个新工程，然后在表单上绘制两个图片方块、一个水平卷轴和一个垂直卷轴。位置随便放，这里，用表单的 Form_Load 事件设定比例模型，在父图片方块中调整子图片方块的大小，水平、垂直卷轴，搜寻并调整它们的大小，然后载入点阵图图形。将下列程序码新增到表单的 Form_Load 事件程序中：
修正：避开 Form_Resize 产生的错误，将程序模组化，并加上范例程序。
Private Sub init_object()
'初始化两个图片方块的位置。
Picture1.Move 0, 0, ScaleWidth - VScroll1.Width, ScaleHeight - HScroll1.Height
Picture2.Move 0, 0
'将水平卷轴搜寻。
HScroll1.Top = Picture1.Height
HScroll1.Left = 0
HScroll1.Width = Picture1.Width
'将垂直卷轴搜寻。
VScroll1.Top = 0
VScroll1.Left = Picture1.Width
VScroll1.Height = Picture1.Height
'设定卷轴的 Max 属性。
HScroll1.Max = Picture2.Width - Picture1.Width
VScroll1.Max = Picture2.Height - Picture1.Height
'判断子图片方块是否将充满屏幕。若如此，则无需使用卷轴。
VScroll1.Visible = (Picture1.Height < Picture2.Height)
HScroll1.Visible = (Picture1.Width < Picture2.Width)
End Sub
Private Sub Form_Load()
'设定 ScaleMode 为像素。
Form1.ScaleMode = vbPixels
Picture1.ScaleMode = vbPixels
'将 Autosize 设定为 True，以使 Picture2 的边界延伸到实际的点阵图大小。
Picture2.AutoSize = True
'将每个图片方块的 BorderStyle 属性设定为 None。
Picture1.BorderStyle = 0
Picture2.BorderStyle = 0
'载入点阵图。此处请自行更改图片
'Picture2.Picture = LoadPicture("c:/Windows/ham.bmp")
'初始化各物件
init_object
End Sub
水平和垂直卷轴的 Change 事件，用在父图片方块中上、下、左、右移动子图片方块。请将下列程序码新增到两个卷轴控制项的 Change 事件中：
Private Sub HScroll1_Change()
Picture2.Left = -HScroll1.Value
End Sub
Private Sub VScroll1_Change()
Picture2.Top = -VScroll1.Value
End Sub
将子图片方块的 Left 和 Top 属性分别设定成水平和垂直卷轴数字的负值，这样，当上、下、左、右卷动时，图形可以正确移动。
执行阶段中，显示的图形如上图所示。
在执行阶段调整表单大小
在上例中，表单的初始大小限制图形的可视大小。在执行阶段中，当使用者调整表单大小时，为了调整图形视域应用程序的大小，可将下列程序码新增到表单的 Form_Resize 事件程序中：
Private Sub Form_Resize()
'重新初始化各物件
'避开表单最小化的情况
If Me.WindowState <> 1 Then init_object
End Sub
157、如何侦测目前文字框中共有几行？
要判断文字框中目前有几行，可以使用回圈判断共有几个换行字元来取得，但是在这儿我们要使用 API 来做到这个功能！
'请在 Form 中放一个 TextBox 及一个 label，在声明区中加入以下声明：
Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Const EM_GETLINECOUNT = &HBA
'在 Text1 的 Change 事件中加入以下程序码：
Sub Text1_Change()
Dim lineCount As Long
On Local Error Resume Next
'立刻侦测目前文字框中共有几行
lineCount = SendMessageLong(Text1.hwnd, EM_GETLINECOUNT, 0&, 0&)
Label1 = "文字框中共有 " & Format$(lineCount, "##,###") & " 行"
End Sub
158、如何判断使用者电脑中系统字型大小？
在【问题】如何算出屏幕的分辨率？我们提到：如果希望使用者在跑我们开发的应用程序时，看到的画面的样子和我们在 Design Time 时一样的话，我们往往需要处理屏幕分辨率的问题。
除了屏幕的分辨率之外，电脑中设定的字型大小是大字型 ( Large Font ) 或小字型 ( Small Font ) 或其他大小的自订字型，也是一个影响的因素，要如何侦测电脑中的字型大小呢？
由【控制面板】的【显示器】【设定】页签中，我们可以得知以下讯息：
大字型 ( Large Font )：120 dpi
小字型 ( Small Font )：96 dpi
以下之程序可以判断系统是否使用小字型，当然大字型之判断方式也相同：
请在模组中加入以下声明及模组：
Public Declare Function GetDesktopWindow Lib "user32" () As Long
Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Public Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Public Const LOGPIXELSX = 88
Public Function IsScreenFontSmall() As Boolean
Dim hWndDesk As Long
Dim hDCDesk As Long
Dim logPix As Long
Dim r As Long
hWndDesk = GetDesktopWindow()
hDCDesk = GetDC(hWndDesk)
logPix = GetDeviceCaps(hDCDesk, LOGPIXELSX)
r = ReleaseDC(hWndDesk, hDCDesk)
IsScreenFontSmall = (logPix = 96)
End Function
在程序中呼叫 IsScreenFontSmall 若返回值为 True 即为小字型。
159、使用 Label 模拟资源管理器左右窗口中的调整杆 ( Splitter )
要模拟这个功能，有很多种不同的作法，今天我们要使用一个 Label 控制项来分割分别放在左右的 TreeView 及 ListView，整个动作的重点在于，当我们在分隔线上按下鼠标左键时，就准备调整视窗中各控制项的大小，当我们放开鼠标左键时，就停止调整的动作！
'在 Form 中放入一个 Label，一个 TreeView 及一个 ListView，位置不拘，并加入以下程序码：
Private mbResizing As Boolean '判断是否按下鼠标左键 (准备调整大小)
Private Sub Form_Load()
'设定 TreeView1 为屏幕 1/3,ListView1 为屏幕 2/3
TreeView1.Move 0, 0, Me.ScaleWidth / 3, Me.ScaleHeight
ListView1.Move (Me.ScaleWidth / 3) + 50, 0, (Me.ScaleWidth * 2 / 3) - 50, Me.ScaleHeight
Label1.Move Me.ScaleWidth / 3, 0, 100, Me.ScaleHeight
Label1.MousePointer = vbSizeWE
End Sub
Private Sub Form_Resize()
'设定 TreeView1 为屏幕 1/3,ListView1 为屏幕 2/3
TreeView1.Move 0, 0, Me.ScaleWidth / 3, Me.ScaleHeight
ListView1.Move (Me.ScaleWidth / 3) + 50, 0, (Me.ScaleWidth * 2 / 3) - 50, Me.ScaleHeight
Label1.Move Me.ScaleWidth / 3, 0, 100, Me.ScaleHeight
Label1.MousePointer = vbSizeWE
End Sub
Private Sub Label1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
'准备调整大小
If Button = vbLeftButton Then mbResizing = True
End Sub
Private Sub Label1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
'按下鼠标左键并移动时, 自动调整各控制项大小
If mbResizing Then
Dim nX As Single
nX = Label1.Left + X
If nX < 500 Then Exit Sub
If nX > Me.ScaleWidth - 500 Then Exit Sub
TreeView1.Width = nX
ListView1.Left = nX + 50
ListView1.Width = Me.ScaleWidth - nX - 50
Label1.Left = nX
End If
End Sub
Private Sub Label1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
'停止调整大小
mbResizing = False
End Sub
160、【万用文件搜寻器】--- 将 Windows 的【寻找文件】功能套进 VB 中
这个 Walkdir 模组可以让您从任何一个目录往下所有目录中找寻符合您要求的所有文件！根据实际测试的结果，搜寻文件的速度和 Windows 的【寻找文件】功能不相上下，有时甚至更快呢！
共有三个参数说明如下：
1、文件类型：可接受万用字符 *，可同时设定多个类型(中间用分号隔开)，例如 ( OLE*.DLL; *.TLB )
2、开始目录：可以是根目录。
3、字串阵列：用来存放符合的文件名称 (全路径文件名)，是一个动态阵列。
这个模组会使用递回的方式一层一层的搜寻所有的子目录，找出所有符合条件的文件，并将文件名称 (含全路径) 放入字串阵列中，这个阵列的大小会自动根据找到的文件个数而自动调整，最后阵列的大小就是找到的文件个数！
要实际使用这个模组，您必须先在 Form 中放入一个 DirListBox 及一个 FileListBox，分别取名为 Dir1 及 File1，最好将这二个控制项的 Visible 属性设成 False，可以大大加快搜寻的速度。
'以下是使用的范例： ( 　要一个 CommandButton 及一个 ListBox )
Private Sub Command1_Click()
ReDim sarray(0) As String
'找寻 Windows 目录下文件类型为 OLE*.DLL 的所有文件
Call DirWalk("OLE*.DLL", "C:/windows", sarray)
'将阵列的资料放到 List1 中
Dim i As Integer
For i = LBound(sarray) To UBound(sarray) - 1
List1.AddItem sarray(i)
Next
End Sub
'模组内容如下：
Sub DirWalk(ByVal sPattern As String, ByVal CurrDir As String, sFound() As String)
Dim i As Integer
Dim sCurrPath As String
Dim sFile As String
Dim ii As Integer
Dim iFiles As Integer
Dim iLen As Integer
If Right$(CurrDir, 1) <> "/" Then
Dir1.Path = CurrDir & "/"
Else
Dir1.Path = CurrDir
End If
For i = 0 To Dir1.ListCount
If Dir1.List(i) <> "" Then
DoEvents
Call DirWalk(sPattern, Dir1.List(i), sFound())
Else
If Right$(Dir1.Path, 1) = "/" Then
sCurrPath = Left(Dir1.Path, Len(Dir1.Path) - 1)
Else
sCurrPath = Dir1.Path
End If
File1.Path = sCurrPath
File1.Pattern = sPattern
If File1.ListCount > 0 Then
'在目录中找到符合的文件
For ii = 0 To File1.ListCount - 1
ReDim Preserve sFound(UBound(sFound) + 1)
sFound(UBound(sFound) - 1) = sCurrPath & "/" & File1.List(ii)
Next ii
End If
iLen = Len(Dir1.Path)
Do While Mid(Dir1.Path, iLen, 1) <> "/"
iLen = iLen - 1
Loop
Dir1.Path = Mid(Dir1.Path, 1, iLen)
End If
Next i
End Sub
161、如何移除 MDIForm 的 Max/Min Button？
不像其他的 Form 一样，MDIForm 并没有提供 MaxButton 及 MinButton 的属性来让我们移除最大化及最小化的按钮，如果您想移除 MDIForm 的最大化及最小化的按钮，您可以在 MDIForm 中加入以下的程序，但是如果您只想移除其中的一个，则只要将对应的程序码加上注解符号即可。
'请在 MDIForm 的声明区中加入以下声明
#If Win32 Then
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
#Else
Private Declare Function SetWindowLong Lib "User" (ByVal hwnd As Integer, ByVal nIndex As Integer, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "User" (ByVal hwnd As Integer, ByVal nIndex As Integer) As Long
#End If
Const WS_MINIMIZEBOX = &H20000 '最小化
Const WS_MAXIMIZEBOX = &H10000 '最大化
Const GWL_STYLE = (-16)
'在 MDIForm 的 MDIForm_Load 事件中加入以下程序码
Sub MDIForm_Load()
Dim lWnd As Long
lWnd = GetWindowLong(Me.hwnd, GWL_STYLE)
lWnd = lWnd And Not (WS_MINIMIZEBOX) '最小化
lWnd = lWnd And Not (WS_MAXIMIZEBOX) '最大化
lWnd = SetWindowLong(Me.hwnd, GWL_STYLE, lWnd)
End Sub
162、如何防止 Form 被移动？
有些应用程序，我们希望固定 Form 的位置，不希望使用者移动它，在 VB5 以上的版本，我们可以直接在属性表中设定 Form 的 Moveable 属性为 False 即可。
但是 VB4 以下的版本却没有这个功能，这时就得借助 API 的功能了！而我们实际要做的，就是移除系统功能表 ( ControlBox ) 中的【移动】的功能，您可以检查一下您现在使用的浏览器左上方的系统功能表，【移动】的位置是第二个，所以 Index = 1 ( index 由 0 算起 )。
'请在表单的声明区中加入以下声明
Private Declare Function GetSystemMenu Lib "User" (ByVal hWnd As Integer, ByVal bRevert As Integer) As Integer
Private Declare Function RemoveMenu Lib "User" (ByVal hMenu As Integer, ByVal nPosition As Integer, ByVal wFlags As Integer) As Integer
Const MF_BYPOSITION = &H400
'在 Form_Load 事件中加入以下程序码
Private Sub Form_Load()
SystemMenu% = GetSystemMenu(hWnd, 0)
Res% = RemoveMenu(SystemMenu%, 1, MF_BYPOSITION) <--- 第二个参数是 Index
End Sub
163、如何设定 ComboBox 之最大长度？
在文字框 (TextBox) 中，我们可以设定 MaxLength 属性来设定文字框可输入的最大长度，但是同样具有一个文字框的 ComboBox，却没有提供这样的功能！要做到这个功能，必须自己写程序来判断。
'下面就是一个范例程序：
'我们在 Key_Press 事件来处理，程序中假设最大长度为 10，并已将倒退键排除在外
Private Sub Combo1_KeyPress(KeyAscii As Integer)
Const MAXLENGTH = 10 '设定最大长度为 10
If Len(Combo1.Text) >= MAXLENGTH And KeyAscii <> vbKeyBack Then
KeyAscii = 0
End If
End Sub
164、如何撰写没 Form 的程序？
一般在撰写 VB 的程序时，由于一进入 VB 的环境时就会自动产生一个 Form1，而 VB 本身又是一种事件驱动程序，所以有些人一直认为 VB 的程序一定会有一个以上的 Form 存在。其实 VB 也可以撰写一些完全没有表单 (Form) 的程序。
撰写的方法如下：
1、启动一个新的工程 (Project)
2、移除 Form1
3、开启一个 Module (名称可自取，或使用 Default 名称 Module1)
4、在 Module 中加入一段名为 Main 的 SubRoutine (名称一定要取为 Main)
'例：下面的程序执行时会开启 c:/test.txt 并写入一个数字，然后直接结束，没有任何表单。
Public Sub Main()
Open "c:/test.txt" For Output As #3
Print #3, 6666
Close #3
End '可有可无,会自动结束
End Sub
165、别让 MsgBox 中断了一些 Background 的处理作业
在 VB 中，一旦您呼叫了 MsgBox，您正在执行的一些 Background 的处理作业，例如计数器或时钟...等，都会停下来，直到您回应了 MsgBox 之后，一切才会恢复正常！或许您并不希望如此，这也有可能造成一些不必要的错误！
要解决这个问题，您必须使用 Windows API 去呼叫 MessageBox Function，它的使用方法、外观和 MsgBox 的结果完全相同，但是它却不会中断一些 Background 的处理作业！
在以下的范例中，您要在 Form 中加入一个 Label、二个 CommandButton 及一个 Timer，不更改任何属性。
'在声明区中加入以下声明：
Private Declare Function MessageBox Lib "user32" Alias "MessageBoxA" (ByVal hwnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As Long) As Long
'加入以下程序码：
Private Sub Command1_Click()
MsgBox "计时器停掉了！", 64, "VB 的讯息框"
End Sub
Private Sub Command2_Click()
MessageBox Me.hwnd, "注意！计时器还在跑！", "API 的讯息框", 64
End Sub
Private Sub Form_Load()
Timer1.Interval = 1000
Label1.Caption = "目前的时间是：" & Time
End Sub
Private Sub Timer1_Timer()
Label1.Caption = "目前的时间是：" & Time
End Sub
166、如何找出 Windows / System / Temp 目录的正确路径？(二)
记得我们分三个单元来说明如何找出 Windows / System / Temp 目录的正确路径？
当时我们都是使用 API 来做，使用的 API 分别是：
问题如何找出 Windows 目录的正确路径？
使用 GetWindowsDirectory Function
问题如何找出 System 目录的正确路径？
使用 GetSystemDirectory Function
问题如何找出 Temp 目录的正确路径？
使用 GetTempPath Function
有的人不太喜欢使用 API，一来有的 API 有点难，一来比较不容易找到完整的资料说明或完整的范例。不过以上三个题目都可以不使用 API 就得到答案的！原因如下：
在我们启动电脑的同时，我们的操作系统，会挪出一个区块，用来存放一些系统环境变量，或许您会问，到底存了哪些东西呢？其实说来不外乎几个来源：
1、Autoexec.bat：TMP / TEMP / PATH / PROMPT .....
2、Config.sys：COMSPEC .....
3、Msdos.sys：WinDir / WinBootDir .....
4、当然您的电脑中不一定有 Autoexec.bat 或 Config.sys，不过没关系，系统自己会给定一些初始值！
而这些环境变量，在 VB 中只要使用 ENVIRON Statement 就可以抓得到！语法如下：
Environ[$](environmentstring)
其中 environmentstring 是一个环境变量的字串，例如：〈TEMP〉、〈WinDir〉、〈PATH〉...等。
所以，如果您 .....
要得到 TEMP 的路径，只要使用 Environ("TEMP") 即可，结果可能为 C:/WINDOWS/TEMP。
要得到 Windows 的路径，只要使用 Environ("Windows") 即可，结果可能为 C:/WINDOWS。
而如果您想找到 System 的路径，我想有了 Windows 路径之后，应该不是难事了吧！
167、如何将长文件名转成短文件名格式 (MS-DOS 8.3)
虽然在 Windows95/98 中已经都可以使用长文件名/目录 (最长可以到255个字元)，但是在您将长文件名的文件或目录存档时，系统同时给了它一个可以相容于以前 MS-DOS 时代的 8.3 格式的文件名称！
到目前为止，还是有些软件会使用 8.3 格式的文件名称，在安装这些软件时，它们写到注册表中的资料，仍然采用 8.3 格式的文件名称，所以有时候，您在维护系统时，必须知道目前这时长文件的档案，转成 8.3 格式的文件名称之后是什么文件。
以下这个范例会让您在 DirListBox 及 FileListBox 中选择目录及文件名称，然后将您选出的(长)文件名转成 8.3 格式的文件名称，如果您有注意到的话，它不但是将文件名称转掉，连长文件的目录名称也会一起转成 8.3 格式的文件名称。
由于程序码较长，我不再列出程序码，而直接将文件压缩下载：
Source Code 下载
168、清除画面中各栏位资料
当一个 Form 中只有二、三个物件的时候，您要清除其中的资料，您会一个栏位一个栏位来清除，反正就是那么几个物件，二三行指令也就解决了！
但是，若您的 Form 中有二、三十个，甚至五、六十个以上的物件时，可就要想想办法了！以下的这个模组就在这种情形下产生了，一般要清除资料，最重要的二个属性就是 .Text 及 .LisIndex。
Public Sub ClearAllControls(frmFORM As Form)
Dim ctlControl As Object
On Error Resume Next
For Each ctlControl In frmFORM.Controls
ctlControl.Text = ""
ctlControl.ListIndex = -1
DoEvents
Next
End Sub
而在程序中要呼叫这个模组只要如下使用即可：
call ClearAllControls(Me)
169、为您精心设计的画面拍张快照吧！( Taking a screenshot )
我们在设计系统时，有时候会保留让使用者做屏幕 HardCopy 的功能。
以前，我总是要求使用者自己去按键盘上的【Print Screen】按钮，将画面的影像留在【剪贴板】中，并要求使用者自己到 Windows95/98 提供的【小画家】或【小作家】中，先做【贴上】的动作后，再将画面影像存成 .BMP 档或直接由印表机中印出。
上面这些动作，对一个程序开发者，或一个熟练的操作者并不困难，但是，很可悲的，大部份的使用者都不属于以上所描述的二种人，例如：我曾经写过一个系统是给大楼清洁维护公司的人员用的，其中有很多使用者甚至是一些学历不高的『欧巴尚』，不但程序的设计都要简化操作，连系统上线都是高难度的，更别说屏幕的 HardCopy 列印、存档的动作了！
不过，以上的动作，我们都可以直接在 VB 的程序中做到，要做到这个功能有二个方法：
方法一：直接模拟按【Print Screen】按钮，再将【剪贴板】中的图像抓到 Picture 中。
方法二：完全使用 API 来处理。
下面来看看第二种做法：
'请在声明区中加入以下声明：
Private Declare Function GetDesktopWindow Lib "user32" () As Long
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 BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Const SRCCOPY = &HCC0020
'在 Form 中加入二个 CommandButton，及一个 PictureBox，不必更改属性，加入以下程序码：
Private Sub Form_Load()
'将 Picture1 之长宽设定成和屏幕一样大小
Picture1.Width = Screen.Width
Picture1.Height = Screen.Height
End Sub
Private Sub Command1_Click()
'将屏幕画面抓下后放到 Picture1 中
Dim lngDesktopHwnd As Long
Dim lngDesktopDC As Long
Picture1.AutoRedraw = True
Picture1.ScaleMode = vbPixels
lngDesktopHwnd = GetDesktopWindow
lngDesktopDC = GetDC(lngDesktopHwnd)
Call BitBlt(Picture1.hdc, 0, 0, Screen.Width, Screen.Height, lngDesktopDC, 0, 0, SRCCOPY)
Picture1.Picture = Picture1.Image
Call ReleaseDC(lngDesktopHwnd, lngDesktopDC)
End Sub
Private Sub Command2_Click()
'将 Picture1 中的屏幕画面存成 .BMP 档
SavePicture Picture1, "C:/TEST.BMP"
End Sub
在以上的范例中，只要按下 Command1 就会将屏幕的画面截取下来放到 Picture1 中，按下 Command2 之后，就会将 Picture1 中的图片存成文件 ( 文件名称可自行更改 )，如果您想打印，也可以直接使用 PaintPicture 将图片丢到打印机中打出！
至于图片的打印，以后会另有单元介绍。
170、随心所欲地移除表单左上方的系统功能表的某几个项目
针对这个主题，其实以前已经讨论过二次了，只不过不是以这样直接了当的方式点出在题目中而已，不知道大家是否有印象？
这二次分别是：
问题：如何移除 Form 右上方之『X』按钮？
对应到系统功能表的【关闭】选项
问题：如何防止 Form 被移动？
对应到系统功能表的【移动】选项
而我在网路上闲逛时，看到有个外国人用了一个很笨的方法写了一个模组，不过对于不想研究 API 的人来说应该是很好用的模组，可以让您用选择的方式随便您想移除系统功能表的任一个项目！
完整程序码如下，说明加在其中：
'在声明区中加入以下声明：
'抓取系统 Menu 的 hwnd
Private Declare Function GetSystemMenu Lib "user32" (ByVal hWnd As Integer, ByVal bRevert As Integer) As Integer
'移除系统 Menu 的 API
Private Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Integer, ByVal nPosition As Integer, ByVal wFlags As Integer) As Integer
'第一个参数是系统 Menu 的 hwnd
'第二个参数是要移除选项的 Index
Private Const MF_BYPOSITION = &H400&
'模组内容如下：
Private Sub RemoveMenus(frm As Form, remove_restore As Boolean, remove_move As Boolean, remove_size As Boolean, remove_minimize As Boolean, remove_maximize As Boolean, remove_seperator As Boolean, remove_close As Boolean)
Dim hMenu As Long
' 抓取系统 Menu 的 hwnd
hMenu = GetSystemMenu(hWnd, False)
If remove_close Then RemoveMenu hMenu, 6, MF_BYPOSITION '是否移除【关闭】选项
If remove_seperator Then RemoveMenu hMenu, 5, MF_BYPOSITION '是否移除【分隔线】
If remove_maximize Then RemoveMenu hMenu, 4, MF_BYPOSITION '是否移除【放到最大】选项
If remove_minimize Then RemoveMenu hMenu, 3, MF_BYPOSITION '是否移除【缩到最小】选项
If remove_size Then RemoveMenu hMenu, 2, MF_BYPOSITION '是否移除【大小】选项
If remove_move Then RemoveMenu hMenu, 1, MF_BYPOSITION '是否移除【移动】选项
If remove_restore Then RemoveMenu hMenu, 0, MF_BYPOSITION '是否移除【还原】选项
End Sub
这个模组共有八个参数，第二个到第八个参数分别对应到系统功能表的七个选项！ ( True / False )
今天如果我想做到和问题如何移除 Form 右上方之『X』按钮？一样的结果，表示我要将对应到系统功能表的【关闭】选项移除，则我只要将相对应的参数设成 True 即可，其他要保留的则为 False。
范例如下：
Private Sub Form_Load()
　　RemoveMenus Me, False, False, False, False, False, True, True
End Sub
VB问题全功略（35） [查找本页请按Ctrl+F]
［上一页］（35）［下一页］
171、如何防止使用者按下 CTRL + ALT + DEL
172、如何将 Excel 的资料表导入 Access资料库？
173、取得个人电脑中的设定资讯
174、您想知道有谁正在使用您的 Access 资料库吗？
175、为何声明资料库型态变量时出现《编译错误：使用者自订型态尚未定义》
171、如何防止使用者按下 CTRL + ALT + DEL
有些时候，我们的应用程序执行时，不希望使用者按下 CTRL + ALT + DEL 来异常结束程序或关机，这时候我们可以在启动程序时，将 CTRL + ALT + DEL 功能键之功能取消，然后在结束程序之前，再从新恢复 CTRL + ALT + DEL 之功能。
在模组声明区中加入以下声明及模组：
Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long
Public Const SPI_SCREENSAVERRUNNING = 97
Public Sub Disable_Ctrl_Alt_Del()
'让 CTRL+ALT+DEL 失效
Dim AyW As Integer
Dim TurFls As Boolean
AwY = SystemParametersInfo(SPI_SCREENSAVERRUNNING, True, TurFls, 0)
End Sub
Public Sub Enable_Ctrl_Alt_Del()
'让 CTRL+ALT+DEL 恢复功能
Dim AwY As Integer
Dim TurFls As Boolean
AwY = SystemParametersInfo(SPI_SCREENSAVERRUNNING, False, TurFls, 0)
End Sub
'实际使用时，在 Form 中加入以下程序码：
Private Sub Form_Load()
Disable_Ctrl_Alt_Del
End Sub
Private Sub Form_Unload(Cancel As Integer)
Enable_Ctrl_Alt_Del
End Sub
172、如何将 Excel 的资料表导入 Access资料库？
将程序码做成模组，只要传入必要之参数即可！
此一模组共有四个参数：
1、sSheetName：要导出资料的资料表名称 (Sheet name)，例如 Sheet1
2、sExcelPath：要导出资料的 Excel 文件路径名称 (Workbook path)，例如 C:/book1.xls
3、sAccessTable：要导入的 Access Table 名称，例如 TestTable
4、sAccessDBPath：要导入的 Access 文件路径名称，例如 C:/Test.mdb
在声明区中加入以下声明：
Private Sub ExportExcelSheetToAccess(sSheetName As String, sExcelPath As String, sAccessTable As String, sAccessDBPath As String)
Dim db As Database
Dim rs As Recordset
Set db = OpenDatabase(sExcelPath, True, False, "Excel 5.0")
Call db.Execute("Select * into [;database=" & sAccessDBPath & "]." & sAccessTable & " FROM [" & sSheetName & "$]")
MsgBox "Table exported successfully.", vbInformation, "Yams"
End Sub
使用范例如下：将 C:/book1.xls 中的 Sheet1 导入 C:/Test.mdb 成为 TestTable
ExportExcelSheetToAccess "Sheet1", "C:/book1.xls", "TestTable", "C:/Test.mdb"
173、取得个人电脑中的设定资讯
许多在控制面板中的设定，如果在 VB 的程序中需要知道的话，我们都可以透过 GetLocaleInfo 这个 API 来取得！以下我们已经将它模组化 (WinLocaleInfo)，只　传入一个参数即可得到解答！
在声明区中加入以下的声明及模组：
Private Declare Function GetLocaleInfo Lib "kernel32" Alias "GetLocaleInfoA" (ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As String, ByVal cchData As Long) As Long
Public Function WinLocaleInfo(ByVal lnfoType As Long) As String
Dim sLCData As String
Dim nRet As Long
nRet = GetLocaleInfo(0, lnfoType, sLCData, 0)
If nRet Then
sLCData = Space$(nRet)
nRet = GetLocaleInfo(0, lnfoType, sLCData, Len(sLCData))
If nRet Then
WinLocaleInfo = Left$(sLCData, nRet)
End If
End If
End Function
实际在运用时，可传入的参数相当多，连我也不知道到底有多少个，不过别担心，只要在 VB 附的 API 检视员中就可以找到所有可以传入的参数了！这些参数有一个共通点，都是以 "LOCALE_" 为开头字串，以下举几个例子给大家看看：
LOCALE_SCURRENCY = &H14 ' 货币符号
LOCALE_SDATE = &H1D ' 日期分隔字元
LOCALE_SDAYNAME1 = &H2A ' 完整星期名称
LOCALE_SDECIMAL = &HE ' 小数点符号
'以下是一个实例：
Private Sub Command1_Click()
Text1 = WinLocaleInfo(&H14) '可能返回 NT$
Text2 = WinLocaleInfo(&H1D) '可能返回 /
Text3 = WinLocaleInfo(&H2A) '可能返回星期一
Text4 = WinLocaleInfo(&HE) '可能返回 .
End Sub
174、您想知道有谁正在使用您的 Access 资料库吗？
如果您使用 Access 建立了一个多人使用的资料库环境，有时候您必须要知道有谁正在使用程序连进这个共享的资料库，但是您又不想因为如此而要建立一套完整的 Access 安全系统，您有二个选择：
第一个：
您可以在资料库中建立一个 "Login Table"，每次使用者进入或离开系统时就 Update 这个 Table.
第二个：
较好一点，您可以使用 msldbusr.dll，它可以告诉您目前正连进资料库的电脑名称 (Computer Name)，这些资料其实是存放在扩展名为 LDB 的文件中。一旦您从 DLL 中抓到这些资料，您便可以送出讯息，通知 Client 端的使用者 (Remote User) 结束应用程序，以中断和资料库的连结，然后您便可以使用 Exclusive Mode 来维护资料库了。
在这里，我们要说明的是第二种方法，也就是使用 msldbusr.dll。它提供了二个 Function，说明如下：
1、LDBUser_GetUsers：呼叫后会返回二部份，一个是使用者阵列，一个是连结到资料库的使用者数。
Declare Function LDBUser_GetUsers Lib "MSLDBUSR.DLL" (lpszUserBuffer() _
As String, ByVal lpszFilename As String, ByVal nOptions As Long) As Integer
lpszUserBuffer()：返回使用者阵列，注意！必须使用 ReDim 声明成变动阵列！
lpszFilename：资料库名称 ( .mdb 完整路径 )，若 .ldb 文件不存在，会返回错误代码。
nOptions：下参数声明资料回传的型态。可以使用的参数有四个，如下：
1=返回自从 .ldb 产生后，所有曾经使用资料库的使用者机器名称 (Computer Name) 及数目。
2=只返回目前正在使用资料库的使用者机器名称 (Computer Name) 及数目。
4=只返回导致目前资料库损毁的使用者机器名称 (Computer Name)。
8=只返回使用者的总数，但是并不返回使用者阵列。
2、LDBUser_GetError：呼叫 LDBUser_GetUsers 若有错误产生，可根据返回的错误代码找到说明。
Declare Function LDBUser_GetError Lib "MSLDBUSR.DLL" (ByVal nErrorNo As Long) As String
nErrorNo：呼叫 LDBUser_GetUsers 产生错误所返回的代码，介于 -1 至 -14 之间。说明如下：
-1 = Can't open the LDB file. ( 无法开启 LDB 文件 )
-2 = No user connected. ( 没有使用者在使用资料库 )
-3 = Can't create an array. ( 无法建立阵列 )
-4 = Can't redimension array. ( 无法重新建立阵列 )
-5 = Invalid argument passed. ( 传入无效的参数 )
-6 = Memory allocation error. ( 内存配置错误 )
-7 = Bad index. ( 无效的索引 )
-8 = Out of memory. ( 内存不足 )
-9 = Invalid argument. ( 无效的参数 )
-10= LDB is suspected as corrupted. ( LDB 文件可能损毁 )
-11= Invalid argument. ( 无效的参数 )
-12= Unable to read MDB file. ( 无法读取 MDB 文件 )
-13= Can't open the MDB file. ( 无法开启 MDB 文件 )
-14= Can't find the LDB file. ( 找不到 LDB 文件 )
'范例程序：( 移除所有的 Form，请将以下程序复制到 .bas 文件中即可执行 )
Option Explicit
Declare Function LDBUser_GetUsers Lib "MSLDBUSR.DLL" (lpszUserBuffer() _
As String, ByVal lpszFilename As String, ByVal nOptions As Long) As Integer
Declare Function LDBUser_GetError Lib "MSLDBUSR.DLL" (ByVal nErrorNo As Long) As String
Sub MAIN()
Dim psMDBFilename As String
psMDBFilename = InputBox("请输入资料库名称：")
If Len(psMDBFilename) Then
ShowUsers psMDBFilename
End If
End Sub
Sub ShowUsers(psFilename As String)
ReDim lpszUserBuffer(1) As String
Dim psError As String
Dim cUsers As Long
Dim iLoop As Long
'呼叫 LDBUser_GetUsers 返回使用者阵列
cUsers = LDBUser_GetUsers(lpszUserBuffer(), psFilename, 1)
'确认是否返回使用者阵列
If (cUsers = 0) Then
Debug.Print "No Users."
GoTo Exit_ShowUsers
End If
'若有错误则显示错误讯息
If (cUsers < 0) Then
psError = LDBUser_GetError(cUsers)
Debug.Print "Error #:"; cUsers; "--"; psError
GoTo Exit_ShowUsers
End If
'显示使用者阵列
For iLoop = 1 To cUsers
Debug.Print "User "; iLoop; ":"; lpszUserBuffer(iLoop)
Next iLoop
Exit_ShowUsers:
End Sub
'除了上面的范例之外，Microsoft 也提供了一个更完整的范例，它有一个容易理解的介面设计：
如果您在这个主题中想要更多的资讯，或想取得 Microsoft 提供的更多的工具程序，您可以参考：
http://support.microsoft.com/support/kb/articles/q176/6/70.asp
175、为何声明资料库型态变量时出现《编译错误：使用者自订型态尚未定义》
很多人在学习用 VB 撰写资料库程序时，都会从使用 VB 提供的 Data Control 加上各种资料库感知控制项 ( Data Aware Control ) 开始，因为这样子的组合，您甚至一行程序都不用写就可以完成一支简单的资料库程序了！
然而，为了程序控制的灵活度或其他原因，您会开始想要自己声明资料库物件，自己控制各种资料的处理动作，于是您在程序中加入了类似以下的声明： ( 因为书上及 Help 都这么写 )
Dim DB As Database
Dim SS As Snapshot
:
写了一支很简单的程序之後，当您想看看成果，而按下【开始执行】的按钮时，却从电脑中发出了一声令人惊心动魄、代表错误的声响！ (如果您有装 Sound Card 的话) 您一遍一遍的检查程序，已经是最简单的程序了，怎么可能会错误呢！让我们来看看错误讯息：《编译错误：使用者自订型态尚未定义》
其实您的程序并没有错，您声明的资料型态也都是对的，只是定义它的物件程序库或型态程序库并没有在 Visual Basic 中注册而已。解决方法如下：
从【专案】功能表中选择【设定引用项目】，在【可引用的项目】栏中选择【Microsoft DAO x.x Object Library】【Microsoft DAO x.x/x.x Compatibility Library】即可。
其中 x.x 代表的是某一个资料库引擎的版本，x.x/x.x 则代表相容于好几个版本的资料库引擎！
如果您的公司中有人使用 Access2.0 / Access95 / Access97 ...等多个不同的版本时，您可以使用【Microsoft DAO 2.5/3.5 Compatibility Library】。
176、模拟 VB 程序执行时产生的错误讯息
VB 程序执行时若有错误产生，而程序中又没有错误控制的话，便会出现 VB 内定的错误编号及错误讯息，但是这个错误讯息通常都很简短，所以使用者和写程序的人反应时，有时候也不知道是什么意思及该如何处理。而且这种错误有时候在开发人员的机器上不会发生，只有在使用者的机器上才会发生，所以开发人员也模拟不出来！
虽然 VB 的错误编号及讯息都很简短，但是在 VB 的线上说明中都有比较详细的错误分析及解决方法，只是有些人找不到，所以常常有人在问 VB 产生的错误讯息是什么意思及该如何处理。
VB 的 Err 物件其实就可以让我们模拟错误，以下的 Sample 是从 VB 的 HELP 中节录出来的：
' If an error occurs, construct an error message
On Error Resume Next ' Defer error handling.
Err.Clear
Err.Raise 6 ' Generate an "Overflow" error.
' Check for error, then show message.
If Err.Number <> 0 Then
Msg = "Error # " & Str(Err.Number) & " was generated by " & Err.Source & Chr(13) & Err.Description
MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext
End If
以上的程序加了 On Error Resume Next，所以并不会中断跳出来，而出现的讯息框内容如下，有错误编号及错误讯息，而且错误讯息很简短，而且它只有一个【确定】按钮，对我们帮助不大：
Error # 6 was generated by Project1
OverFlow
今天如果在 Design Time 时将 On Error Resume Next 拿掉，出现的讯息框如下：
Run-time error '6'
OverFlow
除了以上的讯息外，它有四个按钮，分别是【Continue】、【End】、【Debug】、【Help】，而最后一个按钮【Help】就可以让我们直接进到 Help 看到以下的详细说明：
Overflow (Error 6)
An overflow results when you try to make an assignment that exceeds the limitations of the target of the assignment. This error has the following causes and solutions:
The result of an assignment, calculation, or data type conversion is too large to be represented within the range of values allowed for that type of variable.
Assign the value to a variable of a type that can hold a larger range of values.
An assignment to a property exceeds the maximum value the property can accept.
Make sure your assignment fits the range for the property to which it is made.
For additional information, select the item in question and press F1.
所以，下一次您就可以使用这个方法来方便找到详细的错误说明！
177、如何取得文件大小？
VB6 提供了一个新的物件模型，叫做 FSO (File System Object) 物件模型，运用它，我们可以很方便的处理磁盘、资料夹和文件的一些动作。
FSO 物件模型含有好几个物件，其中有一个 File 物件是用来求得文件的相关资讯，在目前这个主题，我们就可以使用 File 物件！它有一个属性是 Size，对文件来说就是指文件的大小 (单位为位元组)。 (注一)
虽然使用 File 物件的 Size 属性就可以求得文件的大小，但是它有以下二个缺点：
1、只能用于 VB6 以后的版本。
2、它不是 VB6 内定的功能，必须另外引用 Scrrun.dll (Microsoft Scripting Runtime) 才可以！
以下的二个方法就可以使用在所有的 VB 版本中 (含 VB6)，而且是 VB 内定的功能：
1、FileLen 函数：返回一个 Long，代表一个文件的长度，单位是位元组。
语法：FileLen(pathname) ' pathname 是全路径之文件名称
适用：取得一个尚未开启的文件的长度大小 (注二)
2、LOF 函数：返回一个 Long ，单位为位元组，用来代表由 Open 陈述式所开启的文件之大小。
语法：LOF(filenumber) ' filenumber 是一个文件代码
适用：取得一个已开启的文件的长度大小
注一：File 物件的 Size 属性除了可以求得一个文件的大小，也可以用来取得整个目录的所有文件大小！
注二：使用 FileLen 函数时，如果所指定的文件正在开启中，则所返回的值是这个文件在开启前的大小。
178、如何一次读取整个文件的内容？
通常我们要读取整个文件的内容时，都是一行一行读进来，再使用变数来累加。除了这种方法之外，您还可以使用 GET Function，只要呼叫一次就可以读入一整个文件了！而且速度更快！
以下这个模组就是使用 GET 来读入整个文件，参数只有一个，就是含路径的文件名：
Function FileContent(FileName As String) As String
Dim FileNo As Integer
Dim FileString As String
FileNo = FreeFile
Open FileName For Binary As #FileNo
FileString = Space(FileLen(FileName))
Get #FileNo, , FileString
Close #FileNo
FileContent = FileString
End Function
使用实例如下：
Private Sub Command1_Click()
RichTextBox1 = FileContent("C:/Test.txt") (注)
End Sub
注：
当文件大小小于 64K 时可使用 TextBox
当文件大小大于 64K 时请使用 RichTextBox
若是 VB6 您还可以使用 FSO 物件模型中的 TextStream 物件的 ReadAll 方法来读一个完整的 TextStream 文件并返回得到的字串。
对于太大的文件，使用以上的方法浪费记忆体资源。应使用其它的技术去输入一个文件，比如一列一列地读取文件。
179、如何使用文本文件来存取 ListBox 内的资料？
当我第一次在网路上的讨论区中看到有人提到以下的二个问题时：
1、请问如何将 TextBox 或 ListBox 的资料存到文本文件中？
2、请问如何将文本文件中的资料一行一行读出放到 ListBox 中？
我真的有一点惊讶，因为我一直都是待在民营企业的 MIS 部门，所有的系统都要使用到资料库，像这样的问题，我们在系统设计时，都会在资料库中用一个片语文件来存放，不管系统大小，都可以将这一类的资料存在片语文件中，再依类别来区分，还可以依使用者　要来加以编号排序，除此之外，也方便统一管理。
不过，不管是国内或国外的讨论区中，这样的问题却一直不断的有人在问，而且频率不低，这让我体会到，基于各种理由，并不是所有人都一定要使用资料库来存放这些资料！
若要使用文本文件来存放这些资料，其实最需要了解的，就是文本文件的存取方法！
在以下的范例中，我使用到二个 ListBox 及二个 CommandButton，不需更改任何属性！按下 Command1 时，会将 List1 中的资料放到暂存文件中，按下 Command2 时，再将暂存文件中的资料放到 List2 中。
Private Sub Command1_Click()
'将 ListBox 资料放到文本文件中
Dim i As Integer
Open "c:/temp.txt" For Output As #1
For i = 0 To List1.ListCount - 1
Print #1, List1.List(i)
Next
Close #1
End Sub
Private Sub Command2_Click()
'将文本文件中资料读出放到 ListBox 中
Dim wstr As String
Open "c:/temp.txt" For Input As #1
Do While Not EOF(1) '执行回圈直到文件尾为止。
Input #1, wstr
List2.AddItem wstr
Loop
Close #1
End Sub
不过如果您的系统有使用到资料库，而您之前没有想到要使用资料库的片语文件来存放这些资料的话，我建议您试试看，您会发现片语文件真的很方便，不管什么杂七杂八的资料，只要一个文件就解决了！
180、字串取代之【全部取代】
在一般的应用软体中，例如 Word、小作家、Excel....等，都会提供字串取代【全部取代】的功能，这个功能很简单，就是将整篇文章从头到尾找一遍，碰到您要找的字串，就将它转换成您要取代的字串。
当然，或许您会说 VB6 不是己经有提供这个功能了吗？没错！VB6 己经有提供这个功能了，但是据我所知，目前企业界实际在使用 VB6 的比例并不高！大部份还是使用 VB5 / VB4-32，这个模组就是专为 VB6 以前的版本写的。
以下这个模组 myReplaceString ，它共有三个参数，说明如下：
1、hString：您要搜寻的一篇文章。
2、hSource：要搜寻到的子字串。
3、hTarget：用来取代的子字串。
整个模组的程序码很短，如下：
Public Function myReplaceString(ByVal hString As String, ByVal hSource As String, ByVal hTarget As String) As String
　　tLen = Len(hSource)
　　tChk = (Len(hTarget) = Len(hSource))
　　tLoc = 1
　　Do
　　　　tLoc = InStr(tLoc, hString, hSource)
　　　　If tLoc <> 0 Then
　　　　　　If tChk Then
　　　　　　　　Mid(hString, tLoc, tLen) = hTarget
　　　　　　Else
　　　　　　　　hString = Left(hString, tLoc - 1) + hTarget + _
　　　　　　　　Mid(hString, tLoc + tLen)
　　　　　　End If
　　　　　　tLoc = tLoc + Len(hTarget)
　　　　Else
　　　　　　Exit Do
　　　　End If
　　Loop
　　myReplaceString = hString
End Function
而返回值就是已经经过转换后的新文章！
181、如何在 VB5 中打开 VB6 的工程？
如果您用 VB5 打开 VB6 撰写的工程，会出现一个类似以下的讯息：
"Retained 为不正确的键。无法载入文件 C:/Windows/Desktop/Project1.vbp。"
"Retained is an invalid key. The file C:/Windows/Desktop/Project1.vbp can't be loaded".
那是因为在 VB6 的工程的 .vbp 文件中，多了一个之前的 VB 版本不认得的键值 "Retained" 的缘故！
要解决这个问题很简单，您只要依照以下的几个步骤：
1、使用记事本 (Notepad.exe) 打开 VB6 的工程的 .vbp 文件。
2、在这个文件中找到包含 "Retained" 字串的那一行，将那一整行移除。
3、存文件。
这样子您就可以使用 VB5 来打开之前使用 VB6 开发的工程了！很简单吧！
注：我在别的网站上看到有人说，这样子做了之后不一定百分之百成功，不过我自己试了之后，倒是没有出现错误，各位也自己试试吧！
182、VB6.0 的 Help 在那里？MSDN 是什么？
很多人在安装了 VB6.0 ，开始撰写程序之后，遇到了问题，按下【F1】，却出现了错误讯息，告诉您：
【MSDN 不存在......，请重新安装 MSDN】
有的人还会觉得很奇怪，VB6.0 的 Help 出了什么问题了？MSDN 又是什么？为什么要重新安装 MSDN？
其实，从 VB6.0 以后，Microsoft 已经将它所有的开发软件，合并成 Microsoft Visual Studio 6.0，一起出售 ( 当然，也有分开独立贩售的版本 )，在合并软件的同时，Microsoft 也将每一个开发软件的 Help 挪出来，统一放在 MSDN 光盘中，所以，现在不管您买的是合并软件的 Microsoft Visual Studio 6.0 或是独立贩售的 VB6.0 版本，都会另外附上二片 Microsoft MSDN Library 光盘。
今天，如果您购买的是独立贩售的 VB6.0 版本，在您安装完 VB6.0 之前，安装程序会要求您放入 MSDN 光盘，它会继续帮您安装 MSDN (也就是新版的 Help)。至于安装的注意事项，请参考
问题10:不方便的 Msdn -- VB6.0 的 Help
如果您安装 VB6.0 时，没有同时安装 MSDN，也没关系，您只要找到 MSDN 光盘，将第一片放入光驱，直接执行 Setup.exe 即可！
注：VB6 及 Microsoft Visual Studio 6.0 所附之 MSDN Library 光盘其实只是一个特殊版本，是专门针对 Microsoft Visual Studio 6.0 所推出的！MSDN Library 光盘在 VB6 及 Microsoft Visual Studio 6.0 出现之前就已经存在很久了，是微软针对程序开发人员的官方的技术资源，它定期提供产品操作手册、范例程序、技术文章、公用程序及许多最新的技术资料。而随 VB6 及 Microsoft Visual Studio 6.0 所附之 MSDN Library 光盘内容包含 VB6 及 Microsoft Visual Studio 6.0 的最新产品手册 (电子书) 及技术资料。
183、如何判断资料库中某一个 Table 是否存在？(ADO)
要判断资料库中某一个 Table 是否存在？最简单的方法就是错误尝试法！什么叫做错误尝试法呢？就是先假设它存在，直接去打开它，如果它真的存在，不会有错误产生，但是如果它不存在的话，就会有错误产生！做法大致如下：
1、设定 On Error Resume Next
2、直接打开要检查的 Table
3、如果文件存在，则 err.Number=0
我们就以 Access 为例，资料库使用 VB 内附的 Biblio.mdb，程序码如下：
On Error Resume Next '1
Set Conn = CreateObject("ADODB.Connection")
Conn.open "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False;Data Source=C:/Biblio.mdb"
Set rs = Conn.execute("Titles") '2
If Err.Number <> 0 Then MsgBox "Table 不存在" Else MsgBox "Table 存在" '3
184、如何移除或更改桌面背景的底色图案 (Wallpaper)？
SystemParametersInfo 这个 API 可以设定许多 Windows 系统的功能参数，而其中一个参数就是桌面底图！通常一般的使用者会透过控制面板中的【显示器】来设定桌面底图。
在底下的范例中，我们使用 SPI_SETDESKWALLPAPER 这个参数及图片文件名称来设定新的桌面底图，同时使用 SPIF_SENDWININICHANGE 来通知各个视窗这个改变。
'在表单的声明区中加入以下声明及常数：
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As String, ByVal fuWinIni As Long) As Long
Const SPI_SETDESKWALLPAPER = 20
Const SPIF_UPDATEINIFILE = &H1
Const SPIF_SENDWININICHANGE = &H2
'在表单上加入一个 CommandButton (Command1) 来移除桌面底图，程序码如下：
Private Sub Command1_Click()
Dim X As Long
X = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0&, "(None)", SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE)
MsgBox "桌面底图 (Wallpaper) 已经被移除"
End Sub
'在表单上加入另一个 CommandButton (Command2) 来更改桌面底图，程序码如下：
Private Sub Command2_Click()
Dim FileName As String
Dim X As Long
FileName = "c:/windows/test.bmp"
X = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0&, FileName, SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE)
MsgBox "桌面底图 (Wallpaper) 已经被更改"
End Sub
185、如何在不开启文件的情况下打印各类文件？
您还记得或怀念以前 DOS 时代，在 DOS 的命令列就可以直接下指令打印文件吗？
其实这个题目的标题，就如同当今的报纸标题一般，有点夸张，因为要打印文件，势必要先开启文件！
但是您也不用失望，既然标题会这样订，表示我也有好方法 (其实应该说 Microsoft 有提供好方法)！您只要使用 ShellExecuteAny 这个 API，对于各种不同格式不同类型的文件，您都不用自己先去启动开启该类文件的应用程序，再开启文件，再打印文件！
看到上面的说明，是否让您回想起之前我们提到过的二个主题：
如何用 VB 启动其他程序或开启各类文件？
完全模拟【开始】中的【运行...】功能
在这二个主题中，我们都有提到，不必管文件的扩展名是什么？格式是什么？您都可以使用如下面
Shell("Start C:/Test.txt")
Call Shell("rundll32.exe url.dll,FileProtocolHandler " & Text1, 1)
的方式来启动程序或开启文件。今天，我们要提到的 API 也可以开启或执行各种不同类型的文件，但是那不是我们今天的重点 (如果各位有兴趣的话，请自行研究！)，今天的重点是 ShellExecuteAny 这个 API 它可以：
1、自动依文件型态帮我们在 Background 启动应用程序。
2、自动打印文件。
3、自动再关闭文件。
应用在我们的 VB 程序中的话，使用者只要输入或选择文件，不管什么文件 (当然是指在注册表中曾经注册过的文件类型)，都可以打印！
'以下是完成的模组：
Private Declare Function ShellExecuteAny Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As Any, ByVal lpDirectory As Any, ByVal nShowCmd As Long) As Long
Const SW_SHOWMINNOACTIVE = 7
Sub PrintAnyFile(FileToPrint As String)
Dim Ret As Long
Ret = ShellExecuteAny(Me.hwnd, "print", FileToPrint, ByVal 0&, ByVal 0&, SW_SHOWMINNOACTIVE)
End Sub
'实际使用案例如下：
Private Sub Command1_Click()
PrintAnyFile Text1.Text
End Sub
其实上面这种打印文件的方式，它的作用方式，和我们直接将文件文件拖拉到打印机的图示上去打印文件是一样的道理！ (如果您之前尚不知道这个功能的话，您现在可以试试看将一份文件直接拖拉放到打印机的图示上，看看结果如何！)
186、谁终结了我的程序？
您开发的应用程序或许写得非常完整，您也很满意，但有时候却莫名其妙地出现了一点问题，在不该结束程序的时候，它被强迫结束了！可能使用者是按下了 Ctrl + Alt + Del，使用 Microsoft Windows 工作管理员关闭应用程序，或者强迫关机了！然而您的程序却没有考虑到这一点。
在正常情况下要结束一个表单，会经过三个事件 (当您使用 End 结束程序时是例外！)，顺序如下：
1、Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
2、Private Sub Form_Unload(Cancel As Integer)
3、Private Sub Form_Unload(Cancel As Integer)
在这三个事件中都允许您设定 Cancel=True 来避免表单被结束，但是它们是不分青红皂白的，唯一能让您分辨表单为什么被结束的，就是在 Form_QueryUnload 中的 UnloadMode 参数！
unloadmode 参数返回下列的值：
常数值描述
vbFormControlMenu 0 使用者从表单上的控制功能表中选取「关闭」指令。
vbFormCode 1 Unload 陈述式被程序代码呼叫。
vbAppWindows 2 目前 Microsoft Windows 作业环境任务结束。
vbAppTaskManager 3 Microsoft Windows 工作管理员正在关闭应用程序。
vbFormMDIForm 4 因为 MDI 表单正在关闭的缘故，MDI 子表单正在关闭。
vbFormOwner 5 表单因其拥有人关闭而关闭。
所以下次您就可以在 Form_QueryUnload 中利用 UnloadMode 参数来判断程序是否　要做什么特别处理！
187、完全模拟【开始】中的【关机】功能
在【问题：如何从您的应程序中结束 Windows 重开机？】我们曾经提到过，如何由程序中强迫关机、重开机，但是在这个主题中，我们要告诉您的，是如何模拟按下了【开始】中的【关机】选项，屏幕变成灰灰一片，并且在屏幕中央出现【关闭 Windows】问话框！
在声明区中加入以下声明：
Declare Function SHShutDownDialog Lib "shell32" Alias "#60" (ByVal lType As Long) As Long
Public Const EWX_LOGOFF = 0
Public Const EWX_SHUTDOWN = 1
Public Const EWX_REBOOT = 2
Public Const EWX_FORCE = 4
Public Const EWX_POWEROFF = 8
要 Show 出【关闭 Windows】问话框时用法如下：
SHShutDownDialog EWX_SHUTDOWN
188、如何将桌面上所有的视窗最小化？
有很多好用的桌面工具软件都有提供这个功能，将桌面上所有的视窗最小化，也会提供将它们复原的功能，当然，要提供这种功能的软件，执行后都是将程序缩到桌面右下角的工具列中，使用 Menu 来操控，否则，将桌面上所有的视窗最小化，也包括它自己的程序本身的视窗的！
'请在视窗声明区中加入以下声明及模组：
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Const WM_COMMAND As Long = &H111
Private Const MIN_ALL As Long = 419
Private Const MIN_ALL_UNDO As Long = 416
Public Sub MinimizeAll()
Dim lngHwnd As Long
lngHwnd = FindWindow("Shell_TrayWnd", vbNullString)
Call PostMessage(lngHwnd, WM_COMMAND, MIN_ALL, 0&)
End Sub
Public Sub RestoreAll()
Dim lngHwnd As Long
lngHwnd = FindWindow("Shell_TrayWnd", vbNullString)
Call PostMessage(lngHwnd, WM_COMMAND, MIN_ALL_UNDO, 0&)
End Sub
'而实际使用之范例如下：
Private Sub Command1_Click()
MinimizeAll '将桌面上所有的视窗最小化
End Sub
Private Sub Command2_Click()
RestoreAll '将最小化的视窗还原
End Sub
189、如何动态新增、移除 ODBC DSN？
一般我们建立 Client 端 DSN 都是在使用者的机器上进入【控制台】【ODBC 资料来源管理员】去建立，但是如果我们开发的 APP 使用者很多时，这就有点累人了，所以我们可以将这个动作放在程序中！
新增 DSN 的方法有二种：
1、使用 DBEngine 物件的 RegisterDatabase 方法
2、呼叫 SQLConfigDataSource API
不管使用以上任何一种方法新增 DSN，一共会写入二个地方，一个是注册表，一个是 ODBC.INI。
而删除 DSN 的方法同上面的第二种方法，呼叫 SQLConfigDataSource API。
以下之模组以 Oracle73 Ver 2.5 为例，在 Form 的声明区中加入以下声明及模组：
Private Const ODBC_ADD_DSN = 1 ' Add data source
Private Const ODBC_CONFIG_DSN = 2 ' Configure (edit) data source
Private Const ODBC_REMOVE_DSN = 3 ' Remove data source
Private Const vbAPINull As Long = 0& ' NULL Pointer
Private Declare Function SQLConfigDataSource Lib "ODBCCP32.DLL" (ByVal hwndParent As Long, ByVal fRequest As Long, ByVal lpszDriver As String, ByVal lpszAttributes As String) As Long
Public Sub CreateDSN(sDSN As String)
Dim nRet As Long
Dim sDriver As String
Dim sAttributes As String
sDriver = "Oracle73 Ver 2.5"
sAttributes = "Server=Oracle8" & Chr$(0)
sAttributes = sAttributes & "DESCRIPTION=" & sDSN & Chr$(0)
'sAttributes = sAttributes & "DSN=" & sDSN & Chr$(0)
sAttributes = sAttributes & "DATABASE=DBFinance" & Chr$(0)
sAttributes = sAttributes & "Userid=Scott" & Chr$(0)
'sAttributes = sAttributes & "PWD=myPassword" & Chr$(0)
DBEngine.RegisterDatabase sDSN, sDriver, True, sAttributes '注一
'nRet = SQLConfigDataSource(vbAPINull, ODBC_ADD_DSN, sDriver, sAttributes) '注二
End Sub
Public Sub DeleteDSN(sDSN As String)
Dim nRet As Long
Dim sDriver As String
Dim sAttributes As String
sDriver = "Oracle73 Ver 2.5"
sAttributes = sAttributes & "DSN=" & sDSN & Chr$(0)
nRet = SQLConfigDataSource(vbAPINull, ODBC_REMOVE_DSN, sDriver, sAttributes)
End Sub
'假设要产生的 DSN 为 Test，实际使用范例如下：
Private Sub Command1_Click()
CreateDSN "Test"
End Sub
Private Sub Command2_Click()
DeleteDSN "Test"
End Sub
'而写到系统的资料如下：
1、ODBC.INI
[ODBC 32 bit Data Sources]
Test=Oracle73 Ver 2.5 (32 bit)
[Test]
Driver32=C:/ORAWIN95/ODBC250/sqo32_73.dll
2、注册表
机码：HKEY_CURRENT_USER/Software/ODBC/ODBC.INI/ODBC Data Sources
名称：Test 资料：Oracle73 Ver 2.5
机码：HKEY_CURRENT_USER/Software/ODBC/ODBC.INI/Test
名称：Description 资料：Test
名称：Driver 资料：C:/ORAWIN95/ODBC250/sqo32_73.dll
名称：Server 资料：Oracle8
名称：UserId 资料：Scott
※注一及注二可任选一种，只要将不使用的方法 Mark 起来即可！
※若您想使用其他之资料库，只要将以上模组稍作修改即可！
190、如何从全路径文件名中分别抓出路径及文件名？
这是一个很简单很常碰到的问题，只要有用到文件的程序常常都会需要处理这样的问题！既然很简单为什么还要提出这样的问题呢？没错，是很简单，但是我的着眼点是：它太常出现了，值得做成模组！
要解决这个问题，第一个要了解的就是全路径文件名称的构成要素：磁盘代号、目录名称、文件名称，而这三个组成要素之间，都是使用反斜线符号 (即 "/") 分开！
所以，要从全路径文件名中分别抓出路径及文件名，第一件事就是要找到从右边倒数的第一个反斜线符号！
不多说，直接来看看模组及实例：
'模组：抓出路径
Function ExtractDirName(PathName As String) As String
Dim X As Integer
For X = Len(PathName) To 1 Step -1
If Mid$(PathName, X, 1) = "/" Then Exit For
Next
ExtractDirName = Left$(PathName, X - 1)
End Function
'模组：抓出文件名
Function ExtractFileName(PathName As String) As String
Dim X As Integer
For X = Len(PathName) To 1 Step -1
If Mid$(PathName, X, 1) = "/" Then Exit For
Next
ExtractFileName = Right$(PathName, Len(PathName) - X)
End Function
'使用实例：
Private Sub Command1_Click()
Dim PathName As String
PathName = "C:/倪匡小说原稿/未整理小说/黄金故事.txt"
Text1.Text = ExtractFileName(PathName) ' 黄金故事.txt
Text2.Text = ExtractDirName(PathName) ' C:/倪匡小说原稿/未整理小说
End Sub
196、如何一次关闭 MDIForm 内的所有子表单？
以下这段程序可以让您一次关闭 MDIForm 内的所有子表单，首先在 MDIForm 中建立一个 Menu，假设取名为 mnuCloseAll，则程序码如下：
Private Sub mnuCloseAll_Click()
'Screen.MousePointer = vbHourglass
Do While Not (Me.ActiveForm Is Nothing)
Unload Me.ActiveForm
Loop
'Screen.MousePointer = vbDefault
End Sub
197、按下 CommandButton 之前后，如何让鼠标停留在同一个物件中？
在一般表单输入画面中，使用者输入了一笔资料后，会去按 '存档' 按钮，当然他也可能去按任一个按钮，但是不管他是按那一个按钮，如果您不在程序中将鼠标移到下一笔输入的第一个栏位，或其他特定的栏位，使用者便必须自己去移动鼠标，如果这个使用者是使用键盘输入，那更是麻烦！他必须使用 Tab 键一个物件一个物件移动光标。
下面这个范例将示范如何做到在按下 CommandButton 之前后，让鼠标停留在同一个物件中！请在表单中放入二个 TextBox 及一个 CommandButton，不必更改任何属性，将以下之程序复制到表单中：
Dim mCtl As Control
Private Sub Command1_Click()
' 在这一个段落中可以执行您想做的动作, 例如存档动作
' 然后将鼠标移回按下 Command1 之前鼠标停留的物件上
On Error Resume Next
mCtl.SetFocus
End Sub
Private Sub Text1_GotFocus()
Set mCtl = Text1
End Sub
Private Sub Text2_GotFocus()
Set mCtl = Text2
End Sub
198、您用过【符号字型】吗？
有时候您是否觉得，同样的开发环境，为什么 Microsoft 写出来的程序，画面总是在某些地方看来特别一点点，例如 CommandButton 的样子就是和我们自己写的不一样，您总是感觉他们的 CommandButton 上放的是图形，其实，在 CommandButton 上的不是图形，只不过是某一种字型而已！而且这些字型在每一台 Windows95 / Windows98 / NT 上都有，如果没有，您只要安装了 IE4 或 IE5 就有了。
举个例子好了，如果您要在 CommandButton 上放一个向右或向左的箭头，不使用图片的话，您会使用【>】【<】，但是您在 Microsoft 写出来的程序中看到的是【4】【3】，为什么呢？因为它用的是一种符号字型，就是 Marlett 字型的 3 【4】及 4【3】！
这些字型在那里呢？在本页的下方列了七种符号字型，每一种字型分别列出了 0-9 / a-z / A-Z 共 62 个字元，如果在某些栏位中您看到的仍然是 0-9 / a-z / A-Z，表示您的电脑中没有这种字型，当然，符号字型不只这七种而已，如果您想知道您的电脑中暗藏多少种符号字型的话，方法如下：
在任何可以设定字型的应用程序中，叫出【字型】设定对话框，我们就用 VB 的开发环境来举例好了：
1、在表单上放一个 Label，Caption 随意输入 0-9 / a-z / A-Z 的字元，在属性表中设定字型 (Font)。
2、在【字型】设定对话框的左上方，您随便选择一种【字型】。
3、看看【字型】设定对话框的右下方，【字集】也会跟著改变！每一种字型会包含一种以上的字集。
4、如果字集中出现的是 symbol，表示这种字型就是符号字型！
5、按下确定按钮，看看 Label 上面的字有何改变，很令人惊讶吧！
6、Marlett 字型的 012345 变成了 012345了！
这些符号字型有的非常精美，下一次要使用图片之前，记得找一找符号字型，使用符号字型不但美观，而且可以避免使用图片，让程序瘦身！
注：符号字型范例
( 由于此页档案太大，怕影响速度，所以移除了部份英文字元，若有需要，请自行测试 )
字型 Marlett Monotype Sorts r_symbol MT Extra Wingdings Wingdings 2 Wingdings 3
0 0 0 0 0 0 0 0
1 1 1 1 1 1 1 1
2 2 2 2 2 2 2 2
3 3 3 3 3 3 3 3
4 4 4 4 4 4 4 4
5 5 5 5 5 5 5 5
6 6 6 6 6 6 6 6
7 7 7 7 7 7 7 7
8 8 8 8 8 8 8 8
9 9 9 9 9 9 9 9
a a a a a a a a
: : : : : : : :
A a A A A A A A
: : : : : : : :
Z Z Z Z Z Z Z Z
199、避免使用没有效率的 IIF Function 及 Choose Function！
IIF Function 的功能是根据逻辑判断，返回给定的二个值中的一个 (二选一)；
Choose Function 的功能是从引数串列中选择并返回一个值 (多选一)。
二个函数的语法如下：
IIf(expr, truepart, falsepart)
Choose(index, choice-1[, choice-2, ... [, choice-n]])
这二个函数乍看之下，好像和 IF....Else IF....Else....End IF 是一样的，没错，结果好像是一样的，但是事实上 IF....Else....End IF 却比较有效率和安全多了，为什么呢？
1、IIf 会计算 truepart 以及 falsepart，虽然它只返回其中的一个，所以您应该要留意这项副作用，
例如，如果 falsepart 会产生除以零的错误，那么程序就会发生错误，即使 expr 为 True。
2、Choose 会计算串列中的每个选择项，即使它只返回一个选项值。所以您应该注意这项副作用，
例如，当您在每个选择项中使用了 MsgBox 函数，那么每计算一个选择项，就会显示一次讯息方块。
而 IF....Else....End IF 却没有上述的缺点！
所以，虽然 IIF 及 Choose Function 的程序码看起来相当简洁，但效率不见得比较好，最重要的，是可能还会导致错误产生。我的建议就是：能不用就不用！
200、如何用TextBox打开和保存文件
作为轻量级的控件，TextBox控件使用率很高，但相关的资料极少谈及如何用TextBox控件打开和保存文件，大都采用回避的态度，对VB初学者带来很多不便。笔者近日为友人做一个英文朗读软件，按友人的要求，软件要能象MS的记事本那样能打开和保存文档。其实实现方法并不复杂，现将心得写出来，希望对大家有帮助。如果您有更好的方法，请来信：handanfang@163.net。
'新建标准EXE，加入一个TextBox控件，一个公共对话框，两个菜单。
'打开
Private Sub mnuOpen_Click()
CommonDialog1.Filter = "文档文件(*.txt)|*.txt|所有文件(*.*)|*.*"
CommonDialog1.ShowOpen
Open CommonDialog1.FileName For Input As #1
Text1.Text = StrConv(InputB$(LOF(1), 1), vbUnicode)
Close #1
End Sub
'保存
Private Sub mnuSave_Click()
On Error Resume Next
CommonDialog1.Filter ="文档文件(*.txt)|*.txt|所有文件(*.*)|*.*"
CommonDialog1.ShowSave
Open CommonDialog1.FileName For Output As #1
Print #1, Text1.Text
Close 1
End Sub
TextBox只支持打开64K以下的文件，建议最好设置出错处理。
以上程序在PWin98、VB6.0下调试通过。
201、避免使用没有效率的 IIF Function 及 Choose Function！
IIF Function 的功能是根据逻辑判断，返回给定的二个值中的一个 (二选一)；
Choose Function 的功能是从引数串列中选择并返回一个值 (多选一)。
二个函数的语法如下：
IIf(expr, truepart, falsepart)
Choose(index, choice-1[, choice-2, ... [, choice-n]])
这二个函数乍看之下，好像和 IF....Else IF....Else....End IF 是一样的，没错，结果好像是一样的，但是事实上 IF....Else....End IF 却比较有效率和安全多了，为什么呢？
1、IIf 会计算 truepart 以及 falsepart，虽然它只返回其中的一个，所以您应该要留意这项副作用，
例如，如果 falsepart 会产生除以零的错误，那么程序就会发生错误，即使 expr 为 True。
2、Choose 会计算串列中的每个选择项，即使它只返回一个选项值。所以您应该注意这项副作用，
例如，当您在每个选择项中使用了 MsgBox 函数，那么每计算一个选择项，就会显示一次讯息方块。
而 IF....Else....End IF 却没有上述的缺点！
所以，虽然 IIF 及 Choose Function 的程序码看起来相当简洁，但效率不见得比较好，最重要的，是可能还会导致错误产生。我的建议就是：能不用就不用！
202、使用一个指令建立目录 (巢状目录)
假设您需要建立目录，不管是在根目录或者是好几层的目录，例如：C:/Dir1/Dir2/Dir3/Dir4 下面这个模组都可以满足您的需求！它只需要一个参数，就是完整的目录名称 (指全路径)，例如："C:/Dir1/Dir2/Dir3/Dir4"。
如果您给的目录中，前几层目录都已经存在，例如："C:/Dir1/Dir2/"，则它只会帮您再往下建立 Dir3 及 Dir4 二层目录而己。除了本机的磁盘之外，您已经 Mapped 的网路磁盘也可以做到！而如果您没有给定磁盘代号，它会将目录建立在应用程序的预设目录之下！
Public Function MkDirs(ByVal PathIn As String) As Boolean
Dim nPos As Long
MkDirs = True '先假设成功
If Right$(PathIn, 1) <> "/" Then PathIn = PathIn + "/"
nPos = InStr(1, PathIn, "/")
Do While nPos > 0
If Dir$(Left$(PathIn, nPos), vbDirectory) = "" Then
On Error GoTo Failed
MkDir Left$(PathIn, nPos)
On Error GoTo 0
End If
nPos = InStr(nPos + 1, PathIn, "/")
Loop
Exit Function
Failed:
MkDirs = False
End Function
'使用范例如下：在 Text1 中输入要建立的目录 (指全路径)
Private Sub Command1_Click()
Dim istrue As Boolean
istrue = MkDirs(Text1)
If istrue Then
MsgBox "目录已成功建立！", 64, "建立目录"
Else
MsgBox "建立目录失败！", 16, "建立目录"
End If
End Sub
'或许您在测试时找不到失败的范例，给您一个提示：将目录建在只读光盘驱动器试试！
203、如何在资料库中存入单引号？
当您想要新增一笔资料到 Access 或 Oracle 时，若文字栏位中含有单引号，便会产生错误！
在以下的例子中，我们告诉您如何使用 Chr$(34) 将含有单引号之字串存入 Jet database engine 中！
Private Sub CmdAddNew_Click()
Dim dbCustomer As Database ' 声明资料库
Dim strSql As String ' SQL 字串
Dim strodbc As String ' ODBC 字串
' 以下为资料库中客户档之三个栏位变量声明
Dim strCustID As String ' 客户代码
Dim strFirstName As String ' 客户名称
Dim strAddress As String ' 客户地址
strodbc = "odbc;uid=scott;pwd=tiger;dsn=myconnect"
Set dbCustomer = OpenDatabase("myconnect", dbDriverNoPrompt, False, strodbc)
strCustID = "A003"
strFirstName = "Annie"
strAddress = "Reflection's"
strSql = "insert into CUSTOMER values('" & strCustID & "'"
strSql = strSql & ",'" & strFirstName & "',"
strSql = strSql & Chr(34) & strAddress & Chr(34) & ")"
dbCustomer.Execute (strSql)
dbCustomer.Close
End Sub
'如果您还想要更详细的资料，您可以参考 Microsoft Knowledge Base 中的 Q147687。
204、如何算出 TextBox 中目前光标是在第几行？
在很多文字编辑器中，都可以告诉您，目前您的光标是在文字编辑器的第几行，我们也来实作一下！
在 Form 中放入一个 TextBox 并将 Multiline 属性设为 True，放入一个 Label 用来显示目前光标所在的行数，在表单声明区中加入以下声明及模组：
Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Const EM_LINEFROMCHAR = &HC9
Function LineNo(txthwnd As Long) As Long
On Local Error Resume Next
LineNo = SendMessageLong(txthwnd, EM_LINEFROMCHAR, -1&, 0&) + 1
LineNo = Format$(lineno, "##,###")
End Function
'呼叫这个模组时要导入的是 TextBox 的 hwnd
'实际使用时，必须在 TextBox 的以下几个事件中呼叫这个模组，才会完全正确：
'1. Change事件：输入资料时可侦测计算
'2. Click 事件：用鼠标移动光标时可侦测计算
'3. KeyUp 事件：用上下左右键移动光标时可侦测计算
Sub Text1_Change()
Label1 = LineNo(Text1.hwnd)
End Sub
Private Sub Text1_Click()
Label1 = LineNo(Text1.hwnd)
End Sub
Private Sub Text1_KeyUp(KeyCode As Integer, Shift As Integer)
Label1 = LineNo(Text1.hwnd)
End Sub
205、当前操作系统的语言集
声明：
Declare Function GetSystemDefaultLCID Lib "kernel32" () As Long
例子：
Dim LocaleID As Long
LocalID = GetSystemDefaultLCID
= &H404 中文繁体（台湾）
= &H804 中文简体（大陆）
= &H409 英文 ...
206、如何算出 TextBox 的总行数？
在很多文字编辑器中，都可以告诉您，目前在编辑器中的文字总共有几行，我们也来实作一下！
有人问我说，要计算文字框中有多少行，只要将光标移到最后方 (Text1.SelLength=Len(Text1)),再使用前一个主题：问题180：如何算出 TextBox 中目前光标是在第几行？的模组就可以算出来了，没错！不过，二种方法都差不了多少，可以任君选择！
在 Form 中放入一个 TextBox 并将 Multiline 属性设为 True，放入一个 Label 用来显示目前 TextBox 中总共有几行，在表单声明区中加入以下声明及模组：
Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Const EM_GETLINECOUNT = &HBA
Function LineCount(txthwnd As Long) As Long
On Local Error Resume Next
LineCount = SendMessageLong(Text1.hwnd, EM_GETLINECOUNT, 0&, 0&)
LineCount = Format$(lineCount, "##,###")
End Function
'呼叫这个模组时要传入的是 TextBox 的 hwnd
'实际使用时，用法如下：
Private Sub Command1_Click()
Label1 = LineCount(Text1.hwnd)
End Sub
207、如何预先算出目前在 TextBox 中的资料存档后的文件大小？
之前在问题156: 如何取得文件大小？我们讨论过已存档文件大小的算法，但是在一笔新资料尚未存档前，我们其实也可以先算出它存档后文件会有多大！作法如下：
在 Form 中放入一个 TextBox 并将 Multiline 属性设为 True，放入一个 Label 用来显示目前 TextBox 中总共有几行，在表单声明区中加入以下声明及模组：
Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Const EM_GETLINECOUNT = &HBA
Const EM_LINEINDEX = &HBB
Const EM_LINELENGTH = &HC1
Function TextSize(txthwnd As Long) As Long
Dim lineCount As Long
Dim ChrsUpToLast As Long
Dim DocumentSize As Long
On Local Error Resume Next
'首先，算出 TextBox 的总行数
lineCount& = SendMessageLong(txthwnd, EM_GETLINECOUNT, 0&, 0&)
'接著，算出 TextBox 的位元组数
ChrsUpToLast& = SendMessageLong(txthwnd, EM_LINEINDEX, lineCount& - 1, 0&)
If ChrsUpToLast& = 0 Then
DocumentSize& = 0
ElseIf ChrsUpToLast& < 65000 Then
DocumentSize& = SendMessageLong(txthwnd, _
EM_LINELENGTH, ChrsUpToLast&, 0&) + ChrsUpToLast
End If
TextSize = Format$(DocumentSize&, "##,###")
End Function
'呼叫这个模组时要传入的是 TextBox 的 hwnd
'实际使用时，用法如下：
Private Sub Command1_Click()
Label1 = TextSize(Text1.hwnd)
End Sub
208、如何以桌面上的背景图来设定 Form 的背景？
这个功能是由网友 jimmy 所提供，它的功能就是将 User 桌面的图片直接拿来当作我们表单的背景图。
PaintDesktop API 只　要传入一个数值，就是表单的 hDC 属性值。
请直接将以下之程序码复制到表单中即可：
Private Declare Function PaintDesktop Lib "user32" (ByVal hDC As Long) As Long
Private Sub Form_Paint()
PaintDesktop Me.hDC
End Sub
注:
hDC 属性是 Windows 执行环境的周边设定内容物件代码。在 Windows 执行环境，系统透过给 Printer 物件和应用程序中每个表单和 PictureBox 控制项分配一个周边设定内容，来管理系统显示。可以用 hDC 属性参考物件的周边设定内容代码。这提供了一个传递给 Windows API 呼叫的值。
209、改变 ListIndex而不发生 Click 事件
在修改 Combo 或 Listview 的ListIndex 时，会发生 Click 事件，下面的函数可以阻止该事件。
声明：
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 CB_GETCURSEL = &H147
Const CB_SETCURSEL = &H14E
Const LB_SETCURSEL = &H186
Const LB_GETCURSEL = &H188
函数：
Public Function SetListIndex(lst As Control, ByVal NewIndex As Long) As Long
If TypeOf lst Is ListBox Then
Call SendMessage(lst.hWnd, LB_SETCURSEL, NewIndex, 0&)
SetListIndex = SendMessage(lst.hWnd, LB_GETCURSEL, NewIndex, 0&)
ElseIf TypeOf lst Is ComboBox Then
Call SendMessage(lst.hWnd, CB_SETCURSEL, NewIndex, 0&)
SetListIndex = SendMessage(lst.hWnd, CB_GETCURSEL, NewIndex, 0&)
End If
End Function
210、调整 Combo 下拉部分的宽度
声明：
Private Declare Function SendMessage Lib "USER32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Const CB_GETDROPPEDWIDTH = &H15F
Private Const CB_SETDROPPEDWIDTH = &H160
Private Const CB_ERR = -1
函数：
' 取得 Combo 下拉的宽度
' 可以利用该函数比例放大或缩小宽度
Public Function GetDropdownWidth(cboHwnd As Long) As Long
Dim lRetVal As Long
lRetVal = SendMessage(cboHwnd, CB_GETDROPPEDWIDTH, 0, 0)
If lRetVal <> CB_ERR Then
GetDropdownWidth = lRetVal
'单位为 pixels
Else
GetDropdownWidth = 0
End If
End Function
'设置 Combo 下拉的宽度
'单位为 pixels
Public Function SetDropdownWidth(cboHwnd As Long, NewWidthPixel As Long) As Boolean
Dim lRetVal As Long
lRetVal = SendMessage(cboHwnd, CB_SETDROPPEDWIDTH, NewWidthPixel, 0)
If lRetVal <> CB_ERR Then
SetDropdownWidth = True
Else
SetDropdownWidth = False
End If
End Function
004 把所有的字体名称放到 Combo 98-6-07
For I = 0 To Screen.FontCount - 1
cboFont.AddItem Screen.Fonts(I)
Next I
211、如何将短文件名格式转成长文件名？
虽然在 Windows95/98 中已经都可以使用长文件名/目录 (最长可以到255个字节)，但是在您将长文件名的文件或目录存文件时，系统同时给了它一个可以相容于以前 MS-DOS 时代的 8.3 格式的文件名称！
到目前为止，还是有些软件会使用 8.3 格式的文件名称，在安装这些软件时，它们写到注册文件中的资料，仍然采用 8.3 格式的文件名称，所以有时候，您在维护系统时，必须知道目前这些已经转成 8.3 格式的文件名称，原来的长文件名是什么。
在问题：如何将长文件名转成短文件名格式 (MS-DOS 8.3) ，我们已经讲过长文件名转成短文件名，当时是使用 API 来做，过程上还蛮麻烦的，但是相反的，要从短文件名转成长文件名，过程却比较简单，也不需要用到 API，只要使用 Dir( ) 就可以了！
'请将以下的模组放到声明区中：
Public Function GetLongFilename(ByVal sShortName As String) As String
Dim sLongName As String
Dim sTemp As String
Dim iSlashPos As Integer
'在短文件名之后加上倒斜线 "/"，避免 Instr 造成错误
sShortName = sShortName & "/"
'略过磁盘代号，从第四码开始
iSlashPos = InStr(4, sShortName, "/")
'从文件名之第四码之后，一段一段处理在二个倒斜线 "/"之间的字串转换
While iSlashPos
sTemp = Dir(Left$(sShortName, iSlashPos - 1), vbNormal + vbHidden + vbSystem + vbDirectory)
If sTemp = "" Then 'Error 52 - Bad File Name or Number
GetLongFilename = ""
Exit Function
End If
sLongName = sLongName & "/" & sTemp
iSlashPos = InStr(iSlashPos + 1, sShortName, "/")
Wend
'将转换后的文件名加上原先略过的磁盘代号，变成完整的全路径文件名
GetLongFilename = Left$(sShortName, 2) & sLongName
End Function
'实际使用范例如下：
Private Sub Command1_Click()
'假设 C:/Program Files/Common Files 是一个正确的全路径文件名或目录
Print GetLongFilename("C:/PROGRA~1/COMMON~1")
End Sub
'结果就是 C:/Program Files/Common Files。
212、如何将桌面上的图标排列整齐？
您的或您的使用者的桌面是否有一大堆乱乱的图标，您可以使用 VB 来将这些图标排列整　！
程序码如下：
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
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
Private Const GW_CHILD = 5
Private Const LVA_ALIGNLEFT = &H1
Private Const LVM_ARRANGE = &H1016
Private Sub Command1_Click()
Dim hWnd1 As Long
Dim hWnd2 As Long
Dim Ret As Long
hWnd1 = FindWindow("Progman", vbNullString)
hWnd2 = GetWindow(hWnd1, GW_CHILD)
hWnd1 = GetWindow(hWnd2, GW_CHILD)
Ret = SendMessage(hWnd1, LVM_ARRANGE, 0, 0)
End Sub
执行完以上的程序码后，桌面上的所有图标便会自动的靠左对齐！
213、VB 的 SDI / MDI 开发环境切换
如果您使用过 Windows 应用程序，也许已经注意到并不是每个程序的使用者介面看上去都一样，也不见得同样的介面做的事就一样。使用者介面样式主要有两种：单一文件介面 (SDI) 和多重文件介面 (MDI)。SDI 介面的一个典型就是 Microsoft Windows 中的 WordPad 程序 (图 6.1)。在WordPad 中，使用者一次只能开启一个文件 (文件)，想要开启另一个文件时，就必须先关上已开启的文件。
像 Microsoft Excel 和 Microsoft Word for Windows 这样的应用程序，就是 MDI 介面；它们允许同时显示多个文件，每个文件都显示在自己的视窗中 (图 6.2)。从程序的「视窗」功能表　，可以看出它是否为一个 MDI 应用程序。如果「视窗」功能表中含有已开启的文件清单，可以让使用者藉此来切换要显示或编辑的文件，这个程序就是一个 MDI 应用程序。
Visual Basic IDE 也有这两种不同的型态：单一文件介面 (SDI) 或多重文件介面 (MDI)。对 SDI 选项来说，只要 Visual Basic 是目前作用中的应用程序，则所有 IDE 视窗都可在屏幕上的任何地方自由移动，并且会保持在其它的应用程序之上；而对 MDI 选项来说，所有 IDE 视窗则都包含在一个可调整大小的父视窗内。
在 VB5 或 VB6 刚安装好时，预设的开发环境是多重文件介面 (MDI)，它最麻烦的地方是，当您的表单大小比较大时，或者您的表单是最大化时，您必须在 MDI 开发环境中使用卷动杆来移动表单，对设计者来说，不能一次看到表单的全貌，是相当不方便的，所以您需要将开发环境改成 SDI，但是要如何改呢？有的人找来找去，就是找不到从那里改，其实很简单，方法如下：
SDI 和 MDI 模式的切换：
1、在「工具」功能表中选取「选项」。此时会显示「选项」对话方块。
2、再选取「进阶」页签。
3、核取或取消核取「SDI 开发环境」核取方块。
-或-
1、在指令行使用 /sdi 或 /mdi 参数来执行 Visual Basic。
设定好之后，不会马上生效！但是当您下次启动 Visual Basic 时，IDE 将以您选取的模式启动。
214、Combo的自动查询技术
Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Const CB_FINDSTRING = &H14C
Private Sub Combo1_Change()
Dim iStart As Integer
Dim sString As String
Static iLeftOff As Integer
iStart = 1
iStart = Combo1.SelStart
If iLeftOff <> 0 Then
Combo1.SelStart = iLeftOff
iStart = iLeftOff
End If
sString = CStr(Left(Combo1.Text, iStart))
Combo1.ListIndex = SendMessage(Combo1.hwnd, B_FINDSTRING, -1, ByVal CStr(Left(ombo1.Text, iStart)))
If Combo1.ListIndex = -1 Then
iLeftOff = Len(sString)
combo1.Text = sString
End If
Combo1.SelStart = iStart
iLeftOff = 0
End Sub
静态变量 iLeftOff 指定了字符长度。
215、如何改变 TreeView 的背景
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
Private Declare Function GetWindowLong Lib "User32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "User32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Const GWL_STYLE = -16&
Private Const TVM_SETBKCOLOR = 4381&
Private Const TVM_GETBKCOLOR = 4383&
Private Const TVS_HASLINES = 2&
Dim frmlastForm As Form
Private Sub Form_Load()
Dim nodX As Node
Set nodX = TreeView1.Nodes.Add(, , "R", "Root")
Set nodX = TreeView1.Nodes.Add("R", tvwChild, "C1", "Child 1")
Set nodX = TreeView1.Nodes.Add("R", tvwChild, "C2", "Child 2")
Set nodX = TreeView1.Nodes.Add("R", tvwChild, "C3", "Child 3")
Set nodX = TreeView1.Nodes.Add("R", tvwChild, "C4", "Child 4")
nodX.EnsureVisible
TreeView1.style = tvwTreelinesText ' Style 4.
TreeView1.BorderStyle = vbFixedSingle
End Sub
Private Sub Command1_Click()
Dim lngStyle As Long
Call SendMessage(TreeView1.hWnd, TVM_SETBKCOLOR, 0, ByVal RGB(255, 0, 0))
'改变背景到红色
lngStyle = GetWindowLong(TreeView1.hWnd, GWL_STYLE)
Call SetWindowLong(TreeView1.hWnd, GWL_STYLE, lngStyle - TVS_HASLINES)
Call SetWindowLong(TreeView1.hWnd, GWL_STYLE, lngStyle)
End Sub

kyu16866

关注

0
点赞
踩
14

收藏

觉得还不错? 一键收藏
0
评论
如何优化VB程序

如何去优化你的VB程序帮助 1、如何去优化你的VB程序Visual Basic 作为一种高级编程语言，它也有着不可避免的缺点---开发出的应用程序运行速度慢。如果我们能够程序做一些优化，那么情况将会大大改善。要优化程序运行的实际速度，常用的方法有三种：1.尽量避免使用 Variant 变量。由于VB不能确定 Variant 变量的具体类型，所以它会给该类型变量分配16个字节的空间，而且在用变量
复制链接

扫一扫