' 發展單位：水海科技系統研發驗證工作室
' 撰寫人：鄭子璉(Tzu-Lien, Cheng, 璉璉) ，成大水利博士候選人，微軟最有價值專家
' Web: http://tlcheng.no-ip.com/TLCheng/ E-Mail: qvb3377@ms5.hinet.net
' --------------------------------------------------------------------------------------

Private Declare Function CloseFile Lib "kernel32" Alias "_lclose" (ByVal hFile 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 GetFullPathName Lib "kernel32" Alias "GetFullPathNameA" (ByVal lpFileName As String, ByVal nBufferLength As Long, ByVal lpBuffer As String, ByVal lpFilePart As String) As Long
Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long
Private Declare Function GetFileInformationByHandle Lib "kernel32" (ByVal hFile As Long, lpFileInformation As BY_HANDLE_FILE_INFORMATION) As Long
Private Declare Function GetVolumeInformation Lib "kernel32" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Any, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize 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 GetFileSize Lib "kernel32" (ByVal hFile As Long, lpFileSizeHigh As Long) As Long
Private Declare Function GetFileType Lib "kernel32" (ByVal hFile As Long) As Long
Private Declare Function LocalFileTimeToFileTime Lib "kernel32" (lpLocalFileTime As Any, lpFileTime As Any) As Long
Private Declare Function OpenFile Lib "kernel32" (ByVal lpFileName As String, lpReOpenBuff As OFSTRUCT, ByVal wStyle As Long) As Long
Private Declare Function SearchPath Lib "kernel32" Alias "SearchPathA" (ByVal lpPath As String, ByVal lpFileName As String, ByVal lpExtension As String, ByVal nBufferLength As Long, ByVal lpBuffer As String, ByVal lpFilePart As String) As Long
Private Declare Function SetFileTime Lib "kernel32" (ByVal hFile As Long, lpCreationTime As FILETIME, lpLastAccessTime As FILETIME, lpLastWriteTime As FILETIME) As Long
Private Declare Function SystemTimeToFileTime Lib "kernel32" (lpSystemTime As SYSTEMTIME, lpFileTime As FILETIME) As Long

' 磁碟空間
Private Declare Function GetDiskFreeSpaceEx Lib "kernel32" Alias "GetDiskFreeSpaceExA" (ByVal lpRootPathName As String, lpFreeBytesAvailableToCaller As typLong64, lpTotalNumberOfBytes As typLong64, lpTotalNumberOfFreeBytes As typLong64) As Long

Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, Optional ByVal lpOverlapped As Long = 0) As Long
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, Optional ByVal lpOverlapped As Long = 0) As Long

' Shell
Private Declare Function PathRemoveFileSpec Lib "shlwapi" Alias "PathRemoveFileSpecA" (ByVal pszPath As String) As Long

' 記憶體
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)

Public Const MAX_PATH = 260

Public Type FILETIME
   dwLowDateTime As Long
   dwHighDateTime As Long
End Type

Private Type DWord
   High As Long
   Low As Long
End Type

Private Type typ_Integer_Word
   High As Integer
   Low As Integer
End Type

Public 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 BY_HANDLE_FILE_INFORMATION
   dwFileAttributes As Long
   ftCreationTime As FILETIME
   ftLastAccessTime As FILETIME
   ftLastWriteTime As FILETIME
   dwVolumeSerialNumber As Long
   nFileSizeHigh As Long
   nFileSizeLow As Long
   nNumberOfLinks As Long
   nFileIndexHigh As Long
   nFileIndexLow 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 OFS_MAXPATHNAME = 128
Private Const OF_READ = &H0
Private Const HFILE_ERROR = &HFFFF
Private Const OF_READWRITE = &H2
Private Const OF_WRITE = &H1

Public 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 typLong64
   Low As Long
   High As Long
End Type

Public Enum enuDiskFreeSpace
   dfs_FreeBytes = 0
   dfs_TotalBytes = 1
   dfs_TotalFreeBytes = 2
End Enum

' 供 Win32_Find_Data 使用
Public Enum enuWin32FindData
   WFD_FileName = 0
   WFD_FileSize = 1
   WFD_LastWriteTime = 2
   WFD_CreationTime = 3
   WFD_LastAccessTime = 4
   WFD_FileAttributes = 5 ' 檔案屬性
   WFD_Reserved = 6
   WFD_Alternate = 7  ' 短檔名
   WFD_All = &H80000000
