Fala aí feras, sou eu novamente!

Pesquisei no fórum mas não achei nada que atenda o que preciso. Achei até um site com vários exemplos, porem a maioria deles foi feito em VB e eu preciso que seja feito no access.

Seguinte:
Como eu poderia conseguir no access obter o endereço de todar árvore de diretórios?
Vou explicar melhor:
No DOS se eu digitar "tree" ele me traz toda a árvore do diretório desejado (contendo pastas e subpastas). Queria saber como fazer isto no Access. Encontrei um exemplo que faz isto do próprio access, ou seja, mostra a árvores dos objetos existentes. Achei interessante, mas o que preciso e que me mostre de um diretório escolhido. Entenderam. Alguem pode me ajudar???

Sub List(strOrigem As String)
Dim objFso As FileSystemObject
Dim objFolder As Object
Dim objSubFolder As Object
Dim objFile As Object
    
    Set objFso = New FileSystemObject
    Set objFolder = objFso.GetFolder(strOrigem)
    For Each objSubFolder In objFolder.SubFolders
        For Each objFile In objSubFolder.Files
            Debug.Print objFile.Path
        Next
    Next
    Set objFso = Nothing
    
End Sub

Rogério,

Em primeiro lugar obrigado pela presteza e rapidez. Mas não está trazendo todos os diretórios. Primeiro estava dando um erro, então eu consertei e ficou assim:

Function List(strOrigem As String)
Dim bd As Database
Dim ds As Recordset
Dim objFso, d, s
Dim objFolder As Object
Dim objSubFolder As Object
Dim objFile As Object

Set bd = CurrentDb()
Set ds = bd.OpenRecordset("Afsdvs")

Set objFso = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFso.GetFolder(strOrigem)
For Each objSubFolder In objFolder.SubFolders
For Each objFile In objSubFolder.Files
ds.AddNew
ds!nome = objFile.Path
ds.Update
Next
Next
Set objFso = Nothing
End Function

