• Home
 · 
• Windows API Call/Explanation
 · 
• This program displays a window through which the user can select a folder.The next time the user op

This program displays a window through which the user can select a folder.The next time the user op

This program displays a window through which the user can select a folder.The next time the user opens this window again, the user is taken to

Rate This program displays a window through which the user can select a folder.The next time the user op

• 1
• 2
• 3
• 4
• 5

(1(1 Vote))

Option Explicit

'--------------Start "browse for folder" declarations------------
Private Const BIF_STATUSTEXT = &H4&
Private Const BIF_RETURNONLYFSDIRS = 1

Private Const MAX_PATH = 260

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 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
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long

Private 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 Type FILETIME
        dwLowDateTime As Long
        dwHighDateTime As Long
End Type


Private m_CurrentDirectory As String   'The current directory
'-----End "Browse for folder" declarations----

'-------------Handle "browser for folder dialog----------
Public Function BrowseForFolder(ByVal lngHandle_IN As Long, Title As String, StartDir As String) As String
  'Opens a Treeview control that displays the directories in a computer

  Dim lpIDList As Long
  Dim szTitle As String
  Dim sBuffer As String
  Dim tBrowseInfo As BrowseInfo
  
  
  m_CurrentDirectory = StartDir & vbNullChar
    
  szTitle = ""
  
  With tBrowseInfo
    .hWndOwner = lngHandle_IN
    .ulFlags = BIF_RETURNONLYFSDIRS + BIF_STATUSTEXT
    .lpfnCallback = GetAddressofFunction(AddressOf BrowseCallbackProc)  'get address of function.
  End With

  lpIDList = SHBrowseForFolder(tBrowseInfo)
        
  If (lpIDList) Then
    sBuffer = Space(MAX_PATH)
    SHGetPathFromIDList lpIDList, sBuffer
    sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
    BrowseForFolder = sBuffer
  Else
    BrowseForFolder = ""
  End If
  
End Function

Private Function BrowseCallbackProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal lp As Long, ByVal pData As Long) As Long
  
  Dim lpIDList As Long
  Dim ret As Long
  Dim sBuffer As String
  
  On Error Resume Next  'Sugested by MS to prevent an error from propagating back into the calling process.  
    
  Select Case uMsg
    
    Case BFFM_INITIALIZED
      
      Call SendMessage(hwnd, BFFM_SETSELECTION, 1, m_CurrentDirectory)

    Case BFFM_SELCHANGED
      
      sBuffer = Space(MAX_PATH)

      ret = SHGetPathFromIDList(lp, sBuffer)
      
      If ret = 1 Then
        Call SendMessage(hwnd, BFFM_SETSTATUSTEXT, 0, sBuffer)
      End If

  End Select
  
  BrowseCallbackProc = 0
  
End Function

' This function allows you to assign a function pointer to a vaiable.
Private Function GetAddressofFunction(add As Long) As Long
  GetAddressofFunction = add
End Function
---------------------------------------------------------------------------------------------------------------------------
UserConrol1 : UserContro1l.ctl
Option Explicit

Public Event GetPath()

'Default Property Values:
Const m_def_DefaultPath = ""

'Property Variables:
Dim m_DefaultPath As String

Private Sub cmdBrowse_Click()
    SelectPath
    RaiseEvent GetPath
    txtPath.SetFocus
End Sub
Private Sub txtPath_GotFocus()
    HighLightText
End Sub
Private Sub txtPath_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 And Trim(txtPath.Text) <> "" Then
        Call SelectPath
        RaiseEvent GetPath
    End If
End Sub
'Initialize Properties for User Control
Private Sub UserControl_InitProperties()
On Error GoTo InitializeError
    
    m_DefaultPath = m_def_DefaultPath
    UserControl.Height = txtPath.Height
    
    Exit Sub
InitializeError:

    'ActiveX Component Cant Create Object Error
    
    'If Err.Number = 429 Then
     MsgBox "Required files may be missing!!!" & vbCrLf & "Error Desription : " & Err.Description, vbCritical + vbOKOnly, "Error"
     
    'End If
    
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    m_DefaultPath = PropBag.ReadProperty("DefaultPath", m_def_DefaultPath)
End Sub

Private Sub UserControl_Resize()
    ResizeControls
End Sub
Private Sub SelectPath()
On Error GoTo errHandlerSection
Dim sPath As String
        
    sPath = BrowseForFolder(UserControl.hwnd, "Select Path", DefaultPath)
    If sPath <> "" Then
        DefaultPath = sPath
    End If
    
    Exit Sub
errHandlerSection:
    MsgBox "Cannot select the path." & vbCrLf & "Error Description : " & Err.Description, vbCritical + vbOKOnly, "Error"
End Sub

Private Sub ResizeControls()

On Error Resume Next
    
    'Set the TextBox's Left/Top/Height/Width Properties
    txtPath.Top = 0
    txtPath.Left = 0
    txtPath.Height = UserControl.Height
    txtPath.Width = UserControl.Width - cmdBrowse.Width

    'Set the Command Buttons Left/Top/Height/Width Properties
    cmdBrowse.Top = 0
    cmdBrowse.Left = UserControl.Width - cmdBrowse.Width
    cmdBrowse.Height = txtPath.Height

End Sub
Private Sub HighLightText()
    txtPath.SelStart = 0
    txtPath.SelLength = Len(txtPath.Text)
End Sub
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=13,0,0,
Public Property Get DefaultPath() As String
    DefaultPath = m_DefaultPath
End Property

Public Property Let DefaultPath(ByVal New_DefaultPath As String)
    m_DefaultPath = New_DefaultPath
    PropertyChanged "DefaultPath"
End Property

---------------------------------------------------------------------------------------------------------------------------
Property Page : BrowsePropPage.pag

Option Explicit
Private Sub txtDefaultPath_Change()
    Changed = True
End Sub


Private Sub PropertyPage_ApplyChanges()
    SelectedControls(0).DefaultPath = txtDefaultPath.Text
End Sub



Private Sub PropertyPage_SelectionChanged()
    txtDefaultPath.Text = SelectedControls(0).DefaultPath
End Sub
---------------------------------------------------------------------------------------------------------------------------