booksnew/tools/rssII.vbs

	'==============================================================
	' RSS/RDF Syndicate Reader v0.95
	' http://www.kattanweb.com/webdev
	'--------------------------------------------------------------
	' Copyright(c) 2002, KattanWeb.com
	'
	' Change Log:
	'--------------------------------------------------------------
	'==============================================================

Const adOpenStatic = 3
Const adCmdTable = &H0002
Const adOpenKeyset = 1
Const adLockReadOnly = 1
Const adLockPessimistic = 2
Const adLockOptimistic = 3
Const adLockBatchOptimistic = 4

'const sqlServer = "dsn=rssfeeds;uid=rss_user;pwd=hOC2jBiQFxAOKy9PoUXDhoix8Ec7BRLfHkz7trh7ZMn27H_lESSkRk7m-jX5ibiN;"
const sqlServer = "dsn=rssfeeds;uid=rss_user;pwd=rss;"



Const rssInit  = 1
Const rssError = 2
Const rssBadRSS= 3
Const rssOK    = 0
Private Const BITS_TO_A_BYTE=8
Private Const BYTES_TO_A_WORD=4
Private Const BITS_TO_A_WORD=32
Private m_lOnBits(30)
Private m_l2Power(30)
m_lOnBits(0)=CLng(1)
m_lOnBits(1)=CLng(3)
m_lOnBits(2)=CLng(7)
m_lOnBits(3)=CLng(15)
m_lOnBits(4)=CLng(31)
m_lOnBits(5)=CLng(63)
m_lOnBits(6)=CLng(127)
m_lOnBits(7)=CLng(255)
m_lOnBits(8)=CLng(511)
m_lOnBits(9)=CLng(1023)
m_lOnBits(10)=CLng(2047)
m_lOnBits(11)=CLng(4095)
m_lOnBits(12)=CLng(8191)
m_lOnBits(13)=CLng(16383)
m_lOnBits(14)=CLng(32767)
m_lOnBits(15)=CLng(65535)
m_lOnBits(16)=CLng(131071)
m_lOnBits(17)=CLng(262143)
m_lOnBits(18)=CLng(524287)
m_lOnBits(19)=CLng(1048575)
m_lOnBits(20)=CLng(2097151)
m_lOnBits(21)=CLng(4194303)
m_lOnBits(22)=CLng(8388607)
m_lOnBits(23)=CLng(16777215)
m_lOnBits(24)=CLng(33554431)
m_lOnBits(25)=CLng(67108863)
m_lOnBits(26)=CLng(134217727)
m_lOnBits(27)=CLng(268435455)
m_lOnBits(28)=CLng(536870911)
m_lOnBits(29)=CLng(1073741823)
m_lOnBits(30)=CLng(2147483647)

m_l2Power(0)=CLng(1)
m_l2Power(1)=CLng(2)
m_l2Power(2)=CLng(4)
m_l2Power(3)=CLng(8)
m_l2Power(4)=CLng(16)
m_l2Power(5)=CLng(32)
m_l2Power(6)=CLng(64)
m_l2Power(7)=CLng(128)
m_l2Power(8)=CLng(256)
m_l2Power(9)=CLng(512)
m_l2Power(10)=CLng(1024)
m_l2Power(11)=CLng(2048)
m_l2Power(12)=CLng(4096)
m_l2Power(13)=CLng(8192)
m_l2Power(14)=CLng(16384)
m_l2Power(15)=CLng(32768)
m_l2Power(16)=CLng(65536)
m_l2Power(17)=CLng(131072)
m_l2Power(18)=CLng(262144)
m_l2Power(19)=CLng(524288)
m_l2Power(20)=CLng(1048576)
m_l2Power(21)=CLng(2097152)
m_l2Power(22)=CLng(4194304)
m_l2Power(23)=CLng(8388608)
m_l2Power(24)=CLng(16777216)
m_l2Power(25)=CLng(33554432)
m_l2Power(26)=CLng(67108864)
m_l2Power(27)=CLng(134217728)
m_l2Power(28)=CLng(268435456)
m_l2Power(29)=CLng(536870912)
m_l2Power(30)=CLng(1073741824)



