cfileinfo.cls

数据库属性,页面的设置

Public Property Get attrSystem() As Boolean
   ' Returns whether file has System attribute.
   attrSystem = (m_Attributes And FILE_ATTRIBUTE_SYSTEM)
End Property

Public Property Let attrArchive(ByVal NewVal As Boolean)
   Dim NewAttr As Long
   ' Calculate new attribute value.
   If NewVal Then
      NewAttr = m_Attributes Or FILE_ATTRIBUTE_ARCHIVE
   Else
      NewAttr = m_Attributes And Not FILE_ATTRIBUTE_ARCHIVE
   End If
   ' Attempt to set new attribute if not set already.
   If NewAttr <> m_Attributes Then
      If SetAttr(NewAttr) Then
         Me.Refresh
      End If
   End If
End Property

Public Property Get attrArchive() As Boolean
   ' Returns whether file has Archive attribute.
   attrArchive = (m_Attributes And FILE_ATTRIBUTE_ARCHIVE)
End Property

Public Property Let attrTemporary(ByVal NewVal As Boolean)
   ' Cannot change Temporary attribute with normal methods
   ' (This must be set with CreateFile?), but include the
   ' stub routine here just in case anyone tries.
End Property

Public Property Get attrTemporary() As Boolean
   ' Returns whether file has Temporary attribute.
   attrTemporary = (m_Attributes And FILE_ATTRIBUTE_TEMPORARY)
End Property

Public Property Let attrCompressed(ByVal NewVal As Boolean)
   ' Cannot change Compressed attribute with normal methods,
   ' but should have a stub routine here just in case anyone
   ' tries.
End Property

Public Property Get attrCompressed() As Boolean
   ' Returns whether file has Compressed attribute.
   attrCompressed = (m_Attributes And FILE_ATTRIBUTE_COMPRESSED)
End Property

Public Property Get hIcon() As Long
   ' Returns handle to display icon.
   hIcon = m_hIcon
End Property

' ********************************************
'  Public Methods
' ********************************************
Public Sub Refresh()
   Dim hSearch As Long
   Dim wfd As WIN32_FIND_DATA
   Dim Buffer As String
   Dim nRet As Long
   Dim i As Long
   Dim sfi As SHFILEINFO
   '
   ' Check for existence of file.
   '
   hSearch = FindFirstFile(m_PathName, wfd)
   If hSearch <> INVALID_HANDLE_VALUE Then
      Call FindClose(hSearch)
      '
      ' Assign file data to member variables.
      '
      m_FileExists = True
      m_PathExists = True
      m_FileSize = wfd.nFileSizeLow
      m_FileSizeHigh = wfd.nFileSizeHigh
      m_Attributes = wfd.dwFileAttributes
      m_tmCreation = FileTimeToDouble(wfd.ftCreationTime, True)
      m_tmAccess = FileTimeToDouble(wfd.ftLastAccessTime, True)
      m_tmWrite = FileTimeToDouble(wfd.ftLastWriteTime, True)
      '
      ' Assign file/path data to member variables.
      '
      m_Name = TrimNull(wfd.cFileName)
      For i = Len(m_PathName) To 1 Step -1
         If Mid(m_PathName, i, 1) = "\" Then
            m_Path = ProperCasePath(Left(m_PathName, i))
            If Right(m_Path, 1) <> "\" Then m_Path = m_Path & "\"
            Exit For
         End If
      Next i
      m_PathName = m_Path & m_Name
      '
      ' Extract extension from filename.
      '
      If InStr(m_Name, ".") Then
         For i = Len(m_Name) To 1 Step -1
            If Mid(m_Name, i, 1) = "." Then
               m_Extension = Mid(m_Name, i + 1)
               Exit For
            End If
         Next i
      Else
         m_Extension = ""
      End If
      '
      ' Short name same as long, if cAlternate element empty.
      '
      If InStr(wfd.cAlternate, vbNullChar) = 1 Then
         m_NameShort = UCase(m_Name)
      Else
         m_NameShort = TrimNull(wfd.cAlternate)
      End If
      '
      ' Retrieve short path name.
      '
      Buffer = Space(MAX_PATH)
      nRet = GetShortPathName(m_PathName, Buffer, Len(Buffer))
      If nRet Then
         m_PathNameShort = Left(Buffer, nRet)
         m_PathShort = Left(m_PathNameShort, Len(m_PathNameShort) - Len(m_NameShort))
      End If
      '
      ' Retrieve compressed size.
      '
      m_CompFileSize = GetCompressedFileSize(m_PathName, m_CompFileSizeHigh)
      '
      ' Get icon and descriptive text.
      '
      If m_hIcon Then
         Call DestroyIcon(m_hIcon)
         m_hIcon = 0
      End If
      nRet = SHGetFileInfo(m_PathName, 0&, sfi, Len(sfi), _
             SHGFI_ICON Or SHGFI_DISPLAYNAME Or SHGFI_TYPENAME)
      m_DisplayName = TrimNull(sfi.szDisplayName)
      m_TypeName = TrimNull(sfi.szTypeName)
      m_hIcon = sfi.hIcon
      '
      ' Confirm displayable typename.
      '
      If Trim(m_TypeName) = "" Then
         m_TypeName = Trim(UCase(m_Extension) & " File")
      End If
   Else
      '
      ' Assign applicable data to member variables.
      '
      m_FileExists = False
   End If
