'--与文件及文件夹操作相关的函数'--必须引用FSO的ACTIVE OBJECTDim 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 IfEnd FunctionPublic Function DeleteFileX(ByVal strFileAndPath As String) As BooleanOn Error GoTo deleteErrorDeleteFileX = FalseDim myFso As New FileSystemObjectDim myFile As FileIf myFso.FileExists(strFileAndPath) = True Then Set myFile = myFso.GetFile(strFileAndPath) myFile.Attributes = Normal myFso.DeleteFile strFileAndPath, True DeleteFileX = True Set myFile = NothingEnd IfExit FunctiondeleteError:DeleteFileX = FalseErr.ClearEnd 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 FunctionIsFileExitsErr: Err.Clear IsFileExits = FalseEnd 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 FunctionCopyDirErr: CopyDir = False Err.ClearEnd 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 FunctiondeleteError: DeleteDirX = FalseEnd 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 FunctionIsFolderExistERR: Err.ClearEnd 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, 1) <> "\" And Right(strLongDir, 1) <> "/" Then strDir = strLongDir & "\" Else strDir = strLongDir End If For i = 1 To Len(strDir) strN = Mid(strDir, i, 1) If strN = "\" Or strN = "/" Then If i = 3 Then GoTo xx strdirX = Left(strDir, i - 1) If myFso.FolderExists(strdirX) = False Then MkDir strdirX End If End Ifxx: Next CreateDir = True Exit Functionyy: CreateDir = FalseEnd 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 FunctionShowFolderListErr: Err.ClearEnd 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 FunctionShowFolderFolderListERR: Err.ClearEnd Function
梦想，并不奢侈，只要勇敢地迈出第一步。
