|
|
楼主 |
发表于 2019-4-7 10:39
|
显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
在我发这个求助帖子之前，没有找到VBA调用chrome浏览器的例子，不过从网友“源理”的帖子《vba中使用Selenium 》http://club.excelhome.net/thread-1452021-6-1.html这个问题就已经解决了，也不知道如何结帖。
请帮忙结帖。
Selenium能够调用浏览器，是遵循了WebDriver的规范，如果想绕开Selenium，也是可以的。
如果要完整的完成一套动作，也就相当于自己写了类似于Selenium的驱动，这是个浩大的工程。
所以，想来想去，还是使用现成的。
下面自己写了一段测试代码，就是按WebDriver的规范，打开浏览器，访问百度的例子。
首先启动chromedriver.exe（会打开9515端口），然后运行下面代码
'打开百度
OpenChrome "http://www.baidu.com"
Private Sub OpenChrome(mBaseLocalURL as string)
Dim Webcode$, Url$, PostDate$
Dim LocalURL As String
mPort = 9515
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
Private Function GetKeyWordMid(InputStr, StrKey1 As String, StrKey2 As String, Optional Start As Long = 1) As String
'取两个关键字之间的内容
Dim nLen As Long
Dim nFind1 As Long
Dim nFind2 As Long
nLen = Len(InputStr)
nFind1 = InStr(Start, InputStr, StrKey1) '查找第一个关键字
nFind2 = InStr(nFind1 + 1, InputStr, StrKey2) '在找到的第一个关键字后一位开始找第二个关键字
If nFind1 > 0 And nFind2 - nFind1 > 1 Then '如果找到，而且第二个关键字位置大于第一个。
GetKeyWordMid = Mid(InputStr, nFind1 + Len(StrKey1), nFind2 - nFind1 - Len(StrKey1))
End If
End Function
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2018-12-15 13:19
