Cancellare tutti i dati di vari db esterni al DATABASE in uso e poi compattarli ( tutto da codice VBA).

Anonimo

Buon pomeriggio a tutti, chiedo l'aiuto degli esperti del forum sulla operazione che intendo eseguire su 3 database esterni rispetto a quello su cui opero.

Attualmente uso questo codice ( abbinato ad un pulsante di comando) su ognuno dei 3 DB esterni per cancellare i dati di tutte le tabelle e poi con il comando Compatta e Ripristina sistemo il tutto e ricomincio il lavoro.

Private Sub cmdCancella_Click()

If MsgBox("Sei sicuro di voler cancellare i dati?", vbCritical + vbDefaultButton2 + vbYesNo, "OPERAZIONE IRREVERSIBILE") = vbNo Then

Exit Sub

Else

CancellaTabelle

Call ClearUnbound(frmMe:=Me)

MsgBox "Cancellazione dati avvenuta con successo!", vbInformation

End If

Me.Refresh

Me.Requery

End Sub

Public Function CancellaTabelle()

CurrentDb.Execute "DELETE * FROM tblFruitori"

CurrentDb.Execute "DELETE * FROM tblTurno"

CurrentDb.Execute "DELETE * FROM tblFamiliari"

CurrentDb.Execute "DELETE * FROM tblAnniPrecedenti"

CurrentDb.Execute "DELETE * FROM tblDirectory"

End Function

Quello che vi chiedo è questo:

e' possibile con codice vba poter azzerare tutti i dati delle tabelle di uno o più database esterni ( intendo poterlo fare da un pulsante di comando posizionato su un altro db ) e compattarli contestualmente in modo da vere il campo numerazione automatica che parte sempre da 1 per tutti i db in argomento?.

E' sicuro farlo da codice oppure è meglio farlo singolarmente come già faccio.

P.S. il problema è che la procedura manuale e che osservo quotidianamente mi comporta tanti passaggi e perdita di tempo , vorrei farlo in modo automatico da codice.

Ringrazio in anticipo chi mi aiuta in questo.

Ciao Nicola.

Domanda bloccata. Questa domanda è stata eseguita dalla community del supporto tecnico Microsoft. È possibile votare se è utile, ma non è possibile aggiungere commenti o risposte o seguire la domanda.

0 commenti

Risposta accettata dall'autore della domanda

Anonimo

ciao Nicola,

mi perplime il fatto che voglia cancellare dati dal database in tal modo...

In ogni caso...se I database sono solo 3 potresti provare come segue, personalizzando il nome dei tre databases come indicato qui sotto.

La routine va inserita in un modulo standard a lanciata dalla sub kickoff() dal tuo DB da cui vuoi effettuare l'operazione.

Alla fine ottieni tre database clone dei tuoi, completamente vuoti e compattati.

Ad ogni esecuzione non hai la sovrascrittura dei precedenti perche' la modalita' di concatenazione circa la costruzione del nome ne garantisce l'unicita.

La routine ri-crea anche le relazione nei db nuovi.

Prova :

Option Compare Database

Option Explicit

Private objDbSource As Object ' Access.Application

Private newCurrentDb As DAO.Database

Public Sub kickoff()

Dim aDataBase(2) As String

Dim i As Long

aDataBase(0) = "C:\Northwind2007_3.accdb" ' personalizza path e nome del DB

aDataBase(1) = "C:\Northwind2007_4.accdb" ' personalizza path e nome del DB

aDataBase(2) = "C:\Northwind2007_5.accdb" ' personalizza path e nome del DB

Set objDbSource = CreateObject("Access.Application")

For i = 0 To UBound(aDataBase())

objDbSource.OpenCurrentDatabase filePAth:=aDataBase(i)

Set newCurrentDb = objDbSource.DBEngine(0)(aDataBase(i))

myNewdB strDataBaseFullPath:=aDataBase(i)

exit_here:

Erase aDataBase()

Set objDbSource = Nothing

Set newCurrentDb = Nothing

VBA.MsgBox prompt:="Ho finito.", _

buttons:=vbInformation, _

