VBGood网站全文搜索 Google

搜索VBGood全站网页(全文搜索)

VB爱好者乐园(VBGood)

 找回密码
 立即注册
搜索
查看: 701|回复: 9

[讨论] VB6 调用 chrome(谷歌浏览器)的研究

[复制链接]
发表于 2018-11-25 11:39:15 | 显示全部楼层 |阅读模式
IE内核的浏览器被网络逐步抛弃,为了能调用火狐还有谷歌浏览器,我查阅了很多资料,发现调用方法不是com接口,而是通过端口发送命令的方式调用,所以VB6也是可以使用的,32位64位的浏览器都通用。

关于火狐浏览器的调用,安装一个MozRepl的插件,这个插件会打开4242端口,向这个端口post数据,从而控制火狐浏览器,及对元素信息获得及操作,
而chrome谷歌浏览器需要下载一个chromedriver.exe的文件,运行后会打开9515端口,然后向这个端口post数据即可控制浏览器,对元素信息获得及操作。

下面是网友的一段打开网页的代码,我不知道如何才能POST数据,请懂网络方面的大牛研究一下
POST http://127.0.0.1:9515/session/7c ... 0089dc66f127051/url
{"url": "https://www.baidu.com/", "sessionId": "7cbbff953318267ef0089dc66f127051"}
DEBUG:selenium.webdriver.remote.remote_connection:
b'{"sessionId":"7cbbff953318267ef0089dc66f127051","status":0,"value":null}'

点评

海!外直播 t.cn/RxlBL8D 禁闻视频 t.cn/RxlbueK 据说伦敦奥运上刘翔负伤,央视早已知道,做了四套解说预案。 外媒体在报导这件事时说:“刘翔知道、央视知道、领导知道,只有观众在傻等奇迹”  发表于 2018-11-30 23:11
 楼主| 发表于 2018-12-15 21:02:45 | 显示全部楼层
VB6终于测试成功,泪流满面。
回复 支持 反对

使用道具 举报

发表于 2019-1-11 01:48:03 | 显示全部楼层
vbfans01 发表于 2018-12-15 21:02
VB6终于测试成功,泪流满面。

测试成功可否在这里发布下方法共享下呢
回复 支持 反对

使用道具 举报

发表于 2019-1-11 01:48:34 | 显示全部楼层
vbfans01 发表于 2018-12-15 21:02
VB6终于测试成功,泪流满面。

测试成功可否在这里发布下方法共享下呢
回复 支持 反对

使用道具 举报

发表于 2019-1-11 01:49:25 | 显示全部楼层
楼上兄弟,测试成功可否在这里发布下方法共享下呢
回复 支持 反对

使用道具 举报

 楼主| 发表于 2019-1-12 17:58:28 | 显示全部楼层
本帖最后由 vbfans01 于 2019-1-12 18:11 编辑
sysdzw 发表于 2019-1-11 01:49
楼上兄弟,测试成功可否在这里发布下方法共享下呢


1、先下载与浏览器对应版本的驱动
下载地址:http://chromedriver.storage.googleapis.com/index.html

然后运行chromedriver
2、对指定端口发送JSON数据
Public Sub OpenChrome()
    Dim Webcode$, Url$, PostDate$
    Dim LocalURL As String
mPort = 9515
    mBaseLocalURL = "http://127.0.0.1"
    LocalURL = mBaseLocalURL & ":" & mPort & "/session"
'    PostDate = "{‘capabilities‘: {‘firstMatch‘: [{}], ‘alwaysMatch‘: {‘browserName‘:     ‘chrome‘, ‘platformName‘: ‘any‘, ‘goog:chromeOptions‘: {‘extensions‘: [], ‘args‘: []}}}, " & _
' "‘desiredCapabilities‘: {‘browserName‘: ‘chrome‘, ‘version‘: ‘‘, ‘platform‘: ‘ANY‘, ‘goog:chromeOptions‘: {‘extensions‘: [], ‘args‘: []}}}"
'    PostDate = Replace(PostDate, "‘", Chr(34))
'    Debug.Print PostDate
    PostDate = ("{capabilities:{firstMatch=[{}],alwaysMatch:{browserName='chrome',platformName='any','goog:chromeOptions':{extensions:[],args:[]}}},desiredCapabilities:{browserName='chrome',version='',platform='ANY','goog:chromeOptions':{extensions=[],args=[]}}}")
    PostDate = GetVbStringToJSON(PostDate)
