Tabellen exporteren incl data ipv linken

DoCmd.TransferDatabase acExport, "Microsoft Access", strFilenameBK, acTable, "tblProducten", "tblProducten", False

Option Compare Database
Option Explicit


Public Sub ExpObj2ExtDb(sExtDb As String)
    On Error GoTo Error_Handler
    Dim qdf             As QueryDef
    Dim tdf             As TableDef
    Dim obj             As AccessObject

' Tables.
    For Each tdf In CurrentDb.TableDefs
        If Left(tdf.Name, 4) <> "MSys" Then    'Ignore/Skip system tables
            DoCmd.TransferDatabase acExport, "Microsoft Access", sExtDb, _
                                   acTable, tdf.Name, tdf.Name, False
        End If
    Next tdf

Error_Handler_Exit:
    On Error Resume Next
    Set qdf = Nothing
    Set tdf = Nothing
    Set obj = Nothing
    Exit Sub

Error_Handler:
    MsgBox "The following error has occurred." & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: ExpObj2ExtDb" & vbCrLf & _
           "Error Description: " & Err.Description, _
           vbCritical, "An Error has Occurred!"
    Resume Error_Handler_Exit
End Sub

Private Sub Knop0_Click()

Call ExpObj2ExtDb("D:\GOEDE ACCESS PROGRAMMA\test.accdb")
End Sub

strFilenameBK = AanmaakDb(Me.Directorie,Currentdb.Name)

Call DeleteTableIfExist(strTabel)

Call ImportTabel(strDatabaseName, strTabel, strTabel)

Call ExportTabel(strFilenameBK, strTabel, strTabel)

Call DeleteTableIfExist(strTabel)

Call LinkTabelAccess(strDatabaseName, strTabel)

Private Function LinkTabelAccess(strDb As String, strTbl As String) As Boolean
Dim tdf As TableDef
    
    On Error GoTo LinkTabelAccessErr
    
    Set tdf = CurrentDb.CreateTableDef(strTbl)
    tdf.Connect = ";DATABASE=" & strDb
    tdf.SourceTableName = strTbl
    CurrentDb.TableDefs.Append tdf
    CurrentDb.TableDefs.Refresh
    
    LinkTabelAccess = True
    
LinkTabelAccessErr:
If Err.Number <> 0 Then
    Err.Clear
End If
End Function

Private Function ImportTabel(strDb As String, strTbl As String, strTblBk As String) As Boolean
    
    On Error GoTo ErrBk
    
    DoCmd.TransferDatabase acImport, "Microsoft Access", strDb, acTable, strTbl, strTblBk, False
    
    ImportTabel = True
    
ErrBk:
If Err.Number <> 0 Then
    MsgBox Err.Description, vbCritical + vbOKOnly, "Foutnummer: " & Err.Number
    Err.Clear
End If
End Function
Private Function ExportTabel(strBackupDb As String, strTbl As String, strTblBk As String) As Boolean
    
    On Error GoTo ErrBk
    
    DoCmd.TransferDatabase acExport, "Microsoft Access", strFilenameBK, acTable, strTbl, strTblBk, False
    
    ExportTabel = True
    
ErrBk:
If Err.Number <> 0 Then
    MsgBox Err.Description, vbCritical + vbOKOnly, "Foutnummer: " & Err.Number
    Err.Clear
End If
End Function

Private Function AanmaakDb(strDirBk As String, strDbname As String) As String
Dim objAccess As Object
Dim strDbTemp As String
    
    On Error GoTo AanmaakDbErr
    
    strDbTemp = "bfpl_dat_" & Day(Date) & Format(Date, "mmm") & Right(Year(Date), 2) & ".accdb"
    strDbTemp = strDirBk & strDbTemp
    
    If FileExist(strDbTemp) Then Call FileDelete(strDbTemp)

    Set objAccess = CreateObject("Access.Application")
    Call objAccess.NewCurrentDatabase(strDbTemp)
    objAccess.Quit
    If FileExist(strDbTemp) = True Then AanmaakDb = strDbTemp

