www.pudn.com > SuperDLL2.zip > modPathFiles.bas

Attribute VB_Name = "modPathFiles" 
Option Explicit 
 
Private Type OSVERSIONINFO 
        dwOSVersionInfoSize As Long 
        dwMajorVersion As Long 
        dwMinorVersion As Long 
        dwBuildNumber As Long 
        dwPlatformId As PlatformType 
        szCSDVersion As String * 128      '  Maintenance string for PSS usage 
End Type 
 
Public Enum FILE_ATTRIBUTE 
  FILE_ATTRIBUTE_DIRECTORY = &H10 
  FILE_ATTRIBUTE_ARCHIVE = &H20 
  FILE_ATTRIBUTE_NORMAL = &H80 
  FILE_ATTRIBUTE_READONLY = &H1 
  FILE_ATTRIBUTE_HIDDEN = &H2 
  FILE_ATTRIBUTE_SYSTEM = &H4 
  FILE_ATTRIBUTE_COMPRESSED = &H800 
  FILE_ATTRIBUTE_ENCRYPTED = &H40 
  FILE_ATTRIBUTE_TEMPORARY = &H100 
  FILE_ATTRIBUTE_OFFLINE = &H1000 
  FILE_ATTRIBUTE_SPARSE_FILE = &H200 
  FILE_ATTRIBUTE_REPARSE_POINT = &H400 
  FILE_ATTRIBUTE_NOT_CONTENT_INDEXED = &H2000 
End Enum 
 
Private Type FILETIME 
    dwLowDateTime As Long 
    dwHighDateTime As Long 
End Type 
 
Public Type SYSTEMTIME       ' DayOfWeek : 
    wYear As Integer         ' ------------ 
    wMonth As Integer        ' Dimanche = 0 
    wDayOfWeek As Integer    ' Lundi    = 1 
    wDay As Integer          ' Mardi    = 2 
    wHour As Integer         ' Mercredi = 3 
    wMinute As Integer       ' Jeudi    = 4 
    wSecond As Integer       ' Vendredi = 5 
    wMilliseconds As Integer ' Samedi   = 6 
End Type 
 
Private Type WIN32_FIND_DATA 
    dwFileAttributes As FILE_ATTRIBUTE 
    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 
 
Public Type Search_File_Type 
    dwFileAttributes As FILE_ATTRIBUTE 
    nFileSize As Currency 
    cPath As Variant 
    cFileName As Variant 
    cPathAndFileName As Variant 
    stCreationTime As SYSTEMTIME 
    stLastAccessTime As SYSTEMTIME 
    stLastWriteTime As SYSTEMTIME 
End Type 
 
Public Enum DriveTypeVar 
  DRIVE_ERROR = -1 
  DRIVE_UNKNOWN = 0 
  DRIVE_ABSENT = 1 
  DRIVE_REMOVABLE = 2 
  DRIVE_FIXED = 3 
  DRIVE_REMOTE = 4 
  DRIVE_CDROM = 5 
  DRIVE_RAMDISK = 6 
End Enum 
 
Private Type BrowseInfo 
  hWndOwner      As Long 
  pidlRoot       As Long 
  pszDisplayName As String 
  lpszTitle      As String 
  ulFlags        As Long 
  lpfnCallback   As Long 
  lParam         As Long 
  iImage         As Long 
End Type 
 