title:="Informazione"

Exit Sub

errHandler:

With Err

VBA.MsgBox "ERR#" & .Number _

& vbNewLine & .Description _

, vbOKOnly Or vbCritical

Resume exit_here

End With

End Sub

Private Sub myNewdB(ByVal strDataBaseFullPath As String)

On Error GoTo errHandler

Dim strRand As String

strRand = "_new_" & CStr(CLng(Rnd() * 10000 * CDbl(VBA.Now))) & ".accdb"

Dim strNewDB As String

strNewDB = GetFilePath(strPath:=strDataBaseFullPath) & GetFileText(strPath:=strDataBaseFullPath) & strRand

If FileExists(strNewDB) Then Exit Sub

With DBEngine

.Idle

Dim newDb As DAO.Database

Set newDb = .CreateDatabase(Name:=strNewDB, _

locale:=dbLangGeneral, _

option:=dbVersion120)

newDb.Close

copyTables strDBNewName:=strNewDB, strOldDbName:=strDataBaseFullPath

copyRel strDBName:=strNewDB

.CompactDatabase strNewDB, strNewDB & 2

Kill strNewDB & 2

End With

exit_here:

Set newDb = Nothing

Exit Sub

errHandler:

With Err

VBA.MsgBox "ERR#" & .Number _

& vbNewLine & .Description _

, vbOKOnly Or vbCritical

Resume exit_here

End With

End Sub

Private Sub copyTables(ByVal strDBNewName As String, ByVal strOldDbName As String)

On Error GoTo errHandler

Dim tdf As DAO.TableDef

For Each tdf In newCurrentDb.TableDefs

If Not DAO.dbSystemObject And tdf.Attributes = 0 Then

objDbSource.DoCmd.CopyObject DestinationDatabase:=strDBNewName, _

SourceObjectType:=acTable, _

SourceObjectName:=tdf.Name

newCurrentDb.Execute Query:="delete * from [" & tdf.Name & "];"

End If

exit_here:

Set tdf = Nothing

Exit Sub

errHandler:

With Err

VBA.MsgBox "ERR#" & .Number _

& vbNewLine & .Description _

, vbOKOnly Or vbCritical

Resume exit_here

End With

End Sub

Private Sub copyRel(ByVal strDBName As String)

On Error GoTo errHandler

Dim OrRel As DAO.Relation

Dim DeRel As DAO.Relation

Dim dbsBK As DAO.Database

Set dbsBK = OpenDatabase(strDBName, False, False)

For Each OrRel In newCurrentDb.Relations

' If OrRel.Attributes = 0 Then

If Left$(OrRel.Name, 4) <> "msys" Then

'Debug.Print OrRel.ForeignTable

Set DeRel = dbsBK.CreateRelation(Name:="new" & OrRel.Name, _

Table:=OrRel.Table, _

ForeignTable:=OrRel.ForeignTable, _

Attributes:=OrRel.Attributes)

DeRel.Fields.Append DeRel.CreateField(OrRel.Fields(0).Name)

DeRel.Fields(DeRel.Fields(0).Name).ForeignName = OrRel.Fields(0).ForeignName

dbsBK.Relations.Append DeRel

End If

Set OrRel = Nothing

Set DeRel = Nothing

Set dbsBK = Nothing

objDbSource.CloseCurrentDatabase

newCurrentDb.Close

exit_here:

Set OrRel = Nothing

Set DeRel = Nothing

Set dbsBK = Nothing

Exit Sub

errHandler:

With Err

VBA.MsgBox "ERR#" & .Number _

& vbNewLine & .Description _

, vbOKOnly Or vbCritical

Resume exit_here

End With

End Sub

Private Function FileExists(strPathFile As String) As Boolean

On Error Resume Next

FileExists = ((GetAttr(strPathFile) And vbDirectory) = 0)

End Function

Public Function GetFilePath(strPath As String) As String

Dim strIn As String

strIn = Mid$(strPath, 1, InStrRev(strPath, ""))

GetFilePath = strIn

End Function

Public Function GetFileName(strPath As String) As String

Dim strIn As String

