[Resolvido]Salvar o caminho de uma pasta através da janela de localizar do windows

Ola amigos do Fórum
Atualmente tenho código para capturar o caminho com um arquivo através da janela do windows, mas gostaria de capturar somente o caminho da pasta....seria possível não estou conseguindo adaptar o código abaixo para fazer isto, ele só aceita se eu selecionar um arquivo..
Agradeço ao amigos do fórum !!!

'Codigo Utilizado para capturar o caminho com um arquivo.

Public Function GetMyFile(strTitle As String) As String

Dim OpenFile As OPENFILENAME
Dim lReturn As Long

OpenFile.lpstrFilter = ""
OpenFile.nFilterIndex = 1
OpenFile.hwndOwner = 0
OpenFile.lpstrFile = String(257, 0)
#If VBA7 Then
OpenFile.nMaxFile = LenB(OpenFile.lpstrFile) - 1
OpenFile.lStructSize = LenB(OpenFile)
#Else
OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1
OpenFile.lStructSize = Len(OpenFile)
#End If
OpenFile.lpstrFileTitle = OpenFile.lpstrFile
OpenFile.nMaxFileTitle = OpenFile.nMaxFile
OpenFile.lpstrInitialDir = "C:\"
OpenFile.lpstrTitle = strTitle
OpenFile.flags = 0
lReturn = GetOpenFileName(OpenFile)

If lReturn = 0 Then
GetMyFile = ""
Else
GetMyFile = Trim(Left(OpenFile.lpstrFile, InStr(1, OpenFile.lpstrFile, vbNullChar) - 1))
End If

End Function

Boa tarde,
Fez pesquisa no fórum? https://www.maximoaccess.com/t3084-resolvidoidentificar-nomes-de-pastas-via-codigo-vba

Alexandre Tudo bem !!!

Sim eu vi este Post que você citou, porem não é bem isto ja utilizo a API do Windows para abrir a caixa de Dialogo e selecionar o arquivo, o que eu gostaria é de utilizar esta mesma API mas para selecionar a pasta e não o arquivo, entendeu !
O post citado lista todas a Pasta e Sub Pasta dentro do caminho, no meu caso o caminho da pasta ira retornar na variável onde sera salva em um campo no Formulário..igual acontece quando você seleciona um arquivo.

Somente Respondendo eu fiz uma busca sim, porem não localizei a Utilização desta API que postei...não queria substituir todo o código existente.

Já entendi o que precisa
Já vi aqui no fórum a ter form com árvore de pasta.
Aguardemos que algum colega tenha e venha partilhar

Alexandre vou aguardar algum amigo postar este form....pois seria isto mesmo..mesmo assim agradeço sua atenção e ajuda...caso tenha alguma ideia de como manipular esta API ficarei agradecido..

Abraço !!!
Wellington