Public Enum ROOTDIR_ID 
  ROOTDIR_CUSTOM = -1 
  ROOTDIR_ALL = &H0 
  ROOTDIR_MY_COMPUTER = &H11 
  ROOTDIR_DRIVES = &H11 
  ROOTDIR_ALL_NETWORK = &H12 
  ROOTDIR_NETWORK_COMPUTERS = &H3D 
  ROOTDIR_WORKGROUP = &H3D 
  ROOTDIR_USER = &H28 
  ROOTDIR_USER_DESKTOP = &H10 
  ROOTDIR_USER_MY_DOCUMENTS = &H5 
  ROOTDIR_USER_START_MENU = &HB 
  ROOTDIR_USER_START_MENU_PROGRAMS = &H2 
  ROOTDIR_USER_START_MENU_PROGRAMS_STARTUP = &H7 
  ROOTDIR_COMMON_DESKTOP = &H19 
  ROOTDIR_COMMON_DOCUMENTS = &H2E 
  ROOTDIR_COMMON_START_MENU = &H16 
  ROOTDIR_COMMON_START_MENU_PROGRAMS = &H17 
  ROOTDIR_COMMON_START_MENU_PROGRAMS_STARTUP = &H18 
  ROOTDIR_WINDOWS = &H24 
  ROOTDIR_SYSTEM = &H25 
  ROOTDIR_FONTS = &H14 
  ROOTDIR_PROGRAM_FILES = &H26 
  ROOTDIR_PROGRAM_FILES_COMMON_FILES = &H2B 
End Enum 
 
Private Const MaxLength As Long = 60 
 
Private Const WM_USER = &H400 
Private Const BFFM_INITIALIZED = 1 
Private Const BFFM_SELCHANGED = 2 
Private Const BFFM_SETSTATUSTEXT = (WM_USER + 100) 
Private Const BFFM_SETSELECTION = (WM_USER + 102) 
Private Const BFFM_SETOKTEXT = (WM_USER + 105) 
Private Const BFFM_ENABLEOK = (WM_USER + 101) 
 
Private Const BIF_DEFAULT = &H0 
Private Const BIF_RETURNONLYFSDIRS = &H1     ' only local Directory 
Private Const BIF_DONTGOBELOWDOMAIN = &H2 
Private Const BIF_STATUSTEXT = &H4           ' not with BIF_NEWDIALOGSTYLE 
Private Const BIF_RETURNFSANCESTORS = &H8 
Private Const BIF_EDITBOX = &H10 
Private Const BIF_VALIDATE = &H20            ' use with BIF_EDITBOX or BIF_USENEWUI 
Private Const BIF_NEWDIALOGSTYLE = &H40      ' Use OleInitialize before 
Private Const BIF_USENEWUI = &H50            ' = (BIF_NEWDIALOGSTYLE + BIF_EDITBOX) 
Private Const BIF_BROWSEINCLUDEURLS = &H80 
Private Const BIF_UAHINT = &H100             ' use with BIF_NEWDIALOGSTYLE, add Usage Hint if no EditBox 
Private Const BIF_NONEWFOLDERBUTTON = &H200 
Private Const BIF_NOTRANSLATETARGETS = &H400 
Private Const BIF_BROWSEFORCOMPUTER = &H1000 
Private Const BIF_BROWSEFORPRINTER = &H2000 
Private Const BIF_BROWSEINCLUDEFILES = &H4000 
Private Const BIF_SHAREABLE = &H8000         ' use with BIF_NEWDIALOGSTYLE 
 
' IShellFolder's ParseDisplayName member function should be used instead. 
Private Declare Function SHSimpleIDListFromPath Lib "shell32.dll" Alias "#162" (ByVal szPath As String) As Long 
 