Private Function LShift(lValue,iShiftBits)
  If iShiftBits=0 Then
    LShift=lValue
    Exit Function
  ElseIf iShiftBits=31 Then
    If lValue And 1 Then
      LShift=&H80000000
    Else
      LShift=0
    End If
    Exit Function
  ElseIf iShiftBits<0 Or iShiftBits>31 Then
    Err.Raise 6
  End If

  If (lValue And m_l2Power(31-iShiftBits)) Then
    LShift=((lValue And m_lOnBits(31-(iShiftBits+1)))*m_l2Power(iShiftBits)) Or &H80000000
  Else
    LShift=((lValue And m_lOnBits(31-iShiftBits))*m_l2Power(iShiftBits))
  End If
End Function

Private Function RShift(lValue,iShiftBits)
  If iShiftBits=0 Then
    RShift=lValue
    Exit Function
  ElseIf iShiftBits=31 Then
    If lValue And &H80000000 Then
      RShift=1
    Else
      RShift=0
    End If
    Exit Function
  ElseIf iShiftBits<0 Or iShiftBits>31 Then
    Err.Raise 6
  End If
  
  RShift=(lValue And &H7FFFFFFE)\m_l2Power(iShiftBits)

  If (lValue And &H80000000) Then
    RShift=(RShift Or (&H40000000\m_l2Power(iShiftBits-1)))
  End If
End Function

Private Function RotateLeft(lValue,iShiftBits)
  RotateLeft=LShift(lValue,iShiftBits) Or RShift(lValue,(32-iShiftBits))
End Function

Private Function AddUnsigned(lX,lY)
  Dim lX4
  Dim lY4
  Dim lX8
  Dim lY8
  Dim lResult

  lX8=lX And &H80000000
  lY8=lY And &H80000000
  lX4=lX And &H40000000
  lY4=lY And &H40000000

  lResult=(lX And &H3FFFFFFF)+(lY And &H3FFFFFFF)

  If lX4 And lY4 Then
    lResult=lResult Xor &H80000000 Xor lX8 Xor lY8
  ElseIf lX4 Or lY4 Then
    If lResult And &H40000000 Then
      lResult=lResult Xor &HC0000000 Xor lX8 Xor lY8
    Else
      lResult=lResult Xor &H40000000 Xor lX8 Xor lY8
    End If
  Else
    lResult=lResult Xor lX8 Xor lY8
  End If

  AddUnsigned=lResult
End Function

Private Function F(x,y,z)
  F=(x And y) Or ((Not x) And z)
End Function

Private Function G(x,y,z)
  G=(x And z) Or (y And (Not z))
End Function

Private Function H(x,y,z)
  H=(x Xor y Xor z)
End Function

Private Function I(x,y,z)
  I=(y Xor (x Or (Not z)))
End Function

Private Sub FF(a,b,c,d,x,s,ac)
  a=AddUnsigned(a,AddUnsigned(AddUnsigned(F(b,c,d),x),ac))
  a=RotateLeft(a,s)
  a=AddUnsigned(a,b)
End Sub

Private Sub GG(a,b,c,d,x,s,ac)
  a=AddUnsigned(a,AddUnsigned(AddUnsigned(G(b,c,d),x),ac))
  a=RotateLeft(a,s)
  a=AddUnsigned(a,b)
End Sub

Private Sub HH(a,b,c,d,x,s,ac)
  a=AddUnsigned(a,AddUnsigned(AddUnsigned(H(b,c,d),x),ac))
  a=RotateLeft(a,s)
  a=AddUnsigned(a,b)
End Sub

Private Sub II(a,b,c,d,x,s,ac)
  a=AddUnsigned(a,AddUnsigned(AddUnsigned(I(b,c,d),x),ac))
  a=RotateLeft(a,s)
  a=AddUnsigned(a,b)
End Sub

