[Resolvido]Abrir função BrowseForFolder em determinada pasta

Amigos, encontrei esta função para abrir pastas e
minha dúvida é se teria como ao abrí-la, ir para uma
determinada pasta, como por exemplo:

D:\Certificado Escritorio Conectividade Social

ou

D:\ArquivosXML

Pois sempre que ela é executada vai para "Meu computador"

Obrigado


Option Compare Database
Option Explicit

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

'Navegando para o diretório..
Private Const BIF_RETURNONLYFSDIRS = &H1 '&H1 'para localizar uma pasta para _
Inicie a pesquisa do documento.
Private Const BIF_DONTGOBELOWDOMAIN = &H2 '&H2 'para iniciar a localizar _
Computador.
Private Const BIF_STATUSTEXT = &H4
Private Const BIF_RETURNFSANCESTORS = &H8

Private Const BIF_BROWSEFORCOMPUTER = &H1000 'navegando para computadores.
Private Const BIF_BROWSEFORPRINTER = &H2000 'navegando para impressoras.
Private Const BIF_BROWSEINCLUDEFILES = &H4000 'navegando para tudo.

Private Const MAX_PATH = 260

Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal _
lpString1 As String, ByVal lpString2 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

Public Function BrowseForFolder(hWndOwner As Long, _
sPrompt As String) As String

'=======================================================
'Abre a caixa de diálogo do sistema para procurar pasta.
'=======================================================
Dim iNull As Integer
Dim lpIDList As Long
Dim lResult As Long
Dim sPath As String
Dim udtBI As BROWSEINFO

With udtBI
.hWndOwner = hWndOwner
.lpszTitle = lstrcat(sPrompt, "")
.ulFlags = BIF_RETURNONLYFSDIRS
End With

lpIDList = SHBrowseForFolder(udtBI)

If lpIDList Then
sPath = String$(MAX_PATH, 0)
lResult = SHGetPathFromIDList(lpIDList, sPath)
Call CoTaskMemFree(lpIDList)
iNull = InStr(sPath, vbNullChar)

If iNull Then
sPath = Left$(sPath, iNull - 1)
End If
End If

BrowseForFolder = sPath

End Function


Para Chamar a função estou usando:

Private Sub cmdLocalizarDiretorio_Click()

Dim MyStr As String
MyStr = BrowseForFolder(0, "Salvar BD em:")


End Sub

Se for somente para abrir uma determinada pasta, como diz no seu título do tópico, não necessita de todo esse código;

Private Sub SeuBotão_Click()
Dim x As Variant
   x = Shell("EXPLORER.EXE D:\Certificado Escritorio Conectividade Social\", vbNormalFocus)
End Sub

JPaulo,
Obrigado pelo seu interesse,
este comando funciona, mas no meu
projeto renomeio alguns arquivos e o caminhho deles é procurado em um formulário
no qual quando chamo esta função fica gravado no formulario o ultimo caminho
percorrido.

Seria como se está função me abrisse na última pasta selecionada, teria como?


Obrigado

Essa API nunca usei, esta sei que funfa;


Num modulo:

Option Explicit

Private Declare Function SHBrowseForFolder Lib "shell32" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, _
ByVal pszPath As String) As Long
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal pv As Long)
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)

Private Declare Function LocalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal uBytes As Long) As Long
Private Declare Function LocalFree Lib "kernel32" (ByVal hMem As Long) As Long

Private Const MAX_PATH = 260

Private Const BIF_RETURNONLYFSDIRS = 1
Private Const BIF_NEWDIALOGSTYLE = &H40

Private Const BFFM_INITIALIZED As Long = 1
Private Const BFFM_SELCHANGED As Long = 2
Private Const BFFM_VALIDATEFAILED As Long = 3

Private Const WM_USER = &H400

Private Const BFFM_SETSTATUSTEXT As Long = (WM_USER + 100)
Private Const BFFM_ENABLEOK As Long = (WM_USER + 101)
Private Const BFFM_SETSELECTION As Long = (WM_USER + 102)

Private Const LMEM_FIXED = &H0
Private Const LMEM_ZEROINIT = &H40

Private Const LPTR = (LMEM_FIXED Or LMEM_ZEROINIT)

Private Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type

Public Function GetFolder(ByVal title As String, ByVal start As String, ByVal newfolder As Boolean) As String
Dim BI As BROWSEINFO, pidl As Long, lpSelPath As Long
Dim spath As String * MAX_PATH

'fill in the info it needs
With BI
.hOwner = GetForegroundWindow
.pidlRoot = 0
.lpszTitle = title
.lpfn = FARPROC(AddressOf BrowseCallbackProcStr)
.ulFlags = BIF_RETURNONLYFSDIRS
If newfolder = True Then .ulFlags = BIF_RETURNONLYFSDIRS + BIF_NEWDIALOGSTYLE
lpSelPath = LocalAlloc(LPTR, Len(start) + 1)
CopyMemory ByVal lpSelPath, ByVal start, Len(start) + 1
.lParam = lpSelPath
End With

'get the idlist long from the returned folder
pidl = SHBrowseForFolder(BI)

'do then if they clicked ok
If pidl Then
If SHGetPathFromIDList(pidl, spath) Then
'next line is the returned folder
GetFolder = Left$(spath, InStr(spath, vbNullChar) - 1)
End If
Call CoTaskMemFree(pidl)
Else
'user clicked cancel
End If

Call LocalFree(lpSelPath)

End Function

Public Function BrowseCallbackProcStr(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lParam As Long, ByVal lpData As Long) As Long
Dim spath As String, bFlag As Long

spath = Space$(MAX_PATH)

Select Case uMsg
Case BFFM_INITIALIZED
Call SendMessage(hWnd, BFFM_SETSELECTION, 1, ByVal lpData)
Case BFFM_SELCHANGED
If SHGetPathFromIDList(lParam, spath) Then
spath = Left(spath, InStr(1, spath, Chr(0)) - 1)
End If
End Select

End Function

Public Function FARPROC(pfn As Long) As Long
FARPROC = pfn
End Function


Para usar num botão do seu formulario:

Private Sub SeuBotão_Click()
    Dim MinhaPasta As String
    MinhaPasta = GetFolder("Salvar BD em:", "D:\ArquivosXML", True)
End Sub

JPaulo,

Mais uma vez obrigado, funfou certinho, como precisava

Valeu mesmo!

Obrigado pelo retorno o forum agradece.