VB6中FSO具体应用详解

文前申明:原文为通用版实例代码,本菜鸟在每例之后加入一个简单的实例(均验证通过),供有需要的朋友参考.

您正在看的VB教程是:VB入门基础认识VB的文件系统对象FSO。 

在 VB 编程中经常需要和文件系统打交道，比如获取硬盘的剩余空间、判断文件夹或文件是否存在等。在VB 推出文件系统对象(File System Object)以前，完成这些功能需要调用 Windows API 函数或者使用一些比较复杂的过程来实现，使编程复杂、可靠性差又容易出错。使用 Windows 提供的的文件系统对象，一切变得简单多了。以下笔者举出一些编程中比较常用的例子，以函数或过程的形式提供给大家，读者可在编程中直接使用，也可以改进后实现更为强大的功能。

  要应用 FSO 对象，须要引用一个名为 Scripting 的类型库，方法是，执行 VB6.0 的菜单项“工程/引用”，添加引用列表框中的“Microsoft Scripting Runtime”一项。然后我们在“对象浏览器”中就可以看到 Scripting 类型库下的众多对象及其方法、属性。

如果未添加此引用,运行时会出现以下错误:

1.判断光驱的盘符

  Function GetCDROM()      返回光驱的盘符(字母)
  Dim Fso As New FileSystemObject       '创建 FSO 对象的一个实例
  Dim FsoDrive As Drive, FsoDrives As Drives   '定义驱动器、驱动器集合对象
  Set FsoDrives = Fso.Drives
  For Each FsoDrive In FsoDrives          '遍历所有可用的驱动器
  If FsoDrive.DriveType = CDRom Then       '如果驱动器的类型为 CDrom
  GetCDROM = FsoDrive.DriveLetter   '输出其盘符
  Else
  GetCDROM = ""
  End If
  Next
  Set Fso = Nothing
  Set FsoDrive = Nothing
  Set FsoDrives = Nothing
  End Function

个人改写实例:用以上代码验证电脑硬盘的盘符类型

首先建立窗体, 在设计模式把form的autoredraw设置为true

Sub Form_Load()

'首先在设计模式把form的autoredraw设置为true

 Dim Fso As New FileSystemObject          '创建 FSO 对象的一个实例

  Dim FsoDrive As Drive, FsoDrives As Drives '定义驱动器、驱动器集合对象

  Set FsoDrives = Fso.Drives

  For Each FsoDrive In FsoDrives       '遍历所有可用的驱动器

 

  If FsoDrive.DriveType = CDRom Then       '如果驱动器的类型为 CDrom

  GetCDROM = FsoDrive.DriveLetter   '输出其盘符

  Print "CDRom 驱动器是:"

  Print GetCDROM

  ElseIf FsoDrive.DriveType = Fixed Then

  getfixed = FsoDrive.DriveLetter

  Print "固定驱动器是:"

  Print getfixed

 

  ElseIf FsoDrive.DriveType = Remote Then

  getremote = FsoDrive.DriveLetter

  Print "网络驱动器是:"

  Print getremote

 

  ElseIf FsoDrive.DriveType = unknown Then

  getunknown = FsoDrive.DriveLetter

  Print "未知驱动器是:"

  Print getunknow

 

  ElseIf FsoDrive.DriveType = RamDisk Then

  getramdisk = FsoDrive.DriveLetter

  Print "RAM磁盘是:"

  Print getramdisk

   End If

  

  Next

  Set Fso = Nothing

  Set FsoDrive = Nothing

  Set FsoDrives = Nothing

End Sub

2.判断文件、文件夹是否存在：

  '返回布尔值:True 存在，False 不存在，filername 文件名

  Function FileExist(filename As String)
  Dim Fso As New FileSystemObject
  If Fso.FileExists(filename) = True Then
  FileExist = True
  Else
  FileExist = False
  End If
  Set Fso = Nothing

End Function

'返回布尔值:True 存在，False 不存在，foldername 文件夹
  Function FolderExist(foldername As String)
  Dim Fso As New FileSystemObject
  If Fso.FolderExists(foldername) = True Then
  FolderExist = True
  Else
  FolderExist = False
  End If
  Set Fso = Nothing
  End Function

个人改进实例:验证文件是否存在

首先在form中建立一个文本框和一个按钮.文本框的multiline属性改为true

运行时在文本框中输入文件名,格式为D:\*.jpg,可以用通配符,或者固定文件名