'Private Declare Function SHILCreateFromPath Lib "shell32.dll" (ByVal pszPath As Long, ByRef ppidl As Long, ByRef rgflnOut As Long) As Long 
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal HWND As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long 
Private Declare Function SendMessage2 Lib "user32.dll" Alias "SendMessageA" (ByVal HWND As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long 
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" (ByVal pidList As Long, ByVal lpBuffer As String) As Long 
Private Declare Function SHBrowseForFolder Lib "shell32.dll" (lpbi As BrowseInfo) As Long 
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long) 
Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hWndOwner As Long, ByVal nFolder As Long, pidl As ITEMIDLIST) As Long 
Private Declare Sub OleInitialize Lib "ole32.dll" (pvReserved As Any) 
Private Declare Function PathIsDirectory Lib "shlwapi.dll" Alias "PathIsDirectoryA" (ByVal pszPath As String) As Long 
Private Declare Function GetDriveType Lib "kernel32.dll" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long 
Private Declare Function SetCurrentDirectory Lib "kernel32.dll" Alias "SetCurrentDirectoryA" (ByVal lpPathName As String) As Long 
Private Declare Function GetDiskFreeSpaceEx Lib "kernel32.dll" Alias "GetDiskFreeSpaceExA" (ByVal lpRootPathName As String, lpFreeBytesAvailableToCaller As Currency, lpTotalNumberOfBytes As Currency, lpTotalNumberOfFreeBytes As Currency) As Long 
Private Declare Function PathFileExists Lib "shlwapi.dll" Alias "PathFileExistsA" (ByVal pszPath As String) As Long 
Private Declare Function FindFirstFile Lib "kernel32.dll" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long 
Private Declare Function FindNextFile Lib "kernel32.dll" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long 
Private Declare Function FindClose Lib "kernel32.dll" (ByVal hFindFile As Long) As Long 
Private Declare Function FileTimeToSystemTime Lib "kernel32.dll" (lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long 
Private Declare Function SearchTreeForFile Lib "imagehlp.dll" (ByVal RootPath As String, ByVal InputPathName As String, ByVal OutputPathBuffer As String) As Long 
Private Declare Function PathIsDirectoryEmpty Lib "shlwapi.dll" Alias "PathIsDirectoryEmptyA" (ByVal pszPath As String) As Long 
Private Declare Function GetShortPathName Lib "kernel32.dll" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal lBuffer As Long) As Long 
Private Declare Function GetLongPathName Lib "kernel32.dll" Alias "GetLongPathNameA" (ByVal lpszShortPath As String, ByVal lpszLongPath As String, ByVal lBuffer As Long) As Long 
Private Declare Function GetVersionEx Lib "kernel32.dll" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long 
Private 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 
Private 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 
 
Private m_CurrentDirectory As String 
Private OK_BUTTON_TEXT As String 
Private FileArray() As Search_File_Type 
Private TotalFilesFound As Long 
 
Public Function AppPath(ByVal zPathPtr As String) As String 
  Dim zPath As String 
  zPath = Trim3(CSTOVBS(zPathPtr)) 
  If Right$(zPath, 1) = "\" Then AppPath = VBSTOCS(zPath) Else AppPath = VBSTOCS(zPath & "\") 
End Function 
 
Private Function GetDT(ByVal var1 As String) As String 
  Select Case GetDriveType(var1) 
    Case DRIVE_UNKNOWN 
      GetDT = "UNKNOWN" 
    Case DRIVE_ABSENT 
      GetDT = "ABSENT" 
    Case DRIVE_REMOVABLE 
      GetDT = "REMOVABLE" 
    Case DRIVE_FIXED 
      GetDT = "FIXED" 
    Case DRIVE_REMOTE 
      GetDT = "REMOTE" 
    Case DRIVE_CDROM 
      GetDT = "CDROM" 
    Case DRIVE_RAMDISK 
      GetDT = "RAMDISK" 
    Case Else 
      GetDT = "ERROR" 
  End Select 
End Function 
 
Public Function DriveTypeS(ByVal zDrivePtr As String) As String 
  Dim var1 As String, zDrive As String 
  zDrive = Trim3(CSTOVBS(zDrivePtr)) 
  If ((Len(zDrive) = 2) And (Right$(zDrive, 1) = ":")) Or (Len(zDrive) = 1) Then 
    var1 = Left$(zDrive, 1) 
    Select Case Asc(var1) 
      Case 65 To 90 
        DriveTypeS = VBSTOCS(GetDT(var1 & ":")) 
      Case 97 To 122 
        DriveTypeS = VBSTOCS(GetDT(var1 & ":")) 
      Case Else 
        MsgBox "Use " & Chr$(34) & "DriveTypeS c" & Chr$(34) & " or " & Chr$(34) & "DriveTypeS c:" & Chr$(34), vbExclamation, "SuperDLL - DriveTypeS" 
        DriveTypeS = VBSTOCS("ERROR") 
    End Select 
  Else 
    MsgBox "Use " & Chr$(34) & "DriveTypeS c" & Chr$(34) & " or " & Chr$(34) & "DriveTypeS c:" & Chr$(34), vbExclamation, "SuperDLL - DriveTypeS" 
    DriveTypeS = VBSTOCS("ERROR") 
  End If 
