|
发表于 2008 年 6 月 25 日 00:42:16
|
显示全部楼层
VB 下代码, 功能已经调试过. 你参考, 睡觉了, 祝你好运.- Dim HTTPUrl As String
- Dim Retrieval As Object
- Private Sub Class_Initialize()
- Set Retrieval = CreateObject("Microsoft.XMLHTTP")
- End Sub
- Function GetURL(Optional url As String)
- If url <> "" Then
- HTTPUrl = url
- End If
- On Error GoTo Exittag:
- With Retrieval
- .Open "GET", url, False, "", ""
- .send
- GetURL = .responsetext
- End With
- Exit Function
- Exittag:
- MsgBox Err.Description & "::. GetUrl"
- Err.Clear
- End Function
- Private Sub Class_Terminate()
- Set Retrieval = Nothing
- End Sub
- Private Sub Form_DblClick()
- Dim tempstr As String
- Dim ID(10000) As String
- Dim i, maxid As Integer
- Open "C:\idfile.txt" For Input As #1 '你的ID索引文件
- i = 1
- Do While Not EOF(1)
- Line Input #1, ID(i)
- i = i + 1
- Loop
- Close #1
- maxid = i
- Class_Initialize
- i = 1
- RichTextBox1.Text = ""
- Do While i <= maxid
- tempstr = GetURL("http://www.yourdomain.com/app.php?id=" & ID(i))
- tempstr = Replace(tempstr, "<html><head></head><body>
- <table bgcolor=""#000000"" border=""0"" cellpadding=""0"" cellspacing=""1"" width=""450""><tbody><tr><td bgcolor=""#ffffff""><div align=""center"">院校名称</div></td><td bgcolor=""#ffffff""><div class=""STYLE3"" align=""center"">地址</div></td><td bgcolor=""#ffffff""><div align=""center"">邮编</div></td><td bgcolor=""#ffffff""><div align=""center"">联系电话</div></td><td bgcolor=""#ffffff""><div align=""center"">招办网址</div></td></tr><tr><td bgcolor=""#ffffff""><div align=""center"">", ID(i) & " ")
- tempstr = Replace(tempstr, "</div></td><td bgcolor=""#ffffff""><div align=""center"">", " ")
- tempstr = Replace(tempstr, "</div></td></tr></tbody></table></body></html>", vbCrLf)
- RichTextBox1.Text = RichTextBox1.Text + tempstr
- i = i + 1
- Loop
- Class_Terminate
- End Sub
复制代码 |
|