'----------------------------------------------------------------
' Hands-On 16.1
'----------------------------------------------------------------

Sub Custom_Recordset()
  Dim rst As ADODB.Recordset
  Dim strFile As String
  Dim strPath As String
  Dim strFolder As String

  Const MyFolder = "C:\VBAAccess2016_ByExample"
  strPath = InputBox("Enter pathname, e.g., " & MyFolder, _
   "Enter the Folder Name", MyFolder)
  If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
  strFolder = strPath
  strFile = Dir(strPath & "*.*")
  If strFile = "" Then
    MsgBox "This folder does not contain files."
    Exit Sub
  End If
  Set rst = New ADODB.Recordset
  ' Create an empty recordset with 3 fields
  With rst
    Set .ActiveConnection = Nothing
    .CursorLocation = adUseClient
    With .Fields
      .Append "Name", adVarChar, 255
      .Append "Size", adDouble
      .Append "Modified", adDBTimeStamp
    End With
    .Open
    Do While strFile <> ""
      If strFile = "" Then Exit Do
      ' Add a new record to the recordset
      .AddNew Array("Name", "Size", "Modified"), _
      Array(strFile, FileLen(strFolder & strFile), _
      FileDateTime(strFolder & strFile))
      strFile = Dir
    Loop
    .MoveFirst
    ' Print the contents of the recordset
    ' to the Immediate window
    Do Until .EOF
      Debug.Print !Name & vbTab & !Size & vbTab & !Modified
      .MoveNext
    Loop
    .Close
  End With
  Set rst = Nothing
End Sub


----------------------------------------------------------------
' Hands-On 16.2
'----------------------------------------------------------------

Sub Rst_Disconnected()
  Dim conn As ADODB.Connection
  Dim rst As ADODB.Recordset
  Dim strConn As String
  Dim strSQL As String
  Dim strRst As String
  Dim strFilePath As String
  
  strFilePath = "C:\VBAAccess2016_ByExample\Northwind.mdb"
  strSQL = "SELECT * FROM Orders WHERE CustomerID = 'VINET'"
  
  strConn = "Provider=Microsoft.Jet.OLEDB.4.0;"
  strConn = strConn & "Data Source = " & strFilePath
  Set conn = New ADODB.Connection
  conn.ConnectionString = strConn
  conn.Open
  
  Set rst = New ADODB.Recordset
  Set rst.ActiveConnection = conn
  
  ' retrieve the data
  rst.CursorLocation = adUseClient
  rst.LockType = adLockBatchOptimistic
  rst.CursorType = adOpenStatic
  rst.Open strSQL, , , , adCmdText
  
  ' disconnect the recordset
  Set rst.ActiveConnection = Nothing
  
  ' change the CustomerID in the first record to 'OCEAN'
  rst.MoveFirst
  Debug.Print rst.Fields(0) & " was previously: " _
    & rst.Fields(1)
  rst.Fields("CustomerID").Value = "OCEAN"
  rst.Update
  
  ' stream out the recordset as a comma-delimited string
  strRst = rst.GetString(adClipString, , ",")
  Debug.Print strRst
End Sub



'----------------------------------------------------------------
' Hands-On 16.3
'----------------------------------------------------------------

Sub SaveRecordsToDisk()
  Dim conn As ADODB.Connection
  Dim rst As ADODB.Recordset
  Dim strFileName As String
  Dim strNorthPath As String

  strFileName = CurrentProject.Path & "\Companies.rst"
  strNorthPath = CurrentProject.Path & "\Northwind.mdb"

  On Error GoTo ErrorHandler

  Set conn = New ADODB.Connection

  With conn
    .Provider = "Microsoft.Jet.OLEDB.4.0"
    .ConnectionString = "Data Source = " & strNorthPath
    .Mode = adModeReadWrite
    .Open
  End With

  Set rst = New ADODB.Recordset
  With rst
    .CursorLocation = adUseClient
    ' Retrieve the data
    .Open "Customers", conn, _
    adOpenKeyset, adLockBatchOptimistic, adCmdTable
    
    ' Disconnect the recordset
    .ActiveConnection = Nothing
    
    ' Save the recordset to disk
    .Save strFileName, adPersistADTG
    .Close
  End With

  MsgBox "Records were saved in " & strFileName & "."
