fileapi.bas

此文档为VB公共模块

Attribute VB_Name = "FileApi"
Option Explicit
'*********************文件或目录操作*************************
'*作者：谢建军                                              *
'*创建日期：2002年11月18日  20：47                          *
'************************************************************
'*  1.WriteINI(ByVal TmpGroup As String,　　　　　　　　　　*
'*             ByVal TmpKeyName As String,　　　　　　　　　*
'*             ByVal TmpValue As String,                    *
'*             ByVal TmpINIFilePath As String)              *
'*  2.GetINI(ByVal TmpGroup As String,                      *
'*            ByVal TmpKeyName As String,                   *
'*            ByVal TmpINIFilePath As String)               *
'*  3.CopyFileOrPath
'*  4.MoveFileOrPath
'*  5.DeleteFileOrPath
'*  6.ReNameFileOrPath
'*  7.GetTempFile(Optional ByVal cPrefix As String)         *
'************************************************************

'Write or Read From Ini Files
Private Declare Function GetPrivateProfileString Lib "kernel32" _
   Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Private Declare Function WritePrivateProfileString Lib "kernel32" _
Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, _
   ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long

'返回一个临时文件名称
Private Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" (ByVal lpszPath As _
String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, _
ByVal lpBuffer As String) As Long

'返回文件或文件夹的属性
Private Declare Function OpenFile Lib "kernel32" (ByVal lpFileName As String, _
                            lpReOpenBuff As OFSTRUCT, ByVal wStyle As Long) As Long
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, _
                            ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, _
                            ByVal lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, _
                            ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
