USUÁRIO:      SENHA:        SALVAR LOGIN ?    Adicione o VBWEB na sua lista de favoritos   Fale conosco 



  Visual Basic    (Banco de Dados)

Título da Dica:  Criando backup de bancos de dados
Postada em 28/10/2003 por ^HEAVY-METAL^            
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)
    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

        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

            BackupDataBase = True
        End If

        Exit Function
        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 =

    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

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

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
    Exit Function
    MsgBox Error, 16, "FUNCTION: ValidTableFilter( " & tablen
End Function

CyberWEB Network Ltda.    © Copyright 2000-2021   -   Todos os direitos reservados.
Powered by HostingZone - A melhor hospedagem para seu site
Topo da página