ExitHere:
  ' Cleanup
  Set rst = Nothing
Exit Sub
ErrorHandler:
  If Not IsEmpty(Dir(strFileName)) Then
    Kill strFileName
    Resume
  Else
    MsgBox Err.Number & ": " & Err.Description
    Resume ExitHere
    End If
End Sub



'----------------------------------------------------------------
' Custom Project 16.1
'----------------------------------------------------------------

Private Sub Form_Load()
  Dim rst As ADODB.Recordset
  Dim strRowSource As String
  Dim strName As String
  
  strName = CurrentProject.Path & "\Companies.rst"
  
  Set rst = New ADODB.Recordset
    With rst
        .CursorLocation = adUseClient
        .Open strName, , , , adCmdFile
        Do Until .EOF
            strRowSource = strRowSource & rst!CompanyName & ";"
            .MoveNext
        Loop
        With Me.cboCompany
            .RowSourceType = "Value List"
            .RowSource = strRowSource
        End With
        .Close
    End With
    Set rst = Nothing
End Sub


'----------------------------------------------------------------
' Custom Project 16.2
'----------------------------------------------------------------

Dim rst As ADODB.Recordset
Dim counter As Integer

Private Sub Form_Load()
    Dim strFileName As String
      
    strFileName = CurrentProject.Path & "\Companies.rst"
                
    On Error GoTo ErrorHandler
         
    Set rst = New ADODB.Recordset
    With rst
        .CursorLocation = adUseClient
        .Open strFileName, , adOpenKeyset, _
            adLockBatchOptimistic, adCmdFile
    End With
    
    counter = 1
    Call FillTxtBoxes(rst, Me)
    
    With Me
        .txtCompany.SetFocus
        .cmdFirst.Enabled = False
        .cmdPrevious.Enabled = False
        .lbRecordNo.Caption = counter
    End With
ExitHere:
    Exit Sub
ErrorHandler:
    MsgBox Err.Number & ": " & Err.Description
    Resume ExitHere
End Sub


Sub FillTxtBoxes(ByVal rst As ADODB.Recordset, frm As Form)
  With frm
    .txtCompany = rst!CompanyName
    .txtCity = rst!City
    .txtCountry = rst!Country
  End With
End Sub


Private Sub cmdFirst_Click()
    On Error GoTo Err_cmdFirst_Click
    
    rst.Update "City", Me.txtCity
    rst.MoveFirst
    
    Call FillTxtBoxes(rst, Me)
    
    With Me
        .txtCompany.SetFocus
        .cmdFirst.Enabled = False
        .cmdLast.Enabled = True
        .cmdPrevious.Enabled = False
        .cmdNext.Enabled = True
        counter = 1
        .lbRecordNo.Caption = counter
    End With
Exit_cmdFirst_Click:
    Exit Sub
Err_cmdFirst_Click:
    MsgBox Err.Description
    Resume Exit_cmdFirst_Click
End Sub

Private Sub cmdNext_Click()
    On Error GoTo Err_cmdNext_Click
    
    rst.Update "City", Me.txtCity
    rst.MoveNext
    counter = counter + 1
    
    Me.cmdFirst.Enabled = True
    
    Call FillTxtBoxes(rst, Me)
    
    With Me
        .cmdPrevious.Enabled = True
        .lbRecordNo.Caption = counter
        .txtCompany.SetFocus
    End With
    If counter = rst.RecordCount Then
        Me.cmdNext.Enabled = False
        Me.cmdLast.Enabled = False
    End If
    
Exit_cmdNext_Click:
    Exit Sub
Err_cmdNext_Click:
    MsgBox Err.Description
    Resume Exit_cmdNext_Click
End Sub

