


'----------------------------------------------------------------
' Hands-On 10-1
' No code for this Hands-On. 
' Please follow the instructions in the book.
'----------------------------------------------------------------



'----------------------------------------------------------------
' Hands-On 10-2
'----------------------------------------------------------------


Sub Open_AndRead_dBaseFile()
   Dim conn As ADODB.Connection
   Dim rst As ADODB.Recordset

   Set conn = New ADODB.Connection
   conn.Open "Provider=MSDASQL;DSN=MyDbaseFile;"
   
   Debug.Print conn.ConnectionString
   
   Set rst = New ADODB.Recordset
   rst.Open "Customer.dbf", conn
   
   Do Until rst.EOF
      Debug.Print rst.Fields(1).Value
      rst.MoveNext
   Loop
   
   rst.Close
   Set rst = Nothing
   conn.Close
   Set conn = Nothing
End Sub


'----------------------------------------------------------------
' Code on Page 213
' This is a replacement procedure for Hands-On 10-2 if you'd
' like to use a DSN-less connection
'----------------------------------------------------------------

' This is a DSN-less connection example

Sub Open_AndRead_dBaseFile()
   Dim conn As ADODB.Connection
   Dim rst As ADODB.Recordset

   Set conn = New ADODB.Connection
   conn.Open "DRIVER={Microsoft dBase Driver (*.dbf)};" & _
       "DBQ=" & CurrentProject.Path & "\"

   
   Debug.Print conn.ConnectionString
   
   Set rst = New ADODB.Recordset
   rst.Open "Customer.dbf", conn
   
   Do Until rst.EOF
      Debug.Print rst.Fields(1).Value
      rst.MoveNext
   Loop
   
   rst.Close
   Set rst = Nothing
   conn.Close
   Set conn = Nothing
End Sub


'----------------------------------------------------------------
' Hands-On 10-3
' No code for this Hands-On. 
' Please follow the instructions in the book.
'----------------------------------------------------------------


'----------------------------------------------------------------
' Hands-On 10-4
'----------------------------------------------------------------

Sub openDB_DAO()
    Dim db As DAO.Database
    Dim dbName As String
    Dim c As Container
    Dim doc As Document
    
    dbName = InputBox("Enter a name of an existing database:", _
            "Database Name")
    
    If dbName = "" Then Exit Sub
    If Dir(dbName) = "" Then
        MsgBox dbName & " was not found."
        Exit Sub
    End If
    
    Set db = OpenDatabase(dbName)
    With db
       ' list the names of the Container objects
        For Each c In .Containers
            Debug.Print c.Name & " container:" & _
                c.Documents.Count
            ' list the document names in the specified Container
            If c.Documents.Count > 0 Then
                For Each doc In c.Documents
                    Debug.Print vbTab & doc.Name
                Next doc
            End If
        Next c
        .Close
    End With
End Sub


'----------------------------------------------------------------
' Hands-On 10-5
'----------------------------------------------------------------

Sub openDB_ADO()
   Dim conn As ADODB.Connection
   Dim strDb As String

   On Error GoTo ErrorHandler
   
   strDb = CurrentProject.Path & "\Northwind 2007.accdb"
   Set conn = New ADODB.Connection

   With conn
      .Provider = "Microsoft.ACE.OLEDB.12.0;"
      .Mode = adModeReadWrite
      .ConnectionString = "Data Source=" & strDb
      .Open
   End With
   
   If conn.State = adStateOpen Then
     MsgBox "Connection was opened."
   End If

   conn.Close
   Set conn = Nothing
   MsgBox "Connection was closed."

   Exit Sub
ErrorHandler:
   MsgBox Err.Number & ": " & Err.Description
End Sub

