Auto Archive Function

**Desstro** · 09-07-2010, 06:08 AM

For Forum Purposes, this is what the code should look like.

Private Sub Posted_Click()
On Error GoTo Err_DoArchive
Dim ws As DAO.Workspace 'Current workspace (for transaction).
Dim db As DAO.Database 'Inside the transaction.
Dim bInTrans As Boolean 'Flag that transaction is active.
Dim strSql As String 'Action query statements.
Dim strMsg As String 'MsgBox message.

'Step 1: Initialize database object inside a transaction.
Set ws = DBEngine(0)
ws.BeginTrans
bInTrans = True
Set db = ws(0)

'Step 2: Execute the append.
strSql = "INSERT INTO InternalPostedPackageArchive (PackageNumber, Program, FacilityArea, FacilityLocation, Comments) " & _
"IN ""C:\Documents and Settings\thorcc\Desktop\Database Work\InternalPostedPackageArchive.accdb"" " & _

"SELECT PackageNumber, Program, FacilityArea, FacilityLocation, Comments FROM PkgsReceivedandScheduledStatus WHERE (Posted = True);"
db.Execute strSql, dbFailOnError

'Step 3: Execute the delete.
strSql = "DELETE FROM PkgsReceivedandScheduledStatus WHERE (Posted = True);"
db.Execute strSql, dbFailOnError

'Step 4: Get user confirmation to commit the change.
strMsg = "Archive " & db.RecordsAffected & " record(s)?"
If MsgBox(strMsg, vbOKCancel + vbQuestion, "Confirm") = vbOK Then
ws.CommitTrans
bInTrans = False
End If

Exit_DoArchive:
'Step 5: Clean up
On Error Resume Next
Set db = Nothing
If bInTrans Then 'Rollback if the transaction is active.
ws.Rollback
End If
Set ws = Nothing
Exit Sub

Err_DoArchive:
MsgBox Err.Description, vbExclamation, "Archiving failed: Error " & Err.Number
Resume Exit_DoArchive

End Sub

**RuralGuy** · 09-07-2010, 06:42 AM

Thanks for sharing and marking the thread as Solved.

**Desstro** · 09-07-2010, 11:55 PM

So I had to unsolve this thread because there is a problem with the code....or something...it's weird.

Here is the code:

Private Sub Posted_Click()
On Error GoTo Err_DoArchive
Dim ws As DAO.Workspace 'Current workspace (for transaction).
Dim db As DAO.Database 'Inside the transaction.
Dim bInTrans As Boolean 'Flag that transaction is active.
Dim strSql As String 'Action query statements.
Dim strMsg As String 'MsgBox message.

'Step 1: Initialize database object inside a transaction.
Set ws = DBEngine(0)
ws.BeginTrans
bInTrans = True
Set db = ws(0)

'Step 2: Execute the append.
strSql = "INSERT INTO InternalPostedPackageArchive (PackageNumber, Program, FacilityArea, FacilityLocation, Comments) " & _
"IN ""C:\Documents and Settings\thorcc\Desktop\Database Work\InternalPostedPackageArchive.accdb"" " & _
"SELECT PackageNumber, Program, FacilityArea, FacilityLocation, Comments FROM PkgsReceivedandScheduledStatus WHERE (Posted = True);"
db.Execute strSql, dbFailOnError

'Step 3: Execute the delete.
strSql = "DELETE FROM PkgsReceivedandScheduledStatus WHERE (Posted = True);"
db.Execute strSql, dbFailOnError

'Step 4: Get user confirmation to commit the change.
strMsg = "Archive " & db.RecordsAffected & " record(s)?"
If MsgBox(strMsg, vbOKCancel + vbQuestion, "Confirm") = vbOK Then
ws.CommitTrans
bInTrans = False
End If

Exit_DoArchive:
'Step 5: Clean up
On Error Resume Next
Set db = Nothing
If bInTrans Then 'Rollback if the transaction is active.
ws.Rollback
End If
Set ws = Nothing
Exit Sub