End Function 
 
Public Function DriveType(ByVal zDrivePtr As String) As DriveTypeVar 
  Dim var1 As String, zDrive As String 
  zDrive = Trim3(CSTOVBS(zDrivePtr)) 
  If ((Len(zDrive) = 2) And (Right$(zDrive, 1) = ":")) Or (Len(zDrive) = 1) Then 
    var1 = Left$(zDrive, 1) 
    Select Case Asc(var1) 
      Case 65 To 90 
        DriveType = GetDriveType(var1 & ":") 
      Case 97 To 122 
        DriveType = GetDriveType(var1 & ":") 
      Case Else 
        MsgBox "Use " & Chr$(34) & "DriveType c" & Chr$(34) & " or " & Chr$(34) & "DriveType c:" & Chr$(34), vbExclamation, "SuperDLL - DriveType" 
        DriveType = DRIVE_ERROR 
    End Select 
  Else 
    MsgBox "Use " & Chr$(34) & "DriveType c" & Chr$(34) & " or " & Chr$(34) & "DriveType c:" & Chr$(34), vbExclamation, "SuperDLL - DriveType" 
    DriveType = DRIVE_ERROR 
  End If 
End Function 
 
Public Function FileExist(ByVal strPathPtr As String) As Boolean 
  On Local Error GoTo ErrFile 
  Dim strPath As String 
  strPath = CSTOVBS(strPathPtr) 
  Open strPath For Input Access Read As #1 
  Close #1 
  FileExist = True 
  Exit Function 
ErrFile: 
  FileExist = False 
End Function 
 
Public Function Filexist(ByVal strPathPtr As String) As Boolean 
  Filexist = FileExist(strPathPtr) 
End Function 
 
Public Function DirExist(ByVal zPathPtr As String) As Boolean 
'  On Local Error GoTo ErrDir 
  Dim zPath As String 
  zPath = CSTOVBS(zPathPtr) 
  DirExist = PathIsDirectory(zPath) 
'  Dim qwe As String 
'  qwe = CurDir 
'  ChDir zPath 
'  ChDir qwe 
'  DirExist = True 
'  Exit Function 
'ErrDir: 
'  DirExist = False 
End Function 
 
Public Function SetCurDir(ByVal zPathPtr As String) As Boolean 
  Dim zPath As String 
  zPath = CSTOVBS(zPathPtr) 
  If SetCurrentDirectory(zPath) <> 0 Then 
    SetCurDir = True 
  Else 
    SetCurDir = False 
  End If 
End Function 
 
Public Function FreeSpace(ByVal zDrivePtr As String) As Currency 
  Dim var1 As Currency, var2 As Currency, var3 As Currency 
  Dim var4 As String, zDrive As String 
  zDrive = Trim3(CSTOVBS(zDrivePtr)) 
  If ((Len(zDrive) = 2) And (Right$(zDrive, 1) = ":")) Or (Len(zDrive) = 1) Then 
    var4 = Left$(zDrive, 1) 
    Select Case Asc(var4) 
      Case 65 To 90 
        GetDiskFreeSpaceEx var4 & ":", var1, var2, var3 
      Case 97 To 122 
        GetDiskFreeSpaceEx var4 & ":", var1, var2, var3 
      Case Else 
        MsgBox "Use " & Chr$(34) & "FreeSpace c" & Chr$(34) & " or " & Chr$(34) & "FreeSpace c:" & Chr$(34), vbExclamation, "SuperDLL - FreeSpace" 
        FreeSpace = -1 
        Exit Function 
    End Select 
  Else 
    MsgBox "Use " & Chr$(34) & "FreeSpace c" & Chr$(34) & " or " & Chr$(34) & "FreeSpace c:" & Chr$(34), vbExclamation, "SuperDLL - FreeSpace" 
    FreeSpace = -1 
    Exit Function 
  End If 
  If var1 = 0 And var2 = 0 And var3 = 0 Then 
    FreeSpace = -1 
  Else 
    FreeSpace = var1 * 10000 
  End If 
