XML med ADO 2

När vi har formen klar skriver vi in lite kod:

1. Preparationer
   
   Sätt in följande i General Declarations för formen:
   
   Option Explicit
   
   Dim C_PROVIDER As String
   Dim C_CONNECTION As String
   Dim C_XML As String
   Dim C_SQL As String
   
   

   ' Globalt Recordset objekt
   Dim rs As ADODB.Recordset
   

   
   
2. Sätt in följade Form_Load handelseprocedur
   
   Private Sub Form_Load()
      ' modifiera dessa vid behov
      C_PROVIDER = "Microsoft.Jet.OLEDB.4.0"
      C_CONNECTION = "Data Source=" & App.Path & "\xml.mdb"
      C_XML = App.Path & "\xml.xml"
      C_SQL = "SELECT * FROM DATA"
   
      ' Skapa recordset objektet
      Set rs = New ADODB.Recordset
   
      ' Lite inställningar för knappar mm.
      cmd_SaveXML.Enabled = False
      txt_Texten.Locked = True
      txt_Siffran.Locked = True
      cmd_Navigera(5).Enabled = False
      txt_Texten = ""
      txt_Siffran = ""
   End Sub
   
   
3. Sedan skapar vi koden som öppnar databasen och sparar den som xml
   
   Private Sub cmd_OpenMDB_Click()
      ' Skapa och öppna en Connection till databasen
      Dim conn As ADODB.Connection
      Set conn = New ADODB.Connection
      conn.Provider = C_PROVIDER
      conn.ConnectionString = C_CONNECTION
      conn.Open
   
      ' om recordsetten är öppen så stänger vi den
      If rs.State <> adStateClosed Then
         rs.Close
      End If
      
      ' OBS! använd helst klient kursor
      rs.CursorLocation = adUseClient
      rs.CursorType = adOpenKeyset
      rs.ActiveConnection = conn
      rs.LockType = adLockOptimistic
   
      ' öppna recordset med SQL
      rs.Source = C_SQL
      rs.Open
   
      ' Tag bort eventuella tidigare xml-filer
      If Dir(C_XML) <> "" Then
         Kill C_XML
      End If
   
      ' spara som xml
      rs.Save C_XML, adPersistXML
      
      ' stäng allt
      rs.Close
      conn.Close
      Set conn = Nothing
   End Sub
   
   
   
4. Starta programmet och klicka på knappen "exportera xml". Om allt gått vägen borde du ny ha fått en xml fil sominnehåller allt data från databasen. Tag en titt på den...
   
   
5. Som nästa så skapar vi koden som öppnar databasen från xml filen:
   
   Private Sub cmd_UseXML_Click()
      Dim I As Integer
      Dim fName As String
   
      ' Om recordset är öppen så stänger vi den
      If rs.State <> adStateClosed Then
         rs.Close
      End If
   
      ' måste ha klientkursor
      rs.CursorLocation = adUseClient
      rs.Open C_XML, _
            "Provider=MSpersist;", _
            adOpenKeyset, _
            adLockBatchOptimistic, _
            adCmdFile
   
      ' Övervaka ändringarna så att ändringar
      ' skrivs till xmlfilen på sådant sätt
      ' att vi ser alla ändringar
      rs.MarshalOptions = adMarshalModifiedOnly
   
   
      ' Nedanstående är ett trick som automatiskt ser
      ' till att textboxar kopplas till databasfälten
      ' Gå igenom fälten
      ' Om det finns en kontroll som heter
      ' txt_<Fältets namn> t.ex. txt_Siffran
      ' så kopplar vi detnna textbox till
      ' fältet
      ' vill vi inte loopa kan vi sätta följande rader
      ' för varje fält
      ' Set textboxen.DataSource = recordset
      ' textboxen.DataField = "namn på fältet"
      ' ta för guds skull inte och kör med
      ' rs!Fält = Text1.text varianten som ni
      ' kanske använde i VB 5.0
   
      On Error Resume Next
      For I = 0 To rs.Fields.Count - 1
         fName = "txt_" & rs.Fields(I).Name
         If fName = Controls(fName).Name Then
            Set Controls(fName).DataSource = rs
            Controls(fName).DataField = rs.Fields(I).Name
         End If
      Next
      On Error GoTo 0
      cmd_SaveXML.Enabled = True
      Label1.Caption = rs.AbsolutePosition & _
                  "/" & rs.RecordCount
   End Sub
   
   
   
