home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / CODE_UPLOAD5591582000.psc / TreeCreator / modMain.bas < prev    next >
Encoding:
BASIC Source File  |  2000-05-04  |  1.7 KB  |  70 lines

  1. Attribute VB_Name = "modMain"
  2. Global selected As Boolean
  3. Global tFile As String
  4. Global Sel_dir As String
  5. Private Type BrowseInfo
  6.        hWndOwner As Long
  7.        pIDLRoot As Long
  8.        pszDisplayName As Long
  9.        lpszTitle As Long
  10.        ulFlags As Long
  11.        lpfnCallback As Long
  12.        lParam As Long
  13.        iImage As Long
  14. End Type
  15.  
  16. Private Const BIF_RETURNONLYFSDIRS = 1
  17. Private Const MAX_PATH = 260
  18.  
  19. Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
  20.  
  21. Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" _
  22.        (ByVal lpString1 As String, ByVal lpString2 As String) As Long
  23.  
  24. Private Declare Function SHBrowseForFolder Lib "shell32" _
  25.        (lpbi As BrowseInfo) As Long
  26.  
  27. Private Declare Function SHGetPathFromIDList Lib "shell32" _
  28.        (ByVal pidList As Long, ByVal lpBuffer As String) As Long
  29. Sub Wait(WaitSeconds As Single)
  30.  
  31. Dim StartTime As Single
  32.  
  33. StartTime = Timer
  34.  
  35. Do While Timer < StartTime + WaitSeconds
  36. DoEvents
  37. Loop
  38. End Sub
  39.  
  40. Public Function BrowseForFolder(hWndOwner As Long, sPrompt As String) As String
  41.  
  42.        Dim iNull As Integer
  43.        Dim lpIDList As Long
  44.        Dim lResult As Long
  45.        Dim sPath As String
  46.        Dim udtBI As BrowseInfo
  47.        
  48.     With udtBI
  49.        .hWndOwner = hWndOwner
  50.        .lpszTitle = lstrcat(sPrompt, "")
  51.        .ulFlags = BIF_RETURNONLYFSDIRS
  52. End With
  53.  
  54. lpIDList = SHBrowseForFolder(udtBI)
  55.  
  56. If lpIDList Then
  57.        sPath = String$(MAX_PATH, 0)
  58.        lResult = SHGetPathFromIDList(lpIDList, sPath)
  59.        Call CoTaskMemFree(lpIDList)
  60.        iNull = InStr(sPath, vbNullChar)
  61.  
  62.               If iNull Then
  63.                      sPath = Left
  64.  = Single
  65.  
  66. StartTime = Timer
  67. ime As Single
  68.  
  69. Starttrl = ome = Timer
  70. ime As SeeebLirsi