VBGood网站全文搜索 Google

搜索VBGood全站网页(全文搜索)
首页 - 经验之谈 - 用 VB 实现新闻眼(提取搜狐的当天新闻),刚写的文章(准备投稿用的),大家先看为快吧,再提点见意!!
发表评论(0)作者:影子, 平台:VB6.0+Win98, 阅读:10026, 日期:2000-12-11
标 题:用 VB 实现新闻眼(提取搜狐的当天新闻),刚写的文章(准备投稿用的),大家先看为快吧,再提点见意!!
发信人:影子
时 间:2000-12-01 21:07:15
阅读次数:44
详细信息:
标题 :用 VB 实现新闻眼
一、引言
现在许多专业的网站都推出了自己的"新闻眼"(一种快速读取自己网站最近信息的软件),这种功能的实现方法如下。
二、这类软件的工作原理
(1)从指定网站下载相关的网页。(当然不是用 IE)
(2)把下载的网页转为文本文件。
(3)从文本文件中分析出必要的信息。
(4)显示在软件上。
三、在 VB 中实现的方法
程序所需要控件,1 个 Winsock 控件(其属性值为默认),1 个 TextBox 控件(Name 为 TxtWebPage,MultiLine 为 True,ScrollBars 为 2),提取数据后的界面如下(图1所示):

注意:这里就以取得"搜狐"为例(http://www.sohu.com)
Dim i, j, m, n, o As Long
Dim temp(1 To 2), s, str, str1, str2, myall, gettext(11) As String

Private Sub Form_Load()
`建立连接连接
Winsock1.RemoteHost = "sohu.com`如果想取"新浪",则换为 sina.com.cn
Winsock1.RemotePort = 80
Winsock1.Connect  ` 开始提取数据
End Sub

Private Sub Winsock1_Connect()
Dim strCommand As String
Dim strWebPage As String
strWebPage = "http://www.oshu.com/" `指定网页,这里是指搜狐的首页
strCommand = "GET " + strWebPage + " HTTP/1.0" + vbCrLf
strCommand = strCommand + "Accept: */*" + vbCrLf
strCommand = strCommand + "Accept: text/html" + vbCrLf
strCommand = strCommand + vbCrLf
Winsock1.SendData strCommand `发送命令
End Sub

Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
`开始下载, 在收到数据时, 发生DataArrival 事件
On Error Resume Next
Dim webData As String
Winsock1.GetData webData, vbString
myall = myall + webData `取得相关的网页文件
End Sub

(2)建立一个自定义的函数把 HTML 转为 TXT ,从文本文件中分析出必要的信息
Private Sub Winsock1_Close() `当下载完成时发生,开始把 HTML 转为指定文本格式
Call DelFind("<STYLE", "</STYLE>", 7) `去掉网页中的 CSS 部分
Call DelFind("<SCRIPT language=javascript", "</SCRIPT>", 8) `去掉网页中的 javascript 部分
Call HtmltoText(myall) `把 HTML 转为 TXT
Call ShowText(myall) `从 TXT 中提取所需要的信息
TxtWebPage.Text = myall `将提取的内容显示在文本框中
Winsock1.Close `关闭 Winsock
End Sub


Function DelFind(ByVal str1 As String, ByVal str2 As String, ByVal str3 As Integer)
Do
m = Len(myall)
i = InStr(1, myall, str1)
If i = 0 Then Exit Function
j = InStr(i, myall, str2)
temp(1) = Left(myall, i - 1)
temp(2) = Right(myall, m - j - str3)
myall = temp(1) & temp(2)
Loop
End Function

Function HtmltoText(ByVal str As String)
i = 0
j = 0
str = Replace(str, "&amp;", "&")
str = Replace(str, "&quot;", Chr(34)) `替换成双引号
str = Replace(str, "&lt;", "<")
str = Replace(str, "&gt;", ">")
str = Replace(str, "&nbsp;", vbNullString)
          
    `您可加入其他替换
    For i = 1 To Len(str)
        s = Mid(str, i, 1)
        Select Case s
            Case "<"
                If i <> 1 Then
                    str2 = str2 & Mid(str, j + 1, i - j - 1)
                End If
            Case ">"
                j = i
        End Select
    Next i
    myall = str2
   End Function

Function ShowText(ByVal str As String) `这是根据搜狐首页的一定格式提取的,如果想提取其他的网页,请自己定义
str2 = ""
i = InStr(1, str, "今日搜狐")
j = InStr(i, str, "更多新闻")
n = j
m = j - i
temp(1) = Mid(str, i, m)
For i = 1 To Len(temp(1))
s = Mid(temp(1), i, 1)
If s <> Chr(13) And s <> Space(1) And s <> Chr(10) Then str1 = str1 & Mid(temp(1), i, 1)
Next
j = 1
For m = 0 To 11
i = InStr(j, str1, "-")
If i = 0 Then
gettext(m) = Mid(str1, j, Len(str1) - j + 1)
str2 = str2 + gettext(m) + Chr(13) + Chr(10)
Exit For
End If
gettext(m) = Mid(str1, j, i - 1)
o = InStr(1, gettext(m), "-")
If o <> 0 Then
gettext(m) = Mid(gettext(m), 1, o - 1)
End If
str2 = str2 + gettext(m) + Chr(13) + Chr(10)
j = i + 1
Next
myall = str2
End Function

最后对这个程序的补充:
1、把 HTML 转为 TXT,及提取所需要的信息的一些算法,大家可以自己再想想(我的自我感觉也不好,感觉速度很慢)
2、最后提取出来的信息,还需要一定的处理,这需要你自己好好的想想,如果显示在你做的程序中(也就是程序界面需要大家自己来做,呵,要不然这可就是一个完整的软件了)。
3、最后如果大家还有什么想法,请到 http://www.d1vb.com(对编辑的话,这是一个VB论坛,我总在上面) 来我们一起讨论。