End Function 
 
Public Function FileOrDirExist(ByVal zPathPtr As String) As Boolean 
  Dim zPath As String 
  zPath = CSTOVBS(zPathPtr) 
  FileOrDirExist = PathFileExists(zPath) 
End Function 
 
Public Function TreeFind(ByVal zPathPtr As String, ByVal zFilePtr As String) As Variant 
  Dim VarTemp As String, zPath As String, zFile As String 
  zPath = CSTOVBS(zPathPtr) 
  zFile = CSTOVBS(zFilePtr) 
  VarTemp = String(MAX_PATH, 0) 
  If SearchTreeForFile(zPath, zFile, VarTemp) <> 0 Then 
    TreeFind = Trim3(VarTemp) 
  Else 
    TreeFind = -1 
  End If 
End Function 
 
Private Function SearchFilesEx(ByVal zPath As String, ByVal zFiles As String, Optional ByVal SubDirs As Boolean = True, Optional ByRef NumberFound As Long = -1, Optional NewSearch As Boolean = True) As Search_File_Type() 
  Dim zPathStr As String, DirCount As Long, FileCount As Long, isOK As Boolean 
  Dim RetVal As Long, TempSearch() As WIN32_FIND_DATA, DDir() As String, t As Long 
  If NewSearch = True Then TotalFilesFound = 0 
  If zFiles = vbNullString Or zFiles = "" Then zFiles = "*.*" 
  If Right$(zPath, 1) = "\" Then 
    zPathStr = zPath 
  Else 
    zPathStr = zPath & "\" 
  End If 
  DirCount = 0 
  isOK = True 
  ReDim TempSearch(1 To 1) 
  RetVal = FindFirstFile(zPathStr & "*.*", TempSearch(1)) 
  If RetVal <> -1 Then 
  Do While isOK 
    DoEvents 
    If (FILE_ATTRIBUTE_DIRECTORY And TempSearch(1).dwFileAttributes) = FILE_ATTRIBUTE_DIRECTORY Then 
      If Trim3(TempSearch(1).cFileName) <> "." And Trim3(TempSearch(1).cFileName) <> ".." Then 
        DirCount = DirCount + 1 
        ReDim Preserve DDir(DirCount) 
        DDir(DirCount) = Trim3(TempSearch(1).cFileName) 
      End If 
    End If 
    ReDim TempSearch(1 To 1) 
    isOK = FindNextFile(RetVal, TempSearch(1)) <> 0 
  Loop 
  End If 
  FindClose RetVal 
  FileCount = 0 
  isOK = True 
  ReDim TempSearch(1 To 1) 
  RetVal = FindFirstFile(zPathStr & zFiles, TempSearch(1)) 
  If RetVal <> -1 Then 
  Do While isOK 
    DoEvents 
    If Trim3(TempSearch(1).cFileName) <> "." And Trim3(TempSearch(1).cFileName) <> ".." Then 
      FileCount = FileCount + 1 
      ReDim Preserve FileArray(TotalFilesFound + 1) 
      FileArray(TotalFilesFound + 1).cPath = zPathStr 
      FileArray(TotalFilesFound + 1).cFileName = Trim3(TempSearch(1).cFileName) 
      FileArray(TotalFilesFound + 1).cPathAndFileName = zPathStr & Trim3(TempSearch(1).cFileName) 
      FileArray(TotalFilesFound + 1).dwFileAttributes = TempSearch(1).dwFileAttributes 
      FileArray(TotalFilesFound + 1).nFileSize = (4294967296@ * TempSearch(1).nFileSizeHigh) + TempSearch(1).nFileSizeLow 
      FileTimeToSystemTime TempSearch(1).ftCreationTime, FileArray(TotalFilesFound + 1).stCreationTime 
      FileTimeToSystemTime TempSearch(1).ftLastWriteTime, FileArray(TotalFilesFound + 1).stLastWriteTime 
      FileTimeToSystemTime TempSearch(1).ftLastAccessTime, FileArray(TotalFilesFound + 1).stLastAccessTime 
      TotalFilesFound = TotalFilesFound + 1 
      If NumberFound <> -1 Then NumberFound = TotalFilesFound 
    End If 
    ReDim TempSearch(1 To 1) 
    isOK = FindNextFile(RetVal, TempSearch(1)) <> 0 
  Loop 
  End If 
  FindClose RetVal 
  If SubDirs = True Then 
    If NumberFound = -1 Then 
      For t = 1 To DirCount 
        DoEvents 
        SearchFilesEx zPathStr & DDir(t), zFiles, True, , False 
      Next t 
    Else 
      For t = 1 To DirCount 
        DoEvents 
        SearchFilesEx zPathStr & DDir(t), zFiles, True, NumberFound, False 
      Next t 
    End If 
  End If 
  If NumberFound <> -1 Then NumberFound = TotalFilesFound 
  SearchFilesEx = FileArray 