'----------------------------------------------------------------
' Code on page 223
'----------------------------------------------------------------
Sub openDB_DAOReadOnly()
    Dim db As DAO.Database
    Dim t As Variant
    Dim strNames As String
    
    strNames = ""

    ' Open for shared read-only access
    'Set db = DBEngine.OpenDatabase(CurrentProject.Path & _
            "\Northwind.mdb", False, True)

    Set db = DBEngine.OpenDatabase(CurrentProject.Path & _
            "\Northwind 2007.accdb", False, True)
            
    For Each t In db.TableDefs
        strNames = strNames & t.Name & vbCrLf
    Next

    MsgBox "The following tables were found:" & _
            vbCrLf & strNames
    db.Close
End Sub


'----------------------------------------------------------------
' Hands-On 10-6
'----------------------------------------------------------------

Sub setPass_AndOpenDB_withDAO()
    Dim db As DAO.Database
    Dim strDb As String
    
    strDb = "C:\Acc07_ByExample\Northwind 2007.accdb"
    'strDb = "C:\Acc07_ByExample\Northwind.mdb"

    ' open the database in exclusive mode to set database password
    Set db = DBEngine.OpenDatabase(strDb, True)
    db.NewPassword "", "secret"
    MsgBox "Access Database version: " & Int(db.Version)
    db.Close
    
    ' open password protected database
    Set db = DBEngine.OpenDatabase(Name:=strDb, _
            Options:=False, _
            ReadOnly:=False, _
            Connect:=";PWD=secret")
    
    MsgBox "Password protected database was successfully opened."
    db.Close
    MsgBox "Password protected database has been closed."
    
    ' remove password protection from the database
    Set db = DBEngine.OpenDatabase(Name:=strDb, _
            Options:=True, _
            ReadOnly:=False, _
            Connect:=";PWD=secret")
    db.NewPassword "secret", ""
    MsgBox "Password protection was removed."
    db.Close
End Sub


'----------------------------------------------------------------
' Hands-On 10-7
'----------------------------------------------------------------

Sub setPass_AndOpenDB_withADO()
    Dim jetEng As JRO.JetEngine
    Dim conn As ADODB.Connection
    Dim strCompactFrom As String
    Dim strCompactTo As String
    Dim strPath As String
    
    strPath = CurrentProject.Path & "\"

    strCompactFrom = "Northwind.mdb"
    strCompactTo = "Northwind_P.mdb"
    
    On Error GoTo ErrorHandler
    
    Set jetEng = New JRO.JetEngine
    
    ' Compact the database specifying
    ' the new database password
    jetEng.CompactDatabase "Data Source=" & _
        strPath & strCompactFrom & ";", _
        "Data Source=" & strPath & strCompactTo & ";" & _
        "Jet OLEDB:Database Password=welcome"
    
    MsgBox "The database file " & strPath & strCompactTo & _
            " has been protected with password."
    Set jetEng = Nothing
    
    ' now open the password-protected MDB database
    Set conn = New ADODB.Connection
    With conn
      .Provider = "Microsoft.Jet.OLEDB.4.0;"
      .ConnectionString = "Data Source=" & _
            strPath & strCompactTo & ";" & _
           "Jet OLEDB:Database Password=welcome;"
      .Open
    End With
    
    If conn.State = adStateOpen Then
        MsgBox "Password protected database was opened."
    End If
    
    conn.Close
    MsgBox "Password protected Database was closed."

    Set conn = Nothing
    Exit Sub
ErrorHandler:
    If Err.Number = -2147217897 Then
        Kill strPath & strCompactTo
    ElseIf Err.Number = -2147467259 Then
        MsgBox "Make sure to close the " & strCompactFrom & _
        " database file prior to compacting it."
        Exit Sub
    Else
        MsgBox Err.Number & ": " & Err.Description
        Exit Sub
    End If
    Resume
End Sub


'----------------------------------------------------------------
' Hands-On 10-8
'----------------------------------------------------------------

