'----------------------------------------------------------------
' Hands-On 16-1
'----------------------------------------------------------------

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

    strPath = InputBox("Enter pathname, e.g., C:\My Folder")
    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

    strSQL = "Select * From Orders where CustomerID = 'VINET'"

    strConn = "Provider=Microsoft.Jet.OLEDB.4.0;"
    strConn = strConn & "Data Source = C:\Acc07_ByExample\Northwind.mdb"

    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 " & rst.Fields(1) & " before."
    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
'----------------------------------------------------------------

'----------------------------------------------------------------
' Code in Step 2 (Custom Project 16-2, Part 3)
' Enter the code in the frmCompanyInfo form class module.
'----------------------------------------------------------------

' Module level declarations
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)
    
    Me.txtCompany.SetFocus
    Me.cmdFirst.Enabled = False
    Me.cmdPrevious.Enabled = False
    Me.lbRecordNo.Caption = counter
ExitHere:
    Exit Sub
ErrorHandler:
    MsgBox Err.Number & ": " & Err.Description
    Resume ExitHere
End Sub


'----------------------------------------------------------------
' Code in Step 3 (Custom Project 16-2, Part 3)
' Enter this code in a standard module.
'----------------------------------------------------------------

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

'----------------------------------------------------------------
' Code in Step 4 (Custom Project 16-2, Part 3)
' Enter the code in the frmCompanyInfo form class module.
'----------------------------------------------------------------

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

'----------------------------------------------------------------
' Code in Step 5 (Custom Project 16-2, Part 3)
' Enter the code in the frmCompanyInfo form class module.
'----------------------------------------------------------------

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)
    
    Me.cmdPrevious.Enabled = True
    Me.lbRecordNo.Caption = counter
    Me.txtCompany.SetFocus
    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


'----------------------------------------------------------------
' Code in Step 6 (Custom Project 16-2, Part 3)
' Enter the code in the frmCompanyInfo form class module.
'----------------------------------------------------------------

Private Sub cmdPrevious_Click()
    On Error GoTo Err_cmdPrevious_Click
    
    rst.Update "City", Me.txtCity
       
    rst.MovePrevious
    counter = counter - 1
    
    Call FillTxtBoxes(rst, Me)
    
    Me.txtCompany.SetFocus
    Me.cmdLast.Enabled = True
    Me.cmdNext.Enabled = True
    
    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


'----------------------------------------------------------------
' Code in Step 7 (Custom Project 16-2, Part 3)
' Enter the code in the frmCompanyInfo form class module.
'----------------------------------------------------------------

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


'----------------------------------------------------------------
' Code in Step 8 (Custom Project 16-2, Part 3)
' Enter the code in the frmCompanyInfo form class module.
'----------------------------------------------------------------

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


'----------------------------------------------------------------
' Code in Step 2 (Custom Project 16-2, Part 5)
' Enter this code in a standard module.
'----------------------------------------------------------------

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
' Code in step 7.
' Enter this code in the frmCompare form class module.
'----------------------------------------------------------------

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
        Me.CustIdPrev = rs.Fields(0).Value
        Me.CompanyPrev = rs.Fields(1)
        Me.ContactPrev = rs.Fields(2)
        Me.TitlePrev = rs.Fields(3)
    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


'----------------------------------------------------------------
' Custom Project 16-3
' Code in step 10.
' Enter this code in the frmCompare form class module.
'----------------------------------------------------------------

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


'----------------------------------------------------------------
' SQL Statement on page 412
' Enter this statement in the Query Design SQL View.
'----------------------------------------------------------------

SELECT Customers.CustomerID AS [Cust Id],
  Customers.CompanyName,
  Orders.OrderDate,
  [Order Details].OrderID,
  Products.ProductName,
  [Order Details].UnitPrice,
  [Order Details].Discount,
  CCur([Order Details].[UnitPrice]*[Quantity]*(1-[Discount])/100)*100 AS
  [Extended Price]
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 Customers.CustomerID, Orders.OrderDate DESC;


'----------------------------------------------------------------
' 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:\Acc07_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:\Acc07_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
' Code in step 5 (Custom Project 16-4, Part 2)
' This code must be entered in the frmOrders form class module.
'----------------------------------------------------------------

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 = " & _
            CurrentProject.Path & "\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 rst = 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:\Acc07_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:\Acc07_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, "Procceed?") = 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:\Acc07_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