End Function 
 
Public Function SearchFiles(ByVal zPathPtr As String, ByVal zFilesPtr As String, Optional ByVal SubDirs As Boolean = True, Optional ByRef NumberFound As Long = -1, Optional NewSearch As Boolean = True) As Search_File_Type() 
  Dim zPath As String, zFiles As String 
  zPath = CSTOVBS(zPathPtr) 
  zFiles = CSTOVBS(zFilesPtr) 
  SearchFiles = SearchFilesEx(zPath, zFiles, SubDirs, NumberFound, NewSearch) 
End Function 
 
Public Function StripPath(ByVal zPathAndFilePtr As String) As String 
  Dim t As Long, zPathAndFile As String 
  zPathAndFile = CSTOVBS(zPathAndFilePtr) 
  For t = Len(zPathAndFile) To 1 Step -1 
    If Mid$(zPathAndFile, t, 1) = "\" Or Mid$(zPathAndFile, t, 1) = ":" Then Exit For 
  Next t 
  StripPath = VBSTOCS(Mid$(zPathAndFile, t + 1)) 
End Function 
 
Public Function StripFile(ByVal zPathAndFilePtr As String) As String 
  Dim t As Long, zPathAndFile As String 
  zPathAndFile = CSTOVBS(zPathAndFilePtr) 
  For t = Len(zPathAndFile) To 1 Step -1 
    If Mid$(zPathAndFile, t, 1) = "\" Or Mid$(zPathAndFile, t, 1) = ":" Then Exit For 
  Next t 
  StripFile = VBSTOCS(Left$(zPathAndFile, t)) 
End Function 
 
Public Function IsDirEmpty(ByVal zPathPtr As String) As Boolean 
  Dim zPath As String 
  zPath = CSTOVBS(zPathPtr) 
  IsDirEmpty = PathIsDirectoryEmpty(zPath) 
End Function 
 
Public Function GetShortPath(ByVal zPathAndFilePtr As String) As String 
  Dim StrLen As Long, ShortPath As String, zPathAndFile As String 
  zPathAndFile = CSTOVBS(zPathAndFilePtr) 
  ShortPath = String$(MAX_PATH, 0) 
  StrLen = GetShortPathName(zPathAndFile, ShortPath, MAX_PATH) 
  GetShortPath = VBSTOCS(Left$(ShortPath, StrLen)) 
End Function 
 
Public Function GetLongPath(ByVal zPathAndFilePtr As String) As String 
  Dim StrLen As Long, LongPath As String, zPathAndFile As String 
  zPathAndFile = CSTOVBS(zPathAndFilePtr) 
  LongPath = String$(MAX_PATH, 0) 
  StrLen = GetLongPathName(zPathAndFile, LongPath, MAX_PATH) 
  GetLongPath = VBSTOCS(Left$(LongPath, StrLen)) 
End Function 
 
Private Function GetPIDLFromPath(spath As String) As Long 
  ' Return the pidl to the path supplied by calling the undocumented API #162 
  If isNT2000XP Then 
    GetPIDLFromPath = SHSimpleIDListFromPath(StrConv(spath, vbUnicode)) 
  Else 
    GetPIDLFromPath = SHSimpleIDListFromPath(spath) 
  End If 
