' BBC News Script v1.0 With Link Support
' Created 17 April 2003 by MetalGearAl (metalgearal@hotmail.com)
'
' Description: Displays 3 Headlines from BBC Newspage, with briefs underneath each headline. 
' Optional:	   If your Samurize has linkage support, you can click on the headlines to load that news page
'
' This script creates a temporary textfile called News.txt in your Samurize folder
'
' Usage Instructions:
'
' 1. Copy "BBCNews.vbs" into your Samurize Scripts folder.
'
' 2. Add an active script to your Samurize Config and select "BBCNews.vbs"
'    Select the GetNews function
'    Set how often you want the script to update (e.g. I use every 30 minutes)
'
' 3. Add a Text File Meter and set it to read News.txt (should be in your Samurize folder)
'
'	 Choose which line you would like to read, the format is as follows:
'
'	 Line 1: Headline 1
'	 Line 2: Brief 1
'	 Line 3: Headline 2
'	 Line 4: Brief 2
'	 Line 5: Headline 3
'	 Line 6: Brief 3
'
' 4. If you want links, add linkage support to each Meter that shows a headline

Const Path = "C:\Program Files\Samurize\Configs\News.txt"
Const WebSite = "http://news.bbc.co.uk"

Links = False    ' Set to True to enable Link Support; False to disable Link Support.

' This splits the news briefs into seperate lines after this many characterss, in case you
' want to fit the text into a specific width. Set to 0 if you want it all on one line.
Const splitNum = 65	

' -- Leave Code Below Alone! :) --

Function GetNews
	URL = "http://news.bbc.co.uk/text_only.stm"

	html = BinToText(GetHTMLBin(URL), 32000) 

	html = replace(html,"  ","") 
	html = replace(html,vbCrLf,"") 
	html = replace(html,Chr(13),"") 
	html = replace(html,Chr(10),"") 
	html = replace(html,vbTab,"") 

	Dim regEx
	Set regEx = New RegExp 
	regEx.Global = True 

	Set fs = CreateObject("Scripting.FileSystemObject") 
	Set outFile = fs.CreateTextFile(Path, True) 

	regEx.Pattern = "/></a><a href=""(.*?)""><b>(.*?)</b></a><br />(.*?)<br clear=""all"" />"
	Set Matches = regEx.Execute(html) 
	For Each Match in Matches
		If Links Then
			outfile.write match.SubMatches(1) & "%l" & WebSite & match.SubMatches(0) & VbNewLine
		Else
			outfile.write match.SubMatches(1) & VbNewLine
		End If

		desc = BreakLine(match.SubMatches(2), SplitNum)
		outfile.write desc & VbNewLine
	Next 

	outFile.close
End Function

Private Function GetHTMLBin(strURL) 
        Dim objXMLHTTP, strReturn 
        Set objXMLHTTP = CreateObject("Microsoft.XMLHTTP") 
        On Error Resume Next 
        objXMLHTTP.Open "GET", strURL, False 
        objXMLHTTP.SEnd 
        If Err <> 0 Then 
          GetHTMLBin = -1 
        Else 
          GetHTMLBin = objXMLHTTP.responseBody 
        End If 
        On Error GoTo 0 
        Set objXMLHTTP = Nothing 
End Function 

Private Function BinToText(varBinData, intDataSizeInBytes)    ' as String
        Const adFldLong = &H00000080 
        Const adVarChar = 200 
        Set objRS = CreateObject("ADODB.Recordset") 
        objRS.Fields.AppEnd "txt", adVarChar, intDataSizeInBytes, adFldLong 
        objRS.Open 
        objRS.AddNew 
        objRS.Fields("txt").AppEndChunk varBinData 
        BinToText = objRS("txt").Value 
        objRS.Close 
        Set objRS = Nothing 
End Function 

Private Function BreakLine(MyText,LineLength)
    if LineLength <> 0 AND len(MyText) > LineLength then
        BreakLine = ""
        Do While len(MyText) > LineLength
                 breakPoint = InStrRev(MyText, " ", LineLength, 1)
                 BreakLine = BreakLine & left(MyText, breakPoint) & "%b"
            MyText = right(MyText, len(MyText) - breakPoint)
        loop
        BreakLine = BreakLine & MyText
    else
        BreakLine = MyText
    end if
End Function