248、如何建立多级目录
Sub CreateLongDir(sDrive As String, sDir As String)
Dim sBuild As String
While InStr(2, sDir, "\") > 1
sBuild = sBuild & left(sDir, InStr(2, sDir, "\") - 1)
sDir = Mid(sDir, InStr(2, sDir, "\"))
If Dir(sDrive & sBuild, 16) = "" Then
MkDir sDrive & sBuild
End If
Wend
End Sub
249、如何从全路径名中提取文件名
Function StripPath(T$) As String
Dim x%, ct%
StripPath$ = T$
x% = InStr(T$, "\")
Do While x%
ct% = x%
x% = InStr(ct% + 1, T$, "\")
Loop
If ct% > 0 Then StripPath$ = Mid$(T$, ct% + 1)
End Function
例子：
File = StripPath("c:\windows\hello.txt")
250、如何检测文件是否存在
Function FileExists(FileName As String) As Boolean
On Error Resume Next
FileExists = Dir$(FileName) <> ""
If Err.Number <> 0 Then
FileExists = False
End If
On Error GoTo 0
End Function
251、如何使用 ADO 来压缩或修复 Microsoft Access 资料库？
以前使用 DAO 时，Microsoft 有提供 CompactDatabase Method 来压缩 Microsoft Access 资料库，RepairDatabase Method 来修复损毁的 Microsoft Access 资料库，这个在《问题: 处理加了密码的 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 Acess 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！
252、如何打印 MSChart 控制项的内容？
我这里所说的打印 MSChart 控制项的内容，不单指打印图表而已，还包括建立图表使用的原始数据资料！
我第一次使用 MSChart 控制项时，就发现它并没有提供打印的功能，因为以前使用的 Graph 控制项，是有打印功能的！经过研究之后，发现只有一个 EditCopy 方法可以利用来打印！
EditCopy 方法的功能：
以 Windows 中继文件格式将目前图表的图片复制到剪贴簿中。
它同时将建立图表使用的资料复制到剪贴簿中。
由于 EditCopy 方法会同时将文字及图片二种格式的资料一起放到剪贴簿中，所以我们只要从剪贴簿中，分别抓出文字及图片二种格式的资料，透过 Printer 物件，就可以将它们分别打印在同一张报表中！
在 Form 中放一个 MSChart 控制项及一个 CommandButton，不改属性，程序码如下：
Private Sub Command1_Click()
'复制 MSChart 控制项的内容，包括图表及资料
MSChart1.EditCopy
Printer.Print " "
'从剪贴簿中抓出文字资料来打印
Printer.Print Clipboard.GetText(vbCFText)
Printer.Print " "
'从剪贴簿中抓出图表来打印
Printer.PaintPicture Clipboard.GetData(), 0, 2500
Printer.EndDoc
End Sub
253、您使用 DAO 存取 Access 2000 时会出现错误吗？
当您使用 DAO 存取 Access 2000 时，是否会出现以下的错误讯息？
"Run-time error 3343 Unrecognized Database Format XXX"
这个错误讯息有二个解决的方式：
1、如果您是使用 Data Control 来连结 Access 2000 的资料库时：
您必须在设定 Data Control 的 Source 前先加上一行
Set Data1.Recordset = rsDAO36 'rsDAO36 is a DAO 3.6
2、如果您是引用「Microsoft DAO 3.51 Object Library」来存取 Access 2000 的资料库时：
请加入【工程】【设定引用项目】「Microsoft DAO 3.6 Object Library」
254、如何把文件置入到 Text 或RichText
dim sFile as string
'Set sFile equal to your filename
dim i as long
i = freefile()
open sFile for input as #i
txtMain.text = input$(i,LOF(i))
close #1
255、如何增加快捷方式到 启动 组
利用 DDE 可方便地建立快捷方式：（Text1 为表单中的 Textbox）
Text1.LinkTopic = "Progman|Progman"
Text1.LinkMode = 2
Text1.LinkExecute "[ShowGroup(启动, 4)]"
Text1.LinkExecute "[AddItem(c:\vb5\myprog.exe, 我的程序)]"
256、您使用 ADO 存取 Access 2000 时会出现错误吗？
很多 VB 的程序设计师，以往在 VB6 中利用 ADO OLEDB Provider 3.51 存取 Access 97 资料库，系统都能正常的执行。但是自从将 Access 97 升级到 Access 2000 之后，就无法顺利的存取 Access 2000 资料库了，不知道您是否也曾遇到这样的情形呢？
其实这种事情在 Microsoft 已经是思空见惯的事情了！任何软件只要有了新的版本，就会有和旧版本相容的问题产生！
而这一次是因为 由于 Access2000 己经使用 Jet 4.0 Engine，所以解决方法如下：
在您的 ADO 的 Connect String 中的 Provider 必须修改为："PROVIDER=Microsoft,Jet.OLEDB.4.0"
257、如何侦测光驱中是否有光盘存在？
要快速的判断光驱中是否有光盘存在，您必须使用 Scripting Runtime library 中 Drive 物件的 IsReady 属性！一旦光驱中有光盘存在，它会传回 True，否则传回值是 False！
要使用 Drive 物件的 IsReady 属性，您必须先引用 Microsoft Scripting Runtime library，方法如下：
Menu【项目】-->选择【设定引用项目】-->选择【Microsoft Scripting Runtime】(Scrrun.dll)
再来，您必须知道光驱的磁盘代号，这个问题，我们之前在 问题：如何判断目前电脑中所有磁盘之型态？ 中曾经讨论，不过在这 我们不用那个方法了，我们要直接使用 Drive 物件的 DriveType 属性！
程序码如下：
Private Sub Command1_Click()
Dim FSO As FileSystemObject
Dim aDrive As Drive
Set FSO = New FileSystemObject
For Each aDrive In FSO.Drives
If aDrive.DriveType = CDRom And aDrive.IsReady = False Then
MsgBox "请放入光盘片！"
Exit For
ElseIf aDrive.DriveType = CDRom Then
MsgBox aDrive.VolumeName
Exit For
End If
Next
Set FSO = Nothing
End Sub
258、您知道每一个表单 (Form) 最多可以放多少个控制项吗？
如果我说每一个表单 (Form) 最多可以放无限多个控制项，您相信吗？往下看到最后您或许就相信了！
根据 Microsoft 的官方说法，一个表单中最多可以有 254 个控制项的「名称」(注意，是控制项的名称！)，不过还是要看您放在表单中的控制项种类以及您机器中的系统资源有多少而定！
若您想突破控制项的名称数及系统资源的限制，以下有三个方法：
1、使用控制项阵列：
您可以产生一个控制项阵列来放相同种类的控制项，他们共用一个控制项「名称」！
2、动态产生控制项：
如果您不需要同时使用那么多控制项，Form_Load 时就不要 Load 进来，用到时再动态产生即可能！
3、将控制项放在 UserControl 中：
这个方法和使用控制项阵列相似，您可以将很多个控制项放在一个 UserControl 中，然后将这个 UserControl 放进 Form 中，举个例子来说，如果您的表单中需要 500 个 TextBox，您可以建立一个包含 250 个 TextBox 的 UserControl，那么，您只要放二个 UserControl，您就有 500 个 TextBox 了，但是您总共只用到二个控制项而已！
注意：
虽然，一个表单中最多可以有 254 个控制项的名称，但是控制项如果太多了，便会严重影响您的程序的效能(performance)，甚至您会得到一个记忆体不足(out-of-memory) 的错误讯息！因此想要让您的应用程序效能好一点，您应该尽量减少控制项的数量！
259、如何动态新增控制项？
VB 从 6.0 版开始，已经可以允许我们使用 Controls Collection 的 Add Method 在程序执行时动态新增控制项！今天这个单元就是要告诉大家如何动态新增 VB 预设的控制项或是 ActiveX 控制项。
在以下的范例中，我们会在程序执行时动态新增二个预设的控制项及一个 ActiveX 控制项，也会告诉大家如何处理动态新增控制项的事件！如果您新增的控制项，在项目的【设定使用元件】、【设定引用项目】中没有声明的话，您还必须先将这个控制项的 License Key 加到 License Collection 中！(注一)
如果您要使用这个新增控制项的属性时，您必须使用物件的关键字来存取这个控制项的属性。如果您不使用物件的关键字的话，您会得到一个错误代码为 438 的错误讯息如下：
"Object doesn't support this property or method." (物件不支援这个属性或方法)
当您在声明区中使用 VBControlExtender object 及 WithEvents 来新增 ActiveX 控制项时，您必须使用 ObjectEvent method 来处理所有这个控制项的事件。如果您声明一个预设的控制项事件，您将会得到您声明的这个物件类别的所有标准事件，如何得知呢？加入以下的声明，然后在程序码视窗的控制项 Combo 中，找到您声明的这个控制项变数，然后点选事件 Combo，您就会看到了！
Dim WithEvents cmdMyCommand as VB.CommandButton
以下是我们的范例：
1、建立一个标准的新项目，预设会产生 Form1，不必加入任何控制项。
2、在 Form1 中加入以下的程序码：
Option Explicit
' 在程序执行时要动态新增 ActiveX 控制项，而这个新增的控制项，
' 在项目的【设定使用元件】、【设定引用项目】中没有声明的话，
' 您必须将它声明成 VBControlExtender
Dim WithEvents ctlDynamic As VBControlExtender
Dim WithEvents ctlText As VB.TextBox
Dim WithEvents ctlCommand As VB.CommandButton
Private Sub ctlCommand_Click()
ctlText.Text = "You Clicked the Command button"
End Sub
Private Sub ctlDynamic_ObjectEvent(Info As EventInfo)
' 测试 TreeView 的 Click 事件
If Info.Name = "Click" Then
ctlText.Text = "You clicked " & ctlDynamic.object.selecteditem.Text
End If
End Sub
Private Sub Form_Load()
Dim i As Integer
' 将 TreeView 的 License Key 加到 License Collection 中。
' 但是，如果这个 License Key 已经存在 License Collection 中，
' 您会得到一个编号 732 的执行期错误讯息。
Licenses.Add "MSComctlLib.TreeCtrl"
' 动态新增 TreeView 控制项到 Form 中，如果您想将这个控制项
' 加到 Form 以外的 Container 中，例如 Frame 或 Picture，那么，
' 在 Controls.Add 的第三个参数必须修改成 Container 的名称。
Set ctlDynamic = Controls.Add("MSComctlLib.TreeCtrl", "myctl", Form1)
' 设定 TreeView 控制项的位置及大小
ctlDynamic.Move 1, 1, 2500, 3500
' 新增 TreeView 控制项的 nodes
For i = 1 To 10
ctlDynamic.object.nodes.Add Key:="Test" & Str(i), Text:="Test" & Str(i)
ctlDynamic.object.nodes.Add Relative:="Test" & Str(i), _
Relationship:=4, Text:="TestChild" & Str(i)
Next i
' 设定 TreeView 控制项的 Visible 属性为 True
ctlDynamic.Visible = True
' 动态新增 TextBox 控制项
Set ctlText = Controls.Add("VB.TextBox", "ctlText1", Form1)
' 设定 TextBox 控制项的位置及大小
ctlText.Move (ctlDynamic.Left + ctlDynamic.Width + 50), 1, 2500, 100
' 设定 TextBox 控制项的 backcolor 属性
ctlText.BackColor = vbYellow
' 设定 TextBox 控制项的 Visible 属性为 True
ctlText.Visible = True
' 动态新增 CommandButton 控制项
Set ctlCommand = Controls.Add("VB.CommandButton", "ctlCommand1", Form1)
' 设定 CommandButton 控制项的位置及大小
ctlCommand.Move (ctlDynamic.Left + ctlDynamic.Width + 50), _
ctlText.Height + 50, 1500, 500
' 设定 CommandButton 控制项的标题
ctlCommand.Caption = "Click Me"
' 设定 CommandButton 控制项的 Visible 属性为 True
ctlCommand.Visible = True
End Sub
3、您现在可以执行看看了！按一下 CommandButton 或是 TreeView 的不同 Node，看看 TextBox 中出现什么！
注一：
如果您想知道多一点关于 License Collection 的资料，您可以到以下这个网址看看：
http://support.microsoft.com/support/kb/articles/Q188/5/77.ASP
它的主题是：HOWTO: What is the Licenses Collection Used For? (Licenses Collection 要做什么用？)
260、如何查看目录所占的字节数？
该函数返回目录使用的字节数：
Function DirUsedBytes(ByVal dirName As String) As Long
Dim FileName As String
Dim FileSize As Currency
If Right$(dirName, 1) <> "\" Then
dirName = dirName & "\"
Endif
FileSize = 0
FileName = Dir$(dirName & "*.*")
Do While FileName <> ""
FileSize = FileSize + _
FileLen(dirName & FileName)
FileName = Dir$
Loop
DirUsedBytes = FileSize
使用：
MsgBox DirUsedBytes("C:\Windows")
261、您知道 VB6.0 的阵列最多可以包含几个元素吗？
其实这个问题和 问题：您知道每一个表单 (Form) 最多可以放多少个控制项吗？ 一样，第一个条件就是决定于您机器中的系统资源有多少而定！
如果今天我们假设系统资源充足而不考虑系统资源的话，根据 Microsoft 的官方说法，一个阵列最多可到 2 的 31 次方，也就是 2147483648，不过如果您真的用到 2147483648 的话，您一定会得到一个「记忆体不足」的错误讯息！因为连 Windows NT 在一个 Process 中也只能支援到 4GB 的记忆体而已！
262、如何抓取应用程序的图标 (Icon) 并存文件备用？
有些应用程序的图标非常的漂亮，不禁让人想将它们据为己有，您是否常常想将它们抓下来私用呢？
一般可以抓出图标 (Icon) 的文件大概就是 .EXE 文件 .ICO 文件及 .DLL 文件三种，但是 .DLL 文件不一定会有图标！
我看过很多范例程序教人家如何从 .EXE 文件及 .DLL 文件中抓出图标，但是也常常在讨论区中看到有人在问，要如何将这些抓出的图标再存成 .ICO 文件？其实，在抓出图标之后，只要使用 SavePicture 陈述式就可以将这个图标再存成 .ICO 的图标文件了！
在含有图标的 .EXE 文件 及 .DLL 文件中不一定只包含一个图标而已，例如：C:\Windows\System\Shell32.dll 中就含有 72 个图标之多！
在以下的范例中，您开启文件之后，程序会告诉您，在该文件中共有几个图标，它会 Show 出其中的第一个图标(索引值是0)，其他的图标您可以利用卷动轴来卷动浏览。
以下列出详细的程序码：
所需控制项说明：
Dlg：开文件存文件问话框 CommandDialog
CmdSave：另存图标按钮
CmdOpen：开启文件按钮
Picture1：显示图标
Label1：显示图标总数用
Label2：显示目前在 Picture1 中的图标在原文件中的索引值
Label3：显示目前在 Picture1 中的图标原文件名称
Scroll1：改变显示在 Picture1 中的图标索引值
Dim lIcon As Long
Dim sSourcePgm As String
Dim sDestFile As String
Private Declare Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long
Private Declare Function DrawIcon Lib "user32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal hIcon As Long) As Long
Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long
Private Sub CmdSave_Click() '另存图标
On Error Resume Next
With Dlg '存文件问话框
.filename = sDestFile
.CancelError = True
.Action = 2
If Err Then
Err.Clear
Exit Sub
End If
sDestFile = .filename
SavePicture Picture1.Image, sDestFile '将抓出的图标存文件
End With
End Sub
Private Sub CmdOpen_Click() '开启文件
Dim a%
On Error Resume Next
With Dlg '开文件问话框
.filename = sSourcePgm
.CancelError = True
.DialogTitle = "请选择包含图标的 DLL 或 EXE 文件"
.Filter = "Icon Resources (*.ico;*.exe;*.dll)|*.ico;*.exe;*.dll|All files|*.*"
.Action = 1
If Err Then
Err.Clear
Exit Sub
End If
sSourcePgm = .filename
Label3.Caption = .filename
DestroyIcon lIcon
Do
lIcon = ExtractIcon(App.hInstance, sSourcePgm, a)
If lIcon = 0 Then Exit Do
a = a + 1
DestroyIcon lIcon
Loop
If a = 0 Then
MsgBox "在这个文件中没有任何图标！"
End If
Label1.Caption = "在这个文件中共有 " & a & " 个图标"
VScroll1.Max = IIf(a = 0, 0, a - 1)
VScroll1.Value = 0
VScroll1_Change
End With
End Sub
Private Sub Form_Load()
CmdOpen_Click
End Sub
Private Sub VScroll1_Change()
Label2.Caption = "正在浏览的图标索引值： " & VScroll1.Value
DestroyIcon lIcon
Picture1.Cls
lIcon = ExtractIcon(App.hInstance, sSourcePgm, VScroll1.Value)
Picture1.AutoSize = True
Picture1.AutoRedraw = True
DrawIcon Picture1.hdc, 0, 0, lIcon
Picture1.Refresh
End Sub
263、如何直接使用 VB 来打印 MS Access 的 Report？
在 Visual Basic 中，Access 2.0 可以使用 DDE 来操控，而 Access 97 及更新的版本，则可以使用 OLE Automation 来操控。不过我想，现在大部份的人使用的，都是某一个 32 位版本的 Access。
要在 Visual Basic 中来操控 Access，您首先要在 VB 的【工程】【设定引用项目】问话框中设定引用项目：
Access 7.0 设定的是 "Microsoft Access for Windows 95"
Access 8.0 设定的是 "Microsoft Access 8.0 Object Library"
引用项目设定完成之后，您就可以在您开发的应程序中，基于 Access application 来建立物件变量！只要使用一些简单的指令，您就可以用来开启资料库、执行 Access 报表及关闭资料库...等。
Dim ac As Access.Application
Set ac = New Access.Application
'指定要开启的资料库路径
ac.OpenCurrentDatabase("c:\foo\foo.mdb")
'只要使用 DoCmd 物件的 OpenReport method 就可以将报表送到打印机
ac.DoCmd.OpenReport "MyReport"
'关闭资料库
ac.CloseCurrentDatabase
很简单吧！就是上面这么简单的程序码！只是要记得，您设计的这些可以独立执行的报表，它需要出现什么样的提示讯息或问话框...等！
264、如何打开 Windows 的创建快捷方式窗口
以下的代码演示了如何利用 Win95 的 Wizard 在指定的目录中建立快捷方式。
Dim X As Integer
X = Shell("C:\WINDOWS\rundll32.exe AppWiz.Cpl,NewLinkHere " & App.Path & "\", 1)
265、如何取得短文件名
如果要传递文件到老的不支持长文件名的应用，以下的函数可以派上用场：
Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
Function ShortName(LongPath As String) As String
Dim ShortPath As String
Const MAX_PATH = 260
Dim ret&
ShortPath = Space$(MAX_PATH)
ret& = GetShortPathName(LongPath, ShortPath, MAX_PATH)
If ret& Then
ShortName = Left$(ShortPath, ret&)
End If
End Function
266、让您的音乐 CD 动起来(多部光驱)！
以前，硬件还没有很便宜的时候，一般人的机器上 (指 Client 端) 最多只会装一部光驱，很少有使用者在同一台机器上装二台或二台以上的光驱，但是，现在连烧录机及 DVD 都很便宜了，所以在机器上装二台光驱已经是稀松平常的事了。
而我们用 VB 来开发应用程序时，若需要用到光驱，以前都是使用预设的光驱，没有什么困扰，但是现在，如果应用程序还是这样写的话，可能就会有点问题会发生了！因为 User 使用的不一定是预设的光驱！
我们在【问题: 让您的音乐 CD 动起来！】中曾经介绍过如何拨放 CD，但是当时并不考虑二台以上光驱的状况，当时的程序码如下：
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
Dim lRet As Long
lRet = mciSendString("open cdaudio alias cd", 0&, 0, 0)
而今天如果有二台以上的光驱时，假设机器上的 E:\ 及 F:\ 都是光驱，而我们要用的是 F:\ 的话，只要将原来的程序稍为修改就可以了！如下：
lRet = mciSendString("open F:\ type cdaudio alias cd2", 0&, 0, 0) '使用 cd2 只是为了和上面区别而已！
至于您要如何知道有那些磁盘代号是属于光驱的话，您可以参考 (依 VB 版本而定)：
问题: 如何判断目前电脑中所有磁盘之型态？
问题: 如何侦测光驱中是否有光碟存在？
或者看看以下的这个适用多部光驱的媒体拨放程序范例，这个范例的作者对于多媒体相当有研究，且有他自己的网站，网站名称及位址是：
267、如何求出磁盘大小及剩余空间大小 (含大于 2GB 的正确算法)
在问题：如何求出磁盘大小及剩余空间大小
我们使用了 GetDiskFreeSpace API 来求出磁盘大小及剩余空间大小，
在问题：如何求出磁盘大小及剩余空间大小 (更简单的 VB6 新功能)
我们使用了 FileSystemObject 来求出磁盘大小及剩余空间大小，
如果网友自己曾经实际测试过这二个主题的程序码，而您的硬盘又大于 2GB 时，或许您会发现，只要大于 2GB 的部份都无法正确的显示！为什么会这样呢？这是因为目前 VB 只支持到 32 位的 Integer 资料型态，所以最大值就是 2GB！
要解决这个问题，您必须改用另一个 API GetDiskFreeSpaceEx，不过，在这个 API 中，有使用了一个新的 ULARGE_INTEGER Structure，所以在声明 GetDiskFreeSpaceEx API 之前，您也必须要先声明 ULARGE_INTEGER Type：
Type ULARGE_INTEGER
LowPart As Long
HighPart As Long
End Type
Declare Function GetDiskFreeSpaceEx Lib "kernel32.dll" Alias "GetDiskFreeSpaceExA" _
(ByVal lpDirectoryName As String, _ '目录名称或磁盘代码
lpFreeBytesAvailableToCaller As ULARGE_INTEGER, _ '剩余可用空间大小 (Bytes)
lpTotalNumberOfBytes As ULARGE_INTEGER, _ '磁盘总空间大小 (Bytes)
lpTotalNumberOfFreeBytes As ULARGE_INTEGER) As Long '剩余总空间大小 (Bytes)
ULARGE_INTEGER Structure 是一个 VB 预设中尚未支持的 64 位的 Integer，它的范围是从 &H0 到 &HFFFFFFFFFFFFFFFF (也就是 2 的 64 次方)，它可用于所有尚未支持 64 位的 Integer 的程序语言中。它将 64 位的值切割成二个 32 位的部份，也就是 LowPart 及 HighPart。如果那一天 VB 开始支持 64 位的 Integer 资料型态，ULARGE_INTEGER Structure 就用不到了，否则，您一定要记得声明！
在模组中声明了上面的 Type ULARGE_INTEGER 及 GetDiskFreeSpaceEx API 之后，我们来看看以下的范例程序：
Private Sub Command1_Click()
Dim userbytes As ULARGE_INTEGER ' 目前 User 可用磁盘空间
Dim totalbytes As ULARGE_INTEGER ' 磁盘总空间
Dim freebytes As ULARGE_INTEGER ' 磁盘剩余总空间
Dim retval As Long ' GetDiskFreeSpaceEx 的返回值
If Text1.Text = "" Then Text1.Text = "C"
retval = GetDiskFreeSpaceEx(Text1.Text & ":\", userbytes, totalbytes, freebytes)
'
If userbytes.LowPart < 0 Then
User 可用磁盘空间 = Format((userbytes.HighPart * (16 ^ 8)) + (userbytes.LowPart + (16 ^ 8)), "#,###")
Else
User 可用磁盘空间 = Format((userbytes.HighPart * (16 ^ 8)) + userbytes.LowPart, "#,###")
End If
'
If totalbytes.LowPart < 0 Then
磁盘总空间 = Format((totalbytes.HighPart * (16 ^ 8)) + (totalbytes.LowPart + (16 ^ 8)), "#,###")
Else
磁盘总空间 = Format((totalbytes.HighPart * (16 ^ 8)) + totalbytes.LowPart, "#,###")
End If
'
If freebytes.LowPart < 0 Then
磁盘剩余总空间 = Format((freebytes.HighPart * (16 ^ 8)) + (freebytes.LowPart + (16 ^ 8)), "#,###")
Else
磁盘剩余总空间 = Format((freebytes.HighPart * (16 ^ 8)) + freebytes.LowPart, "#,###")
End If
'
Text1.SelStart = 0
Text1.SelLength = Len(Text1)
End Sub
注意：以上的功能有以下 OS 本身的限制
Windows 95 必须在 OSR2 或以后的版本才行！
Windows NT 必须在 4.0 以后的版本才行！
268、如何显示磁盘中所有的目录？
以下的代码把盘中所有的目录都显示在 Listbox 中。需要一个 DriveListBox 和一个 DirListBox。如果 DirListBox 隐藏的话，处理可以快一些。
Dim iLevel As Integer, iMaxSize As Integer
Dim i As Integer, j As Integer
ReDim iDirCount(22) As Integer
'最大 22 级目录
ReDim sdirs(22, 1) As String
'drive1 是 DriveListBox 控件
'dir1 是 DirListBox 控件
iLevel = 1
iDirCount(iLevel) = 1
iMaxSize = 1
sdirs(iLevel, iDirCount(iLevel)) = Left$(drive1.Drive, 2) & "\"
Do
iLevel = iLevel + 1
iDirCount(iLevel) = 0
For j = 1 To iDirCount(iLevel - 1)
dir1.Path = sdirs(iLevel - 1, j)
dir1.Refresh
If iMaxSize < (iDirCount(iLevel) + dir1.ListCount) Then
ReDim Preserve sdirs(22, iMaxSize + dir1.ListCount + 1) As String
iMaxSize = dir1.ListCount + iDirCount(iLevel) + 1
End If
For i = 0 To dir1.ListCount - 1
iDirCount(iLevel) = iDirCount(iLevel) + 1 '子目录记数
sdirs(iLevel, iDirCount(iLevel)) = dir1.List(i)
Next i
Next j
'所有名称放到 List1 中
list1.Clear
If iDirCount(iLevel) = 0 Then
'如果无自目录
For i = 1 To iLevel
For j = 1 To iDirCount(i)
list1.AddItem sdirs(i, j)
Next j
Next i
Exit Do
End If
Loop
269、如何取得长文件名？
Public Function GetLongFilename (ByVal sShortName As String) As String
Dim sLongName As String
Dim sTemp As String
Dim iSlashPos As Integer
'Add \ to short name to prevent Instr from failing
sShortName = sShortName & "\"
'Start from 4 to ignore the "[Drive Letter]:\" characters
iSlashPos = InStr(4, sShortName, "\")
'Pull out each string between \ character for conversion
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
'Prefix with the drive letter
GetLongFilename = Left$(sShortName, 2) & sLongName
End Function
评论