Private Function ConvertToWordArray(sMessage)
  Dim lMessageLength
  Dim lNumberOfWords
  Dim lWordArray()
  Dim lBytePosition
  Dim lByteCount
  Dim lWordCount
  
  Const MODULUS_BITS=512
  Const CONGRUENT_BITS=448
  
  lMessageLength=Len(sMessage)
  
  lNumberOfWords=(((lMessageLength+((MODULUS_BITS-CONGRUENT_BITS)\BITS_TO_A_BYTE))\(MODULUS_BITS\BITS_TO_A_BYTE))+1)*(MODULUS_BITS\BITS_TO_A_WORD)
  ReDim lWordArray(lNumberOfWords-1)
  
  lBytePosition=0
  lByteCount=0
  Do Until lByteCount >=lMessageLength
    lWordCount=lByteCount\BYTES_TO_A_WORD
    lBytePosition=(lByteCount Mod BYTES_TO_A_WORD)*BITS_TO_A_BYTE
    lWordArray(lWordCount)=lWordArray(lWordCount) Or LShift(Asc(Mid(sMessage,lByteCount+1,1)),lBytePosition)
    lByteCount=lByteCount+1
  Loop

  lWordCount=lByteCount\BYTES_TO_A_WORD
  lBytePosition=(lByteCount Mod BYTES_TO_A_WORD)*BITS_TO_A_BYTE

  lWordArray(lWordCount)=lWordArray(lWordCount) Or LShift(&H80,lBytePosition)

  lWordArray(lNumberOfWords-2)=LShift(lMessageLength,3)
  lWordArray(lNumberOfWords-1)=RShift(lMessageLength,29)
  
  ConvertToWordArray=lWordArray
End Function

Private Function WordToHex(lValue)
  Dim lByte
  Dim lCount
  
  For lCount=0 To 3
    lByte=RShift(lValue,lCount*BITS_TO_A_BYTE) And m_lOnBits(BITS_TO_A_BYTE-1)
    WordToHex=WordToHex & Right("0" & Hex(lByte),2)
  Next
End Function

Public Function MD5(sMessage)
  Dim x
  Dim k
  Dim AA
  Dim BB
  Dim CC
  Dim DD
  Dim a
  Dim b
  Dim c
  Dim d
  
  Const S11=7
  Const S12=12
  Const S13=17
  Const S14=22
  Const S21=5
  Const S22=9
  Const S23=14
  Const S24=20
  Const S31=4
  Const S32=11
  Const S33=16
  Const S34=23
  Const S41=6
  Const S42=10
  Const S43=15
  Const S44=21

  x=ConvertToWordArray(sMessage)
  
  a=&H67452301
  b=&HEFCDAB89
  c=&H98BADCFE
  d=&H10325476

  For k=0 To UBound(x) Step 16
    AA=a
    BB=b
    CC=c
    DD=d

    FF a,b,c,d,x(k+0),S11,&HD76AA478
    FF d,a,b,c,x(k+1),S12,&HE8C7B756
    FF c,d,a,b,x(k+2),S13,&H242070DB
    FF b,c,d,a,x(k+3),S14,&HC1BDCEEE
    FF a,b,c,d,x(k+4),S11,&HF57C0FAF
    FF d,a,b,c,x(k+5),S12,&H4787C62A
    FF c,d,a,b,x(k+6),S13,&HA8304613
    FF b,c,d,a,x(k+7),S14,&HFD469501
    FF a,b,c,d,x(k+8),S11,&H698098D8
    FF d,a,b,c,x(k+9),S12,&H8B44F7AF
    FF c,d,a,b,x(k+10),S13,&HFFFF5BB1
    FF b,c,d,a,x(k+11),S14,&H895CD7BE
    FF a,b,c,d,x(k+12),S11,&H6B901122
    FF d,a,b,c,x(k+13),S12,&HFD987193
    FF c,d,a,b,x(k+14),S13,&HA679438E
    FF b,c,d,a,x(k+15),S14,&H49B40821

    GG a,b,c,d,x(k+1),S21,&HF61E2562
    GG d,a,b,c,x(k+6),S22,&HC040B340
    GG c,d,a,b,x(k+11),S23,&H265E5A51
    GG b,c,d,a,x(k+0),S24,&HE9B6C7AA
    GG a,b,c,d,x(k+5),S21,&HD62F105D
    GG d,a,b,c,x(k+10),S22,&H2441453
    GG c,d,a,b,x(k+15),S23,&HD8A1E681
    GG b,c,d,a,x(k+4),S24,&HE7D3FBC8
    GG a,b,c,d,x(k+9),S21,&H21E1CDE6
    GG d,a,b,c,x(k+14),S22,&HC33707D6
    GG c,d,a,b,x(k+3),S23,&HF4D50D87
    GG b,c,d,a,x(k+8),S24,&H455A14ED
    GG a,b,c,d,x(k+13),S21,&HA9E3E905
    GG d,a,b,c,x(k+2),S22,&HFCEFA3F8
    GG c,d,a,b,x(k+7),S23,&H676F02D9
    GG b,c,d,a,x(k+12),S24,&H8D2A4C8A
        
    HH a,b,c,d,x(k+5),S31,&HFFFA3942
    HH d,a,b,c,x(k+8),S32,&H8771F681
    HH c,d,a,b,x(k+11),S33,&H6D9D6122
    HH b,c,d,a,x(k+14),S34,&HFDE5380C
    HH a,b,c,d,x(k+1),S31,&HA4BEEA44
    HH d,a,b,c,x(k+4),S32,&H4BDECFA9
    HH c,d,a,b,x(k+7),S33,&HF6BB4B60
    HH b,c,d,a,x(k+10),S34,&HBEBFBC70
    HH a,b,c,d,x(k+13),S31,&H289B7EC6
    HH d,a,b,c,x(k+0),S32,&HEAA127FA
    HH c,d,a,b,x(k+3),S33,&HD4EF3085
    HH b,c,d,a,x(k+6),S34,&H4881D05
    HH a,b,c,d,x(k+9),S31,&HD9D4D039
    HH d,a,b,c,x(k+12),S32,&HE6DB99E5
    HH c,d,a,b,x(k+15),S33,&H1FA27CF8
    HH b,c,d,a,x(k+2),S34,&HC4AC5665

    II a,b,c,d,x(k+0),S41,&HF4292244
    II d,a,b,c,x(k+7),S42,&H432AFF97
    II c,d,a,b,x(k+14),S43,&HAB9423A7
    II b,c,d,a,x(k+5),S44,&HFC93A039
    II a,b,c,d,x(k+12),S41,&H655B59C3
    II d,a,b,c,x(k+3),S42,&H8F0CCC92
    II c,d,a,b,x(k+10),S43,&HFFEFF47D
    II b,c,d,a,x(k+1),S44,&H85845DD1
    II a,b,c,d,x(k+8),S41,&H6FA87E4F
    II d,a,b,c,x(k+15),S42,&HFE2CE6E0
    II c,d,a,b,x(k+6),S43,&HA3014314
    II b,c,d,a,x(k+13),S44,&H4E0811A1
    II a,b,c,d,x(k+4),S41,&HF7537E82
    II d,a,b,c,x(k+11),S42,&HBD3AF235
    II c,d,a,b,x(k+2),S43,&H2AD7D2BB
    II b,c,d,a,x(k+9),S44,&HEB86D391

    a=AddUnsigned(a,AA)
    b=AddUnsigned(b,BB)
    c=AddUnsigned(c,CC)
    d=AddUnsigned(d,DD)
  Next
  
  MD5=LCase(WordToHex(a) & WordToHex(b) & WordToHex(c) & WordToHex(d))