Private Sub cmdPrevious_Click()
    On Error GoTo Err_cmdPrevious_Click
    
    rst.Update "City", Me.txtCity
       
    rst.MovePrevious
    counter = counter - 1
    
    Call FillTxtBoxes(rst, Me)
    
    With Me
        .txtCompany.SetFocus
        .cmdLast.Enabled = True
        .cmdNext.Enabled = True
    End With
    Me.lbRecordNo.Caption = counter
    If counter = 1 Then
        Me.cmdFirst.Enabled = False
        Me.cmdPrevious.Enabled = False
    End If
    
Exit_cmdPrevious_Click:
    Exit Sub
Err_cmdPrevious_Click:
    MsgBox Err.Description
    Resume Exit_cmdPrevious_Click
End Sub

Private Sub cmdLast_Click()
    On Error GoTo Err_cmdLast_Click
    
    rst.Update "City", Me.txtCity
    rst.MoveLast
    
    Call FillTxtBoxes(rst, Me)
    
    With Me
        .txtCompany.SetFocus
        .cmdFirst.Enabled = True
        .cmdPrevious.Enabled = True
        .cmdLast.Enabled = False
        .cmdNext.Enabled = False
    End With
    counter = rst.RecordCount
    Me.lbRecordNo.Caption = counter
Exit_cmdLast_Click:
    Exit Sub
Err_cmdLast_Click:
    MsgBox Err.Description
    Resume Exit_cmdLast_Click
End Sub


Private Sub Form_Unload(Cancel As Integer)
    If rst.Fields("City").OriginalValue <> Me.txtCity Then
          rst.Update "City", Me.txtCity
    End If
    Kill (CurrentProject.Path & "\Companies.rst")
    rst.Save CurrentProject.Path & "\Companies.rst", _
            adPersistADTG
End Sub


Sub UpdateDb()
  Dim conn As ADODB.Connection
  Dim rst As ADODB.Recordset
  Dim strNorthPath As String
  Dim strRecStat As String
  
  On Error GoTo ErrorHandler
  strNorthPath = CurrentProject.Path & "\Northwind.mdb"
  
  ' Open the connection to the database
  Set conn = New ADODB.Connection
  With conn
    .Provider = "Microsoft.Jet.OLEDB.4.0"
    .ConnectionString = "Data Source = " & strNorthPath
    .Mode = adModeReadWrite
    .Open
  End With
  
  ' Open the recordset from the local file
  ' that was persisted to the hard drive
  ' and update the data source with the changes
  Set rst = New ADODB.Recordset
  With rst
    .CursorLocation = adUseClient
    .Open CurrentProject.Path & "\Companies.rst", conn, _
    adOpenKeyset, adLockBatchOptimistic, adCmdFile
    .UpdateBatch adAffectAll
    
    ' Check if there were records with conflicts
    ' during the update
    .Filter = adFilterAffectedRecords
    Do Until .EOF
      strRecStat = strRecStat & " " & rst!City & ":" & rst.Status
      .MoveNext
    Loop
    .Close
    Debug.Print strRecStat
  End With
  
ExitHere:
  Set rst = Nothing
  Set conn = Nothing
  Exit Sub
ErrorHandler:
  MsgBox Err.Number & ": " & Err.Description
  Resume ExitHere
End Sub

'----------------------------------------------------------------
' Custom Project 16.3
'----------------------------------------------------------------

Private Sub cboCompany_AfterUpdate()
'  Find the record that matches the control.
    Dim rs As Object
    Dim c As Control
        
    On Error GoTo ErrHandle

    Set rs = Me.Recordset.Clone
    rs.FindFirst "[CustomerID] = '" & Me![cboCompany] & "'"
    If Not rs.EOF Then Me.Bookmark = rs.Bookmark
    ' Move to the previous record in the clone
    ' so that we can load previous records's
    ' data in the form's texboxes
    rs.MovePrevious
    If Not rs.BOF Then
        For Each c In Me.Controls
                c.Visible = True
        Next
        With Me
            .CustIdPrev = rs.Fields(0).Value
            .CompanyPrev = rs.Fields(1)
            .ContactPrev = rs.Fields(2)
            .TitlePrev = rs.Fields(3)
        End With
    Else
        For Each c In Me.Controls
            If c.Tag = "PrevRec" Then
                c.Visible = False
            End If
        Next
    End If