然后单击按钮来验证文件是否存在

Sub Command1_Click()

Dim fs As New FileSystemObject

filename = Text1.Text

If fs.FileExists(filename) Then

Text1.Text = "存在"

Else

Text1.Text = "不存在"

End If

End Sub

Private Sub Form_Load()

Command1.Caption = "验证"

End Sub

3、获取驱动器参数:

返回磁盘总空间大小(单位：M)，Drive = 盘符 A ,C, D ...
  Function AllSpace(Drive As String)
  Dim Fso As New FileSystemObject, Drv As Drive
 Set Drv = Fso.GetDrive(Drive) '得到 Drv 对象的实例
  If Drv.IsReady Then '如果该驱动器存在(软驱或光驱里有盘片，硬盘存取正常)
  AllSpace = Format(Drv.TotalSize / (2 ^ 20), "0.00") '将字节转换为兆
  Else
  AllSpace = 0
  End If
  Set Fso = Nothing
  Set Drv = Nothing
  End Function
  '返回磁盘可用空间大小(单位：M)，Drive = 盘符 A ,C, D ...
  Function FreeSpace(drive)
  Dim Fso As New FileSystemObject, drv As drive
  Set drv = Fso.GetDrive(drive)
  If drv.IsReady Then
  FreeSpace = Format(drv.FreeSpace / (2 ^ 20), "0.00")
  End If
  Set Fso = Nothing
  Set Drv = Nothing
  End Function
 

  '获取驱动器文件系统类型，Drive = 盘符 A ,C, D ...
  Function FsType(Drive As String)
  Dim Fso As New FileSystemObject, Drv As Drive
  Set Drv = Fso.GetDrive(Drive)
  If Drv.IsReady Then
  FsType = Drv.FileSystem
  Else
  FsType = ""
  End If
  Set Fso = Nothing
  Set Drv = Nothing
  End Function

个人改进实例:验证c盘空间和文件类型

在窗体中画一个文本框和一个按钮,文本框的multiline属性改为true

Sub Command1_Click()

 Dim fso As New FileSystemObject, drv As Drive

 

 Set drv = fso.GetDrive(fso.GetDriveName("c:"))      '得到 Drv 对象的实例

  If drv.IsReady Then             '如果该驱动器存在(软驱或光驱里有盘片，硬盘存取正常)

 

  AllSpace = Format(drv.TotalSize / (2 ^ 20), "0.00") '将字节转换为兆

  free = Format(drv.FreeSpace / (2 ^ 20), "0.00")

  sys = drv.FileSystem

  Else

  AllSpace = 0

  End If

  Set fso = Nothing

  Set drv = Nothing

Text1.Text = "C盘空间为" & AllSpace & "MB" & vbCrLf & "c盘空闲空间为" & free & "MB"

Text1.Text = Text1.Text & vbCrLf & "c盘的文件系统为" & sys

End Sub

4，获取系统文件夹路径：

  '返回 Windows 文件夹路径
  Function GetWindir()
  Dim Fso As New FileSystemObject
  GetWindir = Fso.GetSpecialFolder(WindowsFolder)
  Set Fso = Nothing
  End Function
  '返回 Windows\System 文件夹路径
  Function GetWinSysdir()
  Dim Fso As New FileSystemObject
  GetWinSysdir = Fso.GetSpecialFolder(SystemFolder)
  Set Fso = Nothing
  End Function

个人改进实例:获取系统文件夹

同上,在窗体中画文本框和按钮,运行后点按钮来验证,别忘了把文本框的multiline属性改为true

Private Sub Command1_Click()

Dim fso As New FileSystemObject

 getwin = fso.GetSpecialFolder(windowfolder)

 getsys = fso.GetSpecialFolder(SystemFolder)

 Text1.Text = "windows文件夹为:" & getwin & vbCrLf & "system文件夹为:" & getsys

End Sub

5，综合运用：一个文件备份通用过程：
 

'Filename = 文件名，Drive = 驱动器，Folder = 文件夹(一层)

  Sub BackupFile(Filename As String, Drive As String, Folder As String)
  Dim Fso As New FileSystemObject '创建 FSO 对象实例
  Dim Dest_path As String, Counter As Long
  Counter = 0

  Do While Counter < 6 '如果驱动器没准备好，继续检测。共检测 6 秒
  Counter = Counter + 1
  Call Waitfor(1) '间隔 1 秒