Veja este (http://www.ammara.com/)access_image_faq/browse_for_folder_dialog.html

Wellington

Copie e cole a função a seguir num módulo básico.

Código:


Public Function SplitFile(CaminhoCompleto As String, Retorna As Boolean) As String
On Error Resume Next
    Dim Diretório, Arquivo As String
    Dim total As Long
    total = Len(CaminhoCompleto)
    Do While total > 0
        If Mid$(CaminhoCompleto, total, 1) <> "\" Then
            Arquivo = Mid(CaminhoCompleto, total, 1) & Arquivo
            total = total - 1
        Else
            Diretório = Mid(CaminhoCompleto, 1, total)
            Exit Do
        End If
    Loop
    If Retorna = False Then
        SplitFile = Diretório
    Else
        SplitFile = Arquivo
    End If
End Function


Na parte final do teu código, adicione a linha em azul:

If lReturn = 0 Then
GetMyFile = ""
Else
GetMyFile = Trim(Left(OpenFile.lpstrFile, InStr(1, OpenFile.lpstrFile, vbNullChar) - 1))
MinhaPasta = SplitFile( "'" & GetMyFile & "'",False)
End If

End Function

Não esqueça do

Dim MinhaPasta as string

A função Split() retorna o caminho da pasta quando o argumento é False, e o nome do arquivo quando é True.

[ ]'s

Noobezinho tudo bem !!!

Cara foi quase lá rsrsrsrs, voce deu a dica certa porem na função da API  OPENFILENAME ele espera receber um arquivo para abrir na tela do windows o botão é Abrir e não um Ok....por este motivo ele não retorna vazio. veja a tela do windows.
Seria possível utilizar somente o SplitFile para retornar o caminho da pasta assim eu modificaria somente esta parte do código no sistema...eu desconsideraria o retorno pelo GetMyFile ?

Alexandre vou verificar sua sugestão também beleza.
Valeu...

Noobezinho valeu plea dica....aguardo sua resposta aqui também com certeza ira ajudar outros amigos...


Segue o Cogido Completo


Public Function GetMyFile(strTitle As String) As String

   Dim OpenFile    As OPENFILENAME
   Dim lReturn     As Long
   Dim MinhaPasta As String
 
   OpenFile.lpstrFilter = ""
   OpenFile.nFilterIndex = 1
   OpenFile.hwndOwner = 0
   OpenFile.lpstrFile = String(257, 0)
   #If VBA7 Then
       OpenFile.nMaxFile = LenB(OpenFile.lpstrFile) - 1
       OpenFile.lStructSize = LenB(OpenFile)
   #Else
       OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1
       OpenFile.lStructSize = Len(OpenFile)
   #End If
   OpenFile.lpstrFileTitle = OpenFile.lpstrFile
   OpenFile.nMaxFileTitle = OpenFile.nMaxFile
   OpenFile.lpstrInitialDir = "E:\"
   OpenFile.lpstrTitle = strTitle
   OpenFile.flags = 0
   lReturn = GetOpenFileName(OpenFile)
 
   If lReturn = 0 Then
       GetMyFile = ""
   Else
       GetMyFile = Trim(Left(OpenFile.lpstrFile, InStr(1, OpenFile.lpstrFile, vbNullChar) - 1))
       MinhaPasta = SplitFile("'" & GetMyFile & "'", False)
   End If
 
End Function


Public Function SplitFile(CaminhoCompleto As String, Retorna As Boolean) As String
On Error Resume Next
   Dim Diretório, Arquivo As String
   Dim total As Long
   total = Len(CaminhoCompleto)
   Do While total > 0
       If Mid$(CaminhoCompleto, total, 1) <> "\" Then
           Arquivo = Mid(CaminhoCompleto, total, 1) & Arquivo
           total = total - 1
       Else
           Diretório = Mid(CaminhoCompleto, 1, total)
           Exit Do
       End If
   Loop
   If Retorna = False Then
       SplitFile = Diretório
   Else
       SplitFile = Arquivo
   End If
End Function

Atenção amigo do Forum gostaria de agradecer a todos que contribuiram em especial aos amigos Noobezinho e Alexandre...

Alexandre perfeito o site que você indicou, era exatamente o que eu precisava, vou ter que modificar a estrutura do sistema mas pelo menos achamos uma solução, fico feliz de poder contar com os amigos aqui...lembre-se de que vale o conhecimento se você não quiser compartilhar, segue o código completo inclusive com as declarações de API para sistema 32 bts e 64 bts....
Abraço a Todos...


'Em um Modulo Cole este Código
'************** Code Start **************
'This code was originally written by Terry Kreft.
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copyright notice is left unchanged.
'
'Code courtesy of
'Terry Kreft
'
'04/03/2018 - Modificado Por Wellington Araujo
'Incluido API 32 e 64 Bts


#If VBA7 Then

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

Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" Alias _
           "SHGetPathFromIDListA" (ByVal pidl As LongPtr, _
           ByVal pszPath As String) As Boolean
           
Private Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" Alias _
           "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) _
           As LongPtr
           
#Else

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

Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias _
           "SHGetPathFromIDListA" (ByVal pidl As Long, _
           ByVal pszPath As String) As Boolean
           
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias _
           "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) _
           As Long


           
#End If
           
Private Const BIF_RETURNONLYFSDIRS = &H1


Public Function BrowseFolder(szDialogTitle As String) As String
 Dim X As Long, bi As BROWSEINFO, dwIList As Long
 Dim szPath As String, wPos As Integer
 
   With bi
       .hOwner = hWndAccessApp
       .lpszTitle = szDialogTitle
       .ulFlags = BIF_RETURNONLYFSDIRS
   End With
   
   dwIList = SHBrowseForFolder(bi)
   szPath = Space$(512)
   X = SHGetPathFromIDList(ByVal dwIList, ByVal szPath)
   
   If X Then
       wPos = InStr(szPath, Chr(0))
       BrowseFolder = Left$(szPath, wPos - 1)
   Else
       BrowseFolder = vbNullString
   End If
End Function
'*********** Code End *****************

'No seu Formulário em um botão.

'**********************************************************
Dim strFolderName As String
strFolderName = BrowseFolder("Texto na janela do Windows")

   If Len(strFolderName) > 0 Then
       Me!SeuCampo= strFolderName
       ' Do something with the selected folder
   'Else
       'No folder chosen, or user canceled
   End If
'**********************************************************

Wellington

Que bom que resolveu!

Valeu pelo retorno!

Agora, só falta o Resolvido no título do tópico.

Para isso, edite uma mensagem tua e clique no botão Resolvido, ali embaixo da página, no lado direito.

Se tiver dúvida, veja na minha assinatura.

Boa sorte!

Noobezinho estranho no meu não esta aparecendo este Botão de resolvido mais....ja abri em dois navegadores aqui e nada, por que sera...

Eu coloque pra você.

Veja aqui.

A imagem mostra onde o botão Resolvido está na página de edição de mensagens.

[ ]'s