End Enum

Private cdlDefaultPath As String
Private Const BufferString = 256

Private Const rDayZeroBias As Double = 109205#   
Private Const rMillisecondPerDay As Double = 10000000# * 60# * 60# * 24# / 10000#

Public Enum enuNoGetData
   Default = 0
   No_Common = 1
   No_Null_Line = 2
End Enum

Public Function GetWin32FindDataValue(lpWFD As WIN32_FIND_DATA, Optional ByVal dwFlags As enuWin32FindData = WFD_FileName)

With lpWFD
   Select Case dwFlags
   Case WFD_FileName
      vTempValue = Left(.cFileName, InStr(.cFileName, Chr(0)) - 1)
   Case WFD_FileSize
      vTempValue = CDec(.nFileSizeHigh) * CDec(2 ^ 32) + CDec(.nFileSizeLow)
   Case WFD_LastWriteTime
      vTempValue = Win32FileTimeToVB(.ftLastWriteTime)
   Case WFD_CreationTime
      vTempValue = Win32FileTimeToVB(.ftCreationTime)
   Case WFD_LastAccessTime
      vTempValue = Win32FileTimeToVB(.ftLastAccessTime)
   Case WFD_FileAttributes
      vTempValue = .dwFileAttributes
   Case WFD_Reserved
      vTempValue = CDec(.dwReserved0) * CDec(2 ^ 32) + CDec(.dwReserved1)
   Case WFD_Alternate
      vTempValue = Left(.cAlternate, InStr(.cAlternate, Chr(0)) - 1)
   Case WFD_All
      ReDim arrValue(WFD_Alternate)
      
      arrValue(WFD_FileName) = Left(.cFileName, InStr(.cFileName, Chr(0)) - 1)
      arrValue(WFD_FileSize) = CDec(.nFileSizeHigh) * CDec(2 ^ 32) + CDec(.nFileSizeLow)
      arrValue(WFD_LastWriteTime) = Win32FileTimeToVB(.ftLastWriteTime)
      arrValue(WFD_CreationTime) = Win32FileTimeToVB(.ftCreationTime)
      arrValue(WFD_LastAccessTime) = Win32FileTimeToVB(.ftLastAccessTime)
      arrValue(WFD_FileAttributes) = .dwFileAttributes
      arrValue(WFD_Reserved) = CDec(.dwReserved0) * CDec(2 ^ 32) + CDec(.dwReserved1)
      arrValue(WFD_Alternate) = Left(.cAlternate, InStr(.cAlternate, Chr(0)) - 1)
      
      vTempValue = arrValue
   End Select
End With

GetWin32FindDataValue = vTempValue

End Function

Public Function mySetFileTime(ByVal lpFileName As String, Optional hDate As Date) As Date

Dim inof As OFSTRUCT
Dim lpCreationTime As FILETIME, lpLastAccessTime As FILETIME, lpLastWriteTime As FILETIME
Dim fh As Long
Dim tDate As Date

tDate = FileDateTime(lpFileName)

If Not IsMissing(hDate) Then
   fh = OpenFile(lpFileName, inof, OF_READWRITE)
   GetFileTime fh, lpCreationTime, lpLastAccessTime, lpLastWriteTime
   
   lpLastWriteTime = VBToWin32FileTime(hDate)
   
   SetFileTime fh, lpLastWriteTime, lpLastAccessTime, lpLastWriteTime
   CloseFile fh
End If

mySetFileTime = tDate

End Function

Public Function Win32FileTimeToVB(hFileTime As FILETIME) As Date

Dim ftl As Currency, ft As FILETIME

FileTimeToLocalFileTime hFileTime, ft
CopyMemory ftl, ft, Len(ft)

Win32FileTimeToVB = CDate((ftl / rMillisecondPerDay) - rDayZeroBias)

End Function

Public Function VBToWin32FileTime(hDate As Date) As FILETIME

Dim hft As Currency

hft = (CCur(hDate) + rDayZeroBias) * rMillisecondPerDay

LocalFileTimeToFileTime hft, VBToWin32FileTime