strIn = Mid$(strPath, InStrRev(strPath, "") + 1, 255)

GetFileName = strIn

End Function

Public Function GetFileText(strPath As String) As String

Dim strIn As String

Dim intStart As Integer

Dim intStop As Integer

intStart = InStrRev(strPath, "") + 1

intStop = InStrRev(strPath, ".")

strIn = Mid$(strPath, intStart, intStop - intStart)

strIn = Replace(strIn, "'", "''")

strIn = Replace(strIn, ".", "")

GetFileText = strIn

End Function

HTH.

Ciao, Sandro

0 commenti

9 risposte aggiuntive

Anonimo

2019-04-15T19:36:28+00:00

ciao Nicola,

per rendere il tutto maggiormente flessibile prova con questa soluzione, ti lascio il link della demo in fondo al post.

una form che richiama un oggetto specifico clsExport che si occupa dell'itera procedura di export indipendentemente dal numero di database.

Ho voluto inserire due semplici barre di progressione (senza Ocx ovviamente) che danno evidenza dello status dell'esportazione sia per quanto alle tabelle che per i database, anch'esse gestite dalla classi.

La stessa si occupa anche della gestione di due immagini e delle textoboxes che via via mostrano i vari messaggi.

La form resta sempre molto leggera _:

Option Compare Database

Option Explicit

Private exportDB As clsExport

Private Sub cmdExport_Click()

Set exportDB = New clsExport

With Me

    exportDB.Path = CurrentProject.Path & ""

    exportDB.init lbl:=.lblProgress, _

          RECT:=.outerPB, _

          lblM:=.lblMessage, _

          lbl2:=.lblWholeProgress, _

          rect2:=.outerWholePB, _

          lblM2:=.lblWholeMessage, _

          imgOK1:=.imgOK1, _

          imgOK2:=.imgOK2

End With

End Sub

Private Sub Form_Unload(Cancel As Integer)

Set exportDB = Nothing

End Sub

questa la classe clsExport.

Option Compare Database

Option Explicit

Private mPath                 As String

Private objDbSource           As Object ' Access.Application

Private newCurrentDb          As DAO.Database

Private aDataBase()           As String

Private sngPr                 As Single

Private bool                  As Boolean

Private lblPB                 As Access.label

Private rectPB                As Access.Rectangle

Private lblMessage            As Access.label

Private lblPB2                As Access.label

Private rectPB2               As Access.Rectangle

Private lblMessage2           As Access.label

Private imgOK1                As Access.Image

Private imgOK2                As Access.Image

Public Function cmdFileDialog() As String

     Dim fDialog      As Object

     Dim strFile      As Variant

     Dim varFiles     As Variant

     Set fDialog = Application.FileDialog(3)

     With fDialog

       .title = "Seleziona uno o più databases:"

       .AllowMultiSelect = True

       .Filters.Clear

       .Filters.Add "files di Ms-Access", "*.accdb, *.accde, *.mdb"

       .InitialFileName = Me.Path

       strFile = vbNullString

       If .Show Then

          For Each varFiles In .SelectedItems

               strFile = strFile & "," & varFiles

          Next

       End If

     End With

     If Len(strFile) > 0 Then

        strFile = Mid$(strFile, 2)

     End If

     cmdFileDialog = strFile

     Set fDialog = Nothing

End Function

Private Sub Class_Initialize()

    Set objDbSource = CreateObject("Access.Application")

End Sub

Public Property Get Path() As String

    Path = mPath

End Property

Public Property Let Path(ByVal Path As String)

    mPath = Path

End Property

Public Sub init(ByVal lbl As Access.label, _

                ByVal RECT As Access.Rectangle, _

                ByVal lblM As Access.label, _

                ByVal lbl2 As Access.label, _

                ByVal rect2 As Access.Rectangle, _

                ByVal lblM2 As Access.label, _

                ByVal imgOK1 As Access.Image, _

                ByVal imgOK2 As Access.Image)

On Error GoTo errHandler

Dim i            As Long

Dim strFileName As String

Dim lngCur       As Long