ExitHere:
    Exit Sub
ErrHandle:
    MsgBox Err.Number & ":" & Err.Description
    Resume ExitHere
End Sub

Private Sub Form_Load()
    Dim c As Control
    
    For Each c In Me.Controls
        If c.Tag <> "cbo" Then
           c.Visible = False
        End If
    Next
End Sub



'----------------------------------------------------------------
' Hands-On 16.4
'----------------------------------------------------------------

Sub ShapeDemo()
  Dim conn As ADODB.Connection
  Dim rst As ADODB.Recordset
  Dim rstChapter As Variant
  Dim strConn As String
  Dim shpCmd As String
  
  ' define database connection string
  ' using the OLE DB provider
  ' and Northwind database as Data Source
  strConn = "Data Provider=Microsoft.Jet.OLEDB.4.0;"
  strConn = strConn & "Data Source = " & _
   "C:\VBAAccess2016_ByExample\Northwind.mdb"
  
  ' specify Data Shaping provider
  ' and open connection to the database
  Set conn = New ADODB.Connection
  With conn
    .ConnectionString = strConn
    .Provider = "MSDataShape"
    .Open
  End With

  ' define the SHAPE command for the shaped recordset
  shpCmd = "SHAPE {SELECT CustomerID AS [Cust Id], " & _
   " CompanyName AS Company FROM Customers}" & _
   " APPEND ({SELECT CustomerID, OrderDate," & _
   " OrderID, Freight FROM Orders} AS custOrders" & _
   " RELATE [Cust Id] TO CustomerID)"
  
  ' create and open the parent recordset
  ' using the open connection
  Set rst = New ADODB.Recordset
  rst.Open shpCmd, conn
  
  ' output data from the parent recordset
  Do While Not rst.EOF
    Debug.Print rst("Cust Id"); _
    Tab; rst("Company")
    rstChapter = rst("custOrders")
    ' write out column headings
    ' for the child recordset
    Debug.Print Tab; _
     "OrderDate", "Order #", "Freight"
    ' output data from the child recordset
    Do While Not rstChapter.EOF
      Debug.Print Tab; _
       rstChapter("OrderDate"), _
       rstChapter("OrderID"), _
       Format(rstChapter("Freight"), "$ #.##")
      rstChapter.MoveNext
    Loop
    rst.MoveNext
  Loop
  
  ' Cleanup
  rst.Close
  Set rst = Nothing
  Set conn = Nothing
End Sub


'----------------------------------------------------------------
' Hands-On 16.5
'----------------------------------------------------------------

