home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 7_2009-2012.ISO / data / zips / read_and_w217231192010.psc / CREATION / DOMAINS / CodeSection / GFFileAccess / GFFileAccessmod.bas < prev    next >
BASIC Source File  |  2004-03-16  |  8KB  |  177 lines
  1. Attribute VB_Name = "GFFileAccessmod"
  2. Option Explicit
  3. '(c)2001, 2004 by Louis. Functions for FAST (!) file access.
  4. 'GFFileAccess_GetDirFileSizeTotal
  5. Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
  6. Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
  7. Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
  8. 'Get[Total/Avail]DiskSpace (source: drvspace.zip)
  9. Private Declare Function GetDiskFreeSpace Lib "kernel32.dll" Alias "GetDiskFreeSpaceA" (ByVal lpRootPathName As String, lpClusterSectorNumber As Long, lpSectorByteNumber As Long, lpNumberOfFreeClusters As Long, lpTotalNumberOfClusters As Long) As Long
  10. Private Declare Function GetDiskFreeSpaceEx Lib "kernel32.dll" Alias "GetDiskFreeSpaceExA" (ByVal lpDirectoryName As String, lpFreeBytesAvailableToCaller As ULARGE_INTEGER, lpTotalNumberOfBytes As ULARGE_INTEGER, lpTotalNumberOfFreeBytes As ULARGE_INTEGER) As Long
  11. Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
  12. 'GFFileAccess_GetDirFileSizeTotal
  13. Private Const MAX_PATH = 260
  14. 'GFFileAccess_GetDirFileSizeTotal
  15. Private Type FILETIME
  16.     dwLowDateTime As Long
  17.     dwHighDateTime As Long
  18. End Type
  19. 'GFFileAccess_GetDirFileSizeTotal
  20. Private Type WIN32_FIND_DATA
  21.     dwFileAttributes As Long
  22.     ftCreationTime As FILETIME
  23.     ftLastAccessTime As FILETIME
  24.     ftLastWriteTime As FILETIME
  25.     nFileSizeHigh As Long
  26.     nFileSizeLow As Long
  27.     dwReserved0 As Long
  28.     dwReserved1 As Long
  29.     cFileName As String * MAX_PATH
  30.     cAlternate As String * 14
  31. End Type
  32. 'GFFileAccess_Get[Free/Total]DiskSpace
  33. Private Type ULARGE_INTEGER
  34.     LowPart As Long
  35.     HighPart As Long
  36. End Type
  37.  
  38. Public Function GFFileAccess_GetDirFileSizeTotal(ByVal DirectoryName As String, ByVal Pattern As String) As Double
  39.     'on error resume next 'returns total file size of all files matching the passed search pattern or -1 for error
  40.     Dim FindFileHandle As Long
  41.     Dim FileSizeTotal As Double
  42.     Dim WIN32_FIND_DATAVar As WIN32_FIND_DATA
  43.     '
  44.     'NOTE: this function is bloody fast, in tests it needed less that 2 seconds
  45.     'on an Athlon 800 to get the total size of 31.461 mp3 files.
  46.     '
  47.     'verify
  48.     If Dir(DirectoryName, vbDirectory) = "" Then
  49.         GFFileAccess_GetDirFileSizeTotal = (-1#) 'error
  50.         Exit Function
  51.     End If
  52.     If Not (Right$(DirectoryName, 1) = "\") Then DirectoryName = DirectoryName + "\"
  53.     'begin
  54.     FindFileHandle = FindFirstFile(DirectoryName + Pattern, WIN32_FIND_DATAVar)
  55.     If FindFileHandle > 0& Then
  56. ReDo:
  57.         FileSizeTotal = FileSizeTotal + CDbl(WIN32_FIND_DATAVar.nFileSizeLow)
  58.         If FindNextFile(FindFileHandle, WIN32_FIND_DATAVar) > 0& Then GoTo ReDo:
  59.         Call FindClose(FindFileHandle)
  60.         GFFileAccess_GetDirFileSizeTotal = FileSizeTotal 'ok
  61.         Exit Function
  62.     Else
  63.         GFFileAccess_GetDirFileSizeTotal = (-1#) 'error
  64.         Exit Function
  65.     End If
  66. End Function
  67.  
  68. 'NOTE: GFFileAccess_IsFileExisting() requires Attributes to be passed, DirSave() doesn't.
  69.  
  70. Public Function GFFileAccess_IsFileExisting(ByVal DirectoryName As String, ByVal Pattern As String) As Boolean
  71.     'on error resume next 'returns True if directory contains files that match the pattern, False if not
  72.     Dim FindFileHandle As Long
  73.     Dim WIN32_FIND_DATAVar As WIN32_FIND_DATA
  74.     '
  75.     'NOTE: use this function if it must be determinated if a large amount
  76.     'of directories contain files of a special type (pattern).
  77.     'Directory must exist and must be back-slash terminated.
  78.     '
  79.     'begin
  80.     FindFileHandle = FindFirstFile(DirectoryName + Pattern, WIN32_FIND_DATAVar)
  81.     GFFileAccess_IsFileExisting = (FindFileHandle > 0&)
  82.     Call FindClose(FindFileHandle)
  83. End Function
  84.  
  85. Public Function GFFileAccess_DirSave(ByVal PathName As String, ByVal Attributes As Integer) As String
  86.     On Error GoTo Error: 'important
  87.     '
  88.     'NOTE: Dir() raises an error if PathName represents a cdrom drive
  89.     'and the cd is not inserted (damn VB!). Use this function rather than Dir().
  90.     '
  91.     GFFileAccess_DirSave = Dir(PathName, Attributes) 'ok
  92.     Exit Function
  93. Error:
  94.     GFFileAccess_DirSave = "" 'error
  95.     Exit Function
  96. End Function
  97.  
  98. Public Function DirSave(ByVal PathName As String, Optional ByVal Attributes As Integer = vbNormal) As String
  99.     On Error GoTo Error: 'important
  100.     '
  101.     'NOTE: Dir() raises an error if PathName represents a cdrom drive
  102.     'and the cd is not inserted (damn VB!). Use this function rather than Dir().
  103.     '
  104.     DirSave = Dir(PathName, Attributes) 'ok
  105.     Exit Function
  106. Error:
  107.     DirSave = "" 'error
  108.     Exit Function
  109. End Function
  110.  
  111. Public Function GetAttrSave(ByRef PathName As String) As VbFileAttribute
  112.     On Error GoTo Error: 'important
  113.     '
  114.     'NOTE: GetAttr() raises an error if PathName is a cdrom drive
  115.     'with no cd inserted. Use GetAttrSave() instead of GetAttr() if
  116.     'PathName could be a cdrom drive.
  117.     '
  118.     GetAttrSave = GetAttr(PathName)
  119.     Exit Function
  120. Error:
  121.     GetAttrSave = vbNormal
  122.     Exit Function
  123. End Function
  124.     
  125. '***DISK SPACE FUNCTIONS***
  126. 'NOTE: the following two functions are to be used to dterminate the free or total space available on a special drive.
  127. 'The two functions were created out of the Noname99 functions GetAvailableDiskSpace() and GetTotalDiskSpace().
  128. 'The two functions use the API functions GetDiskFreeSpace() and GetDiskFreeSpaceEx().
  129. 'The largest detrminable size using GetDiskFreeSpace() is 2 GB, from Win95 OSR 2 on GetDiskFreeSpaceEx()
  130. 'can be used to retreive sizes above 2 GB.
  131. 'Code was partially taken from http://www.vbapi.com/ref/g/getdiskfreespaceex.html (03.02.2002).
  132.  
  133. Public Function GFFileAccess_GetFreeDiskSpace(ByVal DiskName As String) As Double
  134.     On Error GoTo Error: 'important; returns free disk space in bytes
  135.     Dim BytesFreeToUser As ULARGE_INTEGER
  136.     Dim BytesTotal As ULARGE_INTEGER
  137.     Dim BytesFree As ULARGE_INTEGER
  138.     Dim TempCurrency As Currency
  139.     Dim Temp As Long
  140.     'begin
  141.     Call GetDiskFreeSpaceEx(DiskName, BytesFreeToUser, BytesTotal, BytesFree)
  142.     Call CopyMemory(TempCurrency, BytesFreeToUser, 8) 'taken from http://www.vbapi.com/ref/g/getdiskfreespaceex.html
  143.     GFFileAccess_GetFreeDiskSpace = CDbl(TempCurrency * 10000@)
  144.     Exit Function
  145. Error: 'on Win95 OSR 1
  146.     Dim ClusterSectorNumber As Long
  147.     Dim SectorByteNumber As Long
  148.     Dim ClusterNumberFree As Long
  149.     Dim ClusterNumberTotal As Long
  150.     Call GetDiskFreeSpace(DiskName, ClusterSectorNumber, SectorByteNumber, ClusterNumberFree, ClusterNumberTotal)
  151.     GFFileAccess_GetFreeDiskSpace = CDbl(ClusterSectorNumber) * CDbl(SectorByteNumber) * CDbl(ClusterNumberFree)
  152.     Exit Function
  153. End Function
  154.  
  155. Public Function GFFileAccess_GetTotalDiskSpace(ByVal DiskName As String) As Double
  156.     On Error GoTo Error: 'important; returns total disk space in bytes
  157.     Dim BytesFreeToUser As ULARGE_INTEGER
  158.     Dim BytesTotal As ULARGE_INTEGER
  159.     Dim BytesFree As ULARGE_INTEGER
  160.     Dim TempCurrency As Currency
  161.     Dim Temp As Long
  162.     'begin
  163.     Call GetDiskFreeSpaceEx(DiskName, BytesFreeToUser, BytesTotal, BytesFree)
  164.     Call CopyMemory(TempCurrency, BytesTotal, 8) 'taken from http://www.vbapi.com/ref/g/getdiskfreespaceex.html
  165.     GFFileAccess_GetTotalDiskSpace = CDbl(TempCurrency * 10000@)
  166.     Exit Function
  167. Error: 'on Win95 OSR 1
  168.     Dim ClusterSectorNumber As Long
  169.     Dim SectorByteNumber As Long
  170.     Dim ClusterNumberFree As Long
  171.     Dim ClusterNumberTotal As Long
  172.     Call GetDiskFreeSpace(DiskName, ClusterSectorNumber, SectorByteNumber, ClusterNumberFree, ClusterNumberTotal)
  173.     GFFileAccess_GetTotalDiskSpace = CDbl(ClusterSectorNumber) * CDbl(SectorByteNumber) * CDbl(ClusterNumberTotal)
  174.     Exit Function
  175. End Function
  176.  
  177.