Dim lngMax       As Long

    With Me

        strFileName = .cmdFileDialog()

        If Len(strFileName) > 0 Then

                If Not lbl Is Nothing Then

                    lbl.Width = 0

                    Set .progressBar = lbl

                End If

                If Not RECT Is Nothing Then

                    Set .progressRect = RECT

                End If

                If Not lblM Is Nothing Then

                    Set .progressMessage = lblM

                End If

                If Not lbl2 Is Nothing Then

                    lbl2.Width = 0

                    Set .progressBar2 = lbl2

                End If

                If Not rect2 Is Nothing Then

                    Set .progressRect2 = rect2

                End If

                If Not lblM2 Is Nothing Then

                    Set .progressMessage2 = lblM2

                End If

                If Not imgOK1 Is Nothing Then

                    Set .imageOk1 = imgOK1

                End If

                If Not imgOK2 Is Nothing Then

                    Set .imageOk2 = imgOK2

                End If

            aDataBase = Split(strFileName, ",")

            lngCur = 1

            lngMax = UBound(aDataBase()) + 1

            For i = 0 To UBound(aDataBase())

                 objDbSource.OpenCurrentDatabase filePAth:=aDataBase(i)

                Set newCurrentDb = objDbSource.DBEngine(0)(aDataBase(i))

                isProgressVisible bool:=True

                imgOK2.Visible = False

                lblM2.Visible = False

                .myNewdB strDataBaseFullPath:=aDataBase(i)

                pbar lngCurrentPr:=lngCur, _

                     lngMaxPr:=lngMax, _

                     r:=rectPB2, _

                     label:=lblPB2

                lngCur = lngCur + 1

                imgOK2.Visible = True

                With lblM2

                    .Visible = True

                    .Caption = "Esportazione completata " & aDataBase(i)

                End With

            Next

           VBA.MsgBox prompt:="Ho finito.", _

                      buttons:=vbInformation, _

                      title:="Informazione"

           isProgressVisible bool:=False

           lbl.Visible = False

           lblM2.Visible = False

           imgOK1.Visible = False

           imgOK2.Visible = False

        End If

    End With

exit_here:

    Exit Sub

errHandler:

    With Err

        VBA.MsgBox "ERR#" & .Number _

                   & vbNewLine & .Description _

                  , vbOKOnly Or vbCritical

        Resume exit_here

    End With

End Sub

Public Sub myNewdB(ByVal strDataBaseFullPath As String)

On Error GoTo errHandler

Dim strRand      As String

Dim lngCur       As Long

Dim lngMax       As Long

strRand = "_new_" & CStr(CLng(Rnd() * 10000 * CDbl(VBA.Now))) & ".accdb"

Dim strNewDB As String

strNewDB = GetFilePath(strPath:=strDataBaseFullPath) & GetFileText(strPath:=strDataBaseFullPath) & strRand

If FileExists(strNewDB) Then Exit Sub

With DBEngine

    .Idle

    Dim newDb As DAO.Database

    Set newDb = .CreateDatabase(Name:=strNewDB, _

                                locale:=dbLangGeneral, _

                                option:=dbVersion120)

    newDb.Close

    Me.copyTables strDBNewName:=strNewDB

    Me.copyRel strDBName:=strNewDB

    .CompactDatabase strNewDB, strNewDB & 2

    VBA.Kill strNewDB & 2

End With

exit_here:

    Set newDb = Nothing

    Exit Sub

errHandler:

    With Err

        VBA.MsgBox "ERR#" & .Number _

                   & vbNewLine & .Description _

                  , vbOKOnly Or vbCritical

        Resume exit_here

    End With

End Sub

Public Sub copyTables(ByVal strDBNewName As String)

On Error GoTo errHandler

Dim tdf          As DAO.TableDef

Dim lngCur       As Long

Dim lngMax       As Long

lngCur = 1

lngMax = populateTables(strDBNewName:=strDBNewName)

imgOK1.Visible = False

lblMessage.Visible = True

