[Resolvido]Back-End Front-End CurrentProject.Path

Public Sub ZipaBanco()
'Criado pelo colega Raw do Canadá
'Adaptado por JPaulo ® Maximo Access
'Adaptado por Norberto Rost
    Dim strDate As String, DefPath As String
    Dim oApp As Object
    Dim fname, FileNameZip
    On Error Resume Next

    'Usando uma função do Avelino para informar a pasta de destino
    DefPath = fncOrigem(mBackup)
    If Right(DefPath, 1) <> "\" Then
        DefPath = DefPath & "\"
    End If

    strDate = Format(Now, "dd-mmm-yy_h-mm-ss")
    'Empresa é uma função que retorna o nome do cliente usuário
    FileNameZip = DefPath & Empresa & " Backup " & Format(Date, "Long Date") & " .zip"
    fname = BackEndAtual
    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

Código:

Public Function fncBackEndAtual() As String
Dim strCon As String
Dim strTabelaLink As String
Dim tbl As DAO.TableDef

Dim k As String
On Error GoTo trataerro

For Each tbl In CurrentDb.TableDefs
    If Len(tbl.Connect & "") > 0 Then strTabelaLink = tbl.Name
Next
'-----------------------------------------------------
'Vou usar a última tabela vinculada, para obter
'o caminho do back-end (propriedade Connect).
'-----------------------------------------------------
strCon = CurrentDb.TableDefs(strTabelaLink).Connect
'-----------------------------------------------------
'Agora vou retirar apenas o caminho do accdb,
'sem o ";DATABASE=" que o precede na string Connect.
'-----------------------------------------------------
fncBackEndAtual = Right$(strCon, (Len(strCon) - (InStr(1, strCon, ";DATABASE=", 2) + 9)))

sair:
    Exit Function
trataerro:
    MsgBox "Erro: " & Err.Number & vbCrLf & Err.Description, vbCritical, "Aviso", Err.HelpFile, Err.HelpContext
    Resume sair:
End Function