Then
  Exit Do
  End If
  Loop

  If Fso.Drives(Drive).IsReady = False Then '6 秒后目标盘仍未准备就绪，退出
  MsgBox " 目标驱动器 " & Drive & " 没有准备好！ ", vbCritical
  Exit Sub
  End If
  If Fso.GetDrive(Drive).FreeSpace < Fso.GetFile(Filename).Size Then
  MsgBox "目标驱动器空间太小！", vbCritical '目标驱动器空间不够，退出
  Exit Sub
  End If
  If Right(Drive, 1) <> ":" Then
  Drive = Drive & ":"
  End If
  If Left(Folder, 1) <> "\" Then
  Folder = "\" & Folder
  End If
  If Right(Folder, 1) <> "\" Then
  Folder = Folder & "\"
  End If
  Dest_path = Drive & Folder
  If Not Fso.FolderExists(Dest_path) Then '如果目标文件夹不存在，创建之
  Fso.CreateFolder Dest_path
  End If
  Fso.CopyFile Filename, Dest_path & Fso.GetFileName(Filename), True
  '拷贝，直接覆盖同名文件
  MsgBox " 文件备份完毕。", vbOKOnly
  Set Fso = Nothing
  End Sub
  Private Sub Waitfor(Delay As Single) '延时过程，Delay 单位约为 1 秒
  Dim StartTime As Single
  StartTime = Timer
  Do Until (Timer - StartTime) > Delay
  Loop
  End Sub

个人改进实例一:(复杂)

首先建立窗体,在窗体下输入以下代码:

 Private Sub Waitfor(Delay As Single) '延时过程，Delay 单位约为 1 秒

  Dim StartTime As Single

  StartTime = Timer

  Do Until (Timer - StartTime) > Delay

  Loop

  End Sub

Private Sub Form_Load()

 Dim Fso As New FileSystemObject '创建 FSO 对象实例

  Dim Dest_path As String, Counter As Long

  Counter = 0

  Do While Counter < 6 '如果驱动器没准备好，继续检测。共检测 6 秒

  Counter = Counter + 1

  Call Waitfor(1) '间隔 1 秒

  Exit Do

  Loop

  If Fso.Drives("d:").IsReady = False Then '6 秒后目标盘仍未准备就绪，退出

  MsgBox " 目标驱动器 " & "d:" & " 没有准备好！ ", vbCritical

  Exit Sub

  End If

 

    Dim sofile

  sofile = InputBox("请输入要复制的文件名(如C:\temp.doc)")

 

  If Fso.GetDrive("d:").FreeSpace < Fso.GetFile(sofile).Size Then

  MsgBox "目标驱动器空间太小！", vbCritical '目标驱动器空间不够，退出

  Exit Sub

  End If

 

 

  Drive = InputBox("请输入目的驱动器盘符(如D):")

  If Right(Drive, 1) <> ":" Then

  Drive = Drive & ":"

  End If

 

 

  Depath = InputBox("请输入目标文件夹(如temp):")

  If Left(Depath, 1) <> "\" Then

  Folder = "\" & Depath

  End If

  If Right(Depath, 1) <> "\" Then

  Folder = Depath & "\"

  End If

 

  Dest_path = Drive & Folder

  MsgBox "目标文件为" & Dest_path

 

  If Not Fso.FolderExists(Dest_path) Then '如果目标文件夹不存在，创建之

  Fso.CreateFolder (Dest_path)

  End If

 

 

  Fso.CopyFile sofile, Dest_path, True

  '拷贝，直接覆盖同名文件

  MsgBox " 文件备份完毕。", vbOKOnly

  Set Fso = Nothing

End Sub

个人改进实例二:(精简)

先建立窗体,在窗体下输入以下代码:

Private Sub Form_Load()

 Dim Fso As New FileSystemObject '创建 FSO 对象实例

  Dim Depath As String

  Dim sofile

  sofile = InputBox("请输入要复制的文件名(如C:\temp.doc)")

  MsgBox "要复制的文件名为" & sofile

 

 

  Depath = InputBox("请输入目的文件夹(如D:\temp\):")

  MsgBox "目标文件夹为" & Depath

 

  If Not Fso.FolderExists(Depath) Then '如果目标文件夹不存在，创建之

  Fso.CreateFolder (Depath)

  End If

 

 

  Fso.CopyFile sofile, Depath, True

  '拷贝，直接覆盖同名文件

  MsgBox " 文件备份完毕。", vbOKOnly

  Set Fso = Nothing

End Sub