[Resolvido]Código não extraí todos os arquivos do drive informado

Olá pessoal!

Encontrei um código aqui no fórum e inseri em um projeto meu, porém, o código não está extraindo todos os arquivos do diretório "C:\Windows\", extraí apenas 15% dos arquivos existentes na pasta do Windows. Eu abri o Explorer pra tentar achar algum problema nas subpastas e algumas delas eu não podia abrir, apareceu uma mensagem dizendo "você não tem permissão para acessar esta pasta". Então eu entrei nas propriedades da pasta e alterei as permissões de usuário, só depois consegui abrir a pasta. Não sei se esse é o problema, mas foi a única coisa que observei de diferente.

O código que estou usando para a rotina é o seguinte:

Public Function ContaFicheirosExtraiNome(strCaminho As String, strIncluiSubPastas As Boolean)
'By JPaulo ® Maximo Access
'Requer a seguinte referência VBA ativa:
'Microsoft Scripting Runtime
'Para chamar a função, deve colocar no pressionar de um botão: Call ContaFicheirosExtraiNome("C:\SuaPasta\",True)
Dim FSO As Object, strPasta As Object, strSubPasta As Object, strFicheiro As Object


Set FSO = CreateObject("Scripting.FileSystemObject")
Set strPasta = FSO.GetFolder(strCaminho)
'Percorre a drive e extraí o nome das pastas, subPastas e ficheiros
For Each strFicheiro In strPasta.Files
'Insere nas tabelas os dados completos dos ficheiros encontrados com as extensões
CurrentDb.Execute "INSERT INTO tblArquivos (URL, NomeArq, TamArq, DataC, DataM, DataA, TipoArq) SELECT '" & strPasta.Path & "\" & "', '" & strFicheiro.Name & "', '" & strFicheiro.Size / 1000 & "', '" & Format(strFicheiro.DateCreated, "dd/mm/yyyy") & "', '" & Format(strFicheiro.DateLastModified, "dd/mm/yyyy") & "', '" & Format(strFicheiro.DateLastAccessed, "dd/mm/yyyy") & "', '" & strFicheiro.Type & "'"

Next strFicheiro

'Se existirem subpastas, insere na tabela o caminho completo dos ficheiros
If strIncluiSubPastas = True Then

For Each strSubPasta In strPasta.SubFolders
ContaFicheirosExtraiNome strSubPasta.Path, True
Next strSubPasta

End If
Set strFicheiro = Nothing
Set strPasta = Nothing
End Function

Se alguém souber qual o problema que impede que o código extraia 100% doas arquivos existentes numa determinada pasta, ficarei grato se puder me ajudar.

Utilizo:
Access 2007
Windows 7

Obrigado!

Bom dia!

Fiz o teste no meu notebook com Windows 8.1 e deu o mesmo, quando chega na pasta do Windows a função para de extrair arquivos e encerra a rotina. Porém, pelo explorer as subpastas abriram sem restrições.

Alguém tem ideia de onde pode estar o problema?


Desde já, agradeço!

Roni

Verifique o tamanho do  arquivo.

Se for dividido em BE  e FE , veja qual o tamanho do BE.

Sugiro que teste o código direcionando o resultado para um arquivo de texto.

Pode ser que não seja erro no código e sim no limite de espaço do arquivo que é de 2Gb

Veja as especificações do Acc 2010 aqui.


Abraços

NB

Bom dia NB!

Obrigado pela atenção!

O BD não esta dividido e quando a função para de carregar os diretórios dos arquivos, o BD fica com 6,8MB.

Abraço!

Mais uma observação, a tabela "tblArquivos" fica com 14.812 registros.

Noobezinho escreveu:Sugiro que teste o código direcionando o resultado para um arquivo de texto.

Chegou a fazer esse teste?


Nb

Noob, pra ser sincero nem sei como fazer esse teste. Pode me passar o processo?

Vamos fazer melhor

Envie parte do aplicativo, a tabela e o código para eu testar, ok?

Aguardo ...


NB

Bom dia Noob!

Segue o arquivo para teste.

Estou enviando o teu aplicativo com um exemplo que encontrei na net.

Veja o frmNoob (só tem um botão) e o módulo mod_Noob.

Esse código pega todos os arquivos da pasta selecionada.

Ele como qualquer outro código,não irá ler aquivos com atributos de restrição, é o caso da pasta windows que tem vários arquivos restritos.

Deixo pra você incrementar melhor o código.

Nb

Bom dia Noob!

Muito obrigado pela atenção!

Muito bom o exemplo, pena que também não captura os arquivos com restrições. Vou ver como posso aproveitá-lo ao máximo.


Abraço!

Roni

Embora tenha dado o tópico como resolvido,
encontrei mais esse código na net, que achei melhor de todos.

Ele não lista os arquivos restritos, mas ele coloca um error no registro da tabela e continua a relacionar os demais registros.
Quanto a isso, acredito que não irá conseguir listar esses arquivos restritos, mas posso estar enganado.

Me parece que no teu código tem uma função que conta os registros a serem listados, não olhei direito e não vi se funfa legal