End Function


function stripBadChars(istr)
	goodchars = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890"

	l = len(istr)

	outstr = ""	
	for t= 1 to l 
		if instr(goodchars,mid(istr,t,1)) > 0 then outstr = outstr & mid(istr,t,1)
		wscript.echo mid(istr,t,1)
	next

	stripBadchars = outstr

end function



class kwRSS_reader
	Private Items()
	Private CurrentItem, TotalItems
	Public ChannelRSSURI, ChannelURL, ChannelTitle, ChannelDesc, ChannelLanguage
	Public ImageTitle, ImageLink, ImageURL
	Public TextInputURL, TextInputTitle, TextInputDesc, TextInputName
	public Status

    '>>>>>>>> Setup Initialize event, called automtially when creating an instant of this class using
	'	      Set rss = new kwRSS_reader
	Private Sub Class_Initialize
		CurrentItem = -1
		TotalItems  = -1
		Redim Items(2, 10)		'1st dimension = item's title/link/desc, 2nd dimension the item number
		Status = rssInit
	End Sub

    '>>>>>>>> Setup Terminate event, called automtially when killing an instant of this class using
	'	      Set rss = nothing
	Private Sub Class_Terminate
		Erase Items
	End Sub

    '>>>>>>>> Load an RSS/RDF file and process it.
	Public Function ParseLocation(URL)

	rssname = stripBadChars(url)

wscript.echo "Rssname : " & rssname 

	rssupdate = true

'application(rssname & "time") = cdate("1974-10-24")