6. Vi skapar sedan en (enkel) navigering med hjälp av cmd_Navigera knapparna
   
   Private Sub cmd_Navigera_Click(Index As Integer)
      Dim I As Integer
      Select Case Index
         Case 0 ' Första
            rs.MoveFirst
   
         Case 1 ' Föregående
            rs.MovePrevious
            If rs.BOF Then
               Beep
               rs.MoveFirst
            End If
   
         Case 2 ' Nästa
            rs.MoveNext
            If rs.EOF Then
               Beep
               rs.MoveLast
            End If
   
         Case 3 ' Sista
            rs.MoveLast
   
         Case 4 ' Ändra
            For I = 0 To 3
               cmd_Navigera(I).Enabled = False
            Next
            cmd_Navigera(5).Enabled = True
            txt_Texten.Locked = False
            txt_Siffran.Locked = False
   
         Case 5 ' Spara
            If rs.Status = adRecModified Then
               rs.Update
            End If
            For I = 0 To 3
               cmd_Navigera(I).Enabled = True
            Next
            txt_Texten.Locked = True
            txt_Siffran.Locked = True
            cmd_Navigera(5).Enabled = False
   
         Case 6 ' Radera
            rs.Delete
            rs.MovePrevious
            If rs.BOF Then
               rs.MoveFirst
            End If
   
         Case 7 ' Ny
            rs.AddNew
            For I = 0 To 3
               cmd_Navigera(I).Enabled = False
            Next
            cmd_Navigera(5).Enabled = True
            txt_Texten.Locked = False
            txt_Siffran.Locked = False
      End Select
      Label1.Caption = rs.AbsolutePosition & _
               "/" & rs.RecordCount
   End Sub
   
   
7. Innan vi kan proköra måste vi även se till att datat sparas (det görs inte automatiskt)
   
   Private Sub cmd_SaveXML_Click()
      If Dir(C_XML) <> "" Then
         Kill C_XML
      End If
      ' Finns en bug i ADO 2.5 som gör att
      ' första posten ibland inte sparas
      ' om man har kontroller kopplade till fälten
      ' en klon funkar bättre
      rs.Clone.Save C_XML, adPersistXML
   End Sub
   
   
8. Prova genom att öppna xmlfilen med knappen "öppna xml". Gör sedan några ändringar. Se till att ändra, lägga till och radera. Spara xml data. Öppna sedan XML filen i ett annat program och se på datat. Observera att det inte lagras statiskt resultat, utan i xml filen framgår vilka ändringar som gjorts. Detta betyder att vi kan ta dessa ändringar och sätta dessa tillbaka till databasen.
   
   Detta kan göras med följande kod:
   
   Private Sub cmd_UpdateMDB_Click()
      Dim conn As ADODB.Connection
      Set conn = New ADODB.Connection
   
      Dim tmpConn As ADODB.Connection
   
      conn.Provider = C_PROVIDER
      conn.ConnectionString = C_CONNECTION
      conn.Open
   
      If rs.State = adStateClosed Then
         rs.CursorLocation = adUseClient
         rs.Open C_XML, _
               "Provider=MSpersist;", _
               adOpenKeyset, _
               adLockBatchOptimistic, _
               adCmdFile
      End If
   
      ' spara recordsettens nuvarande connection
      Set tmpConn = rs.ActiveConnection
   
      ' Koppla rs till databasen connection
      rs.ActiveConnection = conn
   
      ' Töm eventuella fel
      conn.Errors.Clear
   
      ' uppdatera allt
      rs.UpdateBatch
   
      ' om ingenting gått fel så   
      ' "nollställer" vi xml filen
      ' tag en titt på xml filen efteråt
      If conn.Errors.Count = 0 Then
         rs.ActiveConnection = tmpConn
         rs.UpdateBatch
      End If
      ' spara
      If Dir(C_XML) <> "" Then
         Kill C_XML
      End If
   
      ' spara xml
      rs.Clone.Save C_XML, adPersistXML
   
      rs.Close
      conn.Close
      tmpConn.Close
      Set conn = Nothing
      Set tmpConn = Nothing
   End Sub