Err_DoArchive:
MsgBox Err.Description, vbExclamation, "Archiving failed: Error " & Err.Number
Resume Exit_DoArchive

End Sub

The code is written into the onclick event for a yes/no field.

What is happening is when I select the yes no field to equal yes, the message box opens asking if I want to "Archive 0 record(s)". (figure1) Should be 1 record. I push ok anyway and and the confirm box goes away but nothing else happens. Record is not archived. I right click on the form and save form. Still Nothing. I then click the yes/no field to equal no and the confirm box opens again asking to "Archive 1 record(s)" (figure 2). I push ok and nothing....right click save, record gets archived.(figure3)

Please help me with this because I am thoroughly confused.

What I want to happen is I click to =yes and then confirm box opens. Click OK and record gets archived. No saving...extra clicks. Yes/OK done.

I think what is happening is the yes from the form is not being written to the table before the rest of the code applies. Is there some code I can add to the beginning of the current on onlick event that saves the data to the table first and then goes through the rest of the code?

**RuralGuy** · 09-08-2010, 06:09 AM

If Me.Dirty Then Me.Dirty = False
...will save any current Dirty record.

**Desstro** · 09-08-2010, 06:15 AM

Pardon my ignorance, but where should i put that in the code?

**RuralGuy** · 09-08-2010, 06:23 AM

Right at the beginning of the executing code after all of the Dim statements. BTW, you used the "quote" tags instead of the "code" tags. "Code" tags preserve formatting (indenting) and "quote" tages do not.

**Desstro** · 09-08-2010, 06:28 AM

I put that in after the DIM Statements and I get an error.

Archiving Failed: Error 3218
Could not update; currently locked.

I'll paste the code in again.

Code:

Private Sub Posted_Click()
On Error GoTo Err_DoArchive
  Dim ws As DAO.Workspace   'Current workspace (for transaction).
  Dim db As DAO.Database    'Inside the transaction.
  Dim bInTrans As Boolean   'Flag that transaction is active.
  Dim strSql As String      'Action query statements.
  Dim strMsg As String      'MsgBox message.
  
  If Me.Dirty Then Me.Dirty = False

  'Step 1: Initialize database object inside a transaction.
  Set ws = DBEngine(0)
  ws.BeginTrans
  bInTrans = True
  Set db = ws(0)

  'Step 2: Execute the append.
  strSql = "INSERT INTO InternalPostedPackageArchive (PackageNumber, Program, FacilityArea, FacilityLocation, Comments) " & _
    "IN ""C:\Documents and Settings\thorcc\Desktop\Database Work\InternalPostedPackageArchive.accdb"" " & _
    "SELECT PackageNumber, Program, FacilityArea, FacilityLocation, Comments FROM PkgsReceivedandScheduledStatus WHERE (Posted = True);"
  db.Execute strSql, dbFailOnError

  'Step 3: Execute the delete.
  strSql = "DELETE FROM PkgsReceivedandScheduledStatus WHERE (Posted = True);"
  db.Execute strSql, dbFailOnError

  'Step 4: Get user confirmation to commit the change.
  strMsg = "Archive " & db.RecordsAffected & " record(s)?"
  If MsgBox(strMsg, vbOKCancel + vbQuestion, "Confirm") = vbOK Then
    ws.CommitTrans
    bInTrans = False
  End If

Exit_DoArchive:
  'Step 5: Clean up
  On Error Resume Next
  Set db = Nothing
  If bInTrans Then   'Rollback if the transaction is active.
    ws.Rollback
  End If
  Set ws = Nothing
Exit Sub

Err_DoArchive:
  MsgBox Err.Description, vbExclamation, "Archiving failed: Error " & Err.Number
  Resume Exit_DoArchive

End Sub

**RuralGuy** · 09-08-2010, 06:56 AM

Hmm...OK remove that code and add a test for:
If Me.Posted Then
.. your current code
..
..
End If
...around all of the code.