wscript.echo "Just about to retrieve the xml"


		ChannelRSSURI = URL
		set xmlObj = wscript.createobject("Msxml2.DOMDocument.3.0")
		set xmlhttp= wscript.createobject("Msxml2.XMLHTTP.3.0")


'var xmlDoc = new ActiveXObject("MSXML2.DOMDocument.3.0");



wscript.echo "XML objects created...."

'			xmlObj.validateOnParse = false
'			xmlObj.async = false
'			xmlObj.preserveWhiteSpace = false
'
'			xmlhttp.open "GET", ChannelRSSURI, False
'			xmlhttp.send
'			rssXML_Data = xmlhttp.responseXML.xml

wscript.echo "retrieved news "


			xmlObj.validateOnParse = false
			xmlObj.async = false
			xmlObj.preserveWhiteSpace = false

			xmlhttp.open "GET", ChannelRSSURI, False
			xmlhttp.send

	

			rssXML_Data = xmlhttp.responseXML.xml
'			rssXML_Data = application(rssname & "xml")




if len(rssXML_Data) = 0 then
		Status = rssError 

			wscript.echo "<!-- RSS Status : " & status & " -->" & vbcrlf
			wscript.echo "RSS Status : " & status  & vbcrlf

			Exit Function

	end if





			' --------- PHP-Nuke & PostNuke compatabilaty --------------------------------
			rssXML_Data = replace(rssXML_Data, "<!DOCTYPE", "<!--DOCTYPE")
			rssXML_Data = replace(rssXML_Data, "rss-0.91.dtd"">", "rss-0.91.dtd""-->")
			' ----------------------------------------------------------------------------
			xmlObj.loadXML(rssXML_Data)
			

			If xmlObj.parseError.errorCode = 0 then
				ValidLocation = true
			else
				ValidLocation = false
			end if
		set xmlhttp = nothing

		if not ValidLocation then
			Status = rssBadRSS

			wscript.echo "<!-- RSS Status : " & status & " -->" & vbcrlf
'response.flush

			Exit Function
		end if

		set rootNode = xmlObj.selectSingleNode("rdf:RDF")
		if rootNode is nothing then
			set rootNode = xmlObj.selectSingleNode("rss")
			if rootNode is nothing then
				Status = rssError
				wscript.echo "<!-- RSS Status : " & status & " -->" & vbcrlf