Function procura()
List ("c:\")
End Function

Só que não traz todos mundo... por exemplo: "arquivos de programas" ele não traz. Poderia me ajudar??

Acho que voce quer somente os diretórios

Function List(strOrigem As String)
Dim bd As DataBase
Dim ds As RecordSet
Dim objFso, d, s
Dim objFolder As Object
Dim objSubFolder As Object
Dim objFile As Object

    Set bd = CurrentDb()
    Set ds = bd.OpenRecordset("Afsdvs")
    Set objFso = CreateObject("Scripting.FileSystemObject")
    Set objFolder = objFso.GetFolder(strOrigem)
    For Each objSubFolder In objFolder.SubFolders
        'For Each objFile In objSubFolder.Files
            ds.AddNew
            ds!nome = objSubFolder    'objFile.Path
            ds.Update
        'Next
    Next
    Set objFso = Nothing
End Function

Nao sei exatamento o que vc pretente, mas se o seu objetivo e selecionar um diretorio crie um modulo por exemplo FindFolder.

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

'Browsing for directory.
Private Const BIF_RETURNONLYFSDIRS = &H1 'For finding a folder to _
start document searching.
Private Const BIF_DONTGOBELOWDOMAIN = &H2 'For starting the Find _
Computer.
Private Const BIF_STATUSTEXT = &H4
Private Const BIF_RETURNFSANCESTORS = &H8

Private Const BIF_BROWSEFORCOMPUTER = &H1000 'Browsing for Computers.
Private Const BIF_BROWSEFORPRINTER = &H2000 'Browsing for Printers.
Private Const BIF_BROWSEINCLUDEFILES = &H4000 'Browsing for Everything.

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



'On Click
'Dim MyStr As String
'MyStr = BrowseForFolder(Me.hwnd, _
' "Select Folder")
'If Len(MyStr) > 0 Then
' MsgBox "A sua escolha foi:" & vbCrLf _
' & MyStr, vbOKOnly, "BrowseForFolder"
'End If



Vanderlei S. Matheus

Mas se seu objectivo e selecionar um arquivo, crie Class Module clsAbrirSalvarArquivo e copie.

Option Compare Database
Option Explicit

' Este módulo classe contém rotinas para
' ativar as caixas de diálogo padrão "Abrir Arquivo"
' e "Salvar Como" do Windows 95/98/NT 4.0/2000/XP.
' Ver Obs. quanto ao Windows 2000.

' A estrutura OPENFILENAME serve tanto para passar parâmetros
' de configuração como para receber o nome do arquivo selecionado
' pelo usuário na caixa de diálogo "Abrir Arquivo" do Windows.

'Observação quanto ao Windows 2000:
' Na estrutura abaixo, sempre coloque & vbNullChar após as strings.

Private Type OPENFILENAME
lStructSize As Long 'O tamanho em bytes da estrutura.
hWndOwner As Long 'Handle da janela abrindo a caixa de diálogo.
hInstance As Long 'Handle do bloco de memória usado pelo template. O valor 0 significa a caixa de diálogo padrão.
lpstrFilter As String 'As entradas da caixa de combinação File Type.
'O formato da string é: "nome da extensão" & vbNullChar
'& "máscara" & vbNullChar ... para quantos tipos quiser,
'onde o nome da extensão é o texto que aparece na lista e "máscara" é o tipo de arquivo (extensão).
'A string deve terminar com um duplo vbNullChar.
lpstrCustomFilter As String 'Similar a lpstrFilter, mas contém apenas um par de file type name/mask que especifica um file type definido pelo usuário. Se não usado, defina como uma string vazia ("").
nMaxCustFilter As Long 'Tamanho em bytes de lpstrCustomFilter.
nFilterIndex As Long 'Índice 1, 2 etc para lpstrFilter.
lpstrFile As String 'Defina como uma série de espaços em branco.
nMaxFile As Long 'O comprimento em caracteres de lpstrFile.
lpstrFileTitle As String 'Muito similar a lpstrFile, mas apenas recebe o filename do arquivo selecionado.
nMaxFileTitle As Long 'O comprimento em caracteres de lpstrFileTitle.
lpstrInitialDir As String 'O diretório default para pesquisar.
lpstrTitle As String 'Texto que aparece na barra de título da caixa.
flags As Long 'Flags de configuração da caixa.
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type

' GetOpenFileName abre a caixa de diálogo padrão "Abrir Arquivo"
' do Windows, conforme os parâmetros de configuração passados no
' argumento pOpenfilename. A função retorna 1 se obtiver sucesso,
' ou 0 se um erro ocorrer ou o usuário clicar no botão Cancelar
' da caixa de diálogo.
Private Declare Function GetOpenFileName Lib "comdlg32.dll" _
Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

'GetSaveFileName abre a caixa de diálogo "Salvar como" do Windows, conforme os
'parâmetros passados no argumento pOpenfilename. Note que esta função
'apenas retorna um caminho\nome de arquivo informado pelo usuário. O
'aplicativo é que irá trabalhar este nome para criar um arquivo.
'Se o usuário selecionar um arquivo na caixa, a função retorna um valor
'não-zero. Se um erro ocorrer, ou se o usuário clicar em Cancelar, a
'função retorna zero.
Private Declare Function GetSaveFileName Lib "comdlg32.dll" _
Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long

' NOTA: Use CommDlgExtendedError para obter o código de erro dessas funções da API.

' Constantes usadas como flags em OPENFILENAME.
Private Const OFN_OVERWRITEPROMPT = &H2
Private Const OFN_HIDEREADONLY = &H4
Private Const OFN_NOCHANGEDIR = &H8
Private Const OFN_PATHMUSTEXIST = &H800
Private Const OFN_FILEMUSTEXIST = &H1000

Function GetOpenFile(ByVal hwnd As Long, _
ByVal strDialogTitle As String, StrStion As String) As String
' O arquivo selecionado na caixa de diálogo
' será retornado no elemento lpstrFile
' da estrutura OPENFILENAME.
Dim OFN As OPENFILENAME
Dim varFileName As Variant 'Nome do arquivo selecionado.

' Define os elementos da estrutura OFN.
OFN = SetOFN("OpenFile", hwnd, strDialogTitle, StrStion)

' Chama a função e verifica se a operação foi completada com sucesso;
' ou seja, se o retorno é diferente de 0.
If GetOpenFileName(OFN) Then
' Remove o Null final da string.
varFileName = Left(OFN.lpstrFile, _
InStr(OFN.lpstrFile, vbNullChar) - 1)
GetOpenFile = varFileName
Else
GetOpenFile = ""
End If
End Function

Function SaveFileName(ByVal hwnd As Long, _
ByVal strDialogTitle As String, StrStion As String) As String
' O arquivo informado pelo usuário na caixa de diálogo
' será retornado no elemento lpstrFile
' da estrutura OPENFILENAME.
Dim OFN As OPENFILENAME
Dim varFileName As Variant 'Nome do arquivo selecionado.

' Define os elementos da estrutura OFN.
OFN = SetOFN("SaveAs", hwnd, strDialogTitle, StrStion)

'Abre a caixa "Salvar como" e retorna o nome
'do arquivo informado pelo usuário.
If GetSaveFileName(OFN) Then
' Remove o Null final da string.
varFileName = Left(OFN.lpstrFile, _
InStr(OFN.lpstrFile, vbNullChar) - 1)
SaveFileName = varFileName
Else
SaveFileName = ""
End If

End Function

Private Function SetOFN(strTipo As String, _
hwnd As Long, strDialogTitle As String, StrStion As String) As OPENFILENAME

' Função interna usada para definir uma estrutura padrão
' comum aos métodos GetOpenFile e SaveFileName desta classe.

' strTipo deve ser:
' OpenFile - caixa Abrir arquivo; e
' SaveAs - caixa Salvar como.

Dim lngFlags As Long 'flags da estrutura.

'Define o conjunto de flags conforme o tipo de
'caixa de diálogo passado em strTipo.
Select Case strTipo
Case "OpenFile"
' Os flags são usados para especificar que o arquivo
' escolhido deve existir, e não permitir a mudança no
' diretório atual do Windows ou a exibição da opção
' read-only da caixa de diálogo.
lngFlags = OFN_FILEMUSTEXIST Or _
OFN_HIDEREADONLY Or OFN_NOCHANGEDIR
Case "SaveAs"
' Os flags são usados para especificar que o caminho
' escolhido deve existir, avisar se um arquivo
' existente for escolhido e ocultar a exibição da opção
' read-only da caixa de diálogo.
lngFlags = OFN_PATHMUSTEXIST Or OFN_HIDEREADONLY _
Or OFN_OVERWRITEPROMPT
End Select

' Define os elementos da estrutura OPENFILENAME.
With SetOFN

.lStructSize = Len(SetOFN) 'Tamanho da estrutura.
.hWndOwner = hwnd 'Handle da janela abrindo a caixa de diálogo.
.lpstrFilter = "File type (" & StrStion & ")" _
& vbNullChar & StrStion & vbNullChar & vbNullChar
.lpstrDefExt = StrStion 'Extensão default do arquivo.
'.lpstrFilter = "Microsoft Access DataBase(*.mdb,*.mde)" _
& vbNullChar & "*.mdb; *.mde" & vbNullChar & vbNullChar
'.lpstrDefExt = "mdb" 'Extensão default do arquivo.
'.lpstrCustomFilter é ignorado - string não usada.
.nMaxCustFilter = 0
.flags = lngFlags
'.lpstrInitialDir = "F:\Spoolfile\Spool\Daily" & vbNullChar 'Diretório inicial.
.lpstrInitialDir = CurDir & vbNullChar 'Diretório inicial.
.lpstrTitle = strDialogTitle & vbNullChar 'Título da caixa de diálogo.
.lpstrFile = Space$(256) & vbNullChar 'Inicializa buffer que recebe o caminho e nome do arquivo.
.lpstrFileTitle = Space$(256) & vbNullChar 'O mesmo para o nome do arquivo.
.nMaxFile = Len(.lpstrFile) 'Comprimento máximo de lpstrFile.
.nMaxFileTitle = Len(.lpstrFileTitle)
' O filtro Default é o primeiro (arquivos do tipo MDB, neste caso).
.nFilterIndex = 1
End With

End Function



Exemplo para usar Open File
Function FindFile()
Dim cAbrirArq As New clsAbrirSalvarArquivo
Dim strPath As String

Dim StrTop As String
Dim StrType As String

StrType = "*.mdb; *.mde"
StrTop = " " & Format(Environ("USERNAME"), ">") & ", Select DataBase."

'Passa o path do arquivo selecionado para a variável strPath.
strPath = cAbrirArq.GetOpenFile(Me.hwnd, _
StrTop, StrType)

'Destrói a instância aberta da classe, ao fechar o form.
Set cAbrirArq = Nothing

'Checa se o usuário clicou no botão Cancelar da caixa.
If Len(strPath) > 0 Then
FindFile = strPath
End If
End Function



Vanderlei S. Matheus

Amigo Vanderlei,

Muito obrigado, já testei seu primeiro codigo e nota 10000, vou testar o segundo e te respondo.

Amigo vanderlei.
Perdoe minha ignorância, não consegui fazer funcionar o seu segundo codigo. criei um novo modulo classe, mas ele esta dando erro. poderia me detalhar melho como fazer? Não entendo nada de módulo classe.

Gto,
Edson

Edson,

Copie o codigo postado e testei, funciona normalmente. Qual o erro?



Exemplo de como usar o codigo.

' Crie um botao por exemplo CmmFindFile
' No evento On Click coloque o codigo abaixo


Private Sub CmmFindFile_Click()
MsgBox FindFile()
End Sub

Function FindFile()
Dim cAbrirArq As New clsAbrirSalvarArquivo
Dim strPath As String

Dim StrTop As String
Dim StrType As String

'''' Aqui vc define a extensao do arquivo *.* mostra todos
StrType = "*.*" '"*.mdb; *.mde"
StrTop = " " & Format(Environ("USERNAME"), ">") & ", Select DataBase."

'Passa o path do arquivo selecionado para a variável strPath.
strPath = cAbrirArq.GetOpenFile(Me.hwnd, _
StrTop, StrType)

'Destrói a instância aberta da classe, ao fechar o form.
Set cAbrirArq = Nothing

'Checa se o usuário clicou no botão Cancelar da caixa.
If Len(strPath) > 0 Then
FindFile = strPath
End If
End Function



Vanderlei S. Matheus

Vanderlei,

Vou descrever passo a passo como procedi:

Abri um modulo novo e cliquei em inserir modulo de classe
Salvei o modulo como “clsAbrirSalvarArquivo”
Copiei todo o código para dentro dele

Pedi para compilar e no lugar demonstrado abaixo e informou um erro:

Function FindFile()
Dim cAbrirArq As New clsAbrirSalvarArquivo
Dim strPath As String

Dim StrTop As String
Dim StrType As String

StrType = "*.mdb; *.mde"
StrTop = " " & Format(Environ("USERNAME"), ">") & ", Select DataBase."
strPath = cAbrirArq.GetOpenFile(Me.hwnd, _
StrTop, StrType)
Set cAbrirArq = Nothing
If Len(strPath) > 0 Then
FindFile = strPath
End If
End Function

Cujo o erro foi o seguinte:
ERRO DE COMILAÇÃO:
MÉTODO OU MEMBRO DE DADOS NÃO ENCONTRATO

Gto,
Edson

Essa parte do codigo nao faz parte da Class "clsAbrirSalvarArquivo", e um exemplo de como usar dentro de um formulario

Exemplo para usar Open File

Function FindFile()
Dim cAbrirArq As New clsAbrirSalvarArquivo
Dim strPath As String

Dim StrTop As String
Dim StrType As String

StrType = "*.mdb; *.mde"
StrTop = " " & Format(Environ("USERNAME"), ">") & ", Select DataBase."

'Passa o path do arquivo selecionado para a variável strPath.
strPath = cAbrirArq.GetOpenFile(Me.hwnd, _
StrTop, StrType)

'Destrói a instância aberta da classe, ao fechar o form.
Set cAbrirArq = Nothing

'Checa se o usuário clicou no botão Cancelar da caixa.
If Len(strPath) > 0 Then
FindFile = strPath
End If
End Function


Vanderlei

Vanderlei,
Desculpe, esqueci de falar que a FUNCTION FINDFILE eu coloquei num módulo comum e mesmo assim está dando o erro acima.

Gto,
Edson

Edson,

Copie novamente os codigos.

Hwnd Property
See Also Applies To Example Specifics
You can use the hWnd property to determine the handle (a unique Long Integer value) assigned by Microsoft Windows to the current window. Read/write Long.

expression.Hwnd

expression Required. An expression that returns one of the objects in the Applies To list.

Remarks
This property is available only by using a macro or Visual Basic.

You can use this property in Visual Basic when making calls to Windows application programming interface (API) functions or other external routines that require the hWnd property as an argument. Many Windows functions require the hWnd property value of the current window as one of the arguments.

Caution Because the value of this property can change while a program is running, don't store the hWnd property value in a public variable.

Vanderlei

Use essa function dentro de um formulario.

quote:

Exemplo para usar Open File

Function FindFile()
Dim cAbrirArq As New clsAbrirSalvarArquivo
Dim strPath As String

Dim StrTop As String
Dim StrType As String

StrType = "*.mdb; *.mde"
StrTop = " " & Format(Environ("USERNAME"), ">") & ", Select DataBase."

'Passa o path do arquivo selecionado para a variável strPath.
strPath = cAbrirArq.GetOpenFile(Me.hwnd, _
StrTop, StrType)

'Destrói a instância aberta da classe, ao fechar o form.
Set cAbrirArq = Nothing

'Checa se o usuário clicou no botão Cancelar da caixa.
If Len(strPath) > 0 Then
FindFile = strPath
End If
End Function

Vanderlei

Resolvido!!!!!! Valeu vanderlei. Somente funcionou no formulário, mas porque sera???

Gto,
Edson

[/quote]

quote:

Resolvido!!!!!! Valeu vanderlei. Somente funcionou no formulário, mas porque sera???

Caution Because the value of this property can change while a program is running, don't store the hWnd property value in a public variable.


Valeu,


Vanderlei