Chip 2004 April/CMCD0404.ISO/Software/Shareware/Programare/sharp/wwwSharp_setup.exe/{app}/Examples/RssPublisher/Source/RssPublisher.vbs

Text File | 2004-02-04 | 19.0 KB | 668 lines

Option Explicit

Dim BookmarkType
Dim rsArticles
Dim CurrentBookmark

BookmarkType = vbEmpty
rsArticles = Null
CurrentBookmark = Null

Function VarAsType(Value, ValueType)
    Select Case ValueType
        Case vbInteger VarAsType = CInt(Value)
        Case vbLong VarAsType = CLng(Value)
        Case vbSingle VarAsType = CSng(Value)
        Case vbDouble VarAsType = CDbl(Value)
        Case vbCurrency VarAsType = CCur(Value)
        Case vbDate VarAsType = CDate(Value)
        Case vbString VarAsType = CStr(Value)
        Case vbBoolean VarAsType = CBool(Value)
        Case vbVariant VarAsType = Value 'Leave as is
        Case vbByte VarAsType = CByte(Value)
        Case Else Err.Raise 5, "Convertion", "Convertion failed"
    End Select
End Function

Sub CleanupArticle()
    document.all.inpArticleTitle.innerText = ""
    document.all.inpArticleDescription.innerText = ""
    document.all.inpArticleURL.innerText = ""
    document.all.inpArticleDate.innerText = ""
    document.all.inpArticleCategory.innerText = ""
    document.all.inpArticleKeywords.innerText = ""
    document.all.inpArticleAuthorNames.innerText = ""
    document.all.inpArticleAuthorEmails.innerText = ""
End Sub

Sub CleanupArticles()
    CleanupArticle()
    document.all.tblArticleList.outerHTML = "<TABLE id=""tblArticleList"" cols=""1"" border=""0""></TABLE>"
End Sub

Sub CleanupSite()
    document.all.inpSiteTitle.innerText = ""
    document.all.inpSiteDescription.innerText = ""
    document.all.inpSiteURL.innerText = ""
    document.all.inpSiteDetails.innerText = ""
    document.all.inpSiteImageURL.innerText = ""
    document.all.inpSiteFurtherReading.innerText = ""
    document.all.inpSiteAuthorNames.innerText = ""
    document.all.inpSiteAuthorEmails.innerText = ""
End Sub

Sub CleanupAll()
    CleanupSite()
    CleanupArticles()
End Sub

Sub SetInputText(RootNode, inputControl, NodePath)
    Dim Node
    Set Node = RootNode.selectSingleNode(NodePath)
    If IsEmpty(Node) or IsNull(Node) or (Node is Nothing) Then Exit Sub
    inputControl.innerText = Node.text
End Sub

' Retrieve authors name and email from dc:creator node
Sub FindAuthors(RootNode, ByRef Authors, ByRef Emails)
    Dim Nodes, Node, i, AuthorText, Pos, Author, Email
    Authors = ""
    Emails = ""

    Set Nodes = RootNode.selectNodes("./dc:creator")
    For i = 0 To Nodes.length-1
        Set Node = Nodes.item(i)
        AuthorText = Node.text

        Pos = InStr(1, AuthorText, "(mailto:", 1)
        If Pos > 0 Then
            Author = Trim(Mid(AuthorText, 1, Pos-1))
            Email = Trim(Mid(AuthorText, Pos + Len("(mailto:")))
            If (Len(Email) > 0) and (Mid(Email, Len(Email), 1) = ")") Then
                Email = Mid(Email, 1, Len(Email) - 1)
            End If
        Else
            Author = AuthorText
            Email = ""
        End If

        If Len(Authors) > 0 Then Authors = Authors & "|"
        Authors = Authors & Author
        if Len(Emails) > 0 Then Emails = Emails & "|"
        Emails = Emails & Email
    Next
End Sub

Sub SetAuthors(RootNode)
    Dim Authors, Emails
    FindAuthors RootNode, Authors, Emails

       document.all.inpSiteAuthorNames.innerText = Authors
       document.all.inpSiteAuthorEmails.innerText = Emails