**Desstro** · 09-08-2010, 07:04 AM

I'm not quite sure what you mean by,

"End If
...around all of the code."

**RuralGuy** · 09-08-2010, 07:11 AM

This is what I mean:

Code:

Private Sub Posted_Click()
   On Error GoTo Err_DoArchive
   Dim ws As DAO.Workspace  'Current workspace (for transaction).
   Dim db As DAO.Database   'Inside the transaction.
   Dim bInTrans As Boolean  'Flag that transaction is active.
   Dim strSql As String     'Action query statements.
   Dim strMsg As String     'MsgBox message.
   If Me.Posted Then
      'Step 1: Initialize database object inside a transaction.
      Set ws = DBEngine(0)
      ws.BeginTrans
      bInTrans = True
      Set db = ws(0)
      'Step 2: Execute the append.
      strSql = "INSERT INTO InternalPostedPackageArchive (PackageNumber, Program, FacilityArea, FacilityLocation, Comments) " & _
               "IN ""C:\Documents and Settings\thorcc\Desktop\Database Work\InternalPostedPackageArchive.accdb"" " & _
               "SELECT PackageNumber, Program, FacilityArea, FacilityLocation, Comments FROM PkgsReceivedandScheduledStatus WHERE (Posted = True);"
      db.Execute strSql, dbFailOnError
      'Step 3: Execute the delete.
      strSql = "DELETE FROM PkgsReceivedandScheduledStatus WHERE (Posted = True);"
      db.Execute strSql, dbFailOnError
      'Step 4: Get user confirmation to commit the change.
      strMsg = "Archive " & db.RecordsAffected & " record(s)?"
      If MsgBox(strMsg, vbOKCancel + vbQuestion, "Confirm") = vbOK Then
         ws.CommitTrans
         bInTrans = False
      End If
   End If
Exit_DoArchive:
   'Step 5: Clean up
   On Error Resume Next
   Set db = Nothing
   If bInTrans Then  'Rollback if the transaction is active.
      ws.Rollback
   End If
   Set ws = Nothing
   Exit Sub
Err_DoArchive:
   MsgBox Err.Description, vbExclamation, "Archiving failed: Error " & Err.number
   Resume Exit_DoArchive
End Sub

**Desstro** · 09-08-2010, 07:22 AM

ok...

Here's the code...

Code:

Private Sub Posted_Click()
On Error GoTo Err_DoArchive
  Dim ws As DAO.Workspace   'Current workspace (for transaction).
  Dim db As DAO.Database    'Inside the transaction.
  Dim bInTrans As Boolean   'Flag that transaction is active.
  Dim strSql As String      'Action query statements.
  Dim strMsg As String      'MsgBox message.
  If Me.Posted Then

  'Step 1: Initialize database object inside a transaction.
  Set ws = DBEngine(0)
  ws.BeginTrans
  bInTrans = True
  Set db = ws(0)

  'Step 2: Execute the append.
  strSql = "INSERT INTO InternalPostedPackageArchive (PackageNumber, Program, FacilityArea, FacilityLocation, Comments) " & _
    "IN ""C:\Documents and Settings\thorcc\Desktop\Database Work\InternalPostedPackageArchive.accdb"" " & _
    "SELECT PackageNumber, Program, FacilityArea, FacilityLocation, Comments FROM PkgsReceivedandScheduledStatus WHERE (Posted = True);"
  db.Execute strSql, dbFailOnError

  'Step 3: Execute the delete.
  strSql = "DELETE FROM PkgsReceivedandScheduledStatus WHERE (Posted = True);"
  db.Execute strSql, dbFailOnError

  'Step 4: Get user confirmation to commit the change.
  strMsg = "Archive " & db.RecordsAffected & " record(s)?"
  If MsgBox(strMsg, vbOKCancel + vbQuestion, "Confirm") = vbOK Then
    ws.CommitTrans
    bInTrans = False
  End If
  End If
