bkp - VBWEB

Quem sabe esse código te ajude. Ele faz bkp da Base de dados.
OBS.: Nunca testei....não sei se funciona. Caso funcionar post.
===================================================

Function BackupDataBase (filename$) As Integer
    '****************************************************************
    '     ******************
    '* PROCEDURE: BackupDataBase
    '* ARGS: filename$ -- Name of New DataBase, defaults To current D
    On Error GoTo BackupDataBase_Err
    Dim newDB As Database, oldDB As Database, oldTable As TableDef
    Dim tempname As String, path As String, intIndex As Integer, numTables As Integer
    Dim intIndex2 As Integer, errorFlag As Integer
    'backup defaults To current directory,...
    path = GetApplicationDir() & filename$
    'replace above Line With this one To pass a full path To this fun
    '     ction
    'path = filename$
    'If database already exists, delete it.

    If MB_FileExists(path) Then
        Kill path
    End If

    'create New file
    Set newDB = DBEngine.workspaces(0).CreateDatabase(path, DB_LANG_GENERAL)
    newDB.Close
    Set oldDB = DBEngine(0)(0)
    'Get number of tables And their names
    numTables = oldDB.tabledefs.count - 1
    'Actually export all the tables In the list.

    For intIndex = 0 To numTables
        tempname = oldDB.tabledefs(intIndex).name
        If ValidTableFilter(tempname) Then
            DoCmd TransferDatabase A_EXPORT, "Microsoft Access", path, A_TABLE, tempname, tempname
            End If

        Next intIndex

        BackupDataBase = True
        BackupDataBase_Exit:

        If errorFlag Then
            BackupDataBase = False
            'If we errored out, Then destroy the backup, (less risk of using
            '     incorrect file).

            If MB_FileExists(path) Then
                Kill path
            End If

        Else
            BackupDataBase = True
        End If

        Exit Function
        BackupDataBase_Err:
        MsgBox "Backup Failed! Error: " & Error$, 16, "FUNCTION: BackupDataBase( " & filename$ & " )"
        errorFlag = True
        Resume BackupDataBase_Exit
    End Function

Function GetApplicationDir () As String

    '****************************************************************
    '     ***********
    '* PROCEDURE: GetApplicationDir
    '* ARGS: NONE
    '* RETURNS:App's dir
    '* CREATED:8/2/95 GDK
    '* REVISED:
    '* CommentsRetrieves App's directory, (actually the current MDB's
    '     dir.)
    '****************************************************************
    '     ***********
    Dim d As Database, path As String, i%
    Set d = DBEngine(0)(0)
    path = d.name
    d.Close

    For i% = Len(path) To 0 Step -1

        If Mid$(path, i%, 1) = "" Then
            path = Left$(path, i%)
            Exit For
        End If

    Next i%

    GetApplicationDir = path
End Function

'*************************************************************
'* FUNCTION: MB_FileExists
'* ARGUMENTS: strFilename-- Name of file To look For
'* RETURNS:TRUE/False -- True = File Exists
'* CREATED:8/95 GDK Initial Code
'* CHANGED:N/A
'*************************************************************

Function MB_FileExists (strFileName As String) As Integer

    '
    'Check To see If file strFileName exists
    '

    If Len(Dir$(strFileName)) Then
        MB_FileExists = True
    End If

End Function

'***************************************************************
'* FUNCTION: ValidTableFilter
'* ARGUMENTS: tablename$ -- table To OK For export
'* RETURNS:TRUE/False -- True = OK To export
'* PURPOSE:Screen out invalid tables by testing them here.
'* CREATED:2/97 GDK Initial code
'* CHANGES:N/A
'***************************************************************

Function ValidTableFilter (tablename$) As Integer

    On Error GoTo ValidTableFilter_Error:

    If Left$(tablename$, 4) = "MSys" Then
        Exit Function
    End If

    If tablename$ = "" Then
        Exit Function
    End If

    'Add test functions above this line.
    ValidTableFilter = True
    ValidTableFilter_Exit:
    Exit Function
    ValidTableFilter_Error:
    MsgBox Error, 16, "FUNCTION: ValidTableFilter( " & tablen
End Function