kiranreddys.com
Kiran's personal website
Blog    Forums   Sitemap   Social    Phone
 
     

 
Knowledgebase
 
Home
Knowledge base home, and site home.
Categories
List of all Knowledge base categories.
Glossary
An alphabetical list of technical terms.
Contact Me
Contact me for knowledge base questions
My Blog
My articles, white papers, ideas and thoughts.
 

 
 


Folder Dialog Box

Date Added January 1, 1970 | Print | Bookmark
'Code by Kiran Reddy
'Folder Dialog Box
'Common Dialog Box does not provide you Folder Dialog Box to select a folder.
'You can create it using DriveListBox and DirectoryListBox on a Form but it does not look good; following code is the best solution, it creates Folder Path Dialog box

'Add following code in your form's command button click event
Private Sub Command1_Click()

Text1.Text = GetFolderPath(Me)
End Sub


'Add following API code in your module
Option Explicit
Public Declare Function SHBrowseForFolder Lib "shell32.dll" (lpBrowseInfo As BROWSEINFO) As Long
Public Declare Function SHGetPathFromIDList Lib "shell32.dll" (ByVal pidl As Long, ByVal pszPath As String) As Long
Public Type BROWSEINFO
howner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
lImage As Long
End Type
Public bi As BROWSEINFO
Public pidl As Long
Public gMyFolder As String

'To release the memory
Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
Public Const LMEM_FIXED = &H0
Public Const LMEM_ZEROINIT = &H40
Public Const LPTR = (LMEM_FIXED Or LMEM_ZEROINIT)

'Send a message
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Const BFFM_INITIALIZED = 1
Public Const BFFM_SELECTIONCHANGED = 2

'Allocate and free space
Public Declare Function LocalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal uBytes As Long) As Long
Public Declare Function LocalFree Lib "kernel32" (ByVal hMem As Long) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)

Public Const MAX_PATH = 260
Public Const WM_USER = &H400
Public Const BFFM_SETSELECTIONA As Long = (WM_USER + 102)
Public Const BFFM_SETSELECTIONW As Long = (WM_USER + 103)

Private Function BrowseCallbackProcStr(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lParam As Long, ByVal lpData As Long) As Long

Select Case uMsg
Case BFFM_INITIALIZED
Call SendMessage(hWnd, BFFM_SETSELECTIONA, _
True, ByVal lpData)
Case Else:
End Select
End Function

Private Function FARPROC(ByVal pfn As Long) As Long

FARPROC = pfn
End Function

Public Function GetFolderPath(frm As Form, Optional DefaultFolder As String = "C:\\") As String

Dim lpSelPath As Long
Dim sPath As String * MAX_PATH
Dim pidl As Long
Dim iNull As Integer
Dim strFolderPath As String

'Get the folder .
If Right(DefaultFolder, 1) <> "\\" Then
sPath = DefaultFolder & "\\"
Else
sPath = DefaultFolder
End If

lpSelPath = LocalAlloc(LPTR, Len(sPath) + 1)
CopyMemory ByVal lpSelPath, ByVal sPath, Len(sPath) + 1

With bi
If IsNumeric(frm.hWnd) Then .howner = frm.hWnd
.pidlRoot = 0
.lpfn = FARPROC(AddressOf BrowseCallbackProcStr)
.lParam = lpSelPath
.lpszTitle = "Select a Registered File folder:" & Chr$(0)
End With

pidl = SHBrowseForFolder(bi)
If pidl Then
If SHGetPathFromIDList(pidl, sPath) Then
strFolderPath = Trim(sPath)
If InStr(strFolderPath, vbNullChar) Then
strFolderPath = Left$(strFolderPath, Len(strFolderPath) - 1)
End If
End If
CoTaskMemFree pidl
End If
LocalFree lpSelPath

GetFolderPath = strFolderPath

End Function

Was this article helpful?

Yes No

Category: VB API

Last updated on January 1, 1970 with 3345 views

0 User Comments

There are no comments yet...Kick things off by filling out the form below.

Leave a Comment

CAPTCHA Image
Security code

 



Home | About Me | Products | Support | Contact | Knowledgebase | Forums | Blog | Site map | Site Search | Subscribe | Links | Social | News

Travel | Guest Book | All Pages | History | Site Calendar | Recipes | Ex-Rates | UK Stuff | Downloads | Telugu Stuff | Tell a Friend | Feedback

Bookmark and Share
www.kiranreddys.com
Terms of Use
Site contents Copyright © 2008-2009 Kiran Reddy. All rights reserved.