Inquiridor
BrowseForFolder (?)

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?
[]squinta-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 = resultadoPara 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 IfBoa sorte.
terça-feira, 25 de março de 2008 01:33 -
Segue outra opção para a questão:
Code SnippetOption Explicit
'API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) _
As LongDeclare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As LongPublic 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 TypeDim 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 KreftPrivate 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 TypePrivate 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:18Moderador -
Obrigado à todos.
Irei testar as opções.
[]sterça-feira, 25 de março de 2008 15:50