modfileutil.bas

FloodEvaluation-程序是gis方面的程序

Attribute VB_Name = "modFileUtil"
Option Explicit

Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
         "GetOpenFileNameA" (pOPENFILENAME As OPENFILENAME) As Long
         
Private Type OPENFILENAME
  lStructSize As Long
  hwndOwner As Long
  hInstance As Long
  lpstrFilter As String
  lpstrCustomFilter As String
  nMaxCustFilter As Long
  nFilterIndex As Long
  lpstrFile As String
  nMaxFile As Long
  lpstrFileTitle As String
  nMaxFileTitle As Long
  lpstrInitialDir As String
  lpstrTitle As String
  FLAGS As Long
  nFileOffset As Integer
  nFileExtension As Integer
  lpstrDefExt As String
  lCustData As Long
  lpfnHook As Long
  lpTemplateName As String
End Type



Const OFN_ALLOWMULTISELECT = &H200
'Allow the user to select multiple files (Open File dialog box only).
Const OFN_CREATEPROMPT = &H2000
'Prompt if a non-existing file is chosen.
Const OFN_ENABLEHOOK = &H20
'Use the function specified by lpfnHook to process the dialog box's messages.
Const OFN_ENABLETEMPLATE = &H40
'Use the dialog box template specifed by hInstance and lpTemplateName.
Const OFN_ENABLETEMPLATEHANDLE = &H80
'Use the preloaded dialog box template specified by hInstance.
Const OFN_EXTENSIONDIFFERENT = &H400
'The function sets this flag if the user selects a file with an extension different than the one specified by lpstrDefExt.
Const OFN_FILEMUSTEXIST = &H1000
'Only allow the selection of existing files.
Const OFN_HIDEREADONLY = &H4
'Hide the Open As Read Only check box (Open File dialog box only).
Const OFN_NOCHANGEDIR = &H8
'Don 't change Windows's current directory to match the one chosen in the dialog box.
Const OFN_NODEREFERENCELINKS = &H100000
'If a shortcut file (.lnk or .pif) is chosen, return the shortcut file itself instead of the file or directory it points to.
Const OFN_NONETWORKBUTTON = &H20000
'Hide and disable the Network button in the dialog box.
Const OFN_NOREADONLYRETURN = &H8000
'The function sets this flag if the selected file is not read-only (Open File dialog box only).
Const OFN_NOVALIDATE = &H100
'Don 't check the filename for invalid characters.
Const OFN_OVERWRITEPROMPT = &H2
'Prompt the user if the chosen file already exists (Save File dialog box only).
Const OFN_PATHMUSTEXIST = &H800

Const OFN_READONLY = &H1

Const OFN_SHAREAWARE = &H4000
Const OFN_SHOWHELP = &H10


Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOPENFILENAME As OPENFILENAME) As Long
Public Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Public Declare Function FindNextFile Lib "kernel32.dll" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Declare Function FindClose Lib "kernel32.dll" (ByVal hFindFile As Long) As Long

Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
Private Declare Function SetEnvironmentVariable Lib "kernel32" Alias "SetEnvironmentVariableA" (ByVal lpName As String, ByVal lpValue As String) As Long
Private Declare Function EnableWindow Lib "user32" (ByVal hwnd As Long, ByVal fEnable As Long) As Long
Private Declare Function GetEnvironmentVariable Lib "kernel32" Alias "GetEnvironmentVariableA" (ByVal lpName As String, ByVal lpBuffer As String, ByVal nSize As Long) As Long
Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Public Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long
Public Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Public Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long

Type FILETIME
  dwLowDateTime As Long
  dwHighDateTime As Long
End Type

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 * 260
  cAlternate As String * 14
End Type

Public Function RemoveQuotes(ByVal sTempExp) As String
'   if there are quotes or double quotes around the passed in expression,
'   this function returns the expression without them.........