Sub ShapeMultiChildren()
  Dim conn As ADODB.Connection
  Dim rst As ADODB.Recordset
  Dim rstChapter1 As Variant
  Dim rstChapter2 As Variant
  Dim strConn As String
  Dim shpCmd As String
  Dim strParent As String
  Dim strChild1 As String
  Dim strChild2 As String
  Dim strLink As String
  Dim str1stChildName As String
  Dim str2ndChildName As String
  
  ' define database connection string
  ' using the OLE DB provider
  ' and Northwind database as Data Source
  strConn = "Data Provider=Microsoft.Jet.OLEDB.4.0;"
  strConn = strConn & "Data Source = " & _
   "C:\VBAAccess2016_ByExample\Northwind.mdb"
  
  ' specify Data Shaping provider
  ' and open connection to the database
  Set conn = New ADODB.Connection
  With conn
    .ConnectionString = strConn
    .Provider = "MSDataShape"
    .Open
  End With
  
  ' define the SHAPE command for the shaped recordset
  
  strParent = "SELECT CustomerID AS [Cust Id], " & _
   "CompanyName AS Company FROM Customers"
  
  strChild1 = "SELECT CustomerID, OrderDate," & _
   "OrderID, Freight FROM Orders"
  
  strChild2 = "SELECT Customers.CustomerID," & _
   "Products.ProductName FROM Products " & _
   "INNER JOIN ((Customers INNER JOIN Orders ON " & _
   "Customers.CustomerID = Orders.CustomerID) " & _
   "INNER JOIN [Order Details] ON " & _
   "Orders.OrderID = [Order Details].OrderID) ON " & _
   "Products.ProductID = [Order Details].ProductID " & _
   "Order By Products.ProductName"
  
  str1stChildName = "custOrders"
  str2ndChildName = "custProducts"
  
  strLink = "RELATE [Cust Id] TO CustomerID"
  
  shpCmd = "SHAPE {"
  shpCmd = shpCmd & strParent
  shpCmd = shpCmd & "}"
  shpCmd = shpCmd & " APPEND ({"
  shpCmd = shpCmd & strChild1
  shpCmd = shpCmd & "}"
  shpCmd = shpCmd & strLink
  shpCmd = shpCmd & ")"
  shpCmd = shpCmd & " AS " & str1stChildName
  shpCmd = shpCmd & ", ({"
  shpCmd = shpCmd & strChild2
  shpCmd = shpCmd & "} "
  shpCmd = shpCmd & strLink
  shpCmd = shpCmd & ")"
  shpCmd = shpCmd & " AS " & str2ndChildName
  
  ' create and open the parent recordset
  ' using the open connection
  Set rst = New ADODB.Recordset
  rst.Open shpCmd, conn
  
  ' output data from the parent recordset
  Do While Not rst.EOF
    Debug.Print rst("Cust Id"); Tab; rst("Company")
    rstChapter1 = rst("custOrders")
  
    ' write out column headings
    ' for the 1st child recordset
    Debug.Print Tab(4); " (" & rst("Cust Id") & " Orders)"
    Debug.Print Tab; "OrderDate", "Order #", "Freight"
  
    ' output data from the 1st child recordset
    Do While Not rstChapter1.EOF
      Debug.Print Tab; _
      rstChapter1("OrderDate"), _
      rstChapter1("OrderID"), _
      Format(rstChapter1("Freight"), "$ #,#0.00")
      rstChapter1.MoveNext
    Loop
  
    rstChapter2 = rst("custProducts")
    ' write out column headings
    ' for the 2nd child recordset
    Debug.Print Tab(4); " (" & rst("Cust Id") & " Products)"
    
    ' output data from the 2nd child recordset
    Do While Not rstChapter2.EOF
      Debug.Print Tab; _
      rstChapter2("ProductName")
      rstChapter2.MoveNext
    Loop
    rst.MoveNext
  Loop
  
  ' Cleanup
  rst.Close
  Set rst = Nothing
  Set conn = Nothing
End Sub


'----------------------------------------------------------------
' Custom Project 16.4
'----------------------------------------------------------------

