BrowseForFolder (?)

Question

Estou realizando algumas automações em uma pasta de trabalho do Excel (2003), e necessito realizar a seguinte operação:
Exibir para o usuário uma janela para que possa ser selecionado um diretório (local ou rede). O procedimento salvará uma cópia do arquivo no diretório com um nome pre-definido.
A questão de salvamento é tranquila. O problema é que não estou conseguindo armazenar o caminho completo da pasta selecionada.

Utilizei essa forma (http://msdn2.microsoft.com/en-us/library/bb774065(VS.85).aspx):

Private Sub fnShellBrowseForFolderVB()
    Dim objShell   As Shell32.Shell
    Dim ssfWINDOWS As Long
    Dim objFolder  As Shell32.Folder
    
    ssfWINDOWS = 36
    Set objShell = New Shell
        Set objFolder = objShell.BrowseForFolder(0, "Example", 0, ssfWINDOWS)
            If (Not objFolder Is Nothing) Then
                'Add code here
            End If
        Set objFolder = Nothing
    Set objShell = Nothing
End Sub

Se eu selecionar a pasta C:\Documents and Settings\<<Usuario>>\Desktop o valor armazenado será Desktop e não C:\Documents and Settings\<<Usuario>>\Desktop. Como faço para contornar isso?

[]s

Answer 1

Orosolin2,

 

Eu resolvi esta situação escrevendo a rotina que apresento abaixo:

 

Public Function extraiDirPath(inDir As Folder) As String

Dim resultado As String
Dim raiz As String
Dim FolderPai As Folder
Dim i As Long
  '
  ' O principio utilizado para encontrar o nome completo da pasta
  ' está em saber que somente na pasta raiz encontraremos a substring ":".
  ' Nas demais pastas vale a regra que diz que um nome de arquivo ou pasta não pode
  ' conter o caractere ":" (caracteres \ / : * ? " < > | não são permitidos)
  '
  Set FolderPai = inDir
  resultado = ""
  Do
    If Len(FolderPai.Title) = 0 Then Exit Do
    i = InStr(1, FolderPai.Title, ":", vbBinaryCompare)
    If i > 0 Then
      ' FolderPai aponta para raiz do disco
      raiz = Mid$(FolderPai.Title, i - 1, 2)
      resultado = raiz & "\" & resultado
      Exit Do
    Else
      ' FolderPai aponta para uma pasta
      resultado = FolderPai.Title & "\" & resultado
      Set FolderPai = FolderPai.ParentFolder
    End If
  Loop
  extraiDirPath = resultado

 

Para usar no seu código, faça o seguinte:

 

    If (Not objFolder Is Nothing) Then
      ' Add code e ria...
      txt = extraiDirPath(objFolder)  ' string txt recebe path

    End If

Boa sorte.

Answer 2

Segue outra opção para a questão:

Code Snippet

Option Explicit
'API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
  Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) _
  As Long

Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) 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
    iImage As Long
End Type

Dim FilePath

Sub FileInfo()
    Dim c As Long, r As Long, i As Long
    Dim FileName As Object 'FolderItem2
    Dim objShell As Object 'IShellDispatch4
    Dim objFolder As Object 'Folder3
   
'   Create the object
    Set objShell = CreateObject("Shell.Application")
   
'   Prompt for the folder
    Set objFolder = objShell.Namespace(GetDirectory)

    MsgBox FilePath

End Sub

Function GetDirectory(Optional Msg) As String
'   Returns the directory specified by the user
    Dim bInfo As BROWSEINFO
    Dim path As String
    Dim r As Long, x As Long, pos As Integer
    Dim FileName
 

'   Title in the dialog
    If IsMissing(Msg) Then
        bInfo.lpszTitle = "Selecione um diretório."
    Else
        bInfo.lpszTitle = Msg
    End If
   
'   Type of directory to return
    bInfo.ulFlags = &H1

'   Display the dialog
    x = SHBrowseForFolder(bInfo)
   
'   Parse the result
    path = Space$(512)
    r = SHGetPathFromIDList(ByVal x, ByVal path)
    If r Then
        pos = InStr(path, Chr$(0))
        GetDirectory = Left(path, pos - 1)
    Else
        GetDirectory = ""
    End If
    FilePath = GetDirectory
End Function

 

 

[ ]s

 

Answer 3

Code Snippet

 

'************** 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

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 Long
           
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias _
            "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) _
            As Long
           
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 *****************

 

 

 

Answer 4

Obrigado à todos.

Irei testar as opções.

[]s