End Function

Public Function myGetDiskFreeSpace(ByVal lpRootPathName As String, Optional ByVal dwFlags As enuDiskFreeSpace = dfs_FreeBytes)

Dim lpFreeBytesAvailableToCaller As typLong64, lpTotalNumberOfBytes As typLong64, lpTotalNumberOfFreeBytes As typLong64
summy = GetDiskFreeSpaceEx(lpRootPathName, lpFreeBytesAvailableToCaller, lpTotalNumberOfBytes, lpTotalNumberOfFreeBytes)

Select Case dwFlags
Case Is = dfs_FreeBytes
   tdfs = CLong64(lpFreeBytesAvailableToCaller)
Case Is = dfs_TotalBytes
   tdfs = CLong64(lpTotalNumberOfBytes)
Case Is = dfs_TotalFreeBytes
   tdfs = CLong64(lpTotalNumberOfFreeBytes)
End Select

myGetDiskFreeSpace = tdfs

End Function

Private Function CLong64(hLong64 As typLong64)
       
With hLong64
   If .Low < 0 Then
      tLow = 2 ^ 32 + .Low
   Else
      tLow = .Low
   End If

   If .High < 0 Then
      tHigh = 2 ^ 32 + .High
   Else
      tHigh = .High
   End If
End With

CLong64 = tLow + tHigh * 2 ^ 32
       
End Function

Public Function myGetSingleFileName(ByVal lpFullFilename As String) As String