End Function 
 
Private Function GetSpecialFolderID(ByVal CSIDL As ROOTDIR_ID) As Long 
  Dim IDL As ITEMIDLIST, r As Long 
  r = SHGetSpecialFolderLocation(ByVal 0&, CSIDL, IDL) 
  If r = 0 Then 
    GetSpecialFolderID = IDL.mkid.cb 
  Else 
    GetSpecialFolderID = 0 
  End If 
End Function 
 
Private Function GetAddressofFunction(gAdd As Long) As Long 
  GetAddressofFunction = gAdd 
End Function 
 
Private Function BrowseCallbackProc(ByVal HWND As Long, ByVal uMsg As Long, ByVal lp As Long, ByVal pData As Long) As Long 
  On Local Error Resume Next 
  Dim sBuffer As String 
  Select Case uMsg 
    Case BFFM_INITIALIZED 
      SendMessage HWND, BFFM_SETSELECTION, 1, m_CurrentDirectory 
      If OK_BUTTON_TEXT <> vbNullString Then SendMessage2 HWND, BFFM_SETOKTEXT, 1, StrPtr(OK_BUTTON_TEXT) 
    Case BFFM_SELCHANGED 
      sBuffer = Space$(MAX_PATH) 
      SHGetPathFromIDList lp, sBuffer 
      sBuffer = Left$(sBuffer, InStr(sBuffer, vbNullChar) - 1) 
      If Len(sBuffer) = 0 Then 
        SendMessage2 HWND, BFFM_ENABLEOK, 1, 0 
        SendMessage HWND, BFFM_SETSTATUSTEXT, 1, "" 
      Else 
        SendMessage HWND, BFFM_SETSTATUSTEXT, 1, sBuffer 
      End If 
  End Select 
  BrowseCallbackProc = 0 
End Function 
 
Private Function isME2KXP() As Boolean 
  Dim lpv As OSVERSIONINFO 
  lpv.dwOSVersionInfoSize = Len(lpv) 
  GetVersionEx lpv 
  If ((lpv.dwPlatformId = 2) And (lpv.dwMajorVersion >= 5)) Or _ 
     ((lpv.dwPlatformId = 1) And (lpv.dwMajorVersion >= 4) And (lpv.dwMinorVersion >= 90)) Then 
    isME2KXP = True 
  Else 
    isME2KXP = False 
  End If 
End Function 
 
Public Function BrowseForFolder(Optional OwnerForm As Form = Nothing, Optional ByVal TitlePtr As String = "", Optional ByVal RootDir As ROOTDIR_ID = ROOTDIR_ALL, Optional ByVal CustomRootDirPtr As String = "", Optional ByVal StartDirPtr As String = "", Optional ByVal NewStyle As Boolean = True, Optional ByVal IncludeFiles As Boolean = False, Optional ByVal OkButtonTextPtr As String = "") As String 
  Dim lpIDList As Long, sBuffer As String, tBrowseInfo As BrowseInfo, clRoot As Boolean 
  Dim Title As String, CustomRootDir As String, StartDir As String, OkButtonText As String 
  Title = CSTOVBS(TitlePtr) 
  CustomRootDir = CSTOVBS(CustomRootDirPtr) 
  StartDir = CSTOVBS(StartDirPtr) 
  OkButtonText = CSTOVBS(OkButtonTextPtr) 
  If Len(OkButtonText) > 0 Then 
    OK_BUTTON_TEXT = OkButtonText 
  Else 
    OK_BUTTON_TEXT = vbNullString 
  End If 
  clRoot = False 
  If RootDir = ROOTDIR_CUSTOM Then 
    If Len(CustomRootDir) > 0 Then 
      If (PathIsDirectory(CustomRootDir) And (Left$(CustomRootDir, 2) <> "\\")) Or (Left$(CustomRootDir, 2) = "\\") Then 
        tBrowseInfo.pidlRoot = GetPIDLFromPath(CustomRootDir) 