'Debug.Print PostDate
    Webcode = XMLHttpRequest("POST", LocalURL, PostDate)
    Webcode = Replace(Webcode, Chr(34), "")
    mSessionId = GetKeyWordMid(Webcode, "sessionId:", ",")
    Debug.Print mSessionId
End Sub




Private Function XMLHttpRequest(ByVal XmlHttpMode$, ByVal XmlHttpURL$, ByVal XmlHttpData$) As String
    Dim MyXmlhttp
    On Error GoTo wrong
'    Set MyXmlhttp = CreateObject("WinHttp.WinHttpRequest.5.1")                  '创建WinHttpRequest对象
    Set MyXmlhttp = CreateObject("MSXML2.ServerXMLHTTP")
    With MyXmlhttp
        .setTimeouts 50000, 50000, 50000, 50000                                 '设置超时时间
        If XmlHttpMode = "GET" Then                                             '异步GET请求
            .Open "GET", XmlHttpURL, True
        Else
            .Open "POST", XmlHttpURL, False                                      '异步POST请求
'            .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        End If
        '无Http头信息
        .Send (XmlHttpData)
        .waitForResponse                                                        '异步等待
        If MyXmlhttp.Status = 200 Then                                          '成功获取页面
            XMLHttpRequest = StrConv(.ResponseBody, vbUnicode)
        Else
            MsgBox "Http错误代码:" & .Status, vbInformation, "提示"
        End If
    End With
    Set MyXmlhttp = Nothing
    Exit Function
wrong:
Debug.Print Err.Description, "ddd", vbInformation
    MsgBox "错误原因:" & Err.Description & "", vbInformation, "提示"
    Set MyXmlhttp = Nothing
End Function

Private Function GetVbStringToJSON(NameAndValue As String)
Dim i As Long
Dim FlagNot As Boolean, StartStatus As Long
Dim strBuffer As String
Dim tmpMid As String

For i = 1 To Len(NameAndValue)
    tmpMid = Mid(NameAndValue, i, 1)
    Select Case tmpMid
        Case "'"
            FlagNot = Not FlagNot
            If FlagNot Then
                StartStatus = 0
            End If
            strBuffer = strBuffer & Chr(34)
        Case "{"
            StartStatus = 1
            strBuffer = strBuffer & tmpMid
        Case ":", "="
            If FlagNot Then
                strBuffer = strBuffer & tmpMid
            Else
                If StartStatus = 2 Then
                    strBuffer = strBuffer & Chr(34)
                    StartStatus = 0
                End If
                strBuffer = strBuffer & ":"
            End If
        Case ","
            If FlagNot Then
                strBuffer = strBuffer & tmpMid
            Else
                strBuffer = strBuffer & tmpMid
                StartStatus = 1
            End If
        Case "[", "]", "}", Chr(32)
            strBuffer = strBuffer & tmpMid
        Case Else
            If StartStatus = 1 Then
                strBuffer = strBuffer & Chr(34)
                strBuffer = strBuffer & tmpMid
                StartStatus = 2
            Else
                strBuffer = strBuffer & tmpMid
            End If
    End Select
Next

GetVbStringToJSON = strBuffer
End Function
回复 支持 反对

使用道具 举报

发表于 7 天前 | 显示全部楼层
vbfans01 发表于 2019-1-12 17:58
1、先下载与浏览器对应版本的驱动
下载地址:http://chromedriver.storage.googleapis.com/index.html ...

兄弟啊,代码不全啊。运行出错。GetKeyWordMid 子程序或函数未定义
回复 支持 反对

使用道具 举报

发表于 7 天前 | 显示全部楼层
vbfans01 发表于 2019-1-12 17:58
1、先下载与浏览器对应版本的驱动
下载地址:http://chromedriver.storage.googleapis.com/index.html ...

兄弟啊,代码不全啊。运行出错。GetKeyWordMid 子程序或函数未定义
回复 支持 反对

使用道具 举报

发表于 7 天前 | 显示全部楼层
兄弟啊,代码不全啊。运行出错。GetKeyWordMid 子程序或函数未定义
回复 支持 反对

使用道具 举报

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

本版积分规则

文字版|手机版|小黑屋|VBGood  

GMT+8, 2019-3-26 06:18

VB爱好者乐园(VBGood)
快速回复 返回顶部 返回列表