'返回文件的时间
Private Declare Function GetFileTime Lib "kernel32" (ByVal hFile As Long, lpCreationTime As FILETIME, lpLastAccessTime As FILETIME, lpLastWriteTime As FILETIME) As Long
'时间转换
Private Declare Function FileTimeToSystemTime Lib "kernel32" (lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long
Private Declare Function FileTimeToLocalFileTime Lib "kernel32" (lpFileTime As FILETIME, lpLocalFileTime As FILETIME) As Long
'文件操作相关API
Private Const FO_MOVE As Long = &H1
Private Const FO_COPY As Long = &H2
Private Const FO_DELETE As Long = &H3
Private Const FO_RENAME As Long = &H4
Private Const OFS_MAXPATHNAME = 128
Private Const OF_CREATE = &H1000
Private Const OF_READ = &H0
Private Const OF_WRITE = &H1
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const OPEN_EXISTING = 3
Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2

Private Type OFSTRUCT
        cBytes As Byte
        fFixedDisk As Byte
        nErrCode As Integer
        Reserved1 As Integer
        Reserved2 As Integer
        szPathName(OFS_MAXPATHNAME) As Byte
End Type
Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type
Private Type SYSTEMTIME
    wYear As Integer
    wMonth As Integer
    wDayOfWeek As Integer
    wDay As Integer
    wHour As Integer
    wMinute As Integer
    wSecond As Integer
    wMilliseconds As Integer
End Type
Private Const FOF_MULTIDESTFILES As Long = &H1
Private Const FOF_CONFIRMMOUSE As Long = &H2
Private Const FOF_SILENT As Long = &H4
Private Const FOF_RENAMEONCOLLISION As Long = &H8
Private Const FOF_NOCONFIRMATION As Long = &H10
Private Const FOF_WANTMAPPINGHANDLE As Long = &H20
Private Const FOF_CREATEPROGRESSDLG As Long = &H0
Private Const FOF_ALLOWUNDO As Long = &H40
Private Const FOF_FILESONLY As Long = &H80
Private Const FOF_SIMPLEPROGRESS As Long = &H100
Private Const FOF_NOCONFIRMMKDIR As Long = &H200
Private Const FILE_FLAG_BACKUP_SEMANTICS = &H2000000

Private Type SHFILEOPSTRUCT
    hWnd As Long
    wFunc As Long
    pFrom As String
    pTo As String
    fFlags As Long
    fAnyOperationsAborted As Long
    hNameMappings As Long
    lpszProgressTitle As String
End Type

Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long

Private Const MAX_PATH = 260
Public TotalFile As Long
Public TotalFolder As Long

'Public Type FileProperty
'    Type As String      '文件系统项目类型
'    FullPath As String         '路径
'    FileName As String     '文件名
'    OpenMethod As String   '打开方式
'    FileSize As Long     '文件大小字节
'    FileImpropriateSize As Double   '文件占用空间
'    Cdate As Date           '创建日期
'    Mdate As Date           '修改日期
'    Adate As Date           '访问日期
'    Suc As Boolean      '文件或者文件夹
'   ' *Files as integer       总的文件数目
'   ' *Folders as integer     总的文件夹数目
'    Attribute As Byte       '文件属性
'End Type

'***********
'Write Ini File
'***********
Public Function WriteINI(ByVal TmpGroup As String, ByVal TmpKeyName As String, ByVal TmpValue As String, ByVal TmpINIFilePath As String) As Boolean
  WriteINI = Not (WritePrivateProfileString(TmpGroup, TmpKeyName, TmpValue, TmpINIFilePath) = 0)
End Function

'************
'Get String From Ini File
'************
Public Function GetINI(ByVal TmpGroup As String, ByVal TmpKeyName As String, ByVal TmpINIFilePath As String) As String
  
  Dim RetVal1 As String * 255, CaseLen As Long
  RetVal1 = Space(255)
  CaseLen = GetPrivateProfileString(TmpGroup, TmpKeyName, "", RetVal1, Len(RetVal1) - 1, TmpINIFilePath)
  If CaseLen <> 0 And CaseLen <> 255 - 1 And CaseLen <> 255 - 2 Then
   GetINI = Left(RetVal1, InStr(RetVal1, Chr(0)) - 1)
  Else
    GetINI = ""
  End If
End Function

'复制文件或文件夹
Public Function CopyFileOrPath(ByVal src As String, ByVal desc As String, Optional ByVal NeedConfirmation As Boolean, Optional ByRef ErrCode As Long) As Boolean
    Dim FileOperation As SHFILEOPSTRUCT
    With FileOperation
     .wFunc = FO_COPY
     .pFrom = src
     .pTo = desc
     .fFlags = FOF_SILENT + IIf(NeedConfirmation, 0, FOF_NOCONFIRMATION)
    End With
    
    Dim lng_RetVal As Long
    lng_RetVal = SHFileOperation(FileOperation)
    ErrCode = lng_RetVal
    CopyFileOrPath = lng_RetVal = 0
End Function

'移动文件或文件夹
Public Function MoveFileOrPath(ByVal src As String, ByVal desc As String, Optional ByVal NeedConfirmation As Boolean, Optional ByRef ErrCode As Long) As Boolean
    Dim FileOperation As SHFILEOPSTRUCT
    With FileOperation
     .wFunc = FO_MOVE
     .pFrom = src
     .pTo = desc
     .fFlags = FOF_SILENT + IIf(NeedConfirmation, 0, FOF_NOCONFIRMATION)
    End With
    
    Dim lng_RetVal As Long
    lng_RetVal = SHFileOperation(FileOperation)
    ErrCode = lng_RetVal
    MoveFileOrPath = lng_RetVal = 0
End Function

'删除文件或文件夹
Public Function DeleteFileOrPath(ByVal str_Path As String, Optional ByVal DirectDeleting As Boolean, Optional ByVal NeedConfirmation As Boolean, Optional ByRef ErrCode As Long) As Boolean
    Dim FileOperation As SHFILEOPSTRUCT
    With FileOperation
     .wFunc = FO_DELETE
     .pFrom = str_Path
     .fFlags = FOF_SILENT + IIf(DirectDeleting, 0, FOF_ALLOWUNDO) + IIf(NeedConfirmation, 0, FOF_NOCONFIRMATION)
    End With
    
    Dim lng_RetVal As Long
    lng_RetVal = SHFileOperation(FileOperation)
    ErrCode = lng_RetVal
    DeleteFileOrPath = lng_RetVal = 0
End Function

'重命名文件或文件夹
Public Function ReNameFileOrPath(ByVal src As String, ByVal newNameIncludePath As String, Optional ByVal NeedConfirmation As Boolean, Optional ByRef ErrCode As Long) As Boolean
    Dim FileOperation As SHFILEOPSTRUCT
    With FileOperation
     .wFunc = FO_RENAME
     .pFrom = src
     .pTo = newNameIncludePath
     .fFlags = FOF_SILENT + IIf(NeedConfirmation, 0, FOF_NOCONFIRMATION)
    End With
    
    Dim lng_RetVal As Long
    lng_RetVal = SHFileOperation(FileOperation)
    ErrCode = lng_RetVal
    ReNameFileOrPath = lng_RetVal = 0
End Function

'***********************
'注释： Return a temporary file name.
'***********************
Public Function GetTempFile(Optional ByVal cPrefix As String) As String

Dim temp_path As String
Dim temp_file As String
Dim length As Long
    '注释： Get the temporary file path.
    temp_path = Space$(MAX_PATH)
    length = GetTempPath(MAX_PATH, temp_path)
    temp_path = Left$(temp_path, length)

    '注释： Get the file name.
    temp_file = Space$(MAX_PATH)
    GetTempFileName temp_path, IIf(cPrefix = "", "Xjj", Left(Trim$(cPrefix), 3)), 0, temp_file
    GetTempFile = Left$(temp_file, InStr(temp_file, Chr$(0)) - 1)
End Function


'返回指定文件或文件夹的属性
Public Function GetFileOrFolderProperty(ByVal str_Name As String) As FileProperty
    On Error Resume Next
    Dim str_FileName As String, stru_FileProperty As FileProperty, OF As OFSTRUCT, fileHandle As Long
    Dim fcd As FILETIME, fmd As FILETIME, fad As FILETIME
    Dim fcd1 As SYSTEMTIME, fmd1 As SYSTEMTIME, fad1 As SYSTEMTIME
    Dim fcd2 As Date, fmd2 As Date, fad2 As Date
    str_FileName = Dir(str_Name, vbArchive + vbDirectory + vbHidden + vbNormal + vbReadOnly + vbSystem)
    If str_FileName = "" Then Exit Function
    
    stru_FileProperty.FileName = str_FileName
    stru_FileProperty.FullPath = str_Name
    Err = 0
    stru_FileProperty.Attribute = GetAttr(str_Name)
    If Err <> 0 Then stru_FileProperty.Attribute = vbNormal Or vbArchive Or vbReadOnly
    On Error Resume Next
    '得到文件日期
    If (stru_FileProperty.Attribute And vbDirectory) <> 0 Then
        fileHandle = CreateFile(str_Name, GENERIC_READ, FILE_SHARE_READ, ByVal 0&, OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, 0)
    Else
        fileHandle = OpenFile(str_Name, OF, OF_READ)
    End If
    If GetFileTime(fileHandle, fcd, fad, fmd) <> 0 Then
        FileTimeToLocalFileTime fcd, fcd
        FileTimeToLocalFileTime fad, fad
        FileTimeToLocalFileTime fmd, fmd
        FileTimeToSystemTime fcd, fcd1
        FileTimeToSystemTime fad, fad1
        FileTimeToSystemTime fmd, fmd1
        stru_FileProperty.Cdate = CDate(fcd1.wYear & "/" & fcd1.wMonth & "/" & fcd1.wDay & " " & fcd1.wHour & ":" & fcd1.wMinute & ":" & fcd1.wSecond)
        stru_FileProperty.Mdate = CDate(fmd1.wYear & "/" & fmd1.wMonth & "/" & fmd1.wDay & " " & fmd1.wHour & ":" & fmd1.wMinute & ":" & fmd1.wSecond)
        stru_FileProperty.Adate = CDate(fad1.wYear & "/" & fad1.wMonth & "/" & fad1.wDay & " " & fad1.wHour & ":" & fad1.wMinute & ":" & fad1.wSecond)
    End If
    If fileHandle <> 0 Then CloseHandle fileHandle
    'CloseHandle fileHandle
    
    If (stru_FileProperty.Attribute And vbDirectory) <> 0 Then
        stru_FileProperty.Suc = True
        stru_FileProperty.Type = "文件夹"
        stru_FileProperty.OpenMethod = ""
    Else
        stru_FileProperty.Suc = False
        stru_FileProperty.FileSize = FileLen(str_Name)
        Dim diskinfo As DiskInformation, strArr() As String
        diskinfo = GetDiskInformation(str_Name)
        stru_FileProperty.FileImpropriateSize = (stru_FileProperty.FileSize \ (diskinfo.TotalSpace(0) * diskinfo.TotalSpace(1)) + IIf(stru_FileProperty.FileSize Mod (diskinfo.TotalSpace(0) * diskinfo.TotalSpace(1)) <> 0, 1, 0)) * diskinfo.TotalSpace(0) * diskinfo.TotalSpace(1)
        strArr = Split(stru_FileProperty.FileName, ".", -1, vbTextCompare)
        If UBound(strArr) <= 0 Then
            stru_FileProperty.Type = "未知文件类型"
        Else
            stru_FileProperty.Type = ReadValue(HKEY_CLASSES_ROOT, ReadValue(HKEY_CLASSES_ROOT, "." & strArr(UBound(strArr)), ""), "")
            If stru_FileProperty.Type = "" Then stru_FileProperty.Type = "未知文件类型"
        End If
    End If
    GetFileOrFolderProperty = stru_FileProperty
    
End Function