Private Sub Form_Load()
    Dim conn As ADODB.Connection
    Dim rstCustomers As ADODB.Recordset
    Dim rstOrders As ADODB.Recordset
    Dim rstOrderDetails As ADODB.Recordset
    Dim fld As Field
    Dim objNode1 As Node
    Dim objNode2 As Node
    Dim strConn As String
    Dim strSQL As String
    
    Dim strSQLCustomers As String
    Dim strSQLOrders As String
    Dim strSQLOrderDetails As String
    Dim strSQLRelParentToChild As String
    Dim strSQLRelGParentToParent As String
    
    ' Create the ADO Connection object
    Set conn = New ADODB.Connection
    
    ' Specify a valid connection string
    strConn = "Data Provider=Microsoft.Jet.OLEDB.4.0;"
    strConn = strConn & "Data Source = " & _
      "C:\VBAAccess2016_ByExample\Northwind.mdb"
    conn.ConnectionString = strConn
    
    ' Specify the Data Shaping provider
    conn.Provider = "MSDataShape"
    
    ' Open the connection
    conn.Open
    
    ' Specify SELECT statement for the Grandparent
    strSQLCustomers = "SELECT CustomerID AS [Cust #]," & _
      "CompanyName AS [Customer] " & _
      "FROM Customers"
    ' Specify SELECT statement for the Parent
    strSQLOrders = "SELECT OrderID AS [Order #]," & _
      "OrderDate AS [Order Date]," & _
      "Orders.CustomerID AS [Cust #] " & _
      "FROM Orders ORDER BY OrderDate DESC"
    
    ' Specify SELECT statement for the Child
    strSQLOrderDetails = "SELECT od.OrderID AS [Order #]," & _
      "p.CategoryId AS [Category]," & _
      "p.ProductName AS [Product]," & _
      "od.Quantity," & _
      "od.ProductId," & _
      "od.UnitPrice AS [Unit Price]," & _
      "(od.UnitPrice * od.Quantity) " & _
      "AS [Extended Price] " & _
      "FROM [Order Details] od " & _
      "INNER JOIN Products p " & _
      "ON od.ProductID = p.ProductID " & _
      "ORDER BY p.CategoryId, p.ProductName"
    
    ' Specify RELATE clause to link Parent to Child
    strSQLRelParentToChild = "RELATE [Order #] TO [Order #]"
    
    ' Specify RELATE clause to link Grandparent to Parent
    strSQLRelGParentToParent = "RELATE [Cust #] TO [Cust #]"
    
    ' Build complete SQL statement for the shaped recordset
    ' adding aggregate functions for the Grandparent and Parent
    strSQL = "SHAPE(SHAPE{" & strSQLCustomers & "}"
    strSQL = strSQL & "APPEND((SHAPE{" & strSQLOrders & "} "
    strSQL = strSQL & "APPEND({" & strSQLOrderDetails & "} "
    strSQL = strSQL & strSQLRelParentToChild & ") AS rstOrderDetails,"
    strSQL = strSQL & "COUNT(rstOrderDetails.Product) "
    strSQL = strSQL & "        AS [Items On Order],"
    strSQL = strSQL & "SUM(rstOrderDetails.[Extended Price]) "
    strSQL = strSQL & "        AS [Order Total])"
    strSQL = strSQL & strSQLRelGParentToParent & ") AS [rstOrders],"
    strSQL = strSQL & "SUM(rstOrders.[Order Total]) "
    strSQL = strSQL & "        AS [Cust Grand Total]"
    strSQL = strSQL & ") AS rstCustomers"
    
    ' Create and open the Grandparent recordset
    Set rstCustomers = New ADODB.Recordset
    rstCustomers.Open strSQL, conn
    
    ' Fill the TreeView control
    Do While Not rstCustomers.EOF
        Set objNode1 = myTreeCtrl.Nodes.Add _
          (Text:=rstCustomers.Fields(0) & _
          "   " & rstCustomers.Fields(1) & _
          "   ($ " & rstCustomers.Fields(3) & ")")
        Set rstOrders = rstCustomers.Fields("rstOrders").Value
            Do While Not rstOrders.EOF
                Set objNode2 = myTreeCtrl.Nodes.Add _
                  (relative:=objNode1.Index, _
                  relationship:=tvwChild, _
                  Text:=rstOrders.Fields(0) & _
                  "  " & rstOrders.Fields(1) & _
                  "  " & rstOrders.Fields(4) & " (items)" & _
                  "    $" & rstOrders.Fields(5) & _
                  " (Order Total)")
                    Set rstOrderDetails = _
                rstOrders.Fields("rstOrderDetails").Value
                Do While Not rstOrderDetails.EOF
                    myTreeCtrl.Nodes.Add _
                      relative:=objNode2.Index, _
                      relationship:=tvwChild, _
                      Text:=rstOrderDetails.Fields(3) & _
                      "  " & rstOrderDetails.Fields(2) & _
                      "  $" & rstOrderDetails.Fields(6) & _
                      "  (" & rstOrderDetails.Fields(3) & _
                      " x $" & rstOrderDetails.Fields(5) & ")"
                    rstOrderDetails.MoveNext
                Loop
                rstOrders.MoveNext
            Loop
            rstCustomers.MoveNext
        Loop
    
    ' Cleanup
    rstCustomers.Close
    Set rstCustomers = Nothing
    Set conn = Nothing