tLoc = 0
Do
   i = InStr(tLoc + 1, lpFullFilename, "\")
   If i = 0 Then
      Exit Do
   Else
      tLoc = i
   End If
Loop

myGetSingleFileName = Mid(lpFullFilename, tLoc + 1)

End Function

Public Function myGetPath(ByVal lpFileName As String) As String

tLoc = 0
Do
   i = InStr(tLoc + 1, lpFileName, "\")
   If i = 0 Then
      Exit Do
   Else
      tLoc = i
   End If
Loop

If tLoc = 0 Then
   myGetPath = ""
Else
   myGetPath = Left(lpFileName, tLoc - 1)
End If

End Function

Public Function myGetSerialNumber(Optional ByVal hDriver As String = "C:\") As String

Dim lpVolumeNameBuffer As String, lpFileSystemNameBuffer As String
Dim lpVolumeSerialNumber As typ_Integer_Word

nVolumeNameSize = 32
lpVolumeNameBuffer = String(nVolumeNameSize, 0)

nFileSystemNameSize = 8
lpFileSystemNameBuffer = String(nFileSystemNameSize, 0)

If Len(hDriver) = 1 Then
   hDriver = hDriver + ":\"
End If

summy = GetVolumeInformation(hDriver, lpVolumeNameBuffer, nVolumeNameSize, lpVolumeSerialNumber, lpMaximumComponentLength, lpFileSystemFlags, lpFileSystemNameBuffer, nFileSystemNameSize)
myGetSerialNumber = VariantToHex(lpVolumeSerialNumber.Low) + "-" + VariantToHex(lpVolumeSerialNumber.High)

End Function

Public Function mySetAllFileTime(ByVal hPath As String, hDate As Date, Optional ByVal SearchSub As Boolean = False) As Long

If Right(hPath, 1) <> "\" Then
   tPath = hPath + "\"
Else
   tPath = hPath
End If

tFile = myDir(tPath, vbNormal + vbReadOnly + vbSystem + vbHidden, SearchSub)

If tFile(1) = "" Then
   Exit Function
End If

lb = LBound(tFile)
ub = UBound(tFile)
nb = ub - lb + 1

For i = lb To ub
   mySetFileTime tPath + tFile(i), hDate
Next i

mySetAllFileTime = nb

End Function

Public Function myDir(ByVal hPath As String, Optional Attributes As VbFileAttribute = vbNormal, Optional ByVal SearchSub As Boolean = False)

summy = BackInStr(hPath, "\")
If summy > 0 Then
   myDirPath = Mid(hPath, 1, summy)
   myDirExt = Mid(hPath, summy)
Else
   myDirPath = hPath
   myDirExt = vbNullString
End If

Dim tmpStr()

tFile = Dir(hPath, Attributes)

TotalLine = 0
Do Until tFile = ""
   
   If tFile <> "." And tFile <> ".." Then
      TotalLine = TotalLine + 1
      ReDim Preserve tmpStr(1 To TotalLine)
      
      tmpStr(TotalLine) = tFile
   End If
   tFile = Dir
Loop

If TotalLine > 0 Then
   lb = LBound(tmpStr)
   ub = UBound(tmpStr)

' 逐個傳回值檢查, 如為目錄屬性, 遞迴呼叫本函數
   For i = ub To lb Step -1
       If GetAttr(myDirPath + tmpStr(i)) = vbDirectory Then
         tmpDir = myDir(myDirPath + tmpStr(i) + "\", Attributes)
      
         If tmpDir(1) <> vbNullString Then
            lbd = LBound(tmpDir)
            ubd = UBound(tmpDir)
            nbd = ubd - lbd + 1
      
            ReDim Preserve tmpStr(1 To TotalLine + nbd)
      
            For j = lbd To ubd
               tmpStr(TotalLine + j - lbd + 1) = tmpStr(i) + "\" + tmpDir(j)
            Next j
            
            TotalLine = TotalLine + nbd
         End If
      
      End If
   Next i
End If

If SearchSub And myDirExt <> vbNullString Then
   tSub = myDirSub(myDirPath)
      
   For i = LBound(tSub) To UBound(tSub)
   
      tmpDir = myDir(myDirPath + tSub(i) + myDirExt, Attributes)
      
      If tmpDir(1) <> vbNullString Then
         lbd = LBound(tmpDir)
         ubd = UBound(tmpDir)
         nbd = ubd - lbd + 1
      
         ReDim Preserve tmpStr(1 To TotalLine + nbd)
      
         For j = lbd To ubd
            tmpStr(TotalLine + j - lbd + 1) = tSub(i) + "\" + tmpDir(j)
         Next j
            
         TotalLine = TotalLine + nbd
      End If
   Next i

End If

If TotalLine = 0 Then
   TotalLine = 1
   ReDim Preserve tmpStr(1 To TotalLine)
   tmpStr(TotalLine) = vbNullString
End If


myDir = tmpStr

End Function

Public Function myDirSub(ByVal hPath As String)

Dim tmpStr()
Attributes = vbDirectory + vbHidden + vbSystem

If Right(hPath, 1) <> "\" Then
   hPath = hPath + "\"
End If

tFile = Dir(hPath, Attributes)

TotalLine = 0
Do Until tFile = ""
   If tFile <> "." And tFile <> ".." Then
      If GetAttr(hPath + tFile) = vbDirectory Then

         TotalLine = TotalLine + 1
         ReDim Preserve tmpStr(1 To TotalLine)
      
         tmpStr(TotalLine) = tFile
      End If
   End If
   tFile = Dir
Loop

If TotalLine > 0 Then
   lb = LBound(tmpStr)
   ub = UBound(tmpStr)

' 逐個傳回值檢查, 如為目錄屬性, 遞迴呼叫本函數
   For i = ub To lb Step -1
      If GetAttr(hPath + tmpStr(i)) = vbDirectory Then
         tmpDir = myDirSub(hPath + tmpStr(i) + "\")
      
         If tmpDir(1) <> vbNullString Then
            lbd = LBound(tmpDir)
            ubd = UBound(tmpDir)
            nbd = ubd - lbd + 1
      
            ReDim Preserve tmpStr(1 To TotalLine + nbd)
      
            For j = lbd To ubd
               tmpStr(TotalLine + j - lbd + 1) = tmpStr(i) + "\" + tmpDir(j)
            Next j
            
            TotalLine = TotalLine + nbd
         End If
      
      End If
   Next i
Else
   TotalLine = 1
   ReDim Preserve tmpStr(1 To TotalLine)
   tmpStr(TotalLine) = vbNullString
End If

myDirSub = tmpStr

End Function

Public Function GetFileLine(ByVal hFile As String, Optional ByVal NoNullString As Boolean = True)

Dim FileBuffer As String
Dim i As Long, tLine As Long, tLoc As Long, tLen As Long

FileBuffer = myGetBinaryFile(hFile)

tLen = Len(vbNewLine)
tLine = 0
i = 1
Do
   tLoc = InStr(i, FileBuffer, vbNewLine)
   If tLoc = 0 Then
      Exit Do
   Else
      If NoNullString And i = tLoc Then
      Else
         tLine = tLine + 1
      End If
      
      i = tLoc + tLen
   End If
Loop

GetFileLine = tLine

End Function

Public Function myGetMultiLineFile(ByVal lpFileName As String, Optional ByVal wFlags As enuNoGetData = Default, Optional ByVal nCodePage As enuCodePage = CP_Big5)

ReDim tBuffer(1 To 1)
Dim tMutiLine As String
Dim tLoc As Long, TotalLine As Long, tLen As Long

tLen = Len(vbNewLine)

tMutiLine = myGetStringBinaryFile(lpFileName, nCodePage)

i = 1
TotalLine = 0
Do
   bAdd = False
   tLoc = InStr(i, tMutiLine, vbNewLine)
   If tLoc <> 0 Then
      tBufferLine = Mid(tMutiLine, i, tLoc - i)
      Select Case wFlags
      Case Default
         bAdd = True
      Case No_Null_Line
         If Trim(tBufferLine) <> "" Then
            bAdd = True
         End If
      End Select
      
      If bAdd Then
         TotalLine = TotalLine + 1
         ReDim Preserve tBuffer(1 To TotalLine)
         tBuffer(TotalLine) = tBufferLine
      End If
      i = tLoc + tLen
   Else
      If i < Len(tMutiLine) Then
         tBufferLine = Mid(tMutiLine, i)
         Select Case wFlags
         Case Default
            bAdd = True
         Case No_NullSpace
            If Trim(tBufferLine) <> "" Then
               bAdd = True
            End If
         End Select
         
         If bAdd Then
            TotalLine = TotalLine + 1
            ReDim Preserve tBuffer(1 To TotalLine)
            tBuffer(TotalLine) = tBufferLine
         End If
      End If
      Exit Do
   End If
Loop

myGetMultiLineFile = tBuffer

End Function

Public Function myGetBinaryFile(ByVal lpFileName As String, Optional hFileSeek As Long = 1, Optional GetLen As Long = 0) As Variant

Dim FileBuffer() As Byte

fLen = FileLen(lpFileName)
If GetLen > 0 Then
   fLen = fLen - hFileSeek + 1
   If fLen > GetLen Then
      fLen = GetLen
   End If
End If

ReDim FileBuffer(1 To fLen) As Byte

hFile = FreeFile
Open lpFileName For Binary As hFile
Get #hFile, hFileSeek, FileBuffer
Close hFile

myGetBinaryFile = FileBuffer

End Function

Public Function myGetStringBinaryFile(ByVal lpFilename As String, Optional ByVal nCodePage As enuCodePage = CP_Big5) As String
   Dim FileBuffer As String
   Dim arrBytes() As Byte

   FileBuffer = myGetBinaryFile(lpFilename)
   
   Select Case nCodePage
   Case CP_Unicode
      FileBuffer = FileBuffer
   Case CP_Big5
      FileBuffer = StrConv(FileBuffer, vbUnicode)
   Case Else
      FileBuffer = myMultiByteToWideChar(FileBuffer, nCodePage)
   End Select

   If Left(FileBuffer, 1) = ChrW(&HFEFF) Then
      FileBuffer = Mid(FileBuffer, 2)
   End If
   
   myGetStringBinaryFile = FileBuffer
End Function

Public Function myMkDir(ByVal hPath As String)

myMkDir = True
If Right(hPath, 1) = "\" Then
   hPath = Left(hPath, Len(hPath) - 1)
End If

IsExist = (Dir(hPath, vbDirectory) <> "")
If IsExist Then
   Exit Function
Else
   tLoc = 0
   Do
      i = InStr(tLoc + 1, hPath, "\")
      If i = 0 Then
         Exit Do
      Else
         tLoc = i
      End If
   Loop

   IsSuccess = myMkDir(Left(hPath, tLoc - 1))
   
   If IsSuccess Then
      On Error Resume Next
      MkDir hPath
   
      If Err.Number <> 0 Then
         myMkDir = False
      End If
   
      On Error GoTo 0
   End If
End If

End Function