'response.flush

			else
				Reader rootNode, 0.91
			end if
		else
			Reader rootNode, 1.0
		end if		

		set rootNode = nothing
		set xmlObj = nothing
		Status = rssOK
	End Function

    '>>>>>>>> Private sub to read the RSS/RDF according to its version
	Private Sub Reader(rootNode, ver)
		itemNum = -1

		set SingleNode = rootNode.selectSingleNode("//channel/title")
		if Not SingleNode is nothing then ChannelTitle = SingleNode.text

		set SingleNode = rootNode.selectSingleNode("//channel/link")
		if Not SingleNode is nothing then ChannelURL = SingleNode.text

		set SingleNode = rootNode.selectSingleNode("//channel/description")
		if Not SingleNode is nothing then ChannelDesc = SingleNode.text

		set SingleNode = rootNode.selectSingleNode("//channel/language")
		if Not SingleNode is nothing then ChannelLanguage = SingleNode.text

		if ver = 1 then
			set child = rootNode.selectSingleNode("image")
		else
			set child = rootNode.selectSingleNode("//channel/image")
		end if
			if not child is nothing then
				set SingleNode = child.selectSingleNode("title")
				if Not SingleNode is nothing then ImageTitle = SingleNode.text

				set SingleNode = child.selectSingleNode("link")
				if Not SingleNode is nothing then ImageLink = SingleNode.text

				set SingleNode = child.selectSingleNode("url")
				if Not SingleNode is nothing then ImageURL = SingleNode.text
			end if
		set child = nothing

		if ver = 1 then
			set child = rootNode.selectSingleNode("textinput")
		else
			set child = rootNode.selectSingleNode("//channel/textinput")
		end if
			if not child is nothing then
				set SingleNode = child.selectSingleNode("title")
				if Not SingleNode is nothing then TextInputTitle = SingleNode.text

				set SingleNode = child.selectSingleNode("description")
				if Not SingleNode is nothing then TextInputDesc = SingleNode.text

				set SingleNode = child.selectSingleNode("name")
				if Not SingleNode is nothing then TextInputName = SingleNode.text

				set SingleNode = child.selectSingleNode("link")
				if Not SingleNode is nothing then TextInputURL = SingleNode.text
			end if
		set child = nothing

		set children = rootNode.selectNodes("//item")
		TotalItems = children.length
			for each child in children
				itemNum = itemNum + 1
				if itemNum > ubound(Items, 2) then
					Redim Preserve Items(2, ubound(Items, 2) + 5)
				end if
				for each ItemChild in child.ChildNodes
					select case ItemChild.baseName
						case "title"		Items(0, itemNum) = ItemChild.text
						case "link"			Items(1, itemNum) = ItemChild.text
						case "description"	Items(2, itemNum) = ItemChild.text
					end select
				next
			next
		if TotalItems > 0 then CurrentItem = 0
	End Sub

    '>>>>>>>> Returns the title of the the current item
	Public Function GetTitle()
		GetTitle = Items(0, CurrentItem)
	End Function

    '>>>>>>>> Returns the url/link of the the current item
	Public Function GetLink()
		GetLink = Items(1, CurrentItem)
	End Function

	'>>>>>>>> Returns the description of the the current item
	Public Function GetDesc()
		GetDesc = Items(2, CurrentItem)
	End Function
	
    '>>>>>>>> Goes to the next item
	Public Function MoveNext
		CurrentItem = CurrentItem + 1
	End Function

    '>>>>>>>> Goes to the first item
	Public Function FirstItem
		if TotalItems > 0 then
			CurrentItem = 0

		else
			CurrentItem = -1

		end if
	End Function

    '>>>>>>>> Checks if the current location is a valid item or not
	Public Function ValidItem
		if CurrentItem > -1 and CurrentItem < TotalItems then
			ValidItem = true
		else
			ValidItem = false
		end if			
	End Function

    '>>>>>>>> Checks if we are at EOF or not
	Public Function EOF
		if CurrentItem < TotalItems then
			EOF = false
		else
			EOF = true
		end if			
	End Function

    '>>>>>>>> Returns status of the class
	Public Function GetStatus()
		GetStatus = Status
	end function

    '>>>>>>>> Returns Image provided in the RSS/RDF file as a linked image.
	Public Function GetImage()
		if ImageURL <> "" then
			if ImageLink <> "" then GetImage = "<a href=""" & ImageLink & """>"
			GetImage = GetImage & "<img src=""" & ImageURL & """ alt=""" & ImageTitle & """ border=""0"" />"
			if ImageLink <> "" then GetImage = GetImage & "</a>"
		else
			GetImage = ""
		end if
	end function

    '>>>>>>>> Returns the code for the TextInput provided in the RSS/RDF file.
	Public Function GetTextInput()
		if TextInputURL <> "" then
			GetTextInput = "<form method=""post"" action=""" & TextInputURL & """>" & vbCrLf & _
							"<table>" & vbCrLf & _
							"<tr>" & vbCrLf & _
							"	<td>" & TextInputDesc & "</td>" & vbCrLf & _
							"</tr>" & vbCrLf & _
							"<tr>" & vbCrLf & _
							"	<td><input type=""text"" name=""" & TextInputName & """ /></td>" & vbCrLf & _
							"</tr>" & vbCrLf & _
							"<tr>" & vbCrLf & _
							"	<td><input type=""submit"" value=""" &  TextInputTitle & """ /></td>" & vbCrLf & _
							"</tr>" & vbCrLf & _
							"</table>" & vbCrLf & _
							"</form>"
		else
			GetTextInput = ""
		end if
	end function

end class





sub showRSSNewsFeeds(rssNewsFeed,id)


' Example for reading RSS or RDF Site Summary files.
' The file is commented, to be as a simple manual as i hate to write manuals :)
' First thing to do is to include the rss reader file, as the first line above.


' First step is to create an instance of the class
	Set RSS = new kwRSS_reader

'	rssURL = "http://feeds.engadget.com/weblogsinc/engadget"
rssUrl = rssNewsFeed


wscript.echo rssurl


' Second step is to call the RSS parser with a valid RSS address.
' The address must be a full qualified internet address, not relative.
' Example on a valid address: http://www.kattanweb.com/webdev/rss.asp
'	on error resume next

	RSS.ParseLocation(rssURL)

If Err.Number <> 0 Then WScript.Echo "Problem with the news feed"
' Here you can get the needed variables.
' Available variables are:
' 	ChannelRSSURI, ChannelURL, ChannelTitle, ChannelDesc, ChannelLanguage
'	ImageTitle, ImageLink, ImageURL
'	TextInputURL, TextInputTitle, TextInputDesc, TextInputName
' for more information about each variable are in the writer example "write_rss.asp

'	WScript.Echo "<h3><a href=""" & RSS.ChannelURL & """ lang=""" & RSS.ChannelLanguage & """ title=""" & RSS.ChannelDesc & """>" & cleanEllipse(RSS.ChannelTitle,20) & "</a></h3>"
'	WScript.Echo "</td></tr><tr><td>"

'boxCaption = "<a href=""" & RSS.ChannelURL & """ lang=""" & RSS.ChannelLanguage & """ title=""" & RSS.ChannelTitle & " - " & RSS.ChannelDesc & """>" & cleanEllipse(RSS.ChannelTitle,20) & "</a>"
wscript.echo "RSS.status : " & RSS.status & "<br />"

if rss.status = 0 then
'call MakeHeadedBox(boxcaption, "100%",0)	


' Some function available:
' [rss].FirstItem: will go to the first item in the rss file (not needed usually, as when the rss is parsed,
'                  the pointer will be on the first item.
' [rss].ValidItem: true/false according if the current item is a valid one (or exist)

rssItemCount = 0

	Set objConn = wscript.CreateObject("ADODB.Connection")
	Set objRec = wscript.CreateObject("ADODB.Recordset")

	Set objAddConn = wscript.CreateObject("ADODB.Connection")
'	Set objAddRec = wscript.CreateObject("ADODB.Recordset")


	objConn.Open sqlServer 


	objAddConn.Open sqlServer 

	objAddConn.begintrans

'	objAddRec.Open "ustructrssitems",objAddConn , adOpenStatic, adLockPessimistic, adCmdTable

'adOpenKeyset, adLockBatchOptimistic

'objAddRec.Open "ustructrssitems",objAddConn , adOpenKeyset, adLockBatchOptimistic


	Set objAddRec= wscript.CreateObject("ADODB.Recordset")

	objAddRec.ActiveConnection = objAddConn
	objAddRec.CursorType = adOpenKeyset
	objAddRec.LockType = adLockBatchOptimistic
	objAddRec.Source = "ustructrssitems"
	objAddRec.Open






	while not RSS.EOF 
		' function available for items:
		' [rss].GetTitle: gets the title of the item
		' [rss].GetLink: gets the link of the item
		' [rss].GetDesc: gets the description of the item  	%>


		sqlstr = "select count(*) as cnt from ustructrssitems where titlehash = '" & MD5(RSS.GetTitle ) & "';"

		wscript.echo sqlstr

		set objRec = objConn.execute(sqlstr)

		if not objrec.bof and not objrec.eof then
			itemcount = objrec("cnt")
		else
			wscript.echo "fuck"
		end if


		wscript.echo"itemcount : " & itemcount
		if cint(itemcount) = 0 then 

wscript.echo "Adding..."

			' addnewItem(objAddRec,id,rss.gettitle,rss.getlink,rss.getdesc)


			objAddRec.addnew

			objAddRec("feedid") = id
			objAddRec("caption") = rss.gettitle
			objAddRec("link") = rss.getlink
			objAddRec("bodytext") = rss.getdesc

			objAddRec("titlehash") = md5(rss.gettitle)
			objAddRec("bodyhash") = md5(rss.getdesc)

			objAddRec("readdt") = sqllongdate(now)
			objAddRec("moddt") = sqllongdate(now)



If Err.Number <> 0 Then

		wscript.echo  "Insert Failed: " & Err.number & ", " & Err.Description

end if

		end if

		'objrec.clear

		RSS.MoveNext
	wend


	objAddRec.Updatebatch
	
	objAddConn.committrans

 objAddRec.close
 set objAddRec = nothing


 objAddConn.close
 set objAddConn = nothing


 objrec.close
 set objrec = nothing

 objconn.close
 set objconn = nothing


sqlstr = "update ustructrssfeeds set feedname='" & rss.channeltitle & "', feednamehash='" & md5(rss.channeltitle) & "',lastupdate='" & sqllongdate(now) & "' where feedid=" & id& ";"

wscript.echo sqlstr

 

Set objConn = wscript.CreateObject("ADODB.Connection")
objConn.Open sqlServer 

objConn.execute(sqlstr)



 objconn.close
 set objconn = nothing



' [rss].GetTextInput: gets the textinput search box, using a simple table.
' if you don't want the default form, make your own one using the TextInputURL, TextInputTitle,
' TextInputDesc, TextInputName variables
if RSS.GetTextInput <> "" then
	wscript.echo RSS.GetTextInput
end if






' [rss].GetImage: gets the image with link (if available)
' if you don't want the default style, make your own one using the ImageTitle, ImageLink, ImageURL variables
if RSS.GetImage <> "" then
'	WScript.Echo RSS.GetImage
end if

' Setting RSS to nothing will free the memory 
Set RSS = nothing
'call closebox()

'response.flush
end if
end sub


function SQLLongDate(olddate)

	dy = day(cdate(olddate))
	mn = month(cdate(olddate))
	yr = year(cdate(olddate))

	mh = hour(cdate(olddate))
	mm = minute(cdate(olddate))
	ss = second(cdate(olddate))

if len(mh) <= 1 then mh = "0" & mh
if len(mm) <= 1 then mm = "0" & mm
if len(ss) <= 1 then ss = "0" & ss

'response.write "Day : " & dy & "<BR>" & vbcrlf
'response.write "Month : " & mn & "<BR>" & vbcrlf
'response.write "Year : " & yr & "<BR>" & vbcrlf
	'mv = mn & "/" & dy & "/" &  yr
	mv= yr & "-" & mn & "-" & dy & " "

	mv = mv & mh & ":" & mm & ":" & ss

	SQLLongDate = mv

end function




sub addnewitem(sqlconnection,feedid,itemtitle,itemlink,itemdesc)


	wscript.echo "Adding..."
	sqlconnection.addnew


	sqlconnection("feedid") = feedid
	sqlconnection("caption") = itemtitle
	sqlconnection("link") = itemlink
	sqlconnection("bodytext") = itemdesc

	sqlconnection("titlehash") = md5(itemtitle)
	sqlconnection("bodyhash") = md5(itemdesc)


	sqlconnection("readdt") = sqllongdate(now)
	sqlconnection("moddt") = sqllongdate(now)




	


end sub



function StripHTML(ByRef asHTML)
    	Dim loRegExp	' Regular Expression Object
    	
    	' Create built In Regular Expression object
    	Set loRegExp = New RegExp
	loRegExp.Global = True
    	' Set the pattern To look For HTML tags
    	loRegExp.Pattern = "<[^>]*>"
    	
    	' Return the original String stripped of HTML
    	StripHTML = loRegExp.Replace(asHTML, "")
    	
    	' Release object from memory
    	Set loRegExp = Nothing
    End function



function numbersOnly(ival)

	notallwd = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ!<21>$%^&*()_+=[]{}#~<>?/\`'.,"
	allwd = "01234567890"


	l = len(ival)

	ws = ""

	for t = 1 to l


		cc = mid(ival,t,1)

		if instr(allwd,cc) > 0 then ws = ws & cc


	next


	numbersonly = ws


end function



sub GatherRSS()

	Set objConn = wscript.CreateObject("ADODB.Connection")
	Set objRec = wscript.CreateObject("ADODB.Recordset")


	objConn.Open sqlServer 


	sqlstr = "select * from ustructrssfeeds where lastupdate < '" & sqllongdate(dateadd("h",-1,now)) & "' or lastupdate is null;"

wscript.echo sqlstr

	set objRec = objConn.execute(sqlstr)


	if not objRec.bof and not objrec.eof then

		do while not objrec.eof
wscript.echo "GO!"
	 		feedid = objrec("feedid")

	 		feedurl = objrec("feedurl")

			call showRSSNewsFeeds(feedurl,feedid)

			objrec.movenext

		loop

	end if
end sub


sub GetNew()

	ChannelRSSURI = "http://www.taggrr.com/updaterss.asp"

	set xmlhttp= wscript.createobject("Msxml2.XMLHTTP.3.0")



	xmlhttp.open "POST", ChannelRSSURI, False
	xmlhttp.send

	

	WScript.Echo xmlhttp.responsetext


end sub

WScript.Echo "RSS UpdaterII"


call GetNew()