TinySeleniumVBAでServiceNoｗの自動ログインを実装したい
TinySeleniumVBAでServiceNoｗの自動ログインがしたいです。
毎日ServiceNoｗの開発サイトからインスタンスを起こしいていましたが
TinySeleniumVBAを使用することで自動ログイン～インスタンス起動までを実装できると考えました。
しかし、以下の赤枠の「Sign In」ボタンの要素がどうしても取れません。。。
ボタンには名前「Sign In」が設定されています。
ClassName、CssSelector ID、Name、TagName、XPathのいずれでも要素が取れませんでした。。
仕方なしに手動でボタンをクリックしてから
ユーザーID、PWをマクロで入力させて次の画面に進みます。
するとまた次の画面の赤枠の「Start Building」ボタンの要素が取れない状態になります。
このボタンの名前は「Start Building」でした。
これら２つのボタンをクリックするために要素を取得したいと考えています。
どなたか解決できる方はおりますでしょうか。
発生している問題・エラー
出ているエラーメッセージを入力
{"error":"no such element","message":"no such element: Unable to locate element: {\"method\":\"css selector\",\"selector\":\"[name=\"Start Building\"]\"}\r\n (Session info: MicrosoftEdge=96.0.1054.62)","stacktrace":"Backtrace:\r\n\tMicrosoft::Applications::Events::ILogConfiguration::ILogConfiguration [0x00007FF77802CD12+56946]\r\n\tMicrosoft::Applications::Events::EventProperty::to_string [0x00007FF777C59DD7+947879]\r\n\tMicrosoft::Applications::Events::EventProperty::to_string [0x00007FF777C95B59+1193001]\r\n\tMicrosoft::Applications::Events::EventProperty::to_string [0x00007FF777CC849F+1400175]\r\n\tMicrosoft::Applications::Events::EventProperty::to_string [0x00007FF777CB0DBB+1304203]\r\n\tMicrosoft::Applications::Events::EventProperty::to_string [0x00007FF777CC559D+1388141]\r\n\tMicrosoft::Applications::Events::EventProperty::to_string [0x00007FF777CB0BFF+1303759]\r\n\tMicrosoft::Applications::Events::EventProperty::to_string [0x00007FF777C862E9+1129401]\r\n\tMicrosoft::Applications::Events::EventPropert
y::to_string [0x00007FF777C873CF+1133727]\r\n\tMicrosoft::Applications::Events::EventProperty::to_string [0x00007FF777D1BAB5+1741701]\r\n\tMicrosoft::Applications::Events::EventProperty::to_string [0x00007FF777D19F41+1734673]\r\n\tMicrosoft::Applications::Events::EventProperty::EventProperty [0x00007FF777EFACD9+2521]\r\n\tMicrosoft::Applications::Events::EventProperty::to_string [0x00007FF777CF18EE+1569214]\r\n\tMicrosoft::Applications::Events::ILogConfiguration::ILogConfiguration [0x00007FF77802591C+27260]\r\n\tMicrosoft::Applications::Events::ILogConfiguration::ILogConfiguration [0x00007FF778025294+25588]\r\n\tMicrosoft::Applications::Events::ILogConfiguration::ILogConfiguration [0x00007FF7780250E6+25158]\r\n\tMicrosoft::Applications::Events::EventProperties::GetName [0x00007FF777F7FA9C+211724]\r\n\tBaseThreadInitThunk [0x00007FFB1C267034+20]\r\n\tRtlUserThreadStart [0x00007FFB1D6A2651+33]\r\n"}
【該当するソースコード】
①標準モジュール【Example】
' TinySeleniumVBA
' A tiny Selenium wrapper written in pure VBA
'
' (c)2021 uezo
'
' Mail: uezo@uezo.net
' Twitter: @uezochan
' https://github.com/uezo/TinySeleniumVBA
'
' ==========================================================================
' セットアップ
'
' 1. ツール＞参照設定で`Microsoft Scripting Runtime`をオンにする
'
' 2. WebDriver.cls, WebElement.cls JsonConverter.bas をプロジェクトに追加
'
' 3. WebDriverをダウンロード（ブラウザのメジャーバージョンと同じもの）
' - Edge: https://developer.microsoft.com/ja-jp/microsoft-edge/tools/webdriver/
' - Chrome: https://chromedriver.chromium.org/downloads
'
' 使い方
' `WebDriver`のインスタンスをダウンロードしたWebDriverを使って生成します。
' そこから先は下のExampleを参照ください。
' ==========================================================================
' ==========================================================================
' ==========================================================================
' Example
' ==========================================================================
Option Explicit
Public Sub main()
' Start WebDriver (Edge)
Dim Driver As New WebDriver
’以下はwebdriverのパス
Driver.Edge "～～デスクトップ\VBA作業\edgedriver_win64\msedgedriver.exe"
Dim tmp_セッションID As String
tmp_セッションID = Driver.DefaultSessionId
Dim セッションID As String
セッションID = ThisWorkbook.Sheets(1).Range("A1")
Driver.DefaultSessionId = セッションID
If セッションID = "" Then
On Error Resume Next
' Open browser
Driver.OpenBrowser
If Err.Number <> 0 Then
Driver.DefaultSessionId = tmp_セッションID
Driver.OpenBrowser
End If
On Error GoTo 0
Else
On Error Resume Next
' ServiceNoｗ開発ページへ遷移
Driver.Navigate "https://developer.servicenow.com/dev.do"
If Err.Number <> 0 Then
Driver.DefaultSessionId = tmp_セッションID
Driver.OpenBrowser
' Navigate to Google
Driver.Navigate "https://developer.servicenow.com/dev.do"
End If
On Error GoTo 0
End If
'Driver.FindElement(By.Name, "Sign In").Click ’左記はうまくいかない箇所
Driver.FindElement(By.CssSelector, "#username").SetValue "ログイン時のメールアドレス"
Driver.FindElement(By.CssSelector, "#usernameSubmitButton").Click
Driver.FindElement(By.CssSelector, "#password").SetValue "ログイン時のパスワード"
Driver.FindElement(By.CssSelector, "#submitButton").Click
’Driver.FindElement(By.Name, "Start Building").Click ’左記はうまくいかない箇所
ThisWorkbook.Sheets(1).Range("A1") = Driver.DefaultSessionId
End Sub
標準モジュール【JsonConverter】
''
' VBA-JSON v2.3.1
' (c) Tim Hall - https://github.com/VBA-tools/VBA-JSON
'
' JSON Converter for VBA
'
' Errors:
' 10001 - JSON parse error
'
' @class JsonConverter
' @author tim.hall.engr@gmail.com
' @license MIT (http://www.opensource.org/licenses/mit-license.php)
'' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ '
'
' Based originally on vba-json (with extensive changes)
' BSD license included below
'
' JSONLib, http://code.google.com/p/vba-json/
'
' Copyright (c) 2013, Ryo Yokoyama
' All rights reserved.
'
' Redistribution and use in source and binary forms, with or without
' modification, are permitted provided that the following conditions are met:
' * Redistributions of source code must retain the above copyright
' notice, this list of conditions and the following disclaimer.
' * Redistributions in binary form must reproduce the above copyright
' notice, this list of conditions and the following disclaimer in the
' documentation and/or other materials provided with the distribution.
' * Neither the name of the <organization> nor the
' names of its contributors may be used to endorse or promote products
' derived from this software without specific prior written permission.
'
' THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
' ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
' WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
' DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT HOLDER> BE LIABLE FOR ANY
' DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
' (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
' LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
' ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
' (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
' SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ '
Option Explicit
' === VBA-UTC Headers
#If Mac Then
#If VBA7 Then
' 64-bit Mac (2016)
Private Declare PtrSafe Function utc_popen Lib "/usr/lib/libc.dylib" Alias "popen" _
(ByVal utc_Command As String, ByVal utc_Mode As String) As LongPtr
Private Declare PtrSafe Function utc_pclose Lib "/usr/lib/libc.dylib" Alias "pclose" _
(ByVal utc_File As LongPtr) As LongPtr
Private Declare PtrSafe Function utc_fread Lib "/usr/lib/libc.dylib" Alias "fread" _
(ByVal utc_Buffer As String, ByVal utc_Size As LongPtr, ByVal utc_Number As LongPtr, ByVal utc_File As LongPtr) As LongPtr
Private Declare PtrSafe Function utc_feof Lib "/usr/lib/libc.dylib" Alias "feof" _
(ByVal utc_File As LongPtr) As LongPtr
#Else
' 32-bit Mac
Private Declare Function utc_popen Lib "libc.dylib" Alias "popen" _
(ByVal utc_Command As String, ByVal utc_Mode As String) As Long
Private Declare Function utc_pclose Lib "libc.dylib" Alias "pclose" _
(ByVal utc_File As Long) As Long
Private Declare Function utc_fread Lib "libc.dylib" Alias "fread" _
(ByVal utc_Buffer As String, ByVal utc_Size As Long, ByVal utc_Number As Long, ByVal utc_File As Long) As Long
Private Declare Function utc_feof Lib "libc.dylib" Alias "feof" _
(ByVal utc_File As Long) As Long
#End If
#ElseIf VBA7 Then
' http://msdn.microsoft.com/en-us/library/windows/desktop/ms724421.aspx
' http://msdn.microsoft.com/en-us/library/windows/desktop/ms724949.aspx
' http://msdn.microsoft.com/en-us/library/windows/desktop/ms725485.aspx
Private Declare PtrSafe Function utc_GetTimeZoneInformation Lib "kernel32" Alias "GetTimeZoneInformation" _
(utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION) As Long
Private Declare PtrSafe Function utc_SystemTimeToTzSpecificLocalTime Lib "kernel32" Alias "SystemTimeToTzSpecificLocalTime" _
(utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION, utc_lpUniversalTime As utc_SYSTEMTIME, utc_lpLocalTime As utc_SYSTEMTIME) As Long
Private Declare PtrSafe Function utc_TzSpecificLocalTimeToSystemTime Lib "kernel32" Alias "TzSpecificLocalTimeToSystemTime" _
(utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION, utc_lpLocalTime As utc_SYSTEMTIME, utc_lpUniversalTime As utc_SYSTEMTIME) As Long
#Else
Private Declare Function utc_GetTimeZoneInformation Lib "kernel32" Alias "GetTimeZoneInformation" _
(utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION) As Long
Private Declare Function utc_SystemTimeToTzSpecificLocalTime Lib "kernel32" Alias "SystemTimeToTzSpecificLocalTime" _
(utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION, utc_lpUniversalTime As utc_SYSTEMTIME, utc_lpLocalTime As utc_SYSTEMTIME) As Long
Private Declare Function utc_TzSpecificLocalTimeToSystemTime Lib "kernel32" Alias "TzSpecificLocalTimeToSystemTime" _
(utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION, utc_lpLocalTime As utc_SYSTEMTIME, utc_lpUniversalTime As utc_SYSTEMTIME) As Long
#End If
#If Mac Then
#If VBA7 Then
Private Type utc_ShellResult
utc_Output As String
utc_ExitCode As LongPtr
End Type
#Else
Private Type utc_ShellResult
utc_Output As String
utc_ExitCode As Long
End Type
#End If
#Else
Private Type utc_SYSTEMTIME
utc_wYear As Integer
utc_wMonth As Integer
utc_wDayOfWeek As Integer
utc_wDay As Integer
utc_wHour As Integer
utc_wMinute As Integer
utc_wSecond As Integer
utc_wMilliseconds As Integer
End Type
Private Type utc_TIME_ZONE_INFORMATION
utc_Bias As Long
utc_StandardName(0 To 31) As Integer
utc_StandardDate As utc_SYSTEMTIME
utc_StandardBias As Long
utc_DaylightName(0 To 31) As Integer
utc_DaylightDate As utc_SYSTEMTIME
utc_DaylightBias As Long
End Type
#End If
' === End VBA-UTC
Private Type json_Options
' VBA only stores 15 significant digits, so any numbers larger than that are truncated
' This can lead to issues when BIGINT's are used (e.g. for Ids or Credit Cards), as they will be invalid above 15 digits
' See: http://support.microsoft.com/kb/269370
'
' By default, VBA-JSON will use String for numbers longer than 15 characters that contain only digits
' to override set `JsonConverter.JsonOptions.UseDoubleForLargeNumbers = True`
UseDoubleForLargeNumbers As Boolean
' The JSON standard requires object keys to be quoted (" or '), use this option to allow unquoted keys
AllowUnquotedKeys As Boolean
' The solidus (/) is not required to be escaped, use this option to escape them as \/ in ConvertToJson
EscapeSolidus As Boolean
End Type
Public JsonOptions As json_Options
' ============================================= '
' Public Methods
' ============================================= '
''
' Convert JSON string to object (Dictionary/Collection)
'
' @method ParseJson
' @param {String} json_String
' @return {Object} (Dictionary or Collection)
' @throws 10001 - JSON parse error
''
Public Function ParseJson(ByVal JsonString As String) As Object
Dim json_Index As Long
json_Index = 1
' Remove vbCr, vbLf, and vbTab from json_String
JsonString = VBA.Replace(VBA.Replace(VBA.Replace(JsonString, VBA.vbCr, ""), VBA.vbLf, ""), VBA.vbTab, "")
json_SkipSpaces JsonString, json_Index
Select Case VBA.Mid$(JsonString, json_Index, 1)
Case "{"
Set ParseJson = json_ParseObject(JsonString, json_Index)
Case "["
Set ParseJson = json_ParseArray(JsonString, json_Index)
Case Else
' Error: Invalid JSON string
Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(JsonString, json_Index, "Expecting '{' or '['")
End Select
End Function
''
' Convert object (Dictionary/Collection/Array) to JSON
'
' @method ConvertToJson
' @param {Variant} JsonValue (Dictionary, Collection, or Array)
' @param {Integer|String} Whitespace "Pretty" print json with given number of spaces per indentation (Integer) or given string
' @return {String}
''
Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitespace As Variant, Optional ByVal json_CurrentIndentation As Long = 0) As String
Dim json_Buffer As String
Dim json_BufferPosition As Long
Dim json_BufferLength As Long
Dim json_Index As Long
Dim json_LBound As Long
Dim json_UBound As Long
Dim json_IsFirstItem As Boolean
Dim json_Index2D As Long
Dim json_LBound2D As Long
Dim json_UBound2D As Long
Dim json_IsFirstItem2D As Boolean
Dim json_Key As Variant
Dim json_Value As Variant
Dim json_DateStr As String
Dim json_Converted As String
Dim json_SkipItem As Boolean
Dim json_PrettyPrint As Boolean
Dim json_Indentation As String
Dim json_InnerIndentation As String
json_LBound = -1
json_UBound = -1
json_IsFirstItem = True
json_LBound2D = -1
json_UBound2D = -1
json_IsFirstItem2D = True
json_PrettyPrint = Not IsMissing(Whitespace)
Select Case VBA.VarType(JsonValue)
Case VBA.vbNull
ConvertToJson = "null"
Case VBA.vbDate
' Date
json_DateStr = ConvertToIso(VBA.CDate(JsonValue))
ConvertToJson = """" & json_DateStr & """"
Case VBA.vbString
' String (or large number encoded as string)
If Not JsonOptions.UseDoubleForLargeNumbers And json_StringIsLargeNumber(JsonValue) Then
ConvertToJson = JsonValue
Else
ConvertToJson = """" & json_Encode(JsonValue) & """"
End If
Case VBA.vbBoolean
If JsonValue Then
ConvertToJson = "true"
Else
ConvertToJson = "false"
End If
Case VBA.vbArray To VBA.vbArray + VBA.vbByte
If json_PrettyPrint Then
If VBA.VarType(Whitespace) = VBA.vbString Then
json_Indentation = VBA.String$(json_CurrentIndentation + 1, Whitespace)
json_InnerIndentation = VBA.String$(json_CurrentIndentation + 2, Whitespace)
Else
json_Indentation = VBA.Space$((json_CurrentIndentation + 1) * Whitespace)
json_InnerIndentation = VBA.Space$((json_CurrentIndentation + 2) * Whitespace)
End If
End If
' Array
json_BufferAppend json_Buffer, "[", json_BufferPosition, json_BufferLength
On Error Resume Next
json_LBound = LBound(JsonValue, 1)
json_UBound = UBound(JsonValue, 1)
json_LBound2D = LBound(JsonValue, 2)
json_UBound2D = UBound(JsonValue, 2)
If json_LBound >= 0 And json_UBound >= 0 Then
For json_Index = json_LBound To json_UBound
If json_IsFirstItem Then
json_IsFirstItem = False
Else
' Append comma to previous line
json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength
End If
If json_LBound2D >= 0 And json_UBound2D >= 0 Then
' 2D Array
If json_PrettyPrint Then
json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength
End If
json_BufferAppend json_Buffer, json_Indentation & "[", json_BufferPosition, json_BufferLength
For json_Index2D = json_LBound2D To json_UBound2D
If json_IsFirstItem2D Then
json_IsFirstItem2D = False
Else
json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength
End If
json_Converted = ConvertToJson(JsonValue(json_Index, json_Index2D), Whitespace, json_CurrentIndentation + 2)
' For Arrays/Collections, undefined (Empty/Nothing) is treated as null
If json_Converted = "" Then
' (nest to only check if converted = "")
If json_IsUndefined(JsonValue(json_Index, json_Index2D)) Then
json_Converted = "null"
End If
End If
If json_PrettyPrint Then
json_Converted = vbNewLine & json_InnerIndentation & json_Converted
End If
json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength
Next json_Index2D
If json_PrettyPrint Then
json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength
End If
json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength
json_IsFirstItem2D = True
Else
' 1D Array
json_Converted = ConvertToJson(JsonValue(json_Index), Whitespace, json_CurrentIndentation + 1)
' For Arrays/Collections, undefined (Empty/Nothing) is treated as null
If json_Converted = "" Then
' (nest to only check if converted = "")
If json_IsUndefined(JsonValue(json_Index)) Then
json_Converted = "null"
End If
End If
If json_PrettyPrint Then
json_Converted = vbNewLine & json_Indentation & json_Converted
End If
json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength
End If
Next json_Index
End If
On Error GoTo 0
If json_PrettyPrint Then
json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength
If VBA.VarType(Whitespace) = VBA.vbString Then
json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace)
Else
json_Indentation = VBA.Space$(json_CurrentIndentation * Whitespace)
End If
End If
json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength
ConvertToJson = json_BufferToString(json_Buffer, json_BufferPosition)
' Dictionary or Collection
Case VBA.vbObject
If json_PrettyPrint Then
If VBA.VarType(Whitespace) = VBA.vbString Then
json_Indentation = VBA.String$(json_CurrentIndentation + 1, Whitespace)
Else
json_Indentation = VBA.Space$((json_CurrentIndentation + 1) * Whitespace)
End If
End If
' Dictionary
If VBA.TypeName(JsonValue) = "Dictionary" Then
json_BufferAppend json_Buffer, "{", json_BufferPosition, json_BufferLength
For Each json_Key In JsonValue.Keys
' For Objects, undefined (Empty/Nothing) is not added to object
json_Converted = ConvertToJson(JsonValue(json_Key), Whitespace, json_CurrentIndentation + 1)
If json_Converted = "" Then
json_SkipItem = json_IsUndefined(JsonValue(json_Key))
Else
json_SkipItem = False
End If
If Not json_SkipItem Then
If json_IsFirstItem Then
json_IsFirstItem = False
Else
json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength
End If
If json_PrettyPrint Then
json_Converted = vbNewLine & json_Indentation & """" & json_Key & """: " & json_Converted
Else
json_Converted = """" & json_Key & """:" & json_Converted
End If
json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength
End If
Next json_Key
If json_PrettyPrint Then
json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength
If VBA.VarType(Whitespace) = VBA.vbString Then
json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace)
Else
json_Indentation = VBA.Space$(json_CurrentIndentation * Whitespace)
End If
End If
json_BufferAppend json_Buffer, json_Indentation & "}", json_BufferPosition, json_BufferLength
' Collection
ElseIf VBA.TypeName(JsonValue) = "Collection" Then
json_BufferAppend json_Buffer, "[", json_BufferPosition, json_BufferLength
For Each json_Value In JsonValue
If json_IsFirstItem Then
json_IsFirstItem = False
Else
json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength
End If
json_Converted = ConvertToJson(json_Value, Whitespace, json_CurrentIndentation + 1)
' For Arrays/Collections, undefined (Empty/Nothing) is treated as null
If json_Converted = "" Then
' (nest to only check if converted = "")
If json_IsUndefined(json_Value) Then
json_Converted = "null"
End If
End If
If json_PrettyPrint Then
json_Converted = vbNewLine & json_Indentation & json_Converted
End If
json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength
Next json_Value
If json_PrettyPrint Then
json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength
If VBA.VarType(Whitespace) = VBA.vbString Then
json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace)
Else
json_Indentation = VBA.Space$(json_CurrentIndentation * Whitespace)
End If
End If
json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength
End If
ConvertToJson = json_BufferToString(json_Buffer, json_BufferPosition)
Case VBA.vbInteger, VBA.vbLong, VBA.vbSingle, VBA.vbDouble, VBA.vbCurrency, VBA.vbDecimal
' Number (use decimals for numbers)
ConvertToJson = VBA.Replace(JsonValue, ",", ".")
Case Else
' vbEmpty, vbError, vbDataObject, vbByte, vbUserDefinedType
' Use VBA's built-in to-string
On Error Resume Next
ConvertToJson = JsonValue
On Error GoTo 0
End Select
End Function
' ============================================= '
' Private Functions
' ============================================= '
Private Function json_ParseObject(json_String As String, ByRef json_Index As Long) As Dictionary
Dim json_Key As String
Dim json_NextChar As String
Set json_ParseObject = New Dictionary
json_SkipSpaces json_String, json_Index
If VBA.Mid$(json_String, json_Index, 1) <> "{" Then
Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting '{'")
Else
json_Index = json_Index + 1
Do
json_SkipSpaces json_String, json_Index
If VBA.Mid$(json_String, json_Index, 1) = "}" Then
json_Index = json_Index + 1
Exit Function
ElseIf VBA.Mid$(json_String, json_Index, 1) = "," Then
json_Index = json_Index + 1
json_SkipSpaces json_String, json_Index
End If
json_Key = json_ParseKey(json_String, json_Index)
json_NextChar = json_Peek(json_String, json_Index)
If json_NextChar = "[" Or json_NextChar = "{" Then
Set json_ParseObject.Item(json_Key) = json_ParseValue(json_String, json_Index)
Else
json_ParseObject.Item(json_Key) = json_ParseValue(json_String, json_Index)
End If
Loop
End If
End Function
Private Function json_ParseArray(json_String As String, ByRef json_Index As Long) As Collection
Set json_ParseArray = New Collection
json_SkipSpaces json_String, json_Index
If VBA.Mid$(json_String, json_Index, 1) <> "[" Then
Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting '['")
Else
json_Index = json_Index + 1
Do
json_SkipSpaces json_String, json_Index
If VBA.Mid$(json_String, json_Index, 1) = "]" Then
json_Index = json_Index + 1
Exit Function
ElseIf VBA.Mid$(json_String, json_Index, 1) = "," Then
json_Index = json_Index + 1
json_SkipSpaces json_String, json_Index
End If
json_ParseArray.Add json_ParseValue(json_String, json_Index)
Loop
End If
End Function
Private Function json_ParseValue(json_String As String, ByRef json_Index As Long) As Variant
json_SkipSpaces json_String, json_Index
Select Case VBA.Mid$(json_String, json_Index, 1)
Case "{"
Set json_ParseValue = json_ParseObject(json_String, json_Index)
Case "["
Set json_ParseValue = json_ParseArray(json_String, json_Index)
Case """", "'"
json_ParseValue = json_ParseString(json_String, json_Index)
Case Else
If VBA.Mid$(json_String, json_Index, 4) = "true" Then
json_ParseValue = True
json_Index = json_Index + 4
ElseIf VBA.Mid$(json_String, json_Index, 5) = "false" Then
json_ParseValue = False
json_Index = json_Index + 5
ElseIf VBA.Mid$(json_String, json_Index, 4) = "null" Then
json_ParseValue = Null
json_Index = json_Index + 4
ElseIf VBA.InStr("+-0123456789", VBA.Mid$(json_String, json_Index, 1)) Then
json_ParseValue = json_ParseNumber(json_String, json_Index)
Else
Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting 'STRING', 'NUMBER', null, true, false, '{', or '['")
End If
End Select
End Function
Private Function json_ParseString(json_String As String, ByRef json_Index As Long) As String
Dim json_Quote As String
Dim json_Char As String
Dim json_Code As String
Dim json_Buffer As String
Dim json_BufferPosition As Long
Dim json_BufferLength As Long
json_SkipSpaces json_String, json_Index
' Store opening quote to look for matching closing quote
json_Quote = VBA.Mid$(json_String, json_Index, 1)
json_Index = json_Index + 1
Do While json_Index > 0 And json_Index <= Len(json_String)
json_Char = VBA.Mid$(json_String, json_Index, 1)
Select Case json_Char
Case "\"
' Escaped string, \\, or \/
json_Index = json_Index + 1
json_Char = VBA.Mid$(json_String, json_Index, 1)
Select Case json_Char
Case """", "\", "/", "'"
json_BufferAppend json_Buffer, json_Char, json_BufferPosition, json_BufferLength
json_Index = json_Index + 1
Case "b"
json_BufferAppend json_Buffer, vbBack, json_BufferPosition, json_BufferLength
json_Index = json_Index + 1
Case "f"
json_BufferAppend json_Buffer, vbFormFeed, json_BufferPosition, json_BufferLength
json_Index = json_Index + 1
Case "n"
json_BufferAppend json_Buffer, vbCrLf, json_BufferPosition, json_BufferLength
json_Index = json_Index + 1
Case "r"
json_BufferAppend json_Buffer, vbCr, json_BufferPosition, json_BufferLength
json_Index = json_Index + 1
Case "t"
json_BufferAppend json_Buffer, vbTab, json_BufferPosition, json_BufferLength
json_Index = json_Index + 1
Case "u"
' Unicode character escape (e.g. \u00a9 = Copyright)
json_Index = json_Index + 1
json_Code = VBA.Mid$(json_String, json_Index, 4)
json_BufferAppend json_Buffer, VBA.ChrW(VBA.Val("&h" + json_Code)), json_BufferPosition, json_BufferLength
json_Index = json_Index + 4
End Select
Case json_Quote
json_ParseString = json_BufferToString(json_Buffer, json_BufferPosition)
json_Index = json_Index + 1
Exit Function
Case Else
json_BufferAppend json_Buffer, json_Char, json_BufferPosition, json_BufferLength
json_Index = json_Index + 1
End Select
Loop
End Function
Private Function json_ParseNumber(json_String As String, ByRef json_Index As Long) As Variant
Dim json_Char As String
Dim json_Value As String
Dim json_IsLargeNumber As Boolean
json_SkipSpaces json_String, json_Index
Do While json_Index > 0 And json_Index <= Len(json_String)
json_Char = VBA.Mid$(json_String, json_Index, 1)
If VBA.InStr("+-0123456789.eE", json_Char) Then
' Unlikely to have massive number, so use simple append rather than buffer here
json_Value = json_Value & json_Char
json_Index = json_Index + 1
Else
' Excel only stores 15 significant digits, so any numbers larger than that are truncated
' This can lead to issues when BIGINT's are used (e.g. for Ids or Credit Cards), as they will be invalid above 15 digits
' See: http://support.microsoft.com/kb/269370
'
' Fix: Parse -> String, Convert -> String longer than 15/16 characters containing only numbers and decimal points -> Number
' (decimal doesn't factor into significant digit count, so if present check for 15 digits + decimal = 16)
json_IsLargeNumber = IIf(InStr(json_Value, "."), Len(json_Value) >= 17, Len(json_Value) >= 16)
If Not JsonOptions.UseDoubleForLargeNumbers And json_IsLargeNumber Then
json_ParseNumber = json_Value
Else
' VBA.Val does not use regional settings, so guard for comma is not needed
json_ParseNumber = VBA.Val(json_Value)
End If
Exit Function
End If
Loop
End Function
Private Function json_ParseKey(json_String As String, ByRef json_Index As Long) As String
' Parse key with single or double quotes
If VBA.Mid$(json_String, json_Index, 1) = """" Or VBA.Mid$(json_String, json_Index, 1) = "'" Then
json_ParseKey = json_ParseString(json_String, json_Index)
ElseIf JsonOptions.AllowUnquotedKeys Then
Dim json_Char As String
Do While json_Index > 0 And json_Index <= Len(json_String)
json_Char = VBA.Mid$(json_String, json_Index, 1)
If (json_Char <> " ") And (json_Char <> ":") Then
json_ParseKey = json_ParseKey & json_Char
json_Index = json_Index + 1
Else
Exit Do
End If
Loop
Else
Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting '""' or '''")
End If
' Check for colon and skip if present or throw if not present
json_SkipSpaces json_String, json_Index
If VBA.Mid$(json_String, json_Index, 1) <> ":" Then
Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting ':'")
Else
json_Index = json_Index + 1
End If
End Function
Private Function json_IsUndefined(ByVal json_Value As Variant) As Boolean
' Empty / Nothing -> undefined
Select Case VBA.VarType(json_Value)
Case VBA.vbEmpty
json_IsUndefined = True
Case VBA.vbObject
Select Case VBA.TypeName(json_Value)
Case "Empty", "Nothing"
json_IsUndefined = True
End Select
End Select
End Function
Private Function json_Encode(ByVal json_Text As Variant) As String
' Reference: http://www.ietf.org/rfc/rfc4627.txt
' Escape: ", \, /, backspace, form feed, line feed, carriage return, tab
Dim json_Index As Long
Dim json_Char As String
Dim json_AscCode As Long
Dim json_Buffer As String
Dim json_BufferPosition As Long
Dim json_BufferLength As Long
For json_Index = 1 To VBA.Len(json_Text)
json_Char = VBA.Mid$(json_Text, json_Index, 1)
json_AscCode = VBA.AscW(json_Char)
' When AscW returns a negative number, it returns the twos complement form of that number.
' To convert the twos complement notation into normal binary notation, add 0xFFF to the return result.
' https://support.microsoft.com/en-us/kb/272138
If json_AscCode < 0 Then
json_AscCode = json_AscCode + 65536
End If
' From spec, ", \, and control characters must be escaped (solidus is optional)
Select Case json_AscCode
Case 34
' " -> 34 -> \"
json_Char = "\"""
Case 92
' \ -> 92 -> \\
json_Char = "\\"
Case 47
' / -> 47 -> \/ (optional)
If JsonOptions.EscapeSolidus Then
json_Char = "\/"
End If
Case 8
' backspace -> 8 -> \b
json_Char = "\b"
Case 12
' form feed -> 12 -> \f
json_Char = "\f"
Case 10
' line feed -> 10 -> \n
json_Char = "\n"
Case 13
' carriage return -> 13 -> \r
json_Char = "\r"
Case 9
' tab -> 9 -> \t
json_Char = "\t"
Case 0 To 31, 127 To 65535
' Non-ascii characters -> convert to 4-digit hex
json_Char = "\u" & VBA.Right$("0000" & VBA.Hex$(json_AscCode), 4)
End Select
json_BufferAppend json_Buffer, json_Char, json_BufferPosition, json_BufferLength
Next json_Index
json_Encode = json_BufferToString(json_Buffer, json_BufferPosition)
End Function
Private Function json_Peek(json_String As String, ByVal json_Index As Long, Optional json_NumberOfCharacters As Long = 1) As String
' "Peek" at the next number of characters without incrementing json_Index (ByVal instead of ByRef)
json_SkipSpaces json_String, json_Index
json_Peek = VBA.Mid$(json_String, json_Index, json_NumberOfCharacters)
End Function
Private Sub json_SkipSpaces(json_String As String, ByRef json_Index As Long)
' Increment index to skip over spaces
Do While json_Index > 0 And json_Index <= VBA.Len(json_String) And VBA.Mid$(json_String, json_Index, 1) = " "
json_Index = json_Index + 1
Loop
End Sub
Private Function json_StringIsLargeNumber(json_String As Variant) As Boolean
' Check if the given string is considered a "large number"
' (See json_ParseNumber)
Dim json_Length As Long
Dim json_CharIndex As Long
json_Length = VBA.Len(json_String)
' Length with be at least 16 characters and assume will be less than 100 characters
If json_Length >= 16 And json_Length <= 100 Then
Dim json_CharCode As String
json_StringIsLargeNumber = True
For json_CharIndex = 1 To json_Length
json_CharCode = VBA.Asc(VBA.Mid$(json_String, json_CharIndex, 1))
Select Case json_CharCode
' Look for .|0-9|E|e
Case 46, 48 To 57, 69, 101
' Continue through characters
Case Else
json_StringIsLargeNumber = False
Exit Function
End Select
Next json_CharIndex
End If
End Function
Private Function json_ParseErrorMessage(json_String As String, ByRef json_Index As Long, ErrorMessage As String)
' Provide detailed parse error message, including details of where and what occurred
'
' Example:
' Error parsing JSON:
' {"abcde":True}
' ^
' Expecting 'STRING', 'NUMBER', null, true, false, '{', or '['
Dim json_StartIndex As Long
Dim json_StopIndex As Long
' Include 10 characters before and after error (if possible)
json_StartIndex = json_Index - 10
json_StopIndex = json_Index + 10
If json_StartIndex <= 0 Then
json_StartIndex = 1
End If
If json_StopIndex > VBA.Len(json_String) Then
json_StopIndex = VBA.Len(json_String)
End If
json_ParseErrorMessage = "Error parsing JSON:" & VBA.vbNewLine & _
VBA.Mid$(json_String, json_StartIndex, json_StopIndex - json_StartIndex + 1) & VBA.vbNewLine & _
VBA.Space$(json_Index - json_StartIndex) & "^" & VBA.vbNewLine & _
ErrorMessage
End Function
Private Sub json_BufferAppend(ByRef json_Buffer As String, _
ByRef json_Append As Variant, _
ByRef json_BufferPosition As Long, _
ByRef json_BufferLength As Long)
' VBA can be slow to append strings due to allocating a new string for each append
' Instead of using the traditional append, allocate a large empty string and then copy string at append position
'
' Example:
' Buffer: "abc "
' Append: "def"
' Buffer Position: 3
' Buffer Length: 5
'
' Buffer position + Append length > Buffer length -> Append chunk of blank space to buffer
' Buffer: "abc "
' Buffer Length: 10
'
' Put "def" into buffer at position 3 (0-based)
' Buffer: "abcdef "
'
' Approach based on cStringBuilder from vbAccelerator
' http://www.vbaccelerator.com/home/VB/Code/Techniques/RunTime_Debug_Tracing/VB6_Tracer_Utility_zip_cStringBuilder_cls.asp
'
' and clsStringAppend from Philip Swannell
' https://github.com/VBA-tools/VBA-JSON/pull/82
Dim json_AppendLength As Long
Dim json_LengthPlusPosition As Long
json_AppendLength = VBA.Len(json_Append)
json_LengthPlusPosition = json_AppendLength + json_BufferPosition
If json_LengthPlusPosition > json_BufferLength Then
' Appending would overflow buffer, add chunk
' (double buffer length or append length, whichever is bigger)
Dim json_AddedLength As Long
json_AddedLength = IIf(json_AppendLength > json_BufferLength, json_AppendLength, json_BufferLength)
json_Buffer = json_Buffer & VBA.Space$(json_AddedLength)
json_BufferLength = json_BufferLength + json_AddedLength
End If
' Note: Namespacing with VBA.Mid$ doesn't work properly here, throwing compile error:
' Function call on left-hand side of assignment must return Variant or Object
Mid$(json_Buffer, json_BufferPosition + 1, json_AppendLength) = CStr(json_Append)
json_BufferPosition = json_BufferPosition + json_AppendLength
End Sub
Private Function json_BufferToString(ByRef json_Buffer As String, ByVal json_BufferPosition As Long) As String
If json_BufferPosition > 0 Then
json_BufferToString = VBA.Left$(json_Buffer, json_BufferPosition)
End If
End Function
''
' VBA-UTC v1.0.6
' (c) Tim Hall - https://github.com/VBA-tools/VBA-UtcConverter
'
' UTC/ISO 8601 Converter for VBA
'
' Errors:
' 10011 - UTC parsing error
' 10012 - UTC conversion error
' 10013 - ISO 8601 parsing error
' 10014 - ISO 8601 conversion error
'
' @module UtcConverter
' @author tim.hall.engr@gmail.com
' @license MIT (http://www.opensource.org/licenses/mit-license.php)
'' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ '
' (Declarations moved to top)
' ============================================= '
' Public Methods
' ============================================= '
''
' Parse UTC date to local date
'
' @method ParseUtc
' @param {Date} UtcDate
' @return {Date} Local date
' @throws 10011 - UTC parsing error
''
Public Function ParseUtc(utc_UtcDate As Date) As Date
On Error GoTo utc_ErrorHandling
#If Mac Then
ParseUtc = utc_ConvertDate(utc_UtcDate)
#Else
Dim utc_TimeZoneInfo As utc_TIME_ZONE_INFORMATION
Dim utc_LocalDate As utc_SYSTEMTIME
utc_GetTimeZoneInformation utc_TimeZoneInfo
utc_SystemTimeToTzSpecificLocalTime utc_TimeZoneInfo, utc_DateToSystemTime(utc_UtcDate), utc_LocalDate
ParseUtc = utc_SystemTimeToDate(utc_LocalDate)
#End If
Exit Function
utc_ErrorHandling:
Err.Raise 10011, "UtcConverter.ParseUtc", "UTC parsing error: " & Err.Number & " - " & Err.Description
End Function
''
' Convert local date to UTC date
'
' @method ConvertToUrc
' @param {Date} utc_LocalDate
' @return {Date} UTC date
' @throws 10012 - UTC conversion error
''
Public Function ConvertToUtc(utc_LocalDate As Date) As Date
On Error GoTo utc_ErrorHandling
#If Mac Then
ConvertToUtc = utc_ConvertDate(utc_LocalDate, utc_ConvertToUtc:=True)
#Else
Dim utc_TimeZoneInfo As utc_TIME_ZONE_INFORMATION
Dim utc_UtcDate As utc_SYSTEMTIME
utc_GetTimeZoneInformation utc_TimeZoneInfo
utc_TzSpecificLocalTimeToSystemTime utc_TimeZoneInfo, utc_DateToSystemTime(utc_LocalDate), utc_UtcDate
ConvertToUtc = utc_SystemTimeToDate(utc_UtcDate)
#End If
Exit Function
utc_ErrorHandling:
Err.Raise 10012, "UtcConverter.ConvertToUtc", "UTC conversion error: " & Err.Number & " - " & Err.Description
End Function
''
' Parse ISO 8601 date string to local date
'
' @method ParseIso
' @param {Date} utc_IsoString
' @return {Date} Local date
' @throws 10013 - ISO 8601 parsing error
''
Public Function ParseIso(utc_IsoString As String) As Date
On Error GoTo utc_ErrorHandling
Dim utc_Parts() As String
Dim utc_DateParts() As String
Dim utc_TimeParts() As String
Dim utc_OffsetIndex As Long
Dim utc_HasOffset As Boolean
Dim utc_NegativeOffset As Boolean
Dim utc_OffsetParts() As String
Dim utc_Offset As Date
utc_Parts = VBA.Split(utc_IsoString, "T")
utc_DateParts = VBA.Split(utc_Parts(0), "-")
ParseIso = VBA.DateSerial(VBA.CInt(utc_DateParts(0)), VBA.CInt(utc_DateParts(1)), VBA.CInt(utc_DateParts(2)))
If UBound(utc_Parts) > 0 Then
If VBA.InStr(utc_Parts(1), "Z") Then
utc_TimeParts = VBA.Split(VBA.Replace(utc_Parts(1), "Z", ""), ":")
Else
utc_OffsetIndex = VBA.InStr(1, utc_Parts(1), "+")
If utc_OffsetIndex = 0 Then
utc_NegativeOffset = True
utc_OffsetIndex = VBA.InStr(1, utc_Parts(1), "-")
End If
If utc_OffsetIndex > 0 Then
utc_HasOffset = True
utc_TimeParts = VBA.Split(VBA.Left$(utc_Parts(1), utc_OffsetIndex - 1), ":")
utc_OffsetParts = VBA.Split(VBA.Right$(utc_Parts(1), Len(utc_Parts(1)) - utc_OffsetIndex), ":")
Select Case UBound(utc_OffsetParts)
Case 0
utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), 0, 0)
Case 1
utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), VBA.CInt(utc_OffsetParts(1)), 0)
Case 2
' VBA.Val does not use regional settings, use for seconds to avoid decimal/comma issues
utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), VBA.CInt(utc_OffsetParts(1)), Int(VBA.Val(utc_OffsetParts(2))))
End Select
If utc_NegativeOffset Then: utc_Offset = -utc_Offset
Else
utc_TimeParts = VBA.Split(utc_Parts(1), ":")
End If
End If
Select Case UBound(utc_TimeParts)
Case 0
ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), 0, 0)
Case 1
ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), VBA.CInt(utc_TimeParts(1)), 0)
Case 2
' VBA.Val does not use regional settings, use for seconds to avoid decimal/comma issues
ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), VBA.CInt(utc_TimeParts(1)), Int(VBA.Val(utc_TimeParts(2))))
End Select
ParseIso = ParseUtc(ParseIso)
If utc_HasOffset Then
ParseIso = ParseIso - utc_Offset
End If
End If
Exit Function
utc_ErrorHandling:
Err.Raise 10013, "UtcConverter.ParseIso", "ISO 8601 parsing error for " & utc_IsoString & ": " & Err.Number & " - " & Err.Description
End Function
''
' Convert local date to ISO 8601 string
'
' @method ConvertToIso
' @param {Date} utc_LocalDate
' @return {Date} ISO 8601 string
' @throws 10014 - ISO 8601 conversion error
''
Public Function ConvertToIso(utc_LocalDate As Date) As String
On Error GoTo utc_ErrorHandling
ConvertToIso = VBA.Format$(ConvertToUtc(utc_LocalDate), "yyyy-mm-ddTHH:mm:ss.000Z")
Exit Function
utc_ErrorHandling:
Err.Raise 10014, "UtcConverter.ConvertToIso", "ISO 8601 conversion error: " & Err.Number & " - " & Err.Description
End Function
' ============================================= '
' Private Functions
' ============================================= '
#If Mac Then
Private Function utc_ConvertDate(utc_Value As Date, Optional utc_ConvertToUtc As Boolean = False) As Date
Dim utc_ShellCommand As String
Dim utc_Result As utc_ShellResult
Dim utc_Parts() As String
Dim utc_DateParts() As String
Dim utc_TimeParts() As String
If utc_ConvertToUtc Then
utc_ShellCommand = "date -ur `date -jf '%Y-%m-%d %H:%M:%S' " & _
"'" & VBA.Format$(utc_Value, "yyyy-mm-dd HH:mm:ss") & "' " & _
" +'%s'` +'%Y-%m-%d %H:%M:%S'"
Else
utc_ShellCommand = "date -jf '%Y-%m-%d %H:%M:%S %z' " & _
"'" & VBA.Format$(utc_Value, "yyyy-mm-dd HH:mm:ss") & " +0000' " & _
"+'%Y-%m-%d %H:%M:%S'"
End If
utc_Result = utc_ExecuteInShell(utc_ShellCommand)
If utc_Result.utc_Output = "" Then
Err.Raise 10015, "UtcConverter.utc_ConvertDate", "'date' command failed"
Else
utc_Parts = Split(utc_Result.utc_Output, " ")
utc_DateParts = Split(utc_Parts(0), "-")
utc_TimeParts = Split(utc_Parts(1), ":")
utc_ConvertDate = DateSerial(utc_DateParts(0), utc_DateParts(1), utc_DateParts(2)) + _
TimeSerial(utc_TimeParts(0), utc_TimeParts(1), utc_TimeParts(2))
End If
End Function
Private Function utc_ExecuteInShell(utc_ShellCommand As String) As utc_ShellResult
#If VBA7 Then
Dim utc_File As LongPtr
Dim utc_Read As LongPtr
#Else
Dim utc_File As Long
Dim utc_Read As Long
#End If
Dim utc_Chunk As String
On Error GoTo utc_ErrorHandling
utc_File = utc_popen(utc_ShellCommand, "r")
If utc_File = 0 Then: Exit Function
Do While utc_feof(utc_File) = 0
utc_Chunk = VBA.Space$(50)
utc_Read = CLng(utc_fread(utc_Chunk, 1, Len(utc_Chunk) - 1, utc_File))
If utc_Read > 0 Then
utc_Chunk = VBA.Left$(utc_Chunk, CLng(utc_Read))
utc_ExecuteInShell.utc_Output = utc_ExecuteInShell.utc_Output & utc_Chunk
End If
Loop
utc_ErrorHandling:
utc_ExecuteInShell.utc_ExitCode = CLng(utc_pclose(utc_File))
End Function
#Else
Private Function utc_DateToSystemTime(utc_Value As Date) As utc_SYSTEMTIME
utc_DateToSystemTime.utc_wYear = VBA.Year(utc_Value)
utc_DateToSystemTime.utc_wMonth = VBA.Month(utc_Value)
utc_DateToSystemTime.utc_wDay = VBA.Day(utc_Value)
utc_DateToSystemTime.utc_wHour = VBA.Hour(utc_Value)
utc_DateToSystemTime.utc_wMinute = VBA.Minute(utc_Value)
utc_DateToSystemTime.utc_wSecond = VBA.Second(utc_Value)
utc_DateToSystemTime.utc_wMilliseconds = 0
End Function
Private Function utc_SystemTimeToDate(utc_Value As utc_SYSTEMTIME) As Date
utc_SystemTimeToDate = DateSerial(utc_Value.utc_wYear, utc_Value.utc_wMonth, utc_Value.utc_wDay) + _
TimeSerial(utc_Value.utc_wHour, utc_Value.utc_wMinute, utc_Value.utc_wSecond)
End Function
#End If
③クラスモジュール【WebDriver】
'VERSION 1.0 CLASS
'BEGIN
' MultiUse = -1 'True
'End
' TinySeleniumVBA v0.1.0
' A tiny Selenium wrapper written in pure VBA
'
' (c)2021 uezo
'
' Mail: uezo@uezo.net
' Twitter: @uezochan
' https://github.com/uezo/TinySeleniumVBA
'
' ==========================================================================
' MIT License
'
' Copyright (c) 2021 uezo
'
' Permission is hereby granted, free of charge, to any person obtaining a copy
' of this software and associated documentation files (the "Software"), to deal
' in the Software without restriction, including without limitation the rights
' to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
' copies of the Software, and to permit persons to whom the Software is
' furnished to do so, subject to the following conditions:
'
' The above copyright notice and this permission notice shall be included in all
' copies or substantial portions of the Software.
'
' THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
' IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
' FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
' AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
' LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
' OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
' SOFTWARE.
' ==========================================================================
Option Explicit
Public DefaultSessionId As String
Public UrlBase As String
' Driver commands
Public CMD_STATUS
Public CMD_NEW_SESSION
Public CMD_GET_ALL_SESSIONS
Public CMD_QUIT
Public CMD_GET_CURRENT_WINDOW_HANDLE
Public CMD_W3C_GET_CURRENT_WINDOW_HANDLE
Public CMD_GET_WINDOW_HANDLES
Public CMD_W3C_GET_WINDOW_HANDLES
Public CMD_GET
Public CMD_GO_FORWARD
Public CMD_GO_BACK
Public CMD_REFRESH
Public CMD_EXECUTE_SCRIPT
Public CMD_W3C_EXECUTE_SCRIPT
Public CMD_W3C_EXECUTE_SCRIPT_ASYNC
Public CMD_GET_CURRENT_URL
Public CMD_GET_TITLE
Public CMD_GET_PAGE_SOURCE
Public CMD_SCREENSHOT
Public CMD_ELEMENT_SCREENSHOT
Public CMD_FIND_ELEMENT
Public CMD_FIND_ELEMENTS
Public CMD_W3C_GET_ACTIVE_ELEMENT
Public CMD_GET_ACTIVE_ELEMENT
Public CMD_FIND_CHILD_ELEMENT
Public CMD_FIND_CHILD_ELEMENTS
Public CMD_CLICK_ELEMENT
Public CMD_CLEAR_ELEMENT
Public CMD_SUBMIT_ELEMENT
Public CMD_GET_ELEMENT_TEXT
Public CMD_SEND_KEYS_TO_ELEMENT
Public CMD_SEND_KEYS_TO_ACTIVE_ELEMENT
Public CMD_UPLOAD_FILE
Public CMD_GET_ELEMENT_VALUE
Public CMD_GET_ELEMENT_TAG_NAME
Public CMD_IS_ELEMENT_SELECTED
Public CMD_SET_ELEMENT_SELECTED
Public CMD_IS_ELEMENT_ENABLED
Public CMD_IS_ELEMENT_DISPLAYED
Public CMD_GET_ELEMENT_LOCATION
Public CMD_GET_ELEMENT_LOCATION_ONCE_SCROLLED_INTO_VIEW
Public CMD_GET_ELEMENT_SIZE
Public CMD_GET_ELEMENT_RECT
Public CMD_GET_ELEMENT_ATTRIBUTE
Public CMD_GET_ELEMENT_PROPERTY
Public CMD_GET_ALL_COOKIES
Public CMD_ADD_COOKIE
Public CMD_GET_COOKIE
Public CMD_DELETE_ALL_COOKIES
Public CMD_DELETE_COOKIE
Public CMD_SWITCH_TO_FRAME
Public CMD_SWITCH_TO_PARENT_FRAME
Public CMD_SWITCH_TO_WINDOW
Public CMD_CLOSE
Public CMD_GET_ELEMENT_VALUE_OF_CSS_PROPERTY
Public CMD_IMPLICIT_WAIT
Public CMD_EXECUTE_ASYNC_SCRIPT
Public CMD_SET_SCRIPT_TIMEOUT
Public CMD_SET_TIMEOUTS
Public CMD_DISMISS_ALERT
Public CMD_W3C_DISMISS_ALERT
Public CMD_ACCEPT_ALERT
Public CMD_W3C_ACCEPT_ALERT
Public CMD_SET_ALERT_VALUE
Public CMD_W3C_SET_ALERT_VALUE
Public CMD_GET_ALERT_TEXT
Public CMD_W3C_GET_ALERT_TEXT
Public CMD_SET_ALERT_CREDENTIALS
Public CMD_CLICK
Public CMD_W3C_ACTIONS
Public CMD_W3C_CLEAR_ACTIONS
Public CMD_DOUBLE_CLICK
Public CMD_MOUSE_DOWN
Public CMD_MOUSE_UP
Public CMD_MOVE_TO
Public CMD_GET_WINDOW_SIZE
Public CMD_SET_WINDOW_SIZE
Public CMD_GET_WINDOW_POSITION
Public CMD_SET_WINDOW_POSITION
Public CMD_SET_WINDOW_RECT
Public CMD_GET_WINDOW_RECT
Public CMD_MAXIMIZE_WINDOW
Public CMD_W3C_MAXIMIZE_WINDOW
Public CMD_SET_SCREEN_ORIENTATION
Public CMD_GET_SCREEN_ORIENTATION
Public CMD_SINGLE_TAP
Public CMD_TOUCH_DOWN
Public CMD_TOUCH_UP
Public CMD_TOUCH_MOVE
Public CMD_TOUCH_SCROLL
Public CMD_DOUBLE_TAP
Public CMD_LONG_PRESS
Public CMD_FLICK
Public CMD_EXECUTE_SQL
Public CMD_GET_LOCATION
Public CMD_SET_LOCATION
Public CMD_GET_APP_CACHE
Public CMD_GET_APP_CACHE_STATUS
Public CMD_CLEAR_APP_CACHE
Public CMD_GET_NETWORK_CONNECTION
Public CMD_SET_NETWORK_CONNECTION
Public CMD_GET_LOCAL_STORAGE_ITEM
Public CMD_REMOVE_LOCAL_STORAGE_ITEM
Public CMD_GET_LOCAL_STORAGE_KEYS
Public CMD_SET_LOCAL_STORAGE_ITEM
Public CMD_CLEAR_LOCAL_STORAGE
Public CMD_GET_LOCAL_STORAGE_SIZE
Public CMD_GET_SESSION_STORAGE_ITEM
Public CMD_REMOVE_SESSION_STORAGE_ITEM
Public CMD_GET_SESSION_STORAGE_KEYS
Public CMD_SET_SESSION_STORAGE_ITEM
Public CMD_CLEAR_SESSION_STORAGE
Public CMD_GET_SESSION_STORAGE_SIZE
Public CMD_GET_LOG
Public CMD_GET_AVAILABLE_LOG_TYPES
Public CMD_CURRENT_CONTEXT_HANDLE
Public CMD_CONTEXT_HANDLES
Public CMD_SWITCH_TO_CONTEXT
Public CMD_FULLSCREEN_WINDOW
Public CMD_MINIMIZE_WINDOW
Public CMD_SHUTDOWN
Private Const ELEMENT_KEY = "element-6066-11e4-a52e-4f735466cecf"
Public Enum By
ID = 0
TagName = 1
ClassName = 2
Name = 3
CssSelector = 4
XPath = 5
End Enum
' ==========================================================================
' Setup and shutdown
' ==========================================================================
' Launch Edge Driver
Public Sub Edge(ByVal driverPath As String, Optional ByVal driverUrl As String = "http://localhost:9515")
Start driverPath, driverUrl
End Sub
' Launch Chrome Driver
Public Sub Chrome(ByVal driverPath As String, Optional ByVal driverUrl As String = "http://localhost:9515")
Start driverPath, driverUrl
End Sub
' Start WebDriver
Public Sub Start(ByVal driverPath As String, ByVal driverUrl As String)
' Start WebDriver executable
If Shell(driverPath, vbMinimizedNoFocus) = 0 Then
MsgBox "Failed in starting WebDriver"
End
End If
' Set WebDriver url
UrlBase = driverUrl
' Initialize driver commands
InitCommands
End Sub
' Shutdown WebDriver
Public Sub Shutdown()
Execute CMD_SHUTDOWN
End Sub
' ==========================================================================
' Browser operations
' ==========================================================================
' Open browser
Public Function OpenBrowser(Optional capabilities As Dictionary = Nothing, Optional desiredCapabilities As Dictionary = Nothing, Optional ByVal useAsDefault As Boolean = True) As String
If capabilities Is Nothing Then
Set capabilities = New Dictionary
End If
Dim resp As Dictionary
Set resp = Execute(CMD_NEW_SESSION, Params("capabilities", capabilities, "desiredCapabilities", desiredCapabilities))
If useAsDefault Then
DefaultSessionId = resp("sessionId")
End If
OpenBrowser = resp("sessionId")
End Function
' Close browser
Public Sub CloseBrowser(Optional ByVal sessionId As String = vbNullString)
Dim data As New Dictionary
If sessionId <> vbNullString Then
data.Add "sessionId", sessionId
End If
Execute CMD_QUIT, data
DefaultSessionId = vbNullString
End Sub
' Open url
Public Sub Navigate(ByVal url As String, Optional ByVal sessionId As String = vbNullString)
Dim data As New Dictionary
If sessionId <> vbNullString Then
data.Add "sessionId", sessionId
End If
data.Add "url", url
Execute CMD_GET, data
End Sub
' ==========================================================================
' DOM operations
' ==========================================================================
' Find DOM element
Public Function FindElement(by_ As By, value As String, Optional parentElementId As String = vbNullString, Optional ByVal sessionId As String = vbNullString) As WebElement
Dim data As Dictionary
Set data = ToSelector(by_, value)
If sessionId <> vbNullString Then
data.Add "sessionId", sessionId
End If
Dim cmd
If parentElementId <> vbNullString Then
data.Add "id", parentElementId
cmd = CMD_FIND_CHILD_ELEMENT
Else
cmd = CMD_FIND_ELEMENT
End If
' Return element
Set FindElement = ToWebElement(Execute(cmd, data)(ELEMENT_KEY), sessionId)
End Function
' Find multiple DOM elements
Public Function FindElements(by_ As By, value As String, Optional parentElementId As String = vbNullString, Optional ByVal sessionId As String = vbNullString) As WebElement()
Dim data As Dictionary
Set data = ToSelector(by_, value)
If sessionId <> vbNullString Then
data.Add "sessionId", sessionId
End If
Dim cmd
If parentElementId <> vbNullString Then
data.Add "id", parentElementId
cmd = CMD_FIND_CHILD_ELEMENTS
Else
cmd = CMD_FIND_ELEMENTS
End If
Dim elements
Set elements = Execute(cmd, data)
' To array of ids
Dim ret() As WebElement
Dim i As Integer
For i = 0 To elements.Count - 1 ' elements is Collection, not array
ReDim Preserve ret(i)
Set ret(i) = ToWebElement(elements(i + 1)(ELEMENT_KEY), sessionId)
Next
' Return element ids
FindElements = ret
End Function
' by* to CSS selector or Xpath
Private Function ToSelector(by_ As By, ByVal value As String) As Dictionary
Dim data As New Dictionary
If (by_ = By.XPath) Then
'Locator Strategy XPath
data.Add "using", "xpath"
Else:
'Use Css Selector for Locator strategies other than
data.Add "using", "css selector"
If by_ = By.ID Then
value = "[id=""" + value + """]"
ElseIf by_ = By.ClassName Then
value = "." + value
ElseIf by_ = By.Name Then
value = "[name=""" + value + """]"
End If
End If
data.Add "value", value
Set ToSelector = data
End Function
' Create element
Private Function ToWebElement(ByVal elementId As String, Optional ByVal sessionId As String = vbNullString) As WebElement
Dim element As New WebElement
Set element.Driver_ = Me
If sessionId = vbNullString Then
element.SessionId_ = sessionId
Else
element.SessionId_ = DefaultSessionId
End If
element.ElementId_ = elementId
Set ToWebElement = element
End Function
' Returns element.value
Public Function GetValue(elementId As String, Optional ByVal sessionId As String = vbNullString) As String
Dim data As New Dictionary
If sessionId <> vbNullString Then
data.Add "sessionId", sessionId
End If
data.Add "id", elementId
data.Add "name", "value"
GetValue = Execute(CMD_GET_ELEMENT_ATTRIBUTE, data)
End Function
' Set value to element
Public Sub SetValue(elementId As String, text As String, Optional ByVal sessionId As String = vbNullString)
Dim data As New Dictionary
If sessionId <> vbNullString Then
data.Add "sessionId", sessionId
End If
data.Add "id", elementId
data.Add "text", text
Dim chars() As String
ReDim chars(Len(text) - 1)
Dim i As Integer
For i = 0 To UBound(chars)
chars(i) = Mid(text, i + 1, 1)
Next
data.Add "value", chars
Execute CMD_CLEAR_ELEMENT, data
Execute CMD_SEND_KEYS_TO_ELEMENT, data
End Sub
' Click element
Public Sub Click(elementId As String, Optional ByVal sessionId As String = vbNullString)
Dim data As New Dictionary
If sessionId <> vbNullString Then
data.Add "sessionId", sessionId
End If
data.Add "id", elementId
Execute CMD_CLICK_ELEMENT, data
End Sub
' Get text
Public Function GetText(elementId As String, Optional ByVal sessionId As String = vbNullString) As String
Dim data As New Dictionary
If sessionId <> vbNullString Then
data.Add "sessionId", sessionId
End If
data.Add "id", elementId
GetText = Execute(CMD_GET_ELEMENT_TEXT, data)
End Function
' ==========================================================================
' Common functions
' ==========================================================================
' Execute driver command
Public Function Execute(driverCommand, Optional parameters As Dictionary = Nothing)
Dim method As String: method = driverCommand(0)
Dim path As String: path = driverCommand(1)
If parameters Is Nothing Then
Set parameters = New Dictionary
End If
' Set default session id if session id is missing
If Not parameters.Exists("sessionId") Then
parameters.Add "sessionId", DefaultSessionId
End If
' Set params to path
Dim paramKey As Variant
For Each paramKey In parameters
If VarType(parameters(paramKey)) = vbString Then
path = Replace(path, "$" + paramKey, parameters(paramKey))
End If
Next
' Send request to selenium server
Dim resp As Dictionary
Set resp = SendRequest(method, UrlBase + path, parameters)
' Return value(s)
If IsNull(resp("value")) Then
Set Execute = New Dictionary
ElseIf TypeName(resp("value")) = "Collection" Then
Set Execute = resp("value")
ElseIf VarType(resp("value")) = vbObject Then
If resp("value").Exists("error") Then
Err.Raise 513, "WebDriver.Execute", JsonConverter.ConvertToJson(resp("value"))
Else
Set Execute = resp("value")
End If
Else
Execute = resp("value")
End If
End Function
' Send HTTP request
Private Function SendRequest(method As String, url As String, Optional data As Dictionary = Nothing) As Dictionary
Dim client As Object
Set client = CreateObject("MSXML2.ServerXMLHTTP")
client.Open method, url
If method = "POST" Or method = "PUT" Then
client.setRequestHeader "Content-Type", "application/json"
client.send JsonConverter.ConvertToJson(data)
Else
client.send
End If
Do While client.readyState < 4
DoEvents
Loop
Dim Json As Object
Set Json = JsonConverter.ParseJson(client.responseText)
Set SendRequest = Json
End Function
' ==========================================================================
' Driver commands
' ==========================================================================
Private Sub InitCommands()
CMD_STATUS = Array("GET", "/status")
CMD_NEW_SESSION = Array("POST", "/session")
CMD_GET_ALL_SESSIONS = Array("GET", "/sessions")
CMD_QUIT = Array("DELETE", "/session/$sessionId")
CMD_GET_CURRENT_WINDOW_HANDLE = Array("GET", "/session/$sessionId/window_handle")
CMD_W3C_GET_CURRENT_WINDOW_HANDLE = Array("GET", "/session/$sessionId/window")
CMD_GET_WINDOW_HANDLES = Array("GET", "/session/$sessionId/window_handles")
CMD_W3C_GET_WINDOW_HANDLES = Array("GET", "/session/$sessionId/window/handles")
CMD_GET = Array("POST", "/session/$sessionId/url")
CMD_GO_FORWARD = Array("POST", "/session/$sessionId/forward")
CMD_GO_BACK = Array("POST", "/session/$sessionId/back")
CMD_REFRESH = Array("POST", "/session/$sessionId/refresh")
CMD_EXECUTE_SCRIPT = Array("POST", "/session/$sessionId/execute")
CMD_W3C_EXECUTE_SCRIPT = Array("POST", "/session/$sessionId/execute/sync")
CMD_W3C_EXECUTE_SCRIPT_ASYNC = Array("POST", "/session/$sessionId/execute/async")
CMD_GET_CURRENT_URL = Array("GET", "/session/$sessionId/url")
CMD_GET_TITLE = Array("GET", "/session/$sessionId/title")
CMD_GET_PAGE_SOURCE = Array("GET", "/session/$sessionId/source")
CMD_SCREENSHOT = Array("GET", "/session/$sessionId/screenshot")
CMD_ELEMENT_SCREENSHOT = Array("GET", "/session/$sessionId/element/$id/screenshot")
CMD_FIND_ELEMENT = Array("POST", "/session/$sessionId/element")
CMD_FIND_ELEMENTS = Array("POST", "/session/$sessionId/elements")
CMD_W3C_GET_ACTIVE_ELEMENT = Array("GET", "/session/$sessionId/element/active")
CMD_GET_ACTIVE_ELEMENT = Array("POST", "/session/$sessionId/element/active")
CMD_FIND_CHILD_ELEMENT = Array("POST", "/session/$sessionId/element/$id/element")
CMD_FIND_CHILD_ELEMENTS = Array("POST", "/session/$sessionId/element/$id/elements")
CMD_CLICK_ELEMENT = Array("POST", "/session/$sessionId/element/$id/click")
CMD_CLEAR_ELEMENT = Array("POST", "/session/$sessionId/element/$id/clear")
CMD_SUBMIT_ELEMENT = Array("POST", "/session/$sessionId/element/$id/submit")
CMD_GET_ELEMENT_TEXT = Array("GET", "/session/$sessionId/element/$id/text")
CMD_SEND_KEYS_TO_ELEMENT = Array("POST", "/session/$sessionId/element/$id/value")
CMD_SEND_KEYS_TO_ACTIVE_ELEMENT = Array("POST", "/session/$sessionId/keys")
CMD_UPLOAD_FILE = Array("POST", "/session/$sessionId/file")
CMD_GET_ELEMENT_VALUE = Array("GET", "/session/$sessionId/element/$id/value")
CMD_GET_ELEMENT_TAG_NAME = Array("GET", "/session/$sessionId/element/$id/name")
CMD_IS_ELEMENT_SELECTED = Array("GET", "/session/$sessionId/element/$id/selected")
CMD_SET_ELEMENT_SELECTED = Array("POST", "/session/$sessionId/element/$id/selected")
CMD_IS_ELEMENT_ENABLED = Array("GET", "/session/$sessionId/element/$id/enabled")
CMD_IS_ELEMENT_DISPLAYED = Array("GET", "/session/$sessionId/element/$id/displayed")
CMD_GET_ELEMENT_LOCATION = Array("GET", "/session/$sessionId/element/$id/location")
CMD_GET_ELEMENT_LOCATION_ONCE_SCROLLED_INTO_VIEW = Array("GET", "/session/$sessionId/element/$id/location_in_view")
CMD_GET_ELEMENT_SIZE = Array("GET", "/session/$sessionId/element/$id/size")
CMD_GET_ELEMENT_RECT = Array("GET", "/session/$sessionId/element/$id/rect")
CMD_GET_ELEMENT_ATTRIBUTE = Array("GET", "/session/$sessionId/element/$id/attribute/$name")
CMD_GET_ELEMENT_PROPERTY = Array("GET", "/session/$sessionId/element/$id/property/$name")
CMD_GET_ALL_COOKIES = Array("GET", "/session/$sessionId/cookie")
CMD_ADD_COOKIE = Array("POST", "/session/$sessionId/cookie")
CMD_GET_COOKIE = Array("GET", "/session/$sessionId/cookie/$name")
CMD_DELETE_ALL_COOKIES = Array("DELETE", "/session/$sessionId/cookie")
CMD_DELETE_COOKIE = Array("DELETE", "/session/$sessionId/cookie/$name")
CMD_SWITCH_TO_FRAME = Array("POST", "/session/$sessionId/frame")
CMD_SWITCH_TO_PARENT_FRAME = Array("POST", "/session/$sessionId/frame/parent")
CMD_SWITCH_TO_WINDOW = Array("POST", "/session/$sessionId/window")
CMD_CLOSE = Array("DELETE", "/session/$sessionId/window")
CMD_GET_ELEMENT_VALUE_OF_CSS_PROPERTY = Array("GET", "/session/$sessionId/element/$id/css/$propertyName")
CMD_IMPLICIT_WAIT = Array("POST", "/session/$sessionId/timeouts/implicit_wait")
CMD_EXECUTE_ASYNC_SCRIPT = Array("POST", "/session/$sessionId/execute_async")
CMD_SET_SCRIPT_TIMEOUT = Array("POST", "/session/$sessionId/timeouts/async_script")
CMD_SET_TIMEOUTS = Array("POST", "/session/$sessionId/timeouts")
CMD_DISMISS_ALERT = Array("POST", "/session/$sessionId/dismiss_alert")
CMD_W3C_DISMISS_ALERT = Array("POST", "/session/$sessionId/alert/dismiss")
CMD_ACCEPT_ALERT = Array("POST", "/session/$sessionId/accept_alert")
CMD_W3C_ACCEPT_ALERT = Array("POST", "/session/$sessionId/alert/accept")
CMD_SET_ALERT_VALUE = Array("POST", "/session/$sessionId/alert_text")
CMD_W3C_SET_ALERT_VALUE = Array("POST", "/session/$sessionId/alert/text")
CMD_GET_ALERT_TEXT = Array("GET", "/session/$sessionId/alert_text")
CMD_W3C_GET_ALERT_TEXT = Array("GET", "/session/$sessionId/alert/text")
CMD_SET_ALERT_CREDENTIALS = Array("POST", "/session/$sessionId/alert/credentials")
CMD_CLICK = Array("POST", "/session/$sessionId/click")
CMD_W3C_ACTIONS = Array("POST", "/session/$sessionId/actions")
CMD_W3C_CLEAR_ACTIONS = Array("DELETE", "/session/$sessionId/actions")
CMD_DOUBLE_CLICK = Array("POST", "/session/$sessionId/doubleclick")
CMD_MOUSE_DOWN = Array("POST", "/session/$sessionId/buttondown")
CMD_MOUSE_UP = Array("POST", "/session/$sessionId/buttonup")
CMD_MOVE_TO = Array("POST", "/session/$sessionId/moveto")
CMD_GET_WINDOW_SIZE = Array("GET", "/session/$sessionId/window/$windowHandle/size")
CMD_SET_WINDOW_SIZE = Array("POST", "/session/$sessionId/window/$windowHandle/size")
CMD_GET_WINDOW_POSITION = Array("GET", "/session/$sessionId/window/$windowHandle/position")
CMD_SET_WINDOW_POSITION = Array("POST", "/session/$sessionId/window/$windowHandle/position")
CMD_SET_WINDOW_RECT = Array("POST", "/session/$sessionId/window/rect")
CMD_GET_WINDOW_RECT = Array("GET", "/session/$sessionId/window/rect")
CMD_MAXIMIZE_WINDOW = Array("POST", "/session/$sessionId/window/$windowHandle/maximize")
CMD_W3C_MAXIMIZE_WINDOW = Array("POST", "/session/$sessionId/window/maximize")
CMD_SET_SCREEN_ORIENTATION = Array("POST", "/session/$sessionId/orientation")
CMD_GET_SCREEN_ORIENTATION = Array("GET", "/session/$sessionId/orientation")
CMD_SINGLE_TAP = Array("POST", "/session/$sessionId/touch/click")
CMD_TOUCH_DOWN = Array("POST", "/session/$sessionId/touch/down")
CMD_TOUCH_UP = Array("POST", "/session/$sessionId/touch/up")
CMD_TOUCH_MOVE = Array("POST", "/session/$sessionId/touch/move")
CMD_TOUCH_SCROLL = Array("POST", "/session/$sessionId/touch/scroll")
CMD_DOUBLE_TAP = Array("POST", "/session/$sessionId/touch/doubleclick")
CMD_LONG_PRESS = Array("POST", "/session/$sessionId/touch/longclick")
CMD_FLICK = Array("POST", "/session/$sessionId/touch/flick")
CMD_EXECUTE_SQL = Array("POST", "/session/$sessionId/execute_sql")
CMD_GET_LOCATION = Array("GET", "/session/$sessionId/location")
CMD_SET_LOCATION = Array("POST", "/session/$sessionId/location")
CMD_GET_APP_CACHE = Array("GET", "/session/$sessionId/application_cache")
CMD_GET_APP_CACHE_STATUS = Array("GET", "/session/$sessionId/application_cache/status")
CMD_CLEAR_APP_CACHE = Array("DELETE", "/session/$sessionId/application_cache/clear")
CMD_GET_NETWORK_CONNECTION = Array("GET", "/session/$sessionId/network_connection")
CMD_SET_NETWORK_CONNECTION = Array("POST", "/session/$sessionId/network_connection")
CMD_GET_LOCAL_STORAGE_ITEM = Array("GET", "/session/$sessionId/local_storage/key/$key")
CMD_REMOVE_LOCAL_STORAGE_ITEM = Array("DELETE", "/session/$sessionId/local_storage/key/$key")
CMD_GET_LOCAL_STORAGE_KEYS = Array("GET", "/session/$sessionId/local_storage")
CMD_SET_LOCAL_STORAGE_ITEM = Array("POST", "/session/$sessionId/local_storage")
CMD_CLEAR_LOCAL_STORAGE = Array("DELETE", "/session/$sessionId/local_storage")
CMD_GET_LOCAL_STORAGE_SIZE = Array("GET", "/session/$sessionId/local_storage/size")
CMD_GET_SESSION_STORAGE_ITEM = Array("GET", "/session/$sessionId/session_storage/key/$key")
CMD_REMOVE_SESSION_STORAGE_ITEM = Array("DELETE", "/session/$sessionId/session_storage/key/$key")
CMD_GET_SESSION_STORAGE_KEYS = Array("GET", "/session/$sessionId/session_storage")
CMD_SET_SESSION_STORAGE_ITEM = Array("POST", "/session/$sessionId/session_storage")
CMD_CLEAR_SESSION_STORAGE = Array("DELETE", "/session/$sessionId/session_storage")
CMD_GET_SESSION_STORAGE_SIZE = Array("GET", "/session/$sessionId/session_storage/size")
CMD_GET_LOG = Array("POST", "/session/$sessionId/log")
CMD_GET_AVAILABLE_LOG_TYPES = Array("GET", "/session/$sessionId/log/types")
CMD_CURRENT_CONTEXT_HANDLE = Array("GET", "/session/$sessionId/context")
CMD_CONTEXT_HANDLES = Array("GET", "/session/$sessionId/contexts")
CMD_SWITCH_TO_CONTEXT = Array("POST", "/session/$sessionId/context")
CMD_FULLSCREEN_WINDOW = Array("POST", "/session/$sessionId/window/fullscreen")
CMD_MINIMIZE_WINDOW = Array("POST", "/session/$sessionId/window/minimize")
CMD_SHUTDOWN = Array("GET", "/shutdown")
End Sub
' ==========================================================================
' Utility functions
' ==========================================================================
' KeyValue arguments to parameters as dictionaly
Private Function Params(ParamArray keysAndValues()) As Dictionary
Dim dict As New Dictionary
Dim i As Integer
For i = 0 To UBound(keysAndValues) - 1 Step 2
dict.Add keysAndValues(i), keysAndValues(i + 1)
Next i
Set Params = dict
End Function
④クラスモジュール【WebElement】
'VERSION 1.0 CLASS
'BEGIN
' MultiUse = -1 'True
'End
' TinySeleniumVBA v0.1.0
' A tiny Selenium wrapper written in pure VBA
'
' (c)2021 uezo
'
' Mail: uezo@uezo.net
' Twitter: @uezochan
' https://github.com/uezo/TinySeleniumVBA
'
' ==========================================================================
' MIT License
'
' Copyright (c) 2021 uezo
'
' Permission is hereby granted, free of charge, to any person obtaining a copy
' of this software and associated documentation files (the "Software"), to deal
' in the Software without restriction, including without limitation the rights
' to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
' copies of the Software, and to permit persons to whom the Software is
' furnished to do so, subject to the following conditions:
'
' The above copyright notice and this permission notice shall be included in all
' copies or substantial portions of the Software.
'
' THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
' IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
' FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
' AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
' LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
' OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
' SOFTWARE.
' ==========================================================================
Option Explicit
Public Driver_ As WebDriver
Public SessionId_ As String
Public ElementId_ As String
' Find DOM element
Public Function FindElement(by_ As By, value As String) As WebElement
Set FindElement = Driver_.FindElement(by_, value, ElementId_, SessionId_)
End Function
' Find multiple DOM elements
Public Function FindElements(by_ As By, value As String) As WebElement()
FindElements = Driver_.FindElements(by_, value, ElementId_, SessionId_)
End Function
' Returns element.value
Public Function GetValue() As String
GetValue = Driver_.GetValue(ElementId_, SessionId_)
End Function
' Set value to element
Public Sub SetValue(text As String)
Driver_.SetValue ElementId_, text, SessionId_
End Sub
' Click
Public Sub Click()
Driver_.Click ElementId_, SessionId_
End Sub
' Returns element.innerText
Public Function GetText() As String
GetText = Driver_.GetText(ElementId_, SessionId_)
End Function
0