End Sub

Sub OpenChannel(Channel)
    SetInputText Channel, document.all.inpSiteTitle, "./title"
    SetInputText Channel, document.all.inpSiteDescription, "./description"
    SetInputText Channel, document.all.inpSiteURL, "./link"
    SetInputText Channel, document.all.inpSiteDetails, "./dc:publisher"
    SetInputText Channel, document.all.inpSiteImageURL, "./image/@rdf:resource"
    SetInputText Channel, document.all.inpSiteFurtherReading, "./fr:url"
    SetAuthors Channel
End Sub

' Create new recordset
Sub CreateRecordset()
    Dim rs
    Set rs = CreateObject("ADODB.Recordset")

    If Err.Number <> 0 Then
        MsgBox("Create: " & Err.Description)
        Exit Sub
    End If

    rs.Fields.Append "Title", 200, 255, &H64    'adVarChar, adFldUpdatable or adFldIsNullable or adFldMayBeNull
    rs.Fields.Append "Description", 201, 4000, &HE4    'adLongVarChar, adFldUpdatable or adFldIsNullable or adFldMayBeNull or adFldLong
    rs.Fields.Append "URL", 200, 255, &H64
    rs.Fields.Append "Date", 200, 80, &H64
    rs.Fields.Append "Category", 200, 50, &H64
    rs.Fields.Append "Keywords", 200, 255, &H64
    rs.Fields.Append "Author", 200, 255, &H64
    rs.Fields.Append "Email", 200, 255, &H64

    If Err.Number <> 0 Then
        MsgBox("Add fields: " & Err.Description)
        Exit Sub
    End If

    rs.Open
    If Err.Number <> 0 Then
        MsgBox("Open: " & Err.Description)
        Exit Sub
    End If

    Set rsArticles = rs
End Sub

Sub SetColumnValue(RootNode, ColumnName, NodePath)
    On Error Resume Next
    Dim Node
    Set Node = RootNode.selectSingleNode(NodePath)
    If IsEmpty(Node) or IsNull(Node) or (Node Is Nothing) Then Exit Sub
    rsArticles(ColumnName) = CStr(Node.text)
End Sub

Sub OpenItem(Item)
    On Error Resume Next
    Dim Authors, Emails
    Authors = ""
    Emails = ""
    rsArticles.AddNew()
    SetColumnValue Item, "Title", "./title"
    SetColumnValue Item, "Description", "./description"
    SetColumnValue Item, "URL", "./link"
    SetColumnValue Item, "Date", "./dc:date"
    SetColumnValue Item, "Category", "./pa:category"
    SetColumnValue Item, "Keywords", "./pa:keywords"
    FindAuthors Item, Authors, Emails
    rsArticles("Author") = Authors
    rsArticles("Email") = Emails
    rsArticles.Update()
End Sub

Sub OnBtnOpenRSSClick()
    CleanupAll()
    rsArticles = Null

    Dim xmlDoc, Channel, Items, Item, Node, i
    Set xmlDoc = CreateObject("MsXml2.DOMDocument")

     cDialog.Filter = "RSS files (*.xml)|*.xml|All files (*.*)|*.*"
     cDialog.FileName = ""
    cDialog.CancelError = True
    On Error Resume Next
    cDialog.ShowOpen()
    If Err.Number <> 0 Then Exit Sub

    On Error Goto 0
    xmlDoc.async = False
    xmlDoc.validateOnParse = True
    xmlDoc.Load(cDialog.FileName)
    If xmlDoc.parseError.ErrorCode <> 0 Then
        Err.Raise 5, "RSS Reader", xmlDoc.parseError.reason
    End If

    'Process only first channel, ignore others if any
    Set Channel = xmlDoc.documentElement.selectSingleNode("./channel")
    If IsEmpty(Channel) or IsNull(Channel) or (Channel is Nothing) Then
        Err.Raise 5, "RSS Reader", "RSS File is invalid"
    End If
    OpenChannel(Channel)

    CreateRecordset()

    Set Items = xmlDoc.documentElement.selectNodes("./item")
    For i = 0 to (Items.length - 1)
        Set Item = Items.item(i)
        OpenItem(Item)
    Next

    FillArticleList()