End Sub

Public Function FormatFileDate(ByVal dt As Double) As String
   FormatFileDate = Format(dt, "long date") & " " & _
                    Format(dt, "long time")
End Function

Public Function FormatFileSize(ByVal Size As Long) As String
   Dim sRet As String
   Const KB& = 1024
   Const MB& = KB * KB
   ' Return size of file in kilobytes.
   If Size < KB Then
      sRet = Format(Size, "#,##0") & " bytes"
   Else
      Select Case Size \ KB
         Case Is < 10
            sRet = Format(Size / KB, "0.00") & "KB"
         Case Is < 100
            sRet = Format(Size / KB, "0.0") & "KB"
         Case Is < 1000
            sRet = Format(Size / KB, "0") & "KB"
         Case Is < 10000
            sRet = Format(Size / MB, "0.00") & "MB"
         Case Is < 100000
            sRet = Format(Size / MB, "0.0") & "MB"
         Case Is < 1000000
            sRet = Format(Size / MB, "0") & "MB"
         Case Is < 10000000
            sRet = Format(Size / MB / KB, "0.00") & "GB"
      End Select
      sRet = sRet & " (" & Format(Size, "#,##0") & " bytes)"
   End If
   FormatFileSize = sRet
End Function

' ********************************************
'  Private Methods
' ********************************************
Private Function DoubleToFileTime(ftDbl As Double, Optional Universalize As Boolean = True) As FILETIME
   Dim ft As FILETIME
   Dim st As SYSTEMTIME
   '
   ' Convert double to systemtime structure.
   '
   With st
      .wYear = Year(ftDbl)
      .wMonth = Month(ftDbl)
      .wDay = Day(ftDbl)
      .wDayOfWeek = Weekday(ftDbl) - 1
      .wHour = Hour(ftDbl)
      .wMinute = Minute(ftDbl)
      .wSecond = Second(ftDbl)
   End With
   '
   ' Convert systemtime to filetime structure.
   '
   Call SystemTimeToFileTime(st, ft)
   '
   ' Convert local time to UTC time, if requested.
   '
   If Universalize Then
      Call LocalFileTimeToFileTime(ft, DoubleToFileTime)
   Else
      DoubleToFileTime = ft
   End If
End Function

Private Function FileTimeToDouble(ftUTC As FILETIME, Localize As Boolean) As Double
   Dim ft As FILETIME
   Dim st As SYSTEMTIME
   Dim d As Double
   Dim t As Double
   '
   ' Convert to local filetime, if necessary.
   '
   If Localize Then
      Call FileTimeToLocalFileTime(ftUTC, ft)
   Else
      ft = ftUTC
   End If
   '
   ' Convert to system time structure.
   '
   Call FileTimeToSystemTime(ft, st)
   '
   ' Convert to VB-style date (double).
   '
   FileTimeToDouble = DateSerial(st.wYear, st.wMonth, st.wDay) + _
                      TimeSerial(st.wHour, st.wMinute, st.wSecond)
