I have the API working from (http://www.mvps.org/access/api/api0002.htm). Can
I make the Browse for folder dialog start at a particular folder or unc path
such as \\prt02\projects\?

TIA

Hi,

Here is the module code I wrote to do what you looking for...

'Begin ************************
Option Explicit
Option Private Module

Private Const BIF_STATUSTEXT As Long = &H4&
Private Const BIF_RETURNONLYFSDIRS As Long = 1
Private Const BIF_DONTGOBELOWDOMAIN As Long = 2
Private Const MAX_PATH As Long = 260

Private Const WM_USER As Long = &H400
Private Const BFFM_INITIALIZED As Long = 1
Private Const BFFM_SELCHANGED As Long = 2
Private Const BFFM_SETSTATUSTEXT As Long = (WM_USER +
100)
Private Const BFFM_SETSELECTION As Long = (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
strWinTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type

Private m_strCurrentDirectory As String

Public Function SelectAnyFolder(ByVal WindowTitle As String, ByVal
StartDirectory As String) As String
'---------------------------------------------------------------------------
' Procedure : BrowseForFolder
' DateTime : 14/09/2007
' Author : jp.ambrosino (argyronet)
' Purpose : Sélectionne un dossier dans l'arboresence de répertoires
'...........................................................................
' Parameters : StartDirectory = #
' WindowTitle = Window title
' Return Codes : String = Foldername
'...........................................................................
' Usage : Example
' strPath = SelectAnyFolder("Select a folder from :",
"C:\WINDOWS")
'...........................................................................
' Evolutions : 21/04/2008 Updated for VB6 (JPA)
'---------------------------------------------------------------------------
Dim cFunctions As New clsFunctions
Dim lngReturn As Long
Dim strBufferData As String
Dim tBI As BROWSEINFO

m_strCurrentDirectory = StartDirectory & vbNullChar
With tBI
.hwndOwner = 0
.strWinTitle = lstrcat(WindowTitle, " ")
.ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN +
BIF_STATUSTEXT
.lpfnCallback = GetAddressOfFunction(AddressOf BrowseCallbackProc)
'get address of function.
End With

lngReturn = SHBrowseForFolder(tBI)
If (lngReturn) Then
strBufferData = Space(MAX_PATH)
SHGetPathFromIDList lngReturn, strBufferData
strBufferData = Left$(strBufferData, InStr(strBufferData,
vbNullChar) - 1)
SelectAnyFolder = cFunctions.AddDirSeparator(strBufferData)
Else
SelectAnyFolder = vbNullString
End If
Set cFunctions = Nothing
End Function


Private Function GetAddressOfFunction(Ptr As Long) As Long
'---------------------------------------------------------------------------
' Procedure : GetAddressOfFunction
' DateTime : 14/09/2007 14:52
' Author : jp.ambrosino (argyronet)
' Purpose : Retourne un pointeur de fonction
'...........................................................................
' Parameters : Aucun
' Return Codes : Long = Pointeur de la fonction
'---------------------------------------------------------------------------
GetAddressOfFunction = Ptr
End Function


Private Function BrowseCallbackProc(ByVal Hwnd As Long, ByVal uMsg As Long,
ByVal lp As Long, ByVal pData As Long) As Long
'---------------------------------------------------------------------------
' Procedure : BrowseCallbackProc
' DateTime : 14/09/2007
' Author : jp.ambrosino (argyronet)
' Purpose : Function de callback
'...........................................................................
' Parameters : Aucun
' Return Codes : Long = Callback du process
'---------------------------------------------------------------------------

Dim lngRet As Long
Dim strBufferData As String

' Prevent an error from propagating back into the calling process.
On Error Resume Next
Select Case uMsg

Case BFFM_INITIALIZED
Call SendMessage(Hwnd, BFFM_SETSELECTION, 1,
m_strCurrentDirectory)

Case BFFM_SELCHANGED
strBufferData = Space(MAX_PATH)

lngRet = SHGetPathFromIDList(lp, strBufferData)
If lngRet = eApplicative Then
Call SendMessage(Hwnd, BFFM_SETSTATUSTEXT, 0, strBufferData)
End If

End Select
If Err <> 0 Then Err.Clear
BrowseCallbackProc = 0
End Function

Sub TestToSee()
MsgBox SelectAnyFolder("Your folder...", CurrentProject.Path)
End Sub

'End *************************

Regards,

--
Argy
Goto : http://argyronet.developpez.com/
Livres :
Créez des programmes avec Microsoft Access 2007 (ISBN 2742982442)
VBA pour Office 2007 (ISBN 2742983910)



"Rob Hamlin" wrote:

> I have the API working from (http://www.mvps.org/access/api/api0002.htm). Can
> I make the Browse for folder dialog start at a particular folder or unc path
> such as \\prt02\projects\?
>
> TIA

I get an error "User-Defined type not defined" in this line

Dim cFunctions As New clsFunctions

Any Ideas

"Argyronet" wrote:

> Hi,
>
> Here is the module code I wrote to do what you looking for...
>
> 'Begin ************************
> Option Explicit
> Option Private Module
>
> Private Const BIF_STATUSTEXT As Long = &H4&
> Private Const BIF_RETURNONLYFSDIRS As Long = 1
> Private Const BIF_DONTGOBELOWDOMAIN As Long = 2
> Private Const MAX_PATH As Long = 260
>
> Private Const WM_USER As Long = &H400
> Private Const BFFM_INITIALIZED As Long = 1
> Private Const BFFM_SELCHANGED As Long = 2
> Private Const BFFM_SETSTATUSTEXT As Long = (WM_USER +
> 100)
> Private Const BFFM_SETSELECTION As Long = (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
> strWinTitle As Long
> ulFlags As Long
> lpfnCallback As Long
> lParam As Long
> iImage As Long
> End Type
>
> Private m_strCurrentDirectory As String
>
> Public Function SelectAnyFolder(ByVal WindowTitle As String, ByVal
> StartDirectory As String) As String
> '---------------------------------------------------------------------------
> ' Procedure : BrowseForFolder
> ' DateTime : 14/09/2007
> ' Author : jp.ambrosino (argyronet)
> ' Purpose : Sélectionne un dossier dans l'arboresence de répertoires
> '...........................................................................
> ' Parameters : StartDirectory = #
> ' WindowTitle = Window title
> ' Return Codes : String = Foldername
> '...........................................................................
> ' Usage : Example
> ' strPath = SelectAnyFolder("Select a folder from :",
> "C:\WINDOWS")
> '...........................................................................
> ' Evolutions : 21/04/2008 Updated for VB6 (JPA)
> '---------------------------------------------------------------------------
> Dim cFunctions As New clsFunctions
> Dim lngReturn As Long
> Dim strBufferData As String
> Dim tBI As BROWSEINFO
>
> m_strCurrentDirectory = StartDirectory & vbNullChar
> With tBI
> .hwndOwner = 0
> .strWinTitle = lstrcat(WindowTitle, " ")
> .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN +
> BIF_STATUSTEXT
> .lpfnCallback = GetAddressOfFunction(AddressOf BrowseCallbackProc)
> 'get address of function.
> End With
>
> lngReturn = SHBrowseForFolder(tBI)
> If (lngReturn) Then
> strBufferData = Space(MAX_PATH)
> SHGetPathFromIDList lngReturn, strBufferData
> strBufferData = Left$(strBufferData, InStr(strBufferData,
> vbNullChar) - 1)
> SelectAnyFolder = cFunctions.AddDirSeparator(strBufferData)
> Else
> SelectAnyFolder = vbNullString
> End If
> Set cFunctions = Nothing
> End Function
>
>
> Private Function GetAddressOfFunction(Ptr As Long) As Long
> '---------------------------------------------------------------------------
> ' Procedure : GetAddressOfFunction
> ' DateTime : 14/09/2007 14:52
> ' Author : jp.ambrosino (argyronet)
> ' Purpose : Retourne un pointeur de fonction
> '...........................................................................
> ' Parameters : Aucun
> ' Return Codes : Long = Pointeur de la fonction
> '---------------------------------------------------------------------------
> GetAddressOfFunction = Ptr
> End Function
>
>
> Private Function BrowseCallbackProc(ByVal Hwnd As Long, ByVal uMsg As Long,
> ByVal lp As Long, ByVal pData As Long) As Long
> '---------------------------------------------------------------------------
> ' Procedure : BrowseCallbackProc
> ' DateTime : 14/09/2007
> ' Author : jp.ambrosino (argyronet)
> ' Purpose : Function de callback
> '...........................................................................
> ' Parameters : Aucun
> ' Return Codes : Long = Callback du process
> '---------------------------------------------------------------------------
>
> Dim lngRet As Long
> Dim strBufferData As String
>
> ' Prevent an error from propagating back into the calling process.
> On Error Resume Next
> Select Case uMsg
>
> Case BFFM_INITIALIZED
> Call SendMessage(Hwnd, BFFM_SETSELECTION, 1,
> m_strCurrentDirectory)
>
> Case BFFM_SELCHANGED
> strBufferData = Space(MAX_PATH)
>
> lngRet = SHGetPathFromIDList(lp, strBufferData)
> If lngRet = eApplicative Then
> Call SendMessage(Hwnd, BFFM_SETSTATUSTEXT, 0, strBufferData)
> End If
>
> End Select
> If Err <> 0 Then Err.Clear
> BrowseCallbackProc = 0
> End Function
>
> Sub TestToSee()
> MsgBox SelectAnyFolder("Your folder...", CurrentProject.Path)
> End Sub
>
> 'End *************************
>
> Regards,
>
> --
> Argy
> Goto : http://argyronet.developpez.com/
> Livres :
> Créez des programmes avec Microsoft Access 2007 (ISBN 2742982442)
> VBA pour Office 2007 (ISBN 2742983910)
>
>
>
> "Rob Hamlin" wrote:
>
> > I have the API working from (http://www.mvps.org/access/api/api0002.htm). Can
> > I make the Browse for folder dialog start at a particular folder or unc path
> > such as \\prt02\projects\?
> >
> > TIA

On 21/04/2010 18:58, Rob Hamlin wrote:
> I have the API working from (http://www.mvps.org/access/api/api0002.htm). Can
> I make the Browse for folder dialog start at a particular folder or unc path
> such as \\prt02\projects\?

Save your time!!!

If working in Office 2002 (XP) or newer, there is the FileDialog object.
It includes an 'InitialFileName' property which also can be pointed at a
folder.

INFO: The Microsoft Office XP FileDialog Object
http://support.microsoft.com/kb/288543

--
Adrian C

Ooops sorry, that was my own classes functions. I just copied it here without
looking with details because it was running well in the projet I'm working on.

Here the corrected code :
'Begin ************************
Option Explicit
Option Private Module

Private Const BIF_STATUSTEXT As Long = &H4&
Private Const BIF_RETURNONLYFSDIRS As Long = 1
Private Const BIF_DONTGOBELOWDOMAIN As Long = 2
Private Const MAX_PATH As Long = 260

Private Const WM_USER As Long = &H400
Private Const BFFM_INITIALIZED As Long = 1
Private Const BFFM_SELCHANGED As Long = 2
Private Const BFFM_SETSTATUSTEXT As Long = (WM_USER +
100)
Private Const BFFM_SETSELECTION As Long = (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
strWinTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type

Private m_strCurrentDirectory As String

Public Function SelectAnyFolder(ByVal WindowTitle As String, ByVal
StartDirectory As String) As String
'---------------------------------------------------------------------------
' Procedure : BrowseForFolder
' DateTime : 14/09/2007
' Author : jp.ambrosino (argyronet)
' Purpose : Sélectionne un dossier dans l'arboresence de répertoires
'...........................................................................
' Parameters : StartDirectory = #
' WindowTitle = Window title
' Return Codes : String = Foldername
'...........................................................................
' Usage : Example
' strPath = SelectAnyFolder("Select a folder from
:","C:\WINDOWS")
'...........................................................................
' Evolutions : 21/04/2008 Updated for VB6 (JPA)
'---------------------------------------------------------------------------
Dim lngReturn As Long
Dim strBufferData As String
Dim tBI As BROWSEINFO

m_strCurrentDirectory = StartDirectory & vbNullChar
With tBI
.hwndOwner = 0
.strWinTitle = lstrcat(WindowTitle, " ")
.ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN +
BIF_STATUSTEXT
.lpfnCallback = GetAddressOfFunction(AddressOf BrowseCallbackProc)
'get address of function.
End With

lngReturn = SHBrowseForFolder(tBI)
If (lngReturn) Then
strBufferData = Space(MAX_PATH)
SHGetPathFromIDList lngReturn, strBufferData
strBufferData = Left$(strBufferData, InStr(strBufferData,
vbNullChar) - 1)
SelectAnyFolder = strBufferData & "\"
Else
SelectAnyFolder = vbNullString
End If
End Function


Private Function GetAddressOfFunction(Ptr As Long) As Long
'---------------------------------------------------------------------------
' Procedure : GetAddressOfFunction
' DateTime : 14/09/2007 14:52
' Author : jp.ambrosino (argyronet)
' Purpose : Retourne un pointeur de fonction
'...........................................................................
' Parameters : Aucun
' Return Codes : Long = Pointeur de la fonction
'---------------------------------------------------------------------------
GetAddressOfFunction = Ptr
End Function


Private Function BrowseCallbackProc(ByVal Hwnd As Long, ByVal uMsg As Long,
ByVal lp As Long, ByVal pData As Long) As Long
'---------------------------------------------------------------------------
' Procedure : BrowseCallbackProc
' DateTime : 14/09/2007
' Author : jp.ambrosino (argyronet)
' Purpose : Function de callback
'...........................................................................
' Parameters : Aucun
' Return Codes : Long = Callback du process
'---------------------------------------------------------------------------

Dim lngRet As Long
Dim strBufferData As String

' Prevent an error from propagating back into the calling process.
On Error Resume Next
Select Case uMsg

Case BFFM_INITIALIZED
Call SendMessage(Hwnd, BFFM_SETSELECTION, 1,
m_strCurrentDirectory)

Case BFFM_SELCHANGED
strBufferData = Space(MAX_PATH)

lngRet = SHGetPathFromIDList(lp, strBufferData)
If lngRet = 0 Then
Call SendMessage(Hwnd, BFFM_SETSTATUSTEXT, 0, strBufferData)
End If

End Select
If Err <> 0 Then Err.Clear
BrowseCallbackProc = 0
End Function

Sub TestToSee()
MsgBox SelectAnyFolder("Your folder...", CurrentProject.Path)
End Sub

'End *************************

Regards
--
Argy
Goto : http://argyronet.developpez.com/
Livres :
Créez des programmes avec Microsoft Access 2007 (ISBN 2742982442)
VBA pour Office 2007 (ISBN 2742983910)



"Rob Hamlin" wrote:

> I get an error "User-Defined type not defined" in this line
>
> Dim cFunctions As New clsFunctions
>
> Any Ideas
>
> "Argyronet" wrote:
>
> > Hi,
> >
> > Here is the module code I wrote to do what you looking for...
> >
> > 'Begin ************************
> > Option Explicit
> > Option Private Module
> >
> > Private Const BIF_STATUSTEXT As Long = &H4&
> > Private Const BIF_RETURNONLYFSDIRS As Long = 1
> > Private Const BIF_DONTGOBELOWDOMAIN As Long = 2
> > Private Const MAX_PATH As Long = 260
> >
> > Private Const WM_USER As Long = &H400
> > Private Const BFFM_INITIALIZED As Long = 1
> > Private Const BFFM_SELCHANGED As Long = 2
> > Private Const BFFM_SETSTATUSTEXT As Long = (WM_USER +
> > 100)
> > Private Const BFFM_SETSELECTION As Long = (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
> > strWinTitle As Long
> > ulFlags As Long
> > lpfnCallback As Long
> > lParam As Long
> > iImage As Long
> > End Type
> >
> > Private m_strCurrentDirectory As String
> >
> > Public Function SelectAnyFolder(ByVal WindowTitle As String, ByVal
> > StartDirectory As String) As String
> > '---------------------------------------------------------------------------
> > ' Procedure : BrowseForFolder
> > ' DateTime : 14/09/2007
> > ' Author : jp.ambrosino (argyronet)
> > ' Purpose : Sélectionne un dossier dans l'arboresence de répertoires
> > '...........................................................................
> > ' Parameters : StartDirectory = #
> > ' WindowTitle = Window title
> > ' Return Codes : String = Foldername
> > '...........................................................................
> > ' Usage : Example
> > ' strPath = SelectAnyFolder("Select a folder from :",
> > "C:\WINDOWS")
> > '...........................................................................
> > ' Evolutions : 21/04/2008 Updated for VB6 (JPA)
> > '---------------------------------------------------------------------------
> > Dim cFunctions As New clsFunctions
> > Dim lngReturn As Long
> > Dim strBufferData As String
> > Dim tBI As BROWSEINFO
> >
> > m_strCurrentDirectory = StartDirectory & vbNullChar
> > With tBI
> > .hwndOwner = 0
> > .strWinTitle = lstrcat(WindowTitle, " ")
> > .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN +
> > BIF_STATUSTEXT
> > .lpfnCallback = GetAddressOfFunction(AddressOf BrowseCallbackProc)
> > 'get address of function.
> > End With
> >
> > lngReturn = SHBrowseForFolder(tBI)
> > If (lngReturn) Then
> > strBufferData = Space(MAX_PATH)
> > SHGetPathFromIDList lngReturn, strBufferData
> > strBufferData = Left$(strBufferData, InStr(strBufferData,
> > vbNullChar) - 1)
> > SelectAnyFolder = cFunctions.AddDirSeparator(strBufferData)
> > Else
> > SelectAnyFolder = vbNullString
> > End If
> > Set cFunctions = Nothing
> > End Function
> >
> >
> > Private Function GetAddressOfFunction(Ptr As Long) As Long
> > '---------------------------------------------------------------------------
> > ' Procedure : GetAddressOfFunction
> > ' DateTime : 14/09/2007 14:52
> > ' Author : jp.ambrosino (argyronet)
> > ' Purpose : Retourne un pointeur de fonction
> > '...........................................................................
> > ' Parameters : Aucun
> > ' Return Codes : Long = Pointeur de la fonction
> > '---------------------------------------------------------------------------
> > GetAddressOfFunction = Ptr
> > End Function
> >
> >
> > Private Function BrowseCallbackProc(ByVal Hwnd As Long, ByVal uMsg As Long,
> > ByVal lp As Long, ByVal pData As Long) As Long
> > '---------------------------------------------------------------------------
> > ' Procedure : BrowseCallbackProc
> > ' DateTime : 14/09/2007
> > ' Author : jp.ambrosino (argyronet)
> > ' Purpose : Function de callback
> > '...........................................................................
> > ' Parameters : Aucun
> > ' Return Codes : Long = Callback du process
> > '---------------------------------------------------------------------------
> >
> > Dim lngRet As Long
> > Dim strBufferData As String
> >
> > ' Prevent an error from propagating back into the calling process.
> > On Error Resume Next
> > Select Case uMsg
> >
> > Case BFFM_INITIALIZED
> > Call SendMessage(Hwnd, BFFM_SETSELECTION, 1,
> > m_strCurrentDirectory)
> >
> > Case BFFM_SELCHANGED
> > strBufferData = Space(MAX_PATH)
> >
> > lngRet = SHGetPathFromIDList(lp, strBufferData)
> > If lngRet = eApplicative Then
> > Call SendMessage(Hwnd, BFFM_SETSTATUSTEXT, 0, strBufferData)
> > End If
> >
> > End Select
> > If Err <> 0 Then Err.Clear
> > BrowseCallbackProc = 0
> > End Function
> >
> > Sub TestToSee()
> > MsgBox SelectAnyFolder("Your folder...", CurrentProject.Path)
> > End Sub
> >
> > 'End *************************
> >
> > Regards,
> >
> > --
> > Argy
> > Goto : http://argyronet.developpez.com/
> > Livres :
> > Créez des programmes avec Microsoft Access 2007 (ISBN 2742982442)
> > VBA pour Office 2007 (ISBN 2742983910)
> >
> >
> >
> > "Rob Hamlin" wrote:
> >
> > > I have the API working from (http://www.mvps.org/access/api/api0002.htm). Can
> > > I make the Browse for folder dialog start at a particular folder or unc path
> > > such as \\prt02\projects\?
> > >
> > > TIA