VB6文件操作自定义函数合集之一

Posted 2020-10-10 孤荷凌寒

‘--与文件及文件夹操作相关的函数
‘--必须引用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, 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 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