FSO - FileSystemObject para manipularmos arquivos

FSO - FileSystemObject para manipularmos arquivos;

O Objeto FSO comporta varios métodos para manipulação através do VBA, eis alguns:


'Habilite a Referencia VBA Microsoft Scripting Runtime

'Verifica se o ficheiro existe:

Sub VerificaSeFicheiroExiste()
Dim fso
Dim file As String
file = "C:\Teste.xls" ' caminho do ficheiro
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FileExists(file) Then
MsgBox file & " não encontrado.", vbInformation, "Não Encontrado"
Else
MsgBox file & " encontrado.", vbInformation, "Encontrado"
End If
End Sub


'Copiar um arquivo se ele existir:

Sub CopiaFicheiro()
Dim fso
Dim file As String, sfol As String, dfol As String
file = "teste.xls" ' nome do ficheiro
sfol = "C:" ' caminho inicial
dfol = "E:" ' caminho destino
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FileExists(sfol & file) Then
MsgBox sfol & file & " não existe!", vbExclamation, "Erro"
ElseIf Not fso.FileExists(dfol & file) Then
fso.CopyFile (sfol & file), dfol, True
Else
MsgBox dfol & file & " existente!", vbExclamation, "Sucesso"
End If
End Sub


'Mover um arquivo se ele existir:

Sub MoverFicheiro()
Dim fso
Dim file As String, sfol As String, dfol As String
file = "teste.xls" ' nome do ficheiro
sfol = "C:" ' caminho inicial
dfol = "E:" ' caminho destino
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FileExists(sfol & file) Then
MsgBox sfol & file & " não existet!", vbExclamation, "Erro"
ElseIf Not fso.FileExists(dfol & file) Then
fso.MoveFile (sfol & file), dfol
Else
MsgBox dfol & file & " existente!", vbExclamation, "Sucesso"
End If
End Sub


'Apagar um arquivo se ele existir:


Sub ApagarFicheiro()
Dim fso
Dim file As String
file = "C:\teste.xls" ' caminho do ficheiro
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(file) Then
fso.DeleteFile file, True
Else
MsgBox file & " não existe ou foi apagado!" _
, vbExclamation, "Erro"
End If
End Sub


'Verifique se existe uma pasta:

Sub VerificaSePastaExiste()
Dim fso
Dim folder As String
folder = "C:\SuaPasta" ' caminho da pasta
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FolderExists(folder) Then
MsgBox folder & " pasta encontrada.", vbInformation, "Sucesso"
Else
MsgBox folder & " pasta não encontrada.", vbInformation, "Erro"
End If
End Sub


'Crie uma pasta se não existir:

Sub CriaPastaSeNaoExistir()
Dim fso
Dim fol As String
fol = "c:\SuaPasta" ' caminho da pasta
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(fol) Then
fso.CreateFolder (fol)
Else
MsgBox fol & " existente!", vbExclamation, "Sucesso"
End If
End Sub

'Copiar uma pasta, se ela existe:

Sub CopiaPastaExistente()
Dim fso
Dim sfol As String, dfol As String
sfol = "c:\SuaPasta" ' caminho de origem da pasta
dfol = "e:\SuaPasta" ' caminho de destino da pasta
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(dfol) Then
fso.CopyFolder sfol, dfol
Else
MsgBox dfol & " existente!", vbExclamation, "Sucesso"
End If
End Sub


'Mover uma pasta, se ela existe:

Sub MoverPastaExistente()
Dim fso
Dim fol As String, dest As String
sfol = "c:\SuaPasta" ' caminho de origem da pasta
dfol = "e:\SuaPasta" ' caminho de destino da pasta
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(dfol) Then
fso.MoveFolder sfol, dfol
Else
MsgBox dfol & " existente!", vbExclamation, "Sucesso"
End If
End Sub


'Apagar uma pasta, se ela existe:

Sub ApagarPastaExistente()
Dim fso
Dim fol As String
fol = "c:\SuaPasta" ' caminho da pasta
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FolderExists(fol) Then
fso.DeleteFolder fol
Else
MsgBox fol & " não existe ou foi apagada!" _
, vbExclamation, "Erro"
End If
End Sub


'Mover todos os ficheiros de uma pasta para outra pasta:

Sub MoverTodosOsFicheiros()
Dim fso
Dim sfol As String, dfol As String
sfol = "c:\SuaPasta" ' caminho de origem da pasta
dfol = "e:\SuaPasta" ' caminho de destino da pasta
Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
If Not fso.FolderExists(sfol) Then
MsgBox sfol & " caminho invalido.", vbInformation, "Erro"
ElseIf Not fso.FolderExists(dfol) Then
MsgBox dfol & " caminho invalido.", vbInformation, "Erro"
Else
fso.MoveFile (sfol & "\*.*"), dfol ' Alterar "\ *.*" para "\ *. xls" para mover só arquivos Excel
End If
If Err.Number = 53 Then MsgBox "não encontrado."
End Sub


'Copiar todos os ficheiros de uma pasta para outra pasta:


Sub CopiaTodosOsFicheiros()
Dim fso
Dim sfol As String, dfol As String
sfol = "c:\SuaPasta" ' caminho de origem da pasta
dfol = "e:\SuaPasta" ' caminho de destino da pasta
Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
If Not fso.FolderExists(sfol) Then
MsgBox sfol & " caminho invalido.", vbInformation, "Erro"
ElseIf Not fso.FolderExists(dfol) Then
MsgBox dfol & " caminho invalido.", vbInformation, "Erro"
Else
fso.CopyFile (sfol & "\*.*"), dfol ' Alterar "\ *.*" para "\ *. xls" para mover só arquivos Excel
End If
If Err.Number = 53 Then MsgBox "não encontrado."
End Sub

Parabéns JPaulo, Excelente Post com Excelentes Dicas!

Como necessida de um membro do Fórum, segue uma forma de copiar Varios arquivos...

Situação:

Existe a Tabela "tbArquivo" com o Campo "NomeArquivo" que terá os nomes dos arquivos a serem copiados, ex:

Planilha.xls
Documento1.doc
Teste.txt

Dessa Forma, no click de um Botão, eirei percorrer todos os registros dessa tabela, e copiar seus arquivos para uma pasta.

Código:

Private Sub btCopiarArquivos_Click()
Dim DB As Database
Dim rs As DAO.Recordset
Dim fso
Dim file As String, sfol As String, dfol As String
Set DB = CurrentDb()
Set rs = DB.OpenRecordset("tbArquivo")

Do While Not rs.EOF
file = rs!NomeArquivo 'Nome do Campo com o Nome dos Arquivos
'Pasta Origem dos arquivos
sfol = CurrentProject.Path & "\"
'Pasta destino para os arquivos
dfol = CurrentProject.Path & "\1\"
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FileExists(sfol & file) Then
MsgBox sfol & file & " não existe!", vbExclamation, "Erro"
ElseIf Not fso.FileExists(dfol & file) Then
fso.CopyFile (sfol & file), dfol, True
Else
MsgBox sfol & file & " existente!", vbExclamation, "Sucesso"
Exit Sub
End If
rs.MoveNext
Loop
Set rs = Nothing
Set DB = Nothing
MsgBox "Copia terminada", vbInformation
End Sub