locked
BrowseForFolder (?) RRS feed

  • Pergunta

  • 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
    quinta-feira, 10 de janeiro de 2008 14:33

Todas as Respostas

  • 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.

    terça-feira, 25 de março de 2008 01:33
  • 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

     

    terça-feira, 25 de março de 2008 11:21
  • 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 *****************

     

     

     

    terça-feira, 25 de março de 2008 13:18
    Moderador
  • Obrigado à todos.

    Irei testar as opções.

    []s
    terça-feira, 25 de março de 2008 15:50