MaximoAccess

Caro Usuário, antes de postar pela primeira vez, leia as regras do fórum.

Obrigado

Administração do MaximoAccess

MaximoAccess

Gostaria de reagir a esta mensagem? Crie uma conta em poucos cliques ou inicie sessão para continuar.

Dicas Ms Access, Exemplos Ms Access, Codigos VBA Ms Access, SQL Ms Access

    FSO - FileSystemObject para manipularmos arquivos

    JPaulo
    JPaulo
    Moderador
    Moderador

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 10605
    Registrado : 04/11/2009

    FSO - FileSystemObject para manipularmos arquivos Empty FSO - FileSystemObject para manipularmos arquivos

    Mensagem  JPaulo em 4/10/2010, 12:35

    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





    .................................................................................
    Contribua com o maximoaccess nos links abaixo, ajude a melhorar este que é o seu site na NET.

    Pay-Pal R$ Aqui
    Pay-Pal € Aqui

    Ou ainda: Aqui (Novo)

    Sucesso e Bons Estudos
    Success and Good Studies

    FSO - FileSystemObject para manipularmos arquivos Folder_announce_new Utilize o Sistema de Busca do Fórum...
    FSO - FileSystemObject para manipularmos arquivos Folder_announce_new 102 Códigos VBA Gratuitos...
    FSO - FileSystemObject para manipularmos arquivos Folder_announce_new Instruções SQL como utilizar...
    FabioPaes
    FabioPaes
    Maximo VIP
    Maximo VIP

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 3913
    Registrado : 14/08/2013

    FSO - FileSystemObject para manipularmos arquivos Empty Re: FSO - FileSystemObject para manipularmos arquivos

    Mensagem  FabioPaes em 8/4/2016, 22:55

    Parabéns JPaulo, Excelente Post com Excelentes Dicas!
    FabioPaes
    FabioPaes
    Maximo VIP
    Maximo VIP

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 3913
    Registrado : 14/08/2013

    FSO - FileSystemObject para manipularmos arquivos Empty Copiar Vários Arquivos (Loop)

    Mensagem  FabioPaes em 4/1/2017, 19:21

    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


    .................................................................................
    _____________________________________________________________________
    Achou a solução para sua dúvida? Não seja Egoísta, Compartilhe com todos!
    A dica do Colega foi útil? Agradeça!

    O importante não saber tudo, mas sim a Onde procurar!

      Data/hora atual: 24/11/2020, 09:21