Sub Open_WithUserSecurity()
   Dim conn As ADODB.Connection
   Dim strDb As String
   Dim strSysDb As String

   On Error GoTo ErrorHandler
   
   strDb = CurrentProject.Path & "\NorthSecureUser.mdb"
   strSysDb = CurrentProject.Path & "\Security.mdw"
   Set conn = New ADODB.Connection
   With conn
      .Provider = "Microsoft.Jet.OLEDB.4.0;"
      .ConnectionString = "Data Source=" & strDb & ";" & _
         "Jet OLEDB:System Database=" & strSysDb
      .Open , "Developer", "WebMaster"
   End With
   
   MsgBox "Secured database was opened."
   conn.Close
   Set conn = Nothing
   MsgBox "Database was closed."
   Exit Sub
ErrorHandler:
   MsgBox Err.Number & ": " & Err.Description
End Sub


'---------------------------------------------------------------
' Hands-On 10-9
'----------------------------------------------------------------

Sub Connect_ToCurrentDB()
   Dim conn As ADODB.Connection
   Dim fs As Object
   Dim txtfile As Object
   Dim i As Integer
   Dim strFileName As String
   
   strFileName = "C:\Acc07_ByExample\Propfile.txt"

   Set conn = CurrentProject.Connection
   Set fs = CreateObject("Scripting.FileSystemObject")
   Set txtfile = fs.CreateTextFile(strFileName, True)

   For i = 0 To conn.Properties.Count - 1
      Debug.Print conn.Properties(i).Name & "=" & _
          conn.Properties(i).Value
      txtfile.WriteLine (conn.Properties(i).Name & "=" & _
          conn.Properties(i).Value)
   Next i
   MsgBox "Please check results in the " & _
       "Immediate window." & vbCrLf _
       & "The results have also been written to the " _
       & strFileName & " file."

   txtfile.Close
   Set fs = Nothing
   conn.Close
   Set conn = Nothing
End Sub


'---------------------------------------------------------------
' Hands-On 10-10
'---------------------------------------------------------------

Sub ConnectToSQL_SQLOLEDB()
    Dim conn As ADODB.Connection
    Set conn = New ADODB.Connection
   
   ' Modify the connection information
   With conn
     .Provider = "SQLOLEDB"
     .ConnectionString = "Data Source=Mozartv4;" & _
     "database=Musicians; UserId=sa; Password=;"
     .Open
   End With
   If conn.State = adStateOpen Then
     MsgBox "Connection was established."
   End If
   conn.Close
   Set conn = Nothing
End Sub


Sub Connect_ToSQLServer()
   Dim conn As ADODB.Connection
   Set conn = New ADODB.Connection
   
   With conn

   ' DSN-less connection using the ODBC driver
   ' (modify the data source information below)
     .Open "Driver={SQL Server};" & _
        "Server=11.22.17.153;" & _
        "UID=myId;" & _
        "PWD=myPassword;" & _
        "Database=SupportDb"
     .Close
   End With
   Set conn = Nothing
End Sub


'---------------------------------------------------------------
' Hands-On 10-11
'---------------------------------------------------------------

Sub Open_Excel_DAO(strFileName)
    Dim db As DAO.Database
    Dim rst As DAO.Recordset
    Dim strHeader As String
    Dim strValues As String
    
    strHeader = ""
    strValues = ""
    
    If Right(strFileName, 1) = "x" Then
    
        Set db = OpenDatabase(CurrentProject.Path & _
            "\Report2007.xlsx", _
            False, True, "Excel 12.0; HDR=YES;")

    Else
    
        Set db = OpenDatabase(CurrentProject.Path & _
           "\Report.xls", _
           False, True, "Excel 8.0; HDR=YES;")
           
    End If
    
    Set rst = db.OpenRecordset("Sheet1$")
    
    'get names of columns
    For Each fld In rst.Fields
        strHeader = strHeader & fld.Name & vbTab
    Next
    
    Debug.Print strHeader
    
    ' get cell values
    Do Until rst.EOF
         For Each f In rst.Fields
              strValues = strValues & f.Value & vbTab & vbTab
         Next
         Debug.Print strValues
         strValues = ""
         rst.MoveNext
    Loop
    
    rst.Close
    Set rst = Nothing
    db.Close
    Set db = Nothing