For Each tdf In newCurrentDb.TableDefs

    If Not DAO.dbSystemObject And tdf.Attributes = 0 Then

        objDbSource.DoCmd.CopyObject DestinationDatabase:=strDBNewName, _

                                      SourceObjectType:=acTable, _

                                      SourceObjectName:=tdf.Name

        newCurrentDb.Execute Query:="delete * from [" & tdf.Name & "];"

        pbar lngCurrentPr:=lngCur, _

             lngMaxPr:=lngMax, _

             r:=rectPB, _

             label:=lblPB

        lngCur = lngCur + 1

        lblMessage.Caption = "Sto esportando in " & newCurrentDb.Name & " la tabella : " & tdf.Name

    End If

Next

imgOK1.Visible = True

lblMessage.Visible = False

exit_here:

    Set tdf = Nothing

    Exit Sub

errHandler:

    With Err

        VBA.MsgBox "ERR#" & .Number _

                   & vbNewLine & .Description _

                  , vbOKOnly Or vbCritical

        Resume exit_here

    End With

End Sub

Public Sub copyRel(ByVal strDBName As String)

On Error GoTo errHandler

Dim OrRel As DAO.Relation

Dim DeRel As DAO.Relation

Dim dbsBK As DAO.Database

Set dbsBK = OpenDatabase(Name:=strDBName, options:=False, readonly:=False)

For Each OrRel In newCurrentDb.Relations

' If OrRel.Attributes = 0 Then

    If Left$(OrRel.Name, 4) <> "msys" Then

         'Debug.Print OrRel.ForeignTable

            Set DeRel = dbsBK.CreateRelation(Name:="new" & OrRel.Name, _

                                   Table:=OrRel.Table, _

                                   ForeignTable:=OrRel.ForeignTable, _

                                   Attributes:=OrRel.Attributes)

            DeRel.Fields.Append DeRel.CreateField(OrRel.Fields(0).Name)

            DeRel.Fields(DeRel.Fields(0).Name).ForeignName = OrRel.Fields(0).ForeignName

            dbsBK.Relations.Append DeRel

    End If

Next

Set OrRel = Nothing

Set DeRel = Nothing

Set dbsBK = Nothing

objDbSource.CloseCurrentDatabase

newCurrentDb.Close

exit_here:

    Set OrRel = Nothing

    Set DeRel = Nothing

    Set dbsBK = Nothing

    Exit Sub

errHandler:

    With Err

        VBA.MsgBox "ERR#" & .Number _

                   & vbNewLine & .Description _

                  , vbOKOnly Or vbCritical

        Resume exit_here

    End With

End Sub

Private Function FileExists(strPathFile As String) As Boolean

      On Error Resume Next

      FileExists = ((GetAttr(strPathFile) And vbDirectory) = 0)

End Function

Private Sub Class_Terminate()

    Erase aDataBase()

    Set objDbSource = Nothing

    Set newCurrentDb = Nothing

    Set lblPB = Nothing

    Set rectPB = Nothing

    Set lblMessage = Nothing

    Set lblPB2 = Nothing

    Set rectPB2 = Nothing

    Set lblMessage2 = Nothing

End Sub

Private Sub pbar(ByVal lngCurrentPr, _

                 ByVal lngMaxPr, _

                 ByVal r As Access.Rectangle, _

                 ByVal label As Access.label)

sngPr = lngCurrentPr / lngMaxPr

With label

    .Width = sngPr * r.Width

    .Caption = Format$(sngPr, "##.00%")

     If sngPr < 0.1 Then

        .Caption = vbNullString

     End If

End With

End Sub

Public Property Set progressBar(ByVal lbl As Access.label)

    Set lblPB = lbl

End Property

Public Property Set progressRect(ByVal RECT As Access.Rectangle)

    Set rectPB = RECT

End Property

Public Property Set progressMessage(ByVal lblM As Access.label)

    Set lblMessage = lblM

End Property

Public Property Set progressBar2(ByVal lbl2 As Access.label)

    Set lblPB2 = lbl2

End Property

Public Property Set progressRect2(ByVal rect2 As Access.Rectangle)

    Set rectPB2 = rect2

End Property

Public Property Set progressMessage2(ByVal lblM2 As Access.label)

    Set lblMessage2 = lblM2

