[Resolvido]Backup de base de dados ligada/vinculada (BackEnd)

Boas noites
Este primeiro código localiza a BD_be

Código:

Function fncPathPrimeiraTabelaLigada()
' Origem..: (Cláudio Más) https://www.maximoaccess.com/t27625-caminho-de-tabelas-ligadas
' Alterado: Alvaro Teixeira (ahteixeira)
' Data ...: 13-08-2016

    Dim dbs As DAO.Database
    Dim tdf As TableDef
    
  

 Set dbs = CurrentDb
    For Each tdf In dbs.TableDefs
        If Len(tdf.Connect) > 0 Then
            fncPathPrimeiraTabelaLigada = right$(tdf.Connect, Len(tdf.Connect) - 10)
            Exit For
        End If
    Next tdf
End Function


Este segundo, de JPaulo, zipa a BD

Código:

Public Sub ZipaBanco()
'JPaulo :registered: Maximo Access
    Dim strDate As String, DefPath As String
    Dim oApp As Object
    Dim FName, FileNameZip
    Dim strPrefix As String
     On Error Resume Next

    DefPath = Application.CurrentProject.Path 'Caminho da pasta onde está o banco a zipar
    If Right(DefPath, 1) <> "\" Then
        DefPath = DefPath & "\"
    End If
  
    strDate = Format(Now, "dd-mmmm-yyyy_hh-mm")
    FileNameZip = DefPath & "Backup_" & strDate & ".zip"

    strPrefix = "SeuBanco" 'Nome do banco que vai ser zipado

    'FName é o caminho da pasta onde vai ficar o banco zipado.
    'neste exemplo vai ficar junto ao proprio banco
    'Se o seu Ms Access for anterior ao 2007,
    'deve alterar a extenção de .accdb para .mdb
    FName = Application.CurrentProject.Path & "\" & strPrefix & ".accdb"
    
        On Error Resume Next
    CriaNovoZip (FileNameZip)
    Set oApp = CreateObject("Shell.Application")
    oApp.NameSpace(FileNameZip).CopyHere FName
    MsgBox "Criado com Sucesso em: " & FileNameZip
    Set oApp = Nothing
   Exit Sub
End Sub


Public Sub CriaNovoZip(sPath)
'Criado pelo meu amigo e colega Raw do Canadá
'Adaptado por JPaulo :registered: Maximo Access
    Dim ofso, arrHex, sBin, i, Zip
    On Error Resume Next
    Set ofso = CreateObject("Scripting.FileSystemObject")
    arrHex = Array(80, 75, 5, 6, 0, 0, 0, _
                   0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0)
    For i = 0 To UBound(arrHex)
        sBin = sBin & Chr(arrHex(i))
    Next
    On Error Resume Next
    With ofso.CreateTextFile(sPath, True)
        .Write sBin
        .Close
    End With
   Exit Sub
End Sub


Gostaria que este segundo código localizasse a BD_be através do primeiro código.
Em resumo o que pretendo é que o código localize o be através da TableDefs

Olá Luís Antunes,

Se compreendi bem a dúvida, onde tem:

Código:

FName = Application.CurrentProject.Path & "\" & strPrefix & ".accdb"

altere por:

Código:

FName = fncPathPrimeiraTabelaLigada

Ficando desta forma a função do JPaulo:

Código:

Public Sub ZipaBanco()
'JPaulo Maximo Access
    Dim strDate As String, DefPath As String
    Dim oApp As Object
    Dim FName, FileNameZip
    On Error Resume Next

    DefPath = Application.CurrentProject.Path 'Caminho da pasta onde está o banco a zipar
    If Right(DefPath, 1) <> "\" Then
        DefPath = DefPath & "\"
    End If
 
    strDate = Format(Now, "dd-mmmm-yyyy_hh-mm")
    FileNameZip = DefPath & "Backup_" & strDate & ".zip"
 
    FName = fncPathPrimeiraTabelaLigada  'ahteixeira 2020

        On Error Resume Next
    CriaNovoZip (FileNameZip)
    Set oApp = CreateObject("Shell.Application")
    oApp.NameSpace(FileNameZip).CopyHere FName
    MsgBox "Criado com Sucesso em: " & FileNameZip
    Set oApp = Nothing
  Exit Sub
End Sub

Abraço

Boa tarde ahteixeira

Ficou óptimo, fico-lhe agradecido.
Fiz uma pequena alteração, agora o zip fica no directório à minha escolha, quando o directório não existe o código cria-o.

Código:

Public Sub ZipaBanco()
'JPaulo Maximo Access
    Dim strDate As String, DefPath As String
    Dim oApp As Object
    Dim FName, FileNameZip
    
     Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
     On Error Resume Next

    DefPath = Application.CurrentProject.Path 'Caminho da pasta onde está o banco a zipar
    If right(DefPath, 1) <> "\" Then
        DefPath = DefPath & "\"
    End If
    
    If FSO.FolderExists("C:\Backup") Then ' verifica se já existe a pasta
    Else
        MkDir "c:\Backup" 'se não existir cria
    End If
  
    strDate = Format(Now, "dd-mmmm-yyyy_hh-mm")
    FileNameZip = "C:\Backup\" & "Backup_" & strDate & ".zip"
  
    FName = fncPathPrimeiraTabelaLigada  'ahteixeira 2020

        On Error Resume Next
    CriaNovoZip (FileNameZip)
    Set oApp = CreateObject("Shell.Application")
    oApp.NameSpace(FileNameZip).CopyHere FName
    MsgBox "Criado com Sucesso em: " & FileNameZip
    Set oApp = Nothing
   Exit Sub
End Sub


Olá Luís Antunes,

Fico feliz por ter ajudado, obrigado pela partilha.
Não se esqueça de dar o tópico como Resolvido, veja como fazer:
https://www.maximoaccess.com/t860-resolucao-de-topicos

Abraço

Tenho quase a certeza que dei o assunto como resolvido, no entanto fica a dúvida.
As minhas desculpas.

Luís Antunes