├── .gen ├── index.js └── readme.build.bat ├── .gitattributes ├── Examples ├── BrowserAutomation │ ├── Examples │ │ └── ArcGISOnlinePublisher.bas │ ├── README.md │ ├── lib │ │ ├── stdBrowser.cls │ │ ├── stdChrome.cls │ │ └── stdEdge.cls │ ├── stdBrowserProj.xlsm │ └── ~$stdChromeProj.xlsm ├── ConditionalFormatting │ ├── ConditionalFormattingSample.xlsm │ ├── README.md │ ├── resources │ │ ├── demo.gif │ │ └── image.png │ └── src │ │ ├── ConditionalFormattingEx.bas │ │ └── lib │ │ ├── stdEnumerator.cls │ │ ├── stdICallable.cls │ │ └── stdLambda.cls ├── ConsoleUserform │ ├── Console.md │ ├── ConsoleApplication.xlsm │ ├── README.md │ └── src │ │ ├── Console.frm │ │ └── Console.frx ├── DataSources │ ├── DataSources.xlsm │ └── src │ │ ├── dsISrc.cls │ │ ├── dsMain.bas │ │ ├── dsSrcDatabase.cls │ │ ├── dsSrcExcelRange.cls │ │ ├── dsSrcFileCopy.cls │ │ ├── dsSrcFileCopyMany.cls │ │ ├── dsSrcGISSTdb.cls │ │ ├── dsSrcPowerBI.cls │ │ ├── dsSrcPowerQuery.cls │ │ └── dsSrcSharePoint.cls ├── Document Generator │ ├── Document Generator.xlsm │ ├── Test.pptx │ ├── res │ │ ├── cry.png │ │ └── grin.png │ ├── result │ │ ├── 6527a2a0-2405-4778-9558-da50fd721536.pdf │ │ ├── 6527a2a0-2405-4778-9558-da50fd721537.pdf │ │ ├── 6527a2a0-2405-4778-9558-da50fd721538.pdf │ │ ├── e673794f-1930-48e9-8cd7-acbddb005152.pdf │ │ ├── e673794f-1930-48e9-8cd7-acbddb005153.pdf │ │ └── e673794f-1930-48e9-8cd7-acbddb005154.pdf │ └── src │ │ ├── .Modules │ │ └── genMain.bas │ │ ├── Class Modules │ │ ├── genIInjector.cls │ │ ├── genInjectorExcel.cls │ │ ├── genInjectorPowerPoint.cls │ │ └── genLambdaEx.cls │ │ └── Dependencies │ │ ├── stdCOM.cls │ │ ├── stdCallback.cls │ │ ├── stdEnumerator.cls │ │ ├── stdICallable.cls │ │ ├── stdLambda.cls │ │ ├── stdRegex.cls │ │ ├── stdTable.cls │ │ └── stdWindow.cls ├── DynamicForm-TransformObject │ ├── Demo.xlsm │ ├── README.md │ ├── docs │ │ └── TransformerExample.png │ └── src │ │ ├── DemoClass.cls │ │ ├── frTransformer.frm │ │ ├── frTransformer.frx │ │ └── mMain.bas ├── Inspector-Accessibility-v1 │ ├── Accessibility Inspector.xlsm │ ├── README.md │ ├── docs │ │ └── inspector.png │ ├── src │ │ ├── AccHelper.frm │ │ ├── AccHelper.frx │ │ └── LaunchInspect.bas │ └── ~$Accessibility Inspector.xlsm ├── Inspector-Accessibility-v2 │ ├── Accessibility Inspector v2.xlsm │ ├── README.md │ ├── docs │ │ ├── Inspector.png │ │ ├── InspectorTutorial.png │ │ └── InspectorTutorial.pptx │ ├── icons │ │ ├── HighlightRect.png │ │ ├── Mouse.png │ │ ├── Mouse5.png │ │ ├── Search.png │ │ ├── VB.png │ │ └── VisibleOnly.png │ ├── lib │ │ ├── stdAcc.cls │ │ ├── stdCallback.cls │ │ ├── stdClipboard.cls │ │ ├── stdICallable.cls │ │ ├── stdImage.cls │ │ ├── stdLambda.cls │ │ ├── stdProcess.cls │ │ ├── stdShell.cls │ │ ├── stdWindow.cls │ │ ├── tvTree.cls │ │ ├── uiElement.cls │ │ └── uiIMessagable.cls │ └── src │ │ ├── AccessibilityInspector.frm │ │ ├── AccessibilityInspector.frx │ │ ├── mCommands.bas │ │ ├── tvAcc.cls │ │ └── uiFields.cls ├── Inspector-Clipboard │ ├── Clipboard Inspector.xlsm │ ├── README.md │ ├── docs │ │ ├── clipboard-inspector-imageView.png │ │ └── clipboard-inspector.png │ └── ~$Clipboard Inspector.xlsm ├── Inspector-CommandBars │ ├── Inspector-CommandBars.xlsm │ ├── README.md │ ├── libs │ │ ├── VBA-FastDictionary.cls │ │ ├── stdAcc.cls │ │ ├── stdArray.cls │ │ ├── stdClipboard.cls │ │ ├── stdICallable.cls │ │ ├── stdLambda.cls │ │ └── stdWindow.cls │ └── src │ │ ├── InspectCommandbars.frm │ │ ├── InspectCommandbars.frx │ │ └── Module1.bas ├── Inspector-JSON │ ├── JSON Viewer.xlsm │ ├── README.md │ ├── lib │ │ ├── stdCallback.cls │ │ ├── stdICallable.cls │ │ ├── stdJSON.cls │ │ ├── stdLambda.cls │ │ └── tvTree.cls │ ├── res │ │ ├── 0_ClickButton.png │ │ ├── 1_SelectFile.png │ │ ├── 2_ViewData.png │ │ └── Process.png │ └── src │ │ ├── JSONViewer.frm │ │ ├── JSONViewer.frx │ │ └── modMain.bas ├── Inspector-Registry │ ├── README.md │ ├── Registry Viewer.xlsm │ ├── res │ │ └── Process.png │ └── src │ │ ├── RegistryViewer.frm │ │ ├── RegistryViewer.frx │ │ ├── stdClipboard.cls │ │ ├── stdICallable.cls │ │ ├── stdLambda.cls │ │ ├── stdReg.cls │ │ └── tvTree.cls ├── Inspector-RunningObjectTable │ ├── README.md │ ├── ROT Viewer.xlsm │ ├── docs │ │ └── inspector-rot.png │ ├── libs │ │ ├── stdCOM.cls │ │ ├── stdICallable.cls │ │ ├── stdLambda.cls │ │ ├── uiElement.cls │ │ ├── uiFields.cls │ │ └── uiIMessagable.cls │ └── src │ │ ├── ROTView.frm │ │ └── ROTView.frx ├── MacroDispatcher │ ├── MacroDispatcher.xlsm │ ├── README.md │ ├── Src │ │ ├── extensions │ │ │ ├── mdExtension.cls │ │ │ └── mdMain.bas │ │ ├── mdJob.cls │ │ └── mdMain.bas │ └── Tests │ │ └── Test.xlsm ├── NoteBuilder │ ├── NoteBuilder.xlsm │ ├── README.md │ └── src │ │ ├── Questionnaire.frm │ │ └── Questionnaire.frx ├── Notepad-GetAllTextAndClose │ ├── ExtractAllNotepadText.xlsm │ ├── lib │ │ ├── stdAcc.cls │ │ ├── stdICallable.cls │ │ ├── stdLambda.cls │ │ ├── stdProcess.cls │ │ └── stdWindow.cls │ └── src │ │ └── main.bas ├── SAP-ECC-Automation │ ├── README.md │ ├── lib │ │ ├── stdAcc.cls │ │ ├── stdCallback.cls │ │ ├── stdClipboard.cls │ │ ├── stdFiber.cls │ │ ├── stdICallable.cls │ │ ├── stdLambda.cls │ │ ├── stdProcess.cls │ │ └── stdWindow.cls │ └── src │ │ ├── sapSAPECC.cls │ │ └── sapSAPECCIH06.cls ├── SharepointPAService │ ├── README.md │ ├── res │ │ └── PowerAutomate_Service.png │ └── src │ │ ├── PowerAutomate.zip │ │ ├── Microsoft.Flow │ │ │ └── flows │ │ │ │ ├── 5ab6c1ee-9b2d-4d64-b8f2-67d9a09eba6e │ │ │ │ ├── apisMap.json │ │ │ │ ├── connectionsMap.json │ │ │ │ └── definition.json │ │ │ │ └── manifest.json │ │ └── manifest.json │ │ ├── SS │ │ └── JS │ │ │ └── API.js │ │ └── VBA │ │ ├── HTTPCollection.cls │ │ ├── SPPAService.cls │ │ ├── lib │ │ ├── stdArray.cls │ │ ├── stdCallback.cls │ │ ├── stdEnumerator.cls │ │ ├── stdHTTP.cls │ │ ├── stdICallable.cls │ │ ├── stdJSON.cls │ │ ├── stdLambda.cls │ │ └── stdRegex.cls │ │ └── test │ │ ├── Example.xlsm │ │ └── SPPAServiceTest.bas ├── SplitSideBySide │ ├── README.md │ ├── docs │ │ └── comparison.png │ └── src │ │ └── SplitSideBySide.bas ├── Spreadsheet Extractor │ ├── ExtractionTemplate 1.1.xlsm │ ├── README.md │ ├── Tests │ │ ├── Mars.xlsx │ │ └── Nesle.xlsx │ ├── _ │ │ └── DataGeneration │ │ │ ├── Bars │ │ │ ├── CafeChocolate - Chocolate Platte.png │ │ │ ├── DALLE - Arrits.png │ │ │ ├── DALLE - CandyCorns.png │ │ │ ├── DALLE - Gumballs.png │ │ │ ├── DALLE - Matrats.png │ │ │ ├── DALLE - McCrackers.png │ │ │ ├── Dredgar - Aiftfer 8.png │ │ │ ├── Dredgar - Malseler.png │ │ │ ├── Dredgar - Mars.png │ │ │ ├── Dredgar - Snint.png │ │ │ └── PROMPTS.txt │ │ │ ├── Data.csv │ │ │ └── Data.xlsx │ ├── docs │ │ ├── CategoriesExample.png │ │ ├── GithubOverview.pptx │ │ ├── Overview.png │ │ ├── ProjectStructure.png │ │ ├── RulesExample.png │ │ └── RunningTheTool.png │ ├── extensions │ │ ├── british_geospatial.xlsm │ │ └── template.xlsm │ └── src │ │ ├── .Modules │ │ └── xrExtractor.bas │ │ └── Class Modules │ │ ├── xrCategories.cls │ │ ├── xrLambdaEx.cls │ │ └── xrRules.cls ├── Timer │ ├── README.md │ ├── src │ │ ├── stdTimer.bas │ │ └── stdTimerTests.bas │ └── stdTimerTests.xlsm ├── stdTable │ ├── README.md │ ├── src │ │ └── stdTable.cls │ └── stdTableTest.xlsm ├── uiTextBoxEx-WordControl │ ├── README.md │ ├── WordControl.xlsm │ ├── docs │ │ ├── preview.png │ │ └── result.png │ └── src │ │ ├── Test.frm │ │ ├── Test.frx │ │ ├── mMain.bas │ │ └── uiTextBoxEx.cls └── xlVBA │ ├── xlApplication │ ├── README.md │ └── src │ │ └── xlApplication.cls │ ├── xlSaveHandler │ ├── README.md │ └── src │ │ ├── xlSaveHandler.frm │ │ └── xlSaveHandler.frx │ └── xlTableTools │ ├── README.md │ └── src │ └── xlTableTools.bas ├── README.md └── logs └── xvba_debug.log /.gen/index.js: -------------------------------------------------------------------------------- 1 | const { readdirSync, readFileSync, writeFileSync } = require("fs"); 2 | let paths = readdirSync("../examples").map(e => `../examples/${e}/README.md`); 3 | let regex = /).)*})\s*-->/; 4 | let metas = paths.map(e => ({ path: e, text: readFileSync(e).toString() })) 5 | .filter(e => regex.test(e.text)) 6 | .map(e => ({ path: e.path, data: JSON.parse(regex.exec(e.text)[1]) })) 7 | console.log(metas) 8 | 9 | let md = ` 10 | # \`stdVBA\` Examples 11 | 12 | This repository holds examples of using \`stdVBA\`. This should give people a better idea of how to use \`stdVBA\` and libraries. 13 | 14 | ## Contents 15 | 16 | | Title | Tags | Dependencies | 17 | |-------|------|--------------| 18 | ${metas.map(function (meta) { 19 | return "|" + [ 20 | "[" + meta.data.description + "](" + encodeURI(meta.path.substring(3, meta.path.length - "/README.md".length)) + ")", 21 | meta.data.tags.join(", "), 22 | meta.data.deps.join(", ") 23 | ].join("|") + "|" 24 | }).join("\r\n")} 25 | ` 26 | writeFileSync("../README.md", md) 27 | 28 | -------------------------------------------------------------------------------- /.gen/readme.build.bat: -------------------------------------------------------------------------------- 1 | node . -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | # Auto detect text files and perform LF normalization 2 | * text=auto 3 | -------------------------------------------------------------------------------- /Examples/BrowserAutomation/Examples/ArcGISOnlinePublisher.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "ArcGISOnlinePublisher" 2 | 3 | 'Edit accordingly: 4 | Const AGISOSERVER = "SERVER.maps.arcgis.com" 5 | Const TestLayerCSV = "MY_CSV_LOCATION" 6 | Const TestLayerURL = "https://$SERVER/home/item.html?id=MY_LAYER_ID" 7 | Const SPOCHECKER = "*SERVER.sharepoint.com*" 8 | 9 | 10 | Public Sub test() 11 | Call PublishCSV(SI(TestLayerURL), TestLayerCSV) 12 | End Sub 13 | 14 | Public Sub PublishCSV(ByVal sLayerURL As String, ByVal sCSVPath As String) 15 | 'Force CSV to be local ready for uploading to GISSTOnline 16 | Dim sCSV As String: sCSV = SPOToCSV(sCSVPath) 17 | 18 | 'Input username and password for ArcGIS Online 19 | Dim C_USER as string: C_USER = InputBox("Enter your username") 20 | Dim C_PASS as string: C_PASS = InputBox("Enter your password") 21 | 22 | 'Launch chrome 23 | Dim chrome As stdChrome: Set chrome = stdChrome.Create() 24 | 25 | 'Navigate to ArcGIS login page 26 | Call chrome.Navigate(SI("https://$SERVER/home/signin.html?useLandingPage=true")) 27 | Call chrome.AwaitForCondition(stdLambda.Create("$2.address like $1").Bind(SI("$SERVER/sharing/*oauth2/authorize?client_id=arcgisonline*"))) 28 | 29 | 'Login and wait till login authorised 30 | Dim accLogin As stdAcc: Set accLogin = chrome.accMain.AwaitForElement(stdLambda.Create("$1.name = ""ArcGIS login"" and $1.role = ""ROLE_PANE""")) 31 | Dim accUser As stdAcc: Set accUser = accLogin.FindFirst(stdLambda.Create("$1.Name = ""Username"" and $1.Role = ""ROLE_TEXT""")) 32 | Dim accPass As stdAcc: Set accPass = accLogin.FindFirst(stdLambda.Create("$1.Name = ""Password"" and $1.Role = ""ROLE_TEXT""")) 33 | Dim accSignIn As stdAcc: Set accSignIn = accLogin.FindFirst(stdLambda.Create("$1.Name = ""Sign In"" and $1.Role = ""ROLE_PUSHBUTTON""")) 34 | accUser.value = C_USER 35 | accPass.value = C_PASS 36 | Call accSignIn.DoDefaultAction 37 | Call chrome.AwaitForCondition(stdLambda.Create("$2.Address like $1").Bind(SI("$SERVER/home/index.html"))) 38 | 39 | 'Navigate to layer url 40 | Call chrome.Navigate(sLayerURL) 41 | 'HACK: This is quite slow, consider attempting to speed this up with more tree refinement 42 | 43 | 'Await path "4.1.1.2.2.2.4.2", we do this somewhat dynamically though 44 | Call chrome.AwaitForCondition(stdLambda.Create("$1.winMain.Caption like ""* - Overview - *""")) 45 | Dim sDocCaption As String: sDocCaption = left(chrome.winMain.Caption, Len(chrome.winMain.Caption) - 16) 46 | Dim accDoc As stdAcc: Set accDoc = chrome.AwaitForAccElement(stdLambda.Create("$2.Name = $1 and $2.Role = ""ROLE_DOCUMENT""").Bind(sDocCaption)) 47 | 48 | 'Wait til no longer loading and property page is visible 49 | Dim accMenu As stdAcc: Set accMenu = accDoc.CreateFromPath("4.2") 50 | Do 51 | Set accMenu = accDoc.CreateFromPath("4.2") 52 | DoEvents 53 | Loop Until accMenu.Role = "ROLE_PROPERTYPAGE" 54 | 55 | 'Click update data and overwrite layer 56 | Call accMenu.AwaitForElement(stdLambda.Create("$1.Name = ""Update Data"" and $1.Role = ""ROLE_PUSHBUTTON""")).DoDefaultAction '$1.Role = "" 57 | Call accMenu.AwaitForElement(stdLambda.Create("$1.Name = ""Overwrite Entire Layer"" and $1.Role = ""ROLE_PUSHBUTTON""")).DoDefaultAction 58 | 59 | 'Click Choose file button 60 | Call accDoc.AwaitForElement(stdLambda.Create("$1.Name = ""Choose file"" and $1.Role = ""ROLE_PUSHBUTTON""")).DoDefaultAction 61 | 62 | 'Await the file uploader and target the CSV for uploading 'FIX: Check windw exists to better handle errors 63 | Set fileUploader = stdWindow.CreateFromDesktop().AwaitForWindow(stdLambda.Create("if $2 <= 1 and $1.exists then $1.Class = ""#32770"" and $1.Caption = ""Open"" else EWndFindResult.NoMatchSkipDescendents")) 64 | Dim accFileUploader As stdAcc: Set accFileUploader = stdAcc.CreateFromHwnd(fileUploader.Handle) 65 | accFileUploader.FindFirst(stdLambda.Create("$1.Role = ""ROLE_TEXT"" and $1.Name = ""File name:""")).value = sCSV 66 | Call accFileUploader.FindFirst(stdLambda.Create("$1.DefaultAction = ""Press"" and $1.Name = ""Open""")).DoDefaultAction 67 | 68 | 'Click overwrite button 69 | Call accDoc.AwaitForElement(stdLambda.Create("$1.Name = ""Overwrite"" and $1.Role = ""ROLE_PUSHBUTTON""")).DoDefaultAction 70 | Call chrome.AwaitForCondition(stdLambda.Create("$1.Address like ""*&jobid=*""")) 71 | 72 | 'Quit chrome 73 | Call chrome.Quit 74 | End Sub 75 | 76 | ' 77 | Private Function SI(ByVal s as string) as string 78 | SI = replace(s, "$SERVER", AGISOSERVER) 79 | End Function 80 | 81 | ' 82 | Private Function SPOToCSV(ByVal sSharepointOnlineURL) As String 83 | 'If CSVPath on sharepoint then we need to make a local copy, because windows explorer isn't able to use sharepoint directly 84 | If LCase(sSharepointOnlineURL) Like SPOCHECKER Then 85 | With Workbooks.Open(sSharepointOnlineURL) 86 | Application.DisplayAlerts = False 87 | Dim sFileName As String: sFileName = FileNameFromURL(sSharepointOnlineURL) 88 | .SaveAs "C:\Temp\" & sFileName 89 | SPOToCSV = "C:\Temp\" & sFileName 90 | .Close False 91 | Application.DisplayAlerts = True 92 | End With 93 | Else 94 | SPOToCSV = sSharepointOnlineURL 95 | End If 96 | End Function 97 | 98 | 'Get file name from url 99 | '@param {String} URL to get file name from 100 | '@returns {String} File name from url 101 | Private Function FileNameFromURL(ByVal sURL As String) As String 102 | Dim sFileName As String 103 | sFileName = Mid(sURL, InStrRev(sURL, "/") + 1) 104 | sFileName = Replace(sFileName, "%20", " ") 105 | FileNameFromURL = sFileName 106 | End Function 107 | -------------------------------------------------------------------------------- /Examples/BrowserAutomation/README.md: -------------------------------------------------------------------------------- 1 | 8 | # Browser Automation with stdVBA 9 | 10 | On 15th June 2022, Internet explorer officially retires as an application. It is uncertain what will happen when this occurs, however many users of VBA rely heavily on Internet Explorer to automate web reports etc. 11 | 12 | This is a stdVBA solution which uses accessibility APIs and Google Chrome to perform web automation. 13 | 14 | ## Requirements 15 | 16 | * [stdVBA](http://github.com/sancarn/stdVBA) 17 | * stdAcc 18 | * stdEnumerator 19 | * stdLambda 20 | * stdProcess 21 | * stdWindow 22 | * stdICallable 23 | 24 | * Currently only works on Windows OS 25 | 26 | ## Usage 27 | 28 | * Add a reference to `stdChrome.xlsm` (or import the necessary files; or open the supplied workbook) 29 | * Call `stdChrome.create()` to create a new instance of the chrome object. 30 | * Happy coding 31 | 32 | ## Roadmap 33 | 34 | * [X] Can create new 35 | * [X] Can create from existing 36 | * [ ] Can run Javascript (may not be possible with existing; will likely need chrome DevTools protocol). 37 | * [ ] Can set the HTML of the browser. (2 options: run a http server with VBA, or navigate to a html file (may have CORS issues)) 38 | * [ ] Hide address bar for business apps 39 | * [X] Can `Navigate()` / `Get/Let Address` 40 | * [X] Can `Quit`. 41 | * [ ] A better way to await loading would be nice. 42 | 43 | ## Known issues 44 | 45 | * [ ] `stdWindow`/`stdAcc` errors can be annoying. In most cases it boils down to an issue of approach, but sometimes it can be race conditions... This needs to be worked out better in `stdVBA`, see some of the examples for best practice approaches. 46 | 47 | ## Similar projects 48 | 49 | * [Chrome DevProtocol](https://github.com/PerditionC/VBAChromeDevProtocol) - stdVBA wants to have a `stdBrowser` which interacts with browser devtool protocols; however this repo is already most of the way there! With this library you'll be able to control browsers on a deeper level and gain the ability to execute javascript for instance. 50 | -------------------------------------------------------------------------------- /Examples/BrowserAutomation/stdBrowserProj.xlsm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/BrowserAutomation/stdBrowserProj.xlsm -------------------------------------------------------------------------------- /Examples/BrowserAutomation/~$stdChromeProj.xlsm: -------------------------------------------------------------------------------- 1 | sancarn sancarn -------------------------------------------------------------------------------- /Examples/ConditionalFormatting/ConditionalFormattingSample.xlsm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/ConditionalFormatting/ConditionalFormattingSample.xlsm -------------------------------------------------------------------------------- /Examples/ConditionalFormatting/README.md: -------------------------------------------------------------------------------- 1 | # Conditional Formatting using stdLambda 2 | 3 | A very simple demo, one of the sheets contains a lookup table: 4 | 5 | ![definition table](./resources/image.png) 6 | 7 | This list object is then iterated through whenever a cell changes on `ConditionalFormattingSheet`: 8 | 9 | ![demo](./resources/demo.gif) -------------------------------------------------------------------------------- /Examples/ConditionalFormatting/resources/demo.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/ConditionalFormatting/resources/demo.gif -------------------------------------------------------------------------------- /Examples/ConditionalFormatting/resources/image.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/ConditionalFormatting/resources/image.png -------------------------------------------------------------------------------- /Examples/ConditionalFormatting/src/ConditionalFormattingEx.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "ConditionalFormattingEx" 2 | Public Sub BulkApplyFormatting() 3 | Call TargetedApplyFormatting(shTest.UsedRange, True) 4 | End Sub 5 | 6 | Public Sub TargetedApplyFormatting(ByVal Target As Range, Optional ByVal forceRefreshStyles = False) 7 | Static eConditions As stdEnumerator 8 | If eConditions Is Nothing Or forceRefreshStyles Then 9 | Set eConditions = stdEnumerator.CreateFromListObject(shLookups.ListObjects("ConditionalFormatting")) 10 | Call eConditions.ForEach(stdLambda.Create("set $2.lambda = $1.Create($2.Lambda): $2").Bind(stdLambda)) 11 | End If 12 | 13 | Dim cell As Range 14 | For Each cell In Target.Cells 15 | If cell.Value <> Empty Then 16 | Dim row As Object 17 | Set row = eConditions.FindFirst(stdLambda.Create("$2.lambda.run($1)").Bind(cell.Value), Nothing) 18 | If Not row Is Nothing Then 19 | Dim colors: colors = Split(row("InteriorColor"), ",") 20 | cell.Interior.Color = RGB(colors(0), colors(1), colors(2)) 21 | End If 22 | Else 23 | cell.Interior.ColorIndex = xlColorIndexNone 24 | End If 25 | Next 26 | End Sub 27 | 28 | 29 | -------------------------------------------------------------------------------- /Examples/ConditionalFormatting/src/lib/stdICallable.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "stdICallable" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | 11 | 'Run the function with supplied parameters 12 | '@param params - The parameters to run the function with 13 | '@returns - The result of the function 14 | Public Function Run(ParamArray params() As Variant) As Variant: End Function 15 | 16 | 'Run the function with a array of parameters 17 | '@param params as Variant> - The parameters to run the function with 18 | '@returns - The result of the function 19 | Public Function RunEx(ByVal params As Variant) As Variant: End Function 20 | 21 | 'Bind a set of parameters to the function call 22 | '@param params - The parameters to bind to the function 23 | '@returns - A new function with the parameters bound 24 | Public Function Bind(ParamArray params() As Variant) As stdICallable: End Function 25 | 26 | 'Making late-bound calls to `stdICallable` members. Each object which implements `stdICallable` 27 | 'will support a different set of latebound calls. 28 | '@protected 29 | '@param sMessage - Message to send. Standard messages include "obj" returning the object, "className" returning the class name. Other messages are implementation specific. 30 | '@param success - Whether the call was successful 31 | '@param params - Any variant, typically parameters as an array. Passed along with the message. 32 | '@returns - Any return value. 33 | Public Function SendMessage(ByVal sMessage As String, ByRef success As Boolean, ByVal params As Variant) As Variant: End Function 34 | 35 | 'Ideally we would want to get a pointer to the function... However, getting a pointer to an object method is 36 | 'going to be defficult, partly due to the first parameter sent to the function is `Me`! We'll likely have to 37 | 'use machine code to wrap a call with a `Me` pointer just so we can access the full pointer and use this in 38 | 'real life applications. 39 | 'Finally it might be better to do something more like: `stdPointer.fromICallable()` anyway 40 | ''Returns a callback function 41 | ''Typically this will be achieved with `stdPointer.GetLastPrivateMethod(me)` 42 | ''If this cannot be implemented return 0 43 | 'Public Function ToPointer() as long 44 | 45 | ''Bind arguments to functions to appear as first arguments in call. 46 | ''e.g. stdLambda.Create("$1.EnableEvents = false: $1.ScreenUpdating = false").bind(Application).Run() 47 | 'Public Function Bind(ByVal v as variant) as stdICallable: End Function 48 | 49 | 50 | -------------------------------------------------------------------------------- /Examples/ConsoleUserform/ConsoleApplication.xlsm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/ConsoleUserform/ConsoleApplication.xlsm -------------------------------------------------------------------------------- /Examples/ConsoleUserform/README.md: -------------------------------------------------------------------------------- 1 | # Console 2 | 3 | A custom userform-based console for usage in VBA projects. Developed by @Almesi in a [PR for stdVBA](https://github.com/sancarn/stdVBA/pull/110). Rejected as per comments in [discussion](https://github.com/sancarn/stdVBA/discussions/107#discussioncomment-10119390) but uploaded here as an example, as this will use stdVBA modules. 4 | 5 | ## WIP 6 | 7 | This example is still needs lots of testing. I (Almesi) encourage everyone to help with testing. 8 | 9 | ## Roadmap 10 | 11 | - [ ] Use `stdUIElement` -------------------------------------------------------------------------------- /Examples/ConsoleUserform/src/Console.frx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/ConsoleUserform/src/Console.frx -------------------------------------------------------------------------------- /Examples/DataSources/DataSources.xlsm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/DataSources/DataSources.xlsm -------------------------------------------------------------------------------- /Examples/DataSources/src/dsISrc.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "dsISrc" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | 'Get the name of this type of fiber 11 | '@remark - Used to populate data validation in column C "Type" 12 | Public Function getName() As String 13 | 14 | End Function 15 | 16 | 'Links a fiber 17 | '@param template - The template fiber to link to. 18 | '@param destPath - The destination of the CSV. 19 | '@param data - Data compliant with `getDataType` function. 20 | Public Function linkFiber(ByVal template As stdFiber, ByVal destPath As String, ByVal Data As stdJSON) As stdFiber 21 | 22 | End Function 23 | 24 | 'Returns a required data type 25 | '@returns Object 26 | '@example ``` 27 | '{ 28 | ' "File": { 29 | ' "DisplayText": "Source File", 30 | ' "Tooltip": "The location of the Excel file to get the data from.", 31 | ' "Type": "File", 32 | ' "File":{ 33 | ' "Extensions": "*.xlsx,*.xlsm,*.xlsb", 34 | ' "Multiselect": false 35 | ' } 36 | ' }, 37 | ' "Sheet": { 38 | ' "DisplayText": "Source Sheet", 39 | ' "Tooltip": "The sheet from which to get the data from.", 40 | ' "Type": "Dropdown", 41 | ' "Dropdown":{ 42 | ' "Options": stdCallback.CreateFromObjectMethod(Me, "protGetSheetNamesCollection") 43 | ' } 44 | ' }, 45 | ' "Range": { 46 | ' "DisplayText": "Range address", 47 | ' "Tooltip": "The range from which to get the data from.", 48 | ' "Type": "Text" 49 | ' } 50 | '} 51 | '==> 52 | '{"File":"", "Sheet":"", "Range":""} 53 | '``` 54 | '@remark - Used to generate UI for selecting data, which generates data for column D, "Data" 55 | Public Function getDataType() As stdJSON 56 | 57 | End Function 58 | -------------------------------------------------------------------------------- /Examples/DataSources/src/dsSrcFileCopy.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "dsSrcFileCopy" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | Implements dsISrc 11 | 12 | Private Function dsISrc_getName() As String 13 | dsISrc_getName = "FileCopy" 14 | End Function 15 | 16 | Private Function dsISrc_linkFiber(ByVal template As stdFiber, ByVal destPath As String, ByVal Data As stdJSON) As stdFiber 17 | Set dsISrc_linkFiber = template 18 | With template 19 | .Meta("Source") = Data.item("Source") 20 | .Meta("Destination") = destPath 21 | 22 | Dim cb As stdCallback: Set cb = stdCallback.CreateFromObjectMethod(Me, "protProcessCopySingleFile").Bind(srcPath, destPath, True) 23 | Call .add(cb.Bind(1), "1. launching copy") 24 | Call .add(cb.Bind(2), "2. awaiting copy completion") 25 | End With 26 | End Function 27 | 28 | Private Function dsISrc_getDataType() As stdJSON 29 | Set dsISrc_getDataType = stdJSON.Create(eJSONObject) 30 | With dsISrc_getDataType 31 | With .AddObject("Source") 32 | .add "DisplayText", "Source File" 33 | .add "Tooltip", "The location of the file to copy." 34 | .add "Type", "File" 35 | With .AddObject("File") 36 | .add "Extensions", "*.*" 37 | End With 38 | End With 39 | End With 40 | End Function 41 | 42 | Public Function AsISrc() As dsISrc 43 | Set AsISrc = Me 44 | End Function 45 | 46 | 'Processes an async GISSTdb OLEdb query. 47 | '@fiberRunner 48 | '@protected 49 | Public Function protProcessCopySingleFile(ByVal State As Long, ByVal src As String, ByVal dest As String, ByVal required As Boolean, ByVal fiber As stdFiber) As Boolean 50 | Select Case State 51 | Case 1 52 | 'If it exists, copy it whatever 53 | If FileExists(src) Then 54 | 'Copy asynchronously 55 | Call shell("copy """ & src & """ """ & dest & """", vbHide) 56 | 'If it doesn't exist but is required, error 57 | ElseIf required Then 58 | Call fiber.RaiseCriticalError("File '" & src & "' is not present but is required.") 59 | Exit Function 60 | End If 61 | protProcessCopySingleFile = True 62 | Case 2 ' await copy completion 63 | If FileExists(dest) Then protProcessCopySingleFile = FileLen(src) = FileLen(dest) 64 | End Select 65 | End Function 66 | 67 | Private Function FileExists(ByVal FilePath As String) As Boolean 68 | FileExists = (Dir(FilePath) <> "") 69 | End Function 70 | 71 | 72 | -------------------------------------------------------------------------------- /Examples/DataSources/src/dsSrcFileCopyMany.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "dsSrcFileCopyMany" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | Implements dsISrc 11 | 12 | Private Function dsISrc_getName() As String 13 | dsISrc_getName = "FileCopy (Many)" 14 | End Function 15 | 16 | Private Function dsISrc_linkFiber(ByVal template As stdFiber, ByVal destPath As String, ByVal Data As stdJSON) As stdFiber 17 | Set dsISrc_linkFiber = template 18 | With template 19 | .Meta("Source") = Data.item("Source") 20 | .Meta("Destination") = destPath 21 | 22 | Dim cb As stdCallback: Set cb = stdCallback.CreateFromObjectMethod(dsSrcFileCopy, "protProcessCopySingleFile").Bind(srcPath, destPath, True) 23 | Call .add(cb.Bind(1), "1. launching copy") 24 | Call .add(cb.Bind(2), "2. awaiting copy completion") 25 | End With 26 | End Function 27 | 28 | Private Function dsISrc_getDataType() As stdJSON 29 | Set dsISrc_getDataType = stdJSON.Create(eJSONObject) 30 | With dsISrc_getDataType 31 | With .AddObject("Source") 32 | .add "DisplayText", "Source File" 33 | .add "Tooltip", "The location of the file to copy." 34 | .add "Type", "ObjectArray" 35 | With .AddObject("ObjectArray") 36 | .add "DisplayText", "Files" 37 | .add "Expandable", True 38 | With .AddObject("ObjectType") 39 | With .AddObject("File") 40 | .add "DisplayText", "File to copy" 41 | .add "Type", "Text" 42 | End With 43 | With .AddObject("Required") 44 | .add "DisplayText", "Required?" 45 | .add "Tooltip", "If the file is required, the routine will error if it isn't present. Else it will pass successfully." 46 | .add "Type", "Boolean" 47 | .add "Default", True 48 | End With 49 | End With 50 | End With 51 | End With 52 | End With 53 | End Function 54 | 55 | Public Function AsISrc() As dsISrc 56 | Set AsISrc = Me 57 | End Function 58 | 59 | 'Processes an async GISSTdb OLEdb query. 60 | '@fiberRunner 61 | '@protected 62 | Public Function protProcessCopySingleFile(ByVal State As Long, ByVal src As String, ByVal dest As String, ByVal required As Boolean, ByVal fiber As stdFiber) As Boolean 63 | Select Case State 64 | Case 1 65 | 'If it exists, copy it whatever 66 | If FileExists(src) Then 67 | 'Copy asynchronously 68 | Call shell("copy """ & src & """ """ & dest & """", vbHide) 69 | 'If it doesn't exist but is required, error 70 | ElseIf required Then 71 | Call fiber.RaiseCriticalError("File '" & src & "' is not present but is required.") 72 | Exit Function 73 | End If 74 | protProcessCopySingleFile = True 75 | Case 2 ' await copy completion 76 | If FileExists(dest) Then protProcessCopySingleFile = FileLen(src) = FileLen(dest) 77 | End Select 78 | End Function 79 | 80 | Private Function FileExists(ByVal FilePath As String) As Boolean 81 | FileExists = (Dir(FilePath) <> "") 82 | End Function 83 | 84 | 85 | -------------------------------------------------------------------------------- /Examples/DataSources/src/dsSrcGISSTdb.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "dsSrcGISSTdb" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = False 10 | Implements dsISrc 11 | 12 | Private Const ConnectionString As String = "Provider=sqloledb;Data Source=xxxxxx;Initial Catalog=xxxxxx;User Id=username;Password=password" 13 | 14 | Private Function dsISrc_getName() As String 15 | dsISrc_getName = "GISSTdb" 16 | End Function 17 | 18 | Private Function dsISrc_linkFiber(ByVal template As stdFiber, ByVal destPath As String, ByVal Data As stdJSON) As stdFiber 19 | Dim sql As String: sql = "select *, SHAPE.STAsText() as 'ShapeWKT' from $table" 20 | sql = Replace(sql, "$table", Data.item("Table")) 21 | 22 | Dim json As stdJSON: Set json = stdJSON.Create(eJSONObject) 23 | With json 24 | .add "ConnectionString", ConnectionString 25 | .add "Query", sql 26 | .add "isBigQuery", Data.item("isBigQuery") 27 | End With 28 | 29 | 'Delegate to dsSrcPowerQuery 30 | Set dsISrc_linkFiber = dsSrcDatabase.AsISrc.linkFiber(template, destPath, json) 31 | End Function 32 | 33 | Private Function dsISrc_getDataType() As stdJSON 34 | Set dsISrc_getDataType = stdJSON.Create(eJSONObject) 35 | With dsISrc_getDataType 36 | With .AddObject("Table") 37 | .add "DisplayText", "Table" 38 | .add "Tooltip", "The table to extract" 39 | .add "Type", "Text" 40 | End With 41 | 42 | With .AddObject("isBigQuery") 43 | .add "DisplayText", "Big?" 44 | .add "Tooltip", "TBC" 45 | .add "Type", "Boolean" 46 | End With 47 | End With 48 | End Function 49 | 50 | Public Function createFiberGISST(ByVal fiberTemplate As stdFiber, ByVal gisstLayer As String, ByVal destPath As String) As stdFiber 51 | Set createFiberGISST = fiberTemplate 52 | With createFiberGISST 53 | Const sqlTemplate As String = "select *, SHAPE.STAsText() as 'ShapeWKT' from $table" 54 | .Meta("SQL") = Replace(sqlTemplate, "$table", gisstLayer) 55 | .Meta("OutFile") = destPath 56 | Call .add(stdCallback.CreateFromModule("dsMain", "ProcessGISST").Bind(1), "1. Launch Query") 57 | Call .add(stdCallback.CreateFromModule("dsMain", "ProcessGISST").Bind(2), "2. Await Completion") 58 | Call .add(stdCallback.CreateFromModule("dsMain", "ProcessGISST").Bind(3), "3. Export CSV") 59 | End With 60 | End Function 61 | 62 | Public Function AsISrc() As dsISrc 63 | Set AsISrc = Me 64 | End Function 65 | -------------------------------------------------------------------------------- /Examples/DataSources/src/dsSrcPowerBI.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "dsSrcPowerBI" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = False 10 | Implements dsISrc 11 | 12 | Private Function dsISrc_getName() As String 13 | dsISrc_getName = "PowerBI" 14 | End Function 15 | 16 | Private Function dsISrc_linkFiber(ByVal template As stdFiber, ByVal destPath As String, ByVal Data As stdJSON) As stdFiber 17 | Dim pqFormula As String 18 | pqFormula = "let " & _ 19 | "Source = PowerPlatform.Dataflows(null), " & _ 20 | "Workspaces = Source{[Id=""Workspaces""]}[Data], " & _ 21 | "Workspace = Workspaces{[workspaceId=""$WorkspaceID""]}[Data], " & _ 22 | "Dataflow = Workspace{[dataflowId=""$DataFlowID""]}[Data], " & _ 23 | "Dataset = Dataflow{[entity=""$Entity"",version=""""]}[Data] " & _ 24 | "in Dataset" 25 | pqFormula = Replace(pqFormula, "$WorkspaceID", workspaceID) 26 | pqFormula = Replace(pqFormula, "$DataFlowID", dataflowID) 27 | pqFormula = Replace(pqFormula, "$Entity", entityName) 28 | 29 | Dim json As stdJSON: Set json = stdJSON.Create(eJSONObject) 30 | json.add "M", pqFormula 31 | 32 | 'Delegate to dsSrcPowerQuery 33 | Set dsISrc_linkFiber = dsSrcPowerQuery.AsISrc.linkFiber(template, destPath, json) 34 | End Function 35 | 36 | Private Function dsISrc_getDataType() As stdJSON 37 | Set dsISrc_getDataType = stdJSON.Create(eJSONObject) 38 | With dsISrc_getDataType 39 | With .AddObject("WorkspaceID") 40 | .add "DisplayText", "Workspace ID" 41 | .add "Tooltip", "" 42 | .add "Type", "Text" 43 | End With 44 | With .AddObject("DataFlowID") 45 | .add "DisplayText", "Dataflow ID" 46 | .add "Tooltip", "" 47 | .add "Type", "Text" 48 | End With 49 | With .AddObject("Entity") 50 | .add "DisplayText", "Entity name" 51 | .add "Tooltip", "" 52 | .add "Type", "Text" 53 | End With 54 | End With 55 | End Function 56 | 57 | Public Function AsISrc() As dsISrc 58 | Set AsISrc = Me 59 | End Function 60 | -------------------------------------------------------------------------------- /Examples/DataSources/src/dsSrcPowerQuery.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "dsSrcPowerQuery" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = False 10 | Implements dsISrc 11 | 12 | Private Function dsISrc_getName() As String 13 | dsISrc_getName = "PowerQuery" 14 | End Function 15 | 16 | Private Function dsISrc_linkFiber(ByVal template As stdFiber, ByVal destPath As String, ByVal Data As stdJSON) As stdFiber 17 | Set dsISrc_linkFiber = template 18 | With dsISrc_linkFiber 19 | .Meta("OutFile") = destPath 20 | .Meta("M") = Data.item("M") 21 | 22 | Call .add(stdCallback.CreateFromObjectMethod(Me, "protProcessPowerQuery").Bind(1), "1. Creating Query") 23 | Call .add(stdCallback.CreateFromObjectMethod(Me, "protProcessPowerQuery").Bind(2), "2. Executing Query") 24 | Call .add(stdCallback.CreateFromObjectMethod(Me, "protProcessPowerQuery").Bind(3), "3. Awaiting Query Completion") 25 | Call .add(stdCallback.CreateFromObjectMethod(Me, "protProcessPowerQuery").Bind(4), "4. Exporting to CSV") 26 | End With 27 | End Function 28 | 29 | Private Function dsISrc_getDataType() As stdJSON 30 | Set dsISrc_getDataType = stdJSON.Create(eJSONObject) 31 | With dsISrc_getDataType 32 | With .AddObject("M") 33 | .add "DisplayText", "M Code" 34 | .add "Tooltip", "The M/Mashup/PowerQuery code to execute." 35 | .add "Type", "MultiText" 36 | End With 37 | End With 38 | End Function 39 | 40 | 'Processes an excel query. 41 | '@fiberRunner 42 | '@protected 43 | Public Function protProcessPowerQuery(ByVal stage As Long, ByVal fiber As stdFiber) As Boolean 44 | With fiber 45 | Select Case stage 46 | Case 1 'create query of PowerBI data 47 | Dim xlApp As Excel.Application: Set xlApp = .Agent("xl") 48 | Dim wb As Workbook: Set wb = xlApp.Workbooks.add() 49 | Set .Meta("Workbook") = wb 50 | Set .Meta("Query") = wb.Queries.add("PQ", .Meta("M")) 51 | protProcessPowerQuery = True 52 | Case 2 'await completion 53 | Dim ws As Worksheet: Set ws = .Meta("Workbook").Sheets(1) 54 | Dim lo As ListObject: Set lo = ws.ListObjects.add(xlSrcQuery, "OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=PQ;Extended Properties=""""", Destination:=ws.Range("A1")) 55 | Set .Meta("ListObject") = lo 56 | Dim qt As QueryTable: Set qt = lo.QueryTable 57 | qt.CommandType = xlCmdSql 58 | qt.CommandText = Array("SELECT * FROM [PQ]") 59 | Call qt.Refresh(True) 60 | Set .Meta("QueryTable") = qt 61 | protProcessPowerQuery = True 62 | Case 3 63 | protProcessPowerQuery = Not .Meta("QueryTable").Refreshing 64 | DoEvents 65 | Case 4 'perform extraction 66 | Call RangeToCSV(.Meta("OutFile"), .Meta("ListObject").Range) 67 | Call .Meta("Workbook").Close(False) 68 | protProcessPowerQuery = True 69 | End Select 70 | End With 71 | End Function 72 | 73 | Public Function AsISrc() As dsISrc 74 | Set AsISrc = Me 75 | End Function 76 | 77 | -------------------------------------------------------------------------------- /Examples/DataSources/src/dsSrcSharePoint.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "dsSrcSharePoint" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = False 10 | Implements dsISrc 11 | 12 | Const SPRoot = "https://company.sharepoint.com" 13 | 14 | Private Function dsISrc_getName() As String 15 | dsISrc_getName = "Sharepoint" 16 | End Function 17 | 18 | Private Function dsISrc_linkFiber(ByVal template As stdFiber, ByVal destPath As String, ByVal Data As stdJSON) As stdFiber 19 | Dim pqFormula As String 20 | pqFormula = "let Source = SharePoint.Tables(""$siteURL"", [Implementation=null, ApiVersion=15]), Table = Source{[Title=""$listTitle""]}[Items] in Table" 21 | pqFormula = Replace(pqFormula, "$siteURL", SPRoot & Data.item("Site")) 22 | pqFormula = Replace(pqFormula, "$listTitle", Data.item("ListTitle")) 23 | 24 | Dim json As stdJSON: Set json = stdJSON.Create(eJSONObject) 25 | json.add "M", pqFormula 26 | 27 | 'Delegate to dsSrcPowerQuery 28 | Set dsISrc_linkFiber = dsSrcPowerQuery.AsISrc.linkFiber(template, destPath, json) 29 | End Function 30 | 31 | Private Function dsISrc_getDataType() As stdJSON 32 | Set dsISrc_getDataType = stdJSON.Create(eJSONObject) 33 | With dsISrc_getDataType 34 | With .AddObject("Site") 35 | .add "DisplayText", "Site URL" 36 | .add "Tooltip", "" 37 | .add "Type", "Text" 38 | End With 39 | 40 | With .AddObject("Site") 41 | .add "DisplayText", "Site URL" 42 | .add "Tooltip", "" 43 | .add "Type", "Text" 44 | End With 45 | 46 | With .AddObject("ListIdentifier") 47 | .add "DisplayText", "List identifier" 48 | .add "Tooltip", "How do you want to identify the list?" 49 | .add "Type", "Dropdown" 50 | With .AddObject("Dropdown") 51 | Dim c As New Collection 52 | c.add "By Title" 53 | c.add "By ID" 54 | .add "Options", c 55 | End With 56 | End With 57 | 58 | With .AddObject("ListTitle") 59 | .add "DisplayText", "List Title" 60 | .add "Tooltip", "" 61 | .add "Type", "Text" 62 | End With 63 | 64 | With .AddObject("ListID") 65 | .add "DisplayText", "List ID" 66 | .add "Tooltip", "" 67 | .add "Type", "Text" 68 | End With 69 | End With 70 | End Function 71 | 72 | Public Function AsISrc() As dsISrc 73 | Set AsISrc = Me 74 | End Function 75 | -------------------------------------------------------------------------------- /Examples/Document Generator/Document Generator.xlsm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Document Generator/Document Generator.xlsm -------------------------------------------------------------------------------- /Examples/Document Generator/Test.pptx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Document Generator/Test.pptx -------------------------------------------------------------------------------- /Examples/Document Generator/res/cry.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Document Generator/res/cry.png -------------------------------------------------------------------------------- /Examples/Document Generator/res/grin.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Document Generator/res/grin.png -------------------------------------------------------------------------------- /Examples/Document Generator/result/6527a2a0-2405-4778-9558-da50fd721536.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Document Generator/result/6527a2a0-2405-4778-9558-da50fd721536.pdf -------------------------------------------------------------------------------- /Examples/Document Generator/result/6527a2a0-2405-4778-9558-da50fd721537.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Document Generator/result/6527a2a0-2405-4778-9558-da50fd721537.pdf -------------------------------------------------------------------------------- /Examples/Document Generator/result/6527a2a0-2405-4778-9558-da50fd721538.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Document Generator/result/6527a2a0-2405-4778-9558-da50fd721538.pdf -------------------------------------------------------------------------------- /Examples/Document Generator/result/e673794f-1930-48e9-8cd7-acbddb005152.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Document Generator/result/e673794f-1930-48e9-8cd7-acbddb005152.pdf -------------------------------------------------------------------------------- /Examples/Document Generator/result/e673794f-1930-48e9-8cd7-acbddb005153.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Document Generator/result/e673794f-1930-48e9-8cd7-acbddb005153.pdf -------------------------------------------------------------------------------- /Examples/Document Generator/result/e673794f-1930-48e9-8cd7-acbddb005154.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Document Generator/result/e673794f-1930-48e9-8cd7-acbddb005154.pdf -------------------------------------------------------------------------------- /Examples/Document Generator/src/.Modules/genMain.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "genMain" 2 | #Const DEBUGGING = False 3 | 4 | Sub Main() 5 | 'Get Admin lookups 6 | Dim Lookups As Object: Set Lookups = getLookup(dataAdmin.ListObjects("Lookups")) 7 | 8 | 'Create factory from target type 9 | Dim factory As genIInjector 10 | Select Case Lookups("TargetType") 11 | Case "Excel" 12 | Set factory = genInjectorExcel 13 | Case "PowerPoint" 14 | Set factory = genInjectorPowerPoint 15 | Case Else 16 | Err.Raise 1, "", "No such target type '" & Lookups("TargetType") & "'" 17 | End Select 18 | 19 | 'Create injector from factory 20 | Dim injector As genIInjector 21 | Set injector = stdLambda.Create(Lookups("TargetLambda")).Run(factory) 22 | 23 | 'Get bindings 24 | Dim eBindings As stdEnumerator 25 | Set eBindings = injector.getFormulaBindings() 26 | 27 | 'Create lambdas ahead of time 28 | Dim binding As Object 29 | For Each binding In eBindings 30 | Set binding("lambda") = genLambdaEx.Create(binding("lambda")) 31 | Next 32 | 33 | 34 | Dim SourceFactory As stdLambda: Set SourceFactory = stdLambda.Create(Lookups("Source")).BindGlobal("stdTable", stdTable) 35 | Dim AfterUpdate As stdLambda: Set AfterUpdate = stdLambda.Create(Lookups("AfterUpdate")) 36 | 37 | Dim Source As stdTable: Set Source = SourceFactory.Run() 38 | Dim rows As stdEnumerator: Set rows = Source.rows 39 | #If DEBUGGING Then 40 | Set rows = rows.First(2) 41 | #End If 42 | 43 | Dim row As Object 44 | For Each row In rows 45 | 'Initialise target (create new document) 46 | Dim doc As Object: Set doc = injector.InitialiseTarget() 47 | 48 | 'Evaluate all bindings 49 | For Each binding In eBindings 50 | Dim lambdaEx As stdLambda: Set lambdaEx = binding("lambda") 51 | Dim target As Object: Set target = binding("getSetterTarget").Run() 52 | Call binding("setter").Run(lambdaEx.Run(row, target)) 53 | Next 54 | 55 | 'Run post-update lambda 56 | Call AfterUpdate.Run(doc, row) 57 | 58 | 'Cleanup the target (close the document etc.) 59 | injector.CleanupTarget 60 | 61 | DoEvents 62 | Next 63 | End Sub 64 | 65 | Private Function getLookup(ByVal lo As ListObject) As Object 66 | Set getLookup = CreateObject("Scripting.Dictionary") 67 | Dim v: v = lo.DataBodyRange.value 68 | For i = 1 To UBound(v, 1) 69 | getLookup.add v(i, 1), v(i, 2) 70 | Next 71 | End Function 72 | -------------------------------------------------------------------------------- /Examples/Document Generator/src/Class Modules/genIInjector.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "genIInjector" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | 'Create a new instance of the injector 11 | '@param templatePath - The path to the template file 12 | '@returns - An instance of a genIInjector object - within here include all initialisation stuff 13 | Public Function Create(ByVal templatePath As String, ParamArray v() As Variant) As genIInjector: End Function 14 | 15 | 'Obtain the bindings for the injector 16 | '@returns stdEnumerator>> - a list of bindings for the injector 17 | '@example ``` 18 | ' For each binding in injector.getFormulaBindings() 19 | ' binding("setter").call(stdLambda.create(binding("lambda")).call(row)) 20 | ' Next 21 | '``` 22 | Public Function getFormulaBindings() As stdEnumerator: End Function 23 | 24 | 'Initialise the target 25 | Public Function InitialiseTarget() As Object: End Function 26 | 27 | 'Cleanup the target 28 | Public Sub CleanupTarget(): End Sub 29 | -------------------------------------------------------------------------------- /Examples/Document Generator/src/Class Modules/genLambdaEx.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "genLambdaEx" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = False 10 | Private Type TThis 11 | meta As Object 12 | End Type 13 | Private This As TThis 14 | 15 | 'A small regex based DSL compiling to `stdLambda`. 16 | '@param {String} DSL syntax to execute. DSL is superset of stdLambda with addition in remarks. 17 | '@returns {stdLambda} Compiled lambda to execute. 18 | '@remarks Expects global "targetSheet" late-binding. Replaces `r[...]` with `targetSheet.range("...")` and `[...]` with `targetSheet.range("...").value` 19 | Public Function Create(ByVal sLambda As String, Optional ByVal meta As Object = Nothing) As stdLambda 20 | 'Obtain extension library 21 | Static oFuncExt As Object: If oFuncExt Is Nothing Then Set oFuncExt = GetExtensionLibrary() 22 | Set This.meta = meta 23 | 24 | 'Return translated lambda 25 | Set Create = stdLambda.Create(sLambda) 26 | Set Create.oFunctExt = oFuncExt 27 | End Function 28 | 29 | 'Get a dictionary containing all methods of this object as stdCallback 30 | '@returns {Object>} Dictionary of public methods and callbacks pointing to them 31 | Private Function GetExtensionLibrary() As Object 32 | Static oLib As Object 33 | If oLib Is Nothing Then 34 | Set oLib = CreateObject("Scripting.Dictionary") 35 | 36 | 'Add formula functions 37 | Dim vMethodName 38 | For Each vMethodName In stdCOM.Create(Application.WorksheetFunction).Methods 39 | Set oLib(vMethodName) = stdCallback.CreateFromObjectMethod(Application.WorksheetFunction, vMethodName) 40 | Next 41 | 42 | 'Add methods from this class 43 | For Each vMethodName In stdCOM.Create(Me).Methods 44 | If vMethodName <> "Create" Then 45 | Set oLib(vMethodName) = stdCallback.CreateFromObjectMethod(Me, vMethodName) 46 | End If 47 | Next 48 | 49 | 'Add keywords 50 | Set oLib("stdRegex") = stdRegex 51 | 52 | 'Add extensions 53 | Dim extension 54 | For Each extension In stdEnumerator.CreateFromListObject(dataExtensions.ListObjects("Extensions")).AsCollection 55 | Set oLib(extension("Namespace")) = Application.Run("'" & extension("Path") & "'!getExtension", This.meta) 56 | Next 57 | End If 58 | Set GetExtensionLibrary = oLib 59 | End Function 60 | 61 | Public Property Get meta() As Object 62 | Set meta = This.meta 63 | End Property 64 | 65 | '------------------------------------------------------------------------------------------------------------ 66 | 67 | 'Generates a new GUID 68 | '@param {} 69 | '@returns {string} a new random GUID 70 | Public Function getGUID() As String 71 | Call Randomize 'Ensure random GUID generated 72 | getGUID = "xxxxxxxx-xxxx-4xxx-yxxx-xxxxxxxxxxxx" 73 | getGUID = Replace(getGUID, "y", Hex(Rnd() And &H3 Or &H8)) 74 | Dim i As Long: For i = 1 To 30 75 | getGUID = Replace(getGUID, "x", Hex$(Int(Rnd() * 16)), 1, 1) 76 | Next 77 | End Function 78 | 79 | 'Imports an image into a specified range 80 | '@param path - The path to the picture to import 81 | '@returns Object> - A "picture obect" 82 | Public Function createPicture(ByVal path As String) As Object 83 | Set createPicture = CreateObject("Scripting.Dictionary") 84 | Call createPicture.add("Type", "Picture") 85 | Call createPicture.add("Path", path) 86 | End Function 87 | 88 | ''Imports a table into a specified range 89 | ''@param table as stdEnumerator> - 90 | 'Public Function createTable(ByVal table As stdTable) as Object 91 | ' Set createTable = CreateObject("Scripting.Dictionary") 92 | ' Call createTable.add("Type","Table") 93 | ' Call createTable.add("Table", table) 94 | 'End Function 95 | 96 | 97 | 98 | 99 | 100 | 'Test function, adds 2 numbers 101 | Public Function add(a As Double, b As Double) As Double 102 | add = a + b 103 | End Function 104 | 105 | '--Testing-- 106 | '@test 107 | Friend Sub test(ByVal sLambda As String) 108 | With Create(sLambda) 109 | Set .oFunctExt("targetSheet") = ActiveSheet 110 | MsgBox .Run() 111 | End With 112 | End Sub 113 | 114 | -------------------------------------------------------------------------------- /Examples/Document Generator/src/Dependencies/stdICallable.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "stdICallable" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | 11 | 'Call will call the passed function with param array 12 | Public Function Run(ParamArray params() As Variant) As Variant: End Function 13 | 14 | 'Call function with supplied array of params 15 | Public Function RunEx(ByVal params As Variant) As Variant: End Function 16 | 17 | 'Bind a parameter to the function 18 | Public Function Bind(ParamArray params() As Variant) As stdICallable: End Function 19 | 20 | 'Making late-bound calls to stdICallable members 21 | '@protected 22 | '@param {ByVal String} - Message to send 23 | '@param {ByRef Boolean} - Whether the call was successful 24 | '@param {ByVal Variant} - Any variant, typically parameters as an array. Passed along with the message. 25 | '@returns {Variant} - Any return value. 26 | Public Function SendMessage(ByVal sMessage As String, ByRef success As Boolean, ByVal params As Variant) As Variant: End Function 27 | 28 | 'Ideally we would want to get a pointer to the function... However, getting a pointer to an object method is 29 | 'going to be defficult, partly due to the first parameter sent to the function is `Me`! We'll likely have to 30 | 'use machine code to wrap a call with a `Me` pointer just so we can access the full pointer and use this in 31 | 'real life applications. 32 | 'Finally it might be better to do something more like: `stdPointer.fromICallable()` anyway 33 | ''Returns a callback function 34 | ''Typically this will be achieved with `stdPointer.GetLastPrivateMethod(me)` 35 | ''If this cannot be implemented return 0 36 | 'Public Function ToPointer() as long 37 | 38 | ''Bind arguments to functions to appear as first arguments in call. 39 | ''e.g. stdLambda.Create("$1.EnableEvents = false: $1.ScreenUpdating = false").bind(Application).Run() 40 | 'Public Function Bind(ByVal v as variant) as stdICallable: End Function 41 | 42 | 43 | -------------------------------------------------------------------------------- /Examples/DynamicForm-TransformObject/Demo.xlsm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/DynamicForm-TransformObject/Demo.xlsm -------------------------------------------------------------------------------- /Examples/DynamicForm-TransformObject/README.md: -------------------------------------------------------------------------------- 1 | 2 | # Dynamic Form sample - Transform an object 3 | 4 | Sometimes it is required to generate the contents of a userform on-demand (at runtime). This sample gives an example of one such case. The key function in play is `frTransformer.AlterObject` which displays a form to the user containing all the properties of the object passed into it. As the user changes the values in the userform the values are automatically updated back in the object. When the user closes the form the values are read back out to the worksheet (outputted to F2) 5 | 6 | ```vb 7 | Sub TestAlterObject() 8 | Dim o As DemoClass: Set o = New DemoClass 9 | o.Test1 = "a" 10 | o.Test2 = "b" 11 | 12 | 'Dump input data to sheet 13 | Call DumpPropsToRange(o, shDemo.Range("A2")) 14 | 15 | 'Show form and change object 16 | Call frTransformer.AlterObject(o) 17 | 18 | 'Dump output data to sheet 19 | Call DumpPropsToRange(o, shDemo.Range("F2")) 20 | End Sub 21 | ``` 22 | 23 | `stdVBA` makes this an easy job by simplifying what would be hundreds of lines of code down to 10 or so: 24 | 25 | ```vb 26 | Public Function AlterObject(ByVal obj As Object) As Object 27 | Dim ctrls As Collection: Set ctrls = New Collection 28 | Dim oForm As frTransformer: Set oForm = New frTransformer 29 | Dim index As Long: index = -2 30 | Dim prop 31 | For Each prop In stdCOM.Create(obj).Properties 32 | index = index + 2 33 | ctrls.add stdUIElement.CreateFromType(oForm.controls, uiLabel, prop & "_label", prop, fTop:=index * 20) 34 | ctrls.add stdUIElement.CreateFromType(oForm.controls, uiTextBox, prop & "_field", , CallByName(obj, prop, VbGet), _ 35 | stdLambda.Create("if $3 = EUIElementEvent.uiElementEventKeyUp then let $1." & prop & " = $2.value end").Bind(obj), _ 36 | fTop:=(index + 1) * 20) 37 | Next 38 | oForm.Show 39 | Set AlterObject = obj 40 | End Function 41 | ``` 42 | 43 | ![_](./docs//TransformerExample.png) -------------------------------------------------------------------------------- /Examples/DynamicForm-TransformObject/docs/TransformerExample.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/DynamicForm-TransformObject/docs/TransformerExample.png -------------------------------------------------------------------------------- /Examples/DynamicForm-TransformObject/src/DemoClass.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "DemoClass" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | Public Test1 As String 11 | Public Test2 As String 12 | -------------------------------------------------------------------------------- /Examples/DynamicForm-TransformObject/src/frTransformer.frm: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} frTransformer 3 | Caption = "Transformer" 4 | ClientHeight = 3015 5 | ClientLeft = 120 6 | ClientTop = 465 7 | ClientWidth = 4560 8 | OleObjectBlob = "frTransformer.frx":0000 9 | StartUpPosition = 1 'CenterOwner 10 | End 11 | Attribute VB_Name = "frTransformer" 12 | Attribute VB_GlobalNameSpace = False 13 | Attribute VB_Creatable = False 14 | Attribute VB_PredeclaredId = True 15 | Attribute VB_Exposed = False 16 | Public Function AlterObject(ByVal obj As Object) As Object 17 | Dim ctrls As Collection: Set ctrls = New Collection 18 | Dim oForm As frTransformer: Set oForm = New frTransformer 19 | Dim index As Long: index = -2 20 | Dim prop 21 | For Each prop In stdCOM.Create(obj).Properties 22 | index = index + 2 23 | ctrls.add stdUIElement.CreateFromType(oForm.controls, uiLabel, prop & "_label", prop, fTop:=index * 20) 24 | ctrls.add stdUIElement.CreateFromType(oForm.controls, uiTextBox, prop & "_field", , stdCallback.CreateFromObjectProperty(obj, prop, VbGet)(), _ 25 | stdLambda.Create("if $3 = EUIElementEvent.uiElementEventKeyUp then let $1." & prop & " = $2.value end").Bind(obj), fTop:=(index + 1) * 20) 26 | Next 27 | oForm.Show 28 | Set AlterObject = obj 29 | End Function 30 | 31 | -------------------------------------------------------------------------------- /Examples/DynamicForm-TransformObject/src/frTransformer.frx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/DynamicForm-TransformObject/src/frTransformer.frx -------------------------------------------------------------------------------- /Examples/DynamicForm-TransformObject/src/mMain.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "mMain" 2 | Sub TestAlterObject() 3 | Dim o As DemoClass: Set o = New DemoClass 4 | o.Test1 = "a" 5 | o.Test2 = "b" 6 | 7 | 'Dump input data to sheet 8 | Call DumpPropsToRange(o, shDemo.Range("A2")) 9 | 10 | 'Show form and change object 11 | Call frTransformer.AlterObject(o) 12 | 13 | 'Dump output data to sheet 14 | Call DumpPropsToRange(o, shDemo.Range("F2")) 15 | End Sub 16 | 17 | Private Sub DumpPropsToRange(obj As Object, r As Range) 18 | Dim c As Collection: Set c = stdCOM.Create(obj).Properties 19 | Dim v() 20 | ReDim v(1 To c.Count, 1 To 2) 21 | Dim index As Long: index = 0 22 | Dim prop 23 | For Each prop In c 24 | index = index + 1 25 | v(index, 1) = prop 26 | v(index, 2) = stdCallback.CreateFromObjectProperty(obj, prop, VbGet)() 27 | Next 28 | r.Resize(c.Count, 2).Value = v 29 | End Sub 30 | -------------------------------------------------------------------------------- /Examples/Inspector-Accessibility-v1/Accessibility Inspector.xlsm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Inspector-Accessibility-v1/Accessibility Inspector.xlsm -------------------------------------------------------------------------------- /Examples/Inspector-Accessibility-v1/README.md: -------------------------------------------------------------------------------- 1 | 8 | 9 | # Accessibility Inspector 10 | 11 | While using `stdAcc` it is often useful to be able to obtain the accessibility information at the cursor. This can help you find elements to further investigate the accessibility tree. This example provides a utility application which can be used to: 12 | 13 | * Pinpoint element attributes to assist during automation. 14 | * Allows setting of `accValue`, typically useful to test setting fields with information. 15 | * Allows execution of `DoDefaultAction`. 16 | 17 | 18 | ![inspector](./docs/inspector.png) 19 | 20 | ## Requirements 21 | 22 | * [stdVBA](http://github.com/sancarn/stdVBA) 23 | * stdAcc 24 | * stdWindow 25 | * stdICallable 26 | * Currently only works on Windows OS 27 | 28 | ## Usage 29 | 30 | Open xlsm and click launch! 31 | 32 | Move your mouse around to extract accessibility information 33 | 34 | ## Roadmap 35 | 36 | * [X] Extract basic accessibility information 37 | * [X] Provide a button to freeze time, allowing the copy and paste of data out of the form. 38 | * [X] Make form topmost 39 | * [ ] FIXME: Slow path creation over Excel. 40 | * [ ] Option to highlighting the hovered accessibility element with a yellow rect created with GDI+ to help indicate which window is being inspected. 41 | * [ ] Display the accessibility tree in a treeview control. Navigating the tree should navigate the inspected element and navigate "hover rectangle" above - this will likely be a different project. 42 | 43 | ## Known issues 44 | 45 | * Path field has currently been disabled. See roadmap. 46 | -------------------------------------------------------------------------------- /Examples/Inspector-Accessibility-v1/docs/inspector.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Inspector-Accessibility-v1/docs/inspector.png -------------------------------------------------------------------------------- /Examples/Inspector-Accessibility-v1/src/AccHelper.frm: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} AccHelper 3 | Caption = "Accessibility Helper" 4 | ClientHeight = 4800 5 | ClientLeft = 45 6 | ClientTop = 390 7 | ClientWidth = 4755 8 | OleObjectBlob = "AccHelper.frx":0000 9 | ShowModal = 0 'False 10 | StartUpPosition = 1 'CenterOwner 11 | End 12 | Attribute VB_Name = "AccHelper" 13 | Attribute VB_GlobalNameSpace = False 14 | Attribute VB_Creatable = False 15 | Attribute VB_PredeclaredId = True 16 | Attribute VB_Exposed = False 17 | 'in a module 18 | Option Explicit 19 | 20 | Public Shown As Boolean 21 | 22 | Public Enum EInspectState 23 | Permanent 24 | Temporary 25 | End Enum 26 | 27 | Private pInspectorState As EInspectState 28 | Private pDisabledTime As Date 29 | Private oInspected As stdAcc 30 | 31 | 32 | 33 | Private Sub DoDefaultAction_Click() 34 | stdWindow.CreateFromHwnd(oInspected.hwnd).Activate 35 | oInspected.DoDefaultAction 36 | End Sub 37 | 38 | Private Sub SetValue_Click() 39 | stdWindow.CreateFromHwnd(oInspected.hwnd).Activate 40 | oInspected.value = InputBox("What value due you want to set it to?") 41 | Call UpdateFromInspected 42 | End Sub 43 | 44 | Private Sub UserForm_Initialize() 45 | Me.Show 46 | Shown = True 47 | End Sub 48 | 49 | Public Sub Watch() 50 | stdWindow.CreateFromIUnknown(Me).isTopmost = True 51 | While Shown 52 | If Inspecting.value Then 53 | Set oInspected = stdAcc.CreateFromMouse() 54 | Call UpdateFromInspected 55 | End If 56 | 57 | 'Handle temporary inspector 58 | If pInspectorState = Temporary Then 59 | Dim c: c = Now() 60 | Dim timeLeft As Double: timeLeft = Round(Second(Application.Max(pDisabledTime - Now(), 0)), 1) 61 | If timeLeft = 0 Then 62 | Inspecting.value = False 63 | pInspectorState = Permanent 64 | End If 65 | SecondsLeft.Caption = timeLeft 66 | End If 67 | 68 | DoEvents 69 | Wend 70 | End Sub 71 | 72 | Public Sub UpdateFromInspected() 73 | On Error Resume Next 74 | With oInspected 75 | Me.crName.value = .name & "[P:" & .parent.name & "]" 76 | Me.crDefaultAction.value = .DefaultAction 77 | Me.crDescription.value = .Description 78 | Me.crRole.value = .Role 79 | Me.crStates.value = .States 80 | Me.crValue.value = .value 81 | Me.crLocation.value = "X: " & .Location!left & " Y: " & .Location!top & " W: " & .Location!width & " H: " & .Location!height 82 | Me.crHWND.value = .hwnd 83 | With stdWindow.CreateFromHwnd(.hwnd) 84 | If .Exists Then 85 | Me.crAppName.value = .ProcessName 86 | Me.crWindowClass.value = .Class 87 | End If 88 | End With 89 | On Error Resume Next 90 | 'Me.crPath.value = "" 91 | 'Me.crPath.value = .getPath() 92 | On Error GoTo 0 93 | End With 94 | End Sub 95 | 96 | Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) 97 | Shown = False 98 | Unload Me 99 | End Sub 100 | 101 | Private Sub Enable5_Click() 102 | pInspectorState = Temporary 103 | pDisabledTime = Now() + TimeSerial(0, 0, 5) 104 | Inspecting.value = True 105 | End Sub 106 | Private Sub Inspecting_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single) 107 | pInspectorState = Permanent 108 | End Sub 109 | 110 | Private Sub UserForm_Terminate() 111 | Unload Me 112 | End Sub 113 | 114 | -------------------------------------------------------------------------------- /Examples/Inspector-Accessibility-v1/src/AccHelper.frx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Inspector-Accessibility-v1/src/AccHelper.frx -------------------------------------------------------------------------------- /Examples/Inspector-Accessibility-v1/src/LaunchInspect.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "LaunchInspect" 2 | Sub Launch() 3 | Call AccHelper.Show 4 | Call AccHelper.Watch 5 | End Sub 6 | -------------------------------------------------------------------------------- /Examples/Inspector-Accessibility-v1/~$Accessibility Inspector.xlsm: -------------------------------------------------------------------------------- 1 | sancarn sancarn -------------------------------------------------------------------------------- /Examples/Inspector-Accessibility-v2/Accessibility Inspector v2.xlsm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Inspector-Accessibility-v2/Accessibility Inspector v2.xlsm -------------------------------------------------------------------------------- /Examples/Inspector-Accessibility-v2/README.md: -------------------------------------------------------------------------------- 1 | 8 | 9 | # Accessibility Inspector 10 | 11 | While using `stdAcc` it is often useful to be able to obtain the accessibility information at the cursor. This can help you find elements to further investigate the accessibility tree. This example provides a utility application which can be used to: 12 | 13 | * Pinpoint element attributes to assist during automation. 14 | * Allows setting of `accValue`, typically useful to test setting fields with information. 15 | * Allows execution of `DoDefaultAction`. 16 | 17 | 18 | ![inspector](./docs/InspectorTutorial.png) 19 | 20 | ## Requirements 21 | 22 | * [stdVBA](http://github.com/sancarn/stdVBA) 23 | * stdAcc 24 | * stdCallback 25 | * stdClipboard 26 | * stdICallable 27 | * stdImage 28 | * stdLambda 29 | * stdProcess 30 | * stdShell 31 | * stdWindow 32 | * tvTree 33 | * uiVBA 34 | * uiElement 35 | * uiMessagable 36 | * Currently only works on Windows OS 37 | 38 | ## Usage 39 | 40 | Open xlsm and click "Show Accessibility Inspector"! 41 | 42 | Navigate the treeview to insect the accessibility information of desktop windows. 43 | 44 | ## Roadmap 45 | 46 | * [X] Extract basic accessibility information 47 | * [X] Provide watchable cursor option. 48 | * [X] Provide a temporary watchable cursor option ( 5 second timeout ). 49 | * [X] Make form topmost 50 | * [X] Code generation algorithm to generate stdAcc code for usage in user applications. 51 | * [X] Search function to allow searching of accessibility tree. 52 | * [X] Ability to only show visible elements. 53 | * [X] Option to highlighting the selected accessibility element with a yellow rect. 54 | * [ ] Option to find and display the hovered element within the accessibility tree. 55 | -------------------------------------------------------------------------------- /Examples/Inspector-Accessibility-v2/docs/Inspector.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Inspector-Accessibility-v2/docs/Inspector.png -------------------------------------------------------------------------------- /Examples/Inspector-Accessibility-v2/docs/InspectorTutorial.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Inspector-Accessibility-v2/docs/InspectorTutorial.png -------------------------------------------------------------------------------- /Examples/Inspector-Accessibility-v2/docs/InspectorTutorial.pptx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Inspector-Accessibility-v2/docs/InspectorTutorial.pptx -------------------------------------------------------------------------------- /Examples/Inspector-Accessibility-v2/icons/HighlightRect.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Inspector-Accessibility-v2/icons/HighlightRect.png -------------------------------------------------------------------------------- /Examples/Inspector-Accessibility-v2/icons/Mouse.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Inspector-Accessibility-v2/icons/Mouse.png -------------------------------------------------------------------------------- /Examples/Inspector-Accessibility-v2/icons/Mouse5.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Inspector-Accessibility-v2/icons/Mouse5.png -------------------------------------------------------------------------------- /Examples/Inspector-Accessibility-v2/icons/Search.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Inspector-Accessibility-v2/icons/Search.png -------------------------------------------------------------------------------- /Examples/Inspector-Accessibility-v2/icons/VB.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Inspector-Accessibility-v2/icons/VB.png -------------------------------------------------------------------------------- /Examples/Inspector-Accessibility-v2/icons/VisibleOnly.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Inspector-Accessibility-v2/icons/VisibleOnly.png -------------------------------------------------------------------------------- /Examples/Inspector-Accessibility-v2/lib/stdICallable.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "stdICallable" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | 11 | 'Call will call the passed function with param array 12 | Public Function Run(ParamArray params() As Variant) As Variant: End Function 13 | 14 | 'Call function with supplied array of params 15 | Public Function RunEx(ByVal params As Variant) As Variant: End Function 16 | 17 | 'Bind a parameter to the function 18 | Public Function Bind(ParamArray params() As Variant) As stdICallable: End Function 19 | 20 | 'Making late-bound calls to stdICallable members 21 | '@protected 22 | '@param {ByVal String} - Message to send 23 | '@param {ByRef Boolean} - Whether the call was successful 24 | '@param {ByVal Variant} - Any variant, typically parameters as an array. Passed along with the message. 25 | '@returns {Variant} - Any return value. 26 | Public Function SendMessage(ByVal sMessage As String, ByRef success As Boolean, ByVal params As Variant) As Variant: End Function 27 | 28 | 'Ideally we would want to get a pointer to the function... However, getting a pointer to an object method is 29 | 'going to be defficult, partly due to the first parameter sent to the function is `Me`! We'll likely have to 30 | 'use machine code to wrap a call with a `Me` pointer just so we can access the full pointer and use this in 31 | 'real life applications. 32 | 'Finally it might be better to do something more like: `stdPointer.fromICallable()` anyway 33 | ''Returns a callback function 34 | ''Typically this will be achieved with `stdPointer.GetLastPrivateMethod(me)` 35 | ''If this cannot be implemented return 0 36 | 'Public Function ToPointer() as long 37 | 38 | ''Bind arguments to functions to appear as first arguments in call. 39 | ''e.g. stdLambda.Create("$1.EnableEvents = false: $1.ScreenUpdating = false").bind(Application).Run() 40 | 'Public Function Bind(ByVal v as variant) as stdICallable: End Function 41 | 42 | 43 | -------------------------------------------------------------------------------- /Examples/Inspector-Accessibility-v2/lib/tvTree.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "tvTree" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = False 10 | Private Type TThis 11 | tv As TreeView 12 | roots As Collection 13 | getID As stdICallable 14 | getName As stdICallable 15 | getChildren As stdICallable 16 | getIcon As stdICallable 17 | iconList As ImageList 18 | nodes As Object 19 | ContextMenu As CommandBar 20 | itemFilter As stdICallable 21 | End Type 22 | Private This As TThis 23 | Private WithEvents tv As TreeView 24 | Attribute tv.VB_VarHelpID = -1 25 | Private WithEvents btnRefresh As CommandBarButton 26 | Attribute btnRefresh.VB_VarHelpID = -1 27 | Public Event OnSelected(obj As Object) 28 | Public Event OnRefresh(obj As Object) 29 | 30 | Public Function Create(ByVal tv As TreeView, ByVal roots As Collection, ByVal getID As stdICallable, ByVal filter As stdICallable, ByVal getName As stdICallable, ByVal getChildren As stdICallable, Optional ByVal getIcon As stdICallable, Optional ByVal iconList As ImageList) As tvTree 31 | Set Create = New tvTree 32 | Call Create.protInit(tv, roots, getID, filter, getName, getChildren, getIcon, iconList) 33 | End Function 34 | Public Sub protInit(ByVal otv As TreeView, ByVal roots As Collection, ByVal getID As stdICallable, ByVal filter As stdICallable, ByVal getName As stdICallable, ByVal getChildren As stdICallable, ByVal getIcon As stdICallable, ByVal iconList As ImageList) 35 | Set This.tv = otv 36 | Set This.roots = roots 37 | Set This.getID = getID 38 | Set This.getName = getName 39 | Set This.getChildren = getChildren 40 | Set This.getIcon = getIcon 41 | Set This.iconList = iconList 42 | Set This.nodes = CreateObject("Scripting.Dictionary") 43 | Set This.itemFilter = filter 44 | Set tv = otv 45 | Set This.ContextMenu = Application.CommandBars.Add(getGUID(), msoBarPopup) 46 | With This.ContextMenu 47 | Set btnRefresh = .Controls.Add(msoControlButton) 48 | With btnRefresh 49 | .Caption = "&Refresh" 50 | .FaceId = 1759 51 | .Tag = "Refresh" 52 | End With 53 | End With 54 | 55 | tv.LineStyle = tvwRootLines 56 | tv.Indentation = 0 57 | tv.LabelEdit = tvwManual 58 | tv.Font.size = 12 59 | 60 | Dim root As Object 61 | For Each root In roots 62 | Dim sKey As String: sKey = This.getID.Run(root) 63 | Set This.nodes(sKey) = root 64 | Dim iImage As Variant: If This.getIcon Is Nothing Then iImage = GetMissing Else iImage = This.getIcon.Run(root) 65 | tv.nodes.Add key:=sKey, Text:=This.getName.Run(root), Image:=iImage 66 | tv.nodes.Add sKey, tvwChild, getGUID(), "Dummy" 67 | Next 68 | End Sub 69 | 70 | Public Property Get ContextMenu() As CommandBar 71 | Set ContextMenu = This.ContextMenu 72 | End Property 73 | 74 | 75 | 76 | Private Function GetMissing(Optional vMissing As Variant) As Variant 77 | GetMissing = vMissing 78 | End Function 79 | 80 | Private Sub btnRefresh_Click(ByVal ctrl As Office.CommandBarButton, CancelDefault As Boolean) 81 | 'Close and 82 | This.tv.SelectedItem.Expanded = False 83 | This.tv.nodes.Add This.tv.SelectedItem.key, tvwChild, getGUID(), "Dummy" 84 | 85 | RaiseEvent OnRefresh(This.nodes(This.tv.SelectedItem.key)) 86 | End Sub 87 | 88 | 89 | Private Sub Class_Terminate() 90 | 'Required to prevent crash due to circular reference between nodes and roots 91 | Set This.nodes = Nothing 92 | Set This.roots = Nothing 93 | End Sub 94 | 95 | Private Sub tv_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As stdole.OLE_XPOS_PIXELS, ByVal y As stdole.OLE_YPOS_PIXELS) 96 | Const BTN_RIGHT_CLICK = 2 97 | 98 | 'If right click 99 | If Button = BTN_RIGHT_CLICK Then 100 | Call This.ContextMenu.ShowPopup 101 | End If 102 | End Sub 103 | 104 | Private Sub tv_NodeClick(ByVal Node As MSComctlLib.Node) 105 | RaiseEvent OnSelected(This.nodes(Node.key)) 106 | End Sub 107 | 108 | 109 | 110 | Private Sub tv_Expand(ByVal Node As MSComctlLib.Node) 111 | 'Remove existing children 112 | If Node.children > 0 Then 113 | 'Get first child 114 | Dim oRef As Object: Set oRef = Node.child 115 | 116 | Dim i As Long 117 | For i = 1 To Node.children 118 | Dim oOldRef As Object: Set oOldRef = oRef 119 | Set oRef = oRef.Next 120 | Call This.tv.nodes.remove(oOldRef.key) 121 | Next 122 | End If 123 | 124 | Dim obj As Object: Set obj = This.nodes(Node.key) 125 | Dim children As Object: Set children = This.getChildren.Run(obj) 126 | On Error GoTo SkipNode 127 | Dim oChild As Object 128 | For Each oChild In children 129 | If This.itemFilter.Run(oChild) Then 130 | Dim sKey As String: sKey = This.getID.Run(oChild) 131 | Set This.nodes(sKey) = oChild 132 | Dim iImage As Variant: If This.getIcon Is Nothing Then iImage = GetMissing Else iImage = This.getIcon.Run(oChild) 133 | tv.nodes.Add relative:=This.getID.Run(obj), relationship:=tvwChild, key:=sKey, Text:=This.getName.Run(oChild), Image:=iImage 134 | tv.nodes.Add sKey, tvwChild, getGUID(), "Dummy" 135 | End If 136 | SkipNode: 137 | Next 138 | tv.Refresh 139 | End Sub 140 | 141 | Private Function getGUID() As String 142 | Call Randomize 'Ensure random GUID generated 143 | getGUID = "xxxxxxxx-xxxx-4xxx-yxxx-xxxxxxxxxxxx" 144 | getGUID = Replace(getGUID, "y", Hex(Rnd() And &H3 Or &H8)) 145 | Dim i As Long: For i = 1 To 30 146 | getGUID = Replace(getGUID, "x", Hex$(Int(Rnd() * 16)), 1, 1) 147 | Next 148 | End Function 149 | 150 | 151 | -------------------------------------------------------------------------------- /Examples/Inspector-Accessibility-v2/lib/uiIMessagable.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "uiIMessagable" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | 11 | Function Message(ByVal Caller As Object, iMessage As Long, Optional params As Variant = Empty) As Variant 12 | 13 | End Function 14 | -------------------------------------------------------------------------------- /Examples/Inspector-Accessibility-v2/src/AccessibilityInspector.frx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Inspector-Accessibility-v2/src/AccessibilityInspector.frx -------------------------------------------------------------------------------- /Examples/Inspector-Accessibility-v2/src/mCommands.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "mCommands" 2 | Sub ShowForm() 3 | AccessibilityInspector.Show 4 | End Sub 5 | 6 | Sub dumpClassesAll() 7 | Call dumpClasses(stdShell.CreateFile("C:\Temp\classes.txt"), stdAcc.CreateFromDesktop()) 8 | End Sub 9 | 10 | Sub dumpClasses(file As stdShell, ByVal acc As stdAcc) 11 | Dim wnd As stdWindow 12 | Set wnd = stdWindow.CreateFromHwnd(acc.hwnd) 13 | If wnd.Exists Then Call file.Append(wnd.Class & vbCrLf) 14 | Dim child As stdAcc 15 | For Each child In acc.children 16 | DoEvents 17 | Call dumpClasses(file, child) 18 | Next 19 | End Sub 20 | -------------------------------------------------------------------------------- /Examples/Inspector-Accessibility-v2/src/uiFields.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "uiFields" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = False 10 | Implements uiIMessagable 11 | Private Type TFieldControl 12 | id As Long 13 | name As String 14 | getValue As stdICallable 15 | execute As stdICallable 16 | 17 | ctrlName As uiElement 18 | ctrlValue As uiElement 19 | ctrlExec As uiElement 20 | End Type 21 | Private Type TThis 22 | indexLookup As Object 23 | selected As Object 24 | uiFrame As MSForms.Frame 25 | fields() As TFieldControl 26 | End Type 27 | Private This As TThis 28 | 29 | Public Function Create(ByVal fr As MSForms.Frame) As uiFields 30 | Set Create = New uiFields 31 | Call Create.protInit(fr) 32 | End Function 33 | 34 | Friend Sub protInit(ByVal fr As MSForms.Frame) 35 | Set This.uiFrame = fr 36 | Set This.indexLookup = CreateObject("Scripting.Dictionary") 37 | End Sub 38 | 39 | Public Property Get Top() As Long 40 | Top = This.uiFrame.Top 41 | End Property 42 | Public Property Let Top(v As Long) 43 | This.uiFrame.Top = v 44 | End Property 45 | Public Property Get Left() As Long 46 | Left = This.uiFrame.Left 47 | End Property 48 | Public Property Let Left(v As Long) 49 | This.uiFrame.Left = v 50 | End Property 51 | Public Property Get width() As Long 52 | width = This.uiFrame.width 53 | End Property 54 | Public Property Let width(v As Long) 55 | This.uiFrame.width = v 56 | Dim iWidth As Long: iWidth = (This.uiFrame.InsideWidth - 4) / 2 57 | Dim i As Long: For i = 0 To UBound(This.fields) 58 | With This.fields(i) 59 | .ctrlName.width = iWidth 60 | .ctrlValue.Left = 2 + iWidth 61 | .ctrlValue.width = iWidth 62 | If Not .execute Is Nothing Then 63 | .ctrlValue.width = .ctrlValue.width - 10 64 | .ctrlExec.Left = 2 + 2 * iWidth - 10 65 | End If 66 | End With 67 | Next 68 | End Property 69 | Public Property Get height() As Long 70 | height = This.uiFrame.height 71 | End Property 72 | Public Property Let height(v As Long) 73 | This.uiFrame.height = v 74 | End Property 75 | 76 | Public Function AddField(ByVal sName As String, ByVal getValue As stdICallable, Optional ByVal execute As stdICallable = Nothing, Optional ByVal execIcon As StdPicture) As Long 77 | Dim iWidth As Long: iWidth = This.uiFrame.InsideWidth - 4 78 | On Error Resume Next 79 | Dim i As Long: i = UBound(This.fields) + 1 80 | On Error GoTo 0 81 | ReDim Preserve This.fields(0 To i) 82 | With This.fields(i) 83 | .id = i 84 | Set .ctrlName = uiElement.CreateFromType(Me, This.uiFrame.Controls, uiLabel, "Name_" & i, sName, 2, 2 + i * (20 + 2), iWidth / 2, 20) 85 | Set .ctrlValue = uiElement.CreateFromType(Me, This.uiFrame.Controls, uiTextBox, "Value_" & i, "", 2 + iWidth / 2, 2 + i * (20 + 2), iWidth / 2, 20) 86 | Set .getValue = getValue 87 | If Not execute Is Nothing Then 88 | .ctrlValue.width = .ctrlValue.width - 10 89 | Set .ctrlExec = uiElement.CreateFromType(Me, This.uiFrame.Controls, uiImage, "Button_" & i, "", 2 + iWidth - 10, 2 + i * (20 + 2), 10, 20) 90 | Set .execute = execute 91 | This.indexLookup(.ctrlExec.id) = i 92 | End If 93 | This.indexLookup(.ctrlName.id) = i 94 | This.indexLookup(.ctrlValue.id) = i 95 | End With 96 | End Function 97 | 98 | 99 | Public Sub UpdateSelection(ByVal obj As Object) 100 | Set This.selected = obj 101 | 102 | Dim i As Long 103 | For i = 0 To UBound(This.fields) 104 | This.fields(i).ctrlValue.value = This.fields(i).getValue.Run(obj) 105 | Next 106 | End Sub 107 | 108 | 109 | 110 | 111 | 112 | 113 | 114 | 115 | 116 | 117 | 118 | 119 | 120 | 121 | 122 | 123 | 124 | Private Sub Class_Terminate() 125 | Set This.selected = Nothing 126 | End Sub 127 | 128 | Private Function uiIMessagable_Message(ByVal Caller As Object, iMessage As Long, Optional params As Variant = Empty) As Variant 129 | Dim el As uiElement: Set el = Caller 130 | If iMessage = EUIElementMessage.uiElementEventMouseClick Then 131 | Dim index As Long: index = This.indexLookup(el.id) 132 | With This.fields(index) 133 | If Not .execute Is Nothing Then Call .execute.Run(This.selected) 134 | End With 135 | End If 136 | End Function 137 | -------------------------------------------------------------------------------- /Examples/Inspector-Clipboard/Clipboard Inspector.xlsm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Inspector-Clipboard/Clipboard Inspector.xlsm -------------------------------------------------------------------------------- /Examples/Inspector-Clipboard/README.md: -------------------------------------------------------------------------------- 1 | # Clipboard Inspector 2 | 3 | ## Background 4 | 5 | A **Clipboard Inspector** is a tool or utility that allows users and developers to monitor and inspect the contents of the system clipboard in real-time. While most users interact with the clipboard through basic operations like cut, copy, and paste, a Clipboard Inspector provides a deeper insight into what data is currently stored and how it's formatted. 6 | 7 | For those already familiar with the clipboard's basic functionality, a Clipboard Inspector extends its utility by offering: 8 | 9 | - **Real-Time Monitoring**: See live updates of the clipboard content whenever it's changed, allowing for immediate verification of copy and paste operations. 10 | - **Data Format Inspection**: View all the different data formats that the clipboard is currently holding. The clipboard can store data in multiple formats simultaneously (e.g., plain text, rich text, images), and understanding these formats is crucial for debugging and development. 11 | - **Debugging Tool**: For developers, especially those creating applications that interact with the clipboard, a Clipboard Inspector is invaluable for testing how data is copied to and from the clipboard. It helps in ensuring that the application correctly handles various data formats. 12 | - **Security Auditing**: Monitor the clipboard to ensure that sensitive information is not inadvertently left accessible. This is important because some applications may have access to clipboard data, posing a potential security risk. 13 | 14 | By providing visibility into the clipboard's inner workings, the Clipboard Inspector empower users to have greater control and knowledge over what data is stored in the clipboard and how it works. 15 | 16 | ![_](docs/clipboard-inspector.png) 17 | 18 | ![_](docs/clipboard-inspector-imageView.png) 19 | 20 | ## TODO List 21 | 22 | - [X] Clipboard Monitoring 23 | - [X] Show all formats available on clipboard 24 | - [X] Show images copied to clipboard as images in the viewer 25 | - [ ] Clipboard History 26 | 27 | 28 | -------------------------------------------------------------------------------- /Examples/Inspector-Clipboard/docs/clipboard-inspector-imageView.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Inspector-Clipboard/docs/clipboard-inspector-imageView.png -------------------------------------------------------------------------------- /Examples/Inspector-Clipboard/docs/clipboard-inspector.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Inspector-Clipboard/docs/clipboard-inspector.png -------------------------------------------------------------------------------- /Examples/Inspector-Clipboard/~$Clipboard Inspector.xlsm: -------------------------------------------------------------------------------- 1 | sancarn sancarn -------------------------------------------------------------------------------- /Examples/Inspector-CommandBars/Inspector-CommandBars.xlsm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Inspector-CommandBars/Inspector-CommandBars.xlsm -------------------------------------------------------------------------------- /Examples/Inspector-CommandBars/README.md: -------------------------------------------------------------------------------- 1 | # CommandBar Inspector 2 | 3 | CommandBar Inspector is a utility designed for VBA developers and Office power users to explore and inspect the internal `CommandBar` structure of Microsoft Office applications, such as Excel. It provides quick access to `CommandBar` IDs and labels for use in customization, automation, or troubleshooting. 4 | 5 | ## Features 6 | 7 | * 🔍 Searchable Interface: Filter `CommandBars` and controls by name or ID. 8 | * 📋 Copy MSO ID: Easily copy the internal MSO control ID for Ribbon or CommandBar customization. 9 | * 🖱 Execute via Double-Click: Double-click a row to execute the corresponding control. 10 | * 🖨 Print: Copy (ctrl+c) or print VBA to execute the command bar control to the clipboard. 11 | * 📄 Support for Multiple Contexts: Switch between `Application.CommandBars` and `Application.VBE.CommandBars`! 12 | 13 | ## How to Use 14 | 15 | 1. Open the workbook 16 | 2. Ensure macros are enabled 17 | 3. Press the button on the main sheet. 18 | 4. Search/Find a command bar you want to use 19 | -------------------------------------------------------------------------------- /Examples/Inspector-CommandBars/libs/stdICallable.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "stdICallable" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | 11 | 'Run the function with supplied parameters 12 | '@param params - The parameters to run the function with 13 | '@returns - The result of the function 14 | Public Function Run(ParamArray params() As Variant) As Variant: End Function 15 | 16 | 'Run the function with a array of parameters 17 | '@param params as Variant> - The parameters to run the function with 18 | '@returns - The result of the function 19 | Public Function RunEx(ByVal params As Variant) As Variant: End Function 20 | 21 | 'Bind a set of parameters to the function call 22 | '@param params - The parameters to bind to the function 23 | '@returns - A new function with the parameters bound 24 | Public Function Bind(ParamArray params() As Variant) As stdICallable: End Function 25 | 26 | 'Making late-bound calls to `stdICallable` members. Each object which implements `stdICallable` 27 | 'will support a different set of latebound calls. 28 | '@protected 29 | '@param sMessage - Message to send. Standard messages include "obj" returning the object, "className" returning the class name. Other messages are implementation specific. 30 | '@param success - Whether the call was successful 31 | '@param params - Any variant, typically parameters as an array. Passed along with the message. 32 | '@returns - Any return value. 33 | Public Function SendMessage(ByVal sMessage As String, ByRef success As Boolean, ByVal params As Variant) As Variant: End Function 34 | 35 | 'Ideally we would want to get a pointer to the function... However, getting a pointer to an object method is 36 | 'going to be defficult, partly due to the first parameter sent to the function is `Me`! We'll likely have to 37 | 'use machine code to wrap a call with a `Me` pointer just so we can access the full pointer and use this in 38 | 'real life applications. 39 | 'Finally it might be better to do something more like: `stdPointer.fromICallable()` anyway 40 | ''Returns a callback function 41 | ''Typically this will be achieved with `stdPointer.GetLastPrivateMethod(me)` 42 | ''If this cannot be implemented return 0 43 | 'Public Function ToPointer() as long 44 | 45 | ''Bind arguments to functions to appear as first arguments in call. 46 | ''e.g. stdLambda.Create("$1.EnableEvents = false: $1.ScreenUpdating = false").bind(Application).Run() 47 | 'Public Function Bind(ByVal v as variant) as stdICallable: End Function 48 | 49 | 50 | -------------------------------------------------------------------------------- /Examples/Inspector-CommandBars/src/InspectCommandbars.frx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Inspector-CommandBars/src/InspectCommandbars.frx -------------------------------------------------------------------------------- /Examples/Inspector-CommandBars/src/Module1.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "Module1" 2 | Sub ShowInspector() 3 | InspectCommandbars.Show 4 | End Sub 5 | 6 | -------------------------------------------------------------------------------- /Examples/Inspector-JSON/JSON Viewer.xlsm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Inspector-JSON/JSON Viewer.xlsm -------------------------------------------------------------------------------- /Examples/Inspector-JSON/README.md: -------------------------------------------------------------------------------- 1 | # JSON Viewer 2 | 3 | ## Usage 4 | 5 | 1. Click `Show JSON viewer` button. 6 | 2. Select the JSON file to view. 7 | 3. View the data in the form. 8 | 9 | ![_](./res/Process.png) 10 | -------------------------------------------------------------------------------- /Examples/Inspector-JSON/lib/stdICallable.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "stdICallable" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | 11 | 'Call will call the passed function with param array 12 | Public Function Run(ParamArray params() As Variant) As Variant: End Function 13 | 14 | 'Call function with supplied array of params 15 | Public Function RunEx(ByVal params As Variant) As Variant: End Function 16 | 17 | 'Bind a parameter to the function 18 | Public Function Bind(ParamArray params() As Variant) As stdICallable: End Function 19 | 20 | 'Making late-bound calls to stdICallable members 21 | '@protected 22 | '@param {ByVal String} - Message to send 23 | '@param {ByRef Boolean} - Whether the call was successful 24 | '@param {ByVal Variant} - Any variant, typically parameters as an array. Passed along with the message. 25 | '@returns {Variant} - Any return value. 26 | Public Function SendMessage(ByVal sMessage As String, ByRef success As Boolean, ByVal params As Variant) As Variant: End Function 27 | 28 | 'Ideally we would want to get a pointer to the function... However, getting a pointer to an object method is 29 | 'going to be defficult, partly due to the first parameter sent to the function is `Me`! We'll likely have to 30 | 'use machine code to wrap a call with a `Me` pointer just so we can access the full pointer and use this in 31 | 'real life applications. 32 | 'Finally it might be better to do something more like: `stdPointer.fromICallable()` anyway 33 | ''Returns a callback function 34 | ''Typically this will be achieved with `stdPointer.GetLastPrivateMethod(me)` 35 | ''If this cannot be implemented return 0 36 | 'Public Function ToPointer() as long 37 | 38 | ''Bind arguments to functions to appear as first arguments in call. 39 | ''e.g. stdLambda.Create("$1.EnableEvents = false: $1.ScreenUpdating = false").bind(Application).Run() 40 | 'Public Function Bind(ByVal v as variant) as stdICallable: End Function 41 | 42 | 43 | -------------------------------------------------------------------------------- /Examples/Inspector-JSON/lib/tvTree.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "tvTree" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = False 10 | Private Type TThis 11 | tv As TreeView 12 | roots As Collection 13 | getID As stdICallable 14 | getName As stdICallable 15 | getChildren As stdICallable 16 | getIcon As stdICallable 17 | iconList As ImageList 18 | nodes As Object 19 | ContextMenu As CommandBar 20 | End Type 21 | Private This As TThis 22 | Private WithEvents tv As TreeView 23 | Attribute tv.VB_VarHelpID = -1 24 | Private WithEvents btnRefresh As CommandBarButton 25 | Attribute btnRefresh.VB_VarHelpID = -1 26 | Public Event OnSelected(obj As Object) 27 | Public Event OnRefresh(obj As Object) 28 | 29 | Public Function Create(ByVal tv As TreeView, ByVal roots As Collection, ByVal getID As stdICallable, ByVal getName As stdICallable, ByVal getChildren As stdICallable, Optional ByVal getIcon As stdICallable, Optional ByVal iconList As ImageList) As tvTree 30 | Set Create = New tvTree 31 | Call Create.protInit(tv, roots, getID, getName, getChildren, getIcon, iconList) 32 | End Function 33 | Public Sub protInit(ByVal otv As TreeView, ByVal roots As Collection, ByVal getID As stdICallable, ByVal getName As stdICallable, ByVal getChildren As stdICallable, ByVal getIcon As stdICallable, ByVal iconList As ImageList) 34 | Set This.tv = otv 35 | Set This.roots = roots 36 | Set This.getID = getID 37 | Set This.getName = getName 38 | Set This.getChildren = getChildren 39 | Set This.getIcon = getIcon 40 | Set This.iconList = iconList 41 | Set This.nodes = CreateObject("Scripting.Dictionary") 42 | Set tv = otv 43 | Set This.ContextMenu = Application.CommandBars.Add(getGUID(), msoBarPopup) 44 | With This.ContextMenu 45 | Set btnRefresh = .Controls.Add(msoControlButton) 46 | With btnRefresh 47 | .Caption = "&Refresh" 48 | .FaceId = 1759 49 | .Tag = "Refresh" 50 | End With 51 | End With 52 | 53 | tv.LineStyle = tvwRootLines 54 | tv.Indentation = 0 55 | tv.LabelEdit = tvwManual 56 | tv.Font.size = 12 57 | 58 | Dim root As Object 59 | For Each root In roots 60 | Dim sKey As String: sKey = This.getID.Run(root) 61 | Set This.nodes(sKey) = root 62 | Dim iImage As Variant: If This.getIcon Is Nothing Then iImage = GetMissing Else iImage = This.getIcon.Run(root) 63 | tv.nodes.Add key:=sKey, text:=This.getName.Run(root), Image:=iImage 64 | tv.nodes.Add sKey, tvwChild, getGUID(), "Dummy" 65 | Next 66 | End Sub 67 | 68 | Public Property Get ContextMenu() As CommandBar 69 | Set ContextMenu = This.ContextMenu 70 | End Property 71 | 72 | 73 | 74 | Private Function GetMissing(Optional vMissing As Variant) As Variant 75 | GetMissing = vMissing 76 | End Function 77 | 78 | Private Sub btnRefresh_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean) 79 | 'Close and 80 | This.tv.SelectedItem.Expanded = False 81 | This.tv.nodes.Add This.tv.SelectedItem.key, tvwChild, getGUID(), "Dummy" 82 | 83 | RaiseEvent OnRefresh(This.nodes(This.tv.SelectedItem.key)) 84 | End Sub 85 | 86 | 87 | Private Sub Class_Terminate() 88 | 'Required to prevent crash due to circular reference between nodes and roots 89 | Set This.nodes = Nothing 90 | Set This.roots = Nothing 91 | End Sub 92 | 93 | Private Sub tv_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As stdole.OLE_XPOS_PIXELS, ByVal y As stdole.OLE_YPOS_PIXELS) 94 | Const BTN_RIGHT_CLICK = 2 95 | 96 | 'If right click 97 | If Button = BTN_RIGHT_CLICK Then 98 | Call This.ContextMenu.ShowPopup 99 | End If 100 | End Sub 101 | 102 | Private Sub tv_NodeClick(ByVal Node As MSComctlLib.Node) 103 | RaiseEvent OnSelected(This.nodes(Node.key)) 104 | End Sub 105 | 106 | 107 | 108 | Private Sub tv_Expand(ByVal Node As MSComctlLib.Node) 109 | 'Remove existing children 110 | If Node.children > 0 Then 111 | 'Get first child 112 | Dim oRef As Object: Set oRef = Node.child 113 | 114 | Dim i As Long 115 | For i = 1 To Node.children 116 | Dim oOldRef As Object: Set oOldRef = oRef 117 | Set oRef = oRef.Next 118 | Call This.tv.nodes.Remove(oOldRef.key) 119 | Next 120 | End If 121 | 122 | Dim obj As Object: Set obj = This.nodes(Node.key) 123 | Dim oChild As Object 124 | For Each oChild In This.getChildren.Run(obj) 125 | Dim sKey As String: sKey = This.getID.Run(oChild) 126 | Set This.nodes(sKey) = oChild 127 | Dim iImage As Variant: If This.getIcon Is Nothing Then iImage = GetMissing Else iImage = This.getIcon.Run(oChild) 128 | tv.nodes.Add relative:=This.getID.Run(obj), relationship:=tvwChild, key:=sKey, text:=This.getName.Run(oChild), Image:=iImage 129 | tv.nodes.Add sKey, tvwChild, getGUID(), "Dummy" 130 | Next 131 | tv.Refresh 132 | End Sub 133 | 134 | Private Function getGUID() As String 135 | Call Randomize 'Ensure random GUID generated 136 | getGUID = "xxxxxxxx-xxxx-4xxx-yxxx-xxxxxxxxxxxx" 137 | getGUID = Replace(getGUID, "y", Hex(Rnd() And &H3 Or &H8)) 138 | Dim i As Long: For i = 1 To 30 139 | getGUID = Replace(getGUID, "x", Hex$(Int(Rnd() * 16)), 1, 1) 140 | Next 141 | End Function 142 | 143 | 144 | -------------------------------------------------------------------------------- /Examples/Inspector-JSON/res/0_ClickButton.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Inspector-JSON/res/0_ClickButton.png -------------------------------------------------------------------------------- /Examples/Inspector-JSON/res/1_SelectFile.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Inspector-JSON/res/1_SelectFile.png -------------------------------------------------------------------------------- /Examples/Inspector-JSON/res/2_ViewData.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Inspector-JSON/res/2_ViewData.png -------------------------------------------------------------------------------- /Examples/Inspector-JSON/res/Process.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Inspector-JSON/res/Process.png -------------------------------------------------------------------------------- /Examples/Inspector-JSON/src/JSONViewer.frm: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} JSONViewer 3 | Caption = "Registry Viewer" 4 | ClientHeight = 6285 5 | ClientLeft = 120 6 | ClientTop = 465 7 | ClientWidth = 10260 8 | OleObjectBlob = "JSONViewer.frx":0000 9 | ShowModal = 0 'False 10 | StartUpPosition = 1 'CenterOwner 11 | End 12 | Attribute VB_Name = "JSONViewer" 13 | Attribute VB_GlobalNameSpace = False 14 | Attribute VB_Creatable = False 15 | Attribute VB_PredeclaredId = True 16 | Attribute VB_Exposed = False 17 | #Const UseDictionaryLateBinding = True 18 | Private WithEvents tree As tvTree 19 | Attribute tree.VB_VarHelpID = -1 20 | Private SelectedEntry As Object 21 | 22 | 23 | Public Sub ShowViewerFromString(ByVal data As String) 24 | Dim json As stdJSON: Set json = stdJSON.CreateFromString(data) 25 | Dim uf As JSONViewer: Set uf = New JSONViewer 26 | Call uf.ShowViewer(json) 27 | End Sub 28 | 29 | 30 | Public Sub ShowViewerFromFile(ByVal path As String) 31 | Dim json As stdJSON: Set json = stdJSON.CreateFromFile(path) 32 | Dim uf As JSONViewer: Set uf = New JSONViewer 33 | Call uf.ShowViewer(json) 34 | End Sub 35 | 36 | Public Sub ShowViewer(ByVal json As stdJSON) 37 | 'Roots to render in tree 38 | Dim root As Object: Set root = CreateDictionary("key", "root", "value", json, "isJSON", True, "parent", Me) 39 | Dim roots As Collection: Set roots = New Collection: Call roots.Add(root) 40 | 41 | 'Create tree 42 | Set tree = tvTree.Create( _ 43 | JsonTree, _ 44 | roots, _ 45 | stdCallback.CreateFromObjectMethod(Me, "getItemID"), _ 46 | stdCallback.CreateFromObjectMethod(Me, "getItemName"), _ 47 | stdCallback.CreateFromObjectMethod(Me, "getItemChildren") _ 48 | ) 49 | 50 | ''Add context menu buttons 51 | ' With tree.ContextMenu 52 | ' Set btnCopyCode = .Controls.Add(msoControlButton, 1) 53 | ' With btnCopyCode 54 | ' .Caption = "&Copy stdVBA code" 55 | ' .FaceId = 19 56 | ' .Tag = "Copy" 57 | ' End With 58 | ' End With 59 | 60 | Call tree_OnSelected(roots(1)) 61 | 62 | Call Me.Show 63 | End Sub 64 | 65 | 'Private Sub btnCopyCode_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean) 66 | ' '... 67 | 'End Sub 68 | 69 | 'Get some unique item ID 70 | Public Function getItemID(ByVal v As Object) As String 71 | If v("isJSON") Then 72 | getItemID = ObjPtr(v("value")) 73 | Else 74 | getItemID = ObjPtr(v("parent")) & "." & v("key") 75 | End If 76 | End Function 77 | 78 | 'Get the name of the item to be displayed in the tree view 79 | Public Function getItemName(ByVal v As Object) As String 80 | If v("isJSON") Then 81 | Select Case v("value").JsonType 82 | Case eJSONObject 83 | getItemName = simpleSerialise(v("key")) & " : Object" 84 | Case eJSONArray 85 | getItemName = v("key") & " : Array" 86 | End Select 87 | Else 88 | getItemName = simpleSerialise(v("key")) & ": " & simpleSerialise(v("value")) 89 | End If 90 | End Function 91 | 92 | 'Obtain the children of the item 93 | Public Function getItemChildren(ByVal v As Object) As Collection 94 | If v("isJSON") Then 95 | Set getItemChildren = v("value").ChildrenInfo 96 | Else 97 | Set getItemChildren = New Collection 98 | End If 99 | End Function 100 | 101 | Private Sub tree_OnRefresh(obj As Object) 102 | Call tree_OnSelected(obj) 103 | End Sub 104 | 105 | Private Sub tree_OnSelected(obj As Object) 106 | 'Set selected item 107 | Set SelectedEntry = obj 108 | End Sub 109 | 110 | Private Function simpleSerialise(ByVal v As Variant) As String 111 | Select Case vartype(v) 112 | Case VbVarType.vbString 113 | simpleSerialise = """" & v & """" 114 | Case VbVarType.vbBoolean 115 | simpleSerialise = iif(v, "true", "false") 116 | Case VbVarType.vbNull 117 | simpleSerialise = "null" 118 | Case Else 119 | simpleSerialise = v 120 | End Select 121 | End Function 122 | 123 | Private Function getGUID() As String 124 | Call Randomize 'Ensure random GUID generated 125 | getGUID = "xxxxxxxx-xxxx-4xxx-yxxx-xxxxxxxxxxxx" 126 | getGUID = Replace(getGUID, "y", Hex(Rnd() And &H3 Or &H8)) 127 | Dim i As Long: For i = 1 To 30 128 | getGUID = Replace(getGUID, "x", Hex$(Int(Rnd() * 16)), 1, 1) 129 | Next 130 | End Function 131 | 132 | 'Create a dictionary 133 | '@returns - The dictionary 134 | Private Function CreateDictionary(ParamArray children()) As Object 135 | #If UseDictionaryLateBinding Then 136 | Set CreateDictionary = CreateObject("Scripting.Dictionary") 137 | #Else 138 | Set CreateDictionary = New Scripting.Dictionary 139 | #End If 140 | CreateDictionary.CompareMode = vbTextCompare 141 | 142 | Dim i As Long 143 | For i = LBound(children) To UBound(children) Step 2 144 | Call CreateDictionary.Add(children(i), children(i + 1)) 145 | Next 146 | End Function 147 | 148 | -------------------------------------------------------------------------------- /Examples/Inspector-JSON/src/JSONViewer.frx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Inspector-JSON/src/JSONViewer.frx -------------------------------------------------------------------------------- /Examples/Inspector-JSON/src/modMain.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "modMain" 2 | Sub ShowForm() 3 | With Application.FileDialog(msoFileDialogFilePicker) 4 | .AllowMultiSelect = False 5 | .Title = "Please select the JSON file to view" 6 | .Filters.Add "JSON", "*.json" 7 | If .Show Then 8 | Dim path As String: path = .SelectedItems(1) 9 | Call JSONViewer.ShowViewerFromFile(path) 10 | End If 11 | End With 12 | End Sub 13 | 14 | -------------------------------------------------------------------------------- /Examples/Inspector-Registry/README.md: -------------------------------------------------------------------------------- 1 | # Registry Viewer 2 | 3 | ## Usage 4 | 5 | 1. Click `Show Registry Viewer` button 6 | 2. Search the tree. 7 | 8 | ![_](./res/Process.png) 9 | 10 | You can also copy the stdVBA code for selecting the registry key. 11 | -------------------------------------------------------------------------------- /Examples/Inspector-Registry/Registry Viewer.xlsm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Inspector-Registry/Registry Viewer.xlsm -------------------------------------------------------------------------------- /Examples/Inspector-Registry/res/Process.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Inspector-Registry/res/Process.png -------------------------------------------------------------------------------- /Examples/Inspector-Registry/src/RegistryViewer.frm: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} RegistryViewer 3 | Caption = "Registry Viewer" 4 | ClientHeight = 6285 5 | ClientLeft = 120 6 | ClientTop = 465 7 | ClientWidth = 10260 8 | OleObjectBlob = "RegistryViewer.frx":0000 9 | ShowModal = 0 'False 10 | StartUpPosition = 1 'CenterOwner 11 | End 12 | Attribute VB_Name = "RegistryViewer" 13 | Attribute VB_GlobalNameSpace = False 14 | Attribute VB_Creatable = False 15 | Attribute VB_PredeclaredId = True 16 | Attribute VB_Exposed = False 17 | Private WithEvents tree As tvTree 18 | Attribute tree.VB_VarHelpID = -1 19 | Private WithEvents btnCopyCode As CommandBarButton 20 | Attribute btnCopyCode.VB_VarHelpID = -1 21 | Private SelectedEntry As stdReg 22 | 23 | Private Sub btnCopyCode_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean) 24 | stdClipboard.text = "stdReg.CreateFromKey(""" & SelectedEntry.path & """)" 25 | End Sub 26 | 27 | Private Sub tree_OnRefresh(obj As Object) 28 | Call tree_OnSelected(obj) 29 | End Sub 30 | 31 | Private Sub tree_OnSelected(obj As Object) 32 | 'Set selected item 33 | Set SelectedEntry = obj 34 | 35 | 'Set address bar path to selkected item path 36 | RegistryAddress.value = SelectedEntry.path 37 | 38 | 'Add items to listview 39 | RegistryItems.ListItems.Clear 40 | Dim item As stdReg 41 | For Each item In SelectedEntry.Items 42 | With RegistryItems.ListItems.Add(, , item.name) 43 | Call .ListSubItems.Add(, , ItemTypeText(item.ItemType)) 44 | Call .ListSubItems.Add(, , item.value) 45 | End With 46 | Next 47 | End Sub 48 | 49 | 'Get item type to text description 50 | Private Function ItemTypeText(ByVal it As ERegistryValueType) As String 51 | Select Case it 52 | Case ERegistryValueType.Value_Binary: ItemTypeText = "BINARY" 53 | Case ERegistryValueType.Value_DWORD: ItemTypeText = "DWORD" 54 | Case ERegistryValueType.Value_DWORD_BE: ItemTypeText = "DWORD_BE" 55 | Case ERegistryValueType.Value_Link: ItemTypeText = "LINK" 56 | Case ERegistryValueType.Value_None: ItemTypeText = "NONE" 57 | Case ERegistryValueType.Value_QWORD: ItemTypeText = "QWORD" 58 | Case ERegistryValueType.Value_String: ItemTypeText = "STRING" 59 | Case ERegistryValueType.Value_String_Array: ItemTypeText = "STRING_ARRAY" 60 | Case ERegistryValueType.Value_String_WithEnvVars: ItemTypeText = "STRING_WITH_ENV" 61 | End Select 62 | End Function 63 | 64 | Private Sub UserForm_Initialize() 65 | 'Roots to render in tree 66 | Dim roots As Collection: Set roots = New Collection 67 | Call roots.Add(stdReg.Create("HKEY_CURRENT_USER")) 68 | Call roots.Add(stdReg.Create("HKEY_LOCAL_MACHINE")) 69 | Call roots.Add(stdReg.Create("HKEY_CLASSES_ROOT")) 70 | Call roots.Add(stdReg.Create("HKEY_USERS")) 71 | 72 | 'Create tree 73 | Set tree = tvTree.Create( _ 74 | RegistryKeys, _ 75 | roots, _ 76 | stdLambda.Create("$1.Path"), _ 77 | stdLambda.Create("$1.Name"), _ 78 | stdLambda.Create("$1.Keys") _ 79 | ) 80 | ' 81 | With tree.ContextMenu 82 | Set btnCopyCode = .Controls.Add(msoControlButton, 1) 83 | With btnCopyCode 84 | .Caption = "&Copy stdVBA code" 85 | .FaceId = 19 86 | .Tag = "Copy" 87 | End With 88 | End With 89 | 90 | 'Add columns to listview 91 | RegistryItems.View = lvwReport 92 | RegistryItems.ColumnHeaders.Add text:="Name" 93 | RegistryItems.ColumnHeaders.Add text:="Type" 94 | RegistryItems.ColumnHeaders.Add text:="Data" 95 | 96 | 'Select first element 97 | Call tree_OnSelected(roots(1)) 98 | End Sub 99 | 100 | 101 | -------------------------------------------------------------------------------- /Examples/Inspector-Registry/src/RegistryViewer.frx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Inspector-Registry/src/RegistryViewer.frx -------------------------------------------------------------------------------- /Examples/Inspector-Registry/src/stdICallable.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "stdICallable" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | 11 | 'Call will call the passed function with param array 12 | Public Function Run(ParamArray params() As Variant) As Variant: End Function 13 | 14 | 'Call function with supplied array of params 15 | Public Function RunEx(ByVal params As Variant) As Variant: End Function 16 | 17 | 'Bind a parameter to the function 18 | Public Function Bind(ParamArray params() As Variant) As stdICallable: End Function 19 | 20 | 'Making late-bound calls to stdICallable members 21 | '@protected 22 | '@param {ByVal String} - Message to send 23 | '@param {ByRef Boolean} - Whether the call was successful 24 | '@param {ByVal Variant} - Any variant, typically parameters as an array. Passed along with the message. 25 | '@returns {Variant} - Any return value. 26 | Public Function SendMessage(ByVal sMessage As String, ByRef success As Boolean, ByVal params As Variant) As Variant: End Function 27 | 28 | 'Ideally we would want to get a pointer to the function... However, getting a pointer to an object method is 29 | 'going to be defficult, partly due to the first parameter sent to the function is `Me`! We'll likely have to 30 | 'use machine code to wrap a call with a `Me` pointer just so we can access the full pointer and use this in 31 | 'real life applications. 32 | 'Finally it might be better to do something more like: `stdPointer.fromICallable()` anyway 33 | ''Returns a callback function 34 | ''Typically this will be achieved with `stdPointer.GetLastPrivateMethod(me)` 35 | ''If this cannot be implemented return 0 36 | 'Public Function ToPointer() as long 37 | 38 | ''Bind arguments to functions to appear as first arguments in call. 39 | ''e.g. stdLambda.Create("$1.EnableEvents = false: $1.ScreenUpdating = false").bind(Application).Run() 40 | 'Public Function Bind(ByVal v as variant) as stdICallable: End Function 41 | 42 | 43 | -------------------------------------------------------------------------------- /Examples/Inspector-Registry/src/tvTree.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "tvTree" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = False 10 | Private Type TThis 11 | tv As TreeView 12 | roots As Collection 13 | getID As stdICallable 14 | getName As stdICallable 15 | getChildren As stdICallable 16 | getIcon As stdICallable 17 | iconList As ImageList 18 | nodes As Object 19 | ContextMenu As CommandBar 20 | End Type 21 | Private This As TThis 22 | Private WithEvents tv As TreeView 23 | Attribute tv.VB_VarHelpID = -1 24 | Private WithEvents btnRefresh As CommandBarButton 25 | Attribute btnRefresh.VB_VarHelpID = -1 26 | Public Event OnSelected(obj As Object) 27 | Public Event OnRefresh(obj As Object) 28 | 29 | Public Function Create(ByVal tv As TreeView, ByVal roots As Collection, ByVal getID As stdICallable, ByVal getName As stdICallable, ByVal getChildren As stdICallable, Optional ByVal getIcon As stdICallable, Optional ByVal iconList As ImageList) As tvTree 30 | Set Create = New tvTree 31 | Call Create.protInit(tv, roots, getID, getName, getChildren, getIcon, iconList) 32 | End Function 33 | Public Sub protInit(ByVal otv As TreeView, ByVal roots As Collection, ByVal getID As stdICallable, ByVal getName As stdICallable, ByVal getChildren As stdICallable, ByVal getIcon As stdICallable, ByVal iconList As ImageList) 34 | Set This.tv = otv 35 | Set This.roots = roots 36 | Set This.getID = getID 37 | Set This.getName = getName 38 | Set This.getChildren = getChildren 39 | Set This.getIcon = getIcon 40 | Set This.iconList = iconList 41 | Set This.nodes = CreateObject("Scripting.Dictionary") 42 | Set tv = otv 43 | Set This.ContextMenu = Application.CommandBars.Add(getGUID(), msoBarPopup) 44 | With This.ContextMenu 45 | Set btnRefresh = .Controls.Add(msoControlButton) 46 | With btnRefresh 47 | .Caption = "&Refresh" 48 | .FaceId = 1759 49 | .Tag = "Refresh" 50 | End With 51 | End With 52 | 53 | tv.LineStyle = tvwRootLines 54 | tv.Indentation = 0 55 | tv.LabelEdit = tvwManual 56 | tv.Font.size = 12 57 | 58 | Dim root As Object 59 | For Each root In roots 60 | Dim sKey As String: sKey = This.getID.Run(root) 61 | Set This.nodes(sKey) = root 62 | Dim iImage As Variant: If This.getIcon Is Nothing Then iImage = GetMissing Else iImage = This.getIcon.Run(root) 63 | tv.nodes.Add key:=sKey, text:=This.getName.Run(root), Image:=iImage 64 | tv.nodes.Add sKey, tvwChild, getGUID(), "Dummy" 65 | Next 66 | End Sub 67 | 68 | Public Property Get ContextMenu() As CommandBar 69 | Set ContextMenu = This.ContextMenu 70 | End Property 71 | 72 | 73 | 74 | Private Function GetMissing(Optional vMissing As Variant) As Variant 75 | GetMissing = vMissing 76 | End Function 77 | 78 | Private Sub btnRefresh_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean) 79 | 'Close and 80 | This.tv.SelectedItem.Expanded = False 81 | This.tv.nodes.Add This.tv.SelectedItem.key, tvwChild, getGUID(), "Dummy" 82 | 83 | RaiseEvent OnRefresh(This.nodes(This.tv.SelectedItem.key)) 84 | End Sub 85 | 86 | 87 | Private Sub Class_Terminate() 88 | 'Required to prevent crash due to circular reference between nodes and roots 89 | Set This.nodes = Nothing 90 | Set This.roots = Nothing 91 | End Sub 92 | 93 | Private Sub tv_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As stdole.OLE_XPOS_PIXELS, ByVal y As stdole.OLE_YPOS_PIXELS) 94 | Const BTN_RIGHT_CLICK = 2 95 | 96 | 'If right click 97 | If Button = BTN_RIGHT_CLICK Then 98 | Call This.ContextMenu.ShowPopup 99 | End If 100 | End Sub 101 | 102 | Private Sub tv_NodeClick(ByVal Node As MSComctlLib.Node) 103 | RaiseEvent OnSelected(This.nodes(Node.key)) 104 | End Sub 105 | 106 | 107 | 108 | Private Sub tv_Expand(ByVal Node As MSComctlLib.Node) 109 | 'Remove existing children 110 | If Node.children > 0 Then 111 | 'Get first child 112 | Dim oRef As Object: Set oRef = Node.child 113 | 114 | Dim i As Long 115 | For i = 1 To Node.children 116 | Dim oOldRef As Object: Set oOldRef = oRef 117 | Set oRef = oRef.Next 118 | Call This.tv.nodes.Remove(oOldRef.key) 119 | Next 120 | End If 121 | 122 | Dim obj As Object: Set obj = This.nodes(Node.key) 123 | Dim oChild As Object 124 | For Each oChild In This.getChildren.Run(obj) 125 | Dim sKey As String: sKey = This.getID.Run(oChild) 126 | Set This.nodes(sKey) = oChild 127 | Dim iImage As Variant: If This.getIcon Is Nothing Then iImage = GetMissing Else iImage = This.getIcon.Run(oChild) 128 | tv.nodes.Add relative:=This.getID.Run(obj), relationship:=tvwChild, key:=sKey, text:=This.getName.Run(oChild), Image:=iImage 129 | tv.nodes.Add sKey, tvwChild, getGUID(), "Dummy" 130 | Next 131 | tv.Refresh 132 | End Sub 133 | 134 | Private Function getGUID() As String 135 | Call Randomize 'Ensure random GUID generated 136 | getGUID = "xxxxxxxx-xxxx-4xxx-yxxx-xxxxxxxxxxxx" 137 | getGUID = Replace(getGUID, "y", Hex(Rnd() And &H3 Or &H8)) 138 | Dim i As Long: For i = 1 To 30 139 | getGUID = Replace(getGUID, "x", Hex$(Int(Rnd() * 16)), 1, 1) 140 | Next 141 | End Function 142 | 143 | 144 | -------------------------------------------------------------------------------- /Examples/Inspector-RunningObjectTable/README.md: -------------------------------------------------------------------------------- 1 | # Running Object Table (ROT) Viewer 2 | 3 | ## Background 4 | 5 | The **Running Object Table (ROT)** is a system-wide lookup table provided by the Component Object Model (COM) in Microsoft Windows operating systems. It keeps track of all the COM objects that are currently running and have registered themselves in the ROT. This allows different processes to discover and access shared COM objects, facilitating inter-process communication and object reuse. 6 | 7 | When a COM object is registered in the ROT, other COM-aware applications can obtain a pointer to that object using a `moniker`, an object is a name that uniquely identifies the object across the system. This is particularly useful for applications that need to interact with or control other running applications or services. This is the same name which can be used in VBA's `GetObject()` API. 8 | 9 | A **ROT Viewer** is a diagnostic tool that allows developers and system administrators to inspect the contents of the Running Object Table. By using a ROT Viewer, you can: 10 | 11 | - **List Registered COM Objects**: See all the COM objects currently registered in the ROT. 12 | - **Inspect Object Details**: View detailed information about each object, such as its moniker name and the process ID where it is running. 13 | - **Debug COM Registration Issues**: Identify problems where a COM object might not be properly registered or accessible to other processes. 14 | - **Monitor System Behavior**: Understand how applications are interacting with each other through COM objects, which is helpful for performance tuning and security auditing. 15 | 16 | Understanding how the ROT works and being able to inspect it is essential for developers working with COM technologies, especially when dealing with complex applications that require robust inter-process communication. 17 | 18 | Additionally this example serves as a demonstration of how to use `stdCOM.CreateFromActiveObjects()`, a method which returns a `Collection` of objects containing moniker details. 19 | 20 | ![_](docs/inspector-rot.png) -------------------------------------------------------------------------------- /Examples/Inspector-RunningObjectTable/ROT Viewer.xlsm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Inspector-RunningObjectTable/ROT Viewer.xlsm -------------------------------------------------------------------------------- /Examples/Inspector-RunningObjectTable/docs/inspector-rot.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Inspector-RunningObjectTable/docs/inspector-rot.png -------------------------------------------------------------------------------- /Examples/Inspector-RunningObjectTable/libs/stdICallable.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "stdICallable" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | 11 | 'Run the function with supplied parameters 12 | '@param params - The parameters to run the function with 13 | '@returns - The result of the function 14 | Public Function Run(ParamArray params() As Variant) As Variant: End Function 15 | 16 | 'Run the function with a array of parameters 17 | '@param params as Variant> - The parameters to run the function with 18 | '@returns - The result of the function 19 | Public Function RunEx(ByVal params As Variant) As Variant: End Function 20 | 21 | 'Bind a set of parameters to the function call 22 | '@param params - The parameters to bind to the function 23 | '@returns - A new function with the parameters bound 24 | Public Function Bind(ParamArray params() As Variant) As stdICallable: End Function 25 | 26 | 'Making late-bound calls to `stdICallable` members. Each object which implements `stdICallable` 27 | 'will support a different set of latebound calls. 28 | '@protected 29 | '@param sMessage - Message to send. Standard messages include "obj" returning the object, "className" returning the class name. Other messages are implementation specific. 30 | '@param success - Whether the call was successful 31 | '@param params - Any variant, typically parameters as an array. Passed along with the message. 32 | '@returns - Any return value. 33 | Public Function SendMessage(ByVal sMessage As String, ByRef success As Boolean, ByVal params As Variant) As Variant: End Function 34 | 35 | 'Ideally we would want to get a pointer to the function... However, getting a pointer to an object method is 36 | 'going to be defficult, partly due to the first parameter sent to the function is `Me`! We'll likely have to 37 | 'use machine code to wrap a call with a `Me` pointer just so we can access the full pointer and use this in 38 | 'real life applications. 39 | 'Finally it might be better to do something more like: `stdPointer.fromICallable()` anyway 40 | ''Returns a callback function 41 | ''Typically this will be achieved with `stdPointer.GetLastPrivateMethod(me)` 42 | ''If this cannot be implemented return 0 43 | 'Public Function ToPointer() as long 44 | 45 | ''Bind arguments to functions to appear as first arguments in call. 46 | ''e.g. stdLambda.Create("$1.EnableEvents = false: $1.ScreenUpdating = false").bind(Application).Run() 47 | 'Public Function Bind(ByVal v as variant) as stdICallable: End Function 48 | 49 | 50 | -------------------------------------------------------------------------------- /Examples/Inspector-RunningObjectTable/libs/uiFields.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "uiFields" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = False 10 | Implements uiIMessagable 11 | Private Type TFieldControl 12 | id As Long 13 | name As String 14 | getValue As stdICallable 15 | execute As stdICallable 16 | 17 | ctrlName As uiElement 18 | ctrlValue As uiElement 19 | ctrlExec As uiElement 20 | End Type 21 | Private Type TThis 22 | indexLookup As Object 23 | selected As Object 24 | uiFrame As MSForms.Frame 25 | fields() As TFieldControl 26 | fieldsAdded As Boolean 27 | 28 | keyWidthMultiplier As Double 29 | End Type 30 | Private This As TThis 31 | 32 | Public Function Create(ByVal fr As MSForms.Frame) As uiFields 33 | Set Create = New uiFields 34 | Call Create.protInit(fr) 35 | End Function 36 | 37 | Friend Sub protInit(ByVal fr As MSForms.Frame) 38 | Set This.uiFrame = fr 39 | Set This.indexLookup = CreateObject("Scripting.Dictionary") 40 | This.keyWidthMultiplier = 0.5 41 | End Sub 42 | 43 | Public Property Get top() As Long 44 | top = This.uiFrame.top 45 | End Property 46 | Public Property Let top(v As Long) 47 | This.uiFrame.top = v 48 | End Property 49 | Public Property Get left() As Long 50 | left = This.uiFrame.left 51 | End Property 52 | Public Property Let left(v As Long) 53 | This.uiFrame.left = v 54 | End Property 55 | Public Property Get width() As Long 56 | width = This.uiFrame.width 57 | End Property 58 | Public Property Let width(v As Long) 59 | This.uiFrame.width = v 60 | Dim iWidth As Long: iWidth = This.uiFrame.InsideWidth - 4 61 | Dim i As Long: For i = 0 To UBound(This.fields) 62 | With This.fields(i) 63 | .ctrlName.width = iWidth * This.keyWidthMultiplier 64 | .ctrlValue.left = 2 + iWidth * This.keyWidthMultiplier 65 | .ctrlValue.width = iWidth * (1 - This.keyWidthMultiplier) 66 | If Not .execute Is Nothing Then 67 | .ctrlValue.width = .ctrlValue.width - 10 68 | .ctrlExec.left = 2 + iWidth - 10 69 | End If 70 | End With 71 | Next 72 | End Property 73 | Public Property Get height() As Long 74 | height = This.uiFrame.height 75 | End Property 76 | Public Property Let height(v As Long) 77 | This.uiFrame.height = v 78 | End Property 79 | 80 | Public Property Let keyWidthMultiplier(v As Double) 81 | This.keyWidthMultiplier = v 82 | If This.fieldsAdded Then width = width 83 | End Property 84 | 85 | Public Function AddField(ByVal sName As String, ByVal getValue As stdICallable, Optional ByVal execute As stdICallable = Nothing, Optional ByVal execIcon As StdPicture) As Long 86 | This.fieldsAdded = True 87 | Dim iWidth As Long: iWidth = This.uiFrame.InsideWidth - 4 88 | On Error Resume Next 89 | Dim i As Long: i = UBound(This.fields) + 1 90 | On Error GoTo 0 91 | ReDim Preserve This.fields(0 To i) 92 | With This.fields(i) 93 | .id = i 94 | Set .ctrlName = uiElement.CreateFromType(Me, This.uiFrame.Controls, uiLabel, "Name_" & i, sName, 2, 2 + i * (20 + 2), iWidth * This.keyWidthMultiplier, 20) 95 | Set .ctrlValue = uiElement.CreateFromType(Me, This.uiFrame.Controls, uiTextBox, "Value_" & i, "", 2 + iWidth * This.keyWidthMultiplier, 2 + i * (20 + 2), iWidth * (1 - This.keyWidthMultiplier), 20) 96 | Set .getValue = getValue 97 | If Not execute Is Nothing Then 98 | .ctrlValue.width = .ctrlValue.width - 10 99 | Set .ctrlExec = uiElement.CreateFromType(Me, This.uiFrame.Controls, uiImage, "Button_" & i, "", 2 + iWidth - 10, 2 + i * (20 + 2), 10, 20) 100 | Set .execute = execute 101 | This.indexLookup(.ctrlExec.id) = i 102 | End If 103 | This.indexLookup(.ctrlName.id) = i 104 | This.indexLookup(.ctrlValue.id) = i 105 | End With 106 | End Function 107 | 108 | 109 | Public Sub UpdateSelection(ByVal obj As Object) 110 | Set This.selected = obj 111 | 112 | Dim i As Long 113 | For i = 0 To UBound(This.fields) 114 | This.fields(i).ctrlValue.value = This.fields(i).getValue.Run(obj) 115 | Next 116 | End Sub 117 | 118 | 119 | 120 | 121 | 122 | 123 | 124 | 125 | 126 | 127 | 128 | 129 | 130 | 131 | 132 | 133 | 134 | Private Sub Class_Terminate() 135 | Set This.selected = Nothing 136 | End Sub 137 | 138 | Private Function uiIMessagable_Message(ByVal Caller As Object, iMessage As Long, Optional params As Variant = Empty) As Variant 139 | Dim el As uiElement: Set el = Caller 140 | If iMessage = EUIElementMessage.uiElementEventMouseClick Then 141 | Dim index As Long: index = This.indexLookup(el.id) 142 | With This.fields(index) 143 | If Not .execute Is Nothing Then Call .execute.Run(This.selected) 144 | End With 145 | End If 146 | End Function 147 | -------------------------------------------------------------------------------- /Examples/Inspector-RunningObjectTable/libs/uiIMessagable.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "uiIMessagable" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | 11 | Function Message(ByVal Caller As Object, iMessage As Long, Optional params As Variant = Empty) As Variant 12 | 13 | End Function 14 | -------------------------------------------------------------------------------- /Examples/Inspector-RunningObjectTable/src/ROTView.frm: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} ROTView 3 | Caption = "ROT Viewer" 4 | ClientHeight = 5430 5 | ClientLeft = 120 6 | ClientTop = 465 7 | ClientWidth = 9915.001 8 | OleObjectBlob = "ROTView.frx":0000 9 | StartUpPosition = 1 'CenterOwner 10 | End 11 | Attribute VB_Name = "ROTView" 12 | Attribute VB_GlobalNameSpace = False 13 | Attribute VB_Creatable = False 14 | Attribute VB_PredeclaredId = True 15 | Attribute VB_Exposed = False 16 | Private Type TThis 17 | monikers As Collection 18 | selectedMoniker As Object 19 | 20 | propView As uiFields 21 | End Type 22 | Private This As TThis 23 | 24 | Private Sub btnRefresh_Click() 25 | Call RefreshMonikers 26 | End Sub 27 | 28 | Private Sub lbMonikers_Change() 29 | If lbMonikers.ListIndex >= 0 Then 30 | Set This.selectedMoniker = This.monikers(lbMonikers.ListIndex + 1) 31 | Call This.propView.UpdateSelection(This.selectedMoniker) 32 | End If 33 | End Sub 34 | 35 | Private Sub UserForm_Initialize() 36 | Set This.propView = uiFields.Create(frProps) 37 | With This.propView 38 | .keyWidthMultiplier = 0.25 39 | Call .AddField("Name", stdLambda.Create("$1.Name")) 40 | Call .AddField("Object Type", stdLambda.Create("$1.Type")) 41 | Call .AddField("ProgID", stdLambda.Create("$1.ProgID")) 42 | End With 43 | 44 | Call RefreshMonikers 45 | End Sub 46 | 47 | Private Sub RefreshMonikers() 48 | Set This.monikers = stdCOM.CreateFromActiveObjects() 49 | 50 | With lbMonikers 51 | .SetFocus 52 | .Clear 53 | 54 | Dim moniker 55 | For Each moniker In This.monikers 56 | Call .AddItem(moniker("Name")) 57 | Next 58 | 59 | .ListIndex = 0 60 | End With 61 | End Sub 62 | 63 | 64 | -------------------------------------------------------------------------------- /Examples/Inspector-RunningObjectTable/src/ROTView.frx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Inspector-RunningObjectTable/src/ROTView.frx -------------------------------------------------------------------------------- /Examples/MacroDispatcher/MacroDispatcher.xlsm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/MacroDispatcher/MacroDispatcher.xlsm -------------------------------------------------------------------------------- /Examples/MacroDispatcher/README.md: -------------------------------------------------------------------------------- 1 | # Macro Dispatcher 2 | 3 | Define exactly which macros should be run in which particular order across multiple spreadsheets. Monitors success and errors. 4 | 5 | Say we have 4 macro workbooks, each containing macros which refresh some dataset within them: 6 | 7 | * `FIN`: `Finances.xlsm` - A raw financial export from our source systems. To refresh run the "Refresh" macro. 8 | * `Proj`: `Projects.xlsm` - A list of company improvment projects, uses financial information from `financial.xlsm`. To refresh run the "Refresh" macro. 9 | * `OPR`: `Operational.xlsm` - Produces a list of business operational risks, uses information from `Projects.xlsm`. To refresh run the "RefreshReport" macro. The macro runs and saves the operational report to another drive. 10 | * `AHR`: `AssetHealth.xlsm` - File on sharepoint containing a list of Asset Health Risks, uses information from `Projects.xlsm` and an output from `Operational.xlsm`. To refresh run the "RefreshDatasets" macro. 11 | 12 | ``` 13 | FIN 14 | / 15 | Proj 16 | / | 17 | OPR | 18 | \ | 19 | AHR 20 | ``` 21 | 22 | From this we can see that `FIN` should be run first, Then `Proj`, Then `OPR`, Then `AHR`. Typically this is where users would follow a process of opening workbooks and refreshing workbooks one by one, but what if we wanted to automate this process? Enter stage... Macro Dispatcher! 23 | 24 | First we have to list our workbooks, macro names and dependencies. 25 | 26 | | ID | Workbook | Macro | Dependencies | ReadOnly | CheckOut/In | Status | StatusDate | Frequency Lambda | Comment | 27 | |------|------------------------------|-----------------|--------------|----------|-------------|--------|------------|------------------|---------| 28 | | FIN | C:\...\Finances.xlsm | Refresh | | false | false | Ready | 01/01/2023 | true | | 29 | | Proj | C:\...\Projects.xlsm | Refresh | FIN | false | false | Ready | 01/01/2023 | true | | 30 | | OPR | C:\...\Operational.xlsm | RefreshReport | Proj | true | false | Ready | 01/01/2023 | true | | 31 | | AHR | https://.../AssetHealth.xlsm | RefreshDatasets | Proj,OPR | false | true | Ready | 01/01/2023 | true | | 32 | 33 | The header names mean the following: 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | 74 | 75 | 76 | 77 | 78 | 79 | 80 | 81 | 82 | 83 | 84 | 85 | 86 | 87 | 88 | 89 | 90 | 91 |
NameTypeDescription
IDStringA unique identifier for the file.
WorkbookStringA path to the workbook containing macro.
MacroStringThe name of the macro to run within the workbook.
DependenciesStringComma delimited list of dependencies to ensure are complete before running this macro.
ReadOnlyBooleanWhether the macro being run can run in read-only mode. If TRUE the workbook will be opened in read-only mode.
CheckOut/In BooleanIf the workbook is on sharepoint, and would be modified during runtime of the macro, then check-in and check-out might be required. State TRUE if it is and where WRITE permission is required. FALSE otherwise.
StatusStringThe status of the extraction.
StatusDateDateTimeDate the the status was written.
FrequencyLambdaString"true" if this should be run every time the workbook is run. However you might want to only run once a month, or similar. If you want to ensure this is run only after 1 month has expired (every 30 days) use the following "now() - $1 > 30"
CommentStringAny arbitrary comments.
92 | 93 | Now when we click Execute, each macro will be run when it is able to, fully automatically. Multiple workbooks will be ran in parallel too, allowing faster runtimes. -------------------------------------------------------------------------------- /Examples/MacroDispatcher/Src/extensions/mdExtension.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "mdExtension" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = False 10 | 11 | 'TODO: Call various handles in process 12 | 'TODO: Consider how to best filter which extensions to use. 13 | 'TODO: Consider how to best handle the application object 14 | 15 | 16 | Public Function Create() as mdExtension 17 | set Create = new mdExtension 18 | Call Create.protInit 19 | End Function 20 | Public Sub protInit() 21 | 22 | End Sub 23 | 24 | Public Function Handles() as Object 25 | set Handles = CreateObject("Scripting.Dictionary") 26 | Handles("Before_ApplicationCreate") = false 27 | Handles("After_ApplicationCreate") = false 28 | Handles("After_WorkbookOpen") = false 29 | Handles("On_Initialising") = false 30 | Handles("On_Ready") = false 31 | Handles("On_Executed") = false 32 | Handles("On_Running") = false 33 | Handles("On_Error") = false 34 | Handles("On_Completion") = false 35 | End Function 36 | 37 | 'Make any changes necessary before the application object is created 38 | '@param app - Passed by-ref to allow you to override the application object to be used 39 | '@remark - Usually this method is used to set the application object to be used. 40 | Public Sub Before_ApplicationCreate(ByRef app as Application) 41 | 42 | End Sub 43 | 44 | 'Make any changes necessary after the application object has been created 45 | '@param app - Application to make changes to if necessary 46 | Public Sub After_ApplicationCreate(ByRef app as Application) 47 | 48 | End Sub 49 | 50 | 'Called after a workbook has been opened 51 | '@param wb - The workbook that has been opened, passed by-ref to allow you to make changes to the workbook if necessary 52 | Public Sub After_WorkbookOpen(ByRef wb as Workbook) 53 | 54 | End Sub 55 | 56 | 'Called when the mdJob is initialising 57 | Public Sub On_Initialising() 58 | 59 | End Sub 60 | 61 | 'Called when the mdJob is ready to be executed 62 | Public Sub On_Ready() 63 | 64 | End Sub 65 | 66 | 'Called when the mdJob is executed 67 | Public Sub On_Executed() 68 | 69 | End Sub 70 | 71 | 'Called when the mdJob is running 72 | Public Sub On_Running() 73 | 74 | End Sub 75 | 76 | 'Called when an error occurs 77 | Public Sub On_Error(ByVal status as string) 78 | 79 | End Sub 80 | 81 | 'Called when the mdJob has completed 82 | '@param app - The application object that was used. If any clean up is required, this is the place to do it. 83 | Public Sub On_Completion(ByVal app as Application) 84 | 85 | End Sub -------------------------------------------------------------------------------- /Examples/MacroDispatcher/Src/extensions/mdMain.bas: -------------------------------------------------------------------------------- 1 | Public Function getExtension() as Object 2 | set getExtension = mdExtension.Create() 3 | End Function -------------------------------------------------------------------------------- /Examples/MacroDispatcher/Src/mdMain.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "mdMain" 2 | Public mdApps As Collection 3 | 4 | Public Sub Test() 5 | Call SaveSetting("RPATest", "RPATest", "A", 0) 6 | Call SaveSetting("RPATest", "RPATest", "B", 0) 7 | Call SaveSetting("RPATest", "RPATest", "C", 0) 8 | Call SaveSetting("RPATest", "RPATest", "D", 0) 9 | Call SaveSetting("RPATest", "RPATest", "E", 0) 10 | Call SaveSetting("RPATest", "RPATest", "F", 0) 11 | Call SaveSetting("RPATest", "RPATest", "G", 0) 12 | Call SaveSetting("RPATest", "RPATest", "H", 0) 13 | Call ExecuteAll 14 | Debug.Print GetSetting("RPATest", "RPATest", "A") 15 | Debug.Print GetSetting("RPATest", "RPATest", "B") 16 | Debug.Print GetSetting("RPATest", "RPATest", "C") 17 | Debug.Print GetSetting("RPATest", "RPATest", "D") 18 | Debug.Print GetSetting("RPATest", "RPATest", "E") 19 | Debug.Print GetSetting("RPATest", "RPATest", "F") 20 | Debug.Print GetSetting("RPATest", "RPATest", "G") 21 | Debug.Print GetSetting("RPATest", "RPATest", "H") 22 | End Sub 23 | 24 | Public Sub ExecuteAll() 25 | Dim eJobs As stdEnumerator: Set eJobs = stdEnumerator.CreateFromListObject(shJobs.ListObjects("Jobs")) 26 | Dim job As Object 27 | For Each job In eJobs.AsCollection 28 | If job("StatusDate") = Empty Then 29 | Call setRowCell(job, "Status", "Waiting") 30 | ElseIf stdLambda.Create(job("Frequency Lambda")).Run(job("StatusDate")) Then 31 | Call setRowCell(job, "Status", "Waiting") 32 | End If 33 | Next 34 | 35 | Dim oExtensions as object: set oExtensions = CreateObject("Scripting.Dictionary") 36 | Dim extension 37 | For each extension in stdEnumerator.CreateFromListObject(shExtensions.ListObjects("Extensions")).AsCollection 38 | Set oExtensions(extension("Name")) = Application.Run("'" & extension("Path") & "'!getExtension") 39 | next 40 | 41 | Call Continue(eJobs, oExtensions) 42 | End Sub 43 | 44 | Public Sub Continue(Optional eJobs As stdEnumerator, Optional extensions as Object) 45 | If eJobs Is Nothing Then Set eJobs = stdEnumerator.CreateFromListObject(shJobs.ListObjects("Jobs")) 46 | 47 | 'Convert to mdJob objects 48 | Dim cJobs As Collection: Set cJobs = New Collection 49 | Dim dJobs As Object: Set dJobs = CreateObject("Scripting.Dictionary") 50 | Dim job As Object 'Dictionary<> 51 | For Each job In eJobs.AsCollection 52 | Dim oJob As mdJob: Set oJob = mdJob.Create(job("Workbook"), job("Macro"), job("ReadOnly"), extensions) 53 | cJobs.add oJob 54 | Set dJobs(CStr(job("ID"))) = oJob 55 | Set oJob.Metadata = job 56 | Set job("=JOB") = oJob 57 | Next 58 | 59 | 'Add dependencies 60 | For Each job In eJobs.AsCollection 61 | Dim vDepID 62 | For Each vDepID In Split(job("Dependencies"), ",") 63 | Call job("=JOB").protAddDependency(dJobs(vDepID)) 64 | Next 65 | Next 66 | 67 | 'Port eJobs from cJobs (collection of mdJob objects) 68 | Set eJobs = stdEnumerator.CreateFromIEnumVariant(cJobs) 69 | 70 | 'While jobs exist 71 | While eJobs.length > 0 72 | DoEvents 73 | 74 | 'Find incomplete jobs 75 | Set eJobs = eJobs.Filter(stdLambda.Create("$1.Status <> ""Complete"" and not $1.Status like ""Error*""")) 76 | 77 | 'Advance all jobs 78 | Dim task As mdJob 79 | For Each task In eJobs.AsCollection 80 | 'Advance progress of task 81 | task.protStep 82 | 83 | 'Checking status progresses tasks 84 | Dim sStatus As String: sStatus = task.Status 85 | Select Case True 86 | 'If complete, set status and date 87 | Case sStatus = "Complete" 88 | Call setRowCell(task.Metadata, "Status", task.Status) 89 | Call setRowCell(task.Metadata, "StatusDate", Now()) 90 | 91 | 'If error, set status but not date 92 | Case sStatus Like "Error*" 93 | Call setRowCell(task.Metadata, "Status", task.Status) 94 | Case Else 95 | Call setRowCell(task.Metadata, "Status", task.Status) 96 | End Select 97 | Next 98 | Wend 99 | End Sub 100 | 101 | 102 | 103 | 'Given a row object supplied by `stdEnumerator.CreateFromListObject()`, update a cell's value based on it's column name 104 | '@param {Object} Row object 105 | '@param {String} Column name 106 | '@param {Variant} Value to set cell to 107 | Private Sub setRowCell(ByVal oRow As Object, ByVal sColumnName As String, ByVal vValue As Variant) 108 | Application.Intersect(oRow("=ListRow").Range, oRow("=ListColumns")(sColumnName).Range).value = vValue 109 | oRow("=ListRow").Range.WrapText = False 110 | End Sub 111 | 112 | 113 | Sub NewApp() 114 | Dim app As Application 115 | Set app = New Application 116 | app.Visible = False 117 | app.Workbooks.open "D:\Programming\Github\stdVBA-examples\Examples\MacroDispatcher\Tests\Test.xlsm" 118 | Call app.OnTime(Now(), "Part7") 119 | Debug.Assert False 120 | app.Quit 121 | End Sub 122 | Sub newRuntimeError() 123 | x = 1 / 0 124 | End Sub 125 | -------------------------------------------------------------------------------- /Examples/MacroDispatcher/Tests/Test.xlsm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/MacroDispatcher/Tests/Test.xlsm -------------------------------------------------------------------------------- /Examples/NoteBuilder/NoteBuilder.xlsm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/NoteBuilder/NoteBuilder.xlsm -------------------------------------------------------------------------------- /Examples/NoteBuilder/README.md: -------------------------------------------------------------------------------- 1 | # NoteBuilder 2 | 3 | A simple note-builder driven by stdVBA. 4 | 5 | # Spec 6 | 7 | We define some questions to be asked to the user 8 | 9 | | TemplateName | Type | Userform-Description | dropdown-choices | checkbox-yes-text | checkbox-no-text | 10 | | -------------- | -------- | ----------------------- | -------------------------------------- | --------------------------------------- | ---------------- | 11 | | issue | Dropdown | Issue Type | flooding;smell;pollution | N/A | N/A | 12 | | cause | Dropdown | Cause Type | blockage;collapse;hydraulic incapacity | N/A | N/A | 13 | | custVulnerable | Checkbox | Is customer vulnerable? | N/A | Customer is vulnerable. | | 14 | | job-raised | Dropdown | Job raised | jetting;pipe repair | N/A | N/A | 15 | | capex-required | Checkbox | Is CAPEX required? | N/A | CAPEX Required. Raised on risk system. | | 16 | 17 | We present a userform to the user to select answers to the questions, and generate some note out the backend from a template already provided in a textbox. 18 | 19 | Inspiration: https://www.reddit.com/r/vba/comments/1ixxv6u/is_there_something_we_can_just_pay_someone/ -------------------------------------------------------------------------------- /Examples/NoteBuilder/src/Questionnaire.frm: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} Questionnaire 3 | Caption = "Questionnaire" 4 | ClientHeight = 5415 5 | ClientLeft = 120 6 | ClientTop = 465 7 | ClientWidth = 4695 8 | OleObjectBlob = "Questionnaire.frx":0000 9 | StartUpPosition = 1 'CenterOwner 10 | End 11 | Attribute VB_Name = "Questionnaire" 12 | Attribute VB_GlobalNameSpace = False 13 | Attribute VB_Creatable = False 14 | Attribute VB_PredeclaredId = True 15 | Attribute VB_Exposed = False 16 | Private rows As stdEnumerator 17 | 18 | Private Sub SubmitButton_Click() 19 | Dim template As String: template = shTemplate.Shapes("NoteTemplate").TextFrame2.TextRange.text 20 | Dim replacer As stdCallback: Set replacer = stdCallback.CreateFromObjectMethod(Me, "protReduceRow") 21 | stdClipboard.text = rows.reduce(replacer, template) 22 | Unload Me 23 | End Sub 24 | 25 | Private Sub UserForm_Initialize() 26 | Dim lo As ListObject: Set lo = shTemplate.ListObjects("UserformElements") 27 | Set rows = stdEnumerator.CreateFromListObject(lo) 28 | 29 | Dim rowCreator As stdCallback: Set rowCreator = stdCallback.CreateFromObjectMethod(Me, "protCreateRow") 30 | Call rows.ForEach(rowCreator) 31 | End Sub 32 | 33 | Public Sub protCreateRow(ByVal row As Object, ByVal index As Long) 34 | Set row("ui") = CreateObject("Scripting.Dictionary") 35 | With row("ui") 36 | Set .Item("label") = stdUIElement.CreateFromType(Frame1.Controls, uiLabel, Caption:=row("Userform-Description"), fTop:=(index - 1) * 15, fWidth:=100) 37 | Dim element As stdUIElement 38 | Select Case row("Type") 39 | Case "Dropdown" 40 | Set element = stdUIElement.CreateFromType(Frame1.Controls, uiCombobox, fLeft:=100, fTop:=(index - 1) * 15, fWidth:=100) 41 | Dim cb As ComboBox: Set cb = element.uiObject 42 | cb.List = Split(row("dropdown-choices"), ";") 43 | Case "Checkbox" 44 | Set element = stdUIElement.CreateFromType(Frame1.Controls, uiCheckBox, fLeft:=100, fTop:=(index - 1) * 15) 45 | Case "Freetext" 46 | Set element = stdUIElement.CreateFromType(Frame1.Controls, uiTextBox, fLeft:=100, fTop:=(index - 1) * 15, fWidth:=100) 47 | End Select 48 | Set .Item("input") = element 49 | End With 50 | 51 | End Sub 52 | 53 | Public Function protReduceRow(ByVal text As String, ByVal row As Object, ByVal index As Long) As String 54 | Dim finder As String: finder = "{" & row("TemplateName") & "}" 55 | Dim replacer As String 56 | Select Case row("Type") 57 | Case "Dropdown", "Freetext" 58 | replacer = row("ui")("input").Value 59 | Case "Checkbox" 60 | If row("ui")("input").Value Then 61 | replacer = row("checkbox-yes-text") 62 | Else 63 | replacer = row("checkbox-no-text") 64 | End If 65 | End Select 66 | protReduceRow = replace(text, finder, replacer) 67 | End Function 68 | 69 | 70 | 71 | Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) 72 | Unload Me 73 | End Sub 74 | -------------------------------------------------------------------------------- /Examples/NoteBuilder/src/Questionnaire.frx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/NoteBuilder/src/Questionnaire.frx -------------------------------------------------------------------------------- /Examples/Notepad-GetAllTextAndClose/ExtractAllNotepadText.xlsm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Notepad-GetAllTextAndClose/ExtractAllNotepadText.xlsm -------------------------------------------------------------------------------- /Examples/Notepad-GetAllTextAndClose/lib/stdICallable.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "stdICallable" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | 11 | 'Run the function with supplied parameters 12 | '@param params - The parameters to run the function with 13 | '@returns - The result of the function 14 | Public Function Run(ParamArray params() As Variant) As Variant: End Function 15 | 16 | 'Run the function with a array of parameters 17 | '@param params as Variant> - The parameters to run the function with 18 | '@returns - The result of the function 19 | Public Function RunEx(ByVal params As Variant) As Variant: End Function 20 | 21 | 'Bind a set of parameters to the function call 22 | '@param params - The parameters to bind to the function 23 | '@returns - A new function with the parameters bound 24 | Public Function Bind(ParamArray params() As Variant) As stdICallable: End Function 25 | 26 | 'Making late-bound calls to `stdICallable` members. Each object which implements `stdICallable` 27 | 'will support a different set of latebound calls. 28 | '@protected 29 | '@param sMessage - Message to send. Standard messages include "obj" returning the object, "className" returning the class name. Other messages are implementation specific. 30 | '@param success - Whether the call was successful 31 | '@param params - Any variant, typically parameters as an array. Passed along with the message. 32 | '@returns - Any return value. 33 | Public Function SendMessage(ByVal sMessage As String, ByRef success As Boolean, ByVal params As Variant) As Variant: End Function 34 | 35 | 'Ideally we would want to get a pointer to the function... However, getting a pointer to an object method is 36 | 'going to be defficult, partly due to the first parameter sent to the function is `Me`! We'll likely have to 37 | 'use machine code to wrap a call with a `Me` pointer just so we can access the full pointer and use this in 38 | 'real life applications. 39 | 'Finally it might be better to do something more like: `stdPointer.fromICallable()` anyway 40 | ''Returns a callback function 41 | ''Typically this will be achieved with `stdPointer.GetLastPrivateMethod(me)` 42 | ''If this cannot be implemented return 0 43 | 'Public Function ToPointer() as long 44 | 45 | ''Bind arguments to functions to appear as first arguments in call. 46 | ''e.g. stdLambda.Create("$1.EnableEvents = false: $1.ScreenUpdating = false").bind(Application).Run() 47 | 'Public Function Bind(ByVal v as variant) as stdICallable: End Function 48 | 49 | 50 | -------------------------------------------------------------------------------- /Examples/Notepad-GetAllTextAndClose/src/main.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "main" 2 | Sub executeMain() 3 | Call execute(True) 4 | End Sub 5 | Sub executeNoQuit() 6 | Call execute(False) 7 | End Sub 8 | 9 | Sub execute(ByVal quitAfter As Boolean) 10 | With Sheet1 11 | .UsedRange.Clear 12 | .[a1] = "WindowTitle" 13 | .[b1] = "Value" 14 | Dim r As Range: Set r = .Range("A1") 15 | 16 | Dim iOffset As Long: iOffset = 0 17 | Dim procs As Collection: Set procs = stdProcess.CreateManyFromQuery(stdLambda.Create("$1.Name like ""*Notepad.exe*""")) 18 | Dim proc As stdProcess 19 | For Each proc In procs 20 | Dim wnd As stdWindow 21 | For Each wnd In stdWindow.CreateManyFromProcessId(proc.id) 22 | Dim main As stdAcc: Set main = stdAcc.CreateFromHwnd(wnd.handle) 23 | Dim title As String: title = main.name 24 | 25 | 'Activate all tabs to populate window accessible controls with text 26 | Dim accTab As stdAcc 27 | For Each accTab In main.FindAll(stdLambda.Create("$1.Role = ""ROLE_PAGETAB""")) 28 | Call accTab.DoDefaultAction 29 | Next 30 | 31 | Dim editWnd As stdWindow 32 | For Each editWnd In wnd.FindAll(stdLambda.Create("$1.Class = ""RichEditD2DPT""")) 33 | iOffset = iOffset + 1 34 | 35 | Dim editAcc As stdAcc: Set editAcc = stdAcc.CreateFromHwnd(editWnd.handle).children(4) 36 | Dim text As String: text = editAcc.value 37 | 38 | r.offset(iOffset, 0) = title 39 | r.offset(iOffset, 1).Value2 = "'" & text 40 | Next 41 | Next 42 | 43 | If quitAfter Then Call proc.ForceQuit(400) 44 | Next 45 | End With 46 | End Sub 47 | -------------------------------------------------------------------------------- /Examples/SAP-ECC-Automation/README.md: -------------------------------------------------------------------------------- 1 | # SAP ECC Automation 2 | 3 | Sometimes it is necessary to automate SAP in environments where SAP GUI Scripting is locked down/disabled. This library can be used to automate SAP GUI in these conditions. 4 | 5 | ## Typical usage 6 | 7 | I've used these libraries mostly to perform extraction tasks: 8 | 9 | * Extract SAP Notification long text (Service and PM) 10 | * Extract SAP Order long text 11 | * Extract tables from IH06 12 | * Extract information from address form from functional locations in IH06 13 | 14 | I would generally advise against using this library for any tasks which update financial information. Do so at your own risk. 15 | 16 | ## Note: 17 | 18 | In order to use the library you can either Create a VBA instance of SAP ECC from existing SAP window, or a new process. To create a new process the current library expects you to launch SAP ECC from a Web URL. You may want to use a different mechanism. Ideally this library would accommodate for that but without experience what that looks like I do not have the ability to build such a routine. E.G. I know some people need to use user/password. 19 | 20 | ## Library dependencies 21 | 22 | ### Base: 23 | 24 | * stdICallable 25 | * stdAcc 26 | * stdWindow 27 | * stdClipboard 28 | * stdLambda 29 | 30 | ### With Async: 31 | 32 | Additional modules are required for asynchronous processing. Asynchronous processing allows you to automate multiple SAP windows at once. Care must be had while doing these kind of operations though as SAP is glitchy and often actions aren't registered. 33 | 34 | * stdFiber 35 | * stdProcess 36 | * stdCallback 37 | 38 | 39 | 40 | -------------------------------------------------------------------------------- /Examples/SAP-ECC-Automation/lib/stdICallable.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "stdICallable" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = false 9 | Attribute VB_Exposed = False 10 | 11 | 'Run the function with supplied parameters 12 | '@param params - The parameters to run the function with 13 | '@returns - The result of the function 14 | Public Function Run(ParamArray params() as variant) as variant: End Function 15 | 16 | 'Run the function with a array of parameters 17 | '@param params as Variant> - The parameters to run the function with 18 | '@returns - The result of the function 19 | Public Function RunEx(ByVal params as variant) as variant: End Function 20 | 21 | 'Bind a set of parameters to the function call 22 | '@param params - The parameters to bind to the function 23 | '@returns - A new function with the parameters bound 24 | Public Function Bind(ParamArray params() as variant) as stdICallable: End Function 25 | 26 | 'Making late-bound calls to `stdICallable` members. Each object which implements `stdICallable` 27 | 'will support a different set of latebound calls. 28 | '@protected 29 | '@param sMessage - Message to send. Standard messages include "obj" returning the object, "className" returning the class name. Other messages are implementation specific. 30 | '@param success - Whether the call was successful 31 | '@param params - Any variant, typically parameters as an array. Passed along with the message. 32 | '@returns - Any return value. 33 | Public Function SendMessage(ByVal sMessage as string, ByRef success as boolean, ByVal params as variant) as Variant: End Function 34 | 35 | 'Ideally we would want to get a pointer to the function... However, getting a pointer to an object method is 36 | 'going to be defficult, partly due to the first parameter sent to the function is `Me`! We'll likely have to 37 | 'use machine code to wrap a call with a `Me` pointer just so we can access the full pointer and use this in 38 | 'real life applications. 39 | 'Finally it might be better to do something more like: `stdPointer.fromICallable()` anyway 40 | ''Returns a callback function 41 | ''Typically this will be achieved with `stdPointer.GetLastPrivateMethod(me)` 42 | ''If this cannot be implemented return 0 43 | 'Public Function ToPointer() as long 44 | 45 | ''Bind arguments to functions to appear as first arguments in call. 46 | ''e.g. stdLambda.Create("$1.EnableEvents = false: $1.ScreenUpdating = false").bind(Application).Run() 47 | 'Public Function Bind(ByVal v as variant) as stdICallable: End Function 48 | 49 | 50 | -------------------------------------------------------------------------------- /Examples/SharepointPAService/res/PowerAutomate_Service.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/SharepointPAService/res/PowerAutomate_Service.png -------------------------------------------------------------------------------- /Examples/SharepointPAService/src/PowerAutomate.zip/Microsoft.Flow/flows/5ab6c1ee-9b2d-4d64-b8f2-67d9a09eba6e/apisMap.json: -------------------------------------------------------------------------------- 1 | {"shared_sharepointonline":"94038e56-d034-47f6-9700-150939a7c1e1"} -------------------------------------------------------------------------------- /Examples/SharepointPAService/src/PowerAutomate.zip/Microsoft.Flow/flows/5ab6c1ee-9b2d-4d64-b8f2-67d9a09eba6e/connectionsMap.json: -------------------------------------------------------------------------------- 1 | {"shared_sharepointonline":"0167ec3c-d2a9-48b9-9bc5-c4cf521e8cde"} -------------------------------------------------------------------------------- /Examples/SharepointPAService/src/PowerAutomate.zip/Microsoft.Flow/flows/5ab6c1ee-9b2d-4d64-b8f2-67d9a09eba6e/definition.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "f0f4bd78-cf2e-4cb8-a920-c8c2f8e14ffb", 3 | "id": "/providers/Microsoft.Flow/flows/f0f4bd78-cf2e-4cb8-a920-c8c2f8e14ffb", 4 | "type": "Microsoft.Flow/flows", 5 | "properties": { 6 | "apiId": "/providers/Microsoft.PowerApps/apis/shared_logicflows", 7 | "displayName": "SharepointService", 8 | "definition": { 9 | "metadata": { 10 | "workflowEntityId": null, 11 | "processAdvisorMetadata": null, 12 | "flowChargedByPaygo": null, 13 | "flowclientsuspensionreason": "None", 14 | "flowclientsuspensiontime": null, 15 | "flowclientsuspensionreasondetails": null, 16 | "creator": { 17 | "id": "1901316b-9f95-4073-972c-a557b420a84c", 18 | "type": "User", 19 | "tenantId": "e15c1e99-7be3-495c-978e-eca7b8ea9f31" 20 | }, 21 | "provisioningMethod": "FromDefinition", 22 | "failureAlertSubscription": true, 23 | "clientLastModifiedTime": "2025-04-14T15:05:52.9191335Z", 24 | "connectionKeySavedTimeKey": "2025-04-14T15:05:52.9191335Z", 25 | "creationSource": "Portal", 26 | "modifiedSources": "Portal" 27 | }, 28 | "$schema": "https://schema.management.azure.com/providers/Microsoft.Logic/schemas/2016-06-01/workflowdefinition.json#", 29 | "contentVersion": "1.0.0.0", 30 | "parameters": { 31 | "$authentication": { "defaultValue": {}, "type": "SecureObject" }, 32 | "$connections": { "defaultValue": {}, "type": "Object" } 33 | }, 34 | "triggers": { 35 | "manual": { 36 | "metadata": {}, 37 | "type": "Request", 38 | "kind": "Http", 39 | "inputs": { "method": "POST", "triggerAuthenticationType": "All" } 40 | } 41 | }, 42 | "actions": { 43 | "Parse_JSON": { 44 | "runAfter": {}, 45 | "type": "ParseJson", 46 | "inputs": { 47 | "content": "@triggerBody()", 48 | "schema": { 49 | "type": "object", 50 | "properties": { 51 | "site": { "type": "string" }, 52 | "api": { "type": "string" }, 53 | "method": { "type": "string" }, 54 | "headers": { "type": "object" }, 55 | "body": { "type": "string" } 56 | } 57 | } 58 | } 59 | }, 60 | "Send_an_HTTP_request_to_SharePoint": { 61 | "runAfter": { "Parse_JSON": ["Succeeded"] }, 62 | "type": "OpenApiConnection", 63 | "inputs": { 64 | "parameters": { 65 | "dataset": "@body('Parse_JSON')?['site']", 66 | "parameters/method": "@body('Parse_JSON')?['method']", 67 | "parameters/uri": "@body('Parse_JSON')?['api']", 68 | "parameters/headers": "@body('Parse_JSON')?['headers']", 69 | "parameters/body": "@body('Parse_JSON')?['body']" 70 | }, 71 | "host": { 72 | "apiId": "/providers/Microsoft.PowerApps/apis/shared_sharepointonline", 73 | "connectionName": "shared_sharepointonline", 74 | "operationId": "HttpRequest" 75 | }, 76 | "authentication": "@parameters('$authentication')" 77 | } 78 | }, 79 | "Success_Response": { 80 | "runAfter": { "Send_an_HTTP_request_to_SharePoint": ["Succeeded"] }, 81 | "type": "Response", 82 | "kind": "Http", 83 | "inputs": { 84 | "statusCode": 200, 85 | "body": "@{body('Send_an_HTTP_request_to_SharePoint')}\n" 86 | } 87 | }, 88 | "Fail_Response": { 89 | "runAfter": { 90 | "Send_an_HTTP_request_to_SharePoint": ["Failed", "TimedOut"] 91 | }, 92 | "type": "Response", 93 | "kind": "Http", 94 | "inputs": { 95 | "statusCode": 400, 96 | "body": "@body('Send_an_HTTP_request_to_SharePoint')" 97 | } 98 | } 99 | }, 100 | "outputs": {} 101 | }, 102 | "connectionReferences": { 103 | "shared_sharepointonline": { 104 | "connectionName": "shared-sharepointonl-b1c92c37-ec3f-4e64-807f-2f15fe684613", 105 | "source": "Embedded", 106 | "id": "/providers/Microsoft.PowerApps/apis/shared_sharepointonline", 107 | "tier": "NotSpecified", 108 | "apiName": "sharepointonline" 109 | } 110 | }, 111 | "flowFailureAlertSubscribed": false, 112 | "isManaged": false 113 | } 114 | } 115 | -------------------------------------------------------------------------------- /Examples/SharepointPAService/src/PowerAutomate.zip/Microsoft.Flow/flows/manifest.json: -------------------------------------------------------------------------------- 1 | { 2 | "packageSchemaVersion": "1.0", 3 | "flowAssets": { "assetPaths": ["5ab6c1ee-9b2d-4d64-b8f2-67d9a09eba6e"] } 4 | } 5 | -------------------------------------------------------------------------------- /Examples/SharepointPAService/src/PowerAutomate.zip/manifest.json: -------------------------------------------------------------------------------- 1 | { 2 | "schema": "1.0", 3 | "details": { 4 | "displayName": "SharepointService", 5 | "description": "", 6 | "createdTime": "2025-04-14T15:06:18.6465183Z", 7 | "packageTelemetryId": "c8f10a9a-3ca3-4255-b433-785aa0e747c6", 8 | "creator": "N/A", 9 | "sourceEnvironment": "" 10 | }, 11 | "resources": { 12 | "5ab6c1ee-9b2d-4d64-b8f2-67d9a09eba6e": { 13 | "type": "Microsoft.Flow/flows", 14 | "suggestedCreationType": "Update", 15 | "creationType": "Existing, New, Update", 16 | "details": { "displayName": "SharepointService" }, 17 | "configurableBy": "User", 18 | "hierarchy": "Root", 19 | "dependsOn": [ 20 | "94038e56-d034-47f6-9700-150939a7c1e1", 21 | "0167ec3c-d2a9-48b9-9bc5-c4cf521e8cde" 22 | ] 23 | }, 24 | "94038e56-d034-47f6-9700-150939a7c1e1": { 25 | "id": "/providers/Microsoft.PowerApps/apis/shared_sharepointonline", 26 | "name": "shared_sharepointonline", 27 | "type": "Microsoft.PowerApps/apis", 28 | "suggestedCreationType": "Existing", 29 | "details": { 30 | "displayName": "SharePoint", 31 | "iconUri": "https://conn-afd-prod-endpoint-bmc9bqahasf3grgk.b01.azurefd.net/releases/v1.0.1738/1.0.1738.4131/sharepointonline/icon.png" 32 | }, 33 | "configurableBy": "System", 34 | "hierarchy": "Child", 35 | "dependsOn": [] 36 | }, 37 | "0167ec3c-d2a9-48b9-9bc5-c4cf521e8cde": { 38 | "type": "Microsoft.PowerApps/apis/connections", 39 | "suggestedCreationType": "Existing", 40 | "creationType": "Existing", 41 | "details": { 42 | "displayName": "James-PR.Warren@severntrent.co.uk", 43 | "iconUri": "https://conn-afd-prod-endpoint-bmc9bqahasf3grgk.b01.azurefd.net/releases/v1.0.1738/1.0.1738.4131/sharepointonline/icon.png" 44 | }, 45 | "configurableBy": "User", 46 | "hierarchy": "Child", 47 | "dependsOn": ["94038e56-d034-47f6-9700-150939a7c1e1"] 48 | } 49 | } 50 | } 51 | -------------------------------------------------------------------------------- /Examples/SharepointPAService/src/VBA/HTTPCollection.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "HTTPCollection" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = False 10 | 11 | Private Type TThis 12 | col as Collection 13 | responseMapper as stdICallable 14 | End Type 15 | Private This as TThis 16 | 17 | 'Create a new HTTPCollection object. 18 | '@return - A new HTTPCollection object 19 | Public Function Create() as HTTPCollection 20 | set Create = new HTTPCollection 21 | Call Create.protInit() 22 | End Function 23 | 24 | 'Initialize the HTTPCollection object. 25 | '@protected 26 | Public Sub protInit() 27 | set this.col = new Collection 28 | End Sub 29 | 30 | 'Add a new HTTP object to the collection. 31 | Public Sub add(ByVal http as stdHTTP) 32 | Call this.col.add(http) 33 | End Sub 34 | 35 | 'Await for all HTTP requests in the collection to complete. 36 | '@return - The HTTPCollection object itself 37 | Public Function Await() as HTTPCollection 38 | Dim http as stdHTTP 39 | For each http in this.col 40 | Call http.Await() 41 | Next http 42 | Set Await = Me 43 | End Function 44 | 45 | 'Get/Set the `responseMapper` which is utilised by the `responseMapped` property. 46 | '@return - The responseMapper callable object 47 | Public Property Get responseMapper() as stdICallable 48 | set responseMapper = this.responseMapper 49 | End Property 50 | Public Property Set responseMapper(v as stdICallable) 51 | set this.responseMapper = v 52 | End Property 53 | 54 | 55 | 'Uses reesponseMapper to return some mapped value from the collection. 56 | '@return - The mapped value from the collection 57 | Public Property Get ResponseMapped() as variant 58 | Call CopyVariant(ResponseMapped, this.responseMapper.run(this.col)) 59 | End Property 60 | 61 | 'Copies the value of src to dest. If src is an object, it sets dest to the same object reference. 62 | '@param dest - The destination to copy the value to 63 | '@param src - The source to copy the value from 64 | Private Sub CopyVariant(ByRef dest, ByVal src) 65 | if isObject(src) then 66 | set dest = src 67 | else 68 | let dest = src 69 | end if 70 | End Sub 71 | -------------------------------------------------------------------------------- /Examples/SharepointPAService/src/VBA/lib/stdICallable.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "stdICallable" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = false 9 | Attribute VB_Exposed = False 10 | 11 | 'Run the function with supplied parameters 12 | '@param params - The parameters to run the function with 13 | '@returns - The result of the function 14 | Public Function Run(ParamArray params() as variant) as variant: End Function 15 | 16 | 'Run the function with a array of parameters 17 | '@param params as Variant> - The parameters to run the function with 18 | '@returns - The result of the function 19 | Public Function RunEx(ByVal params as variant) as variant: End Function 20 | 21 | 'Bind a set of parameters to the function call 22 | '@param params - The parameters to bind to the function 23 | '@returns - A new function with the parameters bound 24 | Public Function Bind(ParamArray params() as variant) as stdICallable: End Function 25 | 26 | 'Making late-bound calls to `stdICallable` members. Each object which implements `stdICallable` 27 | 'will support a different set of latebound calls. 28 | '@protected 29 | '@param sMessage - Message to send. Standard messages include "obj" returning the object, "className" returning the class name. Other messages are implementation specific. 30 | '@param success - Whether the call was successful 31 | '@param params - Any variant, typically parameters as an array. Passed along with the message. 32 | '@returns - Any return value. 33 | Public Function SendMessage(ByVal sMessage as string, ByRef success as boolean, ByVal params as variant) as Variant: End Function 34 | 35 | 'Ideally we would want to get a pointer to the function... However, getting a pointer to an object method is 36 | 'going to be defficult, partly due to the first parameter sent to the function is `Me`! We'll likely have to 37 | 'use machine code to wrap a call with a `Me` pointer just so we can access the full pointer and use this in 38 | 'real life applications. 39 | 'Finally it might be better to do something more like: `stdPointer.fromICallable()` anyway 40 | ''Returns a callback function 41 | ''Typically this will be achieved with `stdPointer.GetLastPrivateMethod(me)` 42 | ''If this cannot be implemented return 0 43 | 'Public Function ToPointer() as long 44 | 45 | ''Bind arguments to functions to appear as first arguments in call. 46 | ''e.g. stdLambda.Create("$1.EnableEvents = false: $1.ScreenUpdating = false").bind(Application).Run() 47 | 'Public Function Bind(ByVal v as variant) as stdICallable: End Function 48 | 49 | 50 | -------------------------------------------------------------------------------- /Examples/SharepointPAService/src/VBA/test/Example.xlsm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/SharepointPAService/src/VBA/test/Example.xlsm -------------------------------------------------------------------------------- /Examples/SharepointPAService/src/VBA/test/SPPAServiceTest.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "SPPAServiceTest" 2 | Sub testListItems() 3 | Dim service As SPPAService: Set service = SPPAService.CreateFromCombinedConfig("C:\Temp\SPPAService_NOS.json") 4 | Dim j As stdJSON: Set j = service.ListItems().Await().ResponseMapped() 5 | Call JSONViewer.ShowViewer(j) 6 | End Sub 7 | 8 | Sub testListItemsWithQuery() 9 | Dim service As SPPAService: Set service = SPPAService.CreateFromCombinedConfig("C:\Temp\SPPAService_NOS.json") 10 | Dim j As stdJSON: Set j = service.ListItems("$expand=NOS&$select=Id,County,NOS/Title").Await().ResponseMapped() 11 | Call JSONViewer.ShowViewer(j) 12 | End Sub 13 | 14 | Sub testListItem() 15 | Dim service As SPPAService: Set service = SPPAService.CreateFromCombinedConfig("C:\Temp\SPPAService_NOS.json") 16 | Dim j As stdJSON: Set j = service.ListItem(1).Await().ResponseMapped() 17 | Call JSONViewer.ShowViewer(j) 18 | End Sub 19 | 20 | Sub testGetListItemType() 21 | Dim service As SPPAService: Set service = SPPAService.CreateFromCombinedConfig("C:\Temp\SPPAService_TacticalData-Test.json") 22 | Debug.Print service.getListItemType().Await().ResponseMapped() 23 | End Sub 24 | 25 | Sub testListItemCreate() 26 | Dim service As SPPAService: Set service = SPPAService.CreateFromCombinedConfig("C:\Temp\SPPAService_TacticalData-Test.json") 27 | Dim data As stdJSON: Set data = stdJSON.Create() 28 | Call data.Add("Title", "Hello") 29 | Call data.Add("Poop", "Choice 1") 30 | Dim HTTP As stdHTTP: Set HTTP = service.ListItemCreate(data).Await() 31 | Debug.Print HTTP.ResponseStatus 32 | End Sub 33 | 34 | Sub testListItemCreateBulk() 35 | Dim service As SPPAService: Set service = SPPAService.CreateFromCombinedConfig("C:\Temp\SPPAService_TacticalData-Test.json") 36 | Dim items As stdArray: Set items = stdArray.Create() 37 | For i = 1 To 10 38 | With stdJSON.Create() 39 | .Add "Title", "Hello " & i 40 | .Add "Poop", "Choice 1" 41 | Call items.Push(.ToSelf()) 42 | End With 43 | Next 44 | Debug.Print "Site: " & service.SiteURL & vbCrLf & "List: " & service.ListSelector 45 | 46 | With service.ListItemsCreateBatch(items) 47 | Dim results as string: results = .map(stdLambda.Create("$1.Await().ResponseText")).join(vbCrLf & vbCrLf) 48 | End with 49 | End Sub 50 | 51 | Sub testListItemsDeleteBatch() 52 | Dim service As SPPAService: Set service = SPPAService.CreateFromCombinedConfig("C:\Temp\SPPAService_TacticalData-Test.json") 53 | Dim items As stdArray: Set items = stdArray.Create(31,32,33) 54 | Debug.Print "Site: " & service.SiteURL & vbCrLf & "List: " & service.ListSelector 55 | 56 | With service.ListItemsDeleteBatch(items) 57 | Dim results as string: results = .map(stdLambda.Create("$1.Await().ResponseText")).join(vbCrLf & vbCrLf) 58 | End with 59 | End Sub 60 | 61 | 62 | Sub t() 63 | Debug.Print stdJSON.CreateFromParams(eJSONObject, "a", 1, "b", 2).ToString() 64 | Debug.Print stdJSON.CreateFromParams(eJSONArray, "a", 1, "b", 2).ToString() 65 | End Sub 66 | -------------------------------------------------------------------------------- /Examples/SplitSideBySide/README.md: -------------------------------------------------------------------------------- 1 | 8 | 9 | # Excel and Browser side-by-side 10 | 11 | Split the screen into 2 halves. The left half should contain the excel window. The right half should contain a browser window of your choosing 12 | 13 | ## Requirements 14 | 15 | * [stdVBA](http://github.com/sancarn/stdVBA) 16 | * stdICallable 17 | * stdWindow 18 | * stdLambda 19 | * Currently only works on Windows OS 20 | 21 | ## Usage 22 | 23 | Ensure a browser window is open when running this code. 24 | 25 | ```vb 26 | Sub Main() 27 | Call SideBySide(Edge) 28 | End Sub 29 | ``` 30 | 31 | ## Comparison with pure VBA 32 | 33 | With `stdVBA` we've trimmed our solution down to 162 lines to about 62. `stdVBA` helps you cut down on boiler plate and helps you focus on the important questions like "How do I move my window" rather than "How do I get the caption text of a window?". 34 | 35 | ![comparison](docs/comparison.png) 36 | -------------------------------------------------------------------------------- /Examples/SplitSideBySide/docs/ comparison.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/SplitSideBySide/docs/ comparison.png -------------------------------------------------------------------------------- /Examples/SplitSideBySide/src/SplitSideBySide.bas: -------------------------------------------------------------------------------- 1 | Public Enum BrowsersEnum 2 | Brave 3 | Chrome 4 | Edge 5 | FireFox 6 | InternetExplorer 7 | Opera 8 | Vivaldi 9 | End Enum 10 | 11 | Public Sub SideBySide(Optional SelectedBrowser As BrowsersEnum = Chrome) 12 | 'Identify different browsers by Window Class and Caption pattern matcher 13 | Dim sBrowserCaptionMatcher as string, sBrowserClass as string 14 | Select case SelectedBrowser 15 | case Brave 16 | sBrowserClass = "Chrome_WidgetWin_1" 17 | sBrowserCaptionMatcher = "*- Brave" 18 | case Chrome 19 | sBrowserClass = "Chrome_WidgetWin_1" 20 | sBrowserCaptionMatcher = "*- Google Chrome" 21 | case Edge 22 | sBrowserClass = "Chrome_WidgetWin_1" 23 | sBrowserCaptionMatcher = "*- Microsoft Edge" 24 | case FireFox 25 | sBrowserClass = "MozillaWindowClass" 26 | sBrowserCaptionMatcher = "*- Mozilla FireFox" 27 | Case InternetExplorer 28 | sBrowserClass = "IEFrame" 29 | sBrowserCaptionMatcher = "*- Internet Explorer" 30 | Case Opera 31 | sBrowserClass = "Chrome_WidgetWin_1" 32 | sBrowserCaptionMatcher = "*- Opera" 33 | Case Vivaldi 34 | sBrowserClass = "Chrome_WidgetWin_1" 35 | sBrowserCaptionMatcher = "*- Vivaldi" 36 | end select 37 | 38 | 'Create a matcher for FindFirst 39 | Dim browserFinder as stdLambda 40 | set browserFinder = stdLambda.Create("if $4 > 1 then EWndFindResult.NoMatchSkipDescendents else $3.Class = $2 And $3.Caption like $1") _ 41 | .bind(sBrowserCaptionMatcher, sBrowserClass) 42 | 43 | 'Get the desktop. Set the application to the left half of the screen, set the web browser to the right half of the screen. 44 | Dim desktop As stdWindow: Set desktop = stdWindow.CreateFromDesktop() 45 | With stdWindow.CreateFromApplication() 46 | .State = Normal 47 | .x = desktop.x 48 | .y = desktop.y 49 | .width = desktop.width / 2 50 | .height = desktop.height - 40 51 | End With 52 | 53 | Dim win as stdWindow 54 | For each win in stdWindow.CreateFromDesktop.FindAll(browserFinder) 55 | .State = Normal 56 | .x = desktop.x + desktop.width / 2 57 | .y = desktop.y 58 | .width = desktop.width / 2 59 | .height = desktop.height - 40 60 | .Activate 61 | next 62 | End Sub 63 | -------------------------------------------------------------------------------- /Examples/Spreadsheet Extractor/ExtractionTemplate 1.1.xlsm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Spreadsheet Extractor/ExtractionTemplate 1.1.xlsm -------------------------------------------------------------------------------- /Examples/Spreadsheet Extractor/Tests/Mars.xlsx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Spreadsheet Extractor/Tests/Mars.xlsx -------------------------------------------------------------------------------- /Examples/Spreadsheet Extractor/Tests/Nesle.xlsx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Spreadsheet Extractor/Tests/Nesle.xlsx -------------------------------------------------------------------------------- /Examples/Spreadsheet Extractor/_/DataGeneration/Bars/CafeChocolate - Chocolate Platte.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Spreadsheet Extractor/_/DataGeneration/Bars/CafeChocolate - Chocolate Platte.png -------------------------------------------------------------------------------- /Examples/Spreadsheet Extractor/_/DataGeneration/Bars/DALLE - Arrits.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Spreadsheet Extractor/_/DataGeneration/Bars/DALLE - Arrits.png -------------------------------------------------------------------------------- /Examples/Spreadsheet Extractor/_/DataGeneration/Bars/DALLE - CandyCorns.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Spreadsheet Extractor/_/DataGeneration/Bars/DALLE - CandyCorns.png -------------------------------------------------------------------------------- /Examples/Spreadsheet Extractor/_/DataGeneration/Bars/DALLE - Gumballs.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Spreadsheet Extractor/_/DataGeneration/Bars/DALLE - Gumballs.png -------------------------------------------------------------------------------- /Examples/Spreadsheet Extractor/_/DataGeneration/Bars/DALLE - Matrats.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Spreadsheet Extractor/_/DataGeneration/Bars/DALLE - Matrats.png -------------------------------------------------------------------------------- /Examples/Spreadsheet Extractor/_/DataGeneration/Bars/DALLE - McCrackers.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Spreadsheet Extractor/_/DataGeneration/Bars/DALLE - McCrackers.png -------------------------------------------------------------------------------- /Examples/Spreadsheet Extractor/_/DataGeneration/Bars/Dredgar - Aiftfer 8.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Spreadsheet Extractor/_/DataGeneration/Bars/Dredgar - Aiftfer 8.png -------------------------------------------------------------------------------- /Examples/Spreadsheet Extractor/_/DataGeneration/Bars/Dredgar - Malseler.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Spreadsheet Extractor/_/DataGeneration/Bars/Dredgar - Malseler.png -------------------------------------------------------------------------------- /Examples/Spreadsheet Extractor/_/DataGeneration/Bars/Dredgar - Mars.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Spreadsheet Extractor/_/DataGeneration/Bars/Dredgar - Mars.png -------------------------------------------------------------------------------- /Examples/Spreadsheet Extractor/_/DataGeneration/Bars/Dredgar - Snint.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Spreadsheet Extractor/_/DataGeneration/Bars/Dredgar - Snint.png -------------------------------------------------------------------------------- /Examples/Spreadsheet Extractor/_/DataGeneration/Bars/PROMPTS.txt: -------------------------------------------------------------------------------- 1 | Chocolate candy wrapper created by franchise Marnies -------------------------------------------------------------------------------- /Examples/Spreadsheet Extractor/_/DataGeneration/Data.csv: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Spreadsheet Extractor/_/DataGeneration/Data.csv -------------------------------------------------------------------------------- /Examples/Spreadsheet Extractor/_/DataGeneration/Data.xlsx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Spreadsheet Extractor/_/DataGeneration/Data.xlsx -------------------------------------------------------------------------------- /Examples/Spreadsheet Extractor/docs/CategoriesExample.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Spreadsheet Extractor/docs/CategoriesExample.png -------------------------------------------------------------------------------- /Examples/Spreadsheet Extractor/docs/GithubOverview.pptx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Spreadsheet Extractor/docs/GithubOverview.pptx -------------------------------------------------------------------------------- /Examples/Spreadsheet Extractor/docs/Overview.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Spreadsheet Extractor/docs/Overview.png -------------------------------------------------------------------------------- /Examples/Spreadsheet Extractor/docs/ProjectStructure.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Spreadsheet Extractor/docs/ProjectStructure.png -------------------------------------------------------------------------------- /Examples/Spreadsheet Extractor/docs/RulesExample.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Spreadsheet Extractor/docs/RulesExample.png -------------------------------------------------------------------------------- /Examples/Spreadsheet Extractor/docs/RunningTheTool.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Spreadsheet Extractor/docs/RunningTheTool.png -------------------------------------------------------------------------------- /Examples/Spreadsheet Extractor/extensions/british_geospatial.xlsm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Spreadsheet Extractor/extensions/british_geospatial.xlsm -------------------------------------------------------------------------------- /Examples/Spreadsheet Extractor/extensions/template.xlsm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Spreadsheet Extractor/extensions/template.xlsm -------------------------------------------------------------------------------- /Examples/Spreadsheet Extractor/src/.Modules/xrExtractor.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "xrExtractor" 2 | Public Sub ExtractorMain() 3 | Application.StatusBar = "Setting up..." 4 | 5 | Dim ePaths As stdEnumerator: Set ePaths = stdEnumerator.CreateFromListObject(dataPaths.ListObjects("Paths")) 6 | Dim categories As xrCategories: Set categories = xrCategories.Create(dataCategories.ListObjects("Categories")) 7 | Dim rules As xrRules: Set rules = xrRules.Create(dataRules.ListObjects("Rules")) 8 | 9 | Dim results As stdArray: Set results = stdArray.Create() 10 | 11 | 'Boot a new instance of the excel application 12 | 'opening workbooks in a seperate instance ensures that the workbook isn't loaded on each loop cycle. 13 | 'it will also ensure that we can set various performance increasing settings, allowing us to scan the 14 | 'workbook as soon as possible. Finally we can prevent annoyances like Asking to update links. 15 | 'note we intentionally don't set this app to visible. 16 | Dim xlApp As Excel.Application: Set xlApp = New Excel.Application 17 | xlApp.AskToUpdateLinks = False 18 | xlApp.ScreenUpdating = False 19 | xlApp.AutomationSecurity = msoAutomationSecurityForceDisable 20 | xlApp.EnableEvents = False 21 | xlApp.DisplayAlerts = False 22 | 23 | 'Loop over each path in the supplied paths table 24 | Dim oPath, i As Long: i = 0 25 | For Each oPath In ePaths 26 | 'Increment progress counter 27 | i = i + 1 28 | 29 | 'Only extract if Processed <> Yes 30 | If oPath("Processed") <> "Yes" Then 31 | 'Open workbook in hidden instance 32 | Dim wb As Workbook: Set wb = forceOpenWorkbook(oPath("Path"), xlApp) 33 | 34 | Dim ws As Worksheet 35 | For Each ws In wb.Worksheets 36 | Application.StatusBar = "Processing workbook " & i & "/" & ePaths.Length & " Worksheet: " & ws.name 37 | 38 | 'Get category from sheet data 39 | Dim sCategory As String: sCategory = categories.getCategory(ws) 40 | 41 | 'Perform extraction 42 | If sCategory <> "" Then Call results.Push(rules.executeRules(ws, sCategory)) 43 | Next 44 | 45 | wb.Close SaveChanges:=False 46 | 47 | 'Update row 48 | Call setRowCell(oPath, "Processed", "Yes") 49 | End If 50 | Next 51 | 52 | 'Close hidden app instance 53 | xlApp.Quit 54 | 55 | 56 | Application.StatusBar = "Exporting results..." 57 | Call exportResults(dataOutput, "Output", results) 58 | Application.StatusBar = Empty 59 | End Sub 60 | 61 | 62 | '@param {Worksheet} Sheet to export data to 63 | '@param {(stdEnumerator|stdArray)} Results to export to range 64 | Sub exportResults(ByVal ws As Worksheet, ByVal sTableName As String, results As Object) 65 | If TypeOf results Is stdArray Or TypeOf results Is stdEnumerator Then 66 | If results.Length = 0 Then Exit Sub 'length guard 67 | 68 | 'Populate headers in result 69 | Dim vResults() As Variant 70 | Dim vFields: vFields = results.item(1).keys() 71 | Dim iFieldLength As Long: iFieldLength = UBound(vFields) - LBound(vFields) + 1 72 | ReDim vResults(1 To results.Length + 1, 1 To iFieldLength) 73 | Dim iResCol As Long: iResCol = 0 74 | Dim vField 75 | For Each vField In vFields 76 | iResCol = iResCol + 1 77 | vResults(1, iResCol) = vField 78 | Next 79 | 80 | 'Populate data in result 81 | Dim iRow As Long 82 | For iRow = 1 To results.Length 83 | iResCol = 0 84 | For Each vField In vFields 85 | iResCol = iResCol + 1 86 | vResults(iRow + 1, iResCol) = results.item(iRow)(vField) 87 | Next 88 | Next 89 | 90 | 'Write data to output 91 | dataOutput.UsedRange.Clear 92 | With dataOutput.Range("A1").Resize(results.Length + 1, iFieldLength) 93 | .value = vResults 94 | .WrapText = False 95 | With dataOutput.ListObjects.add(xlSrcRange, .Cells) 96 | .name = sTableName 97 | End With 98 | End With 99 | End If 100 | End Sub 101 | 102 | 'Forcefully open a workbook, handling 103 | '@param {string} Path of workbook to open 104 | '@param {Excel.Application} Application to open workbook within 105 | '@returns {Excel.Workbook} Workbook opened / repaired. 106 | Private Function forceOpenWorkbook(ByVal sPath As String, Optional ByVal xlApp As Excel.Application = Nothing) As Workbook 107 | If xlApp Is Nothing Then Set xlApp = Application 108 | On Error GoTo TryRepair 109 | Set forceOpenWorkbook = xlApp.Workbooks.Open(sPath) 110 | Exit Function 111 | TryRepair: 112 | On Error GoTo ErrorOccurred 113 | Set forceOpenWorkbook = xlApp.Workbooks.Open(sPath, CorruptLoad:=XlCorruptLoad.xlRepairFile) 114 | Exit Function 115 | ErrorOccurred: 116 | Set forceOpenWorkbook = Nothing 117 | End Function 118 | 119 | 120 | 'Given a row object supplied by `stdEnumerator.CreateFromListObject()`, update a cell's value based on it's column name 121 | '@param {Object} Row object 122 | '@param {String} Column name 123 | '@param {Variant} Value to set cell to 124 | Private Sub setRowCell(ByVal oRow As Object, ByVal sColumnName As String, ByVal vValue As Variant) 125 | Application.Intersect(oRow("=ListRow").Range, oRow("=ListColumns")(sColumnName).Range).value = vValue 126 | End Sub 127 | 128 | 129 | 130 | '@test 131 | Sub test_exportResults() 132 | Dim res As stdArray: Set res = stdArray.Create(td(1, 2, 3, 4), td(4, 5, 6, 7)) 133 | Call exportResults(dataOutput, "Output", res) 134 | End Sub 135 | 136 | '@test 137 | '@helper 138 | Private Function td(a, b, c, d) As Object 139 | Dim o As Object 140 | Set o = CreateObject("Scripting.Dictionary") 141 | o("a") = a 142 | o("b") = b 143 | o("c") = c 144 | o("d") = d 145 | Set td = o 146 | End Function 147 | -------------------------------------------------------------------------------- /Examples/Spreadsheet Extractor/src/Class Modules/xrCategories.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "xrCategories" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = True 10 | 'An array of the following structure 11 | 'categories = [ 12 | ' {Name: ... , Conditions: [lambda1, lambda2, ...]} 13 | ' {Name: ... , Conditions: [lambda1, lambda2, ...]} 14 | '] 15 | Private categories As stdArray 16 | 17 | Public Function Create(ByVal lo As ListObject) As xrCategories 18 | Set Create = New xrCategories 19 | Call Create.protInit(lo) 20 | End Function 21 | Friend Sub protInit(lo As ListObject) 22 | Set categories = stdArray.Create() 23 | 24 | Dim vCat As Object 25 | For Each vCat In stdEnumerator.CreateFromListObject(lo) 26 | 'Create a new category object, to be used by getCategory 27 | Dim oNewCategory As Object 28 | Set oNewCategory = CreateObject("Scripting.Dictionary") 29 | oNewCategory("Name") = vCat("Category") 30 | 31 | 'Obtain conditions array, which is an array of lambdas, which can each be used to determine whether a targetSheet matches a category 32 | Dim conditions As stdArray: Set conditions = stdArray.CreateFromArray(vCat.items()) 33 | Call conditions.Shift 'remove first element 34 | Set conditions = conditions.Filter(stdLambda.Create("not isObject($1)")) 35 | 36 | Set oNewCategory("Conditions") = conditions.Map(stdCallback.CreateFromObjectMethod(xrLambdaEx, "Create")) 37 | 38 | 'Bind results to array categories global array 39 | categories.Push oNewCategory 40 | Next 41 | End Sub 42 | 43 | 'Obtains a category from a given worksheet 44 | '@param {ByVal Worksheet} Worksheet to identify category within. (VIDEO NOTE: `ByVal` is important here as it crashes without it, due to a VBA bug) 45 | '@returns {String} - "" if no category found, else one of the categories listed in the primal list object 46 | Public Function getCategory(ByVal targetSheet As Worksheet) As String 47 | For Each Category In categories 48 | Call Category("Conditions").ForEach(stdLambda.Create("$2.bindGlobal(""targetSheet"",$1)").Bind(targetSheet)) 49 | If Category("Conditions").Reduce(stdLambda.Create("$1 and $2.Run()"), True) Then 50 | getCategory = Category("Name") 51 | Exit Function 52 | End If 53 | Next 54 | getCategory = "" 55 | End Function 56 | 57 | 'Test categories 58 | '@test 59 | Friend Sub test() 60 | Dim cats As xrCategories 61 | Set cats = xrCategories.Create(dataCategories.ListObjects("Categories")) 62 | Debug.Print rules.getCategory(testCategories1) 63 | Debug.Print cats.getCategory(testCategories2) 64 | End Sub 65 | -------------------------------------------------------------------------------- /Examples/Spreadsheet Extractor/src/Class Modules/xrRules.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "xrRules" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = False 10 | Private categories As Object 11 | 12 | Public Function Create(ByVal lo As ListObject) As xrRules 13 | Set Create = New xrRules 14 | Call Create.protInit(lo) 15 | End Function 16 | 17 | Friend Sub protInit(lo As ListObject) 18 | Set categories = stdEnumerator.CreateFromListObject(lo).groupBy(stdLambda.Create("$1.Category")) 19 | 20 | Dim vCat, vKey 21 | For Each vCat In categories.keys() 22 | Dim oRetDict As Object: Set oRetDict = CreateObject("Scripting.Dictionary") 23 | Set oRetDict("Path") = xrLambdaEx.Create("targetSheet.parent.fullname") 24 | Set oRetDict("Sheet") = xrLambdaEx.Create("targetSheet.name") 25 | Set oRetDict("Category") = xrLambdaEx.Create("targetCategory") 26 | 27 | 'Apply user defined overrides 28 | Dim oCat As Object: Set oCat = categories(vCat).item(1) 29 | For Each vKey In oCat.keys() 30 | If vKey <> "Category" And Left(vKey, 1) <> "=" Then 31 | Dim sExpression As String: sExpression = oCat(vKey) 32 | Set oRetDict(vKey) = xrLambdaEx.Create(sExpression) 33 | End If 34 | Next 35 | 36 | Set categories(vCat) = oRetDict 37 | Next 38 | End Sub 39 | 40 | 'Execute the rules to generate a list of results 41 | '@param {Worksheet} TargetSheet to extract data from 42 | '@param {String} Category to perform which extraction rules 43 | '@returns {stdEnumerator>} Results of extraction as enumerator of dictionaries 44 | Public Function executeRules(ByVal targetSheet As Worksheet, ByVal sCategory As String) As Object 45 | Dim rules As Object: Set rules = categories(sCategory) 46 | Dim oRet As Object: Set oRet = CreateObject("Scripting.Dictionary") 47 | Dim vKey 48 | For Each vKey In rules.keys() 49 | Dim ld As stdLambda: Set ld = rules(vKey) 50 | Set ld.oFunctExt("targetSheet") = targetSheet 51 | ld.oFunctExt("targetCategory") = sCategory 52 | oRet(vKey) = ld.Run() 53 | Next 54 | Set executeRules = oRet 55 | End Function 56 | 57 | 58 | 59 | 'Test Rules 60 | '@test 61 | Friend Sub test() 62 | Dim rules As xrRules 63 | Set rules = xrRules.Create(dataRules.ListObjects("Rules")) 64 | Debug.Print stringify(rules.executeRules(testCategories1, "1.0.0")) 65 | Debug.Print stringify(rules.executeRules(testCategories2, "1.1.0")) 66 | End Sub 67 | 68 | 'Stringify a dictionary 69 | '@test 70 | '@helper 71 | Private Function stringify(ByVal obj As Object) As String 72 | Dim s As String: s = "{" 73 | Dim vKey: For Each vKey In obj.keys() 74 | s = s & vKey & ": " 75 | Select Case varType(obj(vKey)) 76 | Case VbVarType.vbString 77 | s = s & """" & obj(vKey) & """" 78 | Case Else 79 | s = s & CDbl(obj(vKey)) 80 | End Select 81 | s = s & ", " 82 | Next 83 | stringify = s & "}" 84 | End Function 85 | -------------------------------------------------------------------------------- /Examples/Timer/README.md: -------------------------------------------------------------------------------- 1 | 8 | 9 | # Browser Automation with stdVBA 10 | 11 | Calls a timer function at a set frequency 12 | 13 | ## Requirements 14 | 15 | * [stdVBA](http://github.com/sancarn/stdVBA) 16 | * stdICallable 17 | * Currently only works on Windows OS 18 | 19 | ## Usage 20 | 21 | * Import dependencies 22 | * Call `StartTimer` as necessary. Call `StopTimer` to stop if needed. 23 | 24 | ## Roadmap 25 | 26 | * [X] Create workable timer 27 | 28 | ## Known issues 29 | 30 | TBC -------------------------------------------------------------------------------- /Examples/Timer/src/stdTimer.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "stdTimer" 2 | #If VBA7 Then 3 | Private Declare PtrSafe Function SetTimer Lib "User32" (ByVal hwnd As LongPtr, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As Long 4 | Private Declare PtrSafe Function KillTimer Lib "User32" (ByVal hwnd As LongPtr, ByVal nIDEvent As Long) As Long 5 | #Else 6 | Enum LongPtr 7 | [_] 8 | End Enum 9 | Private Declare Function SetTimer Lib "User32" (ByVal hwnd As LongPtr, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As Long 10 | Private Declare Function KillTimer Lib "User32" (ByVal hwnd As LongPtr, ByVal nIDEvent As Long) As Long 11 | #End If 12 | 13 | Private Type TimerInfo 14 | isAlive As Boolean 15 | id As Long 16 | callable As stdICallable 17 | times As Long 18 | End Type 19 | Private Timers() As TimerInfo 20 | Private pTimerCount As Long 21 | 22 | 'Specify a time in milliseconds and a function, and the routine will call this function every n milliseconds. 23 | '@param {Long} The frequency at which the function should be called 24 | '@param {stdICallable} The function to call at the frequency specified 25 | '@param {Long} The number of times to call the callback 26 | '@returns {Long} Index of timer in Timers array. Use this when calling StopTimer() 27 | Public Function StartTimer(ByVal iMilliseconds As Long, ByVal callable As stdICallable, Optional ByVal iNumberOfTimes As Long = -1) As Long 28 | On Error Resume Next: Dim iNextTimer As Long: iNextTimer = UBound(Timers) + 1: On Error GoTo 0 29 | ReDim Timers(0 To iNextTimer) 30 | pTimerCount = pTimerCount + 1 31 | With Timers(iNextTimer) 32 | .isAlive = True 33 | Set .callable = callable 34 | .times = iNumberOfTimes 35 | .id = SetTimer(0, 0, iMilliseconds, AddressOf OnTime) 36 | StartTimer = iNextTimer 37 | End With 38 | End Function 39 | 40 | 'Stop an active timer 41 | '@param {Long} The index of the timer to stop in Timers array. This ID is returned from StartTimer() 42 | Public Sub StopTimer(ByVal iTimerIndex As Long) 43 | With Timers(iTimerIndex) 44 | If .isAlive Then 45 | Call KillTimer(0, .id) 46 | .isAlive = False 47 | pTimerCount = pTimerCount - 1 48 | End If 49 | End With 50 | End Sub 51 | 52 | 'Stop all timers 53 | Public Sub StopAll() 54 | For i = 0 To UBound(Timers) 55 | With Timers(i) 56 | Call KillTimer(0, .id) 57 | .isAlive = False 58 | End With 59 | Next 60 | pTimerCount = 0 61 | End Sub 62 | 63 | 'Callback called at the desired frequency 64 | Private Sub OnTime(ByVal hwnd As LongPtr, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Integer) 65 | 'If VBA reset, make sure to kill the timer 66 | If pTimerCount = 0 Then 67 | Call KillTimer(0, idEvent) 68 | Exit Sub 69 | End If 70 | 71 | 'Get timer and run callback 72 | Dim iTimerIndex As Long: iTimerIndex = getTimerIndex(idEvent) 73 | With Timers(iTimerIndex) 74 | Call .callable.Run 75 | 76 | 'Handle callback number of times 77 | If .times > 0 Then 78 | .times = .times - 1 79 | If .times = 0 Then Call StopTimer(iTimerIndex) 80 | End If 81 | End With 82 | End Sub 83 | 84 | 'Obtain the index of a timer from it's internal ID 85 | Private Function getTimerIndex(ByVal nID As Long) As Long 86 | For i = 0 To UBound(Timers) 87 | With Timers(i) 88 | If .id = nID Then 89 | getTimerIndex = i 90 | Exit Function 91 | End If 92 | End With 93 | Next 94 | End Function 95 | -------------------------------------------------------------------------------- /Examples/Timer/src/stdTimerTests.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "stdTimerTests" 2 | Public Sub Test() 3 | Call StartTimer(1000, stdCallback.CreateFromModule("stdTimerTests", "TestCallback")) 4 | End Sub 5 | Public Sub TestCallback() 6 | Static i As Long: i = i + 1 7 | Debug.Print "hello " & i 8 | End Sub 9 | -------------------------------------------------------------------------------- /Examples/Timer/stdTimerTests.xlsm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/Timer/stdTimerTests.xlsm -------------------------------------------------------------------------------- /Examples/stdTable/README.md: -------------------------------------------------------------------------------- 1 | # stdTable 2 | 3 | This example, is kind of a library in-of itself. `stdTable`, found in the `src` folder can be used to perform manipulations on tables in a simple declarative manor which mimics SQL. 4 | 5 | ```vb 6 | Attribute VB_Name = "Module1" 7 | 8 | Sub main() 9 | Call stdTable.CreateFromTableByName("Table3") _ 10 | .GroupByField("2", "group") _ 11 | .RenameFields("2", "Type") _ 12 | .AddField("Count", stdLambda.Create("$1.group.length")) _ 13 | .AddField("Sum5", stdLambda.Create("$1.group.sum(lambda(""$1.item(""""5"""")""))")) _ 14 | .ToListObject(Sheet3.Range("A1")) 15 | End Sub 16 | ``` 17 | 18 | This interface aims to be similar in style to the functionality in PowerQuery, but instead with a code first approach. 19 | 20 | ## Requirements 21 | 22 | - `stdEnumerator` 23 | - `stdCallback` 24 | - `stdICallable` 25 | - `stdJSON` - For JSON parsing and exporting 26 | 27 | `stdLambda` is used in a number of examples. But any class which implements `stdICallable` is valid in their place. 28 | 29 | ## Constructors 30 | 31 | - Constructors 32 | - `CreateFromListObject` - Create an Excel list object 33 | - `CreateFromTableByName` - Create an Excel table object by the name of the table 34 | - `CreateFromRecordSet` - Create a table object from a ADODB record set 35 | - Instance Properties 36 | - `Get/Let` Name - The name of the table 37 | - `Get` Headers - The current headers of the table. These are the headers which will be exported when using a To\_\_\_() method. 38 | - `Get` Rows - Obtain the rows of the table as a `stdEnumerator`. 39 | - Instance Methods 40 | - `FieldsSelect` - Select the required fields for the table (i.e. remove fields) 41 | - `RenameFields` - Rename a number of fields to a new name. 42 | - `AddField` - Add a field, and populate it with some callback. 43 | - `UpdateField` - Update a field to the result of some callback. 44 | - `UpdateFieldStatic` - Update a field to a static value. 45 | - `ForEach` - Execute a callback over each row of the table - Commonly used for updating multiple fields. 46 | - `Filter` - Filter a table based on some callback. 47 | - `Join` - Join one table with another table based on some common key. 48 | - `Concat` - Concatenate 2 tables together. 49 | - `AddRow` - Add a single row to a table (slow! - use concat for multiple rows) 50 | - `Reverse` - Reverse the rows in the table. 51 | - `GroupByField` - Group rows of this table by a particular field. 52 | - `GroupBy` - Group rows of this table by a key generated from a callback. 53 | - `Clone` - Clone this table 54 | - `Unique` - Remove duplicates from a table based key generated by a callback. 55 | - `ToArray2D` - Convert the table into a 2D array 56 | - `ToListObject` - Import the table into an Excel ListObject 57 | - `ToRecordSet` - Create an ADODB recordset based on the data inside the table. 58 | - `ToCollection` - Creates a Collection of dictionaries from the table. 59 | - `ToJSON` - Requires `stdJSON` Dump the data to a JSON string. 60 | - `ToJSONFile` - Requires `stdJSON` Dump the data to a JSON file. 61 | 62 | ## Currying to increase functionality 63 | 64 | One of the concerns that people may have is the difficulty in accessing fields like field `5` above, and ensuring that you have the number of quotes correct. To make this easier we can use currying (functions which return functions) to generate functions like `getter` here, which can be used to get fields for you. 65 | 66 | ```vb 67 | Attribute VB_Name = "Module1" 68 | 69 | Sub main() 70 | Call stdTable.CreateFromTableByName("Table3") _ 71 | .GroupByField("2", "group") _ 72 | .RenameFields("2", "Type") _ 73 | .AddField("Count", query("$1.group.length")) _ 74 | .AddField("Sum5", query("$1.group.sum(getter(""5""))")) _ 75 | .ToListObject(Sheet3.Range("A1")) 76 | End Sub 77 | 78 | 'Generate a `stdLambda` instance with additional bound functions 79 | '@param expression - Lambda expression with use of additional functions if needed 80 | '@returns - A lambda object 81 | Public Function query(ByVal expression As String) As stdLambda 82 | Set query = stdLambda.Create(expression) 83 | Set query.oFunctExt("lambda") = stdCallback.CreateFromModule("Module1", "query") 'rebind lambda to this function. 84 | Set query.oFunctExt("getter") = stdCallback.CreateFromModule("Module1", "fieldGetter") 85 | End Function 86 | 87 | 'Currying - Return a lambda with data bound to it. 88 | '@param field - Field to obtain 89 | '@returns stdLambda<(record: Object>)=>variant> 90 | Public Function fieldGetter(ByVal field As String) As stdLambda 91 | 'Note that bound data appears in 1st argument 92 | Set fieldGetter = stdLambda.Create("$2.item($1)").bind(field) 93 | End Function 94 | ``` 95 | 96 | This is a fairly advanced technique, but leads to some very powerful functionality. You can find out more about currying [here](https://youtu.be/nuML9SmdbJ4). 97 | -------------------------------------------------------------------------------- /Examples/stdTable/stdTableTest.xlsm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/stdTable/stdTableTest.xlsm -------------------------------------------------------------------------------- /Examples/uiTextBoxEx-WordControl/README.md: -------------------------------------------------------------------------------- 1 | 8 | 9 | # TextBoxEx for VBA UserForms 10 | 11 | This is a text box control which uses a Microsoft Word instance as a userform control. This control offers all the features you get in word, critically **spell checking**. 12 | 13 | ![preview](docs/preview.png) 14 | 15 | ![result](docs/result.png) 16 | 17 | ## Requirements 18 | 19 | * [stdVBA](http://github.com/sancarn/stdVBA) 20 | * stdICallable 21 | * stdWindow 22 | * stdProcess 23 | * stdLambda 24 | * Currently only works on Windows OS 25 | 26 | ## Usage 27 | 28 | Draw a frame on your Userform. The textBox should populate the frame's location and size. 29 | 30 | In your form code add the following: 31 | 32 | ```vb 33 | Private textBox As uiTextBoxEx 34 | 35 | Private Sub UserForm_Initialize() 36 | 'Intiialise textbox 37 | Set textBox = uiTextBoxEx.Create(Me.TextBoxFrame) 38 | 39 | 'You can change the text displayed via the Text property. This isn't a requirement 40 | textBox.Text = "Yo bruva it's ya boy Jamo and I got something really cool to tell ya " & _ 41 | "It's so cool that you're gunna shizzle ma nizzle isn't it?" 42 | End Sub 43 | ``` 44 | 45 | ## Roadmap 46 | 47 | * [X] Basic text editing / display 48 | * [ ] Disable-able (read only) 49 | * [X] Is there an easy way to inject and extract formatted text? (Use `OpenXML` property) 50 | * [ ] Can the OpenXML be simplified? 51 | * [ ] Make a library to generate OpenXML (for the production of auto-formatters e.g. syntax highlighters) 52 | * [ ] Add a `Textbox.injectToolbar(textBox,frame)` for common commands like `bold`, `italic`, `strikethrough`, `color`, `highlight`, etc. 53 | 54 | ## Known issues 55 | 56 | * Slow startup 57 | * Try to avoid create a huge quantity of these textboxes. A brand new word instance is created for each textbox, and that's pretty performance heavy. Instead keep 1 textbox and change the parent of it if necessary. 58 | * Sometimes ui appears to go offscreen and there are potential sizing issues - happy for PRs to correct this. 59 | -------------------------------------------------------------------------------- /Examples/uiTextBoxEx-WordControl/WordControl.xlsm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/uiTextBoxEx-WordControl/WordControl.xlsm -------------------------------------------------------------------------------- /Examples/uiTextBoxEx-WordControl/docs/preview.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/uiTextBoxEx-WordControl/docs/preview.png -------------------------------------------------------------------------------- /Examples/uiTextBoxEx-WordControl/docs/result.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/uiTextBoxEx-WordControl/docs/result.png -------------------------------------------------------------------------------- /Examples/uiTextBoxEx-WordControl/src/Test.frm: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} Test 3 | Caption = "Test" 4 | ClientHeight = 2940 5 | ClientLeft = 120 6 | ClientTop = 465 7 | ClientWidth = 4560 8 | OleObjectBlob = "Test.frx":0000 9 | StartUpPosition = 1 'CenterOwner 10 | End 11 | Attribute VB_Name = "Test" 12 | Attribute VB_GlobalNameSpace = False 13 | Attribute VB_Creatable = False 14 | Attribute VB_PredeclaredId = True 15 | Attribute VB_Exposed = False 16 | Private textBox As uiTextBoxEx 17 | 18 | Private Sub MsgboxMe_Click() 19 | MsgBox textBox.Text, vbInformation 20 | Unload Me 21 | End Sub 22 | 23 | Private Sub UserForm_Initialize() 24 | Set textBox = uiTextBoxEx.Create(Me.TextBoxFrame) 25 | 26 | With textBox 27 | .Text = "This is the UI Textbox - an " & _ 28 | "example of stdVBA in action..." 29 | .ReadOnly = True 30 | End With 31 | 32 | End Sub 33 | 34 | Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) 35 | Call textBox.Terminate 36 | 37 | 'Have to terminate VBA here. 38 | End 39 | End Sub 40 | 41 | 42 | -------------------------------------------------------------------------------- /Examples/uiTextBoxEx-WordControl/src/Test.frx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/uiTextBoxEx-WordControl/src/Test.frx -------------------------------------------------------------------------------- /Examples/uiTextBoxEx-WordControl/src/mMain.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "mMain" 2 | Sub Main() 3 | Test.Show False 4 | End Sub 5 | -------------------------------------------------------------------------------- /Examples/uiTextBoxEx-WordControl/src/uiTextBoxEx.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "uiTextBoxEx" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = False 10 | 'Bindings to userform 11 | Private pWndUserformFrame As stdWindow 12 | 13 | 'Bindings to word application 14 | Private pAppWord As Object 15 | Private pAppWordDoc As Object 16 | Private pWndWord As stdWindow 17 | Private pWndWordPane As stdWindow 18 | Private pProcWord As stdProcess 19 | 20 | 'Variable to store read-only setting 21 | Private pSettingsReadOnly As Boolean 22 | 23 | Public Function Create(fr As MSForms.Frame) As uiTextBoxEx 24 | Set Create = New uiTextBoxEx 25 | Call Create.protInit(fr) 26 | End Function 27 | 28 | Public Sub Terminate() 29 | Set pWndWordPane.parent = pWndWord 30 | pAppWord.Quit False 31 | DoEvents 32 | End Sub 33 | 34 | 'Obtain the text provided in the word control. 35 | '@returns {String} The text in the word control, note this text is unformatted 36 | Public Property Get Text() As String 37 | Text = pAppWordDoc.Content.Text 38 | End Property 39 | 40 | Public Property Let Text(RHS As String) 41 | 'If the document is protected (i.e., ProtectionType <> wdNoProtection), 42 | 'remove protection, update the text, and then reapply protection 43 | If pSettingsReadOnly And pAppWordDoc.ProtectionType <> -1 Then pAppWordDoc.Unprotect 44 | pAppWordDoc.Content.Text = RHS 45 | If pSettingsReadOnly Then pAppWordDoc.Protect Type:=3 46 | End Property 47 | 48 | 'Get/Set the OpenXML data of the word document. This allows users to save and load formatted text to and from the control. 49 | '@returns {String} OpenXML document containing word data 50 | Public Property Get OpenXML() As String 51 | OpenXML = pAppWordDoc.Content.WordOpenXML 52 | End Property 53 | 54 | 'If the document is protected (i.e., ProtectionType <> wdNoProtection), 55 | 'remove protection, delete the existing content, insert the replacement XML, 56 | 'and then reapply protection 57 | Public Property Let OpenXML(RHS As String) 58 | If pSettingsReadOnly And pAppWordDoc.ProtectionType <> -1 Then pAppWordDoc.Unprotect 59 | With pAppWordDoc.Content 60 | .Delete 61 | pAppWordDoc.Content.InsertXML RHS 62 | End With 63 | If pSettingsReadOnly Then pAppWordDoc.Protect Type:=3 64 | End Property 65 | 66 | Public Property Get ReadOnly() As Boolean 67 | ReadOnly = pSettingsReadOnly 68 | End Property 69 | 70 | 'Applies Read Only protection (Type = wdAllowOnlyReading = 3) 71 | Public Property Let ReadOnly(state As Boolean) 72 | pSettingsReadOnly = state 73 | If state Then 74 | pAppWordDoc.Protect Type:=3 75 | Else 76 | If pAppWordDoc.ProtectionType <> -1 Then pAppWordDoc.Unprotect 77 | End If 78 | End Property 79 | 80 | Friend Sub protInit(fr As MSForms.Frame) 81 | 'Set word control 82 | Set pWndUserformFrame = stdWindow.CreateFromIUnknown(fr) 83 | 84 | 'Set bindings to word 85 | Set pAppWord = CreateObject("Word.Application") 86 | pAppWord.Visible = False 87 | 88 | Set pAppWordDoc = pAppWord.Documents.Add() 89 | 90 | With pAppWord.ActiveWindow 91 | 92 | 'Customise window properties 93 | .View.Type = 6 'webLayout 94 | 95 | 'If the ActiveWindow is in a Maximised state, then the 96 | 'code returns an error for each of the following two lines. 97 | .WindowState = 0 98 | 99 | 'Set width and height to that of the frame 100 | .Width = pWndUserformFrame.Width - 30 101 | .Height = pWndUserformFrame.Height 102 | 103 | .ActivePane.DisplayRulers = False 104 | .ActivePane.View.ShowAll = False 105 | 106 | 'Bind class to ActiveWindow object 107 | Set pWndWord = stdWindow.CreateFromHwnd(.hwnd) 108 | End With 109 | 110 | 'Get window pane object (there is probably is a better way of finding this) 111 | Set pWndWordPane = pWndWord.FindFirst(stdLambda.Create("$1.Caption = """"")) 112 | 113 | 'Bind word pane to frame and set position 114 | With pWndWordPane 115 | 'Set the parent of the word frame to that of the Frame 116 | Set .parent = pWndUserformFrame 117 | 118 | 'Change x, y, width and height 119 | 'Note: changing width and height alters X and Y so alter x and y afterwards 120 | .X = 0 121 | .Y = 0 122 | .Width = pWndUserformFrame.Width 123 | .Height = pWndUserformFrame.Height 124 | 125 | End With 126 | 127 | 'Hide word window 128 | pWndWord.Visible = False 129 | 130 | 'Bind to process 131 | Set pProcWord = stdProcess.CreateFromProcessId(pWndWord.ProcessID) 132 | 133 | 'Focus window 134 | pAppWord.ActiveWindow.Activate 135 | End Sub 136 | 137 | 'Upon termination of the class we need to properly cleanup the word application, as it's still running. 138 | Private Sub Class_Terminate() 139 | 'Force quit process 140 | If Not pProcWord Is Nothing Then 141 | pProcWord.forceQuit 142 | End If 143 | End Sub 144 | -------------------------------------------------------------------------------- /Examples/xlVBA/xlApplication/README.md: -------------------------------------------------------------------------------- 1 | # xlApplication 2 | 3 | This class is `Work In Progress`. 4 | 5 | Initially it's main purpose will be to help obtain various information about the Excel application which is difficult to obtain otherwise. 6 | 7 | Long term the hope is to create a layer over the existing Excel API which is stdVBA complient. 8 | 9 | * `CreateFromApplication` - Creates from an existing instance 10 | * `CreateFromHWND` - Creates from an existing instance via HWND 11 | * `CreateFromAllApplications` - Creates a collection from all existing Excel application instances 12 | * `WIP CreateNewInstance(Optional AccesVBOM = vbYes)` - Create a new instance of Application. Optionally enable VBOM, default yes. 13 | * `WIP Get EditMode`: will return `Undefined`, `Ready`, `Enter`, `Edit`, `Point` dependent on whether the 14 | * `WIP Get VBARuntimeType`: will return `Running`, `Break` or `Stopped`. This ultimately boils down to whether the code is running or not, and can be found ordinarily in the caption of the VBA window, but can be read even while VBA is running (i.e. by another application) 15 | * `WIP Get VBAMode` - a.k.a `EbMode`. Can currently only be run from the instance itself. Returns `true` if the code is 'running' and `false` if not. I.E. This will be true if any code has run, global objects are alive etc. It will only switch back to false when clicking the Stop button. 16 | * `WIP Get VBOM` - returns `stdEnumerator` 17 | * `WIP Get Workbooks` - returns `stdEnumerator>` 18 | * ... -------------------------------------------------------------------------------- /Examples/xlVBA/xlSaveHandler/README.md: -------------------------------------------------------------------------------- 1 | # xlSaveHandler 2 | 3 | Intercepts Excel's "Do you want to save your workbook" message, and raises various events allowing more control over the workbook. 4 | 5 | Events raised: 6 | 7 | * `BeforeShow(obj As xlSaveHandler)` - Before the UI shows 8 | * `AfterShow(obj As xlSaveHandler)` - After the UI shows 9 | * `WorkbookCancelSave()` - After the UI shows, if the user clicked cancel 10 | * `WorkbookBeforeSave()` - After the UI shows, before save is called 11 | * `WorkbookAfterSave()` - After the UI shows, after save is called 12 | * `WorkbookClose()` - Immediately before the workbook is closed. -------------------------------------------------------------------------------- /Examples/xlVBA/xlSaveHandler/src/xlSaveHandler.frm: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} xlSaveHandler 3 | Caption = "Microsoft Excel" 4 | ClientHeight = 1500 5 | ClientLeft = 45 6 | ClientTop = 390 7 | ClientWidth = 6240 8 | OleObjectBlob = "xlSaveHandler.frx":0000 9 | StartUpPosition = 1 'CenterOwner 10 | End 11 | Attribute VB_Name = "xlSaveHandler" 12 | Attribute VB_GlobalNameSpace = False 13 | Attribute VB_Creatable = False 14 | Attribute VB_PredeclaredId = True 15 | Attribute VB_Exposed = False 16 | Private WithEvents pWorkbook As Workbook 17 | Attribute pWorkbook.VB_VarHelpID = -1 18 | Public Event BeforeShow(obj As xlSaveHandler) 19 | Public Event AfterShow(obj As xlSaveHandler) 20 | Public Event WorkbookClose() 21 | Public Event WorkbookCancelSave() 22 | Public Event WorkbookBeforeSave() 23 | Public Event WorkbookAfterSave() 24 | 25 | Public Cancel As Boolean 26 | Public Save As Boolean 27 | Private bClosingAlready As Boolean 28 | 29 | 30 | 31 | Public Function Create(wb As Workbook) As xlSaveHandler 32 | Dim obj As xlSaveHandler 33 | Set obj = New xlSaveHandler 34 | obj.Init wb 35 | Set Create = obj 36 | End Function 37 | Friend Sub Init(wb As Workbook) 38 | Set pWorkbook = wb 39 | End Sub 40 | 41 | 'Button events 42 | Private Sub btnCancel_Click() 43 | Me.Cancel = True 44 | Me.Hide 45 | End Sub 46 | Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) 47 | Me.Cancel = True 48 | Me.Hide 49 | End Sub 50 | 51 | Private Sub btnDontSave_Click() 52 | Me.Cancel = False 53 | Me.Save = False 54 | Me.Hide 55 | End Sub 56 | 57 | Private Sub btnSave_Click() 58 | Me.Cancel = False 59 | Me.Save = True 60 | Me.Hide 61 | End Sub 62 | 63 | Private Sub pWorkbook_BeforeClose(Cancel As Boolean) 64 | If Not bClosingAlready Then 65 | 'Show workbook and raise events either side 66 | RaiseEvent BeforeShow(Me) 67 | Me.labelText = "Want to save your changes to '" & ThisWorkbook.Name & "'?" 68 | Me.Show 69 | RaiseEvent AfterShow(Me) 70 | 71 | 'Always cancel main application dialog 72 | Cancel = True 73 | 74 | 'If cancelled don't raise WorkbookClose event as the workbook is not closing 75 | If Me.Cancel Then 76 | RaiseEvent WorkbookCancelSave 77 | Exit Sub 78 | End If 79 | 80 | 'If me.save is set then save the workbook and call the necessary events 81 | If Me.Save Then 82 | RaiseEvent WorkbookBeforeSave 83 | ThisWorkbook.Save 84 | RaiseEvent WorkbookAfterSave 85 | End If 86 | 87 | 'Raise workbook close event 88 | RaiseEvent WorkbookClose 89 | 90 | 'Close workbook without saving 91 | bClosingAlready = True 92 | ThisWorkbook.Close False 93 | End If 94 | End Sub 95 | -------------------------------------------------------------------------------- /Examples/xlVBA/xlSaveHandler/src/xlSaveHandler.frx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sancarn/stdVBA-examples/693067110385a70a2befba287b4dac91760f6b2b/Examples/xlVBA/xlSaveHandler/src/xlSaveHandler.frx -------------------------------------------------------------------------------- /Examples/xlVBA/xlTableTools/README.md: -------------------------------------------------------------------------------- 1 | # xlTableTools 2 | 3 | Helper functions which can be used in combination with Excel `ListObject` tables. 4 | 5 | ## Setup test 6 | 7 | You can run this setup in order to test the examples in this document. 8 | 9 | ```vb 10 | Sub RunSetup() 11 | Range("A1:A10").value = Application.Transpose(Array("ID", 1, 2, 3, 4, 5, 6, 7, 8, 9)) 12 | Range("B1:D1").value = Array("Score", "Category", "CategoryName") 13 | With ActiveSheet.ListObjects.Add(xlSrcRange, Range("A1:D10"), , xlYes) 14 | .name = "tblMain" 15 | End With 16 | 17 | Range("J1:J4").value = Application.Transpose(Array("ID", "H", "M", "L")) 18 | Range("K1:K4").value = Application.Transpose(Array("Name", "High", "Medium", "Low")) 19 | With ActiveSheet.ListObjects.Add(xlSrcRange, Range("J1:K4"), , xlYes) 20 | .name = "tblCategories" 21 | End With 22 | End Sub 23 | ``` 24 | 25 | ## Example 26 | 27 | The following example will assign values to `Score`, `Category` and `CategoryName` fields of the table. Then if there are any `Category` Highsm, the table will filter to these. 28 | 29 | ```vb 30 | Sub Test() 31 | Dim loCats As ListObject: Set loCats = ActiveSheet.ListObjects("tblCategories") 32 | Dim rels As Collection: Set rels = New Collection 33 | rels.Add CreateRelationship("Category", "Category", loCats, "ID") 34 | 35 | Dim lo As ListObject: Set lo = ActiveSheet.ListObjects("tblMain") 36 | lo.AutoFilter.ShowAllData 37 | 38 | Call updateField(lo, "Score", stdLambda.Create("rnd(1)")) 39 | Call updateField(lo, "Category", stdLambda.CreateMultiline(Array( _ 40 | "if $1.Score < 0.3 then ""L""", _ 41 | "else if $1.Score < 0.7 then ""M""", _ 42 | "else ""H""", _ 43 | "end" _ 44 | ))) 45 | Call updateField(lo, "CategoryName", stdLambda.Create("$1.rels__.Category.Name"), Relationships:=rels) 46 | 47 | Stop 48 | 49 | Call applyFilterToTable(lo, "ID", stdLambda.Create("$1.Category = ""H""")) 50 | End Sub 51 | ``` 52 | 53 | ## Functions 54 | 55 | * `updateFieldConst` - Update a field of a table in Excel to a value. 56 | * `updateField` - Update a field of a table by callback in Excel. 57 | * `CreateRelationship` - Create a relationship object. Links some table's to the `ToTable` where some fields match. 58 | * `applyFilterToTable` - Applies a filter to a table by callback in Excel. The table requires an ID field. -------------------------------------------------------------------------------- /logs/xvba_debug.log: -------------------------------------------------------------------------------- 1 | 2021-12-15 09:04:23 info: XVBA Ribbon Starts 2 | --------------------------------------------------------------------------------