End Property

Public Property Set imageOk1(ByVal imageOk1 As Access.Image)

    Set imgOK1 = imageOk1

End Property

Public Property Set imageOk2(ByVal imageOk2 As Access.Image)

    Set imgOK2 = imageOk2

End Property

Private Sub isProgressVisible(ByVal bool As Boolean)

        lblPB.Visible = bool

        rectPB.Visible = bool

        lblPB2.Visible = bool

        rectPB2.Visible = bool

End Sub

Private Function populateTables(ByVal strDBNewName As String) As Long

On Error GoTo errHandler

Dim tdf          As DAO.TableDef

Dim lngMax       As Long

Dim strSql       As String

Dim strSql2      As String

'Dim BoolT        As Boolean

strSql = "insert into T_tabelle (nometabella, nomeDB) values ('"

With newCurrentDb

   ' objDbSource.DBEngine(0)(0).BeginTrans

        'BoolT = True

        For Each tdf In .TableDefs

            If Not DAO.dbSystemObject And tdf.Attributes = 0 Then

                    lngMax = lngMax + 1

                    strSql2 = strSql & tdf.Name & "','" & .Name & "');"

                    DBEngine(0)(0).Execute Query:=strSql2, options:=&H80

            End If

        Next

    'objDbSource.DBEngine.CommitTrans options:=1 '1=dbForceOSFlush

End With

populateTables = lngMax

exit_here:

    Set tdf = Nothing

    Exit Function

errHandler:

    'If BoolT Then

    '    objDbSource.DBEngine.Rollback

    'End If

    With Err

        VBA.MsgBox "ERR#" & .Number _

                   & vbNewLine & .Description _

                  , vbOKOnly Or vbCritical

        Resume exit_here

    End With

End Function

questo il link della DEMO.

Ci sono altre implementazioni possibili e migliorie che mi vengono in mente….tipo strutturare meglio database e tabelle, implementare meglio la gestione dei messaggi...parte grafica in generale.....

Vedi se ti piace…!

Ciao, Sandro.
La risposta è stata utile?

1 persona ha trovato utile questa risposta.

0 commenti Nessun commento
Anonimo

2019-04-11T08:19:17+00:00

Ho inteso bene i tuoi consigli, comunque da quando frequento questo bellissimo forum, come prima cosa che faccio nei miei file è la copia di Backup periodica ed anche in questo caso ho sempre i miei DB originali sempre salvati e prima di lanciare la tua routine me ne creo una copia.

Sono felicissimo di avervi sempre vicino pronti ad aiutarmi in ogni mia richiesta.

Provo il tuo codice e ti aggiorno.

Ciao Nicola.
La risposta è stata utile?

0 commenti Nessun commento
Anonimo

2019-04-11T07:53:50+00:00

ciao Nicola.,

cancellare senza avere copie di sicurezza mi pare alquanto periglioso...

La mia routine non va a intaccare i db's originali, ma crea copie degli originali e cancella i dati delle tabelle solo nelle copie.

Se ti servono li hai sempre a disposizione ( i dati ).

Cancellare senza avere la certezza che i dati possono essere recuperati ti mette nella condizione che 3 secondi dopo avere cancellato tutto avevi sicuramente bisogno di quei dati…! :-)

HTH.

Ciao, Sandro.

ps. presta attenzione anche all'invocazione multipla di currentDB...e' una funzione che restituisce ogni volta un nuovo oggetto e di conseguenza molto lenta….
La risposta è stata utile?

0 commenti Nessun commento
Anonimo

2019-04-11T07:35:09+00:00

Ciao Sandro, buongiorno.

Quanto a questo:

ciao Nicola,

mi perplime il fatto che voglia cancellare dati dal database in tal modo…

Perché mi dici questo?

Me lo sconsigli questo procedimento per eventuali problemi oppure altro, se è cosi ascolto la tua professionalità ed esperienza a non proceder in questo modo.

Attendo una tua riflessione e spiegazione su questo.

Ciao Nicola.
La risposta è stata utile?

0 commenti Nessun commento