On Error GoTo RemoveQuotes_ERR
    sTempExp = Trim(sTempExp)
    RemoveQuotes = sTempExp
    If sTempExp <> Chr(34) And sTempExp <> Chr(39) Then
        If (Left(Trim(sTempExp), 1) = Chr(34) Or Left(Trim(sTempExp), 1) = Chr(39)) _
        Or (Right(Trim(sTempExp), 1) = Chr(34) Or Right(Trim(sTempExp), 1) = Chr(39)) Then
            
            If Left(Trim(sTempExp), 1) = Chr(34) Or Left(Trim(sTempExp), 1) = Chr(39) Then
                sTempExp = Mid(sTempExp, 2)
            End If
            
            If Right(Trim(sTempExp), 1) = Chr(34) Or Right(Trim(sTempExp), 1) = Chr(39) Then
                sTempExp = Mid(sTempExp, 1, Len(sTempExp) - 1)
            End If
            
            RemoveQuotes = sTempExp
        Else
            RemoveQuotes = sTempExp
        End If
    Else
        RemoveQuotes = ""
    End If

    Exit Function
    
RemoveQuotes_ERR:
    Debug.Assert 0
    Debug.Print "RemoveQuotes_ERR: " & err.Description


End Function


Private Function FileName(ByVal sFilePath As String, Optional bNoExtension As Boolean) As String
'returns the directory that the file in the path resides in:
'ie . returns "Temp.dbf" from "c:\temp\table.dbf"

Dim i As Integer
Dim s As String
Dim iBeg As Integer
Dim sName As String

On Error GoTo GetFileName_ERR

    sFilePath = modFileUtil.RemoveQuotes(sFilePath)
    For i = Len(sFilePath) To 1 Step -1
        s = Mid(sFilePath, i, 1)
    '   bail when when you get first backslash (s="\"):
        If s = "\" Then Exit For
    Next
    
    iBeg = i + 1
    
    If iBeg - 1 = Len(sFilePath) Then 'is a root dir
        sName = Left(sFilePath, 1)
    Else
        sName = Mid(sFilePath, iBeg)
    End If
    
    If bNoExtension Then
        If Len(sName) > 3 Then
    '   If there is an extension:
            If Mid(sName, Len(sName) - 3, 1) = "." Then
                If Len(sName) > 4 Then
                    FileName = Mid(sName, 1, Len(sName) - 4)
                Else
                    FileName = ""
                End If
            Else
                FileName = sName
            End If
        Else
    '   certainly no extension- filename is only 3 characters (ie. pat)
            FileName = sName
        End If
    Else
        FileName = sName
    End If
    

    Exit Function
    
    
GetFileName_ERR:
    Debug.Assert 0
    Debug.Print "GetFileName_ERR: " & err.Description
'   return the last thing we got:
    If Len(sName) > 0 Then
        FileName = sName
    Else
'   else pass back what we got in:
        FileName = sFilePath
    End If
    

End Function



Public Function GetFileToOpen(Optional sDefaultPath As String, Optional sFilter As String, Optional lOwnerHwnd, Optional bMultiSelect As Boolean) As String
Dim OpenFile As OPENFILENAME
Dim lReturn As Long
Dim s As String
Dim sInitFile As String
Dim sInitDir As String


On Error GoTo GetFileToOpen_ERR

    If Len(sDefaultPath) > 1 Then
        sInitDir = sDefaultPath
    End If
    
    OpenFile.lStructSize = Len(OpenFile)
    If Not IsMissing(lOwnerHwnd) Then
        OpenFile.hwndOwner = CLng(lOwnerHwnd)
    End If
    
    OpenFile.hInstance = App.hInstance
    OpenFile.lpstrFilter = sFilter
    OpenFile.nFilterIndex = 1
    OpenFile.lpstrFile = String(257, 0)
    OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1
    OpenFile.lpstrFileTitle = OpenFile.lpstrFile
    OpenFile.nMaxFileTitle = OpenFile.nMaxFile
    If Len(sInitDir) > 1 Then
        OpenFile.lpstrInitialDir = sInitDir
    Else
        OpenFile.lpstrInitialDir = CurDir()
    End If
    
    OpenFile.lpstrTitle = ""

    
    OpenFile.FLAGS = OFN_FILEMUSTEXIST
    If bMultiSelect Then OpenFile.FLAGS = OpenFile.FLAGS Or OFN_ALLOWMULTISELECT
    
    lReturn = GetOpenFileName(OpenFile)
    
    If lReturn = 0 Then
        GetFileToOpen = ""
    Else
        s = OpenFile.lpstrFile
        modFileUtil.ReturnWOEndNull s
        GetFileToOpen = s
    End If

    Exit Function

    
    Exit Function
    
