browseforfolermodule.bas

一个交通专用的gis-T系统

Attribute VB_Name = "BrowseForFolerModule"
'*********************************************************************
'*
'*                本源码完全免费，共交通同仁学习参考                 *
'*                      www.tranbbs.com                              *
'*                   Developed by Yang Ming                          *
'*       Nanjing Institute of City Transportation Planning           *
'*                 请保留本版权信息，谢谢合作                        *
'*                      中国交通技术论坛                             *
'*                                                                   *
'*                                                                   *
'*********************************************************************
Public Type BrowseInfo

     hwndOwner As Long
     pIDLRoot As Long
     pszDisplayName As Long
     lpszTitle As Long
     ulFlags As Long
     lpfnCallback As Long
     lParam As Long
     iImage As Long

End Type
Public Const BIF_RETURNONLYFSDIRS = 1
Public Const MAX_PATH = 260

Public syspath As String
Public Const sizer = 255 * 5 'should be adequate b/c for 4 (255 char) fields and 1 extra to store bytes and tombstone word
Public Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Public Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
Public Declare Function GetSystemDirectory Lib "kernel32.dll" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Public Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Public Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Public Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)

Public Function ReadIndex(ByVal lstrKey As String) As String 'Read value from ini file.
On Error Resume Next
Dim lfixedstrRetValue As String * sizer
Dim lstrRetValue As String
Dim lintJunk As Integer
Dim lstrSection As String
    
    lstrSection = "Path"
    lfixedstrRetValue = String(sizer, " ")
    lintJunk = GetPrivateProfileString(lstrSection, lstrKey, " ", lfixedstrRetValue, sizer, syspath)
    lstrRetValue = Trim(lfixedstrRetValue)
    lstrRetValue = Left(lstrRetValue, Len(lstrRetValue) - 1)
    ReadIndex = lstrRetValue

On Error GoTo 0
On Error Resume Next
End Function

Public Sub WriteIndex(ByVal lstrKey As String, ByVal lstrValue As String) 'Write value to ini file.
On Error Resume Next
Dim lstrSection As String
Dim lintJunk As Integer
    
    lstrSection = "Path"
    lstrValue = Trim(lstrValue)
    lintJunk = WritePrivateProfileString(lstrSection, lstrKey, lstrValue, syspath)
    
On Error GoTo 0
On Error Resume Next
End Sub

Public Function BrowseForFolder(hwndOwner As Long, sPrompt As String) As String 'Browse folder
     Dim iNull As Integer
     Dim lpIDList As Long
     Dim lResult As Long
     Dim sPath As String
     Dim udtBI As BrowseInfo

     With udtBI

          .hwndOwner = hwndOwner
          .lpszTitle = lstrcat(sPrompt, "")
          .ulFlags = BIF_RETURNONLYFSDIRS

     End With

     lpIDList = SHBrowseForFolder(udtBI)
     If lpIDList Then

          sPath = String$(MAX_PATH, 0)
          lResult = SHGetPathFromIDList(lpIDList, sPath)
          Call CoTaskMemFree(lpIDList)
          iNull = InStr(sPath, vbNullChar)
          If iNull Then

               sPath = Left$(sPath, iNull - 1)

          End If

     End If

     BrowseForFolder = sPath

End Function

Public Function FileExists(ByVal f$) As Boolean 'To judge the file exists or no
    On Error Resume Next
    SetAttr f$, vbNormal
    If Err Then
        FileExists = False
    Else
        FileExists = True
    End If
    On Error GoTo 0
    On Error Resume Next
End Function