End Sub


----------------------------------------------------------------
' Hands-On 16.6
'----------------------------------------------------------------

Sub Create_Transaction_ADO()
  Dim conn As ADODB.Connection
  
  On Error GoTo ErrorHandler
  
  Set conn = New ADODB.Connection
  
  With conn
    .Provider = "Microsoft.Jet.OLEDB.4.0"
    .ConnectionString = "Data Source = " & _
     "C:\VBAAccess2016_ByExample\Northwind.mdb"
    .Open
    .BeginTrans
    
    ' insert a new customer record
    .Execute "INSERT INTO Customers " & _
     "Values ('GWIPO','Gwiazda Polarna'," & _
     "'Marcin Garnia', 'Sales Manager'," & _
     "'ul.Majewskiego 10', 'Warszawa', Null, '02-106'," & _
     "'Poland', '0114822230445', Null)"
    
    ' insert the order for that customer
    .Execute "INSERT INTO Orders " & _
     " (CustomerId, EmployeeId, OrderDate, RequiredDate) " & _
     " Values ('GWIPO', 1, Date(), Date()+5)"
    .CommitTrans
    .Close
    MsgBox "Both inserts completed."
  End With
  
ExitHere:
  Set conn = Nothing
  Exit Sub
ErrorHandler:
  If Err.Number = -2147467259 Then
    MsgBox Err.Description
    Resume ExitHere
  Else
    MsgBox Err.Description
    With conn
      .RollbackTrans
      .Close
    End With
    Resume ExitHere
  End If
End Sub


'----------------------------------------------------------------
' Hands-On 16.7
'----------------------------------------------------------------

Sub OrdersArchive1996_DAO()
  Dim db As DAO.Database
  Dim blnTrans As Boolean
  Dim strSQL As String
  
  On Error GoTo ErrorHandler
  
  'begin transaction
  DBEngine.BeginTrans
  blnTrans = True
  
  Set db = CurrentDb()
  
  ' create an archive table on the fly
  ' and fill it with records
  strSQL = "SELECT * INTO OrdersArchive1996 IN " & _
   """C:\VBAAccess2016_ByExample\Chap11.accdb""" & _
   " FROM Orders WHERE Orders.OrderDate " & _
   "BETWEEN #1/1/1996# AND #12/31/1996#;"
  
  db.Execute strSQL, dbFailOnError
  
  ' delete records from the source table
  If db.RecordsAffected <> 0 Then
    strSQL = "DELETE FROM Orders " & _
     "WHERE Orders.OrderDate " & _
     "BETWEEN #1/1/1996# AND #12/31/1996#;"
    
    db.Execute strSQL, dbFailOnError
    
    ' ask user if OK to commit changes
    If MsgBox("Click OK if you want to archive " _
     & db.RecordsAffected & " records.", vbOKCancel + _
     vbQuestion + vbDefaultButton2, "Proceed?") = vbOK Then
      DBEngine.CommitTrans
    Else
      If blnTrans Then DBEngine.Rollback
    End If
  Else
    DBEngine.Rollback
    MsgBox "There are no records to archive " & _
     "with the specified criteria.", _
     vbInformation + vbOKOnly, "Records not found"
  End If
Cleanup:
  Set db = Nothing
  Exit Sub
ErrorHandler:
    If Err.Number = 3010 Then
      strSQL = "INSERT INTO OrdersArchive1996 IN " & _
       """C:\VBAAccess2016_ByExample\Chap11.accdb""" & _
       " SELECT * FROM Orders WHERE Orders.OrderDate " & _
       "BETWEEN #1/1/1996# AND #12/31/1996#;"
      Resume 0
    Else
      If blnTrans Then DBEngine.Rollback
        MsgBox Err.Description
        Resume Cleanup
    End If
End Sub

