'--与文件及文件夹操作相关的函数
'--必须引用FSO的ACTIVE OBJECT
Dim strList As String '--列表串，返回文件列表
'================
'--文件操作区
Public Function CopyFile(SourseStr As String, WhereStr As String, Optional WhereStr2 As String = "") As Boolean
On Error Resume Next
Dim myFso As New FileSystemObject
Dim myFile As File
If myFso.FileExists(SourseStr) Then
Set myFile = myFso.GetFile(SourseStr)
myFile.Copy (WhereStr)
If WhereStr2 <> "" Then
myFile.Copy (WhereStr2)
End If
CopyFile = True
Set myFile = Nothing
Else
CopyFile = False
End If
End Function
Public Function DeleteFileX(ByVal strFileAndPath As String) As Boolean
On Error GoTo deleteError
DeleteFileX = False
Dim myFso As New FileSystemObject
Dim myFile As File
If myFso.FileExists(strFileAndPath) = True Then
Set myFile = myFso.GetFile(strFileAndPath)
myFile.Attributes = Normal
myFso.DeleteFile strFileAndPath, True
DeleteFileX = True
Set myFile = Nothing
End If
Exit Function
deleteError:
DeleteFileX = False
Err.Clear
End Function
'--检查文件是否存在
Public Function IsFileExits(ByVal strFile As String) As Boolean
On Error GoTo IsFileExitsErr
IsFileExits = True
Dim myFso As New FileSystemObject
If Dir(strFile) = "" And myFso.FileExists(strFile) = False Then
IsFileExits = False
End If
Set myFso = Nothing
Exit Function
IsFileExitsErr:
Err.Clear
IsFileExits = False
End Function
'====================================
'--文件夹操作区
'--复制文件夹
'--若要复制C盘下的window文件夹到“d:\dd"文件夹的下面，必须使用
'--copydir "c:\window\","d:\dd\"表示
Public Function CopyDir(SourseStr As String, WhereStr As String, Optional WhereStr2 As String = "") As Boolean
On Error GoTo CopyDirErr
Dim myFso As New FileSystemObject
Dim myFolder As Folder
If myFso.FolderExists(SourseStr) Then
Set myFolder = myFso.GetFolder(SourseStr)
myFolder.Copy (WhereStr)
If WhereStr2 <> "" Then
myFolder.Copy (WhereStr2)
End If
CopyDir = True
Set myFolder = Nothing
Else
CopyDir = False
End If
'------
Exit Function
CopyDirErr:
CopyDir = False
Err.Clear
End Function
'--删除文件 夹
Public Function DeleteDirX(strFileAndPath As String) As Boolean
On Error GoTo deleteError
DeleteDirX = False
'-----
Dim myFso As New FileSystemObject
Dim myFolder As Folder
If myFso.FolderExists(strFileAndPath) = True Then
Set myFolder = myFso.GetFolder(strFileAndPath)
myFolder.Attributes = Normal
myFso.DeleteFolder strFileAndPath
DeleteDirX = True
End If
Set myFolder = Nothing
Set myFso = Nothing
Exit Function
deleteError:
DeleteDirX = False
End Function
'------
Public Function IsFolderExist(ByVal strFolder As String) As Boolean
On Error GoTo IsFolderExistERR
IsFolderExist = False
'-------------------------
Dim myFso As New FileSystemObject
If myFso.FolderExists(strFolder) = True Then
IsFolderExist = True
End If
Set myFso = Nothing
'------------------------------------
Exit Function
IsFolderExistERR:
Err.Clear
End Function '--创建新文件夹-在本地创建
Public Function CreateDir(strLongDir As String) As Boolean
Dim strDir$, i As Integer
Dim strdirX$
Dim strN$
On Error GoTo yy
Dim myFso As New FileSystemObject
If Right(strLongDir, ) <> "\" And Right(strLongDir, ) <> "/" Then
strDir = strLongDir & "\"
Else
strDir = strLongDir
End If
For i = To Len(strDir)
strN = Mid(strDir, i, )
If strN = "\" Or strN = "/" Then
If i = Then GoTo xx
strdirX = Left(strDir, i - )
If myFso.FolderExists(strdirX) = False Then
MkDir strdirX
End If
End If
xx:
Next
CreateDir = True
Exit Function
yy:
CreateDir = False
End Function
'--得到某个Folder下所有的文件列表
Public Function ShowFolderList(ByVal folderSpec As String) As String
On Error GoTo ShowFolderListErr
ShowFolderList = ""
'------------------------------
Dim fS As New FileSystemObject, F As Folder, F1 As File, fC As Files, s As String
Set F = fS.GetFolder(folderSpec)
Set fC = F.Files
s = ""
For Each F1 In fC
If s = "" Then
s = F1.Name
Else
s = s & "|" & F1.Name
End If
Next
ShowFolderList = s
'-------------
Exit Function
ShowFolderListErr:
Err.Clear
End Function
'----得到某个FOLDER下所有的夹
Public Function ShowFolderFolderList(ByVal folderSpec As String) As String
On Error GoTo ShowFolderFolderListERR
ShowFolderFolderList = ""
'-----------------------
Dim fS As New FileSystemObject, F As Folder, F1 As Folder, fC As Folders, s As String
Set F = fS.GetFolder(folderSpec)
Set fC = F.SubFolders
s = ""
For Each F1 In fC
If s = "" Then
s = F1.Name
Else
s = s & "|" & F1.Name
End If
Next
ShowFolderFolderList = s
'--------------------------
Exit Function
ShowFolderFolderListERR:
Err.Clear
End Function