GetFileToOpen_ERR:
    Debug.Assert 0
    Debug.Print "GetFileToOpen_ERR: " & err.Description
    Resume Next
    
    
End Function

Public Sub ReturnWOEndNull(ByRef sString As String)
Dim i As Integer
Dim s As String
'   return a string up to its terminating null character

On Error GoTo ReturnWOEndNull_ERR

    For i = 1 To Len(sString)
        s = Mid(sString, i, 1)
        If s = Chr(0) Then
            Exit For
        End If
    Next
        
    sString = Mid(sString, 1, i - 1)
    
    Exit Sub
    
ReturnWOEndNull_ERR:
    Debug.Assert 0
    Debug.Print "ReturnWOEndNull_ERR: " & err.Description
    

End Sub


Public Function GetFileToSave(Optional sDefaultPath As String, Optional sDefExtention As String, Optional sFilter As String, Optional lOwnerHwnd) As String
Dim OpenFile As OPENFILENAME
Dim lReturn As Long
Dim s As String
Dim sInitFile As String
Dim sInitDir As String


On Error GoTo GetPathToSave_ERR

    If Len(sDefaultPath) > 1 Then
        sInitDir = modFileUtil.FileDir(sInitFile)
    End If
    
    OpenFile.lStructSize = Len(OpenFile)
    If Not IsMissing(lOwnerHwnd) Then
        OpenFile.hwndOwner = CLng(lOwnerHwnd)
    End If
    
    OpenFile.hInstance = App.hInstance
    OpenFile.lpstrFilter = sFilter
    OpenFile.nFilterIndex = 1
    OpenFile.lpstrFile = String(257, 0)
    OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1
    OpenFile.lpstrFileTitle = OpenFile.lpstrFile
    OpenFile.nMaxFileTitle = OpenFile.nMaxFile
    If Len(sInitDir) > 1 Then
        OpenFile.lpstrInitialDir = sInitDir
    Else
        OpenFile.lpstrInitialDir = CurDir()
    End If
    
    OpenFile.lpstrTitle = ""

    If Len(sDefExtention) > 0 Then
        OpenFile.lpstrDefExt = sDefExtention
    End If
    
    OpenFile.FLAGS = OFN_OVERWRITEPROMPT
    lReturn = GetSaveFileName(OpenFile)
    If lReturn = 0 Then
        GetFileToSave = ""
    Else
        s = OpenFile.lpstrFile
        modFileUtil.ReturnWOEndNull s
        GetFileToSave = s
    End If

    Exit Function

    
    Exit Function
    
GetPathToSave_ERR:
    Debug.Assert 0
    Debug.Print "GetPathToSave_ERR: " & err.Description
    Resume Next
    
    
End Function




Public Function FileDir(sPath As String) As String
'   returns the path minus the file name:
'   ie. returns "c:\temp" from "c:\temp\table.dbf"

Dim i As Integer
Dim s As String

On Error GoTo TableDir_ERR

    For i = Len(sPath) To 1 Step -1
        s = Mid(sPath, i, 1)
        If s = "\" Then Exit For
    Next
    
    If i > 1 Then FileDir = Mid(sPath, 1, i - 1)
    
    Exit Function
    
TableDir_ERR:
    Debug.Assert 0
    Debug.Print "TableDir_ERR: " & err.Description
    

End Function



Public Function GetTempDirectory() As String
Dim iRes As Integer
Dim sBuff As String
On Error Resume Next

    sBuff = Space(255)
    iRes = GetTempPath(Len(sBuff), sBuff)
    GetTempDirectory = ReturnWOTrails(sBuff)
    
     
    
End Function
Private Function ReturnWOTrails(ByRef sString As String) As String
Dim i As Integer
Dim s As String
'return a string up to its terminating null character

On Error GoTo ReturnWOEndNull_ERR

    For i = 1 To Len(sString)
        s = Mid(sString, i, 1)
        If s = Chr(0) Then
            Exit For
        End If
    Next
        
    ReturnWOTrails = Mid(sString, 1, i - 1)
    
    Exit Function
    
ReturnWOEndNull_ERR:
    Debug.Assert 0
    Debug.Print "ReturnWOEndNull_ERR: " & err.Description
    

End Function