End Function

Private Function SetAttr(NewAttr As Long) As Boolean
   ' Nothing fancy, just set new attribute and return
   If m_FileExists Then
      SetAttr = SetFileAttributes(m_PathName, NewAttr)
   End If
End Function

Private Function SetTime(NewTime As Double, WhichTime As FileTimes) As Boolean
   Dim ft As FILETIME
   Dim hFile As Long
   '
   ' Bail if no file exists.
   '
   If m_FileExists = False Then Exit Function
   '
   ' Convert passed time (presumably local) to UTC.
   '
   ft = DoubleToFileTime(NewTime, True)
   '
   ' Get a handle on existing file so we can change times.
   '
   hFile = CreateFile(m_PathName, _
      GENERIC_READ Or GENERIC_WRITE, FILE_SHARE_READ Or FILE_SHARE_WRITE, _
      ByVal 0&, OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, 0)
   '
   ' If we were able to open file, change it's timestamp.
   '
   If hFile <> INVALID_HANDLE_VALUE Then
      Select Case WhichTime
         Case ftCreationTime
            SetTime = SetFileTime(hFile, ft, ByVal 0&, ByVal 0&)
         Case ftLastAccessTime
            SetTime = SetFileTime(hFile, ByVal 0&, ft, ByVal 0&)
         Case ftLastWriteTime
            SetTime = SetFileTime(hFile, ByVal 0&, ByVal 0&, ft)
      End Select
      Call CloseHandle(hFile)
   End If
End Function

Private Function ProperCasePath(ByVal PathIn As String) As String
   Dim hSearch As Long
   Dim wfd As WIN32_FIND_DATA
   Dim PathOut As String
   Dim i As Long
   '
   ' Trim trailing backslash, unless root dir.
   '
   If Right(PathIn, 1) = "\" Then
      If Right(PathIn, 2) <> ":\" Then
         PathIn = Left(PathIn, Len(PathIn) - 1)
      Else
         ProperCasePath = UCase(PathIn)
         Exit Function
      End If
   End If
   '
   ' Check for UNC share and return just that,
   ' if that's all that's left of PathIn.
   '
   If InStr(PathIn, "\\") = 1 Then
      i = InStr(3, PathIn, "\")
      If i > 0 Then
         If InStr(i + 1, PathIn, "\") = 0 Then
            ProperCasePath = PathIn
            Exit Function
         End If
      End If
   End If
   '
   ' Insure that path portion of string uses the
   ' same case as the real pathname.
   '
   If InStr(PathIn, "\") Then
      For i = Len(PathIn) To 1 Step -1
         If Mid(PathIn, i, 1) = "\" Then
            '
            ' Found end of previous directory.
            ' Recurse back up into path.
            '
            PathOut = ProperCasePath(Left(PathIn, i - 1)) & "\"
            '
            ' Use FFF to proper-case current directory.
            '
            hSearch = FindFirstFile(PathIn, wfd)
            If hSearch <> INVALID_HANDLE_VALUE Then
               Call FindClose(hSearch)
               If wfd.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY Then
                  ProperCasePath = PathOut & TrimNull(wfd.cFileName)
               End If
            End If
            '
            ' Bail out of loop.
            '
            Exit For
         End If
      Next i
   Else
      '
      ' Just a drive letter and colon,
      ' upper-case and return.
      '
      ProperCasePath = UCase(PathIn)
   End If
End Function

Private Function TrimNull(ByVal StrIn As String) As String
   Dim nul As Long
   '
   ' Truncate input string at first null.
   ' If no nulls, perform ordinary Trim.
   '
   nul = InStr(StrIn, vbNullChar)
   Select Case nul
      Case Is > 1
         TrimNull = Left(StrIn, nul - 1)
      Case 1
         TrimNull = ""
      Case 0
         TrimNull = Trim(StrIn)
   End Select
End Function