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

'返回布尔值
'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

'返回磁盘总空间大小(单位：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

'返回 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

'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 秒
        If Fso.Drives(Drive).IsReady = True 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