End Sub


'---------------------------------------------------------------
' Hands-On 10-12
'---------------------------------------------------------------

Sub Open_Excel_ADO(strFileName As String)

    Dim conn As ADODB.Connection
    Dim rst As ADODB.Recordset
    Dim strFindWhat As String
   
    Set conn = New ADODB.Connection
   
    If Right(strFileName, 1) = "x" Then
    
        With conn
            .Provider = "Microsoft.ACE.OLEDB.12.0;"
            .ConnectionString = "Data Source=" & _
                CurrentProject.Path & _
                "\" & strFileName & _
                "; Extended Properties=""Excel 12.0; HDR=Yes"";"
            .Open
        End With
        
       

     Else
     
         conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                    "Data Source=" & CurrentProject.Path & _
                    "\" & strFileName & _
                    ";Extended Properties=""Excel 8.0; HDR=Yes;"";"
       
     End If
       
   Set rst = New ADODB.Recordset
   rst.Open "Select * from [Sheet1$]", conn, adOpenStatic, adLockOptimistic
      
   strFindWhat = "[Excel Version] = 'Excel 2000'"
   rst.Find strFindWhat
   rst(1).Value = "500"
   rst.Update
   rst.Close
   Set rst = Nothing
   MsgBox "Excel spreadsheet was opened and updated."
   
   conn.Close
   Set conn = Nothing
End Sub


'---------------------------------------------------------------
' Hands-On 10-13
'---------------------------------------------------------------

Sub Open_TextFile()
   Dim conn As ADODB.Connection
   Dim rst As ADODB.Recordset
   Dim fld As ADODB.Field

   Set conn = New ADODB.Connection
   Debug.Print conn.ConnectionString
   conn.Open "DRIVER={Microsoft Text Driver (*.txt; *.csv)};" & _
   "DBQ=" & CurrentProject.Path & "\"
       Set rst = New ADODB.Recordset
   rst.Open "Select * from [Employees.txt]", conn, adOpenStatic, _
       adLockReadOnly, adCmdText
   Do Until rst.EOF
       For Each fld In rst.Fields
          Debug.Print fld.Name & "=" & fld.Value
       Next fld
       rst.MoveNext
   Loop
   rst.Close
   Set rst = Nothing
   conn.Close
   Set conn = Nothing
   MsgBox "Open the Immediate window to view the data."
End Sub


'---------------------------------------------------------------
' Hands-On 10-14
'---------------------------------------------------------------

Sub CreateNewDB_DAO()
    Dim db As DAO.Database
    Dim dbName As String
    
    dbName = "C:\Acc07_ByExample\TestDAO.accdb"
    
    On Error GoTo ErrorHandler
    
    Set db = CreateDatabase(dbName, dbLangGeneral)
    
    MsgBox "The database contains " & _
            db.TableDefs.Count & " tables."
    db.Close
    Set db = Nothing
ErrorHandler:
    MsgBox Err.Description
End Sub


'---------------------------------------------------------------
' Hands-On 10-15
'---------------------------------------------------------------

Sub CreateNewDB_ADO()

' you must make sure that a reference to
' Microsoft ADO Ext. 2.8 for DDL and Security
' Object Library is set in the References dialog box


   Dim cat As ADOX.Catalog
   Dim strDb As String

   Set cat = New ADOX.Catalog
   strDb = "C:\Acc07_ByExample\TestADO.mdb"

   On Error GoTo ErrorHandler
   cat.Create "Provider=Microsoft.Jet.OLEDB.4.0;" & _
       "Data Source=" & strDb
   MsgBox "The database was created (" & strDb & ")."
   Set cat = Nothing
   Exit Sub

ErrorHandler:
   If Err.Number = -2147217897 Then
      Kill strDb
      Resume 0
   Else
      MsgBox Err.Number & ": " & Err.Description
   End If
End Sub



'---------------------------------------------------------------
' Hands-On 10-16
'---------------------------------------------------------------


