├── .gitignore ├── LICENSE ├── README.md └── src ├── JsonConverter.bas ├── Sample.bas ├── WebDriver.cls ├── WebDriverOptions.cls └── WebElement.cls /.gitignore: -------------------------------------------------------------------------------- 1 | *.xlsm 2 | *.xlsx 3 | *.png -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2022 er-ri 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # SeleniumWrapperVBA 2 | A Selenium-WebDriver-based browser automation framework implemented for VBA. 3 | 4 | 5 |
6 | Table of Contents 7 |
    8 |
  1. About The Project
    2. 9 |
  2. Requirements
    3. 10 |
  3. Getting Started
    4. 11 |
  4. Usage
    5. 12 | 25 |
  5. Roadmap
    6. 26 |
  6. License
    7. 27 |
  7. Contribution
    8. 28 |
  8. References
    9. 29 |
30 |
31 | 32 | ## About The Project 33 | The project implements the `endpoint node command` defined in [W3C WebDriver specification](https://www.w3.org/TR/webdriver/#endpoints) through VBA. You can use the project to do browser automation without installing a programming language such as Python, Java, etc. An MS office app and a browser-specific driver are required. 34 | 35 | ## Requirements 36 | 1. MS Office(Excel, Word, PowerPoint, etc) 32bit or 64bit 37 | 2. Browser's driver(Supported Browsers: Firefox, Chrome, Edge and Internet Explorer) 38 | 39 | ## Getting Started 40 | 1. Download the browser-specific *drivers*, [`firefox`](https://github.com/mozilla/geckodriver/releases), 41 | [`chrome`](https://chromedriver.chromium.org/), 42 | [`edge`](https://developer.microsoft.com/en-us/microsoft-edge/tools/webdriver/), or 43 | [`ie`](https://www.selenium.dev/downloads/). 44 | 2. In the office, by clicking the *Developer* tab(if you enabled) or through the shortcut key `Alt + F11` to open the VBA Editor, and then import `WebDriverOptions.cls`, `WebDriver.cls`, `WebElement.cls` and `JsonConverter.bas` into your project. (*File > Import File*) 45 | * where `JsonConverter.bas`, a JSON Parser for VBA created and maintained by [@timhall](https://github.com/timhall). For more details, see [`here`](https://github.com/VBA-tools/VBA-JSON). 46 | 3. Include a reference to "Microsoft Scripting Runtime". (*Tools > References* Check "`Microsoft Scripting Runtime`") 47 | 48 | #### Note 49 | * Add browser's driver in the system `PATH`, or you can also specify the path when launching the corresponding browser's driver. 50 | * Some configurations are required before using `iedriver`, see [here](https://www.selenium.dev/documentation/ie_driver_server/#required-configuration) for more details about the configurations. 51 | 52 | #### Example 53 | ```vba 54 | Sub Example() 55 | Dim driver As New WebDriver 56 | 57 | driver.Chrome "to/your/path/chromedriver.exe" 58 | driver.OpenBrowser 59 | driver.NavigateTo "https://www.python.org/" 60 | driver.MaximizeWindow 61 | driver.FindElement(By.ID, "id-search-field").SendKeys "machine learning" 62 | driver.FindElement(By.ID, "submit").Click 63 | driver.TakeScreenshot ThisWorkbook.path + "./screenshot.png" 64 | driver.MinimizeWindow 65 | driver.CloseBrowser 66 | 67 | driver.Quit 68 | Set driver = Nothing 69 | End Sub 70 | ``` 71 | 72 | ## Usage 73 | ### Element Retrieval 74 | #### Find Element 75 | ```vba 76 | ' Locator Strategies: 77 | Dim e1, e2, e3, e4, e5, e6, e7, e8 As WebElement 78 | set e1 = driver.FindElement(By.ID, "id") 79 | set e2 = driver.FindElement(By.ClassName, "blue") 80 | set e3 = driver.FindElement(By.Name, "name") 81 | set e4 = driver.FindElement(By.LinkText, "www.google.com") 82 | set e5 = driver.FindElement(By.PartialLinkText, "www.googl") 83 | set e6 = driver.FindElement(By.TagName, "div") 84 | set e7 = driver.FindElement(By.XPath, "/html/body/div[1]/div[3]") 85 | set e8 = driver.FindElement(By.CSS, ".search input[type='text']") 86 | ``` 87 | 88 | #### Find Elements 89 | ```vba 90 | Dim elements() As WebElement 91 | elements = driver.FindElements(By.TagName, "a") 92 | 93 | Dim element As Variant 94 | For Each element In elements 95 | ' Do your stuff 96 | Next element 97 | ``` 98 | 99 | #### Find Element From Element 100 | ```vba 101 | Dim elementRoot As WebElement 102 | Set elementRoot = driver.FindElement(By.ID, "root1") 103 | Dim elementChild As WebElement 104 | Set elementChild = driver.FindElementFromElement(elmentRoot, By.TagName, "div") 105 | ``` 106 | 107 | #### Find Elements From Element 108 | ```vba 109 | Dim elementRoot As WebElement 110 | Set elementRoot = driver.FindElement(By.ID, "root1") 111 | Dim elementChildren() As WebElement 112 | elementChildren() = driver.FindElementsFromElement(elmentRoot, By.TagName, "p") 113 | ``` 114 | 115 | #### Find Element From ShadowRoot 116 | ```vba 117 | Dim element as WebElement 118 | Dim elementShadowRoot As WebElement 119 | Set elementShadowRoot = driver.FindElement(By.ID, "shadow_id").GetShadowRoot() 120 | Set element = driver.FindElementFromShadowRoot(eleShadowRoot, By.CSS, "#shadow_css") 121 | ``` 122 | 123 | #### Find Elements From ShadowRoot 124 | ```vba 125 | Dim elements() As WebElement 126 | Dim elementShadowRoot As WebElement 127 | Set elementShadowRoot = driver.FindElement(By.ID, "shadow_id").GetShadowRoot() 128 | elements() = driver.FindElementsFromShadowRoot(elementShadowRoot, By.CSS, "#shadow_css") 129 | ``` 130 | 131 | ### Timeouts 132 | #### Get Timeouts 133 | ```vba 134 | Dim timeoutsDict As Dictionary 135 | Set timeoutsDict = driver.GetTimeouts() 136 | Debug.Print timeoutsDict("script") ' 30000 137 | Debug.Print timeoutsDict("pageLoad") ' 300000 138 | Debug.Print timeoutsDict("implicit") ' 0 139 | ``` 140 | 141 | #### Set Timeouts 142 | ```vba 143 | ' Set "script":40000,"pageLoad":500000,"implicit":15000 144 | driver.SetTimeouts 40000, 500000, 15000 145 | ``` 146 | * Invoke the function before `OpenBrowser`. 147 | 148 | ### Working with iframe 149 | ```vba 150 | Set iframe1 = driver.FindElement(By.ID, "iframe1") 151 | driver.SwitchToFrame iframe1 152 | ' Perform some operations... 153 | driver.SwitchToParentFrame ' switch back 154 | ``` 155 | 156 | ### Working with multiple windows 157 | ```vba 158 | ' Get current windows's handle. 159 | Dim hWnd As String 160 | hWnd = driver.GetWindowHandle 161 | ' Get the handles of all the windows. 162 | Dim hWnds As New Collection 163 | Set hWnds = driver.GetWindowHandles 164 | ' Switch to another window. 165 | driver.SwitchToWindow (driver.GetWindowHandles(2)) 166 | ``` 167 | 168 | ### Execute JavaScript 169 | ```vba 170 | ' No parameters, no return value. 171 | driver.ExecuteScript "alert('Hello world!');" 172 | driver.DismissAlert 173 | ' Accept parameters, no return value. 174 | driver.ExecuteScript "alert('Proof: ' + arguments[0] + arguments[1]);", "1+1=", 2 175 | driver.DismissAlert 176 | ' Accept parameters, return the result. 177 | Dim result As Long 178 | result = driver.ExecuteScript("let result = arguments[0] + arguments[1];return result;", 1, 2) 179 | Debug.Print result ' 3 180 | ``` 181 | 182 | ### Execute Async JavaScript 183 | ```vba 184 | ' No parameters, no return value. 185 | driver.ExecuteAsyncScript "alert('Hello world!');" 186 | driver.WaitUntilAlertIsPresent 187 | driver.DismissAlert 188 | ' Accept parameters, no return value. 189 | driver.ExecuteAsyncScript "alert('Proof: ' + arguments[0] + arguments[1]);", "1+1=", 2 190 | driver.WaitUntilAlertIsPresent 191 | driver.DismissAlert 192 | ' Accept parameters, return the result. 193 | Dim result As Long 194 | result = driver.ExecuteAsyncScript("let result = arguments[0] + arguments[1];return result;", 1, 2) 195 | Debug.Print result ' 3 196 | ``` 197 | 198 | ### Working with alerts 199 | ```vba 200 | driver.WaitUntilAlertIsPresent 201 | driver.DismissAlert 202 | 203 | driver.ExecuteScript "prompt('question?')" 204 | driver.SendAlertText "answer" 205 | driver.AcceptAlert 206 | ``` 207 | 208 | ### Screenshot 209 | #### Take Screenshot 210 | ```vba 211 | ' Take the current webpage screenshot and save it to the specific path. 212 | driver.TakeScreenshot ThisWorkbook.path + "./1.png" 213 | ``` 214 | 215 | #### Take Element Screenshot 216 | ```vba 217 | ' Take the element screenshot directly. 218 | driver.FindElement(By.ID, "selenium_logo").TakeScreenshot ThisWorkbook.path + "./logo.png" 219 | ' or 220 | Dim seleniumLogo As WebElement 221 | Set seleniumLogo = driver.FindElement(By.ID, "selenium_logo") 222 | seleniumLogo.TakeScreenshot ThisWorkbook.path + "./logo.png" 223 | ``` 224 | 225 | ### Enable Edge IE-mode 226 | ```vba 227 | Dim driver As New WebDriver 228 | Dim ieOptions As New WebDriverOptions 229 | ieOptions.BrowserType = InternetExplorer 230 | ieOptions.IntroduceFlakinessByIgnoringSecurityDomains = True ' Optional 231 | ieOptions.IgnoreZoomSetting = True ' Optional 232 | ieOptions.AttachToEdgeChrome = True 233 | ieOptions.EdgeExecutablePath = "C:/Program Files (x86)/Microsoft/Edge/Application/msedge.exe" 234 | 235 | driver.InternetExplorer "C:\WebDriver\IEDriverServer_Win32_4.0.0\IEDriverServer.exe" 236 | driver.OpenBrowser ieOptions 237 | ``` 238 | 239 | ### Headless mode 240 | #### Start Chrome in headless mode 241 | ```vba 242 | Dim driver As New WebDriver 243 | Dim chromeOptions As New WebDriverOptions 244 | chromeOptions.BrowserType = Chrome 245 | chromeOptions.ChromeArguments.add "--headless" 246 | 247 | driver.Chrome "C:\WebDriver\chromedriver_win32\chromedriver.exe" 248 | driver.OpenBrowser chromeOptions 249 | ``` 250 | 251 | #### Start Firefox in headless mode 252 | ```vba 253 | Dim driver As New WebDriver 254 | Dim firefoxOptions As New WebDriverOptions 255 | firefoxOptions.BrowserType = Firefox 256 | firefoxOptions.FirefoxArguments.Add "-headless" 257 | 258 | driver.Firefox "C:\WebDriver\Firefox\geckodriver.exe" 259 | driver.OpenBrowser firefoxOptions 260 | ``` 261 | 262 | ### Customize User-Agent 263 | #### Customize User-Agent in Chrome 264 | ```vba 265 | Dim driver As New WebDriver 266 | Dim chromeOptions As New WebDriverOptions 267 | 268 | driver.Chrome 269 | chromeOptions.BrowserType = Chrome 270 | chromeOptions.ChromeArguments.Add "--user-agent=my customized user-agent" 271 | driver.OpenBrowser chromeOptions 272 | driver.NavigateTo "https://www.whatismybrowser.com/detect/what-is-my-user-agent/" 273 | ``` 274 | 275 | ## Roadmap 276 | | Endpoint Node Command | Function Name | Element Function Name | 277 | |--------------------------------|----------------------------|-----------------------| 278 | | New Session | OpenBrowser | | 279 | | Delete Session | CloseBrowser | | 280 | | Status | GetStatus | | 281 | | Get Timeouts | GetTimeouts | | 282 | | Set Timeouts | SetTimeouts | | 283 | | Navigate To | NavigateTo | | 284 | | Get Current URL | GetCurrentURL | | 285 | | Back | Back | | 286 | | Forward | Forward | | 287 | | Refresh | Refresh | | 288 | | Get Title | GetTitle | | 289 | | Get Window Handle | GetWindowHandle | | 290 | | Close Window | CloseWindow | | 291 | | Switch To Window | SwitchToWindow | | 292 | | Get Window Handles | GetWindowHandles | | 293 | | New Window | NewWindow | | 294 | | Switch To Frame | SwitchToFrame | | 295 | | Switch To Parent Frame | SwitchToParentFrame | | 296 | | Get Window Rect | GetWindowRect | | 297 | | Set Window Rect | SetWindowRect | | 298 | | Maximize Window | MaximizeWindow | | 299 | | Minimize Window | MinimizeWindow | | 300 | | Fullscreen Window | FullscreenWindow | | 301 | | Get Active Element | Not yet | | 302 | | Get Element Shadow Root | Not yet | | 303 | | Find Element | FindElement | | 304 | | Find Elements | FindElements | | 305 | | Find Element From Element | FindElementFromElement | FindElement | 306 | | Find Elements From Element | FindElementsFromElement | FindElements | 307 | | Find Element From Shadow Root | FindElementFromShadowRoot | | 308 | | Find Elements From Shadow Root | FindElementsFromShadowRoot | | 309 | | Get Element Shadow Root | GetElementShadowRoot | GetShadowRoot | 310 | | Is Element Selected | Not yet | | 311 | | Get Element Attribute | GetElementAttribute | GetAttribute | 312 | | Get Element Property | GetElementProperty | GetProperty | 313 | | Get Element CSS Value | Not yet | | 314 | | Get Element Text | GetElementText | GetText | 315 | | Get Element Tag Name | Not yet | | 316 | | Get Element Rect | Not yet | | 317 | | Is Element Enabled | Not yet | | 318 | | Get Computed Role | Not yet | | 319 | | Get Computed Label | Not yet | | 320 | | Element Click | ElementClick | Click | 321 | | Element Clear | ElementClear | Clear | 322 | | Element Send Keys | *ElementSendKeys* | *SendKeys* | 323 | | Get Page Source | GetPageSource | | 324 | | Execute Script | ExecuteScript | | 325 | | Execute Async Script | ExecuteAsyncScript | | 326 | | Get All Cookies | Not yet | | 327 | | Get Named Cookie | Not yet | | 328 | | Add Cookie | Not yet | | 329 | | Delete Cookie | Not yet | | 330 | | Delete All Cookies | Not yet | | 331 | | Perform Actions | Not yet | | 332 | | Release Actions | Not yet | | 333 | | Dismiss Alert | DismissAlert | | 334 | | Accept Alert | AcceptAlert | | 335 | | Get Alert Text | GetAlertText | | 336 | | Send Alert Text | SendAlertText | | 337 | | Take Screenshot | TakeScreenshot | | 338 | | Take Element Screenshot | TakeElementScreenshot | TakeScreenshot | 339 | | Print Page | Not yet | | 340 | * Browser Capabilities are not listed above. 341 | * Key action(Such as `Enter`, `Shift`, `Control`) has not been implemented. 342 | 343 | ## License 344 | Distributed under the MIT License. See `LICENSE.txt` for more information. 345 | 346 | ## Contribution 347 | Any suggestions for improvement or contribution to this project are appreciated! Creating an issue or pull request! 348 | 349 | ## References 350 | 1. W3C WebDriver Working Draft: 351 | * https://www.w3.org/TR/webdriver/ 352 | 2. The Selenium Browser Automation Project 353 | * https://www.selenium.dev/documentation/webdriver/ 354 | 3. The W3C WebDriver Spec, A Simplified Guide: 355 | * https://github.com/jlipps/simple-wd-spec 356 | 4. geckodriver, WebDriver Reference 357 | * https://developer.mozilla.org/en-US/docs/Web/WebDriver 358 | 5. Capabilities & ChromeOptions 359 | * https://chromedriver.chromium.org/capabilities 360 | 6. Capabilities and EdgeOptions 361 | * https://docs.microsoft.com/en-us/microsoft-edge/webdriver-chromium/capabilities-edge-options 362 | -------------------------------------------------------------------------------- /src/JsonConverter.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "JsonConverter" 2 | '' 3 | ' VBA-JSON v2.3.1 4 | ' (c) Tim Hall - https://github.com/VBA-tools/VBA-JSON 5 | ' 6 | ' JSON Converter for VBA 7 | ' 8 | ' Errors: 9 | ' 10001 - JSON parse error 10 | ' 11 | ' @class JsonConverter 12 | ' @author tim.hall.engr@gmail.com 13 | ' @license MIT (http://www.opensource.org/licenses/mit-license.php) 14 | '' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' 15 | ' 16 | ' Based originally on vba-json (with extensive changes) 17 | ' BSD license included below 18 | ' 19 | ' JSONLib, http://code.google.com/p/vba-json/ 20 | ' 21 | ' Copyright (c) 2013, Ryo Yokoyama 22 | ' All rights reserved. 23 | ' 24 | ' Redistribution and use in source and binary forms, with or without 25 | ' modification, are permitted provided that the following conditions are met: 26 | ' * Redistributions of source code must retain the above copyright 27 | ' notice, this list of conditions and the following disclaimer. 28 | ' * Redistributions in binary form must reproduce the above copyright 29 | ' notice, this list of conditions and the following disclaimer in the 30 | ' documentation and/or other materials provided with the distribution. 31 | ' * Neither the name of the nor the 32 | ' names of its contributors may be used to endorse or promote products 33 | ' derived from this software without specific prior written permission. 34 | ' 35 | ' THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 36 | ' ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 37 | ' WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 38 | ' DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY 39 | ' DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 40 | ' (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 41 | ' LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 42 | ' ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 43 | ' (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 44 | ' SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 45 | ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' 46 | Option Explicit 47 | 48 | ' === VBA-UTC Headers 49 | #If Mac Then 50 | 51 | #If VBA7 Then 52 | 53 | ' 64-bit Mac (2016) 54 | Private Declare PtrSafe Function utc_popen Lib "/usr/lib/libc.dylib" Alias "popen" _ 55 | (ByVal utc_Command As String, ByVal utc_Mode As String) As LongPtr 56 | Private Declare PtrSafe Function utc_pclose Lib "/usr/lib/libc.dylib" Alias "pclose" _ 57 | (ByVal utc_File As LongPtr) As LongPtr 58 | Private Declare PtrSafe Function utc_fread Lib "/usr/lib/libc.dylib" Alias "fread" _ 59 | (ByVal utc_Buffer As String, ByVal utc_Size As LongPtr, ByVal utc_Number As LongPtr, ByVal utc_File As LongPtr) As LongPtr 60 | Private Declare PtrSafe Function utc_feof Lib "/usr/lib/libc.dylib" Alias "feof" _ 61 | (ByVal utc_File As LongPtr) As LongPtr 62 | 63 | #Else 64 | 65 | ' 32-bit Mac 66 | Private Declare Function utc_popen Lib "libc.dylib" Alias "popen" _ 67 | (ByVal utc_Command As String, ByVal utc_Mode As String) As Long 68 | Private Declare Function utc_pclose Lib "libc.dylib" Alias "pclose" _ 69 | (ByVal utc_File As Long) As Long 70 | Private Declare Function utc_fread Lib "libc.dylib" Alias "fread" _ 71 | (ByVal utc_Buffer As String, ByVal utc_Size As Long, ByVal utc_Number As Long, ByVal utc_File As Long) As Long 72 | Private Declare Function utc_feof Lib "libc.dylib" Alias "feof" _ 73 | (ByVal utc_File As Long) As Long 74 | 75 | #End If 76 | 77 | #ElseIf VBA7 Then 78 | 79 | ' http://msdn.microsoft.com/en-us/library/windows/desktop/ms724421.aspx 80 | ' http://msdn.microsoft.com/en-us/library/windows/desktop/ms724949.aspx 81 | ' http://msdn.microsoft.com/en-us/library/windows/desktop/ms725485.aspx 82 | Private Declare PtrSafe Function utc_GetTimeZoneInformation Lib "kernel32" Alias "GetTimeZoneInformation" _ 83 | (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION) As Long 84 | Private Declare PtrSafe Function utc_SystemTimeToTzSpecificLocalTime Lib "kernel32" Alias "SystemTimeToTzSpecificLocalTime" _ 85 | (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION, utc_lpUniversalTime As utc_SYSTEMTIME, utc_lpLocalTime As utc_SYSTEMTIME) As Long 86 | Private Declare PtrSafe Function utc_TzSpecificLocalTimeToSystemTime Lib "kernel32" Alias "TzSpecificLocalTimeToSystemTime" _ 87 | (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION, utc_lpLocalTime As utc_SYSTEMTIME, utc_lpUniversalTime As utc_SYSTEMTIME) As Long 88 | 89 | #Else 90 | 91 | Private Declare Function utc_GetTimeZoneInformation Lib "kernel32" Alias "GetTimeZoneInformation" _ 92 | (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION) As Long 93 | Private Declare Function utc_SystemTimeToTzSpecificLocalTime Lib "kernel32" Alias "SystemTimeToTzSpecificLocalTime" _ 94 | (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION, utc_lpUniversalTime As utc_SYSTEMTIME, utc_lpLocalTime As utc_SYSTEMTIME) As Long 95 | Private Declare Function utc_TzSpecificLocalTimeToSystemTime Lib "kernel32" Alias "TzSpecificLocalTimeToSystemTime" _ 96 | (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION, utc_lpLocalTime As utc_SYSTEMTIME, utc_lpUniversalTime As utc_SYSTEMTIME) As Long 97 | 98 | #End If 99 | 100 | #If Mac Then 101 | 102 | #If VBA7 Then 103 | Private Type utc_ShellResult 104 | utc_Output As String 105 | utc_ExitCode As LongPtr 106 | End Type 107 | 108 | #Else 109 | 110 | Private Type utc_ShellResult 111 | utc_Output As String 112 | utc_ExitCode As Long 113 | End Type 114 | 115 | #End If 116 | 117 | #Else 118 | 119 | Private Type utc_SYSTEMTIME 120 | utc_wYear As Integer 121 | utc_wMonth As Integer 122 | utc_wDayOfWeek As Integer 123 | utc_wDay As Integer 124 | utc_wHour As Integer 125 | utc_wMinute As Integer 126 | utc_wSecond As Integer 127 | utc_wMilliseconds As Integer 128 | End Type 129 | 130 | Private Type utc_TIME_ZONE_INFORMATION 131 | utc_Bias As Long 132 | utc_StandardName(0 To 31) As Integer 133 | utc_StandardDate As utc_SYSTEMTIME 134 | utc_StandardBias As Long 135 | utc_DaylightName(0 To 31) As Integer 136 | utc_DaylightDate As utc_SYSTEMTIME 137 | utc_DaylightBias As Long 138 | End Type 139 | 140 | #End If 141 | ' === End VBA-UTC 142 | 143 | Private Type json_Options 144 | ' VBA only stores 15 significant digits, so any numbers larger than that are truncated 145 | ' 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 146 | ' See: http://support.microsoft.com/kb/269370 147 | ' 148 | ' By default, VBA-JSON will use String for numbers longer than 15 characters that contain only digits 149 | ' to override set `JsonConverter.JsonOptions.UseDoubleForLargeNumbers = True` 150 | UseDoubleForLargeNumbers As Boolean 151 | 152 | ' The JSON standard requires object keys to be quoted (" or '), use this option to allow unquoted keys 153 | AllowUnquotedKeys As Boolean 154 | 155 | ' The solidus (/) is not required to be escaped, use this option to escape them as \/ in ConvertToJson 156 | EscapeSolidus As Boolean 157 | End Type 158 | Public JsonOptions As json_Options 159 | 160 | ' ============================================= ' 161 | ' Public Methods 162 | ' ============================================= ' 163 | 164 | '' 165 | ' Convert JSON string to object (Dictionary/Collection) 166 | ' 167 | ' @method ParseJson 168 | ' @param {String} json_String 169 | ' @return {Object} (Dictionary or Collection) 170 | ' @throws 10001 - JSON parse error 171 | '' 172 | Public Function ParseJson(ByVal JsonString As String) As Object 173 | Dim json_Index As Long 174 | json_Index = 1 175 | 176 | ' Remove vbCr, vbLf, and vbTab from json_String 177 | JsonString = VBA.Replace(VBA.Replace(VBA.Replace(JsonString, VBA.vbCr, ""), VBA.vbLf, ""), VBA.vbTab, "") 178 | 179 | json_SkipSpaces JsonString, json_Index 180 | Select Case VBA.Mid$(JsonString, json_Index, 1) 181 | Case "{" 182 | Set ParseJson = json_ParseObject(JsonString, json_Index) 183 | Case "[" 184 | Set ParseJson = json_ParseArray(JsonString, json_Index) 185 | Case Else 186 | ' Error: Invalid JSON string 187 | Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(JsonString, json_Index, "Expecting '{' or '['") 188 | End Select 189 | End Function 190 | 191 | '' 192 | ' Convert object (Dictionary/Collection/Array) to JSON 193 | ' 194 | ' @method ConvertToJson 195 | ' @param {Variant} JsonValue (Dictionary, Collection, or Array) 196 | ' @param {Integer|String} Whitespace "Pretty" print json with given number of spaces per indentation (Integer) or given string 197 | ' @return {String} 198 | '' 199 | Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitespace As Variant, Optional ByVal json_CurrentIndentation As Long = 0) As String 200 | Dim json_Buffer As String 201 | Dim json_BufferPosition As Long 202 | Dim json_BufferLength As Long 203 | Dim json_Index As Long 204 | Dim json_LBound As Long 205 | Dim json_UBound As Long 206 | Dim json_IsFirstItem As Boolean 207 | Dim json_Index2D As Long 208 | Dim json_LBound2D As Long 209 | Dim json_UBound2D As Long 210 | Dim json_IsFirstItem2D As Boolean 211 | Dim json_Key As Variant 212 | Dim json_Value As Variant 213 | Dim json_DateStr As String 214 | Dim json_Converted As String 215 | Dim json_SkipItem As Boolean 216 | Dim json_PrettyPrint As Boolean 217 | Dim json_Indentation As String 218 | Dim json_InnerIndentation As String 219 | 220 | json_LBound = -1 221 | json_UBound = -1 222 | json_IsFirstItem = True 223 | json_LBound2D = -1 224 | json_UBound2D = -1 225 | json_IsFirstItem2D = True 226 | json_PrettyPrint = Not IsMissing(Whitespace) 227 | 228 | Select Case VBA.VarType(JsonValue) 229 | Case VBA.vbNull 230 | ConvertToJson = "null" 231 | Case VBA.vbDate 232 | ' Date 233 | json_DateStr = ConvertToIso(VBA.CDate(JsonValue)) 234 | 235 | ConvertToJson = """" & json_DateStr & """" 236 | Case VBA.vbString 237 | ' String (or large number encoded as string) 238 | If Not JsonOptions.UseDoubleForLargeNumbers And json_StringIsLargeNumber(JsonValue) Then 239 | ConvertToJson = JsonValue 240 | Else 241 | ConvertToJson = """" & json_Encode(JsonValue) & """" 242 | End If 243 | Case VBA.vbBoolean 244 | If JsonValue Then 245 | ConvertToJson = "true" 246 | Else 247 | ConvertToJson = "false" 248 | End If 249 | Case VBA.vbArray To VBA.vbArray + VBA.vbByte 250 | If json_PrettyPrint Then 251 | If VBA.VarType(Whitespace) = VBA.vbString Then 252 | json_Indentation = VBA.String$(json_CurrentIndentation + 1, Whitespace) 253 | json_InnerIndentation = VBA.String$(json_CurrentIndentation + 2, Whitespace) 254 | Else 255 | json_Indentation = VBA.Space$((json_CurrentIndentation + 1) * Whitespace) 256 | json_InnerIndentation = VBA.Space$((json_CurrentIndentation + 2) * Whitespace) 257 | End If 258 | End If 259 | 260 | ' Array 261 | json_BufferAppend json_Buffer, "[", json_BufferPosition, json_BufferLength 262 | 263 | On Error Resume Next 264 | 265 | json_LBound = LBound(JsonValue, 1) 266 | json_UBound = UBound(JsonValue, 1) 267 | json_LBound2D = LBound(JsonValue, 2) 268 | json_UBound2D = UBound(JsonValue, 2) 269 | 270 | If json_LBound >= 0 And json_UBound >= 0 Then 271 | For json_Index = json_LBound To json_UBound 272 | If json_IsFirstItem Then 273 | json_IsFirstItem = False 274 | Else 275 | ' Append comma to previous line 276 | json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength 277 | End If 278 | 279 | If json_LBound2D >= 0 And json_UBound2D >= 0 Then 280 | ' 2D Array 281 | If json_PrettyPrint Then 282 | json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength 283 | End If 284 | json_BufferAppend json_Buffer, json_Indentation & "[", json_BufferPosition, json_BufferLength 285 | 286 | For json_Index2D = json_LBound2D To json_UBound2D 287 | If json_IsFirstItem2D Then 288 | json_IsFirstItem2D = False 289 | Else 290 | json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength 291 | End If 292 | 293 | json_Converted = ConvertToJson(JsonValue(json_Index, json_Index2D), Whitespace, json_CurrentIndentation + 2) 294 | 295 | ' For Arrays/Collections, undefined (Empty/Nothing) is treated as null 296 | If json_Converted = "" Then 297 | ' (nest to only check if converted = "") 298 | If json_IsUndefined(JsonValue(json_Index, json_Index2D)) Then 299 | json_Converted = "null" 300 | End If 301 | End If 302 | 303 | If json_PrettyPrint Then 304 | json_Converted = vbNewLine & json_InnerIndentation & json_Converted 305 | End If 306 | 307 | json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength 308 | Next json_Index2D 309 | 310 | If json_PrettyPrint Then 311 | json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength 312 | End If 313 | 314 | json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength 315 | json_IsFirstItem2D = True 316 | Else 317 | ' 1D Array 318 | json_Converted = ConvertToJson(JsonValue(json_Index), Whitespace, json_CurrentIndentation + 1) 319 | 320 | ' For Arrays/Collections, undefined (Empty/Nothing) is treated as null 321 | If json_Converted = "" Then 322 | ' (nest to only check if converted = "") 323 | If json_IsUndefined(JsonValue(json_Index)) Then 324 | json_Converted = "null" 325 | End If 326 | End If 327 | 328 | If json_PrettyPrint Then 329 | json_Converted = vbNewLine & json_Indentation & json_Converted 330 | End If 331 | 332 | json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength 333 | End If 334 | Next json_Index 335 | End If 336 | 337 | On Error GoTo 0 338 | 339 | If json_PrettyPrint Then 340 | json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength 341 | 342 | If VBA.VarType(Whitespace) = VBA.vbString Then 343 | json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace) 344 | Else 345 | json_Indentation = VBA.Space$(json_CurrentIndentation * Whitespace) 346 | End If 347 | End If 348 | 349 | json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength 350 | 351 | ConvertToJson = json_BufferToString(json_Buffer, json_BufferPosition) 352 | 353 | ' Dictionary or Collection 354 | Case VBA.vbObject 355 | If json_PrettyPrint Then 356 | If VBA.VarType(Whitespace) = VBA.vbString Then 357 | json_Indentation = VBA.String$(json_CurrentIndentation + 1, Whitespace) 358 | Else 359 | json_Indentation = VBA.Space$((json_CurrentIndentation + 1) * Whitespace) 360 | End If 361 | End If 362 | 363 | ' Dictionary 364 | If VBA.TypeName(JsonValue) = "Dictionary" Then 365 | json_BufferAppend json_Buffer, "{", json_BufferPosition, json_BufferLength 366 | For Each json_Key In JsonValue.Keys 367 | ' For Objects, undefined (Empty/Nothing) is not added to object 368 | json_Converted = ConvertToJson(JsonValue(json_Key), Whitespace, json_CurrentIndentation + 1) 369 | If json_Converted = "" Then 370 | json_SkipItem = json_IsUndefined(JsonValue(json_Key)) 371 | Else 372 | json_SkipItem = False 373 | End If 374 | 375 | If Not json_SkipItem Then 376 | If json_IsFirstItem Then 377 | json_IsFirstItem = False 378 | Else 379 | json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength 380 | End If 381 | 382 | If json_PrettyPrint Then 383 | json_Converted = vbNewLine & json_Indentation & """" & json_Key & """: " & json_Converted 384 | Else 385 | json_Converted = """" & json_Key & """:" & json_Converted 386 | End If 387 | 388 | json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength 389 | End If 390 | Next json_Key 391 | 392 | If json_PrettyPrint Then 393 | json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength 394 | 395 | If VBA.VarType(Whitespace) = VBA.vbString Then 396 | json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace) 397 | Else 398 | json_Indentation = VBA.Space$(json_CurrentIndentation * Whitespace) 399 | End If 400 | End If 401 | 402 | json_BufferAppend json_Buffer, json_Indentation & "}", json_BufferPosition, json_BufferLength 403 | 404 | ' Collection 405 | ElseIf VBA.TypeName(JsonValue) = "Collection" Then 406 | json_BufferAppend json_Buffer, "[", json_BufferPosition, json_BufferLength 407 | For Each json_Value In JsonValue 408 | If json_IsFirstItem Then 409 | json_IsFirstItem = False 410 | Else 411 | json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength 412 | End If 413 | 414 | json_Converted = ConvertToJson(json_Value, Whitespace, json_CurrentIndentation + 1) 415 | 416 | ' For Arrays/Collections, undefined (Empty/Nothing) is treated as null 417 | If json_Converted = "" Then 418 | ' (nest to only check if converted = "") 419 | If json_IsUndefined(json_Value) Then 420 | json_Converted = "null" 421 | End If 422 | End If 423 | 424 | If json_PrettyPrint Then 425 | json_Converted = vbNewLine & json_Indentation & json_Converted 426 | End If 427 | 428 | json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength 429 | Next json_Value 430 | 431 | If json_PrettyPrint Then 432 | json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength 433 | 434 | If VBA.VarType(Whitespace) = VBA.vbString Then 435 | json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace) 436 | Else 437 | json_Indentation = VBA.Space$(json_CurrentIndentation * Whitespace) 438 | End If 439 | End If 440 | 441 | json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength 442 | End If 443 | 444 | ConvertToJson = json_BufferToString(json_Buffer, json_BufferPosition) 445 | Case VBA.vbInteger, VBA.vbLong, VBA.vbSingle, VBA.vbDouble, VBA.vbCurrency, VBA.vbDecimal 446 | ' Number (use decimals for numbers) 447 | ConvertToJson = VBA.Replace(JsonValue, ",", ".") 448 | Case Else 449 | ' vbEmpty, vbError, vbDataObject, vbByte, vbUserDefinedType 450 | ' Use VBA's built-in to-string 451 | On Error Resume Next 452 | ConvertToJson = JsonValue 453 | On Error GoTo 0 454 | End Select 455 | End Function 456 | 457 | ' ============================================= ' 458 | ' Private Functions 459 | ' ============================================= ' 460 | 461 | Private Function json_ParseObject(json_String As String, ByRef json_Index As Long) As Dictionary 462 | Dim json_Key As String 463 | Dim json_NextChar As String 464 | 465 | Set json_ParseObject = New Dictionary 466 | json_SkipSpaces json_String, json_Index 467 | If VBA.Mid$(json_String, json_Index, 1) <> "{" Then 468 | Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting '{'") 469 | Else 470 | json_Index = json_Index + 1 471 | 472 | Do 473 | json_SkipSpaces json_String, json_Index 474 | If VBA.Mid$(json_String, json_Index, 1) = "}" Then 475 | json_Index = json_Index + 1 476 | Exit Function 477 | ElseIf VBA.Mid$(json_String, json_Index, 1) = "," Then 478 | json_Index = json_Index + 1 479 | json_SkipSpaces json_String, json_Index 480 | End If 481 | 482 | json_Key = json_ParseKey(json_String, json_Index) 483 | json_NextChar = json_Peek(json_String, json_Index) 484 | If json_NextChar = "[" Or json_NextChar = "{" Then 485 | Set json_ParseObject.Item(json_Key) = json_ParseValue(json_String, json_Index) 486 | Else 487 | json_ParseObject.Item(json_Key) = json_ParseValue(json_String, json_Index) 488 | End If 489 | Loop 490 | End If 491 | End Function 492 | 493 | Private Function json_ParseArray(json_String As String, ByRef json_Index As Long) As Collection 494 | Set json_ParseArray = New Collection 495 | 496 | json_SkipSpaces json_String, json_Index 497 | If VBA.Mid$(json_String, json_Index, 1) <> "[" Then 498 | Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting '['") 499 | Else 500 | json_Index = json_Index + 1 501 | 502 | Do 503 | json_SkipSpaces json_String, json_Index 504 | If VBA.Mid$(json_String, json_Index, 1) = "]" Then 505 | json_Index = json_Index + 1 506 | Exit Function 507 | ElseIf VBA.Mid$(json_String, json_Index, 1) = "," Then 508 | json_Index = json_Index + 1 509 | json_SkipSpaces json_String, json_Index 510 | End If 511 | 512 | json_ParseArray.Add json_ParseValue(json_String, json_Index) 513 | Loop 514 | End If 515 | End Function 516 | 517 | Private Function json_ParseValue(json_String As String, ByRef json_Index As Long) As Variant 518 | json_SkipSpaces json_String, json_Index 519 | Select Case VBA.Mid$(json_String, json_Index, 1) 520 | Case "{" 521 | Set json_ParseValue = json_ParseObject(json_String, json_Index) 522 | Case "[" 523 | Set json_ParseValue = json_ParseArray(json_String, json_Index) 524 | Case """", "'" 525 | json_ParseValue = json_ParseString(json_String, json_Index) 526 | Case Else 527 | If VBA.Mid$(json_String, json_Index, 4) = "true" Then 528 | json_ParseValue = True 529 | json_Index = json_Index + 4 530 | ElseIf VBA.Mid$(json_String, json_Index, 5) = "false" Then 531 | json_ParseValue = False 532 | json_Index = json_Index + 5 533 | ElseIf VBA.Mid$(json_String, json_Index, 4) = "null" Then 534 | json_ParseValue = Null 535 | json_Index = json_Index + 4 536 | ElseIf VBA.InStr("+-0123456789", VBA.Mid$(json_String, json_Index, 1)) Then 537 | json_ParseValue = json_ParseNumber(json_String, json_Index) 538 | Else 539 | Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting 'STRING', 'NUMBER', null, true, false, '{', or '['") 540 | End If 541 | End Select 542 | End Function 543 | 544 | Private Function json_ParseString(json_String As String, ByRef json_Index As Long) As String 545 | Dim json_Quote As String 546 | Dim json_Char As String 547 | Dim json_Code As String 548 | Dim json_Buffer As String 549 | Dim json_BufferPosition As Long 550 | Dim json_BufferLength As Long 551 | 552 | json_SkipSpaces json_String, json_Index 553 | 554 | ' Store opening quote to look for matching closing quote 555 | json_Quote = VBA.Mid$(json_String, json_Index, 1) 556 | json_Index = json_Index + 1 557 | 558 | Do While json_Index > 0 And json_Index <= Len(json_String) 559 | json_Char = VBA.Mid$(json_String, json_Index, 1) 560 | 561 | Select Case json_Char 562 | Case "\" 563 | ' Escaped string, \\, or \/ 564 | json_Index = json_Index + 1 565 | json_Char = VBA.Mid$(json_String, json_Index, 1) 566 | 567 | Select Case json_Char 568 | Case """", "\", "/", "'" 569 | json_BufferAppend json_Buffer, json_Char, json_BufferPosition, json_BufferLength 570 | json_Index = json_Index + 1 571 | Case "b" 572 | json_BufferAppend json_Buffer, vbBack, json_BufferPosition, json_BufferLength 573 | json_Index = json_Index + 1 574 | Case "f" 575 | json_BufferAppend json_Buffer, vbFormFeed, json_BufferPosition, json_BufferLength 576 | json_Index = json_Index + 1 577 | Case "n" 578 | json_BufferAppend json_Buffer, vbCrLf, json_BufferPosition, json_BufferLength 579 | json_Index = json_Index + 1 580 | Case "r" 581 | json_BufferAppend json_Buffer, vbCr, json_BufferPosition, json_BufferLength 582 | json_Index = json_Index + 1 583 | Case "t" 584 | json_BufferAppend json_Buffer, vbTab, json_BufferPosition, json_BufferLength 585 | json_Index = json_Index + 1 586 | Case "u" 587 | ' Unicode character escape (e.g. \u00a9 = Copyright) 588 | json_Index = json_Index + 1 589 | json_Code = VBA.Mid$(json_String, json_Index, 4) 590 | json_BufferAppend json_Buffer, VBA.ChrW(VBA.Val("&h" + json_Code)), json_BufferPosition, json_BufferLength 591 | json_Index = json_Index + 4 592 | End Select 593 | Case json_Quote 594 | json_ParseString = json_BufferToString(json_Buffer, json_BufferPosition) 595 | json_Index = json_Index + 1 596 | Exit Function 597 | Case Else 598 | json_BufferAppend json_Buffer, json_Char, json_BufferPosition, json_BufferLength 599 | json_Index = json_Index + 1 600 | End Select 601 | Loop 602 | End Function 603 | 604 | Private Function json_ParseNumber(json_String As String, ByRef json_Index As Long) As Variant 605 | Dim json_Char As String 606 | Dim json_Value As String 607 | Dim json_IsLargeNumber As Boolean 608 | 609 | json_SkipSpaces json_String, json_Index 610 | 611 | Do While json_Index > 0 And json_Index <= Len(json_String) 612 | json_Char = VBA.Mid$(json_String, json_Index, 1) 613 | 614 | If VBA.InStr("+-0123456789.eE", json_Char) Then 615 | ' Unlikely to have massive number, so use simple append rather than buffer here 616 | json_Value = json_Value & json_Char 617 | json_Index = json_Index + 1 618 | Else 619 | ' Excel only stores 15 significant digits, so any numbers larger than that are truncated 620 | ' 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 621 | ' See: http://support.microsoft.com/kb/269370 622 | ' 623 | ' Fix: Parse -> String, Convert -> String longer than 15/16 characters containing only numbers and decimal points -> Number 624 | ' (decimal doesn't factor into significant digit count, so if present check for 15 digits + decimal = 16) 625 | json_IsLargeNumber = IIf(InStr(json_Value, "."), Len(json_Value) >= 17, Len(json_Value) >= 16) 626 | If Not JsonOptions.UseDoubleForLargeNumbers And json_IsLargeNumber Then 627 | json_ParseNumber = json_Value 628 | Else 629 | ' VBA.Val does not use regional settings, so guard for comma is not needed 630 | json_ParseNumber = VBA.Val(json_Value) 631 | End If 632 | Exit Function 633 | End If 634 | Loop 635 | End Function 636 | 637 | Private Function json_ParseKey(json_String As String, ByRef json_Index As Long) As String 638 | ' Parse key with single or double quotes 639 | If VBA.Mid$(json_String, json_Index, 1) = """" Or VBA.Mid$(json_String, json_Index, 1) = "'" Then 640 | json_ParseKey = json_ParseString(json_String, json_Index) 641 | ElseIf JsonOptions.AllowUnquotedKeys Then 642 | Dim json_Char As String 643 | Do While json_Index > 0 And json_Index <= Len(json_String) 644 | json_Char = VBA.Mid$(json_String, json_Index, 1) 645 | If (json_Char <> " ") And (json_Char <> ":") Then 646 | json_ParseKey = json_ParseKey & json_Char 647 | json_Index = json_Index + 1 648 | Else 649 | Exit Do 650 | End If 651 | Loop 652 | Else 653 | Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting '""' or '''") 654 | End If 655 | 656 | ' Check for colon and skip if present or throw if not present 657 | json_SkipSpaces json_String, json_Index 658 | If VBA.Mid$(json_String, json_Index, 1) <> ":" Then 659 | Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting ':'") 660 | Else 661 | json_Index = json_Index + 1 662 | End If 663 | End Function 664 | 665 | Private Function json_IsUndefined(ByVal json_Value As Variant) As Boolean 666 | ' Empty / Nothing -> undefined 667 | Select Case VBA.VarType(json_Value) 668 | Case VBA.vbEmpty 669 | json_IsUndefined = True 670 | Case VBA.vbObject 671 | Select Case VBA.TypeName(json_Value) 672 | Case "Empty", "Nothing" 673 | json_IsUndefined = True 674 | End Select 675 | End Select 676 | End Function 677 | 678 | Private Function json_Encode(ByVal json_Text As Variant) As String 679 | ' Reference: http://www.ietf.org/rfc/rfc4627.txt 680 | ' Escape: ", \, /, backspace, form feed, line feed, carriage return, tab 681 | Dim json_Index As Long 682 | Dim json_Char As String 683 | Dim json_AscCode As Long 684 | Dim json_Buffer As String 685 | Dim json_BufferPosition As Long 686 | Dim json_BufferLength As Long 687 | 688 | For json_Index = 1 To VBA.Len(json_Text) 689 | json_Char = VBA.Mid$(json_Text, json_Index, 1) 690 | json_AscCode = VBA.AscW(json_Char) 691 | 692 | ' When AscW returns a negative number, it returns the twos complement form of that number. 693 | ' To convert the twos complement notation into normal binary notation, add 0xFFF to the return result. 694 | ' https://support.microsoft.com/en-us/kb/272138 695 | If json_AscCode < 0 Then 696 | json_AscCode = json_AscCode + 65536 697 | End If 698 | 699 | ' From spec, ", \, and control characters must be escaped (solidus is optional) 700 | 701 | Select Case json_AscCode 702 | Case 34 703 | ' " -> 34 -> \" 704 | json_Char = "\""" 705 | Case 92 706 | ' \ -> 92 -> \\ 707 | json_Char = "\\" 708 | Case 47 709 | ' / -> 47 -> \/ (optional) 710 | If JsonOptions.EscapeSolidus Then 711 | json_Char = "\/" 712 | End If 713 | Case 8 714 | ' backspace -> 8 -> \b 715 | json_Char = "\b" 716 | Case 12 717 | ' form feed -> 12 -> \f 718 | json_Char = "\f" 719 | Case 10 720 | ' line feed -> 10 -> \n 721 | json_Char = "\n" 722 | Case 13 723 | ' carriage return -> 13 -> \r 724 | json_Char = "\r" 725 | Case 9 726 | ' tab -> 9 -> \t 727 | json_Char = "\t" 728 | Case 0 To 31, 127 To 65535 729 | ' Non-ascii characters -> convert to 4-digit hex 730 | json_Char = "\u" & VBA.right$("0000" & VBA.Hex$(json_AscCode), 4) 731 | End Select 732 | 733 | json_BufferAppend json_Buffer, json_Char, json_BufferPosition, json_BufferLength 734 | Next json_Index 735 | 736 | json_Encode = json_BufferToString(json_Buffer, json_BufferPosition) 737 | End Function 738 | 739 | Private Function json_Peek(json_String As String, ByVal json_Index As Long, Optional json_NumberOfCharacters As Long = 1) As String 740 | ' "Peek" at the next number of characters without incrementing json_Index (ByVal instead of ByRef) 741 | json_SkipSpaces json_String, json_Index 742 | json_Peek = VBA.Mid$(json_String, json_Index, json_NumberOfCharacters) 743 | End Function 744 | 745 | Private Sub json_SkipSpaces(json_String As String, ByRef json_Index As Long) 746 | ' Increment index to skip over spaces 747 | Do While json_Index > 0 And json_Index <= VBA.Len(json_String) And VBA.Mid$(json_String, json_Index, 1) = " " 748 | json_Index = json_Index + 1 749 | Loop 750 | End Sub 751 | 752 | Private Function json_StringIsLargeNumber(json_String As Variant) As Boolean 753 | ' Check if the given string is considered a "large number" 754 | ' (See json_ParseNumber) 755 | 756 | Dim json_Length As Long 757 | Dim json_CharIndex As Long 758 | json_Length = VBA.Len(json_String) 759 | 760 | ' Length with be at least 16 characters and assume will be less than 100 characters 761 | If json_Length >= 16 And json_Length <= 100 Then 762 | Dim json_CharCode As String 763 | 764 | json_StringIsLargeNumber = True 765 | 766 | For json_CharIndex = 1 To json_Length 767 | json_CharCode = VBA.Asc(VBA.Mid$(json_String, json_CharIndex, 1)) 768 | Select Case json_CharCode 769 | ' Look for .|0-9|E|e 770 | Case 46, 48 To 57, 69, 101 771 | ' Continue through characters 772 | Case Else 773 | json_StringIsLargeNumber = False 774 | Exit Function 775 | End Select 776 | Next json_CharIndex 777 | End If 778 | End Function 779 | 780 | Private Function json_ParseErrorMessage(json_String As String, ByRef json_Index As Long, ErrorMessage As String) 781 | ' Provide detailed parse error message, including details of where and what occurred 782 | ' 783 | ' Example: 784 | ' Error parsing JSON: 785 | ' {"abcde":True} 786 | ' ^ 787 | ' Expecting 'STRING', 'NUMBER', null, true, false, '{', or '[' 788 | 789 | Dim json_StartIndex As Long 790 | Dim json_StopIndex As Long 791 | 792 | ' Include 10 characters before and after error (if possible) 793 | json_StartIndex = json_Index - 10 794 | json_StopIndex = json_Index + 10 795 | If json_StartIndex <= 0 Then 796 | json_StartIndex = 1 797 | End If 798 | If json_StopIndex > VBA.Len(json_String) Then 799 | json_StopIndex = VBA.Len(json_String) 800 | End If 801 | 802 | json_ParseErrorMessage = "Error parsing JSON:" & VBA.vbNewLine & _ 803 | VBA.Mid$(json_String, json_StartIndex, json_StopIndex - json_StartIndex + 1) & VBA.vbNewLine & _ 804 | VBA.Space$(json_Index - json_StartIndex) & "^" & VBA.vbNewLine & _ 805 | ErrorMessage 806 | End Function 807 | 808 | Private Sub json_BufferAppend(ByRef json_Buffer As String, _ 809 | ByRef json_Append As Variant, _ 810 | ByRef json_BufferPosition As Long, _ 811 | ByRef json_BufferLength As Long) 812 | ' VBA can be slow to append strings due to allocating a new string for each append 813 | ' Instead of using the traditional append, allocate a large empty string and then copy string at append position 814 | ' 815 | ' Example: 816 | ' Buffer: "abc " 817 | ' Append: "def" 818 | ' Buffer Position: 3 819 | ' Buffer Length: 5 820 | ' 821 | ' Buffer position + Append length > Buffer length -> Append chunk of blank space to buffer 822 | ' Buffer: "abc " 823 | ' Buffer Length: 10 824 | ' 825 | ' Put "def" into buffer at position 3 (0-based) 826 | ' Buffer: "abcdef " 827 | ' 828 | ' Approach based on cStringBuilder from vbAccelerator 829 | ' http://www.vbaccelerator.com/home/VB/Code/Techniques/RunTime_Debug_Tracing/VB6_Tracer_Utility_zip_cStringBuilder_cls.asp 830 | ' 831 | ' and clsStringAppend from Philip Swannell 832 | ' https://github.com/VBA-tools/VBA-JSON/pull/82 833 | 834 | Dim json_AppendLength As Long 835 | Dim json_LengthPlusPosition As Long 836 | 837 | json_AppendLength = VBA.Len(json_Append) 838 | json_LengthPlusPosition = json_AppendLength + json_BufferPosition 839 | 840 | If json_LengthPlusPosition > json_BufferLength Then 841 | ' Appending would overflow buffer, add chunk 842 | ' (double buffer length or append length, whichever is bigger) 843 | Dim json_AddedLength As Long 844 | json_AddedLength = IIf(json_AppendLength > json_BufferLength, json_AppendLength, json_BufferLength) 845 | 846 | json_Buffer = json_Buffer & VBA.Space$(json_AddedLength) 847 | json_BufferLength = json_BufferLength + json_AddedLength 848 | End If 849 | 850 | ' Note: Namespacing with VBA.Mid$ doesn't work properly here, throwing compile error: 851 | ' Function call on left-hand side of assignment must return Variant or Object 852 | Mid$(json_Buffer, json_BufferPosition + 1, json_AppendLength) = CStr(json_Append) 853 | json_BufferPosition = json_BufferPosition + json_AppendLength 854 | End Sub 855 | 856 | Private Function json_BufferToString(ByRef json_Buffer As String, ByVal json_BufferPosition As Long) As String 857 | If json_BufferPosition > 0 Then 858 | json_BufferToString = VBA.left$(json_Buffer, json_BufferPosition) 859 | End If 860 | End Function 861 | 862 | '' 863 | ' VBA-UTC v1.0.6 864 | ' (c) Tim Hall - https://github.com/VBA-tools/VBA-UtcConverter 865 | ' 866 | ' UTC/ISO 8601 Converter for VBA 867 | ' 868 | ' Errors: 869 | ' 10011 - UTC parsing error 870 | ' 10012 - UTC conversion error 871 | ' 10013 - ISO 8601 parsing error 872 | ' 10014 - ISO 8601 conversion error 873 | ' 874 | ' @module UtcConverter 875 | ' @author tim.hall.engr@gmail.com 876 | ' @license MIT (http://www.opensource.org/licenses/mit-license.php) 877 | '' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' 878 | 879 | ' (Declarations moved to top) 880 | 881 | ' ============================================= ' 882 | ' Public Methods 883 | ' ============================================= ' 884 | 885 | '' 886 | ' Parse UTC date to local date 887 | ' 888 | ' @method ParseUtc 889 | ' @param {Date} UtcDate 890 | ' @return {Date} Local date 891 | ' @throws 10011 - UTC parsing error 892 | '' 893 | Public Function ParseUtc(utc_UtcDate As Date) As Date 894 | On Error GoTo utc_ErrorHandling 895 | 896 | #If Mac Then 897 | ParseUtc = utc_ConvertDate(utc_UtcDate) 898 | #Else 899 | Dim utc_TimeZoneInfo As utc_TIME_ZONE_INFORMATION 900 | Dim utc_LocalDate As utc_SYSTEMTIME 901 | 902 | utc_GetTimeZoneInformation utc_TimeZoneInfo 903 | utc_SystemTimeToTzSpecificLocalTime utc_TimeZoneInfo, utc_DateToSystemTime(utc_UtcDate), utc_LocalDate 904 | 905 | ParseUtc = utc_SystemTimeToDate(utc_LocalDate) 906 | #End If 907 | 908 | Exit Function 909 | 910 | utc_ErrorHandling: 911 | Err.Raise 10011, "UtcConverter.ParseUtc", "UTC parsing error: " & Err.Number & " - " & Err.Description 912 | End Function 913 | 914 | '' 915 | ' Convert local date to UTC date 916 | ' 917 | ' @method ConvertToUrc 918 | ' @param {Date} utc_LocalDate 919 | ' @return {Date} UTC date 920 | ' @throws 10012 - UTC conversion error 921 | '' 922 | Public Function ConvertToUtc(utc_LocalDate As Date) As Date 923 | On Error GoTo utc_ErrorHandling 924 | 925 | #If Mac Then 926 | ConvertToUtc = utc_ConvertDate(utc_LocalDate, utc_ConvertToUtc:=True) 927 | #Else 928 | Dim utc_TimeZoneInfo As utc_TIME_ZONE_INFORMATION 929 | Dim utc_UtcDate As utc_SYSTEMTIME 930 | 931 | utc_GetTimeZoneInformation utc_TimeZoneInfo 932 | utc_TzSpecificLocalTimeToSystemTime utc_TimeZoneInfo, utc_DateToSystemTime(utc_LocalDate), utc_UtcDate 933 | 934 | ConvertToUtc = utc_SystemTimeToDate(utc_UtcDate) 935 | #End If 936 | 937 | Exit Function 938 | 939 | utc_ErrorHandling: 940 | Err.Raise 10012, "UtcConverter.ConvertToUtc", "UTC conversion error: " & Err.Number & " - " & Err.Description 941 | End Function 942 | 943 | '' 944 | ' Parse ISO 8601 date string to local date 945 | ' 946 | ' @method ParseIso 947 | ' @param {Date} utc_IsoString 948 | ' @return {Date} Local date 949 | ' @throws 10013 - ISO 8601 parsing error 950 | '' 951 | Public Function ParseIso(utc_IsoString As String) As Date 952 | On Error GoTo utc_ErrorHandling 953 | 954 | Dim utc_Parts() As String 955 | Dim utc_DateParts() As String 956 | Dim utc_TimeParts() As String 957 | Dim utc_OffsetIndex As Long 958 | Dim utc_HasOffset As Boolean 959 | Dim utc_NegativeOffset As Boolean 960 | Dim utc_OffsetParts() As String 961 | Dim utc_Offset As Date 962 | 963 | utc_Parts = VBA.Split(utc_IsoString, "T") 964 | utc_DateParts = VBA.Split(utc_Parts(0), "-") 965 | ParseIso = VBA.DateSerial(VBA.CInt(utc_DateParts(0)), VBA.CInt(utc_DateParts(1)), VBA.CInt(utc_DateParts(2))) 966 | 967 | If UBound(utc_Parts) > 0 Then 968 | If VBA.InStr(utc_Parts(1), "Z") Then 969 | utc_TimeParts = VBA.Split(VBA.Replace(utc_Parts(1), "Z", ""), ":") 970 | Else 971 | utc_OffsetIndex = VBA.InStr(1, utc_Parts(1), "+") 972 | If utc_OffsetIndex = 0 Then 973 | utc_NegativeOffset = True 974 | utc_OffsetIndex = VBA.InStr(1, utc_Parts(1), "-") 975 | End If 976 | 977 | If utc_OffsetIndex > 0 Then 978 | utc_HasOffset = True 979 | utc_TimeParts = VBA.Split(VBA.left$(utc_Parts(1), utc_OffsetIndex - 1), ":") 980 | utc_OffsetParts = VBA.Split(VBA.right$(utc_Parts(1), Len(utc_Parts(1)) - utc_OffsetIndex), ":") 981 | 982 | Select Case UBound(utc_OffsetParts) 983 | Case 0 984 | utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), 0, 0) 985 | Case 1 986 | utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), VBA.CInt(utc_OffsetParts(1)), 0) 987 | Case 2 988 | ' VBA.Val does not use regional settings, use for seconds to avoid decimal/comma issues 989 | utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), VBA.CInt(utc_OffsetParts(1)), Int(VBA.Val(utc_OffsetParts(2)))) 990 | End Select 991 | 992 | If utc_NegativeOffset Then: utc_Offset = -utc_Offset 993 | Else 994 | utc_TimeParts = VBA.Split(utc_Parts(1), ":") 995 | End If 996 | End If 997 | 998 | Select Case UBound(utc_TimeParts) 999 | Case 0 1000 | ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), 0, 0) 1001 | Case 1 1002 | ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), VBA.CInt(utc_TimeParts(1)), 0) 1003 | Case 2 1004 | ' VBA.Val does not use regional settings, use for seconds to avoid decimal/comma issues 1005 | ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), VBA.CInt(utc_TimeParts(1)), Int(VBA.Val(utc_TimeParts(2)))) 1006 | End Select 1007 | 1008 | ParseIso = ParseUtc(ParseIso) 1009 | 1010 | If utc_HasOffset Then 1011 | ParseIso = ParseIso - utc_Offset 1012 | End If 1013 | End If 1014 | 1015 | Exit Function 1016 | 1017 | utc_ErrorHandling: 1018 | Err.Raise 10013, "UtcConverter.ParseIso", "ISO 8601 parsing error for " & utc_IsoString & ": " & Err.Number & " - " & Err.Description 1019 | End Function 1020 | 1021 | '' 1022 | ' Convert local date to ISO 8601 string 1023 | ' 1024 | ' @method ConvertToIso 1025 | ' @param {Date} utc_LocalDate 1026 | ' @return {Date} ISO 8601 string 1027 | ' @throws 10014 - ISO 8601 conversion error 1028 | '' 1029 | Public Function ConvertToIso(utc_LocalDate As Date) As String 1030 | On Error GoTo utc_ErrorHandling 1031 | 1032 | ConvertToIso = VBA.format$(ConvertToUtc(utc_LocalDate), "yyyy-mm-ddTHH:mm:ss.000Z") 1033 | 1034 | Exit Function 1035 | 1036 | utc_ErrorHandling: 1037 | Err.Raise 10014, "UtcConverter.ConvertToIso", "ISO 8601 conversion error: " & Err.Number & " - " & Err.Description 1038 | End Function 1039 | 1040 | ' ============================================= ' 1041 | ' Private Functions 1042 | ' ============================================= ' 1043 | 1044 | #If Mac Then 1045 | 1046 | Private Function utc_ConvertDate(utc_Value As Date, Optional utc_ConvertToUtc As Boolean = False) As Date 1047 | Dim utc_ShellCommand As String 1048 | Dim utc_Result As utc_ShellResult 1049 | Dim utc_Parts() As String 1050 | Dim utc_DateParts() As String 1051 | Dim utc_TimeParts() As String 1052 | 1053 | If utc_ConvertToUtc Then 1054 | utc_ShellCommand = "date -ur `date -jf '%Y-%m-%d %H:%M:%S' " & _ 1055 | "'" & VBA.format$(utc_Value, "yyyy-mm-dd HH:mm:ss") & "' " & _ 1056 | " +'%s'` +'%Y-%m-%d %H:%M:%S'" 1057 | Else 1058 | utc_ShellCommand = "date -jf '%Y-%m-%d %H:%M:%S %z' " & _ 1059 | "'" & VBA.format$(utc_Value, "yyyy-mm-dd HH:mm:ss") & " +0000' " & _ 1060 | "+'%Y-%m-%d %H:%M:%S'" 1061 | End If 1062 | 1063 | utc_Result = utc_ExecuteInShell(utc_ShellCommand) 1064 | 1065 | If utc_Result.utc_Output = "" Then 1066 | Err.Raise 10015, "UtcConverter.utc_ConvertDate", "'date' command failed" 1067 | Else 1068 | utc_Parts = Split(utc_Result.utc_Output, " ") 1069 | utc_DateParts = Split(utc_Parts(0), "-") 1070 | utc_TimeParts = Split(utc_Parts(1), ":") 1071 | 1072 | utc_ConvertDate = DateSerial(utc_DateParts(0), utc_DateParts(1), utc_DateParts(2)) + _ 1073 | TimeSerial(utc_TimeParts(0), utc_TimeParts(1), utc_TimeParts(2)) 1074 | End If 1075 | End Function 1076 | 1077 | Private Function utc_ExecuteInShell(utc_ShellCommand As String) As utc_ShellResult 1078 | #If VBA7 Then 1079 | Dim utc_File As LongPtr 1080 | Dim utc_Read As LongPtr 1081 | #Else 1082 | Dim utc_File As Long 1083 | Dim utc_Read As Long 1084 | #End If 1085 | 1086 | Dim utc_Chunk As String 1087 | 1088 | On Error GoTo utc_ErrorHandling 1089 | utc_File = utc_popen(utc_ShellCommand, "r") 1090 | 1091 | If utc_File = 0 Then: Exit Function 1092 | 1093 | Do While utc_feof(utc_File) = 0 1094 | utc_Chunk = VBA.Space$(50) 1095 | utc_Read = CLng(utc_fread(utc_Chunk, 1, Len(utc_Chunk) - 1, utc_File)) 1096 | If utc_Read > 0 Then 1097 | utc_Chunk = VBA.left$(utc_Chunk, CLng(utc_Read)) 1098 | utc_ExecuteInShell.utc_Output = utc_ExecuteInShell.utc_Output & utc_Chunk 1099 | End If 1100 | Loop 1101 | 1102 | utc_ErrorHandling: 1103 | utc_ExecuteInShell.utc_ExitCode = CLng(utc_pclose(utc_File)) 1104 | End Function 1105 | 1106 | #Else 1107 | 1108 | Private Function utc_DateToSystemTime(utc_Value As Date) As utc_SYSTEMTIME 1109 | utc_DateToSystemTime.utc_wYear = VBA.Year(utc_Value) 1110 | utc_DateToSystemTime.utc_wMonth = VBA.Month(utc_Value) 1111 | utc_DateToSystemTime.utc_wDay = VBA.Day(utc_Value) 1112 | utc_DateToSystemTime.utc_wHour = VBA.Hour(utc_Value) 1113 | utc_DateToSystemTime.utc_wMinute = VBA.Minute(utc_Value) 1114 | utc_DateToSystemTime.utc_wSecond = VBA.Second(utc_Value) 1115 | utc_DateToSystemTime.utc_wMilliseconds = 0 1116 | End Function 1117 | 1118 | Private Function utc_SystemTimeToDate(utc_Value As utc_SYSTEMTIME) As Date 1119 | utc_SystemTimeToDate = DateSerial(utc_Value.utc_wYear, utc_Value.utc_wMonth, utc_Value.utc_wDay) + _ 1120 | TimeSerial(utc_Value.utc_wHour, utc_Value.utc_wMinute, utc_Value.utc_wSecond) 1121 | End Function 1122 | 1123 | #End If 1124 | 1125 | -------------------------------------------------------------------------------- /src/Sample.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "Sample" 2 | Option Explicit 3 | 4 | Public driver As WebDriver 5 | 6 | Sub Example() 7 | Set driver = New WebDriver 8 | 9 | driver.Chrome 10 | driver.OpenBrowser 11 | driver.MaximizeWindow 12 | driver.NavigateTo "https://www.selenium.dev/" 13 | driver.FindElement(By.XPath, "/html/body/header/nav/div/ul/li[4]/a").Click 14 | driver.TakeScreenshot ThisWorkbook.path + "./screenshot1.png" 15 | 16 | driver.CloseBrowser 17 | driver.Quit 18 | Set driver = Nothing 19 | End Sub 20 | 21 | Sub Example2() 22 | Set driver = New WebDriver 23 | 24 | driver.Edge 25 | driver.OpenBrowser 26 | driver.NavigateTo "https://www.python.org/" 27 | driver.MaximizeWindow 28 | driver.FindElement(By.ID, "id-search-field").SendKeys "machine learning" 29 | driver.FindElement(By.ID, "submit").Click 30 | driver.TakeScreenshot ThisWorkbook.path + "./screenshot2.png" 31 | driver.MinimizeWindow 32 | driver.CloseBrowser 33 | 34 | driver.Quit 35 | Set driver = Nothing 36 | End Sub 37 | -------------------------------------------------------------------------------- /src/WebDriver.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "WebDriver" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | '------------------------------------------------------------------ 11 | ' SeleniumWrapperVBA v1.1.0 12 | ' 13 | ' Auther: er-ri (https://github.com/er-ri/selenium-wrapper-vba) 14 | ' Date: 2022/03 15 | ' License: MIT (https://opensource.org/licenses/MIT) 16 | '------------------------------------------------------------------ 17 | ' 18 | ' ================================================================= 19 | ' #Class WebDriver 20 | ' ================================================================= 21 | Option Explicit 22 | 23 | ' Standard WebDriver commands. 24 | Public W3C_NEW_SESSION 25 | Public W3C_DELETE_SESSION 26 | Public W3C_STATUS 27 | Public W3C_GET_TIMEOUTS 28 | Public W3C_SET_TIMEOUTS 29 | Public W3C_GO 30 | Public W3C_GET_CURRENT_URL 31 | Public W3C_BACK 32 | Public W3C_FORWARD 33 | Public W3C_REFRESH 34 | Public W3C_GET_TITLE 35 | Public W3C_GET_WINDOW_HANDLE 36 | Public W3C_CLOSE_WINDOW 37 | Public W3C_SWITCH_TO_WINDOW 38 | Public W3C_GET_WINDOW_HANDLES 39 | Public W3C_NEW_WINDOW 40 | Public W3C_SWITCH_TO_FRAME 41 | Public W3C_SWITCH_TO_PARENT_FRAME 42 | Public W3C_GET_WINDOW_RECT 43 | Public W3C_SET_WINDOW_RECT 44 | Public W3C_MAXIMIZE_WINDOW 45 | Public W3C_MINIMIZE_WINDOW 46 | Public W3C_FULLSCREEN_WINDOW 47 | Public W3C_FIND_ELEMENT 48 | Public W3C_FIND_ELEMENTS 49 | Public W3C_FIND_ELEMENT_FROM_ELEMENT 50 | Public W3C_FIND_ELEMENTS_FROM_ELEMENT 51 | Public W3C_FIND_ELEMENT_FROM_SHADOW_ROOT 52 | Public W3C_FIND_ELEMENTS_FROM_SHADOW_ROOT 53 | Public W3C_GET_ACTIVE_ELEMENT 54 | Public W3C_GET_ELEMENT_SHADOW_ROOT 55 | Public W3C_IS_ELEMENT_SELECTED 56 | Public W3C_GET_ELEMENT_ATTRIBUTE 57 | Public W3C_GET_ELEMENT_PROPERTY 58 | Public W3C_GET_ELEMENT_CSS_VALUE 59 | Public W3C_GET_ELEMENT_TEXT 60 | Public W3C_GET_ELEMENT_TAG_NAME 61 | Public W3C_GET_ELEMENT_RECT 62 | Public W3C_IS_ELEMENT_ENABLED 63 | Public W3C_ELEMENT_CLICK 64 | Public W3C_ELEMENT_CLEAR 65 | Public W3C_ELEMENT_SEND_KEYS 66 | Public W3C_GET_PAGE_SOURCE 67 | Public W3C_EXECUTE_SCRIPT 68 | Public W3C_EXECUTE_ASYNC_SCRIPT 69 | Public W3C_GET_ALL_COOKIES 70 | Public W3C_GET_NAMED_COOKIE 71 | Public W3C_ADD_COOKIE 72 | Public W3C_DELETE_COOKIE 73 | Public W3C_DELETE_ALL_COOKIES 74 | Public W3C_PERFORM_ACTIONS 75 | Public W3C_RELEASE_ACTIONS 76 | Public W3C_DISMISS_ALERT 77 | Public W3C_ACCEPT_ALERT 78 | Public W3C_GET_ALERT_TEXT 79 | Public W3C_SEND_ALERT_TEXT 80 | Public W3C_TAKE_SCREENSHOT 81 | Public W3C_TAKE_ELEMENT_SCREENSHOT 82 | 83 | Private Const ELEMENT_KEY = "element-6066-11e4-a52e-4f735466cecf" 84 | Private Const SHADOWROOT_KEY = "shadow-6066-11e4-a52e-4f735466cecf" 85 | 86 | Public Enum By 87 | ClassName = 1 88 | ID = 2 89 | name = 3 90 | LinkText = 4 91 | PartialLinkText = 5 92 | TagName = 6 93 | XPath = 7 94 | CSS = 8 95 | End Enum 96 | 97 | Private m_RemoteEndUrl As String 98 | Private m_PID As String 99 | Private m_MyOptions As WebDriverOptions 100 | 101 | '------------------------------------------------------------------ 102 | ' Encapsulation 103 | '------------------------------------------------------------------ 104 | Public Property Get RemoteEndUrl() As String 105 | RemoteEndUrl = m_RemoteEndUrl 106 | End Property 107 | 108 | Public Property Let RemoteEndUrl(ByVal new_RemoteEndUrl As String) 109 | m_RemoteEndUrl = new_RemoteEndUrl 110 | End Property 111 | 112 | Public Property Get PID() As String 113 | PID = m_PID 114 | End Property 115 | 116 | Public Property Let PID(ByVal new_PID As String) 117 | m_PID = new_PID 118 | End Property 119 | 120 | Public Property Get MyOptions() As WebDriverOptions 121 | Set MyOptions = m_MyOptions 122 | End Property 123 | 124 | Public Property Let MyOptions(ByVal new_MyOptions As WebDriverOptions) 125 | Set m_MyOptions = new_MyOptions 126 | End Property 127 | '------------------------------------------------------------------ 128 | ' Constructor 129 | '------------------------------------------------------------------ 130 | Private Sub Class_Initialize() 131 | W3C_NEW_SESSION = Array("POST", "/session") 132 | W3C_DELETE_SESSION = Array("DELETE", "/session/{session id}") 133 | W3C_STATUS = Array("GET", "/status") 134 | W3C_GET_TIMEOUTS = Array("GET", "/session/{session id}/timeouts") 135 | W3C_SET_TIMEOUTS = Array("POST", "/session/{session id}/timeouts") 136 | W3C_GO = Array("POST", "/session/{session id}/url") 137 | W3C_BACK = Array("POST", "/session/{session id}/back") 138 | W3C_REFRESH = Array("POST", "/session/{session id}/refresh") 139 | W3C_GET_WINDOW_HANDLE = Array("GET", "/session/{session id}/window") 140 | W3C_NEW_WINDOW = Array("POST", "/session/{session id}/window/new") 141 | W3C_SWITCH_TO_WINDOW = Array("POST", "/session/{session id}/window") 142 | W3C_SWITCH_TO_FRAME = Array("POST", "/session/{session id}/frame") 143 | W3C_GET_WINDOW_RECT = Array("GET", "/session/{session id}/window/rect") 144 | W3C_MAXIMIZE_WINDOW = Array("POST", "/session/{session id}/window/maximize") 145 | W3C_FULLSCREEN_WINDOW = Array("POST", "/session/{session id}/window/fullscreen") 146 | W3C_FIND_ELEMENTS = Array("POST", "/session/{session id}/elements") 147 | W3C_FIND_ELEMENTS_FROM_ELEMENT = Array("POST", "/session/{session id}/element/{element id}/elements") 148 | W3C_FIND_ELEMENT_FROM_SHADOW_ROOT = Array("POST", "/session/{session id}/shadow/{shadow id}/element") 149 | W3C_FIND_ELEMENTS_FROM_SHADOW_ROOT = Array("POST", "/session/{session id}/shadow/{shadow id}/elements") 150 | W3C_GET_ELEMENT_SHADOW_ROOT = Array("GET", "/session/{session id}/element/{element id}/shadow") 151 | W3C_IS_ELEMENT_SELECTED = Array("GET", "/session/{session id}/element/{element id}/selected") 152 | W3C_GET_ELEMENT_PROPERTY = Array("GET", "/session/{session id}/element/{element id}/property/{name}") 153 | W3C_GET_ELEMENT_TEXT = Array("GET", "/session/{session id}/element/{element id}/text") 154 | W3C_GET_ELEMENT_RECT = Array("GET", "/session/{session id}/element/{element id}/rect") 155 | W3C_ELEMENT_CLICK = Array("POST", "/session/{session id}/element/{element id}/click") 156 | W3C_ELEMENT_SEND_KEYS = Array("POST", "/session/{session id}/element/{element id}/value") 157 | W3C_EXECUTE_SCRIPT = Array("POST", "/session/{session id}/execute/sync") 158 | W3C_GET_ALL_COOKIES = Array("GET", "/session/{session id}/cookie") 159 | W3C_ADD_COOKIE = Array("POST", "/session/{session id}/cookie") 160 | W3C_DELETE_ALL_COOKIES = Array("DELETE", "/session/{session id)/cookie") 161 | W3C_RELEASE_ACTIONS = Array("DELETE", "/session/{session id}/actions") 162 | W3C_ACCEPT_ALERT = Array("POST", "/session/{session id}/alert/accept") 163 | W3C_SEND_ALERT_TEXT = Array("POST", "/session/{session id}/alert/text") 164 | W3C_TAKE_ELEMENT_SCREENSHOT = Array("GET", "/session/{session id}/element/{element id}/screenshot") 165 | W3C_GET_CURRENT_URL = Array("GET", "/session/{session id}/url") 166 | W3C_FORWARD = Array("POST", "/session/{session id}/forward") 167 | W3C_GET_TITLE = Array("GET", "/session/{session id}/title") 168 | W3C_CLOSE_WINDOW = Array("DELETE", "/session/{session id}/window") 169 | W3C_GET_WINDOW_HANDLES = Array("GET", "/session/{session id}/window/handles") 170 | W3C_SWITCH_TO_PARENT_FRAME = Array("POST", "/session/{session id}/frame/parent") 171 | W3C_SET_WINDOW_RECT = Array("POST", "/session/{session id}/window/rect") 172 | W3C_MINIMIZE_WINDOW = Array("POST", "/session/{session id}/window/minimize") 173 | W3C_FIND_ELEMENT = Array("POST", "/session/{session id}/element") 174 | W3C_FIND_ELEMENT_FROM_ELEMENT = Array("POST", "/session/{session id}/element/{element id}/element") 175 | W3C_GET_ACTIVE_ELEMENT = Array("GET", "/session/{session id}/element/active") 176 | W3C_GET_ELEMENT_ATTRIBUTE = Array("GET", "/session/{session id}/element/{element id}/attribute/{name}") 177 | W3C_GET_ELEMENT_CSS_VALUE = Array("GET", "/session/{session id}/element/{element id}/css/{property name}") 178 | W3C_GET_ELEMENT_TAG_NAME = Array("GET", "/session/{session id}/element/{element id}/name") 179 | W3C_IS_ELEMENT_ENABLED = Array("GET", "/session/{session id}/element/{element id}/enabled") 180 | W3C_ELEMENT_CLEAR = Array("POST", "/session/{session id}/element/{element id}/clear") 181 | W3C_GET_PAGE_SOURCE = Array("GET", "/session/{session id}/source") 182 | W3C_EXECUTE_ASYNC_SCRIPT = Array("POST", "/session/{session id}/execute/async") 183 | W3C_GET_NAMED_COOKIE = Array("GET", "/session/{session id}/cookie/{name}") 184 | W3C_DELETE_COOKIE = Array("DELETE", "/session/{session id}/cookie/{name}") 185 | W3C_PERFORM_ACTIONS = Array("POST", "/session/{session id}/actions") 186 | W3C_DISMISS_ALERT = Array("POST", "/session/{session id}/alert/dismiss") 187 | W3C_GET_ALERT_TEXT = Array("GET", "/session/{session id}/alert/text") 188 | W3C_TAKE_SCREENSHOT = Array("GET", "/session/{session id}/screenshot") 189 | W3C_TAKE_ELEMENT_SCREENSHOT = Array("GET", "/session/{session id}/element/{element id}/screenshot") 190 | 191 | MyOptions = New WebDriverOptions 192 | End Sub 193 | 194 | '------------------------------------------------------------------ 195 | ' Browser Implementation 196 | '------------------------------------------------------------------ 197 | Public Sub Edge(Optional ByVal driverPath As String = "msedgedriver.exe", _ 198 | Optional ByVal port As Integer = 9516, _ 199 | Optional ByVal winStyle As VbAppWinStyle = vbMinimizedNoFocus) 200 | Dim cmdLaunch As String 201 | 202 | cmdLaunch = driverPath & " --port=" & CStr(port) 203 | RemoteEndUrl = "http://localhost:" & CStr(port) 204 | PID = Shell(cmdLaunch, winStyle) 205 | End Sub 206 | 207 | Public Sub Chrome(Optional ByVal driverPath As String = "chromedriver.exe", _ 208 | Optional ByVal port As Integer = 9515, _ 209 | Optional ByVal winStyle As VbAppWinStyle = vbMinimizedNoFocus) 210 | Dim cmdLaunch As String 211 | 212 | cmdLaunch = driverPath & " --port=" & CStr(port) 213 | RemoteEndUrl = "http://localhost:" & CStr(port) 214 | PID = Shell(cmdLaunch, winStyle) 215 | End Sub 216 | 217 | Public Sub Firefox(Optional ByVal driverPath As String = "geckodriver.exe", _ 218 | Optional ByVal port As Integer = 4444, _ 219 | Optional ByVal winStyle As VbAppWinStyle = vbMinimizedNoFocus) 220 | Dim cmdLaunch As String 221 | 222 | cmdLaunch = driverPath & " --port " & CStr(port) 223 | RemoteEndUrl = "http://localhost:" & CStr(port) 224 | PID = Shell(cmdLaunch, winStyle) 225 | End Sub 226 | 227 | Public Sub InternetExplorer(Optional ByVal driverPath As String = "IEDriverServer.exe", _ 228 | Optional ByVal port = 5555, _ 229 | Optional ByVal winStyle As VbAppWinStyle = vbMinimizedNoFocus) 230 | Dim cmdLaunch As String 231 | 232 | cmdLaunch = driverPath & " /port=" & CStr(port) 233 | RemoteEndUrl = "http://localhost:" & CStr(port) 234 | PID = Shell(cmdLaunch, winStyle) 235 | End Sub 236 | 237 | Public Sub Quit() 238 | Shell "taskkill /T /F /pid " & PID 239 | End Sub 240 | 241 | '------------------------------------------------------------------ 242 | ' W3C Standard Endpoints 243 | ' https://www.w3.org/TR/webdriver/ 244 | '------------------------------------------------------------------ 245 | Public Sub OpenBrowser(Optional ByVal userOptions As WebDriverOptions = Nothing) 246 | Dim urlParameters As New Dictionary, _ 247 | requestBody As New Dictionary, _ 248 | responseBody As Dictionary 249 | 250 | If Not userOptions Is Nothing Then 251 | MyOptions = userOptions 252 | End If 253 | 254 | requestBody.Add "capabilities", MyOptions.ConstructCapabilities() 255 | 256 | Set responseBody = SendCommand2Webdriver(W3C_NEW_SESSION, urlParameters, requestBody) 257 | 258 | MyOptions.Capabilities = responseBody("value") 259 | End Sub 260 | 261 | Public Sub CloseBrowser() 262 | Dim urlParameters As New Dictionary 263 | 264 | urlParameters.Add "{session id}", MyOptions.Capabilities("sessionId") 265 | 266 | SendCommand2Webdriver W3C_DELETE_SESSION, urlParameters 267 | End Sub 268 | 269 | Public Function GetStatus() 270 | Dim urlParameters As New Dictionary, _ 271 | requestBody As New Dictionary, _ 272 | responseBody As Dictionary 273 | 274 | Set responseBody = SendCommand2Webdriver(W3C_STATUS, urlParameters, requestBody) 275 | 276 | Set GetStatus = responseBody("value") 277 | End Function 278 | 279 | Public Function GetTimeouts() 280 | Dim urlParameters As New Dictionary, _ 281 | requestBody As New Dictionary, _ 282 | responseBody As Dictionary 283 | 284 | urlParameters.Add "{session id}", MyOptions.Capabilities("sessionId") 285 | 286 | Set responseBody = SendCommand2Webdriver(W3C_GET_TIMEOUTS, urlParameters, requestBody) 287 | 288 | Set GetTimeouts = responseBody("value") 289 | End Function 290 | 291 | Public Sub SetTimeouts(Optional ByVal script As Long = 30000, _ 292 | Optional ByVal pageLoad As Long = 300000, _ 293 | Optional ByVal implicit As Long = 0) 294 | Dim urlParameters As New Dictionary, _ 295 | requestBody As New Dictionary 296 | 297 | urlParameters.Add "{session id}", MyOptions.Capabilities("sessionId") 298 | requestBody.Add "script", script 299 | requestBody.Add "pageLoad", pageLoad 300 | requestBody.Add "implicit", implicit ' a time to wait in milliseconds for the element location strategy 301 | 302 | SendCommand2Webdriver W3C_SET_TIMEOUTS, urlParameters, requestBody 303 | End Sub 304 | 305 | Public Sub NavigateTo(ByVal url As String) 306 | Dim urlParameters As New Dictionary, _ 307 | requestBody As New Dictionary 308 | 309 | urlParameters.Add "{session id}", MyOptions.Capabilities("sessionId") 310 | requestBody.Add "url", url 311 | 312 | SendCommand2Webdriver W3C_GO, urlParameters, requestBody 313 | End Sub 314 | 315 | Public Function GetCurrentURL() As String 316 | Dim urlParameters As New Dictionary, _ 317 | requestBody As New Dictionary, _ 318 | responseBody As Dictionary 319 | 320 | urlParameters.Add "{session id}", MyOptions.Capabilities("sessionId") 321 | 322 | Set responseBody = SendCommand2Webdriver(W3C_GET_CURRENT_URL, urlParameters, requestBody) 323 | 324 | GetCurrentURL = responseBody("value") 325 | End Function 326 | 327 | Public Sub Back() 328 | Dim urlParameters As New Dictionary, _ 329 | requestBody As New Dictionary 330 | 331 | urlParameters.Add "{session id}", MyOptions.Capabilities("sessionId") 332 | 333 | SendCommand2Webdriver W3C_BACK, urlParameters, requestBody 334 | End Sub 335 | 336 | Public Sub Forward() 337 | Dim urlParameters As New Dictionary, _ 338 | requestBody As New Dictionary 339 | 340 | urlParameters.Add "{session id}", MyOptions.Capabilities("sessionId") 341 | 342 | SendCommand2Webdriver W3C_FORWARD, urlParameters, requestBody 343 | End Sub 344 | 345 | Public Sub Refresh() 346 | Dim urlParameters As New Dictionary, _ 347 | requestBody As New Dictionary 348 | 349 | urlParameters.Add "{session id}", MyOptions.Capabilities("sessionId") 350 | 351 | SendCommand2Webdriver W3C_REFRESH, urlParameters, requestBody 352 | End Sub 353 | 354 | Public Function GetTitle() As String 355 | Dim urlParameters As New Dictionary, _ 356 | requestBody As New Dictionary, _ 357 | responseBody As Dictionary 358 | 359 | urlParameters.Add "{session id}", MyOptions.Capabilities("sessionId") 360 | 361 | Set responseBody = SendCommand2Webdriver(W3C_GET_TITLE, urlParameters, requestBody) 362 | 363 | GetTitle = responseBody("value") 364 | End Function 365 | 366 | Public Function GetWindowHandle() 367 | Dim urlParameters As New Dictionary, _ 368 | requestBody As New Dictionary, _ 369 | responseBody As Dictionary 370 | 371 | urlParameters.Add "{session id}", MyOptions.Capabilities("sessionId") 372 | 373 | Set responseBody = SendCommand2Webdriver(W3C_GET_WINDOW_HANDLE, urlParameters, requestBody) 374 | 375 | GetWindowHandle = responseBody("value") 376 | End Function 377 | 378 | Public Sub CloseWindow() 379 | Dim urlParameters As New Dictionary, _ 380 | requestBody As New Dictionary 381 | 382 | urlParameters.Add "{session id}", MyOptions.Capabilities("sessionId") 383 | 384 | SendCommand2Webdriver W3C_CLOSE_WINDOW, urlParameters, requestBody 385 | End Sub 386 | 387 | Public Sub SwitchToWindow(ByVal handle As String) 388 | Dim urlParameters As New Dictionary, _ 389 | requestBody As New Dictionary 390 | 391 | urlParameters.Add "{session id}", MyOptions.Capabilities("sessionId") 392 | requestBody.Add "handle", handle 393 | 394 | SendCommand2Webdriver W3C_SWITCH_TO_WINDOW, urlParameters, requestBody 395 | End Sub 396 | 397 | Public Function GetWindowHandles() 398 | Dim urlParameters As New Dictionary, _ 399 | requestBody As New Dictionary, _ 400 | responseBody As Dictionary 401 | 402 | urlParameters.Add "{session id}", MyOptions.Capabilities("sessionId") 403 | 404 | Set responseBody = SendCommand2Webdriver(W3C_GET_WINDOW_HANDLES, urlParameters, requestBody) 405 | 406 | Set GetWindowHandles = responseBody("value") 407 | End Function 408 | 409 | ' Return: JSON Object 410 | ' "handle": The value of handle. 411 | ' "type": Let type be "tab" if the newly created window shares an OS-level window with the current browsing context, or "window" otherwise. 412 | Public Function NewWindow() As Dictionary 413 | Dim urlParameters As New Dictionary, _ 414 | requestBody As New Dictionary, _ 415 | responseBody As Dictionary 416 | 417 | urlParameters.Add "{session id}", MyOptions.Capabilities("sessionId") 418 | 419 | Set responseBody = SendCommand2Webdriver(W3C_NEW_WINDOW, urlParameters, requestBody) 420 | 421 | Set NewWindow = responseBody("value") 422 | End Function 423 | 424 | Public Function SwitchToFrame(ByVal frame As WebElement) As Boolean 425 | Dim urlParameters As New Dictionary, _ 426 | requestBody As New Dictionary, _ 427 | responseBody As Dictionary 428 | 429 | urlParameters.Add "{session id}", frame.driver.MyOptions.Capabilities("sessionId") 430 | requestBody.Add "id", frame.elementJson 431 | 432 | Set responseBody = SendCommand2Webdriver(W3C_SWITCH_TO_FRAME, urlParameters, requestBody) 433 | 434 | SwitchToFrame = True 435 | End Function 436 | 437 | Public Function SwitchToParentFrame() As Boolean 438 | Dim urlParameters As New Dictionary, _ 439 | requestBody As New Dictionary, _ 440 | responseBody As Dictionary 441 | 442 | urlParameters.Add "{session id}", MyOptions.Capabilities("sessionId") 443 | 444 | Set responseBody = SendCommand2Webdriver(W3C_SWITCH_TO_PARENT_FRAME, urlParameters, requestBody) 445 | 446 | SwitchToParentFrame = True 447 | End Function 448 | 449 | Public Function GetWindowRect() As Dictionary 450 | Dim urlParameters As New Dictionary, _ 451 | requestBody As New Dictionary, _ 452 | responseBody As Dictionary 453 | 454 | urlParameters.Add "{session id}", MyOptions.Capabilities("sessionId") 455 | Set responseBody = SendCommand2Webdriver(W3C_GET_WINDOW_RECT, urlParameters, requestBody) 456 | 457 | Set GetWindowRect = responseBody("value") 458 | End Function 459 | 460 | Public Function SetWindowRect(Optional ByVal x As Integer, _ 461 | Optional ByVal y As Integer, _ 462 | Optional ByVal width As Integer, _ 463 | Optional ByVal height As Integer) 464 | Dim urlParameters As New Dictionary, _ 465 | requestBody As New Dictionary, _ 466 | responseBody As Dictionary 467 | 468 | urlParameters.Add "{session id}", MyOptions.Capabilities("sessionId") 469 | 470 | If x <> 0 Then requestBody.Add "x", x 471 | If y <> 0 Then requestBody.Add "y", y 472 | If width <> 0 Then requestBody.Add "width", width 473 | If height <> 0 Then requestBody.Add "height", height 474 | 475 | Set responseBody = SendCommand2Webdriver(W3C_SET_WINDOW_RECT, urlParameters, requestBody) 476 | 477 | Set SetWindowRect = responseBody("value") 478 | End Function 479 | 480 | ' Return: JSON Object 481 | ' "x": the screenX attribute of the window object 482 | ' "y": the screenY attribute of the window object 483 | ' "width": the width of the outer dimensions of the top-level browsing context, including browser chrome etc... 484 | ' "height": the height of the outer dimensions of the top-level browsing context, including browser chrome etc... 485 | Public Function MaximizeWindow() As Dictionary 486 | Dim urlParameters As New Dictionary, _ 487 | requestBody As New Dictionary, _ 488 | responseBody As Dictionary 489 | 490 | urlParameters.Add "{session id}", MyOptions.Capabilities("sessionId") 491 | 492 | Set responseBody = SendCommand2Webdriver(W3C_MAXIMIZE_WINDOW, urlParameters, requestBody) 493 | 494 | Set MaximizeWindow = responseBody("value") 495 | End Function 496 | 497 | ' Return: JSON Object 498 | ' "x": the screenX attribute of the window object 499 | ' "y": the screenY attribute of the window object 500 | ' "width": the width of the outer dimensions of the top-level browsing context, including browser chrome etc... 501 | ' "height": the height of the outer dimensions of the top-level browsing context, including browser chrome etc... 502 | Public Function MinimizeWindow() 503 | Dim urlParameters As New Dictionary, _ 504 | requestBody As New Dictionary, _ 505 | responseBody As Dictionary 506 | 507 | urlParameters.Add "{session id}", MyOptions.Capabilities("sessionId") 508 | 509 | Set responseBody = SendCommand2Webdriver(W3C_MINIMIZE_WINDOW, urlParameters, requestBody) 510 | 511 | Set MinimizeWindow = responseBody("value") 512 | End Function 513 | 514 | Public Function FullscreenWindow() 515 | Dim urlParameters As New Dictionary, _ 516 | requestBody As New Dictionary, _ 517 | responseBody As Dictionary 518 | 519 | urlParameters.Add "{session id}", MyOptions.Capabilities("sessionId") 520 | 521 | Set responseBody = SendCommand2Webdriver(W3C_FULLSCREEN_WINDOW, urlParameters, requestBody) 522 | 523 | Set FullscreenWindow = responseBody("value") 524 | End Function 525 | 526 | Public Function FindElement(ByVal by_strategy As By, _ 527 | ByVal target As String) As WebElement 528 | Dim urlParameters As New Dictionary, _ 529 | requestBody As New Dictionary, _ 530 | responseBody As Dictionary 531 | 532 | urlParameters.Add "{session id}", MyOptions.Capabilities("sessionId") 533 | Set requestBody = SelectLocationStrategies(by_strategy, target) 534 | 535 | Set responseBody = SendCommand2Webdriver(W3C_FIND_ELEMENT, urlParameters, requestBody) 536 | 537 | Set FindElement = Convert2WebElement(responseBody("value")) 538 | End Function 539 | 540 | Public Function FindElements(ByVal by_strategy As By, _ 541 | ByVal target As String) As Variant 542 | Dim urlParameters As New Dictionary, _ 543 | requestBody As New Dictionary, _ 544 | responseBody As Dictionary 545 | 546 | Dim elements() As WebElement 547 | FindElements = elements 548 | 549 | urlParameters.Add "{session id}", MyOptions.Capabilities("sessionId") 550 | Set requestBody = SelectLocationStrategies(by_strategy, target) 551 | 552 | Set responseBody = SendCommand2Webdriver(W3C_FIND_ELEMENTS, urlParameters, requestBody) 553 | If responseBody("value").Count = 0 Then Exit Function 554 | 555 | Dim counter As Integer 556 | Dim elementJson As Dictionary 557 | ReDim elements(responseBody("value").Count - 1) 558 | 559 | counter = 0 560 | For Each elementJson In responseBody("value") 561 | ReDim Preserve elements(counter) 562 | Set elements(counter) = Convert2WebElement(elementJson) 563 | counter = counter + 1 564 | Next 565 | 566 | FindElements = elements 567 | End Function 568 | 569 | Public Function FindElementFromElement(ByVal element As WebElement, _ 570 | ByVal by_strategy As By, _ 571 | ByVal target As String) As WebElement 572 | Dim urlParameters As New Dictionary, _ 573 | requestBody As New Dictionary, _ 574 | responseBody As Dictionary 575 | 576 | urlParameters.Add "{session id}", MyOptions.Capabilities("sessionId") 577 | urlParameters.Add "{element id}", element.elementJson(ELEMENT_KEY) 578 | 579 | Set requestBody = SelectLocationStrategies(by_strategy, target) 580 | 581 | Set responseBody = SendCommand2Webdriver(W3C_FIND_ELEMENT_FROM_ELEMENT, urlParameters, requestBody) 582 | 583 | Set FindElementFromElement = Convert2WebElement(responseBody("value")) 584 | End Function 585 | 586 | Public Function FindElementsFromElement(ByVal element As WebElement, _ 587 | ByVal by_strategy As By, _ 588 | ByVal target As String) As Variant 589 | Dim urlParameters As New Dictionary, _ 590 | requestBody As New Dictionary, _ 591 | responseBody As Dictionary 592 | 593 | Dim elements() As WebElement 594 | FindElementsFromElement = elements 595 | 596 | urlParameters.Add "{session id}", MyOptions.Capabilities("sessionId") 597 | urlParameters.Add "{element id}", element.elementJson(ELEMENT_KEY) 598 | 599 | Set requestBody = SelectLocationStrategies(by_strategy, target) 600 | 601 | Set responseBody = SendCommand2Webdriver(W3C_FIND_ELEMENTS_FROM_ELEMENT, urlParameters, requestBody) 602 | If responseBody("value").Count = 0 Then Exit Function 603 | 604 | Dim counter As Integer 605 | Dim elementJson As Dictionary 606 | ReDim elements(responseBody("value").Count - 1) 607 | 608 | counter = 0 609 | For Each elementJson In responseBody("value") 610 | ReDim Preserve elements(counter) 611 | Set elements(counter) = Convert2WebElement(elementJson) 612 | counter = counter + 1 613 | Next 614 | 615 | FindElementsFromElement = elements 616 | End Function 617 | 618 | Public Function FindElementFromShadowRoot(ByVal shadowRoot As WebElement, _ 619 | ByVal by_strategy As By, _ 620 | ByVal target As String) As Variant 621 | Dim urlParameters As New Dictionary, _ 622 | requestBody As New Dictionary, _ 623 | responseBody As Dictionary 624 | 625 | urlParameters.Add "{session id}", MyOptions.Capabilities("sessionId") 626 | urlParameters.Add "{shadow id}", shadowRoot.elementJson(SHADOWROOT_KEY) 627 | 628 | Set requestBody = SelectLocationStrategies(by_strategy, target) 629 | Set responseBody = SendCommand2Webdriver(W3C_FIND_ELEMENT_FROM_SHADOW_ROOT, urlParameters, requestBody) 630 | 631 | Set FindElementFromShadowRoot = Convert2WebElement(responseBody("value")) 632 | End Function 633 | 634 | Public Function FindElementsFromShadowRoot(ByVal shadowRoot As WebElement, _ 635 | ByVal by_strategy As By, _ 636 | ByVal target As String) As Variant 637 | Dim urlParameters As New Dictionary, _ 638 | requestBody As New Dictionary, _ 639 | responseBody As Dictionary 640 | 641 | Dim elements() As WebElement 642 | FindElementsFromShadowRoot = elements 643 | 644 | urlParameters.Add "{session id}", MyOptions.Capabilities("sessionId") 645 | urlParameters.Add "{shadow id}", shadowRoot.elementJson(SHADOWROOT_KEY) 646 | 647 | Set requestBody = SelectLocationStrategies(by_strategy, target) 648 | 649 | Set responseBody = SendCommand2Webdriver(W3C_FIND_ELEMENTS_FROM_SHADOW_ROOT, urlParameters, requestBody) 650 | If responseBody("value").Count = 0 Then Exit Function 651 | 652 | Dim counter As Integer 653 | Dim elementJson As Dictionary 654 | ReDim elements(responseBody("value").Count - 1) 655 | 656 | counter = 0 657 | For Each elementJson In responseBody("value") 658 | ReDim Preserve elements(counter) 659 | Set elements(counter) = Convert2WebElement(elementJson) 660 | counter = counter + 1 661 | Next 662 | 663 | FindElementsFromShadowRoot = elements 664 | End Function 665 | 666 | Public Function GetElementShadowRoot(ByVal element As WebElement) As Variant 667 | Dim urlParameters As New Dictionary, _ 668 | requestBody As New Dictionary, _ 669 | responseBody As Dictionary 670 | 671 | urlParameters.Add "{session id}", MyOptions.Capabilities("sessionId") 672 | urlParameters.Add "{element id}", element.elementJson(ELEMENT_KEY) 673 | 674 | Set responseBody = SendCommand2Webdriver(W3C_GET_ELEMENT_SHADOW_ROOT, urlParameters, requestBody) 675 | 676 | Set GetElementShadowRoot = Convert2WebElement(responseBody("value")) 677 | End Function 678 | 679 | Public Function GetElementAttribute(ByVal element As WebElement, _ 680 | ByVal name As String) 681 | Dim urlParameters As New Dictionary, _ 682 | requestBody As New Dictionary, _ 683 | responseBody As Dictionary 684 | 685 | urlParameters.Add "{session id}", MyOptions.Capabilities("sessionId") 686 | urlParameters.Add "{element id}", element.elementJson(ELEMENT_KEY) 687 | urlParameters.Add "{name}", name 688 | 689 | Set responseBody = SendCommand2Webdriver(W3C_GET_ELEMENT_ATTRIBUTE, urlParameters, requestBody) 690 | 691 | GetElementAttribute = responseBody("value") 692 | End Function 693 | 694 | Public Function GetElementProperty(ByVal element As WebElement, _ 695 | ByVal name As String) 696 | Dim urlParameters As New Dictionary, _ 697 | requestBody As New Dictionary, _ 698 | responseBody As Dictionary 699 | 700 | urlParameters.Add "{session id}", MyOptions.Capabilities("sessionId") 701 | urlParameters.Add "{element id}", element.elementJson(ELEMENT_KEY) 702 | urlParameters.Add "{name}", name 703 | 704 | Set responseBody = SendCommand2Webdriver(W3C_GET_ELEMENT_PROPERTY, urlParameters, requestBody) 705 | 706 | GetElementProperty = responseBody("value") 707 | End Function 708 | 709 | Public Function GetElementText(ByVal element As WebElement) As String 710 | Dim urlParameters As New Dictionary, _ 711 | requestBody As New Dictionary, _ 712 | responseBody As Dictionary 713 | 714 | urlParameters.Add "{session id}", MyOptions.Capabilities("sessionId") 715 | urlParameters.Add "{element id}", element.elementJson(ELEMENT_KEY) 716 | 717 | Set responseBody = SendCommand2Webdriver(W3C_GET_ELEMENT_TEXT, urlParameters, requestBody) 718 | 719 | GetElementText = responseBody("value") 720 | End Function 721 | 722 | Public Sub ElementClick(ByVal element As WebElement) 723 | Dim urlParameters As New Dictionary, _ 724 | requestBody As New Dictionary 725 | 726 | urlParameters.Add "{session id}", MyOptions.Capabilities("sessionId") 727 | urlParameters.Add "{element id}", element.elementJson(ELEMENT_KEY) 728 | 729 | SendCommand2Webdriver W3C_ELEMENT_CLICK, urlParameters, requestBody 730 | End Sub 731 | 732 | Public Sub ElementClear(ByVal element As WebElement) 733 | Dim urlParameters As New Dictionary, _ 734 | requestBody As New Dictionary 735 | 736 | urlParameters.Add "{session id}", MyOptions.Capabilities("sessionId") 737 | urlParameters.Add "{element id}", element.elementJson(ELEMENT_KEY) 738 | 739 | SendCommand2Webdriver W3C_ELEMENT_CLEAR, urlParameters, requestBody 740 | End Sub 741 | 742 | Public Sub ElementSendKeys(text As String, ByVal element As WebElement) 743 | Dim urlParameters As New Dictionary, _ 744 | requestBody As New Dictionary 745 | 746 | urlParameters.Add "{session id}", MyOptions.Capabilities("sessionId") 747 | urlParameters.Add "{element id}", element.elementJson(ELEMENT_KEY) 748 | 749 | requestBody.Add "text", text 750 | 751 | SendCommand2Webdriver W3C_ELEMENT_SEND_KEYS, urlParameters, requestBody 752 | End Sub 753 | 754 | Public Function GetPageSource() 755 | Dim urlParameters As New Dictionary, _ 756 | requestBody As New Dictionary, _ 757 | responseBody As Dictionary 758 | 759 | urlParameters.Add "{session id}", MyOptions.Capabilities("sessionId") 760 | 761 | Set responseBody = SendCommand2Webdriver(W3C_GET_PAGE_SOURCE, urlParameters, requestBody) 762 | 763 | GetPageSource = responseBody("value") 764 | End Function 765 | 766 | 'Change any WebElement objects passed in to instead be their elementJson 767 | Private Function FormatWebElementArgs(ByRef args() As Variant) As Variant 768 | Dim i As Integer 769 | Dim argsFormat() As Variant 770 | 771 | For i = 0 To UBound(args) 772 | ReDim Preserve argsFormat(i) 773 | 774 | If TypeOf args(i) Is WebElement Then 775 | Set argsFormat(i) = args(i).elementJson 776 | Else 777 | argsFormat(i) = args(i) 778 | End If 779 | Next i 780 | 781 | FormatWebElementArgs = argsFormat 782 | End Function 783 | 784 | Public Function ExecuteScript(ByVal script As String, ParamArray args() As Variant) As Variant 785 | Dim urlParameters As New Dictionary, _ 786 | requestBody As New Dictionary, _ 787 | responseBody As Dictionary 788 | Dim argsFormat() As Variant 789 | 790 | urlParameters.Add "{session id}", MyOptions.Capabilities("sessionId") 791 | 792 | argsFormat = args ' Pass a ParamArray to another function directly will raise "Invalid ParamArray use" Exception 793 | argsFormat = FormatWebElementArgs(argsFormat) 794 | 795 | requestBody.Add "script", script 796 | requestBody.Add "args", argsFormat 797 | 798 | Set responseBody = SendCommand2Webdriver(W3C_EXECUTE_SCRIPT, urlParameters, requestBody) 799 | 800 | ExecuteScript = responseBody("value") 801 | End Function 802 | 803 | Public Function ExecuteAsyncScript(ByVal script As String, ParamArray args() As Variant) As Variant 804 | Dim urlParameters As New Dictionary, _ 805 | requestBody As New Dictionary, _ 806 | responseBody As Dictionary 807 | Dim argsFormat() As Variant 808 | 809 | urlParameters.Add "{session id}", MyOptions.Capabilities("sessionId") 810 | 811 | argsFormat = args 812 | argsFormat = FormatWebElementArgs(argsFormat) 813 | 814 | requestBody.Add "script", script 815 | requestBody.Add "args", argsFormat 816 | 817 | Set responseBody = SendCommand2Webdriver(W3C_EXECUTE_ASYNC_SCRIPT, urlParameters, requestBody) 818 | 819 | ExecuteAsyncScript = responseBody("value") 820 | End Function 821 | 822 | 823 | Public Sub DismissAlert() 824 | Dim urlParameters As New Dictionary, _ 825 | requestBody As New Dictionary 826 | 827 | urlParameters.Add "{session id}", MyOptions.Capabilities("sessionId") 828 | 829 | SendCommand2Webdriver W3C_DISMISS_ALERT, urlParameters, requestBody 830 | End Sub 831 | 832 | Public Sub AcceptAlert() 833 | Dim urlParameters As New Dictionary, _ 834 | requestBody As New Dictionary 835 | 836 | urlParameters.Add "{session id}", MyOptions.Capabilities("sessionId") 837 | 838 | SendCommand2Webdriver W3C_ACCEPT_ALERT, urlParameters, requestBody 839 | End Sub 840 | 841 | Public Function GetAlertText() 842 | Dim urlParameters As New Dictionary, _ 843 | requestBody As New Dictionary, _ 844 | responseBody As Dictionary 845 | 846 | urlParameters.Add "{session id}", MyOptions.Capabilities("sessionId") 847 | 848 | Set responseBody = SendCommand2Webdriver(W3C_GET_ALERT_TEXT, urlParameters, requestBody) 849 | 850 | GetAlertText = responseBody("value") 851 | End Function 852 | 853 | Public Sub SendAlertText(text As String) 854 | Dim urlParameters As New Dictionary, _ 855 | requestBody As New Dictionary 856 | 857 | urlParameters.Add "{session id}", MyOptions.Capabilities("sessionId") 858 | 859 | requestBody.Add "text", text 860 | 861 | SendCommand2Webdriver W3C_SEND_ALERT_TEXT, urlParameters, requestBody 862 | End Sub 863 | 864 | Public Sub TakeScreenshot(ByVal savePath As String) 865 | Dim urlParameters As New Dictionary, _ 866 | requestBody As New Dictionary, _ 867 | responseBody As Dictionary 868 | 869 | urlParameters.Add "{session id}", MyOptions.Capabilities("sessionId") 870 | 871 | Set responseBody = SendCommand2Webdriver(W3C_TAKE_SCREENSHOT, urlParameters, requestBody) 872 | 873 | DecodeBase64ToFile responseBody("value"), savePath 874 | End Sub 875 | 876 | Public Sub TakeElementScreenshot(ByVal element As WebElement, ByVal savePath As String) 877 | Dim urlParameters As New Dictionary, _ 878 | requestBody As New Dictionary, _ 879 | responseBody As Dictionary 880 | 881 | urlParameters.Add "{session id}", MyOptions.Capabilities("sessionId") 882 | urlParameters.Add "{element id}", element.elementJson(ELEMENT_KEY) 883 | 884 | requestBody.Add "scroll", True 885 | 886 | Set responseBody = SendCommand2Webdriver(W3C_TAKE_ELEMENT_SCREENSHOT, urlParameters, requestBody) 887 | 888 | DecodeBase64ToFile responseBody("value"), savePath 889 | End Sub 890 | 891 | '------------------------------------------------------------------ 892 | ' Communication Interface between 'Local end' & 'Remote end' 893 | '------------------------------------------------------------------ 894 | Private Function SendCommand2Webdriver(ByVal driverCommand As Variant, _ 895 | Optional urlParameters As Dictionary = Nothing, _ 896 | Optional requestBody As Dictionary = Nothing) As Dictionary 897 | Dim method As String: method = driverCommand(0) 898 | Dim path As String: path = driverCommand(1) 899 | 900 | ' Replace url parameters with user defined values. 901 | ' {session id}, {element id}, etc.. 902 | Dim paramKey As Variant 903 | For Each paramKey In urlParameters 904 | path = Replace(path, paramKey, urlParameters(paramKey)) 905 | Next 906 | 907 | Dim xmlHttp As Object 908 | Set xmlHttp = CreateObject("MSXML2.ServerXMLHTTP") 909 | 910 | xmlHttp.Open method, RemoteEndUrl + path 911 | xmlHttp.setRequestHeader "Content-Type", "application/json; charset=utf-8" 912 | xmlHttp.setRequestHeader "Cache-Control", "no-cache" 913 | xmlHttp.Send JsonConverter.ConvertToJson(requestBody) 914 | 915 | Do While (xmlHttp.readyState <> 4) 916 | DoEvents 917 | Loop 918 | 919 | If MyOptions.LogFile <> vbNullString Then 920 | Log4Driver MyOptions.LogFile, xmlHttp.responseText 921 | End If 922 | 923 | If xmlHttp.Status = 200 Then 924 | Set SendCommand2Webdriver = JsonConverter.ParseJson(xmlHttp.responseText) 925 | Else 926 | Err.Raise vbObjectError + 513, "WebDriver", xmlHttp.responseText 927 | End If 928 | 929 | Set xmlHttp = Nothing 930 | End Function 931 | 932 | '------------------------------------------------------------------ 933 | ' Other Functions 934 | '------------------------------------------------------------------ 935 | ' Locator strategies 936 | ' Ref: 937 | ' https://github.com/SeleniumHQ/selenium/blob/13d8f8be751001d44df8e5f1797518f4fb4dec6b/java/client/src/org/openqa/selenium/remote/http/W3CHttpCommandCodec.java#L187 938 | Private Function SelectLocationStrategies(ByVal Strategy As By, ByVal value As String) As Dictionary 939 | Dim searchJson As New Dictionary 940 | 941 | Select Case True 942 | Case Strategy = By.ClassName 943 | searchJson.Add "using", "css selector" 944 | searchJson.Add "value", "." & value 945 | Case Strategy = By.ID 946 | searchJson.Add "using", "css selector" 947 | searchJson.Add "value", "[id=""" + value + """]" 948 | Case Strategy = By.name 949 | searchJson.Add "using", "css selector" 950 | searchJson.Add "value", "[name='" & value & "']" 951 | Case Strategy = By.LinkText 952 | searchJson.Add "using", "link text" 953 | Case Strategy = By.PartialLinkText 954 | searchJson.Add "using", "partial link text" 955 | Case Strategy = By.TagName, Strategy = By.CSS 956 | searchJson.Add "using", "css selector" 957 | searchJson.Add "value", value 958 | Case Strategy = By.XPath 959 | searchJson.Add "using", "xpath" 960 | searchJson.Add "value", value 961 | End Select 962 | 963 | Set SelectLocationStrategies = searchJson 964 | End Function 965 | 966 | Private Function Convert2WebElement(ByVal elementJson As Dictionary) As WebElement 967 | Dim element As New WebElement 968 | element.driver = Me 969 | 970 | element.elementJson = elementJson 971 | 972 | Set Convert2WebElement = element 973 | End Function 974 | 975 | Private Sub DecodeBase64ToFile(ByVal Base64String As String, ByVal savePath As String) 976 | Dim base64Byte() As Byte 977 | 978 | With CreateObject("MSXML2.DOMDocument").createElement("b64") 979 | .DataType = "bin.base64" 980 | .text = Base64String 981 | base64Byte = .nodeTypedValue 982 | End With 983 | 984 | Dim FileNumber As Long: FileNumber = FreeFile 985 | 986 | Open savePath For Binary Access Write As #FileNumber 987 | Put #FileNumber, 1, base64Byte 988 | Close #FileNumber 989 | End Sub 990 | 991 | Private Sub Log4Driver(ByVal LogFile As String, ByVal messsage As String) 992 | Dim INT_FILE As Integer 993 | INT_FILE = FreeFile() 994 | 995 | Open LogFile For Append As #INT_FILE 996 | Print #INT_FILE, format(DateTime.Now, "yyyy-MM-dd hh:mm:ss") + messsage 997 | 998 | Close #INT_FILE 999 | End Sub 1000 | -------------------------------------------------------------------------------- /src/WebDriverOptions.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "WebDriverOptions" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | '------------------------------------------------------------------ 11 | ' SeleniumWrapperVBA 12 | ' 13 | ' Auther: er-ri (https://github.com/er-ri/selenium-wrapper-vba) 14 | ' Date: 2022/03 15 | ' License: MIT (https://opensource.org/licenses/MIT) 16 | '------------------------------------------------------------------ 17 | ' 18 | ' ================================================================= 19 | ' #Class WebDriverOptions 20 | ' ================================================================= 21 | Option Explicit 22 | 23 | Public Enum BrowserTypesList 24 | InternetExplorer = 1 25 | Edge = 2 26 | Chrome = 3 27 | Firefox = 4 28 | End Enum 29 | 30 | Private m_BrowserType As BrowserTypesList 31 | 32 | ' Options for Internet Explorer 33 | Private m_AttachToEdgeChrome As Boolean 34 | Private m_EdgeExecutablePath As String 35 | Private m_IntroduceFlakinessByIgnoringSecurityDomains As Boolean 36 | Private m_IgnoreZoomSetting As Boolean 37 | 38 | ' Options for Chrome 39 | Private m_ChromeArguments As Collection 40 | 41 | ' Options for Firefox 42 | Private m_FirefoxArguments As Collection 43 | 44 | ' Options for Edge 45 | Private m_EdgeArguments As Collection 46 | 47 | ' Driver Preference 48 | Private m_LogFile As String 49 | Private m_WebDriverWinStyle As VbAppWinStyle 50 | Private m_Capabilities As Dictionary 51 | 52 | '------------------------------------------------------------------ 53 | ' Encapsulation 54 | '------------------------------------------------------------------ 55 | Public Property Get BrowserType() As BrowserTypesList 56 | BrowserType = m_BrowserType 57 | End Property 58 | 59 | Public Property Let BrowserType(ByVal new_BrowserType As BrowserTypesList) 60 | m_BrowserType = new_BrowserType 61 | End Property 62 | 63 | Public Property Get AttachToEdgeChrome() As Boolean 64 | AttachToEdgeChrome = m_AttachToEdgeChrome 65 | End Property 66 | 67 | Public Property Let AttachToEdgeChrome(ByVal new_AttachToEdgeChrome As Boolean) 68 | m_AttachToEdgeChrome = new_AttachToEdgeChrome 69 | End Property 70 | 71 | Public Property Get EdgeExecutablePath() As String 72 | EdgeExecutablePath = m_EdgeExecutablePath 73 | End Property 74 | 75 | Public Property Let EdgeExecutablePath(ByVal new_EdgeExecutablePath As String) 76 | m_EdgeExecutablePath = new_EdgeExecutablePath 77 | End Property 78 | 79 | Public Property Get IntroduceFlakinessByIgnoringSecurityDomains() As Boolean 80 | IntroduceFlakinessByIgnoringSecurityDomains = m_IntroduceFlakinessByIgnoringSecurityDomains 81 | End Property 82 | 83 | Public Property Let IntroduceFlakinessByIgnoringSecurityDomains(ByVal new_IntroduceFlakinessByIgnoringSecurityDomains As Boolean) 84 | m_IntroduceFlakinessByIgnoringSecurityDomains = new_IntroduceFlakinessByIgnoringSecurityDomains 85 | End Property 86 | 87 | Public Property Get IgnoreZoomSetting() As Boolean 88 | IgnoreZoomSetting = m_IgnoreZoomSetting 89 | End Property 90 | 91 | Public Property Let IgnoreZoomSetting(ByVal new_IgnoreZoomSetting As Boolean) 92 | m_IgnoreZoomSetting = new_IgnoreZoomSetting 93 | End Property 94 | 95 | Public Property Get ChromeArguments() As Collection 96 | Set ChromeArguments = m_ChromeArguments 97 | End Property 98 | 99 | Public Property Let ChromeArguments(ByVal new_ChromeArguments As Collection) 100 | Set m_ChromeArguments = new_ChromeArguments 101 | End Property 102 | 103 | Public Property Get FirefoxArguments() As Collection 104 | Set FirefoxArguments = m_FirefoxArguments 105 | End Property 106 | 107 | Public Property Let FirefoxArguments(ByVal new_FirefoxArguments As Collection) 108 | Set m_FirefoxArguments = new_FirefoxArguments 109 | End Property 110 | 111 | Public Property Get EdgeArguments() As Collection 112 | Set EdgeArguments = m_EdgeArguments 113 | End Property 114 | 115 | Public Property Let EdgeArguments(ByVal new_EdgeArguments As Collection) 116 | Set m_EdgeArguments = new_EdgeArguments 117 | End Property 118 | 119 | Public Property Get LogFile() As String 120 | LogFile = m_LogFile 121 | End Property 122 | 123 | Public Property Let LogFile(ByVal new_LogFile As String) 124 | m_LogFile = new_LogFile 125 | End Property 126 | 127 | Public Property Get Capabilities() As Dictionary 128 | Set Capabilities = m_Capabilities 129 | End Property 130 | 131 | Public Property Let Capabilities(ByVal new_Capabilities As Dictionary) 132 | Set m_Capabilities = new_Capabilities 133 | End Property 134 | '------------------------------------------------------------------ 135 | ' Constructor 136 | '------------------------------------------------------------------ 137 | Private Sub Class_Initialize() 138 | Set m_ChromeArguments = New Collection 139 | Set m_FirefoxArguments = New Collection 140 | Set m_EdgeArguments = New Collection 141 | 142 | m_LogFile = vbNullString 143 | End Sub 144 | 145 | '------------------------------------------------------------------ 146 | ' Class Method 147 | '------------------------------------------------------------------ 148 | Public Function ConstructCapabilities() As Dictionary 149 | Dim capabilitiesRoot As New Dictionary 150 | Dim alwaysMatchRoot As New Dictionary 151 | 152 | Select Case True 153 | Case Me.BrowserType = InternetExplorer 154 | Dim ieOptionsRoot As New Dictionary 155 | ieOptionsRoot.Add "ie.edgechromium", Me.AttachToEdgeChrome 156 | ieOptionsRoot.Add "ie.edgepath", Me.EdgeExecutablePath 157 | ieOptionsRoot.Add "ignoreProtectedModeSettings", Me.IntroduceFlakinessByIgnoringSecurityDomains 158 | ieOptionsRoot.Add "ignoreZoomSetting", Me.IgnoreZoomSetting 159 | 160 | alwaysMatchRoot.Add "browserName", "internet explorer" 161 | alwaysMatchRoot.Add "se:ieOptions", ieOptionsRoot 162 | capabilitiesRoot.Add "alwaysMatch", alwaysMatchRoot 163 | Case Me.BrowserType = Edge 164 | Dim edgeOptionsRoot As New Dictionary 165 | edgeOptionsRoot.Add "args", EdgeArguments 166 | 167 | alwaysMatchRoot.Add "browserName", "MicrosoftEdge" 168 | alwaysMatchRoot.Add "ms:edgeOptions", edgeOptionsRoot 169 | capabilitiesRoot.Add "alwaysMatch", alwaysMatchRoot 170 | Case Me.BrowserType = Chrome 171 | Dim chromeOptionsRoot As New Dictionary 172 | chromeOptionsRoot.Add "args", ChromeArguments 173 | 174 | alwaysMatchRoot.Add "browserName", "chrome" 175 | alwaysMatchRoot.Add "goog:chromeOptions", chromeOptionsRoot 176 | capabilitiesRoot.Add "alwaysMatch", alwaysMatchRoot 177 | Case Me.BrowserType = Firefox 178 | Dim firefoxOptionsRoot As New Dictionary 179 | firefoxOptionsRoot.Add "args", FirefoxArguments 180 | 181 | alwaysMatchRoot.Add "browserName", "firefox" 182 | alwaysMatchRoot.Add "moz:firefoxOptions", firefoxOptionsRoot 183 | capabilitiesRoot.Add "alwaysMatch", alwaysMatchRoot 184 | End Select 185 | 186 | Set ConstructCapabilities = capabilitiesRoot 187 | End Function 188 | -------------------------------------------------------------------------------- /src/WebElement.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "WebElement" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | '------------------------------------------------------------------ 11 | ' SeleniumWrapperVBA 12 | ' 13 | ' Auther: er-ri (https://github.com/er-ri/selenium-wrapper-vba) 14 | ' Date: 2022/03 15 | ' License: MIT (https://opensource.org/licenses/MIT) 16 | '------------------------------------------------------------------ 17 | ' 18 | ' ================================================================= 19 | ' #Class WebElement 20 | ' ================================================================= 21 | Option Explicit 22 | 23 | Private m_Driver As WebDriver 24 | Private m_elementJson As Dictionary 25 | 26 | '------------------------------------------------------------------ 27 | ' Encapsulation 28 | '------------------------------------------------------------------ 29 | Public Property Get driver() As WebDriver 30 | Set driver = m_Driver 31 | End Property 32 | 33 | Public Property Let driver(ByVal new_Driver As WebDriver) 34 | Set m_Driver = new_Driver 35 | End Property 36 | 37 | Public Property Get elementJson() As Dictionary 38 | Set elementJson = m_elementJson 39 | End Property 40 | 41 | Public Property Let elementJson(ByVal new_elementJson As Dictionary) 42 | Set m_elementJson = new_elementJson 43 | End Property 44 | 45 | '------------------------------------------------------------------ 46 | ' Element Command 47 | '------------------------------------------------------------------ 48 | Public Function FindElement(ByVal by_strategy As By, _ 49 | ByVal target As String) As WebElement 50 | Set FindElement = driver.FindElementFromElement(Me, by_strategy, target) 51 | End Function 52 | 53 | Public Function FindElements(ByVal element As WebElement, _ 54 | ByVal by_strategy As By, _ 55 | ByVal target As String) As Variant 56 | FindElements = driver.FindElementsFromElement(Me, by_strategy, target) 57 | End Function 58 | 59 | Public Function GetShadowRoot() 60 | Set GetShadowRoot = driver.GetElementShadowRoot(Me) 61 | End Function 62 | 63 | Public Sub SendKeys(text As String) 64 | driver.ElementSendKeys text, Me 65 | End Sub 66 | 67 | Public Sub Clear() 68 | driver.ElementClear Me 69 | End Sub 70 | 71 | Public Sub Click() 72 | driver.ElementClick Me 73 | End Sub 74 | 75 | Public Function GetAttribute(ByVal name As String) 76 | GetAttribute = driver.GetElementAttribute(Me, name) 77 | End Function 78 | 79 | Public Function GetProperty(ByVal name As String) 80 | GetProperty = driver.GetElementProperty(Me, name) 81 | End Function 82 | 83 | Public Function GetText() 84 | GetText = driver.GetElementText(Me) 85 | End Function 86 | 87 | Public Sub TakeScreenshot(ByVal savePath As String) 88 | driver.TakeElementScreenshot Me, savePath 89 | End Sub 90 | 91 | --------------------------------------------------------------------------------