请选择 进入手机版 | 继续访问电脑版

玩酷之家

 找回密码
 立即注册
搜索
热搜: 活动 交友 discuz
查看: 1347|回复: 2

VB.NET获取网页源代码

[复制链接]

20

主题

24

帖子

328

积分

中级会员

Rank: 3Rank: 3

积分
328
发表于 2018-7-22 17:13:05 | 显示全部楼层 |阅读模式

VS2015测试通过

  1. Public Function LobDotCn(ByVal url_Link As String, ByVal IsGb2312 As Boolean)

  2.         On Error Resume Next
  3.         Dim XmlHttp As Object
  4.         XmlHttp = CreateObject("Microsoft.XMLHttp")
  5.         XmlHttp.Open("POST", url_Link, False)
  6.         XmlHttp.Send()
  7.         Dim WebContent As Object
  8.         Dim Str_WebContent As String
  9.         If IsGb2312 Then
  10.             WebContent = XmlHttp.ResponseBody
  11.             Str_WebContent = System.Text.Encoding.Default.GetString(WebContent)
  12.         Else
  13.             WebContent = XmlHttp.ResponseText
  14.             Str_WebContent = WebContent.ToString
  15.         End If
  16.         XmlHttp = Nothing
  17.         LobDotCn = Str_WebContent

  18.     End Function
复制代码


我用自己的独白,静候彼岸花的盛开...
回复

使用道具 举报

20

主题

24

帖子

328

积分

中级会员

Rank: 3Rank: 3

积分
328
 楼主| 发表于 2018-7-22 19:37:40 | 显示全部楼层
修正版

  1.     Function getHtmlStr(ByVal strURL As String, ByVal IsGb2312 As Boolean) '获取源码
  2.         On Error GoTo reStart
  3. reStart:

  4.         'My.Application.DoEvents()
  5.         Dim stime, ntime
  6.         Dim XmlHttp As Object
  7.         XmlHttp = CreateObject("Microsoft.XMLHTTP")
  8.         XmlHttp.open("GET", strURL, True)
  9.         XmlHttp.setRequestHeader("If-Modified-Since", "0")
  10.         XmlHttp.send
  11.         stime = Now '获取当前时间

  12.         While XmlHttp.readyState <> 4
  13.             My.Application.DoEvents()
  14.             ntime = Now '获取循环时间
  15.             If DateDiff("s", stime, ntime) > 15 Then getHtmlStr = "OutTime" : Exit Function '判断超出3秒即超时退出过程
  16.         End While

  17.         If XmlHttp.ResponseText.ToString = "" Then
  18.             getHtmlStr = "OutTime"
  19.         Else

  20.             If IsGb2312 Then
  21.                 Dim WebContent As Object
  22.                 WebContent = XmlHttp.ResponseBody
  23.                 getHtmlStr = System.Text.Encoding.Default.GetString(WebContent)
  24.             Else
  25.                 getHtmlStr = XmlHttp.ResponseText.ToString
  26.             End If

  27.         End If

  28.         XmlHttp = Nothing
  29.         'My.Application.DoEvents()

  30.     End Function
复制代码


我用自己的独白,静候彼岸花的盛开...
回复

使用道具 举报

3

主题

16

帖子

112

积分

注册会员

Rank: 2

积分
112
QQ
发表于 2019-2-19 21:30:41 | 显示全部楼层
本帖最后由 InkHin 于 2019-2-19 21:35 编辑

关于VB6获取网页源代码

创建标准EXE工程,为窗体添加一个按钮和一个文本框,文本框的属性MulitLine设置为True.    复制下面代码到Form1的窗体代码,运行,单击Command1即可看到效果。
'WinHttp Get 获得网页源码
    '   By: InkHin
    '   E-mail lqx@tyningling.Top
        '   Date : 2- 19
        '   Blog :  https://www.cnblogs.com/lingqingxue

'  WinHttp参考地址:https://blog.csdn.net/diguoguo/article/details/82587906
Private Sub Command1_Click()
Dim StrData As String
    StrData = GetStr("http://www.baidu.com")
    Me.Text1.Text = StrData
End Sub

Public Function GetStr(ByVal Strurl As String) As String
Dim XmlHttp As Object
    Set XmlHttp = CreateObject("WinHttp.WinHttpRequest.5.1")

    With XmlHttp
    .Open "GET", Strurl, False
    On Error GoTo Error
    .send

    GetStr = BytesToBstr(.ResponseBody, "UTF-8")
    End With

    Set XmlHttp = Nothing


Error:
End Function
Private Function BytesToBstr(ByVal StrBody, ByVal CodeBase) As String
Dim Obj As Object
    Set Obj = CreateObject("Adodb.Stream")

    With Obj
.Type = 1
.Mode = 3
.Open
.Write StrBody
.Position = 0
.Type = 2
.Charset = CodeBase
BytesToBstr = .ReadText
.Close
    End With

    Set Obj = Nothing
End Function






细嗅蔷薇。
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

Archiver|手机版|小黑屋|玩酷之家 ( 鄂ICP备14012049号-1 )|

GMT+8, 2019-4-24 20:23 , Processed in 0.182550 second(s), 20 queries .

Powered by Discuz! X3.4

© 2001-2017 Comsenz Inc.

快速回复 返回顶部 返回列表