Pergunto isso, porque você pode usar essa função para retornar o total de arquivos a serem listados e com isso fazer
uma barra de progresso, para o usuário acompanhar, pois como pode ver na tabela (Files), foram mais de 64.000 arquivos e
demorou em torno de 6 a 7 minutos para relacionar todos (c:\windows\ ).

Espero que isso te ajude melhor  

Noobezinho

Noobezinho, realmente esse novo código é melhor por tratar erro e por informar no final o tempo decorrido. No meu teste o resultado foi de 89.420 arquivos e o tempo decorrido foi 5 minutos e 46 segundos.

Quanto a barra de progresso é uma boa opção, vou ver o que consigo.

Vou tentar adaptar esse código no meu projeto.

Por isso vou reabrir o tópico e retorno com o resolvido caso consiga fazer a adaptação no meu projeto.

Muito obrigado mesmo por mais essa ajuda.

Abraço!

Noobezinho,

Estou tentando adaptar o código que você passou para incluir mais itens na "tblArquivosFixos" e não apenas o nome do arquivo e o diretório, como na tabela "File", porém não estou obtendo 100% de sucesso. Pode me ajudar com isso também?

O que preciso é informar também na tabela "tblArquivosFixos", o tamanho, a data de criação, modificação e alteração e o tipo do arquivo, conforme os campos da tabela.

Desde já obrigado!

Olá!

Consegui resolver com o simples. O código ficou como segue:

Public Function ContaFicheirosExtraiNome(ByVal strCaminho As String _
, strFileSpec As String _
, strIncluiSubPastas As Boolean)
'By JPaulo ® Maximo Access
'Requer a seguinte referência VBA ativa:
'Microsoft Scripting Runtime
'Para chamar a função, deve colocar no pressionar de um botão: Call ContaFicheirosExtraiNome("C:\SuaPasta\",True)
On Error GoTo Err_Handler

Dim FSO As Object, strPasta As Object, strSubPasta As Object, strFicheiro As Object
Dim strSize As String
Dim strDescSize As String

Set FSO = CreateObject("Scripting.FileSystemObject")
Set strPasta = FSO.GetFolder(strCaminho)

gCount = gCount + 1
SysCmd acSysCmdSetStatus, gCount
'Percorre a drive e extraí o nome das pastas, subPastas e ficheiros
For Each strFicheiro In strPasta.Files
strDescSize = "KB"
'Insere nas tabelas os dados completos dos ficheiros encontrados com as extensões
CurrentDb.Execute "INSERT INTO tblArquivosFixos (URL, NomeArq, TamArq, DataC, DataM, DataA, TipoArq, DescTam) SELECT '" & strPasta.Path & "\" & "', '" & strFicheiro.Name & "', '" & strFicheiro.Size / 1000 & "', '" & Format(strFicheiro.DateCreated, "dd/mm/yyyy") & "', '" & Format(strFicheiro.DateLastModified, "dd/mm/yyyy") & "', '" & Format(strFicheiro.DateLastAccessed, "dd/mm/yyyy") & "', '" & strFicheiro.Type & "', '" & strDescSize & "'"
CurrentDb.Execute "INSERT INTO tblArquivos (URL, NomeArq, TamArq, DataC, DataM, DataA, TipoArq) SELECT '" & strPasta.Path & "\" & "', '" & strFicheiro.Name & "', '" & strFicheiro.Size / 1000 & "', '" & Format(strFicheiro.DateCreated, "dd/mm/yyyy") & "', '" & Format(strFicheiro.DateLastModified, "dd/mm/yyyy") & "', '" & Format(strFicheiro.DateLastAccessed, "dd/mm/yyyy") & "', '" & strFicheiro.Type & "'"

Next strFicheiro
'Se existirem subpastas, insere na tabela o caminho completo dos ficheiros
If strIncluiSubPastas = True Then
For Each strSubPasta In strPasta.SubFolders
Call ContaFicheirosExtraiNome(strSubPasta.Path, strFileSpec, True)
Next strSubPasta

End If
Set strFicheiro = Nothing
Set strPasta = Nothing

Exit_Handler:

Exit Function

Err_Handler:

CurrentDb.Execute "INSERT INTO tblArquivosFixos (URL, NomeArq, TamArq, DataC, DataM, DataA, TipoArq, DescTam) SELECT '" & strPasta.Path & "\" & "', '" & " ~~~ ERROR ~~~" & "', '" & " ~~~ ERROR ~~~" & "', '" & " ~~~ ERROR ~~~" & "', '" & " ~~~ ERROR ~~~" & "', '" & " ~~~ ERROR ~~~" & "', '" & " ~~~ ERROR ~~~" & "', '" & strDescSize & "'"
CurrentDb.Execute "INSERT INTO tblArquivos (URL, NomeArq, TamArq, DataC, DataM, DataA, TipoArq) SELECT '" & strPasta.Path & "\" & "', '" & " ~~~ ERROR ~~~" & "', '" & " ~~~ ERROR ~~~" & "', '" & " ~~~ ERROR ~~~" & "', '" & " ~~~ ERROR ~~~" & "', '" & " ~~~ ERROR ~~~" & "', '" & " ~~~ ERROR ~~~" & "'"

Resume Exit_Handler

End Function


Abraços!

Roni

Que ótimo que conseguiu

Valeu pelo retorno

Boa sorte !!

Nb