home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / CommonDial18020462001.psc / ModBrowse.bas < prev    next >
Encoding:
BASIC Source File  |  2001-04-07  |  4.7 KB  |  116 lines
  1. Attribute VB_Name = "ModBrowse"
  2. 'This module is the standard Browse for Folder with a few changes
  3. 'to the BrowseCallbackProc function in order to locate the position
  4. 'of the buttons so our button/checkbox will line up
  5. Option Explicit
  6. Private Const BIF_STATUSTEXT = &H4&
  7. Private Const BIF_RETURNONLYFSDIRS = 1
  8. Private Const BIF_DONTGOBELOWDOMAIN = 2
  9. Private Const MAX_PATH = 260
  10. Private Const WM_USER = &H400
  11. Private Const BFFM_INITIALIZED = 1
  12. Private Const BFFM_SELCHANGED = 2
  13. Private Const BFFM_SETSTATUSTEXT = (WM_USER + 100)
  14. Private Const BFFM_SETSELECTION = (WM_USER + 102)
  15. Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
  16. Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
  17. Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
  18. Const GW_NEXT = 2
  19. Const GW_CHILD = 5
  20. Public Type RECT
  21.     Left As Long
  22.     Top As Long
  23.     Right As Long
  24.     Bottom As Long
  25. End Type
  26. Private Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
  27. Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
  28. Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
  29. Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
  30. Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
  31. Private Type BrowseInfo
  32.   hwndOwner      As Long
  33.   pIDLRoot       As Long
  34.   pszDisplayName As Long
  35.   lpszTitle      As Long
  36.   ulFlags        As Long
  37.   lpfnCallback   As Long
  38.   lParam         As Long
  39.   iImage         As Long
  40. End Type
  41. Private m_CurrentDirectory As String
  42. 'Public variables to broadcast info to other mods
  43. Public LetsRecurse As Boolean 'User wants recursion
  44. Public BFhwnd As Long 'handle of the dialog
  45. Public butTop As Integer 'Position of the top of the dialogs' buttons
  46. Public Arestart As Boolean 'We made a new folder and are relaunching the dialog
  47. Dim R As RECT, Bt As RECT
  48. Public Function BrowseForFolder(StartDir As String, owner As Long, Title As String) As String
  49. 'Standard call for the dialog
  50.   Dim lpIDList As Long
  51.   Dim szTitle As String
  52.   Dim sBuffer As String
  53.   Dim tBrowseInfo As BrowseInfo
  54.   m_CurrentDirectory = StartDir & vbNullChar
  55.   szTitle = Title
  56.   With tBrowseInfo
  57.     .hwndOwner = owner
  58.     .lpszTitle = lstrcat(szTitle, "")
  59.     .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN + BIF_STATUSTEXT
  60.     .lpfnCallback = GetAddressofFunction(AddressOf BrowseCallbackProc)
  61.   End With
  62.   lpIDList = SHBrowseForFolder(tBrowseInfo)
  63.   If (lpIDList) Then
  64.     sBuffer = Space(MAX_PATH)
  65.     SHGetPathFromIDList lpIDList, sBuffer
  66.     sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
  67.     BrowseForFolder = sBuffer
  68.   Else
  69.     BrowseForFolder = ""
  70.   End If
  71. End Function
  72. Private Function BrowseCallbackProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal lp As Long, ByVal pData As Long) As Long
  73. Dim lpIDList As Long
  74. Dim Ret As Long
  75. Dim hwnda As Long, ClWind As String * 7
  76. Dim sBuffer As String
  77. On Error Resume Next
  78. BFhwnd = hwnd
  79. Select Case uMsg
  80.   Case BFFM_INITIALIZED
  81.     'If we are relaunching the dialog we want to use the existing
  82.     'RECT to position it otherwise get new values
  83.     If Not Arestart Then getBFSizePos hwnd
  84.     Call MoveWindow(hwnd, R.Left, R.Top, R.Right - R.Left, R.Bottom - R.Top, True)
  85.     Call SendMessage(hwnd, BFFM_SETSELECTION, 1, m_CurrentDirectory)
  86.         'Lets go through all the dialogs' children till we find a Button
  87.         hwnda = GetWindow(hwnd, GW_CHILD)
  88.         Do While hwnda <> 0
  89.             GetClassName hwnda, ClWind, 7
  90.             If Left(ClWind, 6) = "Button" Then
  91.                 Call GetWindowRect(hwnda, Bt)
  92.                 butTop = Bt.Top - R.Top
  93.                 Exit Do
  94.             End If
  95.             hwnda = GetWindow(hwnda, GW_NEXT)
  96.         Loop
  97.   
  98.   Case BFFM_SELCHANGED
  99.     'Make the status text show the selected folder
  100.     sBuffer = Space(MAX_PATH)
  101.     Ret = SHGetPathFromIDList(lp, sBuffer)
  102.     If Ret = 1 Then
  103.       Call SendMessage(hwnd, BFFM_SETSTATUSTEXT, 0, sBuffer)
  104.       m_CurrentDirectory = sBuffer
  105.     End If
  106. End Select
  107. BrowseCallbackProc = 0
  108. End Function
  109. Private Function GetAddressofFunction(add As Long) As Long
  110.   GetAddressofFunction = add
  111. End Function
  112. Public Sub getBFSizePos(hwnd As Long)
  113. 'Where's the window ?
  114.  Call GetWindowRect(hwnd, R)
  115. End Sub
  116.