Planet Source Code Jumbo …e CD Visual Basic 1 to 7/1_2002.ISO/Data/Zips/CODE_UPLOAD88928122000.psc/CFileInfo.cls

Visual Basic class definition | 2000-05-17 | 16.9 KB | 536 lines

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "CFileInfo"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
' *********************************************************************
'  Copyright (C)1995-98 Karl E. Peterson, All Rights Reserved
'  http://www.mvps.org/vb
' *********************************************************************
'  Warning: This computer program is protected by copyright law and
'  international treaties. Unauthorized reproduction or distribution
'  of this program, or any portion of it, may result in severe civil
'  and criminal penalties, and will be prosecuted to the maximum
'  extent possible under the law.
' *********************************************************************
Option Explicit
'
' API declarations
'
Private Declare Function GetFullPathName Lib "kernel32" Alias "GetFullPathNameA" (ByVal lpFileName As String, ByVal nBufferLength As Long, ByVal lpBuffer As String, lpFilePart As Long) As Long
Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal nBufferLength As Long) As Long
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Private Declare Function FileTimeToLocalFileTime Lib "kernel32" (lpFileTime As FILETIME, lpLocalFileTime As FILETIME) As Long
Private Declare Function FileTimeToSystemTime Lib "kernel32" (lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long
Private Declare Function GetCompressedFileSize Lib "kernel32" Alias "GetCompressedFileSizeA" (ByVal lpFileName As String, lpFileSizeHigh As Long) As Long
Private Declare Function SHGetFileInfo Lib "shell32.dll" Alias "SHGetFileInfoA" (ByVal pszPath As String, ByVal dwFileAttributes As Long, psfi As SHFILEINFO, ByVal cbFileInfo As Long, ByVal uFlags As Long) As Long
'
' API constants.
'
Private Const MAX_PATH = 260
Private Const INVALID_HANDLE_VALUE = -1
'
' File attribute constants.
'
Private Const FILE_ATTRIBUTE_READONLY = &H1
Private Const FILE_ATTRIBUTE_HIDDEN = &H2
Private Const FILE_ATTRIBUTE_SYSTEM = &H4
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
Private Const FILE_ATTRIBUTE_ARCHIVE = &H20
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const FILE_ATTRIBUTE_TEMPORARY = &H100
Private Const FILE_ATTRIBUTE_COMPRESSED = &H800
'
' SHGetFileInfo constants.
'
Private Const SHGFI_ICON = &H100                         '  get icon
Private Const SHGFI_DISPLAYNAME = &H200                  '  get display name
Private Const SHGFI_TYPENAME = &H400                     '  get type name
Private Const SHGFI_ATTRIBUTES = &H800                   '  get attributes
Private Const SHGFI_ICONLOCATION = &H1000                '  get icon location
Private Const SHGFI_EXETYPE = &H2000                     '  return exe type
Private Const SHGFI_SYSICONINDEX = &H4000                '  get system icon index
Private Const SHGFI_LINKOVERLAY = &H8000                 '  put a link overlay on icon
Private Const SHGFI_SELECTED = &H10000                   '  show icon in selected state
Private Const SHGFI_LARGEICON = &H0                      '  get large icon
Private Const SHGFI_SMALLICON = &H1                      '  get small icon
Private Const SHGFI_OPENICON = &H2                       '  get open icon
Private Const SHGFI_SHELLICONSIZE = &H4                  '  get shell size icon
Private Const SHGFI_PIDL = &H8                           '  pszPath is a pidl
Private Const SHGFI_USEFILEATTRIBUTES = &H10             '  use passed dwFileAttribute
'
' API structures.
'
Private Type FILETIME
   dwLowDateTime As Long
   dwHighDateTime As Long
End Type

Private Type WIN32_FIND_DATA
   dwFileAttributes As Long
   ftCreationTime As FILETIME
   ftLastAccessTime As FILETIME
   ftLastWriteTime As FILETIME
   nFileSizeHigh As Long
   nFileSizeLow As Long
   dwReserved0 As Long
   dwReserved1 As Long
   cFileName As String * MAX_PATH
   cAlternate As String * 14
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 Type SHFILEINFO
   hIcon As Long                       '  out: icon
   iIcon As Long                       '  out: icon index
   dwAttributes As Long                '  out: SFGAO_ flags
   szDisplayName As String * MAX_PATH  '  out: display name (or path)
   szTypeName As String * 80           '  out: type name
End Type
'
' Member variables.
'
Private m_PathName As String
Private m_Name As String
Private m_Path As String
Private m_Extension As String
Private m_DisplayName As String
Private m_TypeName As String
Private m_hIcon As Long
Private m_PathNameShort As String
Private m_NameShort As String
Private m_PathShort As String
Private m_FileExists As Boolean
Private m_PathExists As Boolean
Private m_FileSize As Long
Private m_FileSizeHigh As Long
Private m_CompFileSize As Long
Private m_CompFileSizeHigh As Long
Private m_Attributes As Long
Private m_tmCreation As Double
Private m_tmAccess As Double
Private m_tmWrite As Double

' ********************************************
'  Initialize and Terminate
' ********************************************
Private Sub Class_Initialize()
   '
   ' All member variables can be left to defaults.
   '
End Sub

Private Sub Class_Terminate()
   '
   ' No special cleanup required.
   '
End Sub

' ********************************************
'  Public Properties
' ********************************************
Public Property Let FullPathName(ByVal NewVal As String)
   Dim Buffer As String
   Dim nFilePart As Long
   Dim nRet As Long
   '
   ' Retrieve fully qualified path/name specs.
   '
   Buffer = Space(MAX_PATH)
   nRet = GetFullPathName(NewVal, Len(Buffer), Buffer, nFilePart)
   If nRet Then
      m_PathName = Left(Buffer, nRet)
      Refresh
   End If
End Property

Public Property Get FullPathName() As String
   ' Returns fully-qualified path/name spec.
   FullPathName = m_PathName
End Property

Public Property Get FileName() As String
   ' Returns filename only.
   FileName = m_Name
End Property

Public Property Get FilePath() As String
   ' Returns fully-qualified pathname only.
   FilePath = m_Path
End Property

Public Property Get FileExtension() As String
   ' Returns the file's extension only.
   FileExtension = m_Extension
End Property

Public Property Get ShortPathName() As String
   ' Returns fully-qualified *short* path/name spec.
   ShortPathName = m_PathNameShort
End Property

Public Property Get ShortName() As String
   ' Returns *short* filename only.
   ShortName = m_NameShort
End Property

Public Property Get ShortPath() As String
   ' Returns *short* fully-qualified pathname only.
   ShortPath = m_PathShort
End Property

Public Property Get DisplayName() As String
   ' Returns the "display" name for the file, not necessarily
   ' proper-cased, but as Explorer shows it.
   DisplayName = m_DisplayName
End Property

Public Property Get TypeName() As String
   ' Returns the string that describes the file's type.
   TypeName = m_TypeName
End Property

Public Property Get FileExists() As Boolean
   ' Returns whether file exists.
   FileExists = m_FileExists
End Property

Public Property Get PathExists() As Boolean
   ' Returns whether path exists.
   PathExists = m_PathExists
End Property

Public Property Get FileSize() As Long
   ' Return size of file.
   FileSize = m_FileSize
End Property

Public Property Get FileSizeHigh() As Long
   ' Returns high dword of filesize to support files > 2Gb.
   FileSizeHigh = m_FileSizeHigh
End Property

Public Property Get CompressedFileSize() As Long
   ' Return actual size of file.
   CompressedFileSize = m_CompFileSize
End Property

Public Property Get CompressedFileSizeHigh() As Long
   ' Returns high dword of actual filesize to support files > 2Gb.
   CompressedFileSizeHigh = m_CompFileSizeHigh
End Property

Public Property Get CreationTime() As Double
   ' Returns date/time of file creation.
   CreationTime = m_tmCreation
End Property

Public Property Get LastAccessTime() As Double
   ' Returns date/time of last access.
   LastAccessTime = m_tmAccess
End Property

Public Property Get ModifyTime() As Double
   ' Returns date/time of last write.
   ModifyTime = m_tmWrite
End Property

Public Property Get Attributes() As Long
   ' Returns entire set of attribute flags.
   Attributes = m_Attributes
End Property

Public Property Get attrReadOnly() As Boolean
   ' Returns whether file has ReadOnly attribute.
   attrReadOnly = (m_Attributes And FILE_ATTRIBUTE_READONLY)
End Property

Public Property Get attrHidden() As Boolean
   ' Returns whether file has Hidden attribute.
   attrHidden = (m_Attributes And FILE_ATTRIBUTE_HIDDEN)
End Property

Public Property Get attrSystem() As Boolean
   ' Returns whether file has System attribute.
   attrSystem = (m_Attributes And FILE_ATTRIBUTE_SYSTEM)
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 Get attrTemporary() As Boolean
   ' Returns whether file has Temporary attribute.
   attrTemporary = (m_Attributes And FILE_ATTRIBUTE_TEMPORARY)
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.
      '
      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
   End If
   FormatFileSize = sRet
End Function

' ********************************************
'  Private Methods
' ********************************************
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 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