Figure 3 Publication.Title
Option Explicit
Dim oXML As XML.xmlparser
Dim rsUpdateTitle As ADODB.Recordset
Dim rsAllTitles As ADODB.Recordset
Dim rsTitle As ADODB.Recordset
Dim cnPubs As ADODB.Connection
Dim cmdTitle As ADODB.Command
Dim sSQL As String
Dim vData As Variant
Dim dbRecordset As String
Const sDataSource = "conPubs"
'local variable(s) to hold property value(s)
Private mvarTitleID As Variant 'local copy
Function GetDSN() As String
GetDSN = "DSN=Pubs;uid=sa;pwd=;"
End Function
Friend Property Let TitleId(ByVal vData As Variant)
'used when assigning a value to the property, on the left side of an assignment.
'Syntax: X.TitleID = 5
mvarTitleID = vData
End Property
Friend Property Set TitleId(ByVal vData As Variant)
'used when assigning an Object to the property, on the left side of a Set statement.
'Syntax: Set x.TitleID = Form1
Set mvarTitleID = vData
End Property
Friend Property Get TitleId() As Variant
'used when retrieving value of a property, on the right side of an assignment.
'Syntax: Debug.Print X.TitleID
If IsObject(mvarTitleID) Then
Set TitleId = mvarTitleID
Else
TitleId = mvarTitleID
End If
End Property
Public Sub UpdateTitle(ByVal TitleId As Variant, Title As Variant, Notes As Variant)
Dim sReturn As String
Set rsTitle = CreateObject("ADODB.Recordset")
On Error GoTo UpdateTitleErr
If Len(TitleId) = 0 Then
Exit Sub
End If
sReturn = ""
sSQL = "UPDATE titles " & _
"SET title = '" & Title & "'," & _
"notes = '" & Notes & "' " & _
"WHERE (title_id = " & "'" & TitleId & "')"
rsTitle.Open sSQL, GetDSN, adOpenForwardOnly, adLockOptimistic, adCmdText
Exit Sub
UpdateTitleErr:
Err.Raise Err.Number, "Title:UpdateTitle", Err.Description
End Sub
Public Function RetrieveAllTitlesOnly()
Set rsAllTitles = CreateObject("ADODB.Recordset")
sSQL = "select * from titles"
rsAllTitles.Open sSQL, GetDSN, adOpenForwardOnly, adLockReadOnly, adCmdText
If Not rsAllTitles.EOF And Not rsAllTitles.BOF Then
vData = rsAllTitles.GetRows
If IsArray(vData) Then
dbRecordset = True
Else
dbRecordset = False
End If
Else
dbRecordset = False
End If
rsAllTitles.Close
Set rsAllTitles = Nothing
RetrieveAllTitlesOnly = vData
End Function
Public Function RetrieveTitle(TitleId As Variant) As Variant
Dim sReturn As String, sTitle As String, sID As String
Dim sNotes As String
'SELECT title_id, title, type, pub_id, price, advance, royalty, ytd_sales, notes,
pubdate FROM titles WHERE (title_id = ?)
Set rsTitle = CreateObject("ADODB.Recordset")
If Len(TitleId) = 0 Then
TitleId = ""
RetrieveTitle = 0
End If
sReturn = ""
sSQL = "SELECT title_id, title, type, pub_id, price, advance, royalty, _
ytd_sales, notes, pubdate FROM titles WHERE (title_id = " & "'" & TitleId & "')"
rsTitle.Open sSQL, GetDSN, adOpenForwardOnly, adLockReadOnly, adCmdText
If rsTitle.RecordCount <> 0 Then
sTitle = oXML.Format("Title", rsTitle("title"))
sID = oXML.Format("Title_ID", rsTitle("title_id"))
sNotes = oXML.Format("Notes", rsTitle("notes"))
sReturn = sID & sTitle & sNotes
RetrieveTitle = sReturn
End If
rsTitle.Close
End Function
Private Sub Class_Initialize()
Set oXML = New xmlparser
End Sub
Figure 4 Publication.Title Methods
Method |
Description |
GetDSN |
Function that returns the DSN for the object. The DSN information is hardcoded. |
UpdateTitle |
Sub that updates a single title. |
RetrieveTitle |
Function that retrieves a specific title and returns it in an XML stream. |
RetrieveAllTitlesOnly |
Function that retrieves all titles and returns them in an array generated by the ADO recordset GetRows method. |
Figure 5 XML.xmlparser
Option Explicit
Const xs = "<"
Const xe = ">"
Const xend = "</"
Public Function XMLDeclaration() As String
XMLDeclaration = "<?xml version=""1.0""?>"
End Function
Public Function Parse(ByVal XMLSource As String, _
ByVal XMLName As String, _
Optional Instance As Integer = 1, _
Optional Default As Variant = "") As String
Dim x As Integer, y As Integer, XMLStart As Integer, XMLTag As String, _
c As String
Dim XMLTagEnd As String
Dim XMLMatch As Integer, XMLEnd As Integer, XMLLength As Integer
XMLLength = Len(XMLSource)
XMLTag = xs + XMLName + xe
XMLTagEnd = xend + XMLName + xe
'*** Find the start of the requested intstance...
XMLStart = 1
For x = 1 To Instance
y = InStr(XMLStart, XMLSource, XMLTag)
If y >= XMLStart Then
XMLStart = y + Len(XMLTag)
Else
Parse = Default
Exit Function
End If
Next
'*** Find the end of the instance...
XMLEnd = XMLStart
XMLMatch = 1
Do Until XMLMatch = 0
c = Mid(XMLSource, XMLEnd, Len(XMLTagEnd))
If c = XMLTagEnd Then
XMLMatch = XMLMatch - 1
ElseIf Left(c, 1) = xs Then
XMLMatch = XMLMatch + 1
End If
XMLEnd = XMLEnd + 1
If XMLEnd = XMLLength Then
Parse = Default
Exit Function
End If
Loop
Parse = Mid(XMLSource, XMLStart, XMLEnd - XMLStart - 1)
End Function
Public Function Format(XMLName As String, XMLValue As Variant) As String
Select Case VarType(XMLValue)
Case vbByte, vbInteger, vbSingle, vbDouble, vbDecimal, vbBoolean, vbLong, _
vbCurrency
Format = xs + XMLName + xe + Trim(Str(XMLValue)) + xend + XMLName + xe
Case vbString, vbVariant, vbDate
Format = xs + XMLName + xe + XMLValue + xend + XMLName + xe
Case Else
Format = ""
End Select
End Function
Figure 6 XML.xmlparser Methods
Method |
Description |
XMLDeclaration |
Function that returns the XML declaration. |
Format |
Function that takes a value and XML tag name, then formats the data in the proper XML structure. |
Parse |
Function that looks up an element in a data stream. You can use Parse to look up a single element or multiple elements. |