End Sub

Sub OnBtnImportADOClick()
    Dim locator, conn
    Set locator = CreateObject("DataLinks")
    Set conn = locator.PromptNew()
    If (IsEmpty(conn) or IsNull(conn) or (conn is Nothing)) Then Exit Sub
    conn.Open()

    On Error Resume Next
    Dim strTableName
    strTableName = PromptTableName(conn)
    If Err.Number <> 0 Then Exit Sub

    On Error Goto 0
    DoImport conn, strTableName
End Sub

Sub OnBtnImportAccessClick()
     cDialog.Filter = "MS Access database files (*.mdb)|*.mdb"
    cDialog.FileName = ""
    cDialog.CancelError = True
    Dim strTableName
    strTableName = ""

    On Error Resume Next
    cDialog.ShowOpen()
    If Err.Number <> 0 Then Exit Sub
    Dim dbFileName
    dbFileName = cDialog.FileName

    Dim conn
    Set conn = CreateObject("ADODB.Connection")
    conn.Open("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & dbFileName)

    strTableName = PromptTableName(conn)
    If Err.Number <> 0 Then Exit Sub

    On Error Goto 0
    DoImport conn, strTableName
End Sub

Sub OnBtnImportExcelClick()
     cDialog.Filter = "MS Excel files (*.xls)|*.xls"
     cDialog.FileName = ""
    cDialog.CancelError = True
    Dim strTableName
    strTableName = ""
    On Error Resume Next
    cDialog.ShowOpen()
    If Err.Number <> 0 Then Exit Sub
    Dim dbFileName
    dbFileName = cDialog.FileName
    Dim conn
    Set conn = CreateObject("ADODB.Connection")
    conn.Open("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & dbFileName & _
        ";Extended properties=Excel 8.0;")

    strTableName = PromptTableName(conn)
    If Err.Number <> 0 Then Exit Sub

    On Error Goto 0
    DoImport conn, strTableName
End Sub

Function PersistRSS()
    PersistRSS = False
    Dim res
    res = RssHeader(document.all.inpSiteTitle.value, _
        document.all.inpSiteDescription.value, _
        document.all.inpSiteURL.value, _
        document.all.inpSiteDetails.value, _
        document.all.inpSiteImageURL.value, _
        document.all.inpSiteFurtherReading.value, _
        document.all.inpSiteAuthorNames.value, _
        document.all.inpSiteAuthorEmails.value)
    If Not res Then
        MsgBox("Site information is not complete.")
        Exit Function
    End If

    If Not IsNull(rsArticles) and Not (rsArticles.BOF and rsArticles.EOF) Then
        rsArticles.MoveFirst()
        While Not rsArticles.EOF
            res = RssItem(rsArticles("Title"), rsArticles("Description"), rsArticles("URL"), _
                rsArticles("Date"), rsArticles("Category"), rsArticles("Keywords"), _
                rsArticles("Author"), rsArticles("Email"))
            If Not res Then
                MsgBox("Error writing article: " + rs("Title"))
                Exit Function
            End If

            rsArticles.MoveNext()
        Wend
    End If

    res = RssFooter()
    If Not res Then
        MsgBox("Can not write footer")
        Exit Function
    End If

    PersistRSS = True
End Function

Sub OnBtnSaveRSSClick()
    If Not PersistRSS Then Exit Sub

     cDialog.Filter = "RSS files (*.xml)|*.xml|All files (*.*)|*.*"
     cDialog.FileName = ""
    cDialog.CancelError = True
    On Error Resume Next
    cDialog.ShowOpen()
    If Err.Number <> 0 Then Exit Sub

    On Error Goto 0
    Dim res
    res = RssPersist(cDialog.FileName)
    sRSSXML = ""
    If Not res Then
        MsgBox("Can not save file")
        Exit Sub
    End If
End Sub

Sub OnBtnExportADOClick()
    Dim locator, conn
    Set locator = CreateObject("DataLinks")
    Set conn = locator.PromptNew()
    If (IsEmpty(conn) or IsNull(conn) or (conn is Nothing)) Then Exit Sub
    conn.Open()

    On Error Resume Next
    Dim strTableName
    strTableName = PromptTableName(conn)
    If Err.Number <> 0 Then Exit Sub

    On Error Goto 0
    DoExport conn, strTableName
End Sub

Sub OnBtnExportAccessClick()
     cDialog.Filter = "MS Access database files (*.mdb)|*.mdb"
    cDialog.FileName = ""
    cDialog.CancelError = True
    Dim strTableName
    strTableName = ""

    On Error Resume Next
    cDialog.ShowOpen()
    If Err.Number <> 0 Then Exit Sub
    Dim dbFileName
    dbFileName = cDialog.FileName

    Dim fso
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FileExists(dbFileName) Then
        Dim cat
        Set cat = CreateObject("ADOX.Catalog")
        cat.Create("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & dbFileName)
        If Err.Number <> 0 Then
            MsgBox Err.Description
            Exit Sub
        End If
        Set cat = Nothing
    End If
    Set fso = Nothing

    Dim conn
    Set conn = CreateObject("ADODB.Connection")
    conn.Open("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & dbFileName)
    If Err.Number <> 0 Then
        MsgBox Err.Description
        Exit Sub
    End If

    On Error Resume Next
    strTableName = PromptTableName(conn)
    If Err.Number <> 0 Then Exit Sub

    On Error Goto 0
    DoExport conn, strTableName
End Sub

Sub OnBtnExportToExcelClick()
     cDialog.Filter = "MS Excel files (*.xls)|*.xls"
     cDialog.FileName = ""
    cDialog.CancelError = True
    Dim strTableName
    strTableName = ""
    On Error Resume Next
    cDialog.ShowOpen()
    If Err.Number <> 0 Then Exit Sub

    Dim dbFileName, conn
    dbFileName = cDialog.FileName
    Set conn = CreateObject("ADODB.Connection")
    conn.Open("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & dbFileName & _
        ";Extended properties=Excel 8.0;")
    If Err.Number <> 0 Then
        MsgBox Err.Description
        Exit Sub
    End If

    On Error Resume Next
    strTableName = PromptTableName(conn)
    If Err.Number <> 0 Then Exit Sub

    On Error Goto 0
    DoExport conn, strTableName
End Sub

Sub OnTblArticleListClick()
    Dim srcElement
    Set srcElement = window.event.srcElement
    If srcElement.tagName <> "A" or IsNull(rsArticles) Then Exit Sub
    CleanupArticle()

    Dim strBookmark
    strBookmark = CStr(srcElement.id)
    If Len(strBookmark) > 3 Then
        strBookmark = Mid(strBookmark, 4)
    Else
        Exit Sub
    End If
    CurrentBookmark = VarAsType(strBookmark, BookmarkType)
    rsArticles.Bookmark = CurrentBookmark

    On Error Resume Next
    document.all.inpArticleTitle.value = CStr(rsArticles("Title"))
    document.all.inpArticleDescription.value = CStr(rsArticles("Description"))
    document.all.inpArticleURL.value = CStr(rsArticles("Url"))
    document.all.inpArticleDate.value = CStr(rsArticles("Date"))
    document.all.inpArticleCategory.value = CStr(rsArticles("Category"))
    document.all.inpArticleKeywords.value = CStr(rsArticles("Keywords"))
    document.all.inpArticleAuthorNames.value = CStr(rsArticles("Author"))
    document.all.inpArticleAuthorEmails.value = CStr(rsArticles("Email"))
End Sub

Function PromptTableName(conn)
    'PromptTableName = window.prompt("Table name:", "Articles")
    PromptTableName = CStr(window.showModalDialog("ChooseTable.html", conn, _
        "dialogHeight: 350px; dialogWidth: 400px; center: yes; help: no; resizable: no; status: no"))
    If PromptTableName = "" Then Err.Raise 5
End Function

Sub FillArticleList()
    Dim strArticles
    strArticles = "<TABLE id=""tblArticleList"" border=""0"" width=""100%"" onclick=""OnTblArticleListClick()"">" & vbCRLF

    On Error Resume Next
    rsArticles.MoveFirst()
    If Err.Number <> 0 Then Exit Sub
    BookmarkType = VarType(rsArticles.Bookmark)
    While Not rsArticles.EOF
        Dim strRow
        strRow = "<TR>" & vbCRLF
        'Bookmark is stored in ID attribute as "artXXX"
           strRow = strRow & "<TD><A href=""#"" id=""art" & CStr(rsArticles.Bookmark) & """>" & _
               rsArticles("Title") & "</A></TD>" & vbCRLF
           strRow = strRow & "</TR>" & vbCRLF
        strArticles = strArticles & strRow
        rsArticles.MoveNext()
    Wend

    strArticles = strArticles & "</TABLE>" & vbCRLF
    document.all.tblArticleList.outerHTML = strArticles
End Sub

Sub DoImport(conn, tblName)
    On Error Resume Next
    CleanupArticles()

    rsArticles = Null
    Dim rs
    Set rs = CreateObject("ADODB.Recordset")
    rs.CursorLocation = 3 'adUseClient
    rs.LockType = 4 'adLockBatchOptimistic
    If Mid(UCase(tblName), 1, 7) <> "SELECT " Then
        tblName = "SELECT [Title], [Description], [URL], [Date], [Category], [Keywords], " & _
            "[Author], [Email] FROM [" & tblName & "] ORDER BY [Title]"
    End If
    rs.Open tblName, conn
    If Err.Number <> 0 Then
        MsgBox Err.Description
        Exit Sub
    End If

    'Disconnect recordset
    Set rs.ActiveConnection = Nothing
    Set rsArticles = rs

    FillArticleList()
End Sub

Sub DoExport(conn, tblName)
    On Error Resume Next

    Dim strCreateTable
    strCreateTable = "CREATE TABLE [" & tblName & "] ([ID] AutoIncrement, [Title] VarChar(255), " & _
        "[Description] Memo, [URL] VarChar(255), [Date] VarChar(80), [Category] VarChar(50), " & _
        "[Keywords] VarChar(255), [Author] VarChar(255), [Email] VarChar(255))"
    conn.Execute(strCreateTable)
    If Err.Number <> 0 Then
        MsgBox "Can not create table: " & tblName
        Exit Sub
    End If

    Dim rs
    Set rs = CreateObject("ADODB.Recordset")
    rs.Open "SELECT * FROM [" & tblName & "]", conn, 0, 3 'adOpenForwardOnly, adLockOptimistic
    If Err.Number <> 0 Then
        MsgBox Err.Description
        Exit Sub
    End If

    Dim i
    i = 0

    rsArticles.MoveFirst()
    While Not rsArticles.EOF
        rs.AddNew()
         rs("Title") = rsArticles("Title")
         rs("Description") = rsArticles("Description")
         rs("URL") = rsArticles("URL")
         rs("Date") = rsArticles("Date")
         rs("Category") = rsArticles("Category")
         rs("Keywords") = rsArticles("Keywords")
         rs("Author") = rsArticles("Author")
         rs("Email") = rsArticles("Email")
         rs.Update()

        rsArticles.MoveNext()
        i = i + 1
    Wend

    MsgBox("Imported " & CStr(i) & " articles.")
End Sub

Function FindCurrentRow()
    FindCurrentRow = Null
    If IsNull(rsArticles) or IsNull(CurrentBookmark) Then Exit Function

    Dim tblArticles
    Set tblArticles = document.all.tblArticleList
    If IsEmpty(tblArticles) or IsNull(tblArticles) or (tblArticles is Nothing) Then Exit Function

    rsArticles.Bookmark = CurrentBookmark
    Set FindCurrentRow = tblArticles.all.item("art" & CStr(CurrentBookmark))

    Do
        If IsEmpty(FindCurrentRow) or IsNull(FindCurrentRow) or (FindCurrentRow is Nothing) or _
            (FindCurrentRow.tagName = "TR") Then Exit Do
        Set FindCurrentRow = FindCurrentRow.parentElement
    Loop

    If IsEmpty(FindCurrentRow) or (FindCurrentRow is Nothing) Then FindCurrentRow = Null
End Function

Sub OnBtnAddArticleClick()
    On Error Resume Next
    CleanupArticle()
    If IsEmpty(rsArticles) or IsNull(rsArticles) Then
        CreateRecordset()
        If Err.Number <> 0 Then
            MsgBox Err.Description
            Exit Sub
        End If
    End If

    rsArticles.AddNew()
    rsArticles("Title") = "<New article>"
    rsArticles("Date") = Now
    rsArticles.Update()
    If Err.Number <> 0 Then
        Err.Description
        Exit Sub
    End If

    CurrentBookmark = rsArticles.Bookmark
    If BookmarkType = vbEmpty Then BookmarkType = VarType(CurrentBookmark)

    Dim tblArticles, row, cell, link, strLink
    Set tblArticles = document.all.tblArticleList

    Set row = tblArticles.insertRow()
    Set cell = row.insertCell()
    Set link = document.createElement("<A href=""#"" id=""art" & CStr(rsArticles.Bookmark) & """>")
    cell.appendChild(link)
    link.innerText = rsArticles("Title")

    link.click()
End Sub

Sub OnBtnRemoveArticleClick()
    Dim CurrentRow
    Set CurrentRow = FindCurrentRow
    If IsNull(CurrentRow) Then Exit Sub

    On Error Resume Next
    CleanupArticle()
    rsArticles.Delete 1 'adAffectCurrent
    If Err.Number <> 0 Then
        MsgBox Err.Description
        Exit Sub
    End If

    Dim tblArticles
    Set tblArticles = document.all.tblArticleList
    tblArticles.deleteRow CurrentRow.rowIndex
End Sub

Function GetValueAsStringOrNull(Value)
    GetValueAsStringOrNull = CStr(Value)
    If Len(Value) = 0 Then GetValueAsStringOrNull = Null
End Function

Sub OnBtnUpdateArticleClick()
    Dim CurrentRow
    Set CurrentRow = FindCurrentRow
    If IsNull(CurrentRow) Then Exit Sub

    On Error Resume Next

    rsArticles("Title").Value = GetValueAsStringOrNull(document.all.inpArticleTitle.value)
    rsArticles("Description").Value = GetValueAsStringOrNull(document.all.inpArticleDescription.value)
    rsArticles("Url").Value = GetValueAsStringOrNull(document.all.inpArticleURL.value)
    rsArticles("Date").Value = GetValueAsStringOrNull(document.all.inpArticleDate.value)
    rsArticles("Category").Value = GetValueAsStringOrNull(document.all.inpArticleCategory.value)
    rsArticles("Keywords").Value = GetValueAsStringOrNull(document.all.inpArticleKeywords.value)
    rsArticles("Author").Value = GetValueAsStringOrNull(document.all.inpArticleAuthorNames.value)
    rsArticles("Email").Value = GetValueAsStringOrNull(document.all.inpArticleAuthorEmails.value)
    rsArticles.Update()

    If Err.Number <> 0 Then
        MsgBox Err.Description
        Exit Sub
    End If

    document.all.tblArticleList.all.item("art" & CStr(CurrentBookmark)).innerText = rsArticles("Title")
End Sub

'Pass data as Class is required becaus window.dialogArguments does not
'accept strings longer than 4096 characters
Class RssData
    Public Property Get RssXml
        RssXml = sRSSXML
    End Property
End Class

Sub OnBtnPreviewClick()
    If Not PersistRSS Then Exit Sub

    window.showModalDialog "Preview.html", new RssData, _
        "dialogHeight: 500px; dialogWidth: 750px; center: yes; help: no; resizable: yes; status: no"
    sRSSXML = ""
End Sub