'        SHILCreateFromPath StrPtr(CustomRootDir), tBrowseInfo.pidlRoot, ByVal 0& 
        clRoot = True 
      Else 
        tBrowseInfo.pidlRoot = GetSpecialFolderID(ROOTDIR_MY_COMPUTER) 
      End If 
    Else 
      tBrowseInfo.pidlRoot = GetSpecialFolderID(ROOTDIR_ALL) 
    End If 
  Else 
    tBrowseInfo.pidlRoot = GetSpecialFolderID(RootDir) 
  End If 
  If (Len(StartDir) > 0) Then 
    m_CurrentDirectory = StartDir & vbNullChar 
  Else 
    m_CurrentDirectory = vbNullChar 
  End If 
  If Len(Title) > 0 Then 
    tBrowseInfo.lpszTitle = Title 
  Else 
    tBrowseInfo.lpszTitle = "Select A Directory" 
  End If 
  tBrowseInfo.lpfnCallback = GetAddressofFunction(AddressOf BrowseCallbackProc) 
  tBrowseInfo.ulFlags = BIF_RETURNONLYFSDIRS 
  If IncludeFiles Then tBrowseInfo.ulFlags = tBrowseInfo.ulFlags + BIF_BROWSEINCLUDEFILES 
  If NewStyle And isME2KXP Then 
    tBrowseInfo.ulFlags = tBrowseInfo.ulFlags + BIF_NEWDIALOGSTYLE + BIF_UAHINT 
    OleInitialize Null ' Initialize OLE and COM 
  Else 
    tBrowseInfo.ulFlags = tBrowseInfo.ulFlags + BIF_STATUSTEXT 
  End If 
  If Not (OwnerForm Is Nothing) Then tBrowseInfo.hWndOwner = OwnerForm.HWND 
  lpIDList = SHBrowseForFolder(tBrowseInfo) 
  If clRoot = True Then CoTaskMemFree tBrowseInfo.pidlRoot 
  If (lpIDList) Then 
    sBuffer = Space$(MAX_PATH) 
    SHGetPathFromIDList lpIDList, sBuffer 
    CoTaskMemFree lpIDList 
    sBuffer = Left$(sBuffer, InStr(sBuffer, vbNullChar) - 1) 
    BrowseForFolder = VBSTOCS(sBuffer) 
  Else 
    BrowseForFolder = VBSTOCS("") 
  End If 
End Function 
 
Public Function WriteIni(ByVal sIniFileNamePtr As String, ByVal sSectionPtr As String, ByVal sItemPtr As String, ByVal sTextPtr As String) As Boolean 
  On Local Error GoTo sWriteIniError 
  Dim sIniFileName As String, sSection As String 
  Dim sItem As String, sText As String 
  sIniFileName = CSTOVBS(sIniFileNamePtr) 
  sSection = CSTOVBS(sSectionPtr) 
  sItem = CSTOVBS(sItemPtr) 
  sText = CSTOVBS(sTextPtr) 
  WritePrivateProfileString sSection, sItem, sText, sIniFileName 
  WriteIni = True 
  Exit Function 
sWriteIniError: 
  WriteIni = False 
End Function 
 
Public Function ReadIni(ByVal sIniFileNamePtr As String, ByVal sSectionPtr As String, ByVal sItemPtr As String, ByVal sDefaultPtr As String) As String 
  Dim iRetAmount As Long, sTemp As String 
  Dim sIniFileName As String, sSection As String 
  Dim sItem As String, sDefault As String 
  sIniFileName = CSTOVBS(sIniFileNamePtr) 
  sSection = CSTOVBS(sSectionPtr) 
  sItem = CSTOVBS(sItemPtr) 
  sDefault = CSTOVBS(sDefaultPtr) 
  sTemp = String$(MaxLength, 0) 
  iRetAmount = GetPrivateProfileString(sSection, sItem, sDefault, sTemp, MaxLength, sIniFileName) 
  sTemp = Left$(sTemp, iRetAmount) 
  ReadIni = VBSTOCS(sTemp) 
End Function