Exit_DoArchive:
  'Step 5: Clean up
  On Error Resume Next
  Set db = Nothing
  If bInTrans Then   'Rollback if the transaction is active.
    ws.Rollback
  End If
  Set ws = Nothing
Exit Sub

Err_DoArchive:
  MsgBox Err.Description, vbExclamation, "Archiving failed: Error " & Err.Number
  Resume Exit_DoArchive

End Sub

see image for what happens. back to "Archive o record(s) and I push ok and nothing.

**Desstro** · 09-08-2010, 07:38 AM

Well i have to go now....thanks for your continuous support. Hopefully when I get back to work tomorrow there will be a golden answer to this perpetual problem.

Thanks again...until tomorrow.

**RuralGuy** · 09-08-2010, 08:24 AM

Posting your db would be very helpful for us to troubleshoot the issue with.

**Desstro** · 09-09-2010, 12:58 AM

Ok, I came up with a simple solution.

I removed the code from the onclick event from the yes/no field.

I added a button to the header of the form and put the code in its onclick event.

I added simple instructions to the form on how to perform its function. (see image)

What I was trying to achieve now works like a dream.

The code in the onclick event for the button is:

Code:

Private Sub Command17_Click()
On Error GoTo Err_DoArchive
  Dim ws As DAO.Workspace   'Current workspace (for transaction).
  Dim db As DAO.Database    'Inside the transaction.
  Dim bInTrans As Boolean   'Flag that transaction is active.
  Dim strSql As String      'Action query statements.
  Dim strMsg As String      'MsgBox message.

  'Step 1: Initialize database object inside a transaction.
  Set ws = DBEngine(0)
  ws.BeginTrans
  bInTrans = True
  Set db = ws(0)

  'Step 2: Execute the append.
  strSql = "INSERT INTO InternalPostedPackageArchive (PostedDate, PackageNumber, Program, FacilityArea, FacilityLocation, Comments) " & _
    "IN ""C:\Documents and Settings\thorcc\Desktop\Database Work\InternalPostedPackageArchive.accdb"" " & _
    "SELECT PostedDate, PackageNumber, Program, FacilityArea, FacilityLocation, Comments FROM PkgsReceivedandScheduledStatus WHERE (Posted = True);"
  db.Execute strSql, dbFailOnError

  'Step 3: Execute the delete.
  strSql = "DELETE FROM PkgsReceivedandScheduledStatus WHERE (Posted = True);"
  db.Execute strSql, dbFailOnError

  'Step 4: Get user confirmation to commit the change.
  strMsg = "Archive " & db.RecordsAffected & " record(s)?"
  If MsgBox(strMsg, vbOKCancel + vbQuestion, "Confirm") = vbOK Then
    ws.CommitTrans
    bInTrans = False
  End If

Exit_DoArchive:
  'Step 5: Clean up
  On Error Resume Next
  Set db = Nothing
  If bInTrans Then   'Rollback if the transaction is active.
    ws.Rollback
  End If
  Set ws = Nothing
Exit Sub

Err_DoArchive:
  MsgBox Err.Description, vbExclamation, "Archiving failed: Error " & Err.Number
  Resume Exit_DoArchive
End Sub

What was wrong was, because the DB isn't updated by just checking the yes/no field on the form, the table that this code is written for did not show that the yes/no field had been modified by the form.

This way the instructions are to modify the data. Save the data. Click submit which now runs the archive code.

Problem solved as far as I'm concerned.

I'm not quite sure how to upload my DB into here but if you don't mind explaining it to me I would be more than happy to.

I tried with the "manage attachments", but the file type was not supported.

**RuralGuy** · 09-09-2010, 09:23 AM

Compact and Repair your db first and then zip it up before uploading.

Auto Archive Function

Thread Tools

Unsolved

Similar Threads

Delete button with archive Table

How do I archive a report?

Archive and Compact function

Want function to get current function name

Archive data

Posting Permissions