Sub CopyDB_DAO()
    Dim dbName As String
    Dim dbNewName As String
    
    dbName = InputBox("Enter the name of the database you want " & _
            "to copy: " & Chr(13) & _
            "(example: C:\Acc07_ByExample\TestDAO.accdb)", "Create a copy of")
        
    If dbName = "" Then Exit Sub
    
    If Dir(dbName) = "" Then
        MsgBox dbName & " was not found. " & Chr(13) _
        & "Check the database name or path."
        Exit Sub
    End If
    
    dbNewName = InputBox("Enter the name of the duplicate " & _
    "database:" & Chr(13) _
    & "(example: C:\Acc07_ByExample\Copy of TestDAO.accdb)", "Save As")
    
    If dbNewName = "" Then Exit Sub
    
    If Dir(dbNewName) <> "" Then
        Kill dbNewName
    End If
    
    DBEngine.CompactDatabase dbName, dbNewName
End Sub


'---------------------------------------------------------------
' Hands-On 10-17
'---------------------------------------------------------------

Sub Copy_AnyFile()
   Dim fso As Object
   Dim strDb As String
   
   On Error GoTo ErrorHandler
   
   Set fso = CreateObject("Scripting.FileSystemObject")
   
   On Error GoTo 0

   strDb = "C:\Acc07_ByExample\TestADO.accdb"
   
   fso.CopyFile strDb, "C:\"
      
   Set fso = Nothing
   Exit Sub
ErrorHandler:
    MsgBox Err.Number & ":" & Err.Description
End Sub


'---------------------------------------------------------------
' Hands-On 10-18
'---------------------------------------------------------------

Sub DBError2()
   Dim conn As New ADODB.Connection
   Dim errADO As ADODB.Error

   On Error GoTo CheckErrors

   conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" _
       & "Data Source=C:\my.accdb"
    Debug.Print CurrentProject.Path
   
CheckErrors:
   Debug.Print "VBA error number: " _
       & Err.Number & vbCrLf _
       & " (" & Err.Description & ")"
   Debug.Print "Listed below is information " _
       & "regarding this error " & vbCrLf _
       & "contained in the ADO Errors collection."
   For Each errADO In conn.Errors
      Debug.Print vbTab & "Error Number: " & errADO.Number
      Debug.Print vbTab & "Error Description: " & errADO.Description
      Debug.Print vbTab & "Jet Error Number: " & errADO.SQLState
      Debug.Print vbTab & "Native Error Number: " & errADO.NativeError
      Debug.Print vbTab & "Source: " & errADO.Source
      Debug.Print vbTab & "Help Context: " & errADO.HelpContext
      Debug.Print vbTab & "Help File: " & errADO.HelpFile
   Next
   MsgBox "Errors were written to the Immediate window."
End Sub


'---------------------------------------------------------------
' Hands-On 10-19
'---------------------------------------------------------------

' use the References dialog box to set up a reference to the
' Microsoft Jet and Replication Objects Library

Sub CompactDb()
   Dim jetEng As JRO.JetEngine
   Dim strCompactFrom As String
   Dim strCompactTo As String
   Dim strPath As String

   strPath = CurrentProject.Path & "\"
   strCompactFrom = "Northwind.mdb"
   strCompactTo = "NorthwindComp.mdb"

   ' Make sure there isn't already a file with the
   ' name of the compacted database.
   On Error GoTo HandleErr

   ' Compact the database
   Set jetEng = New JRO.JetEngine
   jetEng.CompactDatabase "Data Source=" & _
       strPath & strCompactFrom & ";", _
       "Data Source=" & _
       strPath & strCompactTo & ";"

   ' Delete the original database
   Kill strPath & strCompactFrom

   ' Rename the file back to the original name
   Name strPath & strCompactTo As strPath & strCompactFrom
ExitHere:
   Set jetEng = Nothing
   MsgBox "Compacting completed."
   Exit Sub
HandleErr:
   MsgBox Err.Number & ": " & Err.Description
   Resume ExitHere
End Sub