AanmaakDbErr:
If Err.Number <> 0 Then
    Err.Clear
End If
End Function

Public Function DeleteTableIfExist(strTableNameExist As String) As Boolean
Dim rs As Recordset
    
    On Error GoTo TableNotExist
    
    CurrentDb.TableDefs.Delete strTableNameExist
    DeleteTableIfExist = True
    
TableNotExist:
If Err.Number > 0 Then
    Err.Clear
    Exit Function
End If
End Function

Option Compare Database
Option Explicit

Private Sub Knop0_Click()
On Error GoTo Err_backup
Dim strFullPath As String
Dim strBackendFile As String
Dim strPath As String
Dim strSourceFile As String
Dim strDestinationFile As String
Dim strFolder As String
Dim I, N As Integer
Dim fs, cf As Object


' get path to back-end using a linked table as reference. Change "tblLinked" to the name of a table within the back-end db.
' Mid function drops connection info including password (starts at character position 01)
' the 01 will need to be customized depending on the existence and length of the back-end database's password.

strFullPath = Mid(DBEngine.Workspaces(0).Databases(0).TableDefs("tblReserveringen").Connect, 1)

' uncomment next line in order to check path string in order to fine-tune the number of characters to
' truncate from the begining (by changing #01 above) in order to arrive at just the file path.
strFullPath = Mid(strFullPath, 11, Len(strFullPath) - 10)

' isolate the name of the backend database
    For I = Len(strFullPath) To 1 Step -1
        If Mid(strFullPath, I, 1) = "\" Then
            strBackendFile = Mid(strFullPath, (I + 1))
            Exit For
        End If
    Next

    For N = Len(strBackendFile) To 1 Step -1
        If Mid(strBackendFile, N, 1) = "." Then
            strBackendFile = Left(strBackendFile, (N - 1))
            Exit For
        End If
    Next

' remove the filename of the database to isolate the path
    For I = Len(strFullPath) To 1 Step -1
        If Mid(strFullPath, I, 1) = "\" Then
            strPath = Left(strFullPath, I)
            Exit For
        End If
    Next
    
strFolder = strPath & "backup" '*********Enter your backup name here************
  
  Set fs = CreateObject("Scripting.FileSystemObject")
    If fs.FolderExists(strFolder) = True Then
      '
    Else
       Set cf = fs.CreateFolder(strFolder)
    End If
   strFolder = strFolder & "\"

' reconstruct the source and destination file paths
' destination file to include the abbreviated day of the week
' \backup\ directory must already exist
' if working with <=2003 version databases, change 2 instances of ".accdb" below to ".mdb"

    strSourceFile = strPath & strBackendFile & ".accdb"
    strDestinationFile = strFolder & strBackendFile & "-" & WeekdayName(Weekday(Date - 1), True) & ".accdb"
    FileCopy strSourceFile, strDestinationFile
MsgBox "The back-end database has been backed up.", vbOKOnly, "Success"

Exit_Backup:
Exit Sub

Err_backup:
If Err.Number = 0 Then
    ElseIf Err.Number = 70 Then
        MsgBox "The file is currently in use and therefore is locked and cannot be copied at this time. Please ensure that all forms, reports, and queries are closed, and that no one is using the database and try again.", vbOKOnly, "File Currently in Use"
    ElseIf Err.Number = 53 Then
        MsgBox "The Source File '" & strSourceFile & "' could not be found. Please validate the location and name of the specifed Source File and try again", vbOKOnly, "File Not Found"
    Else
        MsgBox "Microsoft Access has generated the following error" & vbCrLf & vbCrLf & "Error Number: " & Err.Number & vbCrLf & "Error Source: ModExtFiles / CopyFile" & vbCrLf & "Error Description: " & Err.Description, vbCritical, "An Error has Occured"
End If

Resume Exit_Backup
    
End Sub