├── README.md ├── cross.md ├── dependencies.md ├── info.json ├── libraries ├── UsefulStuff.vba ├── UsefulStuff_vba.md ├── cStringChunker.cls ├── cStringChunker_cls.md ├── usefulColorStuff.vba ├── usefulColorStuff_vba.md ├── usefulSheetStuff.vba ├── usefulSheetStuff_vba.md ├── usefulStuff.vba └── usefulStuff_vba.md └── scripts ├── cJavaScript.cls ├── cJavaScript_cls.md ├── jscript.vba └── jscript_vba.md /README.md: -------------------------------------------------------------------------------- 1 | # VBA Project: vbaJavaScript 2 | This repo (vbaJavaScript) was automatically created on 6/22/2015 1:30:36 PM by VBAGit.For more information see the [desktop liberation site](https://ramblings.mcpher.com/drive-sdk-and-github/getting-your-apps-scripts-to-github/ "desktop liberation") 3 | you can see [library and dependency information here](dependencies.md) 4 | 5 | To get started with VBA Git, you can either create a workbook with the [code on gitHub](https://github.com/brucemcpherson/VbaGit "VbaGit repo"), or use this premade [VbaBootStrap workbook](https://github.com/brucemcpherson/desktopliberationdownloadable/raw/master/VbaGitBootStrap.xlsm "VbaBootStrap") 6 | 7 | Using this texhnique you can run JavaScript directly off the internet in VBA. See [Integrating JavaScript and VBA ](https://ramblings.mcpher.com/integrating-vba-and-javascript/) 8 | -------------------------------------------------------------------------------- /cross.md: -------------------------------------------------------------------------------- 1 | # VBA Project: vbaJavaScript 2 | This cross reference list for repo (vbaJavaScript) was automatically created on 6/25/2015 10:03:23 AM by VBAGit.For more information see the [desktop liberation site](http://ramblings.mcpher.com/Home/excelquirks/drivesdk/gettinggithubready "desktop liberation") 3 | You can see [library and dependency information here](dependencies.md) 4 | 5 | ###Below is a cross reference showing which modules and procedures reference which others 6 | *module*|*proc*|*referenced by module*|*proc* 7 | ---|---|---|--- 8 | cStringChunker||cJavaScript|removeScriptTags 9 | cStringChunker||cJavaScript|Class_Initialize 10 | usefulColorStuff|compareColors|jscript|jsvsvbaTests 11 | usefulColorStuff|makeColorProps|jscript|comparePerformance 12 | usefulSheetStuff|firstCell|usefulColorStuff|findNearestColorInRange 13 | usefulSheetStuff|fromRadians|usefulColorStuff|rgbToLch 14 | usefulSheetStuff|max|usefulColorStuff|contrastRatio 15 | usefulSheetStuff|max|usefulColorStuff|applyHeatMapToRange 16 | usefulSheetStuff|min|usefulColorStuff|xyzToRgb 17 | usefulSheetStuff|min|usefulColorStuff|rgbToHsv 18 | usefulSheetStuff|min|usefulColorStuff|rgbToHsl 19 | usefulSheetStuff|min|usefulColorStuff|makeColorProps 20 | usefulSheetStuff|toRadians|usefulColorStuff|cieDe2000 21 | usefulSheetStuff|toRadians|usefulColorStuff|lchToLab 22 | usefulStuff|tinyTime|jscript|testGas 23 | usefulStuff|tinyTime|jscript|comparePerformance 24 | -------------------------------------------------------------------------------- /dependencies.md: -------------------------------------------------------------------------------- 1 | # VBA Project: vbaJavaScript 2 | This repo (vbaJavaScript) was automatically created on 6/25/2015 10:03:23 AM by VBAGit.For more information see the [desktop liberation site](https://ramblings.mcpher.com/drive-sdk-and-github/getting-your-apps-scripts-to-github/ "desktop liberation") or [contact me on G+](https://plus.google.com/+BruceMcpherson "Bruce McPherson - GDE") 3 | ## Details for VBA project vbaJavaScript 4 | Where possibile directly referenced or sub referenced library sources have been copied to this repository 5 | ### Modules of vbaJavaScript included in this repo 6 | *name*|*type*|*source*|*docs* 7 | ---|---|---|--- 8 | jscript|StdModule|[jscript.vba](scripts/jscript.vba "script source")|[jscript_vba.md](scripts/jscript_vba.md "script docs") 9 | cJavaScript|ClassModule|[cJavaScript.cls](scripts/cJavaScript.cls "script source")|[cJavaScript_cls.md](scripts/cJavaScript_cls.md "script docs") 10 | 11 | ### All dependencies and sub dependencies in this repo 12 | *name*|*type*|*source*|*docs* 13 | ---|---|---|--- 14 | usefulStuff|StdModule|[usefulStuff.vba](libraries/usefulStuff.vba "library source")|[usefulStuff_vba.md](libraries/usefulStuff_vba.md "library docs") 15 | usefulColorStuff|StdModule|[usefulColorStuff.vba](libraries/usefulColorStuff.vba "library source")|[usefulColorStuff_vba.md](libraries/usefulColorStuff_vba.md "library docs") 16 | cStringChunker|ClassModule|[cStringChunker.cls](libraries/cStringChunker.cls "library source")|[cStringChunker_cls.md](libraries/cStringChunker_cls.md "library docs") 17 | usefulSheetStuff|StdModule|[usefulSheetStuff.vba](libraries/usefulSheetStuff.vba "library source")|[usefulSheetStuff_vba.md](libraries/usefulSheetStuff_vba.md "library docs") 18 | 19 | ###Excel references 20 | ####These references were detected in the workbook (cDataSet.xlsm) this repo was created from. You may not need them all 21 | *name*|*guid*|*major*|*minor*|*description* 22 | ---|---|---|---|--- 23 | VBA|{000204EF-0000-0000-C000-000000000046}|4|2|Visual Basic For Applications 24 | Excel|{00020813-0000-0000-C000-000000000046}|1|8|Microsoft Excel 15.0 Object Library 25 | stdole|{00020430-0000-0000-C000-000000000046}|2|0|OLE Automation 26 | Office|{2DF8D04C-5BFA-101B-BDE5-00AA0044DE52}|2|7|Microsoft Office 15.0 Object Library 27 | VBScript_RegExp_55|{3F4DACA7-160D-11D2-A8E9-00104B365C9F}|5|5|Microsoft VBScript Regular Expressions 5.5 28 | WinHttp|{662901FC-6951-4854-9EB2-D9A2570F2B2E}|5|1|Microsoft WinHTTP Services, version 5.1 29 | SHDocVw|{EAB22AC0-30C1-11CF-A7EB-0000C05BAE0B}|1|1|Microsoft Internet Controls 30 | MSHTML|{3050F1C5-98B5-11CF-BB82-00AA00BDCE0B}|4|0|Microsoft HTML Object Library 31 | MSForms|{0D452EE1-E08F-101A-852E-02608C4D0BB4}|2|0|Microsoft Forms 2.0 Object Library 32 | MSXML2|{F5078F18-C551-11D3-89B9-0000F81FE221}|6|0|Microsoft XML, v6.0 33 | MSComctlLib|{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}|2|1|Microsoft Windows Common Controls 6.0 (SP6) 34 | VBIDE|{0002E157-0000-0000-C000-000000000046}|5|3|Microsoft Visual Basic for Applications Extensibility 5.3 35 | ADODB|{2A75196C-D9EB-4129-B803-931327F72D5C}|2|8|Microsoft ActiveX Data Objects 2.8 Library 36 | ADOR|{00000300-0000-0010-8000-00AA006D2EA4}|2|8|Microsoft ActiveX Data Objects Recordset 2.8 Library 37 | MSScriptControl|{0E59F1D2-1FBE-11D0-8FF2-00A0D10038BC}|1|0|Microsoft Script Control 1.0 38 | 39 | 40 | You can see [full project info as json here](info.json) 41 | -------------------------------------------------------------------------------- /info.json: -------------------------------------------------------------------------------- 1 | {"title":"vbaJavaScript","committedDate":0,"createdDate":1435226601000,"modifiedDate":1435226603000,"version":"0.2.4","noticed":1435226601000,"extract":"c:/users/bruce/documents/gas/Extraction/Scripts/vbaJavaScript/","fileName":"info.json","fileId":"c:/users/bruce/documents/gas/Extraction/Scripts/vbaJavaScript/info.json","modules":[{"name":"jscript","type":"StdModule","folder":"c:/users/bruce/documents/gas/Extraction/Scripts/vbaJavaScript/scripts/","id":"c:/users/bruce/documents/gas/Extraction/Scripts/vbaJavaScript/scripts/jscript.vba","fileName":"jscript.vba","docsName":"jscript_vba.md","docsId":"c:/users/bruce/documents/gas/Extraction/Scripts/vbaJavaScript/scripts/jscript_vba.md"},{"name":"cJavaScript","type":"ClassModule","folder":"c:/users/bruce/documents/gas/Extraction/Scripts/vbaJavaScript/scripts/","id":"c:/users/bruce/documents/gas/Extraction/Scripts/vbaJavaScript/scripts/cJavaScript.cls","fileName":"cJavaScript.cls","docsName":"cJavaScript_cls.md","docsId":"c:/users/bruce/documents/gas/Extraction/Scripts/vbaJavaScript/scripts/cJavaScript_cls.md"} ],"extracted":true,"repo":"vbaJavaScript","dependencies":[{"name":"usefulStuff","type":"StdModule","folder":"c:/users/bruce/documents/gas/Extraction/Scripts/vbaJavaScript/libraries/","id":"c:/users/bruce/documents/gas/Extraction/Scripts/vbaJavaScript/libraries/usefulStuff.vba","fileName":"usefulStuff.vba","docsName":"usefulStuff_vba.md","docsId":"c:/users/bruce/documents/gas/Extraction/Scripts/vbaJavaScript/libraries/usefulStuff_vba.md"},{"name":"usefulColorStuff","type":"StdModule","folder":"c:/users/bruce/documents/gas/Extraction/Scripts/vbaJavaScript/libraries/","id":"c:/users/bruce/documents/gas/Extraction/Scripts/vbaJavaScript/libraries/usefulColorStuff.vba","fileName":"usefulColorStuff.vba","docsName":"usefulColorStuff_vba.md","docsId":"c:/users/bruce/documents/gas/Extraction/Scripts/vbaJavaScript/libraries/usefulColorStuff_vba.md"},{"name":"cStringChunker","type":"ClassModule","folder":"c:/users/bruce/documents/gas/Extraction/Scripts/vbaJavaScript/libraries/","id":"c:/users/bruce/documents/gas/Extraction/Scripts/vbaJavaScript/libraries/cStringChunker.cls","fileName":"cStringChunker.cls","docsName":"cStringChunker_cls.md","docsId":"c:/users/bruce/documents/gas/Extraction/Scripts/vbaJavaScript/libraries/cStringChunker_cls.md"},{"name":"usefulSheetStuff","type":"StdModule","folder":"c:/users/bruce/documents/gas/Extraction/Scripts/vbaJavaScript/libraries/","id":"c:/users/bruce/documents/gas/Extraction/Scripts/vbaJavaScript/libraries/usefulSheetStuff.vba","fileName":"usefulSheetStuff.vba","docsName":"usefulSheetStuff_vba.md","docsId":"c:/users/bruce/documents/gas/Extraction/Scripts/vbaJavaScript/libraries/usefulSheetStuff_vba.md"} ],"excelReferences":[{"name":"VBA","guid":"{000204EF-0000-0000-C000-000000000046}","major":4,"minor":2,"description":"Visual Basic For Applications"},{"name":"Excel","guid":"{00020813-0000-0000-C000-000000000046}","major":1,"minor":8,"description":"Microsoft Excel 15.0 Object Library"},{"name":"stdole","guid":"{00020430-0000-0000-C000-000000000046}","major":2,"minor":0,"description":"OLE Automation"},{"name":"Office","guid":"{2DF8D04C-5BFA-101B-BDE5-00AA0044DE52}","major":2,"minor":7,"description":"Microsoft Office 15.0 Object Library"},{"name":"VBScript_RegExp_55","guid":"{3F4DACA7-160D-11D2-A8E9-00104B365C9F}","major":5,"minor":5,"description":"Microsoft VBScript Regular Expressions 5.5"},{"name":"WinHttp","guid":"{662901FC-6951-4854-9EB2-D9A2570F2B2E}","major":5,"minor":1,"description":"Microsoft WinHTTP Services, version 5.1"},{"name":"SHDocVw","guid":"{EAB22AC0-30C1-11CF-A7EB-0000C05BAE0B}","major":1,"minor":1,"description":"Microsoft Internet Controls"},{"name":"MSHTML","guid":"{3050F1C5-98B5-11CF-BB82-00AA00BDCE0B}","major":4,"minor":0,"description":"Microsoft HTML Object Library"},{"name":"MSForms","guid":"{0D452EE1-E08F-101A-852E-02608C4D0BB4}","major":2,"minor":0,"description":"Microsoft Forms 2.0 Object Library"},{"name":"MSXML2","guid":"{F5078F18-C551-11D3-89B9-0000F81FE221}","major":6,"minor":0,"description":"Microsoft XML, v6.0"},{"name":"MSComctlLib","guid":"{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}","major":2,"minor":1,"description":"Microsoft Windows Common Controls 6.0 (SP6)"},{"name":"VBIDE","guid":"{0002E157-0000-0000-C000-000000000046}","major":5,"minor":3,"description":"Microsoft Visual Basic for Applications Extensibility 5.3"},{"name":"ADODB","guid":"{2A75196C-D9EB-4129-B803-931327F72D5C}","major":2,"minor":8,"description":"Microsoft ActiveX Data Objects 2.8 Library"},{"name":"ADOR","guid":"{00000300-0000-0010-8000-00AA006D2EA4}","major":2,"minor":8,"description":"Microsoft ActiveX Data Objects Recordset 2.8 Library"},{"name":"MSScriptControl","guid":"{0E59F1D2-1FBE-11D0-8FF2-00A0D10038BC}","major":1,"minor":0,"description":"Microsoft Script Control 1.0"} ],"readmeFileId":"c:/users/bruce/documents/gas/Extraction/Scripts/vbaJavaScript/README.md","dependenciesFileId":"c:/users/bruce/documents/gas/Extraction/Scripts/vbaJavaScript/dependencies.md","crossFileId":"c:/users/bruce/documents/gas/Extraction/Scripts/vbaJavaScript/cross.md"} -------------------------------------------------------------------------------- /libraries/UsefulStuff_vba.md: -------------------------------------------------------------------------------- 1 | # VBA Project: **vbaJavaScript** 2 | ## VBA Module: **[UsefulStuff](/libraries/UsefulStuff.vba "source is here")** 3 | ### Type: StdModule 4 | 5 | This procedure list for repo (vbaJavaScript) was automatically created on 6/23/2015 1:44:19 PM by VBAGit. 6 | For more information see the [desktop liberation site](http://ramblings.mcpher.com/Home/excelquirks/drivesdk/gettinggithubready "desktop liberation") 7 | 8 | Below is a section for each procedure in UsefulStuff 9 | 10 | --- 11 | VBA Procedure: **nameExists** 12 | Type: **Function** 13 | Returns: **name** 14 | Return description: **** 15 | Scope: **Public** 16 | Description: **** 17 | 18 | *Public Function nameExists(s As String) As name* 19 | 20 | *name*|*type*|*optional*|*default*|*description* 21 | ---|---|---|---|--- 22 | s|String|False|| 23 | 24 | 25 | --- 26 | VBA Procedure: **whereIsThis** 27 | Type: **Function** 28 | Returns: **Range** 29 | Return description: **** 30 | Scope: **Public** 31 | Description: **** 32 | 33 | *Public Function whereIsThis(r As Variant) As Range* 34 | 35 | *name*|*type*|*optional*|*default*|*description* 36 | ---|---|---|---|--- 37 | r|Variant|False|| 38 | 39 | 40 | --- 41 | VBA Procedure: **OpenUrl** 42 | Type: **Function** 43 | Returns: **Boolean** 44 | Return description: **** 45 | Scope: **Public** 46 | Description: **** 47 | 48 | *Public Function OpenUrl(url) As Boolean* 49 | 50 | *name*|*type*|*optional*|*default*|*description* 51 | ---|---|---|---|--- 52 | url|Variant|False|| 53 | 54 | 55 | --- 56 | VBA Procedure: **firstCell** 57 | Type: **Function** 58 | Returns: **Range** 59 | Return description: **** 60 | Scope: **Public** 61 | Description: **** 62 | 63 | *Function firstCell(inrange As Range) As Range* 64 | 65 | *name*|*type*|*optional*|*default*|*description* 66 | ---|---|---|---|--- 67 | inrange|Range|False|| 68 | 69 | 70 | --- 71 | VBA Procedure: **lastCell** 72 | Type: **Function** 73 | Returns: **Range** 74 | Return description: **** 75 | Scope: **Public** 76 | Description: **** 77 | 78 | *Function lastCell(inrange As Range) As Range* 79 | 80 | *name*|*type*|*optional*|*default*|*description* 81 | ---|---|---|---|--- 82 | inrange|Range|False|| 83 | 84 | 85 | --- 86 | VBA Procedure: **isSheet** 87 | Type: **Function** 88 | Returns: **Boolean** 89 | Return description: **** 90 | Scope: **Public** 91 | Description: **** 92 | 93 | *Function isSheet(o As Object) As Boolean* 94 | 95 | *name*|*type*|*optional*|*default*|*description* 96 | ---|---|---|---|--- 97 | o|Object|False|| 98 | 99 | 100 | --- 101 | VBA Procedure: **findShape** 102 | Type: **Function** 103 | Returns: **shape** 104 | Return description: **** 105 | Scope: **Public** 106 | Description: **** 107 | 108 | *Public Function findShape(sName As String, Optional ws As Worksheet = Nothing) As shape* 109 | 110 | *name*|*type*|*optional*|*default*|*description* 111 | ---|---|---|---|--- 112 | sName|String|False|| 113 | ws|Worksheet|True| Nothing| 114 | 115 | 116 | --- 117 | VBA Procedure: **findRecurse** 118 | Type: **Function** 119 | Returns: **shape** 120 | Return description: **** 121 | Scope: **Public** 122 | Description: **** 123 | 124 | *Public Function findRecurse(target As String, co As GroupShapes) As shape* 125 | 126 | *name*|*type*|*optional*|*default*|*description* 127 | ---|---|---|---|--- 128 | target|String|False|| 129 | co|GroupShapes|False|| 130 | 131 | 132 | --- 133 | VBA Procedure: **clearHyperLinks** 134 | Type: **Sub** 135 | Returns: **void** 136 | Return description: **** 137 | Scope: **Public** 138 | Description: **** 139 | 140 | *Public Sub clearHyperLinks(ws As Worksheet)* 141 | 142 | *name*|*type*|*optional*|*default*|*description* 143 | ---|---|---|---|--- 144 | ws|Worksheet|False|| 145 | 146 | 147 | --- 148 | VBA Procedure: **sheetExists** 149 | Type: **Function** 150 | Returns: **Worksheet** 151 | Return description: **** 152 | Scope: **Public** 153 | Description: **** 154 | 155 | *Function sheetExists(sName As String, Optional complain As Boolean = True) As Worksheet* 156 | 157 | *name*|*type*|*optional*|*default*|*description* 158 | ---|---|---|---|--- 159 | sName|String|False|| 160 | complain|Boolean|True| True| 161 | 162 | 163 | --- 164 | VBA Procedure: **wholeSheet** 165 | Type: **Function** 166 | Returns: **Range** 167 | Return description: **** 168 | Scope: **Public** 169 | Description: **** 170 | 171 | *Function wholeSheet(wn As String) As Range* 172 | 173 | *name*|*type*|*optional*|*default*|*description* 174 | ---|---|---|---|--- 175 | wn|String|False|| 176 | 177 | 178 | --- 179 | VBA Procedure: **wholeWs** 180 | Type: **Function** 181 | Returns: **Range** 182 | Return description: **** 183 | Scope: **Public** 184 | Description: **** 185 | 186 | *Function wholeWs(ws As Worksheet) As Range* 187 | 188 | *name*|*type*|*optional*|*default*|*description* 189 | ---|---|---|---|--- 190 | ws|Worksheet|False|| 191 | 192 | 193 | --- 194 | VBA Procedure: **wholeRange** 195 | Type: **Function** 196 | Returns: **Range** 197 | Return description: **** 198 | Scope: **Public** 199 | Description: **** 200 | 201 | *Function wholeRange(r As Range) As Range* 202 | 203 | *name*|*type*|*optional*|*default*|*description* 204 | ---|---|---|---|--- 205 | r|Range|False|| 206 | 207 | 208 | --- 209 | VBA Procedure: **cleanFind** 210 | Type: **Function** 211 | Returns: **Range** 212 | Return description: **** 213 | Scope: **Public** 214 | Description: **** 215 | 216 | *Function cleanFind(x As Variant, r As Range, Optional complain As Boolean = False, Optional singlecell As Boolean = False) As Range* 217 | 218 | *name*|*type*|*optional*|*default*|*description* 219 | ---|---|---|---|--- 220 | x|Variant|False|| 221 | r|Range|False|| 222 | complain|Boolean|True| False| 223 | singlecell|Boolean|True| False| 224 | 225 | 226 | --- 227 | VBA Procedure: **msglost** 228 | Type: **Sub** 229 | Returns: **void** 230 | Return description: **** 231 | Scope: **Public** 232 | Description: **** 233 | 234 | *Sub msglost(x As Variant, r As Range, Optional extra As String = "")* 235 | 236 | *name*|*type*|*optional*|*default*|*description* 237 | ---|---|---|---|--- 238 | x|Variant|False|| 239 | r|Range|False|| 240 | extra|String|True| ""| 241 | 242 | 243 | --- 244 | VBA Procedure: **SAd** 245 | Type: **Function** 246 | Returns: **String** 247 | Return description: **** 248 | Scope: **Public** 249 | Description: **** 250 | 251 | *Function SAd(rngIn As Range, Optional target As Range = Nothing, Optional singlecell As Boolean = False, Optional removeRowDollar As Boolean = False, Optional removeColDollar As Boolean = False) As String* 252 | 253 | *name*|*type*|*optional*|*default*|*description* 254 | ---|---|---|---|--- 255 | rngIn|Range|False|| 256 | target|Range|True| Nothing| 257 | singlecell|Boolean|True| False| 258 | removeRowDollar|Boolean|True| False| 259 | removeColDollar|Boolean|True| False| 260 | 261 | 262 | --- 263 | VBA Procedure: **SAdOneRange** 264 | Type: **Function** 265 | Returns: **String** 266 | Return description: **** 267 | Scope: **Public** 268 | Description: **** 269 | 270 | *Function SAdOneRange(rngIn As Range, Optional target As Range = Nothing, Optional singlecell As Boolean = False, Optional removeRowDollar As Boolean = False, Optional removeColDollar As Boolean = False) As String* 271 | 272 | *name*|*type*|*optional*|*default*|*description* 273 | ---|---|---|---|--- 274 | rngIn|Range|False|| 275 | target|Range|True| Nothing| 276 | singlecell|Boolean|True| False| 277 | removeRowDollar|Boolean|True| False| 278 | removeColDollar|Boolean|True| False| 279 | 280 | 281 | --- 282 | VBA Procedure: **AddressNoDollars** 283 | Type: **Function** 284 | Returns: **String** 285 | Return description: **** 286 | Scope: **Public** 287 | Description: **** 288 | 289 | *Function AddressNoDollars(a As Range, Optional doRow As Boolean = True, Optional doColumn As Boolean = True) As String* 290 | 291 | *name*|*type*|*optional*|*default*|*description* 292 | ---|---|---|---|--- 293 | a|Range|False|| 294 | doRow|Boolean|True| True| 295 | doColumn|Boolean|True| True| 296 | 297 | 298 | --- 299 | VBA Procedure: **isReallyEmpty** 300 | Type: **Function** 301 | Returns: **Boolean** 302 | Return description: **** 303 | Scope: **Public** 304 | Description: **** 305 | 306 | *Function isReallyEmpty(r As Range) As Boolean* 307 | 308 | *name*|*type*|*optional*|*default*|*description* 309 | ---|---|---|---|--- 310 | r|Range|False|| 311 | 312 | 313 | --- 314 | VBA Procedure: **toEmptyRow** 315 | Type: **Function** 316 | Returns: **Range** 317 | Return description: **** 318 | Scope: **Public** 319 | Description: **** 320 | 321 | *Function toEmptyRow(r As Range) As Range* 322 | 323 | *name*|*type*|*optional*|*default*|*description* 324 | ---|---|---|---|--- 325 | r|Range|False|| 326 | 327 | 328 | --- 329 | VBA Procedure: **toEmptyCol** 330 | Type: **Function** 331 | Returns: **Range** 332 | Return description: **** 333 | Scope: **Public** 334 | Description: **** 335 | 336 | *Function toEmptyCol(r As Range) As Range* 337 | 338 | *name*|*type*|*optional*|*default*|*description* 339 | ---|---|---|---|--- 340 | r|Range|False|| 341 | 342 | 343 | --- 344 | VBA Procedure: **toEmptyBox** 345 | Type: **Function** 346 | Returns: **Range** 347 | Return description: **** 348 | Scope: **Public** 349 | Description: **** 350 | 351 | *Function toEmptyBox(r As Range) As Range* 352 | 353 | *name*|*type*|*optional*|*default*|*description* 354 | ---|---|---|---|--- 355 | r|Range|False|| 356 | 357 | 358 | --- 359 | VBA Procedure: **getLikelyColumnRange** 360 | Type: **Function** 361 | Returns: **Range** 362 | Return description: **** 363 | Scope: **Public** 364 | Description: **** 365 | 366 | *Public Function getLikelyColumnRange(Optional ws As Worksheet = Nothing) As Range* 367 | 368 | *name*|*type*|*optional*|*default*|*description* 369 | ---|---|---|---|--- 370 | ws|Worksheet|True| Nothing| 371 | 372 | 373 | --- 374 | VBA Procedure: **deleteAllFromCollection** 375 | Type: **Sub** 376 | Returns: **void** 377 | Return description: **** 378 | Scope: **Public** 379 | Description: **** 380 | 381 | *Sub deleteAllFromCollection(co As Collection)* 382 | 383 | *name*|*type*|*optional*|*default*|*description* 384 | ---|---|---|---|--- 385 | co|Collection|False|| 386 | 387 | 388 | --- 389 | VBA Procedure: **deleteAllShapes** 390 | Type: **Sub** 391 | Returns: **void** 392 | Return description: **** 393 | Scope: **Public** 394 | Description: **** 395 | 396 | *Sub deleteAllShapes(r As Range, startingwith As String)* 397 | 398 | *name*|*type*|*optional*|*default*|*description* 399 | ---|---|---|---|--- 400 | r|Range|False|| 401 | startingwith|String|False|| 402 | 403 | 404 | --- 405 | VBA Procedure: **makearangeofShapes** 406 | Type: **Function** 407 | Returns: **ShapeRange** 408 | Return description: **** 409 | Scope: **Public** 410 | Description: **** 411 | 412 | *Function makearangeofShapes(r As Range, startingwith As String) As ShapeRange* 413 | 414 | *name*|*type*|*optional*|*default*|*description* 415 | ---|---|---|---|--- 416 | r|Range|False|| 417 | startingwith|String|False|| 418 | 419 | 420 | --- 421 | VBA Procedure: **UTF16To8** 422 | Type: **Function** 423 | Returns: **String** 424 | Return description: **** 425 | Scope: **Public** 426 | Description: **** 427 | 428 | *Public Function UTF16To8(ByVal UTF16 As String) As String* 429 | 430 | *name*|*type*|*optional*|*default*|*description* 431 | ---|---|---|---|--- 432 | ByVal|String|False|| 433 | 434 | 435 | --- 436 | VBA Procedure: **URLEncode** 437 | Type: **Function** 438 | Returns: **String** 439 | Return description: **** 440 | Scope: **Public** 441 | Description: **** 442 | 443 | *Public Function URLEncode( StringVal As String, Optional SpaceAsPlus As Boolean = False, Optional UTF8Encode As Boolean = True ) As String* 444 | 445 | *name*|*type*|*optional*|*default*|*description* 446 | ---|---|---|---|--- 447 | StringVal|String|False|| 448 | SpaceAsPlus|Boolean|True| False| 449 | UTF8Encode|Boolean|True| True| 450 | 451 | 452 | --- 453 | VBA Procedure: **cloneFormat** 454 | Type: **Sub** 455 | Returns: **void** 456 | Return description: **** 457 | Scope: **Public** 458 | Description: **** 459 | 460 | *Public Sub cloneFormat(b As Range, a As Range)* 461 | 462 | *name*|*type*|*optional*|*default*|*description* 463 | ---|---|---|---|--- 464 | b|Range|False|| 465 | a|Range|False|| 466 | 467 | 468 | --- 469 | VBA Procedure: **SortColl** 470 | Type: **Function** 471 | Returns: **Long** 472 | Return description: **** 473 | Scope: **Public** 474 | Description: **** 475 | 476 | *Function SortColl(ByRef coll As Collection, eorder As Long) As Long* 477 | 478 | *name*|*type*|*optional*|*default*|*description* 479 | ---|---|---|---|--- 480 | ByRef|Collection|False|| 481 | eorder|Long|False|| 482 | 483 | 484 | --- 485 | VBA Procedure: **getHandle** 486 | Type: **Function** 487 | Returns: **Integer** 488 | Return description: **** 489 | Scope: **Public** 490 | Description: **** 491 | 492 | *Public Function getHandle(sName As String, Optional readOnly As Boolean = False) As Integer* 493 | 494 | *name*|*type*|*optional*|*default*|*description* 495 | ---|---|---|---|--- 496 | sName|String|False|| 497 | readOnly|Boolean|True| False| 498 | 499 | 500 | --- 501 | VBA Procedure: **afConcat** 502 | Type: **Function** 503 | Returns: **String** 504 | Return description: **** 505 | Scope: **Public** 506 | Description: **** 507 | 508 | *Function afConcat(arr() As Variant) As String* 509 | 510 | *name*|*type*|*optional*|*default*|*description* 511 | ---|---|---|---|--- 512 | arr|Variant|False|| 513 | 514 | 515 | --- 516 | VBA Procedure: **quote** 517 | Type: **Function** 518 | Returns: **String** 519 | Return description: **** 520 | Scope: **Public** 521 | Description: **** 522 | 523 | *Public Function quote(s As String) As String* 524 | 525 | *name*|*type*|*optional*|*default*|*description* 526 | ---|---|---|---|--- 527 | s|String|False|| 528 | 529 | 530 | --- 531 | VBA Procedure: **q** 532 | Type: **Function** 533 | Returns: **String** 534 | Return description: **** 535 | Scope: **Public** 536 | Description: **** 537 | 538 | *Public Function q() As String* 539 | 540 | **no arguments required for this procedure** 541 | 542 | 543 | --- 544 | VBA Procedure: **qs** 545 | Type: **Function** 546 | Returns: **String** 547 | Return description: **** 548 | Scope: **Public** 549 | Description: **** 550 | 551 | *Public Function qs() As String* 552 | 553 | **no arguments required for this procedure** 554 | 555 | 556 | --- 557 | VBA Procedure: **bracket** 558 | Type: **Function** 559 | Returns: **String** 560 | Return description: **** 561 | Scope: **Public** 562 | Description: **** 563 | 564 | *Public Function bracket(s As String) As String* 565 | 566 | *name*|*type*|*optional*|*default*|*description* 567 | ---|---|---|---|--- 568 | s|String|False|| 569 | 570 | 571 | --- 572 | VBA Procedure: **list** 573 | Type: **Function** 574 | Returns: **String** 575 | Return description: **** 576 | Scope: **Public** 577 | Description: **** 578 | 579 | *Public Function list(ParamArray args() As Variant) As String* 580 | 581 | *name*|*type*|*optional*|*default*|*description* 582 | ---|---|---|---|--- 583 | ParamArray|Variant|False|| 584 | 585 | 586 | --- 587 | VBA Procedure: **qlist** 588 | Type: **Function** 589 | Returns: **String** 590 | Return description: **** 591 | Scope: **Public** 592 | Description: **** 593 | 594 | *Public Function qlist(ParamArray args() As Variant) As String* 595 | 596 | *name*|*type*|*optional*|*default*|*description* 597 | ---|---|---|---|--- 598 | ParamArray|Variant|False|| 599 | 600 | 601 | --- 602 | VBA Procedure: **diminishingReturn** 603 | Type: **Function** 604 | Returns: **Double** 605 | Return description: **** 606 | Scope: **Public** 607 | Description: **** 608 | 609 | *Public Function diminishingReturn(val As Double, Optional s As Double = 10) As Double* 610 | 611 | *name*|*type*|*optional*|*default*|*description* 612 | ---|---|---|---|--- 613 | val|Double|False|| 614 | s|Double|True| 10| 615 | 616 | 617 | --- 618 | VBA Procedure: **pivotCacheRefreshAll** 619 | Type: **Sub** 620 | Returns: **void** 621 | Return description: **** 622 | Scope: **Public** 623 | Description: **** 624 | 625 | *Sub pivotCacheRefreshAll()* 626 | 627 | **no arguments required for this procedure** 628 | 629 | 630 | --- 631 | VBA Procedure: **makeKey** 632 | Type: **Function** 633 | Returns: **String** 634 | Return description: **** 635 | Scope: **Public** 636 | Description: **** 637 | 638 | *Public Function makeKey(v As Variant) As String* 639 | 640 | *name*|*type*|*optional*|*default*|*description* 641 | ---|---|---|---|--- 642 | v|Variant|False|| 643 | 644 | 645 | --- 646 | VBA Procedure: **Base64Encode** 647 | Type: **Function** 648 | Returns: **Variant** 649 | Return description: **** 650 | Scope: **Public** 651 | Description: **** 652 | 653 | *Function Base64Encode(sText)* 654 | 655 | *name*|*type*|*optional*|*default*|*description* 656 | ---|---|---|---|--- 657 | sText|Variant|False|| 658 | 659 | 660 | --- 661 | VBA Procedure: **Stream_StringToBinary** 662 | Type: **Function** 663 | Returns: **Variant** 664 | Return description: **** 665 | Scope: **Public** 666 | Description: **** 667 | 668 | *Function Stream_StringToBinary(Text)* 669 | 670 | *name*|*type*|*optional*|*default*|*description* 671 | ---|---|---|---|--- 672 | Text|Variant|False|| 673 | 674 | 675 | --- 676 | VBA Procedure: **Stream_BinaryToString** 677 | Type: **Function** 678 | Returns: **Variant** 679 | Return description: **** 680 | Scope: **Public** 681 | Description: **** 682 | 683 | *Function Stream_BinaryToString(Binary)* 684 | 685 | *name*|*type*|*optional*|*default*|*description* 686 | ---|---|---|---|--- 687 | Binary|Variant|False|| 688 | 689 | 690 | --- 691 | VBA Procedure: **Base64Decode** 692 | Type: **Function** 693 | Returns: **Variant** 694 | Return description: **** 695 | Scope: **Public** 696 | Description: **** 697 | 698 | *Function Base64Decode(ByVal base64String)* 699 | 700 | *name*|*type*|*optional*|*default*|*description* 701 | ---|---|---|---|--- 702 | ByVal|Variant|False|| 703 | 704 | 705 | --- 706 | VBA Procedure: **openNewHtml** 707 | Type: **Function** 708 | Returns: **Boolean** 709 | Return description: **** 710 | Scope: **Public** 711 | Description: **** 712 | 713 | *Public Function openNewHtml(sName As String, sContent As String) As Boolean* 714 | 715 | *name*|*type*|*optional*|*default*|*description* 716 | ---|---|---|---|--- 717 | sName|String|False|| 718 | sContent|String|False|| 719 | 720 | 721 | --- 722 | VBA Procedure: **readFromFile** 723 | Type: **Function** 724 | Returns: **String** 725 | Return description: **** 726 | Scope: **Public** 727 | Description: **** 728 | 729 | *Public Function readFromFile(sName As String) As String* 730 | 731 | *name*|*type*|*optional*|*default*|*description* 732 | ---|---|---|---|--- 733 | sName|String|False|| 734 | 735 | 736 | --- 737 | VBA Procedure: **arrayLength** 738 | Type: **Function** 739 | Returns: **Long** 740 | Return description: **** 741 | Scope: **Public** 742 | Description: **** 743 | 744 | *Public Function arrayLength(a) As Long* 745 | 746 | *name*|*type*|*optional*|*default*|*description* 747 | ---|---|---|---|--- 748 | a|Variant|False|| 749 | 750 | 751 | --- 752 | VBA Procedure: **getControlValue** 753 | Type: **Function** 754 | Returns: **Variant** 755 | Return description: **** 756 | Scope: **Public** 757 | Description: **** 758 | 759 | *Public Function getControlValue(ctl As Object) As Variant* 760 | 761 | *name*|*type*|*optional*|*default*|*description* 762 | ---|---|---|---|--- 763 | ctl|Object|False|| 764 | 765 | 766 | --- 767 | VBA Procedure: **setControlValue** 768 | Type: **Function** 769 | Returns: **Variant** 770 | Return description: **** 771 | Scope: **Public** 772 | Description: **** 773 | 774 | *Public Function setControlValue(ctl As Object, v As Variant) As Variant* 775 | 776 | *name*|*type*|*optional*|*default*|*description* 777 | ---|---|---|---|--- 778 | ctl|Object|False|| 779 | v|Variant|False|| 780 | 781 | 782 | --- 783 | VBA Procedure: **isinCollection** 784 | Type: **Function** 785 | Returns: **Boolean** 786 | Return description: **** 787 | Scope: **Public** 788 | Description: **** 789 | 790 | *Public Function isinCollection(vCollect As Variant, sid As Variant) As Boolean* 791 | 792 | *name*|*type*|*optional*|*default*|*description* 793 | ---|---|---|---|--- 794 | vCollect|Variant|False|| 795 | sid|Variant|False|| 796 | 797 | 798 | --- 799 | VBA Procedure: **getLatFromDistance** 800 | Type: **Function** 801 | Returns: **Double** 802 | Return description: **** 803 | Scope: **Public** 804 | Description: **** 805 | 806 | *Public Function getLatFromDistance(mLat As Double, d As Double, heading As Double) As Double* 807 | 808 | *name*|*type*|*optional*|*default*|*description* 809 | ---|---|---|---|--- 810 | mLat|Double|False|| 811 | d|Double|False|| 812 | heading|Double|False|| 813 | 814 | 815 | --- 816 | VBA Procedure: **getLonFromDistance** 817 | Type: **Function** 818 | Returns: **Double** 819 | Return description: **** 820 | Scope: **Public** 821 | Description: **** 822 | 823 | *Public Function getLonFromDistance(mLat As Double, mLon As Double, d As Double, heading As Double) As Double* 824 | 825 | *name*|*type*|*optional*|*default*|*description* 826 | ---|---|---|---|--- 827 | mLat|Double|False|| 828 | mLon|Double|False|| 829 | d|Double|False|| 830 | heading|Double|False|| 831 | 832 | 833 | --- 834 | VBA Procedure: **earthRadius** 835 | Type: **Function** 836 | Returns: **Double** 837 | Return description: **** 838 | Scope: **Public** 839 | Description: **** 840 | 841 | *Public Function earthRadius() As Double* 842 | 843 | **no arguments required for this procedure** 844 | 845 | 846 | --- 847 | VBA Procedure: **toRadians** 848 | Type: **Function** 849 | Returns: **Variant** 850 | Return description: **** 851 | Scope: **Public** 852 | Description: **** 853 | 854 | *Public Function toRadians(deg)* 855 | 856 | *name*|*type*|*optional*|*default*|*description* 857 | ---|---|---|---|--- 858 | deg|Variant|False|| 859 | 860 | 861 | --- 862 | VBA Procedure: **fromRadians** 863 | Type: **Function** 864 | Returns: **Double** 865 | Return description: **** 866 | Scope: **Public** 867 | Description: **** 868 | 869 | *Public Function fromRadians(rad) As Double* 870 | 871 | *name*|*type*|*optional*|*default*|*description* 872 | ---|---|---|---|--- 873 | rad|Variant|False|| 874 | 875 | 876 | --- 877 | VBA Procedure: **dimensionCount** 878 | Type: **Function** 879 | Returns: **Long** 880 | Return description: **** 881 | Scope: **Public** 882 | Description: **** 883 | 884 | *Public Function dimensionCount(a As Variant) As Long* 885 | 886 | *name*|*type*|*optional*|*default*|*description* 887 | ---|---|---|---|--- 888 | a|Variant|False|| 889 | 890 | 891 | --- 892 | VBA Procedure: **min** 893 | Type: **Function** 894 | Returns: **Variant** 895 | Return description: **** 896 | Scope: **Public** 897 | Description: **** 898 | 899 | *Public Function min(ParamArray args() As Variant)* 900 | 901 | *name*|*type*|*optional*|*default*|*description* 902 | ---|---|---|---|--- 903 | ParamArray|Variant|False|| 904 | 905 | 906 | --- 907 | VBA Procedure: **max** 908 | Type: **Function** 909 | Returns: **Variant** 910 | Return description: **** 911 | Scope: **Public** 912 | Description: **** 913 | 914 | *Public Function max(ParamArray args() As Variant)* 915 | 916 | *name*|*type*|*optional*|*default*|*description* 917 | ---|---|---|---|--- 918 | ParamArray|Variant|False|| 919 | 920 | 921 | --- 922 | VBA Procedure: **encloseTag** 923 | Type: **Function** 924 | Returns: **String** 925 | Return description: **** 926 | Scope: **Public** 927 | Description: **** 928 | 929 | *Public Function encloseTag(tag As String, Optional newLine As Boolean = True, Optional tClass As String = vbNullString, Optional args As Variant) As String* 930 | 931 | *name*|*type*|*optional*|*default*|*description* 932 | ---|---|---|---|--- 933 | tag|String|False|| 934 | newLine|Boolean|True| True| 935 | tClass|String|True| vbNullString| 936 | args|Variant|True|| 937 | 938 | 939 | --- 940 | VBA Procedure: **scrollHack** 941 | Type: **Function** 942 | Returns: **String** 943 | Return description: **** 944 | Scope: **Public** 945 | Description: **** 946 | 947 | *Public Function scrollHack() As String* 948 | 949 | **no arguments required for this procedure** 950 | 951 | 952 | --- 953 | VBA Procedure: **escapeify** 954 | Type: **Function** 955 | Returns: **String** 956 | Return description: **** 957 | Scope: **Public** 958 | Description: **** 959 | 960 | *Public Function escapeify(s As String) As String* 961 | 962 | *name*|*type*|*optional*|*default*|*description* 963 | ---|---|---|---|--- 964 | s|String|False|| 965 | 966 | 967 | --- 968 | VBA Procedure: **unEscapify** 969 | Type: **Function** 970 | Returns: **String** 971 | Return description: **** 972 | Scope: **Public** 973 | Description: **** 974 | 975 | *Public Function unEscapify(s As String) As String* 976 | 977 | *name*|*type*|*optional*|*default*|*description* 978 | ---|---|---|---|--- 979 | s|String|False|| 980 | 981 | 982 | --- 983 | VBA Procedure: **basicStyle** 984 | Type: **Function** 985 | Returns: **String** 986 | Return description: **** 987 | Scope: **Public** 988 | Description: **** 989 | 990 | *Public Function basicStyle() As String* 991 | 992 | **no arguments required for this procedure** 993 | 994 | 995 | --- 996 | VBA Procedure: **tableStyle** 997 | Type: **Function** 998 | Returns: **String** 999 | Return description: **** 1000 | Scope: **Public** 1001 | Description: **** 1002 | 1003 | *Public Function tableStyle() As String* 1004 | 1005 | **no arguments required for this procedure** 1006 | 1007 | 1008 | --- 1009 | VBA Procedure: **is64BitExcel** 1010 | Type: **Function** 1011 | Returns: **Boolean** 1012 | Return description: **** 1013 | Scope: **Public** 1014 | Description: **** 1015 | 1016 | *Public Function is64BitExcel() As Boolean* 1017 | 1018 | **no arguments required for this procedure** 1019 | 1020 | 1021 | --- 1022 | VBA Procedure: **includeJQuery** 1023 | Type: **Function** 1024 | Returns: **String** 1025 | Return description: **** 1026 | Scope: **Public** 1027 | Description: **** 1028 | 1029 | *Public Function includeJQuery() As String* 1030 | 1031 | **no arguments required for this procedure** 1032 | 1033 | 1034 | --- 1035 | VBA Procedure: **includeGoogleCallBack** 1036 | Type: **Function** 1037 | Returns: **String** 1038 | Return description: **** 1039 | Scope: **Public** 1040 | Description: **** 1041 | 1042 | *Public Function includeGoogleCallBack(c As String) As String* 1043 | 1044 | *name*|*type*|*optional*|*default*|*description* 1045 | ---|---|---|---|--- 1046 | c|String|False|| 1047 | 1048 | 1049 | --- 1050 | VBA Procedure: **jScriptTag** 1051 | Type: **Function** 1052 | Returns: **String** 1053 | Return description: **** 1054 | Scope: **Public** 1055 | Description: **** 1056 | 1057 | *Public Function jScriptTag(Optional src As String) As String* 1058 | 1059 | *name*|*type*|*optional*|*default*|*description* 1060 | ---|---|---|---|--- 1061 | src|String|True|| 1062 | 1063 | 1064 | --- 1065 | VBA Procedure: **jDivAtMouse** 1066 | Type: **Function** 1067 | Returns: **Variant** 1068 | Return description: **** 1069 | Scope: **Public** 1070 | Description: **** 1071 | 1072 | *Public Function jDivAtMouse()* 1073 | 1074 | **no arguments required for this procedure** 1075 | 1076 | 1077 | --- 1078 | VBA Procedure: **toClipBoard** 1079 | Type: **Function** 1080 | Returns: **String** 1081 | Return description: **** 1082 | Scope: **Public** 1083 | Description: **** 1084 | 1085 | *Public Function toClipBoard(s As String) As String* 1086 | 1087 | *name*|*type*|*optional*|*default*|*description* 1088 | ---|---|---|---|--- 1089 | s|String|False|| 1090 | 1091 | 1092 | --- 1093 | VBA Procedure: **importTabbed** 1094 | Type: **Function** 1095 | Returns: **Range** 1096 | Return description: **** 1097 | Scope: **Public** 1098 | Description: **** 1099 | 1100 | *Public Function importTabbed(fn As String, r As Range) As Range* 1101 | 1102 | *name*|*type*|*optional*|*default*|*description* 1103 | ---|---|---|---|--- 1104 | fn|String|False|| 1105 | r|Range|False|| 1106 | 1107 | 1108 | --- 1109 | VBA Procedure: **biasedRandom** 1110 | Type: **Function** 1111 | Returns: **String** 1112 | Return description: **** 1113 | Scope: **Public** 1114 | Description: **** 1115 | 1116 | *Function biasedRandom(possibilities, weights) As String* 1117 | 1118 | *name*|*type*|*optional*|*default*|*description* 1119 | ---|---|---|---|--- 1120 | possibilities|Variant|False|| 1121 | weights|Variant|False|| 1122 | 1123 | 1124 | --- 1125 | VBA Procedure: **sleep** 1126 | Type: **Sub** 1127 | Returns: **void** 1128 | Return description: **** 1129 | Scope: **Public** 1130 | Description: **** 1131 | 1132 | *Public Sub sleep(seconds As Long)* 1133 | 1134 | *name*|*type*|*optional*|*default*|*description* 1135 | ---|---|---|---|--- 1136 | seconds|Long|False|| 1137 | 1138 | 1139 | --- 1140 | VBA Procedure: **getDateFromTimestamp** 1141 | Type: **Function** 1142 | Returns: **Date** 1143 | Return description: **** 1144 | Scope: **Public** 1145 | Description: **** 1146 | 1147 | *Public Function getDateFromTimestamp(s As String) As Date* 1148 | 1149 | *name*|*type*|*optional*|*default*|*description* 1150 | ---|---|---|---|--- 1151 | s|String|False|| 1152 | 1153 | 1154 | --- 1155 | VBA Procedure: **dateFromUnix** 1156 | Type: **Function** 1157 | Returns: **Variant** 1158 | Return description: **** 1159 | Scope: **Public** 1160 | Description: **** 1161 | 1162 | *Public Function dateFromUnix(s As Variant) As Variant* 1163 | 1164 | *name*|*type*|*optional*|*default*|*description* 1165 | ---|---|---|---|--- 1166 | s|Variant|False|| 1167 | 1168 | 1169 | --- 1170 | VBA Procedure: **isSomething** 1171 | Type: **Function** 1172 | Returns: **Boolean** 1173 | Return description: **** 1174 | Scope: **Public** 1175 | Description: **** 1176 | 1177 | *Public Function isSomething(o As Object) As Boolean* 1178 | 1179 | *name*|*type*|*optional*|*default*|*description* 1180 | ---|---|---|---|--- 1181 | o|Object|False|| 1182 | 1183 | 1184 | --- 1185 | VBA Procedure: **tinyTime** 1186 | Type: **Function** 1187 | Returns: **Double** 1188 | Return description: **** 1189 | Scope: **Public** 1190 | Description: **** 1191 | 1192 | *Public Function tinyTime() As Double* 1193 | 1194 | **no arguments required for this procedure** 1195 | 1196 | 1197 | --- 1198 | VBA Procedure: **getTableRange** 1199 | Type: **Function** 1200 | Returns: **Range** 1201 | Return description: **** 1202 | Scope: **Public** 1203 | Description: **** 1204 | 1205 | *Public Function getTableRange(tableName As String, Optional complain As Boolean = True) As Range* 1206 | 1207 | *name*|*type*|*optional*|*default*|*description* 1208 | ---|---|---|---|--- 1209 | tableName|String|False|| 1210 | complain|Boolean|True| True| 1211 | 1212 | 1213 | --- 1214 | VBA Procedure: **getListObject** 1215 | Type: **Function** 1216 | Returns: **ListObject** 1217 | Return description: **** 1218 | Scope: **Public** 1219 | Description: **** 1220 | 1221 | *Public Function getListObject(tableName As String) As ListObject* 1222 | 1223 | *name*|*type*|*optional*|*default*|*description* 1224 | ---|---|---|---|--- 1225 | tableName|String|False|| 1226 | 1227 | 1228 | --- 1229 | VBA Procedure: **listObjectExists** 1230 | Type: **Function** 1231 | Returns: **Boolean** 1232 | Return description: **** 1233 | Scope: **Public** 1234 | Description: **** 1235 | 1236 | *Public Function listObjectExists(ws As Worksheet, sName As String) As Boolean* 1237 | 1238 | *name*|*type*|*optional*|*default*|*description* 1239 | ---|---|---|---|--- 1240 | ws|Worksheet|False|| 1241 | sName|String|False|| 1242 | -------------------------------------------------------------------------------- /libraries/cStringChunker.cls: -------------------------------------------------------------------------------- 1 | 'gistThat@mcpher.com :do not modify this line - see ramblings.mcpher.com for details: updated on 8/18/2014 3:54:20 PM : from manifest:7471153 gist https://gist.github.com/brucemcpherson/5102369/raw/cStringChunker.cls 2 | ' stringChunker class for VBA because string concat takes ages 3 | Option Explicit 4 | ' v1.06 5102369 5 | Private pContent As String 6 | Private pSize As Long 7 | ' minimum amount to increment by each time 8 | Const defaultChunkSize = 64 9 | Public Property Get size() As Long 10 | ' this is how much content is real 11 | size = pSize 12 | End Property 13 | Public Property Get content() As String 14 | ' return the real part of the content 15 | If pSize > 0 Then 16 | content = getLeft(size) 17 | Else 18 | content = vbNullString 19 | End If 20 | End Property 21 | Public Property Get getLeft(howMany As Long) As String 22 | ' return the left part of the content 23 | ' c.getLeft(howmany) is equivalent to left(c.content,howmany), but avoids extra assignment 24 | getLeft = getMid(1, howMany) 25 | End Property 26 | Public Property Get getRight(howMany As Long) As String 27 | ' return the right part of the content 28 | ' c.getRight(howmany) is equivalent to right(c.content,howmany), but avoids extra assignment 29 | getRight = getMid(pSize - howMany + 1, howMany) 30 | End Property 31 | Public Property Get getMid(startPos As Long, Optional howMany As Long = -1) As String 32 | ' extract from content 33 | ' c.getMid(startPos,howmany) is equivalent to mid(c.content,startPos, howmany), but avoids extra assignment 34 | Dim n As Long 35 | Debug.Assert startPos > 0 And startPos <= pSize 36 | n = howMany 37 | If n = -1 Then 38 | n = pSize - startPos + 1 39 | End If 40 | n = minNumber(pSize - startPos + 1, n) 41 | If n > 0 Then 42 | getMid = Mid(pContent, startPos, n) 43 | Else 44 | getMid = vbNullString 45 | End If 46 | End Property 47 | Public Property Get self() As cStringChunker 48 | ' convenience for with in with 49 | Set self = Me 50 | End Property 51 | Public Function clear() As cStringChunker 52 | ' easy to clear out.. may as well keep the same buffer going 53 | pSize = 0 54 | Set clear = Me 55 | End Function 56 | Public Function uri(addstring As String) As cStringChunker 57 | Set uri = add(URLEncode(addstring)) 58 | End Function 59 | Public Function toString() As String 60 | toString = content() 61 | End Function 62 | Public Function add(addstring As String) As cStringChunker 63 | Dim k As Long 64 | ' add some content to end 65 | k = Len(addstring) 66 | If k > 0 Then 67 | adjustSize (k) 68 | 69 | Mid(pContent, size + 1, k) = addstring 70 | pSize = size + k 71 | End If 72 | Set add = Me 73 | End Function 74 | Public Function addLine(addstring As String) As cStringChunker 75 | Set addLine = add(addstring).add(vbCrLf) 76 | End Function 77 | Public Function insert(Optional insertString As String = " ", _ 78 | Optional insertBefore As Long = 1) As cStringChunker 79 | 'default position is at beginning, insert a space 80 | 'c.insert("x",c.size+1) is equivalent to c.add("x") 81 | 82 | If insertBefore = pSize + 1 Then 83 | Set insert = add(insertString) 84 | 85 | Else 86 | ' 'todo .. how to handle programming errors? 87 | Debug.Assert insertBefore > 0 And insertBefore <= pSize 88 | 89 | ' regular string concatenation is better since there is overlap 90 | pContent = getLeft(insertBefore - 1) & insertString & getMid(insertBefore) 91 | pSize = Len(pContent) 92 | Set insert = Me 93 | 94 | End If 95 | Set insert = Me 96 | End Function 97 | Public Function overWrite(Optional overWriteString As String = " ", _ 98 | Optional overWriteAt As Long = 1) As cStringChunker 99 | 'default position is at beginning, overwrite with a space 100 | Dim k As Long 101 | k = Len(overWriteString) 102 | If k > 0 Then 103 | ' 'todo .. how to handle programming errors? 104 | Debug.Assert overWriteAt >= 0 105 | '' we'll allow overwrite to extend past end, be greedy 106 | adjustSize (k) 107 | pSize = maxNumber(pSize, k + overWriteAt - 1) 108 | 109 | Mid(pContent, overWriteAt, k) = overWriteString 110 | 111 | End If 112 | Set overWrite = Me 113 | End Function 114 | 115 | Public Function shift(Optional startPos As Long = 1, _ 116 | Optional howManyChars As Long = 0, _ 117 | Optional replaceWith As String = vbNullString) As cStringChunker 118 | ' shift by howmany chars .. negative= left, positive = right 119 | 'TODO how to deal with programming errors? message, raise error, assert? 120 | Dim howMany As Long 121 | 122 | howMany = howManyChars 123 | If howMany = 0 Then 124 | howMany = Len(replaceWith) 125 | End If 126 | 127 | Debug.Assert howMany + startPos > 0 128 | Debug.Assert startPos <= pSize And startPos > 0 129 | 130 | ' make space 131 | If howMany <> 0 Then 132 | 133 | If howMany > 0 Then 134 | ' its a right shift, use insert 135 | Set shift = insert(Space(howMany), startPos) 136 | Else 137 | ' a left shift 138 | If startPos > 1 Then 139 | ' we can do an overwrite 140 | overWrite getMid(startPos + howMany, pSize - startPos + 1), startPos 141 | pSize = pSize + howMany 142 | End If 143 | 144 | End If 145 | End If 146 | 147 | Set shift = Me 148 | End Function 149 | Public Function chop(Optional n As Long = 1) As cStringChunker 150 | ' chop n charaters from end of content 151 | pSize = maxNumber(0, pSize - n) 152 | Set chop = Me 153 | End Function 154 | Public Function chopIf(t As String) As cStringChunker 155 | ' chop if its t 156 | Dim k As Long 157 | k = Len(t) 158 | If k <= pSize Then 159 | If getRight(k) = t Then 160 | chop (k) 161 | End If 162 | End If 163 | Set chopIf = Me 164 | End Function 165 | Public Function chopWhile(t As String) As cStringChunker 166 | ' chop if its t 167 | Dim k As Long, x As Long 168 | 169 | Set chopWhile = Me 170 | x = pSize 171 | While chopIf(t).size <> x 172 | x = pSize 173 | Wend 174 | 175 | End Function 176 | Private Function maxNumber(a As Long, b As Long) As Long 177 | If a > b Then 178 | maxNumber = a 179 | Else 180 | maxNumber = b 181 | End If 182 | End Function 183 | Private Function minNumber(a As Long, b As Long) As Long 184 | If a < b Then 185 | minNumber = a 186 | Else 187 | minNumber = b 188 | End If 189 | End Function 190 | Private Function adjustSize(needMore As Long) As cStringChunker 191 | Dim need As Long 192 | need = pSize + needMore 193 | If Len(pContent) < need Then 194 | pContent = pContent & Space(needMore + maxNumber(defaultChunkSize, Len(pContent))) 195 | End If 196 | Set adjustSize = Me 197 | End Function 198 | Private Sub Class_Initialize() 199 | pSize = 0 200 | pContent = Space(defaultChunkSize) 201 | End Sub 202 | 203 | 204 | 205 | 206 | 207 | -------------------------------------------------------------------------------- /libraries/cStringChunker_cls.md: -------------------------------------------------------------------------------- 1 | # VBA Project: **vbaJavaScript** 2 | ## VBA Module: **[cStringChunker](/libraries/cStringChunker.cls "source is here")** 3 | ### Type: ClassModule 4 | 5 | This procedure list for repo (vbaJavaScript) was automatically created on 6/25/2015 10:03:22 AM by VBAGit. 6 | For more information see the [desktop liberation site](http://ramblings.mcpher.com/Home/excelquirks/drivesdk/gettinggithubready "desktop liberation") 7 | 8 | Below is a section for each procedure in cStringChunker 9 | 10 | --- 11 | VBA Procedure: **size** 12 | Type: **Get** 13 | Returns: **Long** 14 | Return description: **** 15 | Scope: **Public** 16 | Description: **** 17 | 18 | *Public Property Get size() As Long* 19 | 20 | **no arguments required for this procedure** 21 | 22 | 23 | --- 24 | VBA Procedure: **content** 25 | Type: **Get** 26 | Returns: **String** 27 | Return description: **** 28 | Scope: **Public** 29 | Description: **** 30 | 31 | *Public Property Get content() As String* 32 | 33 | **no arguments required for this procedure** 34 | 35 | 36 | --- 37 | VBA Procedure: **getLeft** 38 | Type: **Get** 39 | Returns: **String** 40 | Return description: **** 41 | Scope: **Public** 42 | Description: **** 43 | 44 | *Public Property Get getLeft(howMany As Long) As String* 45 | 46 | *name*|*type*|*optional*|*default*|*description* 47 | ---|---|---|---|--- 48 | howMany|Long|False|| 49 | 50 | 51 | --- 52 | VBA Procedure: **getRight** 53 | Type: **Get** 54 | Returns: **String** 55 | Return description: **** 56 | Scope: **Public** 57 | Description: **** 58 | 59 | *Public Property Get getRight(howMany As Long) As String* 60 | 61 | *name*|*type*|*optional*|*default*|*description* 62 | ---|---|---|---|--- 63 | howMany|Long|False|| 64 | 65 | 66 | --- 67 | VBA Procedure: **getMid** 68 | Type: **Get** 69 | Returns: **String** 70 | Return description: **** 71 | Scope: **Public** 72 | Description: **** 73 | 74 | *Public Property Get getMid(startPos As Long, Optional howMany As Long = -1) As String* 75 | 76 | *name*|*type*|*optional*|*default*|*description* 77 | ---|---|---|---|--- 78 | startPos|Long|False|| 79 | howMany|Long|True| -1| 80 | 81 | 82 | --- 83 | VBA Procedure: **self** 84 | Type: **Get** 85 | Returns: **[cStringChunker](/libraries/cStringChunker_cls.md "cStringChunker")** 86 | Return description: **** 87 | Scope: **Public** 88 | Description: **** 89 | 90 | *Public Property Get self() As cStringChunker* 91 | 92 | **no arguments required for this procedure** 93 | 94 | 95 | --- 96 | VBA Procedure: **clear** 97 | Type: **Function** 98 | Returns: **[cStringChunker](/libraries/cStringChunker_cls.md "cStringChunker")** 99 | Return description: **** 100 | Scope: **Public** 101 | Description: **** 102 | 103 | *Public Function clear() As cStringChunker* 104 | 105 | **no arguments required for this procedure** 106 | 107 | 108 | --- 109 | VBA Procedure: **uri** 110 | Type: **Function** 111 | Returns: **[cStringChunker](/libraries/cStringChunker_cls.md "cStringChunker")** 112 | Return description: **** 113 | Scope: **Public** 114 | Description: **** 115 | 116 | *Public Function uri(addstring As String) As cStringChunker* 117 | 118 | *name*|*type*|*optional*|*default*|*description* 119 | ---|---|---|---|--- 120 | addstring|String|False|| 121 | 122 | 123 | --- 124 | VBA Procedure: **toString** 125 | Type: **Function** 126 | Returns: **String** 127 | Return description: **** 128 | Scope: **Public** 129 | Description: **** 130 | 131 | *Public Function toString() As String* 132 | 133 | **no arguments required for this procedure** 134 | 135 | 136 | --- 137 | VBA Procedure: **add** 138 | Type: **Function** 139 | Returns: **[cStringChunker](/libraries/cStringChunker_cls.md "cStringChunker")** 140 | Return description: **** 141 | Scope: **Public** 142 | Description: **** 143 | 144 | *Public Function add(addstring As String) As cStringChunker* 145 | 146 | *name*|*type*|*optional*|*default*|*description* 147 | ---|---|---|---|--- 148 | addstring|String|False|| 149 | 150 | 151 | --- 152 | VBA Procedure: **addLine** 153 | Type: **Function** 154 | Returns: **[cStringChunker](/libraries/cStringChunker_cls.md "cStringChunker")** 155 | Return description: **** 156 | Scope: **Public** 157 | Description: **** 158 | 159 | *Public Function addLine(addstring As String) As cStringChunker* 160 | 161 | *name*|*type*|*optional*|*default*|*description* 162 | ---|---|---|---|--- 163 | addstring|String|False|| 164 | 165 | 166 | --- 167 | VBA Procedure: **insert** 168 | Type: **Function** 169 | Returns: **[cStringChunker](/libraries/cStringChunker_cls.md "cStringChunker")** 170 | Return description: **** 171 | Scope: **Public** 172 | Description: **** 173 | 174 | *Public Function insert(Optional insertString As String = " ", Optional insertBefore As Long = 1) As cStringChunker* 175 | 176 | *name*|*type*|*optional*|*default*|*description* 177 | ---|---|---|---|--- 178 | insertString|String|True| " "| 179 | insertBefore|Long|True| 1| 180 | 181 | 182 | --- 183 | VBA Procedure: **overWrite** 184 | Type: **Function** 185 | Returns: **[cStringChunker](/libraries/cStringChunker_cls.md "cStringChunker")** 186 | Return description: **** 187 | Scope: **Public** 188 | Description: **** 189 | 190 | *Public Function overWrite(Optional overWriteString As String = " ", Optional overWriteAt As Long = 1) As cStringChunker* 191 | 192 | *name*|*type*|*optional*|*default*|*description* 193 | ---|---|---|---|--- 194 | overWriteString|String|True| " "| 195 | overWriteAt|Long|True| 1| 196 | 197 | 198 | --- 199 | VBA Procedure: **shift** 200 | Type: **Function** 201 | Returns: **[cStringChunker](/libraries/cStringChunker_cls.md "cStringChunker")** 202 | Return description: **** 203 | Scope: **Public** 204 | Description: **** 205 | 206 | *Public Function shift(Optional startPos As Long = 1, Optional howManyChars As Long = 0, Optional replaceWith As String = vbNullString) As cStringChunker* 207 | 208 | *name*|*type*|*optional*|*default*|*description* 209 | ---|---|---|---|--- 210 | startPos|Long|True| 1| 211 | howManyChars|Long|True| 0| 212 | replaceWith|String|True| vbNullString| 213 | 214 | 215 | --- 216 | VBA Procedure: **chop** 217 | Type: **Function** 218 | Returns: **[cStringChunker](/libraries/cStringChunker_cls.md "cStringChunker")** 219 | Return description: **** 220 | Scope: **Public** 221 | Description: **** 222 | 223 | *Public Function chop(Optional n As Long = 1) As cStringChunker* 224 | 225 | *name*|*type*|*optional*|*default*|*description* 226 | ---|---|---|---|--- 227 | n|Long|True| 1| 228 | 229 | 230 | --- 231 | VBA Procedure: **chopIf** 232 | Type: **Function** 233 | Returns: **[cStringChunker](/libraries/cStringChunker_cls.md "cStringChunker")** 234 | Return description: **** 235 | Scope: **Public** 236 | Description: **** 237 | 238 | *Public Function chopIf(t As String) As cStringChunker* 239 | 240 | *name*|*type*|*optional*|*default*|*description* 241 | ---|---|---|---|--- 242 | t|String|False|| 243 | 244 | 245 | --- 246 | VBA Procedure: **chopWhile** 247 | Type: **Function** 248 | Returns: **[cStringChunker](/libraries/cStringChunker_cls.md "cStringChunker")** 249 | Return description: **** 250 | Scope: **Public** 251 | Description: **** 252 | 253 | *Public Function chopWhile(t As String) As cStringChunker* 254 | 255 | *name*|*type*|*optional*|*default*|*description* 256 | ---|---|---|---|--- 257 | t|String|False|| 258 | 259 | 260 | --- 261 | VBA Procedure: **maxNumber** 262 | Type: **Function** 263 | Returns: **Long** 264 | Return description: **** 265 | Scope: **Private** 266 | Description: **** 267 | 268 | *Private Function maxNumber(a As Long, b As Long) As Long* 269 | 270 | *name*|*type*|*optional*|*default*|*description* 271 | ---|---|---|---|--- 272 | a|Long|False|| 273 | b|Long|False|| 274 | 275 | 276 | --- 277 | VBA Procedure: **minNumber** 278 | Type: **Function** 279 | Returns: **Long** 280 | Return description: **** 281 | Scope: **Private** 282 | Description: **** 283 | 284 | *Private Function minNumber(a As Long, b As Long) As Long* 285 | 286 | *name*|*type*|*optional*|*default*|*description* 287 | ---|---|---|---|--- 288 | a|Long|False|| 289 | b|Long|False|| 290 | 291 | 292 | --- 293 | VBA Procedure: **adjustSize** 294 | Type: **Function** 295 | Returns: **[cStringChunker](/libraries/cStringChunker_cls.md "cStringChunker")** 296 | Return description: **** 297 | Scope: **Private** 298 | Description: **** 299 | 300 | *Private Function adjustSize(needMore As Long) As cStringChunker* 301 | 302 | *name*|*type*|*optional*|*default*|*description* 303 | ---|---|---|---|--- 304 | needMore|Long|False|| 305 | 306 | 307 | --- 308 | VBA Procedure: **Class_Initialize** 309 | Type: **Sub** 310 | Returns: **void** 311 | Return description: **** 312 | Scope: **Private** 313 | Description: **** 314 | 315 | *Private Sub Class_Initialize()* 316 | 317 | **no arguments required for this procedure** 318 | -------------------------------------------------------------------------------- /libraries/usefulColorStuff.vba: -------------------------------------------------------------------------------- 1 | 'gistThat@mcpher.com :do not modify this line - see ramblings.mcpher.com for details: updated on 8/18/2014 4:47:46 PM : from manifest:3414394 gist https://gist.github.com/brucemcpherson/3414615/raw 2 | ' this is all about colors 3 | Option Explicit 4 | ' v2.7 3414615 5 | 6 | Public Type colorProps 7 | ' this is a single type to hold everything i know how to calculate about a color 8 | rgb As Long 9 | red As Long 10 | green As Long 11 | blue As Long 12 | htmlHex As String 13 | textColor As Long 14 | luminance As Double 15 | contrastRatio As Double 16 | cyan As Double 17 | magenta As Double 18 | yellow As Double 19 | black As Double 20 | hue As Double 21 | saturation As Double 22 | lightness As Double 23 | value As Double 24 | x As Double 25 | y As Double 26 | z As Double 27 | LStar As Double 28 | aStar As Double 29 | bStar As Double 30 | cStar As Double 31 | hStar As Double 32 | End Type 33 | Enum eCompareColor 34 | eccieDe2000 35 | End Enum 36 | 37 | 'Reference white for XYZ space/Observer = 2 deg Illuminant = D65 38 | Const refWhiteX As Double = 95.047 39 | Const refWhiteY As Double = 100 40 | Const refWhiteZ As Double = 108.883 41 | Const ref1 = 11181951 42 | Const ref2 = 5934250 43 | Public Function getlStar(rgbColor As Long) As Double 44 | getlStar = makeColorProps(rgbColor).LStar 45 | End Function 46 | Public Function getCstar(rgbColor As Long) As Double 47 | getCstar = makeColorProps(rgbColor).cStar 48 | End Function 49 | 50 | Public Function getBstar(rgbColor As Long) As Double 51 | getBstar = makeColorProps(rgbColor).bStar 52 | End Function 53 | Public Function getHstar(rgbColor As Long) As Double 54 | getHstar = makeColorProps(rgbColor).hStar 55 | End Function 56 | Public Function getAstar(rgbColor As Long) As Double 57 | getAstar = makeColorProps(rgbColor).aStar 58 | End Function 59 | Public Function fromRef(rgbColor As Long, ref As Long) As Double 60 | fromRef = compareColors(rgbColor, ref) 61 | End Function 62 | Public Function fromRefX(rgbColor As Long) As Double 63 | fromRefX = fromRef(rgbColor, ref1) 64 | End Function 65 | Public Function fromRefY(rgbColor As Long) As Double 66 | fromRefY = fromRef(rgbColor, ref2) 67 | End Function 68 | Public Function cellProperty(r As Range, p As String) As String 69 | ' find the excel property given the requested style 70 | Select Case p 71 | Case "background-color" 72 | cellProperty = rgbToHTMLHex(r.Interior.Color) 73 | 74 | Case "color" 75 | cellProperty = rgbToHTMLHex(r.Font.Color) 76 | 77 | Case "font-size" 78 | cellProperty = r.Font.size 79 | 80 | Case Else 81 | Debug.Assert False 82 | 83 | End Select 84 | End Function 85 | Public Function cellCss(r As Range, p As String) As String 86 | cellCss = p & ":" & cellProperty(r, p) & ";" 87 | End Function 88 | Public Function heatmapColor(min As Variant, _ 89 | max As Variant, value As Variant) As Long 90 | heatmapColor = rampLibraryRGB("heatmap", min, max, value) 91 | 92 | End Function 93 | Public Function rgbExpose(r As Long, g As Long, b As Long) As Long 94 | ' so i can use it in worksheets 95 | rgbExpose = rgb(r, g, b) 96 | 97 | End Function 98 | Public Function rgbRed(rgbColor As Long) As Long 99 | rgbRed = rgbColor Mod &H100 100 | End Function 101 | Public Function rgbGreen(rgbColor As Long) As Long 102 | rgbGreen = (rgbColor \ &H100) Mod &H100 103 | End Function 104 | Public Function rgbBlue(rgbColor As Long) As Long 105 | rgbBlue = (rgbColor \ &H10000) Mod &H100 106 | End Function 107 | Public Function rgbToHex(rgbColor As Long) As String 108 | ' just a synonym 109 | rgbToHex = rgbToHTMLHex(rgbColor) 110 | End Function 111 | Public Function rgbToHTMLHex(rgbColor As Long) As String 112 | 113 | ' just swap the colors round for rgb to bgr 114 | rgbToHTMLHex = "#" & maskFormat(Hex(rgb(rgbBlue(rgbColor), _ 115 | rgbGreen(rgbColor), rgbRed(rgbColor))), "000000") 116 | 117 | End Function 118 | Public Function htmlHexToRgb(htmlHex As String) As Long 119 | Dim x As Long, s As String 120 | 121 | s = LTrim(RTrim(htmlHex)) 122 | Debug.Assert Len(htmlHex) > 1 And left(htmlHex, 1) = "#" 123 | x = val("&H" & Right(s, Len(s) - 1) & "&") 124 | ' these are purposefully reversed since byte order is different in unix 125 | htmlHexToRgb = rgb(rgbBlue(x), rgbGreen(x), rgbRed(x)) 126 | 127 | End Function 128 | 129 | Private Function maskFormat(sIn As String, f As String) As String 130 | Dim s As String 131 | s = sIn 132 | If Len(s) < Len(f) Then 133 | s = left(f, Len(f) - Len(s)) & s 134 | End If 135 | maskFormat = s 136 | End Function 137 | 138 | Private Function lumRGB(rgbCom As Double, brighten As Double) As Double 139 | Dim x As Double 140 | x = rgbCom * brighten 141 | If x > 255 Then x = 255 142 | If x < 0 Then x = 0 143 | lumRGB = x 144 | 145 | End Function 146 | Public Function rgbToHsl(rgbColor As Long) As colorProps 147 | ' adapted from // http://www.easyrgb.com/ 148 | Dim r As Double, g As Double, b As Double, d As Double, _ 149 | dr As Double, dg As Double, db As Double, mn As Double, mx As Double, _ 150 | p As colorProps 151 | 152 | r = rgbRed(rgbColor) / 255 153 | g = rgbGreen(rgbColor) / 255 154 | b = rgbBlue(rgbColor) / 255 155 | mn = min(r, g, b) 156 | mx = max(r, g, b) 157 | d = mx - mn 158 | 159 | ' HSL sets here 160 | p.hue = 0 161 | p.saturation = 0 162 | ' lightness 163 | p.lightness = (mx + mn) / 2 164 | 165 | If (d <> 0) Then 166 | ' saturation 167 | If (p.lightness < 0.5) Then 168 | p.saturation = d / (mx + mn) 169 | Else 170 | p.saturation = d / (2 - mx - mn) 171 | End If 172 | ' hue 173 | dr = (((mx - r) / 6) + (d / 2)) / d 174 | dg = (((mx - g) / 6) + (d / 2)) / d 175 | db = (((mx - b) / 6) + (d / 2)) / d 176 | 177 | If r = mx Then 178 | p.hue = db - dg 179 | ElseIf g = mx Then 180 | p.hue = (1 / 3) + dr - db 181 | Else 182 | p.hue = (2 / 3) + dg - dr 183 | End If 184 | 185 | 'force between 0 and 1 186 | If p.hue < 0 Then p.hue = p.hue + 1 187 | If p.hue > 1 Then p.hue = p.hue - 1 188 | Debug.Assert p.hue >= 0 And p.hue <= 1 189 | End If 190 | p.hue = p.hue * 360 191 | p.saturation = p.saturation * 100 192 | p.lightness = p.lightness * 100 193 | rgbToHsl = p 194 | 195 | End Function 196 | Private Function rgbToHsv(rgbColor As Long) As colorProps 197 | ' adapted from // http://www.easyrgb.com/ 198 | Dim r As Double, g As Double, b As Double, _ 199 | mn As Double, mx As Double, _ 200 | p As colorProps 201 | 202 | r = rgbRed(rgbColor) / 255 203 | g = rgbGreen(rgbColor) / 255 204 | b = rgbBlue(rgbColor) / 255 205 | mn = min(r, g, b) 206 | mx = max(r, g, b) 207 | 208 | ' this is the same as hsl and hsv are the same. 209 | p = rgbToHsl(rgbColor) 210 | 211 | ' HSV sets here 212 | p.value = mx 213 | 214 | rgbToHsv = p 215 | End Function 216 | Private Function xyzCorrection(v As Double) As Double 217 | If (v > 0.04045) Then 218 | xyzCorrection = ((v + 0.055) / 1.055) ^ 2.4 219 | Else 220 | xyzCorrection = v / 12.92 221 | End If 222 | End Function 223 | 224 | 225 | Private Function xyzCIECorrection(v As Double) As Double 226 | If (v > 0.008856) Then 227 | xyzCIECorrection = (v ^ (1 / 3)) 228 | Else 229 | xyzCIECorrection = (7.787 * v) + (16 / 116) 230 | End If 231 | End Function 232 | Private Function rgbToXyz(rgbColor As Long) As colorProps 233 | ' adapted from // http://www.easyrgb.com/ 234 | Dim r As Double, g As Double, b As Double, _ 235 | p As colorProps 236 | 237 | r = xyzCorrection(rgbRed(rgbColor) / 255) * 100 238 | g = xyzCorrection(rgbGreen(rgbColor) / 255) * 100 239 | b = xyzCorrection(rgbBlue(rgbColor) / 255) * 100 240 | 241 | p.x = r * 0.4124 + g * 0.3576 + b * 0.1805 242 | p.y = r * 0.2126 + g * 0.7152 + b * 0.0722 243 | p.z = r * 0.0193 + g * 0.1192 + b * 0.9505 244 | 245 | rgbToXyz = p 246 | End Function 247 | Private Function rgbToLab(rgbColor As Long) As colorProps 248 | ' adapted from // http://www.easyrgb.com/ 249 | Dim x As Double, y As Double, z As Double, _ 250 | p As colorProps 251 | 252 | p = rgbToXyz(rgbColor) 253 | 254 | x = xyzCIECorrection(p.x / refWhiteX) 255 | y = xyzCIECorrection(p.y / refWhiteY) 256 | z = xyzCIECorrection(p.z / refWhiteZ) 257 | 258 | p.LStar = (116 * y) - 16 259 | p.aStar = 500 * (x - y) 260 | p.bStar = 200 * (y - z) 261 | 262 | rgbToLab = p 263 | End Function 264 | Public Function findNearestColorInRange(rSearchFor As Range, rSearchIn As Range) As Range 265 | Dim r As Range, d As Double, dmin As Double, dr As Range, t As Long 266 | Set dr = Nothing 267 | t = rgbColorOf(firstCell(rSearchFor)) 268 | For Each r In rSearchIn.Cells 269 | d = compareColors(rgbColorOf(r), t) 270 | If d < dmin Or dr Is Nothing Then 271 | Set dr = r 272 | dmin = d 273 | End If 274 | Next r 275 | Set findNearestColorInRange = dr 276 | End Function 277 | 278 | 279 | Public Function compareColors(rgb1 As Long, rgb2 As Long, _ 280 | Optional compareType As eCompareColor = eCompareColor.eccieDe2000) As Double 281 | Dim p1 As colorProps, p2 As colorProps 282 | p1 = makeColorProps(rgb1) 283 | p2 = makeColorProps(rgb2) 284 | Select Case compareType 285 | Case eCompareColor.eccieDe2000 286 | compareColors = cieDe2000(p1, p2) 287 | 288 | Case Else 289 | Debug.Assert False 290 | 291 | End Select 292 | 293 | End Function 294 | 295 | 296 | Public Function cieDe2000(p1 As colorProps, p2 As colorProps) As Double 297 | ' calculates the distance between 2 colors using CIEDE200 298 | ' see http://www.ece.rochester.edu/~gsharma/cieDe2000/cieDe2000noteCRNA.pdf 299 | Dim c1 As Double, c2 As Double, _ 300 | c As Double, g As Double, a1 As Double, b1 As Double, _ 301 | a2 As Double, b2 As Double, c1Tick As Double, c2Tick As Double, _ 302 | h1 As Double, h2 As Double, dh As Double, dl As Double, dc As Double, _ 303 | lTickAvg As Double, cTickAvg As Double, hTickAvg As Double, l50 As Double, sl As Double, _ 304 | sc As Double, t As Double, sh As Double, dTheta As Double, kp As Double, _ 305 | rc As Double, kl As Double, kc As Double, kh As Double, dlk As Double, _ 306 | dck As Double, dhk As Double, rt As Double, dBigH As Double 307 | 308 | kp = 25 ^ 7 309 | kl = 1 310 | kc = 1 311 | kh = 1 312 | 313 | ' calculate c & g values 314 | c1 = Sqr(p1.aStar ^ 2 + p1.bStar ^ 2) 315 | c2 = Sqr(p2.aStar ^ 2 + p2.bStar ^ 2) 316 | c = (c1 + c2) / 2 317 | g = 0.5 * (1 - Sqr(c ^ 7 / (c ^ 7 + kp))) 318 | 319 | ' adjusted ab* 320 | a1 = (1 + g) * p1.aStar 321 | a2 = (1 + g) * p2.aStar 322 | 323 | ' adjusted cs 324 | c1Tick = Sqr(a1 ^ 2 + p1.bStar ^ 2) 325 | c2Tick = Sqr(a2 ^ 2 + p2.bStar ^ 2) 326 | 327 | ' adjusted h 328 | h1 = computeH(a1, p1.bStar) 329 | h2 = computeH(a2, p2.bStar) 330 | 331 | 332 | ' deltas 333 | If (h2 - h1 > 180) Then '1 334 | dh = h2 - h1 - 360 335 | ElseIf (h2 - h1 < -180) Then ' 2 336 | dh = h2 - h1 + 360 337 | Else '0 338 | dh = h2 - h1 339 | End If 340 | 341 | dl = p2.LStar - p1.LStar 342 | dc = c2Tick - c1Tick 343 | dBigH = (2 * Sqr(c1Tick * c2Tick) * sIn(toRadians(dh / 2))) 344 | 345 | ' averages 346 | lTickAvg = (p1.LStar + p2.LStar) / 2 347 | cTickAvg = (c1Tick + c2Tick) / 2 348 | 349 | 350 | If (c1Tick * c2Tick = 0) Then '3 351 | hTickAvg = h1 + h2 352 | 353 | ElseIf (Abs(h2 - h1) <= 180) Then '0 354 | hTickAvg = (h1 + h2) / 2 355 | 356 | ElseIf (h2 + h1 < 360) Then '1 357 | hTickAvg = (h1 + h2) / 2 + 180 358 | 359 | Else '2 360 | hTickAvg = (h1 + h2) / 2 - 180 361 | End If 362 | 363 | l50 = (lTickAvg - 50) ^ 2 364 | sl = 1 + (0.015 * l50 / Sqr(20 + l50)) 365 | sc = 1 + 0.045 * cTickAvg 366 | t = 1 - 0.17 * Cos(toRadians(hTickAvg - 30)) + 0.24 * _ 367 | Cos(toRadians(2 * hTickAvg)) + 0.32 * _ 368 | Cos(toRadians(3 * hTickAvg + 6)) - 0.2 * _ 369 | Cos(toRadians(4 * hTickAvg - 63)) 370 | 371 | sh = 1 + 0.015 * cTickAvg * t 372 | 373 | dTheta = 30 * Exp(-1 * ((hTickAvg - 275) / 25) ^ 2) 374 | rc = 2 * Sqr(cTickAvg ^ 7 / (cTickAvg ^ 7 + kp)) 375 | rt = -sIn(toRadians(2 * dTheta)) * rc 376 | dlk = dl / sl / kl 377 | dck = dc / sc / kc 378 | dhk = dBigH / sh / kh 379 | cieDe2000 = Sqr(dlk ^ 2 + dck ^ 2 + dhk ^ 2 + rt * dck * dhk) 380 | 381 | End Function 382 | Private Function computeH(a As Double, b As Double) As Double 383 | If (a = 0 And b = 0) Then 384 | computeH = 0 385 | ElseIf (b >= 0) Then 386 | computeH = Application.WorksheetFunction.Degrees(Application.WorksheetFunction.Atan2(a, b)) 387 | Else 388 | computeH = Application.WorksheetFunction.Degrees(Application.WorksheetFunction.Atan2(a, b)) + 360 389 | End If 390 | End Function 391 | 392 | Public Function hslToRgb(p As colorProps) As Long 393 | ' adapted from // http://www.easyrgb.com/ 394 | Dim x1 As Double, x2 As Double, h As Double, s As Double, l As Double, _ 395 | red As Double, green As Double, blue As Double 396 | 397 | 398 | h = p.hue / 360 399 | s = p.saturation / 100 400 | l = p.lightness / 100 401 | 402 | If s = 0 Then 403 | red = l * 255 404 | green = l * 255 405 | blue = l * 255 406 | Else 407 | If l < 0.5 Then 408 | x2 = l * (1 + s) 409 | Else 410 | x2 = (l + s) - (l * s) 411 | End If 412 | x1 = 2 * l - x2 413 | 414 | red = 255 * hueToRgb(x1, x2, h + (1 / 3)) 415 | green = 255 * hueToRgb(x1, x2, h) 416 | blue = 255 * hueToRgb(x1, x2, h - (1 / 3)) 417 | 418 | End If 419 | hslToRgb = rgb(red, green, blue) 420 | 421 | End Function 422 | Private Function hueToRgb(a As Double, b As Double, h As Double) As Double 423 | ' adapted from // http://www.easyrgb.com/ 424 | If h < 0 Then h = h + 1 425 | If h > 1 Then h = h - 1 426 | Debug.Assert h >= 0 And h <= 1 427 | 428 | If (6 * h < 1) Then 429 | hueToRgb = a + (b - a) * 6 * h 430 | ElseIf (2 * h < 1) Then 431 | hueToRgb = b 432 | ElseIf (3 * h < 2) Then 433 | hueToRgb = a + (b - a) * ((2 / 3) - h) * 6 434 | Else 435 | hueToRgb = a 436 | End If 437 | 438 | End Function 439 | 440 | Public Function makeColorProps(rgbColor As Long) As colorProps 441 | Dim p As colorProps, p2 As colorProps 442 | 443 | 'store the source color 444 | p.rgb = rgbColor 445 | 446 | 'split the components 447 | p.red = rgbRed(rgbColor) 448 | p.green = rgbGreen(rgbColor) 449 | p.blue = rgbBlue(rgbColor) 450 | 451 | 'the html hex rgb equivalent 452 | p.htmlHex = rgbToHTMLHex(rgbColor) 453 | 454 | 'the w3 algo for luminance 455 | p.luminance = w3Luminance(rgbColor) 456 | 457 | 'determine whether black or white background 458 | If (p.luminance < 0.5) Then 459 | p.textColor = vbWhite 460 | Else 461 | p.textColor = vbBlack 462 | End If 463 | 464 | 'contrast ratio - to comply with w3 recs 1.4 should be at least 10:1 for text 465 | p.contrastRatio = contrastRatio(p.textColor, p.rgb) 466 | 467 | ' myck - just an estimate 468 | p.black = min(1 - p.red / 255, 1 - p.green / 255, 1 - p.blue / 255) 469 | If p.black < 1 Then 470 | p.cyan = (1 - p.red / 255 - p.black) / (1 - p.black) 471 | p.magenta = (1 - p.green / 255 - p.black) / (1 - p.black) 472 | p.yellow = (1 - p.blue / 255 - p.black) / (1 - p.black) 473 | End If 474 | 475 | ' calculate hsl + hsv and other wierd things 476 | p2 = rgbToHsl(p.rgb) 477 | p.hue = p2.hue 478 | p.saturation = p2.saturation 479 | p.lightness = p2.lightness 480 | 481 | p.value = rgbToHsv(p.rgb).value 482 | 483 | p2 = rgbToXyz(p.rgb) 484 | p.x = p2.x 485 | p.y = p2.y 486 | p.z = p2.z 487 | 488 | p2 = rgbToLab(p.rgb) 489 | p.LStar = p2.LStar 490 | p.aStar = p2.aStar 491 | p.bStar = p2.bStar 492 | 493 | p2 = rgbToLch(p.rgb) 494 | p.cStar = p2.cStar 495 | p.hStar = p2.hStar 496 | 497 | makeColorProps = p 498 | 499 | End Function 500 | Public Function pokeLchH(p As colorProps, newH As Double) As colorProps 501 | p.hStar = newH 502 | pokeLchH = p 503 | End Function 504 | 505 | Public Function lchToLab(p As colorProps) As colorProps 506 | Dim h As Double 507 | h = toRadians(p.hStar) 508 | p.aStar = Cos(h) * p.cStar 509 | p.bStar = sIn(h) * p.cStar 510 | lchToLab = p 511 | End Function 512 | Private Function labxyzCorrection(x As Double) As Double 513 | If (x ^ 3 > 0.008856) Then 514 | labxyzCorrection = x ^ 3 515 | Else 516 | labxyzCorrection = (x - 16 / 116) / 7.787 517 | End If 518 | 519 | End Function 520 | Public Function lchToRgb(p As colorProps) As Long 521 | lchToRgb = xyzToRgb(labToXyz(lchToLab(p))) 522 | End Function 523 | 524 | Private Function labToXyz(p As colorProps) As colorProps 525 | 526 | p.y = (p.LStar + 16) / 116 527 | p.x = p.aStar / 500 + p.y 528 | p.z = p.y - p.bStar / 200 529 | 530 | p.x = labxyzCorrection(p.x) * refWhiteX 531 | p.y = labxyzCorrection(p.y) * refWhiteY 532 | p.z = labxyzCorrection(p.z) * refWhiteZ 533 | 534 | labToXyz = p 535 | 536 | End Function 537 | 538 | Private Function xyzrgbCorrection(x As Double) As Double 539 | If (x > 0.0031308) Then 540 | xyzrgbCorrection = 1.055 * (x ^ (1 / 2.4)) - 0.055 541 | Else 542 | xyzrgbCorrection = 12.92 * x 543 | End If 544 | 545 | End Function 546 | Public Function xyzToRgb(p As colorProps) As Long 547 | Dim r As Double, g As Double, b As Double 548 | Dim x1 As Double, y1 As Double, z1 As Double 549 | Dim x2 As Double, y2 As Double, z2 As Double 550 | Dim x As Double, y As Double, z As Double, c As Double 551 | x = p.x / 100 552 | y = p.y / 100 553 | z = p.z / 100 554 | 555 | 556 | x1 = x * 0.8951 + y * 0.2664 + z * -0.1614 557 | y1 = x * -0.7502 + y * 1.7135 + z * 0.0367 558 | z1 = x * 0.0389 + y * -0.0685 + z * 1.0296 559 | 560 | x2 = x1 * 0.98699 + y1 * -0.14705 + z1 * 0.15997 561 | y2 = x1 * 0.43231 + y1 * 0.51836 + z1 * 0.04929 562 | z2 = x1 * -0.00853 + y1 * 0.04004 + z1 * 0.96849 563 | 564 | r = xyzrgbCorrection(x2 * 3.240479 + y2 * -1.53715 + z2 * -0.498535) 565 | g = xyzrgbCorrection(x2 * -0.969256 + y2 * 1.875992 + z2 * 0.041556) 566 | b = xyzrgbCorrection(x2 * 0.055648 + y2 * -0.204043 + z2 * 1.057311) 567 | 568 | c = rgb(min(255, max(0, CLng(r * 255))), _ 569 | min(255, max(0, CLng(g * 255))), _ 570 | min(255, max(0, CLng(b * 255)))) 571 | 572 | 573 | xyzToRgb = c 574 | End Function 575 | Public Function rgbWashout(rgbColor As Long) As Long 576 | ' take a color and wash it out 577 | Dim p As colorProps 578 | p = makeColorProps(rgbColor) 579 | p.saturation = p.saturation * 0.2 580 | p.lightness = p.lightness * 0.9 581 | 582 | rgbWashout = hslToRgb(p) 583 | End Function 584 | Public Function rgbToLch(rgbColor As Long) As colorProps 585 | ' convert from cieL*a*b* to cieL*CH 586 | ' adapted from http://www.brucelindbloom.com/index.html?Equations.html 587 | 588 | 589 | Dim p As colorProps 590 | p = rgbToLab(rgbColor) 591 | If rgbColor = 0 Then 592 | p.hStar = 0 593 | Else 594 | p.hStar = Application.WorksheetFunction.Atan2(p.aStar, p.bStar) 595 | If p.hStar > 0 Then 596 | p.hStar = fromRadians(p.hStar) 597 | Else 598 | p.hStar = 360 - fromRadians(Abs(p.hStar)) 599 | End If 600 | End If 601 | p.cStar = Sqr(p.aStar * p.aStar + p.bStar * p.bStar) 602 | rgbToLch = p 603 | 604 | End Function 605 | Public Function contrastRatio(rgbColorA As Long, rgbColorB As Long) As Double 606 | Dim lumA As Double, lumB As Double 607 | lumA = w3Luminance(rgbColorA) 608 | lumB = w3Luminance(rgbColorB) 609 | 610 | contrastRatio = (max(lumA, lumB) + 0.05) / (min(lumA, lumB) + 0.05) 611 | 612 | End Function 613 | 614 | Public Function w3Luminance(rgbColor As Long) As Double 615 | ' this is based on 616 | ' http://en.wikipedia.org/wiki/Luma_(video) 617 | 618 | w3Luminance = (0.2126 * ((rgbRed(rgbColor) / 255) ^ 2.2)) + _ 619 | (0.7152 * ((rgbGreen(rgbColor) / 255) ^ 2.2)) + _ 620 | (0.0722 * ((rgbBlue(rgbColor) / 255) ^ 2.2)) 621 | 622 | End Function 623 | Public Function rampLibraryRGB(ramp As Variant, min As Variant, _ 624 | max As Variant, value As Variant, _ 625 | Optional brighten As Double = 1) As Long 626 | Dim x As Long 627 | 628 | If IsArray(ramp) Then 629 | ' ramp colors have been passed here 630 | rampLibraryRGB = colorRamp(min, max, value, _ 631 | ramp, , _ 632 | brighten) 633 | Else 634 | 635 | Select Case Trim(LCase(CStr(ramp))) 636 | Case "heatmaptowhite" 637 | rampLibraryRGB = colorRamp(min, max, value, _ 638 | Array(vbBlue, vbGreen, vbYellow, vbRed, vbWhite), , _ 639 | brighten) 640 | 641 | Case "heatmap" 642 | rampLibraryRGB = colorRamp(min, max, value, _ 643 | Array(vbBlue, vbGreen, vbYellow, vbRed), , _ 644 | brighten) 645 | 646 | Case "blacktowhite" 647 | rampLibraryRGB = colorRamp(min, max, value, _ 648 | Array(vbBlack, vbWhite), , brighten) 649 | 650 | Case "whitetoblack" 651 | rampLibraryRGB = colorRamp(min, max, value, _ 652 | Array(vbWhite, vbBlack), , brighten) 653 | 654 | Case "hotinthemiddle" 655 | rampLibraryRGB = colorRamp(min, max, value, _ 656 | Array(vbBlue, vbGreen, vbYellow, vbRed, _ 657 | vbYellow, vbGreen, vbBlue), , brighten) 658 | 659 | Case "candylime" 660 | rampLibraryRGB = colorRamp(min, max, value, _ 661 | Array(rgb(255, 77, 121), rgb(255, 121, 77), _ 662 | rgb(255, 210, 77), rgb(210, 255, 77)), , _ 663 | brighten) 664 | 665 | Case "heatcolorblind" 666 | rampLibraryRGB = colorRamp(min, max, value, _ 667 | Array(vbBlack, vbBlue, vbRed, vbWhite), , brighten) 668 | 669 | Case "gethotquick" 670 | rampLibraryRGB = colorRamp(min, max, value, _ 671 | Array(vbBlue, vbGreen, vbYellow, vbRed), _ 672 | Array(0, 0.1, 0.25, 1), brighten) 673 | 674 | Case "slowramp" 675 | rampLibraryRGB = colorRamp(min, max, value, _ 676 | Array(vbBlack, rgb(0, 46, 184), rgb(0, 138, 184), _ 677 | rgb(0, 184, 138), _ 678 | rgb(138, 184, 0), rgb(184, 138, 0), _ 679 | rgb(138, 0, 184)), _ 680 | Array(0, 0.04, 0.1, 0.15, 0.22, 0.3, 1), brighten) 681 | 682 | Case "greensweep" 683 | rampLibraryRGB = colorRamp(min, max, value, _ 684 | Array(rgb(153, 204, 51), rgb(51, 204, 179)), , _ 685 | brighten) 686 | 687 | Case "terrain" 688 | rampLibraryRGB = colorRamp(min, max, value, _ 689 | Array(vbBlack, rgb(0, 46, 184), rgb(0, 138, 184), _ 690 | rgb(0, 184, 138), _ 691 | rgb(138, 184, 0), rgb(184, 138, 0), _ 692 | rgb(138, 0, 184), vbWhite), , _ 693 | brighten) 694 | 695 | Case "terrainnosea" 696 | rampLibraryRGB = colorRamp(min, max, value, _ 697 | Array(vbGreen, rgb(0, 184, 138), _ 698 | rgb(138, 184, 0), rgb(184, 138, 0), _ 699 | rgb(138, 0, 184), vbWhite), , _ 700 | brighten) 701 | Case "greendollar" 702 | rampLibraryRGB = colorRamp(min, max, value, _ 703 | Array(rgb(225, 255, 235), _ 704 | rgb(2, 202, 69)), , _ 705 | brighten) 706 | 707 | Case "lightblue" 708 | rampLibraryRGB = colorRamp(min, max, value, _ 709 | Array(rgb(230, 237, 246), _ 710 | rgb(163, 189, 271)), , _ 711 | brighten) 712 | 713 | Case "lightorange" 714 | rampLibraryRGB = colorRamp(min, max, value, _ 715 | Array(rgb(253, 233, 217), _ 716 | rgb(244, 132, 40)), , _ 717 | brighten) 718 | Case Else 719 | MsgBox ramp & " is an unknown library entry" 720 | 721 | End Select 722 | End If 723 | End Function 724 | Public Function colorRamp(min As Variant, _ 725 | max As Variant, value As Variant, _ 726 | Optional mileStones As Variant, _ 727 | Optional fractionStones As Variant, _ 728 | Optional brighten As Double = 1) As Long 729 | 730 | ' create a value from a colorramp going through the array of milestones 731 | Dim spread As Double, ratio As Double, red As Double, _ 732 | green As Double, blue As Double, j As Long, _ 733 | lb As Long, ub As Long, cb As Long, r As Double, i As Long 734 | '----defaults and set up milestones on ramp 735 | Dim ms() As Long 736 | Dim fs() As Double 737 | 738 | 739 | If IsMissing(mileStones) Then 740 | ReDim ms(0 To 4) 741 | ms(0) = vbBlue 742 | ms(1) = vbGreen 743 | ms(2) = vbYellow 744 | ms(3) = vbRed 745 | ms(4) = vbWhite 746 | Else 747 | ReDim ms(0 To UBound(mileStones) - LBound(mileStones)) 748 | j = 0 749 | For i = LBound(mileStones) To UBound(mileStones) 750 | ms(j) = mileStones(i) 751 | j = j + 1 752 | Next i 753 | End If 754 | ' tedious this is 755 | lb = LBound(ms) 756 | ub = UBound(ms) 757 | cb = ub - lb + 1 758 | ' only 1 milestone - thats the color 759 | If cb = 1 Then 760 | colorRamp = ms(lb) 761 | Exit Function 762 | End If 763 | 764 | If Not IsMissing(fractionStones) Then 765 | If UBound(fractionStones) - LBound(fractionStones) <> _ 766 | cb - 1 Then 767 | MsgBox ("no of fractions must equal number of steps") 768 | Exit Function 769 | Else 770 | ReDim fs(lb To ub) 771 | j = lb 772 | For i = LBound(fractionStones) To UBound(fractionStones) 773 | fs(j) = fractionStones(i) 774 | j = j + 1 775 | Next i 776 | 777 | End If 778 | Else 779 | ReDim fs(lb To ub) 780 | For i = lb + 1 To ub 781 | fs(i) = i / (cb - 1) 782 | Next i 783 | End If 784 | 'spread of range 785 | spread = max - min 786 | Debug.Assert spread >= 0 787 | If spread = 0 Then spread = 0.5 788 | ratio = (value - min) / spread 789 | Debug.Assert ratio >= 0 And ratio <= 1 790 | ' find which slot 791 | For i = lb + 1 To ub 792 | If ratio <= fs(i) Then 793 | r = (ratio - fs(i - 1)) / (fs(i) - fs(i - 1)) 794 | red = rgbRed(ms(i - 1)) + (rgbRed(ms(i)) - rgbRed(ms(i - 1))) * r 795 | blue = rgbBlue(ms(i - 1)) + (rgbBlue(ms(i)) - rgbBlue(ms(i - 1))) * r 796 | green = rgbGreen(ms(i - 1)) + (rgbGreen(ms(i)) - rgbGreen(ms(i - 1))) * r 797 | colorRamp = rgb(lumRGB(red, brighten), _ 798 | lumRGB(green, brighten), _ 799 | lumRGB(blue, brighten)) 800 | Exit Function 801 | End If 802 | Next i 803 | Debug.Assert False 804 | 805 | End Function 806 | 807 | 808 | Public Sub applyHeatMapToRange(rIn As Range, Optional libraryEntry As String = "heatmap") 809 | Dim mx As Variant, mn As Variant, r As Range, c As colorProps 810 | mx = Application.WorksheetFunction.max(rIn) 811 | mn = Application.WorksheetFunction.min(rIn) 812 | For Each r In rIn.Cells 813 | c = makeColorProps(rampLibraryRGB(libraryEntry, mn, mx, r.value)) 814 | r.Interior.Color = c.rgb 815 | r.Font.Color = c.textColor 816 | Next r 817 | End Sub 818 | Public Function hexColorOf(r As Range) As String 819 | ' this should be volatile but turning off 820 | ''Application.Volatile 821 | hexColorOf = rgbToHTMLHex(rgbColorOf(r)) 822 | End Function 823 | Public Function rgbColorOf(r As Range) As Long 824 | rgbColorOf = r.Interior.Color 825 | End Function 826 | Public Sub colorizeCell(target As Range, c As String) 827 | Dim p As colorProps 828 | If Len(c) > 1 And left(c, 1) = "#" Then 829 | p = makeColorProps(htmlHexToRgb(c)) 830 | target.Interior.Color = p.rgb 831 | target.Font.Color = p.textColor 832 | End If 833 | End Sub 834 | 835 | Private Function colorPropBigger(a As colorProps, b As colorProps, byProp As String, _ 836 | Optional descending As Boolean = False) As Boolean 837 | Dim result As Boolean 838 | 839 | Select Case LCase(byProp) 840 | Case "hue" 841 | result = a.hue > b.hue 842 | 843 | Case "saturation" 844 | result = a.saturation > b.saturation 845 | 846 | Case "lightness" 847 | result = a.lightness > b.lightness 848 | 849 | Case "lstar" 850 | result = a.LStar > b.LStar 851 | 852 | Case "cstar" 853 | result = a.cStar > b.cStar 854 | 855 | Case "hstar" 856 | result = a.hStar > b.hStar 857 | 858 | Case Else 859 | Debug.Assert False 860 | 861 | End Select 862 | If descending Then 863 | colorPropBigger = Not result 864 | Else 865 | colorPropBigger = result 866 | End If 867 | 868 | End Function 869 | 870 | Public Sub sortColorProp(pArray() As colorProps, inlow As Long, inhi As Long, byProp As String, _ 871 | Optional descending As Boolean = False) 872 | 873 | Dim p As colorProps, swap As colorProps, low As Long, hi As Long, half As Long 874 | 875 | 876 | If inlow < inhi Then 877 | half = (inlow + inhi) \ 2 878 | p = pArray(half) 879 | low = inlow 880 | hi = inhi 881 | Do 882 | Do While colorPropBigger(p, pArray(low), byProp, descending) 883 | low = low + 1 884 | Loop 885 | Do While colorPropBigger(pArray(hi), p, byProp, descending) 886 | hi = hi - 1 887 | Loop 888 | If (low <= hi) Then 889 | swap = pArray(low) 890 | pArray(low) = pArray(hi) 891 | pArray(hi) = swap 892 | low = low + 1 893 | hi = hi - 1 894 | End If 895 | 896 | Loop Until low > hi 897 | 898 | If hi <= half Then 899 | sortColorProp pArray, inlow, hi, byProp, descending 900 | sortColorProp pArray, low, inhi, byProp, descending 901 | Else 902 | sortColorProp pArray, low, inhi, byProp, descending 903 | sortColorProp pArray, inlow, hi, byProp, descending 904 | End If 905 | End If 906 | 907 | End Sub 908 | 909 | 910 | 911 | -------------------------------------------------------------------------------- /libraries/usefulColorStuff_vba.md: -------------------------------------------------------------------------------- 1 | # VBA Project: **vbaJavaScript** 2 | ## VBA Module: **[usefulColorStuff](/libraries/usefulColorStuff.vba "source is here")** 3 | ### Type: StdModule 4 | 5 | This procedure list for repo (vbaJavaScript) was automatically created on 6/25/2015 10:03:22 AM by VBAGit. 6 | For more information see the [desktop liberation site](http://ramblings.mcpher.com/Home/excelquirks/drivesdk/gettinggithubready "desktop liberation") 7 | 8 | Below is a section for each procedure in usefulColorStuff 9 | 10 | --- 11 | VBA Procedure: **getlStar** 12 | Type: **Function** 13 | Returns: **Double** 14 | Return description: **** 15 | Scope: **Public** 16 | Description: **** 17 | 18 | *Public Function getlStar(rgbColor As Long) As Double* 19 | 20 | *name*|*type*|*optional*|*default*|*description* 21 | ---|---|---|---|--- 22 | rgbColor|Long|False|| 23 | 24 | 25 | --- 26 | VBA Procedure: **getCstar** 27 | Type: **Function** 28 | Returns: **Double** 29 | Return description: **** 30 | Scope: **Public** 31 | Description: **** 32 | 33 | *Public Function getCstar(rgbColor As Long) As Double* 34 | 35 | *name*|*type*|*optional*|*default*|*description* 36 | ---|---|---|---|--- 37 | rgbColor|Long|False|| 38 | 39 | 40 | --- 41 | VBA Procedure: **getBstar** 42 | Type: **Function** 43 | Returns: **Double** 44 | Return description: **** 45 | Scope: **Public** 46 | Description: **** 47 | 48 | *Public Function getBstar(rgbColor As Long) As Double* 49 | 50 | *name*|*type*|*optional*|*default*|*description* 51 | ---|---|---|---|--- 52 | rgbColor|Long|False|| 53 | 54 | 55 | --- 56 | VBA Procedure: **getHstar** 57 | Type: **Function** 58 | Returns: **Double** 59 | Return description: **** 60 | Scope: **Public** 61 | Description: **** 62 | 63 | *Public Function getHstar(rgbColor As Long) As Double* 64 | 65 | *name*|*type*|*optional*|*default*|*description* 66 | ---|---|---|---|--- 67 | rgbColor|Long|False|| 68 | 69 | 70 | --- 71 | VBA Procedure: **getAstar** 72 | Type: **Function** 73 | Returns: **Double** 74 | Return description: **** 75 | Scope: **Public** 76 | Description: **** 77 | 78 | *Public Function getAstar(rgbColor As Long) As Double* 79 | 80 | *name*|*type*|*optional*|*default*|*description* 81 | ---|---|---|---|--- 82 | rgbColor|Long|False|| 83 | 84 | 85 | --- 86 | VBA Procedure: **fromRef** 87 | Type: **Function** 88 | Returns: **Double** 89 | Return description: **** 90 | Scope: **Public** 91 | Description: **** 92 | 93 | *Public Function fromRef(rgbColor As Long, ref As Long) As Double* 94 | 95 | *name*|*type*|*optional*|*default*|*description* 96 | ---|---|---|---|--- 97 | rgbColor|Long|False|| 98 | ref|Long|False|| 99 | 100 | 101 | --- 102 | VBA Procedure: **fromRefX** 103 | Type: **Function** 104 | Returns: **Double** 105 | Return description: **** 106 | Scope: **Public** 107 | Description: **** 108 | 109 | *Public Function fromRefX(rgbColor As Long) As Double* 110 | 111 | *name*|*type*|*optional*|*default*|*description* 112 | ---|---|---|---|--- 113 | rgbColor|Long|False|| 114 | 115 | 116 | --- 117 | VBA Procedure: **fromRefY** 118 | Type: **Function** 119 | Returns: **Double** 120 | Return description: **** 121 | Scope: **Public** 122 | Description: **** 123 | 124 | *Public Function fromRefY(rgbColor As Long) As Double* 125 | 126 | *name*|*type*|*optional*|*default*|*description* 127 | ---|---|---|---|--- 128 | rgbColor|Long|False|| 129 | 130 | 131 | --- 132 | VBA Procedure: **cellProperty** 133 | Type: **Function** 134 | Returns: **String** 135 | Return description: **** 136 | Scope: **Public** 137 | Description: **** 138 | 139 | *Public Function cellProperty(r As Range, p As String) As String* 140 | 141 | *name*|*type*|*optional*|*default*|*description* 142 | ---|---|---|---|--- 143 | r|Range|False|| 144 | p|String|False|| 145 | 146 | 147 | --- 148 | VBA Procedure: **cellCss** 149 | Type: **Function** 150 | Returns: **String** 151 | Return description: **** 152 | Scope: **Public** 153 | Description: **** 154 | 155 | *Public Function cellCss(r As Range, p As String) As String* 156 | 157 | *name*|*type*|*optional*|*default*|*description* 158 | ---|---|---|---|--- 159 | r|Range|False|| 160 | p|String|False|| 161 | 162 | 163 | --- 164 | VBA Procedure: **heatmapColor** 165 | Type: **Function** 166 | Returns: **Long** 167 | Return description: **** 168 | Scope: **Public** 169 | Description: **** 170 | 171 | *Public Function heatmapColor(min As Variant, max As Variant, value As Variant) As Long* 172 | 173 | *name*|*type*|*optional*|*default*|*description* 174 | ---|---|---|---|--- 175 | min|Variant|False|| 176 | max|Variant|False|| 177 | value|Variant|False|| 178 | 179 | 180 | --- 181 | VBA Procedure: **rgbExpose** 182 | Type: **Function** 183 | Returns: **Long** 184 | Return description: **** 185 | Scope: **Public** 186 | Description: **** 187 | 188 | *Public Function rgbExpose(r As Long, g As Long, b As Long) As Long* 189 | 190 | *name*|*type*|*optional*|*default*|*description* 191 | ---|---|---|---|--- 192 | r|Long|False|| 193 | g|Long|False|| 194 | b|Long|False|| 195 | 196 | 197 | --- 198 | VBA Procedure: **rgbRed** 199 | Type: **Function** 200 | Returns: **Long** 201 | Return description: **** 202 | Scope: **Public** 203 | Description: **** 204 | 205 | *Public Function rgbRed(rgbColor As Long) As Long* 206 | 207 | *name*|*type*|*optional*|*default*|*description* 208 | ---|---|---|---|--- 209 | rgbColor|Long|False|| 210 | 211 | 212 | --- 213 | VBA Procedure: **rgbGreen** 214 | Type: **Function** 215 | Returns: **Long** 216 | Return description: **** 217 | Scope: **Public** 218 | Description: **** 219 | 220 | *Public Function rgbGreen(rgbColor As Long) As Long* 221 | 222 | *name*|*type*|*optional*|*default*|*description* 223 | ---|---|---|---|--- 224 | rgbColor|Long|False|| 225 | 226 | 227 | --- 228 | VBA Procedure: **rgbBlue** 229 | Type: **Function** 230 | Returns: **Long** 231 | Return description: **** 232 | Scope: **Public** 233 | Description: **** 234 | 235 | *Public Function rgbBlue(rgbColor As Long) As Long* 236 | 237 | *name*|*type*|*optional*|*default*|*description* 238 | ---|---|---|---|--- 239 | rgbColor|Long|False|| 240 | 241 | 242 | --- 243 | VBA Procedure: **rgbToHex** 244 | Type: **Function** 245 | Returns: **String** 246 | Return description: **** 247 | Scope: **Public** 248 | Description: **** 249 | 250 | *Public Function rgbToHex(rgbColor As Long) As String* 251 | 252 | *name*|*type*|*optional*|*default*|*description* 253 | ---|---|---|---|--- 254 | rgbColor|Long|False|| 255 | 256 | 257 | --- 258 | VBA Procedure: **rgbToHTMLHex** 259 | Type: **Function** 260 | Returns: **String** 261 | Return description: **** 262 | Scope: **Public** 263 | Description: **** 264 | 265 | *Public Function rgbToHTMLHex(rgbColor As Long) As String* 266 | 267 | *name*|*type*|*optional*|*default*|*description* 268 | ---|---|---|---|--- 269 | rgbColor|Long|False|| 270 | 271 | 272 | --- 273 | VBA Procedure: **htmlHexToRgb** 274 | Type: **Function** 275 | Returns: **Long** 276 | Return description: **** 277 | Scope: **Public** 278 | Description: **** 279 | 280 | *Public Function htmlHexToRgb(htmlHex As String) As Long* 281 | 282 | *name*|*type*|*optional*|*default*|*description* 283 | ---|---|---|---|--- 284 | htmlHex|String|False|| 285 | 286 | 287 | --- 288 | VBA Procedure: **maskFormat** 289 | Type: **Function** 290 | Returns: **String** 291 | Return description: **** 292 | Scope: **Private** 293 | Description: **** 294 | 295 | *Private Function maskFormat(sIn As String, f As String) As String* 296 | 297 | *name*|*type*|*optional*|*default*|*description* 298 | ---|---|---|---|--- 299 | sIn|String|False|| 300 | f|String|False|| 301 | 302 | 303 | --- 304 | VBA Procedure: **lumRGB** 305 | Type: **Function** 306 | Returns: **Double** 307 | Return description: **** 308 | Scope: **Private** 309 | Description: **** 310 | 311 | *Private Function lumRGB(rgbCom As Double, brighten As Double) As Double* 312 | 313 | *name*|*type*|*optional*|*default*|*description* 314 | ---|---|---|---|--- 315 | rgbCom|Double|False|| 316 | brighten|Double|False|| 317 | 318 | 319 | --- 320 | VBA Procedure: **rgbToHsl** 321 | Type: **Function** 322 | Returns: **colorProps** 323 | Return description: **** 324 | Scope: **Public** 325 | Description: **** 326 | 327 | *Public Function rgbToHsl(rgbColor As Long) As colorProps* 328 | 329 | *name*|*type*|*optional*|*default*|*description* 330 | ---|---|---|---|--- 331 | rgbColor|Long|False|| 332 | 333 | 334 | --- 335 | VBA Procedure: **rgbToHsv** 336 | Type: **Function** 337 | Returns: **colorProps** 338 | Return description: **** 339 | Scope: **Private** 340 | Description: **** 341 | 342 | *Private Function rgbToHsv(rgbColor As Long) As colorProps* 343 | 344 | *name*|*type*|*optional*|*default*|*description* 345 | ---|---|---|---|--- 346 | rgbColor|Long|False|| 347 | 348 | 349 | --- 350 | VBA Procedure: **xyzCorrection** 351 | Type: **Function** 352 | Returns: **Double** 353 | Return description: **** 354 | Scope: **Private** 355 | Description: **** 356 | 357 | *Private Function xyzCorrection(v As Double) As Double* 358 | 359 | *name*|*type*|*optional*|*default*|*description* 360 | ---|---|---|---|--- 361 | v|Double|False|| 362 | 363 | 364 | --- 365 | VBA Procedure: **xyzCIECorrection** 366 | Type: **Function** 367 | Returns: **Double** 368 | Return description: **** 369 | Scope: **Private** 370 | Description: **** 371 | 372 | *Private Function xyzCIECorrection(v As Double) As Double* 373 | 374 | *name*|*type*|*optional*|*default*|*description* 375 | ---|---|---|---|--- 376 | v|Double|False|| 377 | 378 | 379 | --- 380 | VBA Procedure: **rgbToXyz** 381 | Type: **Function** 382 | Returns: **colorProps** 383 | Return description: **** 384 | Scope: **Private** 385 | Description: **** 386 | 387 | *Private Function rgbToXyz(rgbColor As Long) As colorProps* 388 | 389 | *name*|*type*|*optional*|*default*|*description* 390 | ---|---|---|---|--- 391 | rgbColor|Long|False|| 392 | 393 | 394 | --- 395 | VBA Procedure: **rgbToLab** 396 | Type: **Function** 397 | Returns: **colorProps** 398 | Return description: **** 399 | Scope: **Private** 400 | Description: **** 401 | 402 | *Private Function rgbToLab(rgbColor As Long) As colorProps* 403 | 404 | *name*|*type*|*optional*|*default*|*description* 405 | ---|---|---|---|--- 406 | rgbColor|Long|False|| 407 | 408 | 409 | --- 410 | VBA Procedure: **findNearestColorInRange** 411 | Type: **Function** 412 | Returns: **Range** 413 | Return description: **** 414 | Scope: **Public** 415 | Description: **** 416 | 417 | *Public Function findNearestColorInRange(rSearchFor As Range, rSearchIn As Range) As Range* 418 | 419 | *name*|*type*|*optional*|*default*|*description* 420 | ---|---|---|---|--- 421 | rSearchFor|Range|False|| 422 | rSearchIn|Range|False|| 423 | 424 | 425 | --- 426 | VBA Procedure: **compareColors** 427 | Type: **Function** 428 | Returns: **Double** 429 | Return description: **** 430 | Scope: **Public** 431 | Description: **** 432 | 433 | *Public Function compareColors(rgb1 As Long, rgb2 As Long, Optional compareType As eCompareColor = eCompareColor.eccieDe2000) As Double* 434 | 435 | *name*|*type*|*optional*|*default*|*description* 436 | ---|---|---|---|--- 437 | rgb1|Long|False|| 438 | rgb2|Long|False|| 439 | compareType|eCompareColor|True| eCompareColor.eccieDe2000| 440 | 441 | 442 | --- 443 | VBA Procedure: **cieDe2000** 444 | Type: **Function** 445 | Returns: **Double** 446 | Return description: **** 447 | Scope: **Public** 448 | Description: **** 449 | 450 | *Public Function cieDe2000(p1 As colorProps, p2 As colorProps) As Double* 451 | 452 | *name*|*type*|*optional*|*default*|*description* 453 | ---|---|---|---|--- 454 | p1|colorProps|False|| 455 | p2|colorProps|False|| 456 | 457 | 458 | --- 459 | VBA Procedure: **computeH** 460 | Type: **Function** 461 | Returns: **Double** 462 | Return description: **** 463 | Scope: **Private** 464 | Description: **** 465 | 466 | *Private Function computeH(a As Double, b As Double) As Double* 467 | 468 | *name*|*type*|*optional*|*default*|*description* 469 | ---|---|---|---|--- 470 | a|Double|False|| 471 | b|Double|False|| 472 | 473 | 474 | --- 475 | VBA Procedure: **hslToRgb** 476 | Type: **Function** 477 | Returns: **Long** 478 | Return description: **** 479 | Scope: **Public** 480 | Description: **** 481 | 482 | *Public Function hslToRgb(p As colorProps) As Long* 483 | 484 | *name*|*type*|*optional*|*default*|*description* 485 | ---|---|---|---|--- 486 | p|colorProps|False|| 487 | 488 | 489 | --- 490 | VBA Procedure: **hueToRgb** 491 | Type: **Function** 492 | Returns: **Double** 493 | Return description: **** 494 | Scope: **Private** 495 | Description: **** 496 | 497 | *Private Function hueToRgb(a As Double, b As Double, h As Double) As Double* 498 | 499 | *name*|*type*|*optional*|*default*|*description* 500 | ---|---|---|---|--- 501 | a|Double|False|| 502 | b|Double|False|| 503 | h|Double|False|| 504 | 505 | 506 | --- 507 | VBA Procedure: **makeColorProps** 508 | Type: **Function** 509 | Returns: **colorProps** 510 | Return description: **** 511 | Scope: **Public** 512 | Description: **** 513 | 514 | *Public Function makeColorProps(rgbColor As Long) As colorProps* 515 | 516 | *name*|*type*|*optional*|*default*|*description* 517 | ---|---|---|---|--- 518 | rgbColor|Long|False|| 519 | 520 | 521 | --- 522 | VBA Procedure: **pokeLchH** 523 | Type: **Function** 524 | Returns: **colorProps** 525 | Return description: **** 526 | Scope: **Public** 527 | Description: **** 528 | 529 | *Public Function pokeLchH(p As colorProps, newH As Double) As colorProps* 530 | 531 | *name*|*type*|*optional*|*default*|*description* 532 | ---|---|---|---|--- 533 | p|colorProps|False|| 534 | newH|Double|False|| 535 | 536 | 537 | --- 538 | VBA Procedure: **lchToLab** 539 | Type: **Function** 540 | Returns: **colorProps** 541 | Return description: **** 542 | Scope: **Public** 543 | Description: **** 544 | 545 | *Public Function lchToLab(p As colorProps) As colorProps* 546 | 547 | *name*|*type*|*optional*|*default*|*description* 548 | ---|---|---|---|--- 549 | p|colorProps|False|| 550 | 551 | 552 | --- 553 | VBA Procedure: **labxyzCorrection** 554 | Type: **Function** 555 | Returns: **Double** 556 | Return description: **** 557 | Scope: **Private** 558 | Description: **** 559 | 560 | *Private Function labxyzCorrection(x As Double) As Double* 561 | 562 | *name*|*type*|*optional*|*default*|*description* 563 | ---|---|---|---|--- 564 | x|Double|False|| 565 | 566 | 567 | --- 568 | VBA Procedure: **lchToRgb** 569 | Type: **Function** 570 | Returns: **Long** 571 | Return description: **** 572 | Scope: **Public** 573 | Description: **** 574 | 575 | *Public Function lchToRgb(p As colorProps) As Long* 576 | 577 | *name*|*type*|*optional*|*default*|*description* 578 | ---|---|---|---|--- 579 | p|colorProps|False|| 580 | 581 | 582 | --- 583 | VBA Procedure: **labToXyz** 584 | Type: **Function** 585 | Returns: **colorProps** 586 | Return description: **** 587 | Scope: **Private** 588 | Description: **** 589 | 590 | *Private Function labToXyz(p As colorProps) As colorProps* 591 | 592 | *name*|*type*|*optional*|*default*|*description* 593 | ---|---|---|---|--- 594 | p|colorProps|False|| 595 | 596 | 597 | --- 598 | VBA Procedure: **xyzrgbCorrection** 599 | Type: **Function** 600 | Returns: **Double** 601 | Return description: **** 602 | Scope: **Private** 603 | Description: **** 604 | 605 | *Private Function xyzrgbCorrection(x As Double) As Double* 606 | 607 | *name*|*type*|*optional*|*default*|*description* 608 | ---|---|---|---|--- 609 | x|Double|False|| 610 | 611 | 612 | --- 613 | VBA Procedure: **xyzToRgb** 614 | Type: **Function** 615 | Returns: **Long** 616 | Return description: **** 617 | Scope: **Public** 618 | Description: **** 619 | 620 | *Public Function xyzToRgb(p As colorProps) As Long* 621 | 622 | *name*|*type*|*optional*|*default*|*description* 623 | ---|---|---|---|--- 624 | p|colorProps|False|| 625 | 626 | 627 | --- 628 | VBA Procedure: **rgbWashout** 629 | Type: **Function** 630 | Returns: **Long** 631 | Return description: **** 632 | Scope: **Public** 633 | Description: **** 634 | 635 | *Public Function rgbWashout(rgbColor As Long) As Long* 636 | 637 | *name*|*type*|*optional*|*default*|*description* 638 | ---|---|---|---|--- 639 | rgbColor|Long|False|| 640 | 641 | 642 | --- 643 | VBA Procedure: **rgbToLch** 644 | Type: **Function** 645 | Returns: **colorProps** 646 | Return description: **** 647 | Scope: **Public** 648 | Description: **** 649 | 650 | *Public Function rgbToLch(rgbColor As Long) As colorProps* 651 | 652 | *name*|*type*|*optional*|*default*|*description* 653 | ---|---|---|---|--- 654 | rgbColor|Long|False|| 655 | 656 | 657 | --- 658 | VBA Procedure: **contrastRatio** 659 | Type: **Function** 660 | Returns: **Double** 661 | Return description: **** 662 | Scope: **Public** 663 | Description: **** 664 | 665 | *Public Function contrastRatio(rgbColorA As Long, rgbColorB As Long) As Double* 666 | 667 | *name*|*type*|*optional*|*default*|*description* 668 | ---|---|---|---|--- 669 | rgbColorA|Long|False|| 670 | rgbColorB|Long|False|| 671 | 672 | 673 | --- 674 | VBA Procedure: **w3Luminance** 675 | Type: **Function** 676 | Returns: **Double** 677 | Return description: **** 678 | Scope: **Public** 679 | Description: **** 680 | 681 | *Public Function w3Luminance(rgbColor As Long) As Double* 682 | 683 | *name*|*type*|*optional*|*default*|*description* 684 | ---|---|---|---|--- 685 | rgbColor|Long|False|| 686 | 687 | 688 | --- 689 | VBA Procedure: **rampLibraryRGB** 690 | Type: **Function** 691 | Returns: **Long** 692 | Return description: **** 693 | Scope: **Public** 694 | Description: **** 695 | 696 | *Public Function rampLibraryRGB(ramp As Variant, min As Variant, max As Variant, value As Variant, Optional brighten As Double = 1) As Long* 697 | 698 | *name*|*type*|*optional*|*default*|*description* 699 | ---|---|---|---|--- 700 | ramp|Variant|False|| 701 | min|Variant|False|| 702 | max|Variant|False|| 703 | value|Variant|False|| 704 | brighten|Double|True| 1| 705 | 706 | 707 | --- 708 | VBA Procedure: **colorRamp** 709 | Type: **Function** 710 | Returns: **Long** 711 | Return description: **** 712 | Scope: **Public** 713 | Description: **** 714 | 715 | *Public Function colorRamp(min As Variant, max As Variant, value As Variant, Optional mileStones As Variant, Optional fractionStones As Variant, Optional brighten As Double = 1) As Long* 716 | 717 | *name*|*type*|*optional*|*default*|*description* 718 | ---|---|---|---|--- 719 | min|Variant|False|| 720 | max|Variant|False|| 721 | value|Variant|False|| 722 | mileStones|Variant|True|| 723 | fractionStones|Variant|True|| 724 | brighten|Double|True| 1| 725 | 726 | 727 | --- 728 | VBA Procedure: **applyHeatMapToRange** 729 | Type: **Sub** 730 | Returns: **void** 731 | Return description: **** 732 | Scope: **Public** 733 | Description: **** 734 | 735 | *Public Sub applyHeatMapToRange(rIn As Range, Optional libraryEntry As String = "heatmap")* 736 | 737 | *name*|*type*|*optional*|*default*|*description* 738 | ---|---|---|---|--- 739 | rIn|Range|False|| 740 | libraryEntry|String|True| "heatmap"| 741 | 742 | 743 | --- 744 | VBA Procedure: **hexColorOf** 745 | Type: **Function** 746 | Returns: **String** 747 | Return description: **** 748 | Scope: **Public** 749 | Description: **** 750 | 751 | *Public Function hexColorOf(r As Range) As String* 752 | 753 | *name*|*type*|*optional*|*default*|*description* 754 | ---|---|---|---|--- 755 | r|Range|False|| 756 | 757 | 758 | --- 759 | VBA Procedure: **rgbColorOf** 760 | Type: **Function** 761 | Returns: **Long** 762 | Return description: **** 763 | Scope: **Public** 764 | Description: **** 765 | 766 | *Public Function rgbColorOf(r As Range) As Long* 767 | 768 | *name*|*type*|*optional*|*default*|*description* 769 | ---|---|---|---|--- 770 | r|Range|False|| 771 | 772 | 773 | --- 774 | VBA Procedure: **colorizeCell** 775 | Type: **Sub** 776 | Returns: **void** 777 | Return description: **** 778 | Scope: **Public** 779 | Description: **** 780 | 781 | *Public Sub colorizeCell(target As Range, c As String)* 782 | 783 | *name*|*type*|*optional*|*default*|*description* 784 | ---|---|---|---|--- 785 | target|Range|False|| 786 | c|String|False|| 787 | 788 | 789 | --- 790 | VBA Procedure: **colorPropBigger** 791 | Type: **Function** 792 | Returns: **Boolean** 793 | Return description: **** 794 | Scope: **Private** 795 | Description: **** 796 | 797 | *Private Function colorPropBigger(a As colorProps, b As colorProps, byProp As String, Optional descending As Boolean = False) As Boolean* 798 | 799 | *name*|*type*|*optional*|*default*|*description* 800 | ---|---|---|---|--- 801 | a|colorProps|False|| 802 | b|colorProps|False|| 803 | byProp|String|False|| 804 | descending|Boolean|True| False| 805 | 806 | 807 | --- 808 | VBA Procedure: **sortColorProp** 809 | Type: **Sub** 810 | Returns: **void** 811 | Return description: **** 812 | Scope: **Public** 813 | Description: **** 814 | 815 | *Public Sub sortColorProp(pArray() As colorProps, inlow As Long, inhi As Long, byProp As String, Optional descending As Boolean = False)* 816 | 817 | *name*|*type*|*optional*|*default*|*description* 818 | ---|---|---|---|--- 819 | pArray|Variant|False|| 820 | inlow|Long|False|| 821 | inhi|Long|False|| 822 | byProp|String|False|| 823 | descending|Boolean|True| False| 824 | -------------------------------------------------------------------------------- /libraries/usefulSheetStuff.vba: -------------------------------------------------------------------------------- 1 | Option Explicit 2 | ' v0.1 23.3.15 3 | Function firstCell(inrange As Range) As Range 4 | Set firstCell = inrange.Cells(1, 1) 5 | End Function 6 | Function lastCell(inrange As Range) As Range 7 | Set lastCell = inrange.Cells(inrange.rows.count, inrange.columns.count) 8 | End Function 9 | Function isSheet(o As Object) As Boolean 10 | Dim r As Range 11 | On Error GoTo handleError 12 | Set r = o.Cells 13 | isSheet = True 14 | Exit Function 15 | 16 | handleError: 17 | isSheet = False 18 | End Function 19 | Public Function findShape(sName As String, Optional ws As Worksheet = Nothing) As shape 20 | Dim s As shape, t As shape 21 | If ws Is Nothing Then Set ws = ActiveSheet 22 | For Each s In ws.Shapes 23 | If makeKey(s.name) = makeKey(sName) Then 24 | Set t = s 25 | Exit For 26 | End If 27 | If s.Type = msoGroup Then 28 | Set t = findRecurse(sName, s.GroupItems) 29 | If Not t Is Nothing Then 30 | Exit For 31 | End If 32 | End If 33 | Next s 34 | Set findShape = t 35 | 36 | End Function 37 | Public Function findRecurse(target As String, co As GroupShapes) As shape 38 | Dim s As shape, t As shape 39 | ' only works one level down.. cant get .gtoupitems to work properly 40 | For Each s In co 41 | If makeKey(s.name) = makeKey(target) Then 42 | Set t = s 43 | Exit For 44 | End If 45 | Next s 46 | Set findRecurse = t 47 | End Function 48 | 49 | Public Sub clearHyperLinks(ws As Worksheet) 50 | ' delete all the hyperlinks on a sheet 51 | With ws 52 | While .Hyperlinks.count > 0 53 | .Hyperlinks(1).Delete 54 | Wend 55 | End With 56 | End Sub 57 | Function sheetExists(sName As String, Optional complain As Boolean = True) As Worksheet 58 | 59 | On Error GoTo handleError 60 | Set sheetExists = Sheets(sName) 61 | Exit Function 62 | 63 | handleError: 64 | If complain Then MsgBox ("Could not open sheet " & sName) 65 | Set sheetExists = Nothing 66 | 67 | End Function 68 | Function wholeSheet(wn As String) As Range 69 | ' return a range representing the entire used worksheet 70 | Set wholeSheet = wholeWs(sheetExists(wn)) 71 | End Function 72 | Function wholeWs(ws As Worksheet) As Range 73 | Set wholeWs = ws.UsedRange 74 | End Function 75 | Function wholeRange(r As Range) As Range 76 | Set wholeRange = wholeWs(r.Worksheet) 77 | End Function 78 | Function cleanFind(x As Variant, r As Range, Optional complain As Boolean = False, _ 79 | Optional singlecell As Boolean = False) As Range 80 | ' does a normal .find, but catches where range is nothing 81 | Dim u As Range 82 | Set u = Nothing 83 | 84 | If r Is Nothing Then 85 | Set u = Nothing 86 | Else 87 | Set u = r.find(x, , xlValues, xlWhole) 88 | End If 89 | 90 | If singlecell And Not u Is Nothing Then 91 | Set u = firstCell(u) 92 | End If 93 | 94 | If complain And u Is Nothing Then 95 | Call msglost(x, r) 96 | End If 97 | 98 | Set cleanFind = u 99 | 100 | End Function 101 | Sub msglost(x As Variant, r As Range, Optional extra As String = "") 102 | 103 | MsgBox ("Couldnt find " & CStr(x) & " in " & SAd(r) & " " & extra) 104 | 105 | End Sub 106 | Function SAd(rngIn As Range, Optional target As Range = Nothing, Optional singlecell As Boolean = False, _ 107 | Optional removeRowDollar As Boolean = False, Optional removeColDollar As Boolean = False) As String 108 | Dim strA As String 109 | Dim r As Range 110 | Dim u As Range 111 | 112 | ' creates an address including the worksheet name 113 | strA = "" 114 | For Each r In rngIn.Areas 115 | Set u = r 116 | If singlecell Then 117 | Set u = firstCell(u) 118 | End If 119 | strA = strA + SAdOneRange(u, target, singlecell, removeRowDollar, removeColDollar) & "," 120 | Next r 121 | SAd = left(strA, Len(strA) - 1) 122 | End Function 123 | Function SAdOneRange(rngIn As Range, Optional target As Range = Nothing, Optional singlecell As Boolean = False, _ 124 | Optional removeRowDollar As Boolean = False, Optional removeColDollar As Boolean = False) As String 125 | Dim strA As String 126 | 127 | ' creates an address including the worksheet name 128 | 129 | strA = AddressNoDollars(rngIn, removeRowDollar, removeColDollar) 130 | 131 | ' dont bother with worksheet name if its on the same sheet, and its been asked to do that 132 | 133 | If Not target Is Nothing Then 134 | If target.Worksheet Is rngIn.Worksheet Then 135 | SAdOneRange = strA 136 | Exit Function 137 | End If 138 | End If 139 | 140 | ' otherwise add the sheet name 141 | 142 | SAdOneRange = "'" & rngIn.Worksheet.name & "'!" & strA 143 | 144 | End Function 145 | Function AddressNoDollars(a As Range, Optional doRow As Boolean = True, Optional doColumn As Boolean = True) As String 146 | ' return address minus the dollars 147 | Dim st As String 148 | Dim p1 As Long, p2 As Long 149 | AddressNoDollars = a.Address 150 | 151 | If doRow And doColumn Then 152 | AddressNoDollars = Replace(a.Address, "$", "") 153 | Else 154 | p1 = InStr(1, a.Address, "$") 155 | p2 = 0 156 | If p1 > 0 Then 157 | p2 = InStr(p1 + 1, a.Address, "$") 158 | End If 159 | ' turn $A$1 into A$1 160 | If doColumn And p1 > 0 Then 161 | AddressNoDollars = left(a.Address, p1 - 1) & Mid(a.Address, p1 + 1) 162 | 163 | ' turn $a$1 into $a1 164 | ElseIf doRow And p2 > 0 Then 165 | AddressNoDollars = left(a.Address, p2 - 1) & Mid(a.Address, p2 + 1, p2 - p1) 166 | 167 | End If 168 | End If 169 | 170 | 171 | End Function 172 | Function isReallyEmpty(r As Range) As Boolean 173 | Dim b As Boolean 174 | b = (Application.CountBlank(r) = r.Cells.count) 175 | 176 | isReallyEmpty = b 177 | End Function 178 | Function toEmptyRow(r As Range) As Range 179 | Dim o As Range, u As Range, w As Long 180 | ' returns to first blank row 181 | Set u = wholeRange(r) 182 | Set o = r 183 | w = lastCell(u).row + 1 184 | Do While True 185 | ' whats left in the sheet 186 | Set o = cleanFind(Empty, o.Resize(w, 1), True, True) 187 | If isReallyEmpty(o.Resize(1, r.columns.count)) Then 188 | Exit Do 189 | Else 190 | Set o = o.Offset(1) 191 | End If 192 | Loop 193 | 194 | If (o.row > lastCell(r).row And r.rows.count > 1) Then 195 | Set toEmptyRow = r 196 | Else 197 | If o.row > r.row Then 198 | Set toEmptyRow = r.Resize(o.row - r.row) 199 | Else 200 | MsgBox ("nothing on sheet") 201 | Set toEmptyRow = Nothing 202 | End If 203 | End If 204 | 205 | End Function 206 | Function toEmptyCol(r As Range) As Range 207 | 208 | Dim o As Range, u As Range, w As Long 209 | ' returns to first blank column 210 | Set u = wholeRange(r) 211 | Set o = r 212 | w = lastCell(u).column + 1 213 | Do While True 214 | Set o = cleanFind(Empty, o.Resize(1, w), True, True) 215 | If isReallyEmpty(toEmptyRow(o)) Then 216 | Exit Do 217 | Else 218 | Set o = o.Offset(, 1) 219 | End If 220 | Loop 221 | If (o.column > r.column) Then 222 | Set toEmptyCol = r.Resize(r.rows.count, o.column - r.column) 223 | End If 224 | End Function 225 | Function toEmptyBox(r As Range) As Range 226 | Set toEmptyBox = toEmptyCol(toEmptyRow(r)) 227 | End Function 228 | Public Function getLikelyColumnRange(Optional ws As Worksheet = Nothing) As Range 229 | ' figure out the likely default value for the refedit. 230 | Dim rstart As Range 231 | If ws Is Nothing Then 232 | Set rstart = wholeSheet(ActiveSheet.name) 233 | Else 234 | Set rstart = wholeSheet(ws.name) 235 | End If 236 | 237 | Set getLikelyColumnRange = toEmptyBox(rstart) 238 | 239 | End Function 240 | Sub deleteAllShapes(r As Range, startingwith As String) 241 | 242 | Dim l As Long 243 | With r.Worksheet 244 | For l = .Shapes.count To 1 Step -1 245 | If left(.Shapes(l).name, Len(startingwith)) = startingwith Then 246 | .Shapes(l).Delete 247 | End If 248 | Next l 249 | End With 250 | 251 | End Sub 252 | Function makearangeofShapes(r As Range, startingwith As String) As ShapeRange 253 | 254 | Dim s As shape 255 | 256 | Dim n() As String, sz As Long 257 | With r.Worksheet 258 | For Each s In .Shapes 259 | If left(s.name, Len(startingwith)) = startingwith Then 260 | sz = sz + 1 261 | ReDim Preserve n(1 To sz) As String 262 | n(sz) = s.name 263 | 264 | End If 265 | Next s 266 | Set makearangeofShapes = .Shapes.Range(n) 267 | End With 268 | 269 | End Function 270 | Public Function nameExists(s As String) As name 271 | On Error GoTo handle 272 | Set nameExists = ActiveWorkbook.names(s) 273 | Exit Function 274 | handle: 275 | Set nameExists = Nothing 276 | End Function 277 | Public Function whereIsThis(r As Variant) As Range 278 | Dim n As name 279 | 280 | If TypeName(r) = "range" Then 281 | Set whereIsThis = r 282 | Else 283 | Set n = nameExists(CStr(r)) 284 | If Not n Is Nothing Then 285 | Set whereIsThis = n.RefersToRange 286 | Else 287 | Set whereIsThis = Range(r) 288 | End If 289 | End If 290 | 291 | 292 | End Function 293 | Sub pivotCacheRefreshAll() 294 | 295 | Dim pc As PivotCache 296 | Dim ws As Worksheet 297 | 298 | With ActiveWorkbook 299 | For Each pc In .PivotCaches 300 | pc.refresh 301 | Next pc 302 | End With 303 | 304 | End Sub 305 | '--- based on trig at http://www.movable-type.co.uk/scripts/latlong.html 306 | Public Function getLatFromDistance(mLat As Double, d As Double, heading As Double) As Double 307 | Dim lat As Double 308 | ' convert ro radians 309 | lat = toRadians(mLat) 310 | getLatFromDistance = _ 311 | fromRadians( _ 312 | Application.WorksheetFunction.Asin(sIn(lat) * _ 313 | Cos(d / earthRadius) + _ 314 | Cos(lat) * _ 315 | sIn(d / earthRadius) * _ 316 | Cos(heading))) 317 | End Function 318 | Public Function getLonFromDistance(mLat As Double, mLon As Double, d As Double, heading As Double) As Double 319 | Dim lat As Double, lon As Double, newLat As Double 320 | ' convert ro radians 321 | lat = toRadians(mLat) 322 | lon = toRadians(mLon) 323 | newLat = toRadians(getLatFromDistance(mLat, d, heading)) 324 | getLonFromDistance = _ 325 | fromRadians( _ 326 | (lon + Application.WorksheetFunction.Atan2(Cos(d / earthRadius) - _ 327 | sIn(lat) * _ 328 | sIn(newLat), _ 329 | sIn(heading) * _ 330 | sIn(d / earthRadius) * _ 331 | Cos(lat)))) 332 | End Function 333 | Public Function earthRadius() As Double 334 | ' earth radius in km. 335 | earthRadius = 6371 336 | End Function 337 | Public Function toRadians(deg) 338 | toRadians = Application.WorksheetFunction.Pi / 180 * deg 339 | End Function 340 | Public Function fromRadians(rad) As Double 341 | 'convert radians to degress 342 | fromRadians = 180 / Application.WorksheetFunction.Pi * rad 343 | End Function 344 | Public Function min(ParamArray args() As Variant) 345 | min = Application.WorksheetFunction.min(args) 346 | End Function 347 | Public Function max(ParamArray args() As Variant) 348 | max = Application.WorksheetFunction.max(args) 349 | End Function 350 | Public Function toClipBoard(s As String) As String 351 | With New MSForms.DataObject 352 | .SetText s 353 | .PutInClipboard 354 | End With 355 | End Function 356 | 357 | Public Function importTabbed(fn As String, r As Range) As Range 358 | 359 | r.Worksheet.QueryTables.add(Connection:= _ 360 | "TEXT;" + fn, Destination:=r).refresh BackgroundQuery:=False 361 | 362 | Set importTabbed = r 363 | End Function 364 | 365 | -------------------------------------------------------------------------------- /libraries/usefulSheetStuff_vba.md: -------------------------------------------------------------------------------- 1 | # VBA Project: **vbaJavaScript** 2 | ## VBA Module: **[usefulSheetStuff](/libraries/usefulSheetStuff.vba "source is here")** 3 | ### Type: StdModule 4 | 5 | This procedure list for repo (vbaJavaScript) was automatically created on 6/25/2015 10:03:22 AM by VBAGit. 6 | For more information see the [desktop liberation site](http://ramblings.mcpher.com/Home/excelquirks/drivesdk/gettinggithubready "desktop liberation") 7 | 8 | Below is a section for each procedure in usefulSheetStuff 9 | 10 | --- 11 | VBA Procedure: **firstCell** 12 | Type: **Function** 13 | Returns: **Range** 14 | Return description: **** 15 | Scope: **Public** 16 | Description: **** 17 | 18 | *Function firstCell(inrange As Range) As Range* 19 | 20 | *name*|*type*|*optional*|*default*|*description* 21 | ---|---|---|---|--- 22 | inrange|Range|False|| 23 | 24 | 25 | --- 26 | VBA Procedure: **lastCell** 27 | Type: **Function** 28 | Returns: **Range** 29 | Return description: **** 30 | Scope: **Public** 31 | Description: **** 32 | 33 | *Function lastCell(inrange As Range) As Range* 34 | 35 | *name*|*type*|*optional*|*default*|*description* 36 | ---|---|---|---|--- 37 | inrange|Range|False|| 38 | 39 | 40 | --- 41 | VBA Procedure: **isSheet** 42 | Type: **Function** 43 | Returns: **Boolean** 44 | Return description: **** 45 | Scope: **Public** 46 | Description: **** 47 | 48 | *Function isSheet(o As Object) As Boolean* 49 | 50 | *name*|*type*|*optional*|*default*|*description* 51 | ---|---|---|---|--- 52 | o|Object|False|| 53 | 54 | 55 | --- 56 | VBA Procedure: **findShape** 57 | Type: **Function** 58 | Returns: **shape** 59 | Return description: **** 60 | Scope: **Public** 61 | Description: **** 62 | 63 | *Public Function findShape(sName As String, Optional ws As Worksheet = Nothing) As shape* 64 | 65 | *name*|*type*|*optional*|*default*|*description* 66 | ---|---|---|---|--- 67 | sName|String|False|| 68 | ws|Worksheet|True| Nothing| 69 | 70 | 71 | --- 72 | VBA Procedure: **findRecurse** 73 | Type: **Function** 74 | Returns: **shape** 75 | Return description: **** 76 | Scope: **Public** 77 | Description: **** 78 | 79 | *Public Function findRecurse(target As String, co As GroupShapes) As shape* 80 | 81 | *name*|*type*|*optional*|*default*|*description* 82 | ---|---|---|---|--- 83 | target|String|False|| 84 | co|GroupShapes|False|| 85 | 86 | 87 | --- 88 | VBA Procedure: **clearHyperLinks** 89 | Type: **Sub** 90 | Returns: **void** 91 | Return description: **** 92 | Scope: **Public** 93 | Description: **** 94 | 95 | *Public Sub clearHyperLinks(ws As Worksheet)* 96 | 97 | *name*|*type*|*optional*|*default*|*description* 98 | ---|---|---|---|--- 99 | ws|Worksheet|False|| 100 | 101 | 102 | --- 103 | VBA Procedure: **sheetExists** 104 | Type: **Function** 105 | Returns: **Worksheet** 106 | Return description: **** 107 | Scope: **Public** 108 | Description: **** 109 | 110 | *Function sheetExists(sName As String, Optional complain As Boolean = True) As Worksheet* 111 | 112 | *name*|*type*|*optional*|*default*|*description* 113 | ---|---|---|---|--- 114 | sName|String|False|| 115 | complain|Boolean|True| True| 116 | 117 | 118 | --- 119 | VBA Procedure: **wholeSheet** 120 | Type: **Function** 121 | Returns: **Range** 122 | Return description: **** 123 | Scope: **Public** 124 | Description: **** 125 | 126 | *Function wholeSheet(wn As String) As Range* 127 | 128 | *name*|*type*|*optional*|*default*|*description* 129 | ---|---|---|---|--- 130 | wn|String|False|| 131 | 132 | 133 | --- 134 | VBA Procedure: **wholeWs** 135 | Type: **Function** 136 | Returns: **Range** 137 | Return description: **** 138 | Scope: **Public** 139 | Description: **** 140 | 141 | *Function wholeWs(ws As Worksheet) As Range* 142 | 143 | *name*|*type*|*optional*|*default*|*description* 144 | ---|---|---|---|--- 145 | ws|Worksheet|False|| 146 | 147 | 148 | --- 149 | VBA Procedure: **wholeRange** 150 | Type: **Function** 151 | Returns: **Range** 152 | Return description: **** 153 | Scope: **Public** 154 | Description: **** 155 | 156 | *Function wholeRange(r As Range) As Range* 157 | 158 | *name*|*type*|*optional*|*default*|*description* 159 | ---|---|---|---|--- 160 | r|Range|False|| 161 | 162 | 163 | --- 164 | VBA Procedure: **cleanFind** 165 | Type: **Function** 166 | Returns: **Range** 167 | Return description: **** 168 | Scope: **Public** 169 | Description: **** 170 | 171 | *Function cleanFind(x As Variant, r As Range, Optional complain As Boolean = False, Optional singlecell As Boolean = False) As Range* 172 | 173 | *name*|*type*|*optional*|*default*|*description* 174 | ---|---|---|---|--- 175 | x|Variant|False|| 176 | r|Range|False|| 177 | complain|Boolean|True| False| 178 | singlecell|Boolean|True| False| 179 | 180 | 181 | --- 182 | VBA Procedure: **msglost** 183 | Type: **Sub** 184 | Returns: **void** 185 | Return description: **** 186 | Scope: **Public** 187 | Description: **** 188 | 189 | *Sub msglost(x As Variant, r As Range, Optional extra As String = "")* 190 | 191 | *name*|*type*|*optional*|*default*|*description* 192 | ---|---|---|---|--- 193 | x|Variant|False|| 194 | r|Range|False|| 195 | extra|String|True| ""| 196 | 197 | 198 | --- 199 | VBA Procedure: **SAd** 200 | Type: **Function** 201 | Returns: **String** 202 | Return description: **** 203 | Scope: **Public** 204 | Description: **** 205 | 206 | *Function SAd(rngIn As Range, Optional target As Range = Nothing, Optional singlecell As Boolean = False, Optional removeRowDollar As Boolean = False, Optional removeColDollar As Boolean = False) As String* 207 | 208 | *name*|*type*|*optional*|*default*|*description* 209 | ---|---|---|---|--- 210 | rngIn|Range|False|| 211 | target|Range|True| Nothing| 212 | singlecell|Boolean|True| False| 213 | removeRowDollar|Boolean|True| False| 214 | removeColDollar|Boolean|True| False| 215 | 216 | 217 | --- 218 | VBA Procedure: **SAdOneRange** 219 | Type: **Function** 220 | Returns: **String** 221 | Return description: **** 222 | Scope: **Public** 223 | Description: **** 224 | 225 | *Function SAdOneRange(rngIn As Range, Optional target As Range = Nothing, Optional singlecell As Boolean = False, Optional removeRowDollar As Boolean = False, Optional removeColDollar As Boolean = False) As String* 226 | 227 | *name*|*type*|*optional*|*default*|*description* 228 | ---|---|---|---|--- 229 | rngIn|Range|False|| 230 | target|Range|True| Nothing| 231 | singlecell|Boolean|True| False| 232 | removeRowDollar|Boolean|True| False| 233 | removeColDollar|Boolean|True| False| 234 | 235 | 236 | --- 237 | VBA Procedure: **AddressNoDollars** 238 | Type: **Function** 239 | Returns: **String** 240 | Return description: **** 241 | Scope: **Public** 242 | Description: **** 243 | 244 | *Function AddressNoDollars(a As Range, Optional doRow As Boolean = True, Optional doColumn As Boolean = True) As String* 245 | 246 | *name*|*type*|*optional*|*default*|*description* 247 | ---|---|---|---|--- 248 | a|Range|False|| 249 | doRow|Boolean|True| True| 250 | doColumn|Boolean|True| True| 251 | 252 | 253 | --- 254 | VBA Procedure: **isReallyEmpty** 255 | Type: **Function** 256 | Returns: **Boolean** 257 | Return description: **** 258 | Scope: **Public** 259 | Description: **** 260 | 261 | *Function isReallyEmpty(r As Range) As Boolean* 262 | 263 | *name*|*type*|*optional*|*default*|*description* 264 | ---|---|---|---|--- 265 | r|Range|False|| 266 | 267 | 268 | --- 269 | VBA Procedure: **toEmptyRow** 270 | Type: **Function** 271 | Returns: **Range** 272 | Return description: **** 273 | Scope: **Public** 274 | Description: **** 275 | 276 | *Function toEmptyRow(r As Range) As Range* 277 | 278 | *name*|*type*|*optional*|*default*|*description* 279 | ---|---|---|---|--- 280 | r|Range|False|| 281 | 282 | 283 | --- 284 | VBA Procedure: **toEmptyCol** 285 | Type: **Function** 286 | Returns: **Range** 287 | Return description: **** 288 | Scope: **Public** 289 | Description: **** 290 | 291 | *Function toEmptyCol(r As Range) As Range* 292 | 293 | *name*|*type*|*optional*|*default*|*description* 294 | ---|---|---|---|--- 295 | r|Range|False|| 296 | 297 | 298 | --- 299 | VBA Procedure: **toEmptyBox** 300 | Type: **Function** 301 | Returns: **Range** 302 | Return description: **** 303 | Scope: **Public** 304 | Description: **** 305 | 306 | *Function toEmptyBox(r As Range) As Range* 307 | 308 | *name*|*type*|*optional*|*default*|*description* 309 | ---|---|---|---|--- 310 | r|Range|False|| 311 | 312 | 313 | --- 314 | VBA Procedure: **getLikelyColumnRange** 315 | Type: **Function** 316 | Returns: **Range** 317 | Return description: **** 318 | Scope: **Public** 319 | Description: **** 320 | 321 | *Public Function getLikelyColumnRange(Optional ws As Worksheet = Nothing) As Range* 322 | 323 | *name*|*type*|*optional*|*default*|*description* 324 | ---|---|---|---|--- 325 | ws|Worksheet|True| Nothing| 326 | 327 | 328 | --- 329 | VBA Procedure: **deleteAllShapes** 330 | Type: **Sub** 331 | Returns: **void** 332 | Return description: **** 333 | Scope: **Public** 334 | Description: **** 335 | 336 | *Sub deleteAllShapes(r As Range, startingwith As String)* 337 | 338 | *name*|*type*|*optional*|*default*|*description* 339 | ---|---|---|---|--- 340 | r|Range|False|| 341 | startingwith|String|False|| 342 | 343 | 344 | --- 345 | VBA Procedure: **makearangeofShapes** 346 | Type: **Function** 347 | Returns: **ShapeRange** 348 | Return description: **** 349 | Scope: **Public** 350 | Description: **** 351 | 352 | *Function makearangeofShapes(r As Range, startingwith As String) As ShapeRange* 353 | 354 | *name*|*type*|*optional*|*default*|*description* 355 | ---|---|---|---|--- 356 | r|Range|False|| 357 | startingwith|String|False|| 358 | 359 | 360 | --- 361 | VBA Procedure: **nameExists** 362 | Type: **Function** 363 | Returns: **name** 364 | Return description: **** 365 | Scope: **Public** 366 | Description: **** 367 | 368 | *Public Function nameExists(s As String) As name* 369 | 370 | *name*|*type*|*optional*|*default*|*description* 371 | ---|---|---|---|--- 372 | s|String|False|| 373 | 374 | 375 | --- 376 | VBA Procedure: **whereIsThis** 377 | Type: **Function** 378 | Returns: **Range** 379 | Return description: **** 380 | Scope: **Public** 381 | Description: **** 382 | 383 | *Public Function whereIsThis(r As Variant) As Range* 384 | 385 | *name*|*type*|*optional*|*default*|*description* 386 | ---|---|---|---|--- 387 | r|Variant|False|| 388 | 389 | 390 | --- 391 | VBA Procedure: **pivotCacheRefreshAll** 392 | Type: **Sub** 393 | Returns: **void** 394 | Return description: **** 395 | Scope: **Public** 396 | Description: **** 397 | 398 | *Sub pivotCacheRefreshAll()* 399 | 400 | **no arguments required for this procedure** 401 | 402 | 403 | --- 404 | VBA Procedure: **getLatFromDistance** 405 | Type: **Function** 406 | Returns: **Double** 407 | Return description: **** 408 | Scope: **Public** 409 | Description: **** 410 | 411 | *Public Function getLatFromDistance(mLat As Double, d As Double, heading As Double) As Double* 412 | 413 | *name*|*type*|*optional*|*default*|*description* 414 | ---|---|---|---|--- 415 | mLat|Double|False|| 416 | d|Double|False|| 417 | heading|Double|False|| 418 | 419 | 420 | --- 421 | VBA Procedure: **getLonFromDistance** 422 | Type: **Function** 423 | Returns: **Double** 424 | Return description: **** 425 | Scope: **Public** 426 | Description: **** 427 | 428 | *Public Function getLonFromDistance(mLat As Double, mLon As Double, d As Double, heading As Double) As Double* 429 | 430 | *name*|*type*|*optional*|*default*|*description* 431 | ---|---|---|---|--- 432 | mLat|Double|False|| 433 | mLon|Double|False|| 434 | d|Double|False|| 435 | heading|Double|False|| 436 | 437 | 438 | --- 439 | VBA Procedure: **earthRadius** 440 | Type: **Function** 441 | Returns: **Double** 442 | Return description: **** 443 | Scope: **Public** 444 | Description: **** 445 | 446 | *Public Function earthRadius() As Double* 447 | 448 | **no arguments required for this procedure** 449 | 450 | 451 | --- 452 | VBA Procedure: **toRadians** 453 | Type: **Function** 454 | Returns: **Variant** 455 | Return description: **** 456 | Scope: **Public** 457 | Description: **** 458 | 459 | *Public Function toRadians(deg)* 460 | 461 | *name*|*type*|*optional*|*default*|*description* 462 | ---|---|---|---|--- 463 | deg|Variant|False|| 464 | 465 | 466 | --- 467 | VBA Procedure: **fromRadians** 468 | Type: **Function** 469 | Returns: **Double** 470 | Return description: **** 471 | Scope: **Public** 472 | Description: **** 473 | 474 | *Public Function fromRadians(rad) As Double* 475 | 476 | *name*|*type*|*optional*|*default*|*description* 477 | ---|---|---|---|--- 478 | rad|Variant|False|| 479 | 480 | 481 | --- 482 | VBA Procedure: **min** 483 | Type: **Function** 484 | Returns: **Variant** 485 | Return description: **** 486 | Scope: **Public** 487 | Description: **** 488 | 489 | *Public Function min(ParamArray args() As Variant)* 490 | 491 | *name*|*type*|*optional*|*default*|*description* 492 | ---|---|---|---|--- 493 | ParamArray|Variant|False|| 494 | 495 | 496 | --- 497 | VBA Procedure: **max** 498 | Type: **Function** 499 | Returns: **Variant** 500 | Return description: **** 501 | Scope: **Public** 502 | Description: **** 503 | 504 | *Public Function max(ParamArray args() As Variant)* 505 | 506 | *name*|*type*|*optional*|*default*|*description* 507 | ---|---|---|---|--- 508 | ParamArray|Variant|False|| 509 | 510 | 511 | --- 512 | VBA Procedure: **toClipBoard** 513 | Type: **Function** 514 | Returns: **String** 515 | Return description: **** 516 | Scope: **Public** 517 | Description: **** 518 | 519 | *Public Function toClipBoard(s As String) As String* 520 | 521 | *name*|*type*|*optional*|*default*|*description* 522 | ---|---|---|---|--- 523 | s|String|False|| 524 | 525 | 526 | --- 527 | VBA Procedure: **importTabbed** 528 | Type: **Function** 529 | Returns: **Range** 530 | Return description: **** 531 | Scope: **Public** 532 | Description: **** 533 | 534 | *Public Function importTabbed(fn As String, r As Range) As Range* 535 | 536 | *name*|*type*|*optional*|*default*|*description* 537 | ---|---|---|---|--- 538 | fn|String|False|| 539 | r|Range|False|| 540 | -------------------------------------------------------------------------------- /libraries/usefulStuff.vba: -------------------------------------------------------------------------------- 1 | 'gistThat@mcpher.com :do not modify this line - see ramblings.mcpher.com for details: updated on 8/18/2014 4:48:00 PM : from manifest:7471153 gist https://gist.github.com/brucemcpherson/3414346/raw 2 | Option Explicit 3 | ' v2.23 3414346 4 | 5 | ' Acknowledgement for the microtimer procedures used here to 6 | ' thanks to Charles Wheeler - http://www.decisionmodels.com/ 7 | ' --- 8 | 9 | #If VBA7 And Win64 Then 10 | 11 | Private Declare PtrSafe Function getTickCount _ 12 | Lib "kernel32" Alias "QueryPerformanceCounter" (cyTickCount As Currency) As Long 13 | 14 | Private Declare PtrSafe Function getFrequency _ 15 | Lib "kernel32" Alias "QueryPerformanceFrequency" (cyFrequency As Currency) As Long 16 | 17 | Private Declare PtrSafe Function ShellExecute _ 18 | Lib "shell32.dll" Alias "ShellExecuteA" ( _ 19 | ByVal hwnd As Long, _ 20 | ByVal Operation As String, _ 21 | ByVal fileName As String, _ 22 | Optional ByVal Parameters As String, _ 23 | Optional ByVal Directory As String, _ 24 | Optional ByVal WindowStyle As Long = vbMaximizedFocus _ 25 | ) As Longlong 26 | 27 | Private Declare PtrSafe Function WideCharToMultiByte Lib "kernel32" ( _ 28 | ByVal CodePage As Longlong, ByVal dwflags As Longlong, _ 29 | ByVal lpWideCharStr As Longlong, ByVal cchWideChar As Longlong, _ 30 | ByVal lpMultiByteStr As Longlong, ByVal cchMultiByte As Longlong, _ 31 | ByVal lpDefaultChar As Longlong, ByVal lpUsedDefaultChar As Longlong) As Longlong 32 | 33 | 34 | #Else 35 | 36 | Private Declare Function getTickCount Lib "kernel32" Alias "QueryPerformanceCounter" (cyTickCount As Currency) As Long 37 | Private Declare Function getFrequency Lib "kernel32" Alias "QueryPerformanceFrequency" (cyFrequency As Currency) As Long 38 | Private Declare Function ShellExecute _ 39 | Lib "shell32.dll" Alias "ShellExecuteA" ( _ 40 | ByVal hwnd As Long, _ 41 | ByVal Operation As String, _ 42 | ByVal fileName As String, _ 43 | Optional ByVal Parameters As String, _ 44 | Optional ByVal Directory As String, _ 45 | Optional ByVal WindowStyle As Long = vbMaximizedFocus _ 46 | ) As Long 47 | 48 | Private Declare Function WideCharToMultiByte Lib "kernel32" ( _ 49 | ByVal CodePage As Long, ByVal dwflags As Long, _ 50 | ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, _ 51 | ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, _ 52 | ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long 53 | 54 | #End If 55 | 56 | ' note original execute shell stuff came from this post 57 | ' http://stackoverflow.com/questions/3166265/open-an-html-page-in-default-browser-with-vba 58 | ' thanks to http://stackoverflow.com/users/174718/dmr 59 | 60 | Private Const CP_UTF8 = 65001 61 | Public Const cFailedtoGetHandle = -1 62 | 63 | Public Function OpenUrl(url) As Boolean 64 | #If VBA7 And Win64 Then 65 | Dim lSuccess As Longlong 66 | #Else 67 | Dim lSuccess As Long 68 | #End If 69 | lSuccess = ShellExecute(0, "Open", url) 70 | OpenUrl = lSuccess > 32 71 | End Function 72 | 73 | Sub deleteAllFromCollection(co As Collection) 74 | Dim o As Object, i As Long 75 | For i = co.count To 1 Step -1 76 | co(i).Delete 77 | Next i 78 | 79 | End Sub 80 | 81 | 82 | Public Function UTF16To8(ByVal UTF16 As String) As String 83 | Dim sBuffer As String 84 | #If VBA7 And Win64 Then 85 | Dim lLength As Longlong 86 | #Else 87 | Dim lLength As Long 88 | #End If 89 | If UTF16 <> "" Then 90 | lLength = WideCharToMultiByte(CP_UTF8, 0, StrPtr(UTF16), -1, 0, 0, 0, 0) 91 | sBuffer = Space$(CLng(lLength)) 92 | lLength = WideCharToMultiByte( _ 93 | CP_UTF8, 0, StrPtr(UTF16), -1, StrPtr(sBuffer), Len(sBuffer), 0, 0) 94 | sBuffer = StrConv(sBuffer, vbUnicode) 95 | UTF16To8 = left$(sBuffer, CLng(lLength - 1)) 96 | Else 97 | UTF16To8 = "" 98 | End If 99 | End Function 100 | 'end of utf16to8 101 | 102 | 103 | Public Function URLEncode( _ 104 | StringVal As String, _ 105 | Optional SpaceAsPlus As Boolean = False, _ 106 | Optional UTF8Encode As Boolean = True _ 107 | ) As String 108 | 109 | Dim StringValCopy As String: StringValCopy = _ 110 | IIf(UTF8Encode, UTF16To8(StringVal), StringVal) 111 | Dim StringLen As Long: StringLen = Len(StringValCopy) 112 | 113 | If StringLen > 0 Then 114 | ReDim result(StringLen) As String 115 | Dim i As Long, CharCode As Integer 116 | Dim Char As String, Space As String 117 | 118 | If SpaceAsPlus Then Space = "+" Else Space = "%20" 119 | 120 | For i = 1 To StringLen 121 | Char = Mid$(StringValCopy, i, 1) 122 | CharCode = Asc(Char) 123 | Select Case CharCode 124 | Case 97 To 122, 65 To 90, 48 To 57, 45, 46, 95, 126 125 | result(i) = Char 126 | Case 32 127 | result(i) = Space 128 | Case 0 To 15 129 | result(i) = "%0" & Hex(CharCode) 130 | Case Else 131 | result(i) = "%" & Hex(CharCode) 132 | End Select 133 | Next i 134 | URLEncode = Join(result, "") 135 | 136 | End If 137 | End Function 138 | Public Sub cloneFormat(b As Range, a As Range) 139 | 140 | ' this probably needs additional properties copied over 141 | With a.Interior 142 | .Color = b.Interior.Color 143 | End With 144 | With a.Font 145 | .Color = b.Font.Color 146 | .size = b.Font.size 147 | End With 148 | With a 149 | .HorizontalAlignment = b.HorizontalAlignment 150 | .VerticalAlignment = b.VerticalAlignment 151 | 152 | End With 153 | 154 | End Sub 155 | Public Function compareAsKey(a As Variant, b As Variant, Optional asKey As Boolean = True) As Boolean 156 | If (asKey And TypeName(a) = "String" And TypeName(b) = "String") Then 157 | compareAsKey = (makeKey(a) = makeKey(b)) 158 | Else 159 | compareAsKey = (a = b) 160 | 161 | End If 162 | End Function 163 | ' sort a collection 164 | Function SortColl(ByRef coll As Collection, eorder As Long) As Long 165 | Dim ita As Long, itb As Long 166 | Dim va As Variant, vb As Variant, bSwap As Boolean 167 | Dim x As Object, y As Object 168 | 169 | For ita = 1 To coll.count - 1 170 | For itb = ita + 1 To coll.count 171 | Set x = coll(ita) 172 | Set y = coll(itb) 173 | bSwap = x.needSwap(y, eorder) 174 | If bSwap Then 175 | With coll 176 | Set va = coll(ita) 177 | Set vb = coll(itb) 178 | .add va, , itb 179 | .add vb, , ita 180 | .remove ita + 1 181 | .remove itb + 1 182 | End With 183 | End If 184 | Next 185 | Next 186 | End Function 187 | Public Function getHandle(sName As String, Optional readOnly As Boolean = False) As Integer 188 | Dim hand As Integer 189 | On Error GoTo handleError 190 | hand = FreeFile 191 | If (readOnly) Then 192 | Open sName For Input As hand 193 | Else 194 | Open sName For Output As hand 195 | End If 196 | getHandle = hand 197 | Exit Function 198 | 199 | handleError: 200 | MsgBox ("Could not open file " & sName) 201 | getHandle = cFailedtoGetHandle 202 | End Function 203 | Function afConcat(arr() As Variant) As String 204 | Dim i As Long, s As String 205 | s = "" 206 | For i = LBound(arr) To UBound(arr) 207 | s = s & arr(i, 1) & "|" 208 | Next i 209 | afConcat = s 210 | End Function 211 | Public Function quote(s As String) As String 212 | quote = q & s & q 213 | End Function 214 | Public Function q() As String 215 | q = Chr(34) 216 | End Function 217 | Public Function qs() As String 218 | qs = Chr(39) 219 | End Function 220 | Public Function bracket(s As String) As String 221 | bracket = "(" & s & ")" 222 | End Function 223 | Public Function list(ParamArray args() As Variant) As String 224 | Dim i As Long, s As String 225 | s = vbNullString 226 | For i = LBound(args) To UBound(args) 227 | If s <> vbNullString Then s = s & "," 228 | s = s & CStr(args(i)) 229 | Next i 230 | list = s 231 | End Function 232 | 233 | Public Function qlist(ParamArray args() As Variant) As String 234 | Dim i As Long, s As String 235 | s = vbNullString 236 | For i = LBound(args) To UBound(args) 237 | If s <> vbNullString Then s = s & "," 238 | s = s & quote(CStr(args(i))) 239 | Next i 240 | qlist = s 241 | End Function 242 | Public Function diminishingReturn(val As Double, Optional s As Double = 10) As Double 243 | diminishingReturn = Sgn(val) * s * (Sqr(2 * (Sgn(val) * val / s) + 1) - 1) 244 | End Function 245 | Public Function superTrim(s As String) As String 246 | Dim c As cStringChunker 247 | Set c = New cStringChunker 248 | superTrim = c.add(s).chopSuperTrim.toString 249 | 250 | End Function 251 | Public Function makeKey(v As Variant) As String 252 | makeKey = LCase(Trim(CStr(v))) 253 | End Function 254 | ' The below is taken from http://stackoverflow.com/questions/496751/base64-encode-string-in-vbscript 255 | Function Base64Encode(sText) 256 | Dim oXML, oNode 257 | Set oXML = createObject("Msxml2.DOMDocument.3.0") 258 | Set oNode = oXML.createElement("base64") 259 | oNode.DataType = "bin.base64" 260 | oNode.nodeTypedValue = Stream_StringToBinary(sText) 261 | ' function inserts line feeds so we need to get rid of them 262 | Base64Encode = Replace(oNode.Text, vbLf, "") 263 | Set oNode = Nothing 264 | Set oXML = Nothing 265 | End Function 266 | 'Stream_StringToBinary Function 267 | '2003 Antonin Foller, http://www.motobit.com 268 | 'Text - string parameter To convert To binary data 269 | Function Stream_StringToBinary(Text) 270 | Const adTypeText = 2 271 | Const adTypeBinary = 1 272 | 273 | 'Create Stream object 274 | Dim BinaryStream 'As New Stream 275 | Set BinaryStream = createObject("ADODB.Stream") 276 | 277 | 'Specify stream type - we want To save text/string data. 278 | BinaryStream.Type = adTypeText 279 | 280 | 'Specify charset For the source text (unicode) data. 281 | BinaryStream.Charset = "us-ascii" 282 | 283 | 'Open the stream And write text/string data To the object 284 | BinaryStream.Open 285 | BinaryStream.WriteText Text 286 | 287 | 'Change stream type To binary 288 | BinaryStream.Position = 0 289 | BinaryStream.Type = adTypeBinary 290 | 291 | 'Ignore first two bytes - sign of 292 | BinaryStream.Position = 0 293 | 294 | 'Open the stream And get binary data from the object 295 | Stream_StringToBinary = BinaryStream.Read 296 | 297 | Set BinaryStream = Nothing 298 | End Function 299 | 300 | 'Stream_BinaryToString Function 301 | '2003 Antonin Foller, http://www.motobit.com 302 | 'Binary - VT_UI1 | VT_ARRAY data To convert To a string 303 | Function Stream_BinaryToString(Binary) 304 | Const adTypeText = 2 305 | Const adTypeBinary = 1 306 | 307 | 'Create Stream object 308 | Dim BinaryStream 'As New Stream 309 | Set BinaryStream = createObject("ADODB.Stream") 310 | 311 | 'Specify stream type - we want To save text/string data. 312 | BinaryStream.Type = adTypeBinary 313 | 314 | 'Open the stream And write text/string data To the object 315 | BinaryStream.Open 316 | BinaryStream.write Binary 317 | 318 | 'Change stream type To binary 319 | BinaryStream.Position = 0 320 | BinaryStream.Type = adTypeText 321 | 322 | 'Specify charset For the source text (unicode) data. 323 | BinaryStream.Charset = "us-ascii" 324 | 325 | 'Open the stream And get binary data from the object 326 | Stream_BinaryToString = BinaryStream.ReadText 327 | Set BinaryStream = Nothing 328 | End Function 329 | ' Decodes a base-64 encoded string (BSTR type). 330 | ' 1999 - 2004 Antonin Foller, http://www.motobit.com 331 | ' 1.01 - solves problem with Access And 'Compare Database' (InStr) 332 | Function Base64Decode(ByVal base64String) 333 | 'rfc1521 334 | '1999 Antonin Foller, Motobit Software, http://Motobit.cz 335 | Const Base64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" 336 | Dim dataLength, sOut, groupBegin 337 | 338 | 'remove white spaces, If any 339 | base64String = Replace(base64String, vbCrLf, "") 340 | base64String = Replace(base64String, vbTab, "") 341 | base64String = Replace(base64String, " ", "") 342 | base64String = Replace(base64String, vbLf, "") 343 | 344 | 'The source must consists from groups with Len of 4 chars 345 | dataLength = Len(base64String) 346 | If dataLength Mod 4 <> 0 Then 347 | Err.Raise 1, "Base64Decode", "Bad Base64 string." 348 | Exit Function 349 | End If 350 | 351 | 352 | ' Now decode each group: 353 | For groupBegin = 1 To dataLength Step 4 354 | Dim numDataBytes, CharCounter, thisChar, thisData, nGroup, pOut 355 | ' Each data group encodes up To 3 actual bytes. 356 | numDataBytes = 3 357 | nGroup = 0 358 | 359 | For CharCounter = 0 To 3 360 | ' Convert each character into 6 bits of data, And add it To 361 | ' an integer For temporary storage. If a character is a '=', there 362 | ' is one fewer data byte. (There can only be a maximum of 2 '=' In 363 | ' the whole string.) 364 | 365 | thisChar = Mid(base64String, groupBegin + CharCounter, 1) 366 | 367 | If thisChar = "=" Then 368 | numDataBytes = numDataBytes - 1 369 | thisData = 0 370 | Else 371 | thisData = InStr(1, Base64, thisChar, vbBinaryCompare) - 1 372 | End If 373 | If thisData = -1 Then 374 | Err.Raise 2, "Base64Decode", "Bad character In Base64 string." 375 | Exit Function 376 | End If 377 | 378 | nGroup = 64 * nGroup + thisData 379 | Next 380 | 381 | 'Hex splits the long To 6 groups with 4 bits 382 | nGroup = Hex(nGroup) 383 | 384 | 'Add leading zeros 385 | nGroup = String(6 - Len(nGroup), "0") & nGroup 386 | 387 | 'Convert the 3 byte hex integer (6 chars) To 3 characters 388 | pOut = Chr(CByte("&H" & Mid(nGroup, 1, 2))) + _ 389 | Chr(CByte("&H" & Mid(nGroup, 3, 2))) + _ 390 | Chr(CByte("&H" & Mid(nGroup, 5, 2))) 391 | 392 | 'add numDataBytes characters To out string 393 | sOut = sOut & left(pOut, numDataBytes) 394 | Next 395 | 396 | Base64Decode = sOut 397 | End Function 398 | Public Function openNewHtml(sName As String, sContent As String) As Boolean 399 | Dim handle As Integer 400 | 401 | handle = getHandle(sName) 402 | If (handle <> cFailedtoGetHandle) Then 403 | Print #handle, sContent 404 | Close #handle 405 | openNewHtml = True 406 | End If 407 | 408 | End Function 409 | Public Function readFromFile(sName As String) As String 410 | Dim handle As Integer 411 | handle = getHandle(sName, True) 412 | If (handle <> cFailedtoGetHandle) Then 413 | readFromFile = Input$(LOF(handle), #handle) 414 | Close #handle 415 | End If 416 | End Function 417 | Public Function arrayLength(a) As Long 418 | arrayLength = UBound(a) - LBound(a) + 1 419 | End Function 420 | Public Function getControlValue(ctl As Object) As Variant 421 | Select Case TypeName(ctl) 422 | Case "Shape" 423 | getControlValue = ctl.TextFrame.Characters.Text 424 | Case "Label" 425 | getControlValue = ctl.Caption 426 | Case Else 427 | getControlValue = ctl.value 428 | End Select 429 | End Function 430 | Public Function setControlValue(ctl As Object, v As Variant) As Variant 431 | Select Case TypeName(ctl) 432 | Case "Shape" 433 | ctl.TextFrame.Characters.Text = v 434 | Case "Label" 435 | ctl.Caption = v 436 | Case Else 437 | ctl.value = v 438 | End Select 439 | setControlValue = v 440 | End Function 441 | Public Function isinCollection(vCollect As Variant, sid As Variant) As Boolean 442 | Dim v As Variant 443 | If Not vCollect Is Nothing Then 444 | On Error GoTo handle 445 | Set v = vCollect(sid) 446 | isinCollection = True 447 | Exit Function 448 | End If 449 | handle: 450 | isinCollection = False 451 | End Function 452 | 453 | Public Function dimensionCount(a As Variant) As Long 454 | ' the only way I can figure out how to do this is to keep trying till it fails 455 | Dim n As Long, j As Long 456 | 457 | n = 1 458 | On Error GoTo allDone 459 | While True 460 | j = UBound(a, n) 461 | n = n + 1 462 | Wend 463 | Debug.Assert False 464 | Exit Function 465 | 466 | allDone: 467 | dimensionCount = n - 1 468 | Exit Function 469 | 470 | End Function 471 | 472 | Public Function encloseTag(tag As String, Optional newLine As Boolean = True, _ 473 | Optional tClass As String = vbNullString, _ 474 | Optional args As Variant) As String 475 | 476 | Dim i As Long, t As cStringChunker 477 | Set t = New cStringChunker 478 | ' args can be an array or a single item 479 | If Not IsArray(args) Then 480 | With t 481 | .add("<").add (tag) 482 | If tClass <> vbNullString Then .add(" class=").add (tClass) 483 | .add (">") 484 | If newLine Then .add (vbCrLf) 485 | .add (CStr(args)) 486 | If newLine Then .add (vbCrLf) 487 | .add("") 488 | If newLine Then .add (vbCrLf) 489 | End With 490 | Else 491 | ' recurse for array memmbers 492 | For i = LBound(args) To UBound(args) 493 | t.add encloseTag(tag, newLine, tClass, args(i)) 494 | Next i 495 | End If 496 | encloseTag = t.content 497 | End Function 498 | 499 | Public Function scrollHack() As String 500 | 'hack for IOS 501 | scrollHack = _ 502 | "
" 504 | End Function 505 | 506 | Public Function escapeify(s As String) As String 507 | escapeify = _ 508 | Replace( _ 509 | Replace( _ 510 | Replace( _ 511 | Replace(s _ 512 | , q, "\" & q), _ 513 | "%", "\" & "%"), _ 514 | ">", "\>"), _ 515 | "<", "\<") 516 | 517 | 518 | 519 | End Function 520 | Public Function unEscapify(s As String) As String 521 | unEscapify = _ 522 | Replace( _ 523 | Replace( _ 524 | Replace( _ 525 | Replace( _ 526 | s, "\" & q, q), _ 527 | "\" & "%", "%"), _ 528 | "\>", ">"), _ 529 | "\<", "<") 530 | 531 | End Function 532 | Public Function basicStyle() As String 533 | With New cStringChunker 534 | .add ".viewdiv {}" 535 | .add ".hide {" 536 | .add "display:none;position:absolute;" 537 | .add "padding:5px;background:white;color:black;" 538 | .add "border-radius:5px;border:1px solid black;" 539 | .add "}" 540 | basicStyle = .content 541 | End With 542 | 543 | End Function 544 | ' i adapted this from some table css I found - apologies I dont have the site for crediting. 545 | Public Function tableStyle() As String 546 | Dim t As cStringChunker 547 | Set t = New cStringChunker 548 | t.add _ 549 | " table {" & _ 550 | "font-family:Arial, Helvetica, sans-serif;" & _ 551 | "color:#666;" & _ 552 | "font-size:10px;" & _ 553 | "background:#eaebec;" & _ 554 | "margin:4px;" & _ 555 | "border:#ccc 1px solid;" & _ 556 | "-moz-border-radius:3px;" & _ 557 | "-webkit-border-radius:3px;" & _ 558 | "border-radius:3px;" & _ 559 | "-moz-box-shadow: 0 1px 2px #d1d1d1;" & _ 560 | "-webkit-box-shadow: 0 1px 2px #d1d1d1;" & _ 561 | "box-shadow: 0 1px 2px #d1d1d1;" & _ 562 | "}" & _ 563 | "table th {" & _ 564 | "padding:8px 9px 8px 9px;" & _ 565 | "border-top:1px solid #fafafa;" & _ 566 | "border-bottom:1px solid #e0e0e0;" & _ 567 | "background: #ededed;" & _ 568 | "background: -webkit-gradient(linear, left top, left bottom, from(#ededed), to(#ebebeb));" & _ 569 | "background: -moz-linear-gradient(top, #ededed, #ebebeb);" & _ 570 | "}" 571 | 572 | t.add _ 573 | "table tr {" & _ 574 | "text-align: left;" & _ 575 | "padding-left:16px;" & _ 576 | "}" & _ 577 | "table td {" & _ 578 | "padding:6px;" & _ 579 | "border-top: 1px solid #ffffff;" & _ 580 | "border-bottom:1px solid #e0e0e0;" & _ 581 | "border-left: 1px solid #e0e0e0;" & _ 582 | "background: #fafafa;" & _ 583 | "}" & _ 584 | "table tr.even td {" & _ 585 | "background: #f6f6f6;" & _ 586 | "}" 587 | 588 | 589 | 590 | tableStyle = t.content 591 | End Function 592 | Public Function is64BitExcel() As Boolean 593 | #If VBA7 And Win64 Then 594 | is64BitExcel = True 595 | #Else 596 | is64BitExcel = False 597 | #End If 598 | End Function 599 | Public Function includeJQuery() As String 600 | ' include jquery source 601 | With New cStringChunker 602 | .addLine jScriptTag("http://www.google.com/jsapi") 603 | .addLine jScriptTag 604 | .addLine "google.load('jquery', '1');" 605 | .addLine "" 606 | includeJQuery = .content 607 | End With 608 | 609 | End Function 610 | Public Function includeGoogleCallBack(c As String) As String 611 | ' include google call back 612 | With New cStringChunker 613 | .addLine jScriptTag 614 | .addLine "google.setOnLoadCallback(" 615 | .addLine c 616 | .addLine ");" 617 | .addLine "" 618 | includeGoogleCallBack = .content 619 | End With 620 | 621 | End Function 622 | Public Function jScriptTag(Optional src As String) As String 623 | With New cStringChunker 624 | .add "") 627 | Else 628 | .addLine ">" 629 | End If 630 | jScriptTag = .content 631 | End With 632 | End Function 633 | Public Function jDivAtMouse() 634 | With New cStringChunker 635 | .addLine "function() {" 636 | .add "$('a.viewdiv').mousemove(" 637 | .addLine "function(e) {" 638 | .add "var targetdiv = $('#d'+this.id);" 639 | .add "targetdiv.css({left:(e.pageX + 20) + 'px'," 640 | .add "top: (Math.max(0,e.pageY - targetdiv.height()/2)) + 'px'}).show();" 641 | .addLine "});" 642 | .add "$('a.viewdiv').mouseout(" 643 | .addLine "function(e) {" 644 | .add "$('#d'+this.id).hide();" 645 | .addLine "});" 646 | .addLine "}" 647 | jDivAtMouse = .content 648 | End With 649 | End Function 650 | 651 | 652 | Function biasedRandom(possibilities, weights) As String 653 | Dim w As Variant, a As Variant, p As Variant, _ 654 | r As Double, i As Long 655 | ' comes in as 2 lists 656 | a = Split(weights, ",") 657 | p = Split(possibilities, ",") 658 | ReDim w(LBound(a) To UBound(a)) 659 | 660 | ' create cumulative 661 | For i = LBound(w) To UBound(w) 662 | w(i) = CDbl(a(i)) 663 | If i > LBound(w) Then w(i) = w(i - 1) + w(i) 664 | Next i 665 | 666 | ' get random index 667 | r = Rnd() * w(UBound(w)) 668 | 669 | ' find its weighted position 670 | For i = LBound(w) To UBound(w) 671 | If (r <= w(i)) Then 672 | biasedRandom = p(i) 673 | Exit Function 674 | End If 675 | Next i 676 | 677 | End Function 678 | 679 | Public Sub sleep(seconds As Long) 680 | 681 | Application.Wait TimeSerial(hour(Now()), Minute(Now()), Second(Now()) + seconds) 682 | End Sub 683 | Public Function getDateFromTimestamp(s As String) As Date 684 | Dim d As Double 685 | 686 | If (Len(s) = 13) Then 687 | ' javaScript Time 688 | d = CDbl(left(s, 10)) 689 | ' may need to round for milliseconds 690 | If Int(Mid(s, 11, 3) >= 500) Then 691 | d = d + 1 692 | End If 693 | 694 | ElseIf (Len(s) = 10) Then 695 | ' unix Time 696 | d = CDbl(s) 697 | 698 | Else 699 | ' wtf time 700 | getDateFromTimestamp = 0 701 | Exit Function 702 | 703 | End If 704 | getDateFromTimestamp = DateAdd("s", d, DateSerial(1970, 1, 1)) 705 | 706 | End Function 707 | Public Function dateFromUnix(s As Variant) As Variant 708 | Dim d As Date, sd As String 709 | sd = CStr(s) 710 | 711 | If (Len(sd) > 0) Then 712 | d = getDateFromTimestamp(sd) 713 | If d = 0 Then 714 | dateFromUnix = CVErr(xlErrValue) 715 | Else 716 | dateFromUnix = d 717 | End If 718 | Else 719 | dateFromUnix = Empty 720 | End If 721 | 722 | End Function 723 | Public Function isSomething(o As Object) As Boolean 724 | 725 | isSomething = Not o Is Nothing 726 | End Function 727 | 728 | 729 | Public Function tinyTime() As Double 730 | ' Returns seconds. 731 | Dim cyTicks1 As Currency 732 | Static cyFrequency As Currency 733 | tinyTime = 0 734 | ' Get frequency. 735 | If cyFrequency = 0 Then getFrequency cyFrequency 736 | ' Get ticks. 737 | getTickCount cyTicks1 738 | If cyFrequency Then tinyTime = cyTicks1 / cyFrequency 739 | End Function 740 | 741 | 742 | Function applyDefaults(value As Variant, defaultValue As Variant) As Variant 743 | If (IsObject(defaultValue)) Then 744 | If isUndefined(value) Then 745 | Set applyDefaults = defaultValue 746 | Else 747 | Set applyDefaults = value 748 | End If 749 | Else 750 | If isUndefined(value) Then 751 | applyDefaults = defaultValue 752 | Else 753 | applyDefaults = value 754 | End If 755 | End If 756 | End Function 757 | Function isUndefined(value As Variant) As Boolean 758 | If (IsObject(value)) Then 759 | isUndefined = value Is Nothing 760 | Else 761 | If (IsMissing(value) Or IsEmpty(value)) Then 762 | isUndefined = True 763 | Else 764 | isUndefined = (value = vbNullString) 765 | End If 766 | End If 767 | End Function 768 | Function conditionalAssignment(condition As Boolean, a As Variant, b As Variant) As Variant 769 | If (condition) Then 770 | 771 | If IsObject(a) Then 772 | Set conditionalAssignment = a 773 | Else 774 | conditionalAssignment = assignHelper(a) 775 | End If 776 | 777 | Else 778 | If IsObject(b) Then 779 | Set conditionalAssignment = b 780 | Else 781 | conditionalAssignment = assignHelper(b) 782 | End If 783 | 784 | End If 785 | End Function 786 | Private Function assignHelper(a As Variant) As Variant 787 | If IsObject(a) Then 788 | Set assignHelper = a 789 | Else 790 | If Not isUndefined(a) Then 791 | assignHelper = a 792 | Else 793 | assignHelper = vbNullString 794 | End If 795 | End If 796 | End Function 797 | Public Function getTimestampFromDate(Optional dt As Date = 0) As Double 798 | Dim d As Double 799 | 800 | If (dt = 0) Then 801 | dt = Now() 802 | End If 803 | 804 | ' convert into time since the epoch 805 | d = DateDiff("s", DateSerial(1970, 1, 1) + TimeSerial(0, 0, 0), dt) 806 | 807 | ' convert to ms 808 | d = d * 1000# 809 | 810 | getTimestampFromDate = d 811 | 812 | End Function 813 | 814 | Public Function checkOrCreateFolder(path As String, Optional optCreate As Boolean = True) As Object 815 | ' doing late binding to avoid refernce for this 816 | 817 | Dim fso As Object, cleanPath As String 818 | Set fso = createObject("Scripting.FileSystemObject") 819 | 820 | 'fso not smart enough to create entire thing, so we need recurse for each 821 | If (optCreate) Then 822 | recurseCreateFolder fso, fso.GetAbsolutePathName(path) 823 | End If 824 | 825 | Set checkOrCreateFolder = fso.getFolder(path) 826 | End Function 827 | Private Function recurseCreateFolder(fso As Object, cleanPath As String) As Object 828 | Dim parentPathString As String 829 | 830 | If Not fso.FolderExists(cleanPath) Then 831 | ' need to create the parent first 832 | recurseCreateFolder fso, fso.GetParentFolderName(cleanPath) 833 | ' now we can do it 834 | fso.CreateFolder (cleanPath) 835 | End If 836 | 837 | End Function 838 | Public Function writeToFolderFile(folderName As String, fileName As String, content As String) As String 839 | 840 | Dim file As Object, fso As Object 841 | Dim path As String 842 | path = fileName 843 | ' create the folder if we need to 844 | 845 | If (folderName <> vbNullString) Then 846 | path = concatFolderName(folderName, path) 847 | checkOrCreateFolder folderName 848 | End If 849 | ' write the data 850 | 851 | Set fso = createObject("Scripting.FileSystemObject") 852 | Set file = fso.OpenTextFile(path, 2, True) 853 | file.write content 854 | writeToFolderFile = content 855 | End Function 856 | Public Function getAllSubFolderPaths(folderName As String) As String 857 | Dim folder As Object, subFolder As Object, c As cStringChunker 858 | Set c = New cStringChunker 859 | Set folder = checkOrCreateFolder(folderName, False) 860 | If (isSomething(folder)) Then 861 | For Each subFolder In folder.subFolders 862 | c.add(subFolder.path).add "," 863 | Next subFolder 864 | End If 865 | getAllSubFolderPaths = c.chopIf(",").toString 866 | End Function 867 | Public Function readFromFolderFile(folderName As String, fileName As String) As String 868 | Dim file As Object, fso As Object 869 | Dim path As String 870 | path = fileName 871 | 872 | If (folderName <> vbNullString) Then 873 | path = concatFolderName(folderName, fileName) 874 | End If 875 | ' read the data 876 | If (fileExists(path)) Then 877 | Set fso = createObject("Scripting.FileSystemObject") 878 | Set file = fso.OpenTextFile(path, 1) 879 | If (file.AtEndOfStream) Then 880 | readFromFolderFile = "" 881 | Else 882 | readFromFolderFile = file.readAll() 883 | End If 884 | file.Close 885 | End If 886 | 887 | End Function 888 | Public Function fileExists(path As String) As Boolean 889 | Dim fso As Object 890 | Set fso = createObject("Scripting.FileSystemObject") 891 | fileExists = fso.fileExists(path) 892 | End Function 893 | Public Function concatFolderName(folderName As String, fileName As String) As String 894 | Dim c As cStringChunker 895 | Set c = New cStringChunker 896 | concatFolderName = c.add(folderName).chopIf("/").chopIf("\").add("/").add(fileName).toString 897 | 898 | End Function 899 | 900 | 901 | -------------------------------------------------------------------------------- /libraries/usefulStuff_vba.md: -------------------------------------------------------------------------------- 1 | # VBA Project: **vbaJavaScript** 2 | ## VBA Module: **[usefulStuff](/libraries/usefulStuff.vba "source is here")** 3 | ### Type: StdModule 4 | 5 | This procedure list for repo (vbaJavaScript) was automatically created on 6/25/2015 10:03:21 AM by VBAGit. 6 | For more information see the [desktop liberation site](http://ramblings.mcpher.com/Home/excelquirks/drivesdk/gettinggithubready "desktop liberation") 7 | 8 | Below is a section for each procedure in usefulStuff 9 | 10 | --- 11 | VBA Procedure: **OpenUrl** 12 | Type: **Function** 13 | Returns: **Boolean** 14 | Return description: **** 15 | Scope: **Public** 16 | Description: **** 17 | 18 | *Public Function OpenUrl(url) As Boolean* 19 | 20 | *name*|*type*|*optional*|*default*|*description* 21 | ---|---|---|---|--- 22 | url|Variant|False|| 23 | 24 | 25 | --- 26 | VBA Procedure: **deleteAllFromCollection** 27 | Type: **Sub** 28 | Returns: **void** 29 | Return description: **** 30 | Scope: **Public** 31 | Description: **** 32 | 33 | *Sub deleteAllFromCollection(co As Collection)* 34 | 35 | *name*|*type*|*optional*|*default*|*description* 36 | ---|---|---|---|--- 37 | co|Collection|False|| 38 | 39 | 40 | --- 41 | VBA Procedure: **UTF16To8** 42 | Type: **Function** 43 | Returns: **String** 44 | Return description: **** 45 | Scope: **Public** 46 | Description: **** 47 | 48 | *Public Function UTF16To8(ByVal UTF16 As String) As String* 49 | 50 | *name*|*type*|*optional*|*default*|*description* 51 | ---|---|---|---|--- 52 | ByVal|String|False|| 53 | 54 | 55 | --- 56 | VBA Procedure: **URLEncode** 57 | Type: **Function** 58 | Returns: **String** 59 | Return description: **** 60 | Scope: **Public** 61 | Description: **** 62 | 63 | *Public Function URLEncode( StringVal As String, Optional SpaceAsPlus As Boolean = False, Optional UTF8Encode As Boolean = True ) As String* 64 | 65 | *name*|*type*|*optional*|*default*|*description* 66 | ---|---|---|---|--- 67 | StringVal|String|False|| 68 | SpaceAsPlus|Boolean|True| False| 69 | UTF8Encode|Boolean|True| True| 70 | 71 | 72 | --- 73 | VBA Procedure: **cloneFormat** 74 | Type: **Sub** 75 | Returns: **void** 76 | Return description: **** 77 | Scope: **Public** 78 | Description: **** 79 | 80 | *Public Sub cloneFormat(b As Range, a As Range)* 81 | 82 | *name*|*type*|*optional*|*default*|*description* 83 | ---|---|---|---|--- 84 | b|Range|False|| 85 | a|Range|False|| 86 | 87 | 88 | --- 89 | VBA Procedure: **compareAsKey** 90 | Type: **Function** 91 | Returns: **Boolean** 92 | Return description: **** 93 | Scope: **Public** 94 | Description: **** 95 | 96 | *Public Function compareAsKey(a As Variant, b As Variant, Optional asKey As Boolean = True) As Boolean* 97 | 98 | *name*|*type*|*optional*|*default*|*description* 99 | ---|---|---|---|--- 100 | a|Variant|False|| 101 | b|Variant|False|| 102 | asKey|Boolean|True| True| 103 | 104 | 105 | --- 106 | VBA Procedure: **SortColl** 107 | Type: **Function** 108 | Returns: **Long** 109 | Return description: **** 110 | Scope: **Public** 111 | Description: **** 112 | 113 | *Function SortColl(ByRef coll As Collection, eorder As Long) As Long* 114 | 115 | *name*|*type*|*optional*|*default*|*description* 116 | ---|---|---|---|--- 117 | ByRef|Collection|False|| 118 | eorder|Long|False|| 119 | 120 | 121 | --- 122 | VBA Procedure: **getHandle** 123 | Type: **Function** 124 | Returns: **Integer** 125 | Return description: **** 126 | Scope: **Public** 127 | Description: **** 128 | 129 | *Public Function getHandle(sName As String, Optional readOnly As Boolean = False) As Integer* 130 | 131 | *name*|*type*|*optional*|*default*|*description* 132 | ---|---|---|---|--- 133 | sName|String|False|| 134 | readOnly|Boolean|True| False| 135 | 136 | 137 | --- 138 | VBA Procedure: **afConcat** 139 | Type: **Function** 140 | Returns: **String** 141 | Return description: **** 142 | Scope: **Public** 143 | Description: **** 144 | 145 | *Function afConcat(arr() As Variant) As String* 146 | 147 | *name*|*type*|*optional*|*default*|*description* 148 | ---|---|---|---|--- 149 | arr|Variant|False|| 150 | 151 | 152 | --- 153 | VBA Procedure: **quote** 154 | Type: **Function** 155 | Returns: **String** 156 | Return description: **** 157 | Scope: **Public** 158 | Description: **** 159 | 160 | *Public Function quote(s As String) As String* 161 | 162 | *name*|*type*|*optional*|*default*|*description* 163 | ---|---|---|---|--- 164 | s|String|False|| 165 | 166 | 167 | --- 168 | VBA Procedure: **q** 169 | Type: **Function** 170 | Returns: **String** 171 | Return description: **** 172 | Scope: **Public** 173 | Description: **** 174 | 175 | *Public Function q() As String* 176 | 177 | **no arguments required for this procedure** 178 | 179 | 180 | --- 181 | VBA Procedure: **qs** 182 | Type: **Function** 183 | Returns: **String** 184 | Return description: **** 185 | Scope: **Public** 186 | Description: **** 187 | 188 | *Public Function qs() As String* 189 | 190 | **no arguments required for this procedure** 191 | 192 | 193 | --- 194 | VBA Procedure: **bracket** 195 | Type: **Function** 196 | Returns: **String** 197 | Return description: **** 198 | Scope: **Public** 199 | Description: **** 200 | 201 | *Public Function bracket(s As String) As String* 202 | 203 | *name*|*type*|*optional*|*default*|*description* 204 | ---|---|---|---|--- 205 | s|String|False|| 206 | 207 | 208 | --- 209 | VBA Procedure: **list** 210 | Type: **Function** 211 | Returns: **String** 212 | Return description: **** 213 | Scope: **Public** 214 | Description: **** 215 | 216 | *Public Function list(ParamArray args() As Variant) As String* 217 | 218 | *name*|*type*|*optional*|*default*|*description* 219 | ---|---|---|---|--- 220 | ParamArray|Variant|False|| 221 | 222 | 223 | --- 224 | VBA Procedure: **qlist** 225 | Type: **Function** 226 | Returns: **String** 227 | Return description: **** 228 | Scope: **Public** 229 | Description: **** 230 | 231 | *Public Function qlist(ParamArray args() As Variant) As String* 232 | 233 | *name*|*type*|*optional*|*default*|*description* 234 | ---|---|---|---|--- 235 | ParamArray|Variant|False|| 236 | 237 | 238 | --- 239 | VBA Procedure: **diminishingReturn** 240 | Type: **Function** 241 | Returns: **Double** 242 | Return description: **** 243 | Scope: **Public** 244 | Description: **** 245 | 246 | *Public Function diminishingReturn(val As Double, Optional s As Double = 10) As Double* 247 | 248 | *name*|*type*|*optional*|*default*|*description* 249 | ---|---|---|---|--- 250 | val|Double|False|| 251 | s|Double|True| 10| 252 | 253 | 254 | --- 255 | VBA Procedure: **superTrim** 256 | Type: **Function** 257 | Returns: **String** 258 | Return description: **** 259 | Scope: **Public** 260 | Description: **** 261 | 262 | *Public Function superTrim(s As String) As String* 263 | 264 | *name*|*type*|*optional*|*default*|*description* 265 | ---|---|---|---|--- 266 | s|String|False|| 267 | 268 | 269 | --- 270 | VBA Procedure: **makeKey** 271 | Type: **Function** 272 | Returns: **String** 273 | Return description: **** 274 | Scope: **Public** 275 | Description: **** 276 | 277 | *Public Function makeKey(v As Variant) As String* 278 | 279 | *name*|*type*|*optional*|*default*|*description* 280 | ---|---|---|---|--- 281 | v|Variant|False|| 282 | 283 | 284 | --- 285 | VBA Procedure: **Base64Encode** 286 | Type: **Function** 287 | Returns: **Variant** 288 | Return description: **** 289 | Scope: **Public** 290 | Description: **** 291 | 292 | *Function Base64Encode(sText)* 293 | 294 | *name*|*type*|*optional*|*default*|*description* 295 | ---|---|---|---|--- 296 | sText|Variant|False|| 297 | 298 | 299 | --- 300 | VBA Procedure: **Stream_StringToBinary** 301 | Type: **Function** 302 | Returns: **Variant** 303 | Return description: **** 304 | Scope: **Public** 305 | Description: **** 306 | 307 | *Function Stream_StringToBinary(Text)* 308 | 309 | *name*|*type*|*optional*|*default*|*description* 310 | ---|---|---|---|--- 311 | Text|Variant|False|| 312 | 313 | 314 | --- 315 | VBA Procedure: **Stream_BinaryToString** 316 | Type: **Function** 317 | Returns: **Variant** 318 | Return description: **** 319 | Scope: **Public** 320 | Description: **** 321 | 322 | *Function Stream_BinaryToString(Binary)* 323 | 324 | *name*|*type*|*optional*|*default*|*description* 325 | ---|---|---|---|--- 326 | Binary|Variant|False|| 327 | 328 | 329 | --- 330 | VBA Procedure: **Base64Decode** 331 | Type: **Function** 332 | Returns: **Variant** 333 | Return description: **** 334 | Scope: **Public** 335 | Description: **** 336 | 337 | *Function Base64Decode(ByVal base64String)* 338 | 339 | *name*|*type*|*optional*|*default*|*description* 340 | ---|---|---|---|--- 341 | ByVal|Variant|False|| 342 | 343 | 344 | --- 345 | VBA Procedure: **openNewHtml** 346 | Type: **Function** 347 | Returns: **Boolean** 348 | Return description: **** 349 | Scope: **Public** 350 | Description: **** 351 | 352 | *Public Function openNewHtml(sName As String, sContent As String) As Boolean* 353 | 354 | *name*|*type*|*optional*|*default*|*description* 355 | ---|---|---|---|--- 356 | sName|String|False|| 357 | sContent|String|False|| 358 | 359 | 360 | --- 361 | VBA Procedure: **readFromFile** 362 | Type: **Function** 363 | Returns: **String** 364 | Return description: **** 365 | Scope: **Public** 366 | Description: **** 367 | 368 | *Public Function readFromFile(sName As String) As String* 369 | 370 | *name*|*type*|*optional*|*default*|*description* 371 | ---|---|---|---|--- 372 | sName|String|False|| 373 | 374 | 375 | --- 376 | VBA Procedure: **arrayLength** 377 | Type: **Function** 378 | Returns: **Long** 379 | Return description: **** 380 | Scope: **Public** 381 | Description: **** 382 | 383 | *Public Function arrayLength(a) As Long* 384 | 385 | *name*|*type*|*optional*|*default*|*description* 386 | ---|---|---|---|--- 387 | a|Variant|False|| 388 | 389 | 390 | --- 391 | VBA Procedure: **getControlValue** 392 | Type: **Function** 393 | Returns: **Variant** 394 | Return description: **** 395 | Scope: **Public** 396 | Description: **** 397 | 398 | *Public Function getControlValue(ctl As Object) As Variant* 399 | 400 | *name*|*type*|*optional*|*default*|*description* 401 | ---|---|---|---|--- 402 | ctl|Object|False|| 403 | 404 | 405 | --- 406 | VBA Procedure: **setControlValue** 407 | Type: **Function** 408 | Returns: **Variant** 409 | Return description: **** 410 | Scope: **Public** 411 | Description: **** 412 | 413 | *Public Function setControlValue(ctl As Object, v As Variant) As Variant* 414 | 415 | *name*|*type*|*optional*|*default*|*description* 416 | ---|---|---|---|--- 417 | ctl|Object|False|| 418 | v|Variant|False|| 419 | 420 | 421 | --- 422 | VBA Procedure: **isinCollection** 423 | Type: **Function** 424 | Returns: **Boolean** 425 | Return description: **** 426 | Scope: **Public** 427 | Description: **** 428 | 429 | *Public Function isinCollection(vCollect As Variant, sid As Variant) As Boolean* 430 | 431 | *name*|*type*|*optional*|*default*|*description* 432 | ---|---|---|---|--- 433 | vCollect|Variant|False|| 434 | sid|Variant|False|| 435 | 436 | 437 | --- 438 | VBA Procedure: **dimensionCount** 439 | Type: **Function** 440 | Returns: **Long** 441 | Return description: **** 442 | Scope: **Public** 443 | Description: **** 444 | 445 | *Public Function dimensionCount(a As Variant) As Long* 446 | 447 | *name*|*type*|*optional*|*default*|*description* 448 | ---|---|---|---|--- 449 | a|Variant|False|| 450 | 451 | 452 | --- 453 | VBA Procedure: **encloseTag** 454 | Type: **Function** 455 | Returns: **String** 456 | Return description: **** 457 | Scope: **Public** 458 | Description: **** 459 | 460 | *Public Function encloseTag(tag As String, Optional newLine As Boolean = True, Optional tClass As String = vbNullString, Optional args As Variant) As String* 461 | 462 | *name*|*type*|*optional*|*default*|*description* 463 | ---|---|---|---|--- 464 | tag|String|False|| 465 | newLine|Boolean|True| True| 466 | tClass|String|True| vbNullString| 467 | args|Variant|True|| 468 | 469 | 470 | --- 471 | VBA Procedure: **scrollHack** 472 | Type: **Function** 473 | Returns: **String** 474 | Return description: **** 475 | Scope: **Public** 476 | Description: **** 477 | 478 | *Public Function scrollHack() As String* 479 | 480 | **no arguments required for this procedure** 481 | 482 | 483 | --- 484 | VBA Procedure: **escapeify** 485 | Type: **Function** 486 | Returns: **String** 487 | Return description: **** 488 | Scope: **Public** 489 | Description: **** 490 | 491 | *Public Function escapeify(s As String) As String* 492 | 493 | *name*|*type*|*optional*|*default*|*description* 494 | ---|---|---|---|--- 495 | s|String|False|| 496 | 497 | 498 | --- 499 | VBA Procedure: **unEscapify** 500 | Type: **Function** 501 | Returns: **String** 502 | Return description: **** 503 | Scope: **Public** 504 | Description: **** 505 | 506 | *Public Function unEscapify(s As String) As String* 507 | 508 | *name*|*type*|*optional*|*default*|*description* 509 | ---|---|---|---|--- 510 | s|String|False|| 511 | 512 | 513 | --- 514 | VBA Procedure: **basicStyle** 515 | Type: **Function** 516 | Returns: **String** 517 | Return description: **** 518 | Scope: **Public** 519 | Description: **** 520 | 521 | *Public Function basicStyle() As String* 522 | 523 | **no arguments required for this procedure** 524 | 525 | 526 | --- 527 | VBA Procedure: **tableStyle** 528 | Type: **Function** 529 | Returns: **String** 530 | Return description: **** 531 | Scope: **Public** 532 | Description: **** 533 | 534 | *Public Function tableStyle() As String* 535 | 536 | **no arguments required for this procedure** 537 | 538 | 539 | --- 540 | VBA Procedure: **is64BitExcel** 541 | Type: **Function** 542 | Returns: **Boolean** 543 | Return description: **** 544 | Scope: **Public** 545 | Description: **** 546 | 547 | *Public Function is64BitExcel() As Boolean* 548 | 549 | **no arguments required for this procedure** 550 | 551 | 552 | --- 553 | VBA Procedure: **includeJQuery** 554 | Type: **Function** 555 | Returns: **String** 556 | Return description: **** 557 | Scope: **Public** 558 | Description: **** 559 | 560 | *Public Function includeJQuery() As String* 561 | 562 | **no arguments required for this procedure** 563 | 564 | 565 | --- 566 | VBA Procedure: **includeGoogleCallBack** 567 | Type: **Function** 568 | Returns: **String** 569 | Return description: **** 570 | Scope: **Public** 571 | Description: **** 572 | 573 | *Public Function includeGoogleCallBack(c As String) As String* 574 | 575 | *name*|*type*|*optional*|*default*|*description* 576 | ---|---|---|---|--- 577 | c|String|False|| 578 | 579 | 580 | --- 581 | VBA Procedure: **jScriptTag** 582 | Type: **Function** 583 | Returns: **String** 584 | Return description: **** 585 | Scope: **Public** 586 | Description: **** 587 | 588 | *Public Function jScriptTag(Optional src As String) As String* 589 | 590 | *name*|*type*|*optional*|*default*|*description* 591 | ---|---|---|---|--- 592 | src|String|True|| 593 | 594 | 595 | --- 596 | VBA Procedure: **jDivAtMouse** 597 | Type: **Function** 598 | Returns: **Variant** 599 | Return description: **** 600 | Scope: **Public** 601 | Description: **** 602 | 603 | *Public Function jDivAtMouse()* 604 | 605 | **no arguments required for this procedure** 606 | 607 | 608 | --- 609 | VBA Procedure: **biasedRandom** 610 | Type: **Function** 611 | Returns: **String** 612 | Return description: **** 613 | Scope: **Public** 614 | Description: **** 615 | 616 | *Function biasedRandom(possibilities, weights) As String* 617 | 618 | *name*|*type*|*optional*|*default*|*description* 619 | ---|---|---|---|--- 620 | possibilities|Variant|False|| 621 | weights|Variant|False|| 622 | 623 | 624 | --- 625 | VBA Procedure: **sleep** 626 | Type: **Sub** 627 | Returns: **void** 628 | Return description: **** 629 | Scope: **Public** 630 | Description: **** 631 | 632 | *Public Sub sleep(seconds As Long)* 633 | 634 | *name*|*type*|*optional*|*default*|*description* 635 | ---|---|---|---|--- 636 | seconds|Long|False|| 637 | 638 | 639 | --- 640 | VBA Procedure: **getDateFromTimestamp** 641 | Type: **Function** 642 | Returns: **Date** 643 | Return description: **** 644 | Scope: **Public** 645 | Description: **** 646 | 647 | *Public Function getDateFromTimestamp(s As String) As Date* 648 | 649 | *name*|*type*|*optional*|*default*|*description* 650 | ---|---|---|---|--- 651 | s|String|False|| 652 | 653 | 654 | --- 655 | VBA Procedure: **dateFromUnix** 656 | Type: **Function** 657 | Returns: **Variant** 658 | Return description: **** 659 | Scope: **Public** 660 | Description: **** 661 | 662 | *Public Function dateFromUnix(s As Variant) As Variant* 663 | 664 | *name*|*type*|*optional*|*default*|*description* 665 | ---|---|---|---|--- 666 | s|Variant|False|| 667 | 668 | 669 | --- 670 | VBA Procedure: **isSomething** 671 | Type: **Function** 672 | Returns: **Boolean** 673 | Return description: **** 674 | Scope: **Public** 675 | Description: **** 676 | 677 | *Public Function isSomething(o As Object) As Boolean* 678 | 679 | *name*|*type*|*optional*|*default*|*description* 680 | ---|---|---|---|--- 681 | o|Object|False|| 682 | 683 | 684 | --- 685 | VBA Procedure: **tinyTime** 686 | Type: **Function** 687 | Returns: **Double** 688 | Return description: **** 689 | Scope: **Public** 690 | Description: **** 691 | 692 | *Public Function tinyTime() As Double* 693 | 694 | **no arguments required for this procedure** 695 | 696 | 697 | --- 698 | VBA Procedure: **applyDefaults** 699 | Type: **Function** 700 | Returns: **Variant** 701 | Return description: **** 702 | Scope: **Public** 703 | Description: **** 704 | 705 | *Function applyDefaults(value As Variant, defaultValue As Variant) As Variant* 706 | 707 | *name*|*type*|*optional*|*default*|*description* 708 | ---|---|---|---|--- 709 | value|Variant|False|| 710 | defaultValue|Variant|False|| 711 | 712 | 713 | --- 714 | VBA Procedure: **isUndefined** 715 | Type: **Function** 716 | Returns: **Boolean** 717 | Return description: **** 718 | Scope: **Public** 719 | Description: **** 720 | 721 | *Function isUndefined(value As Variant) As Boolean* 722 | 723 | *name*|*type*|*optional*|*default*|*description* 724 | ---|---|---|---|--- 725 | value|Variant|False|| 726 | 727 | 728 | --- 729 | VBA Procedure: **conditionalAssignment** 730 | Type: **Function** 731 | Returns: **Variant** 732 | Return description: **** 733 | Scope: **Public** 734 | Description: **** 735 | 736 | *Function conditionalAssignment(condition As Boolean, a As Variant, b As Variant) As Variant* 737 | 738 | *name*|*type*|*optional*|*default*|*description* 739 | ---|---|---|---|--- 740 | condition|Boolean|False|| 741 | a|Variant|False|| 742 | b|Variant|False|| 743 | 744 | 745 | --- 746 | VBA Procedure: **assignHelper** 747 | Type: **Function** 748 | Returns: **Variant** 749 | Return description: **** 750 | Scope: **Private** 751 | Description: **** 752 | 753 | *Private Function assignHelper(a As Variant) As Variant* 754 | 755 | *name*|*type*|*optional*|*default*|*description* 756 | ---|---|---|---|--- 757 | a|Variant|False|| 758 | 759 | 760 | --- 761 | VBA Procedure: **getTimestampFromDate** 762 | Type: **Function** 763 | Returns: **Double** 764 | Return description: **** 765 | Scope: **Public** 766 | Description: **** 767 | 768 | *Public Function getTimestampFromDate(Optional dt As Date = 0) As Double* 769 | 770 | *name*|*type*|*optional*|*default*|*description* 771 | ---|---|---|---|--- 772 | dt|Date|True| 0| 773 | 774 | 775 | --- 776 | VBA Procedure: **checkOrCreateFolder** 777 | Type: **Function** 778 | Returns: **Object** 779 | Return description: **** 780 | Scope: **Public** 781 | Description: **** 782 | 783 | *Public Function checkOrCreateFolder(path As String, Optional optCreate As Boolean = True) As Object* 784 | 785 | *name*|*type*|*optional*|*default*|*description* 786 | ---|---|---|---|--- 787 | path|String|False|| 788 | optCreate|Boolean|True| True| 789 | 790 | 791 | --- 792 | VBA Procedure: **recurseCreateFolder** 793 | Type: **Function** 794 | Returns: **Object** 795 | Return description: **** 796 | Scope: **Private** 797 | Description: **** 798 | 799 | *Private Function recurseCreateFolder(fso As Object, cleanPath As String) As Object* 800 | 801 | *name*|*type*|*optional*|*default*|*description* 802 | ---|---|---|---|--- 803 | fso|Object|False|| 804 | cleanPath|String|False|| 805 | 806 | 807 | --- 808 | VBA Procedure: **writeToFolderFile** 809 | Type: **Function** 810 | Returns: **String** 811 | Return description: **** 812 | Scope: **Public** 813 | Description: **** 814 | 815 | *Public Function writeToFolderFile(folderName As String, fileName As String, content As String) As String* 816 | 817 | *name*|*type*|*optional*|*default*|*description* 818 | ---|---|---|---|--- 819 | folderName|String|False|| 820 | fileName|String|False|| 821 | content|String|False|| 822 | 823 | 824 | --- 825 | VBA Procedure: **getAllSubFolderPaths** 826 | Type: **Function** 827 | Returns: **String** 828 | Return description: **** 829 | Scope: **Public** 830 | Description: **** 831 | 832 | *Public Function getAllSubFolderPaths(folderName As String) As String* 833 | 834 | *name*|*type*|*optional*|*default*|*description* 835 | ---|---|---|---|--- 836 | folderName|String|False|| 837 | 838 | 839 | --- 840 | VBA Procedure: **readFromFolderFile** 841 | Type: **Function** 842 | Returns: **String** 843 | Return description: **** 844 | Scope: **Public** 845 | Description: **** 846 | 847 | *Public Function readFromFolderFile(folderName As String, fileName As String) As String* 848 | 849 | *name*|*type*|*optional*|*default*|*description* 850 | ---|---|---|---|--- 851 | folderName|String|False|| 852 | fileName|String|False|| 853 | 854 | 855 | --- 856 | VBA Procedure: **fileExists** 857 | Type: **Function** 858 | Returns: **Boolean** 859 | Return description: **** 860 | Scope: **Public** 861 | Description: **** 862 | 863 | *Public Function fileExists(path As String) As Boolean* 864 | 865 | *name*|*type*|*optional*|*default*|*description* 866 | ---|---|---|---|--- 867 | path|String|False|| 868 | 869 | 870 | --- 871 | VBA Procedure: **concatFolderName** 872 | Type: **Function** 873 | Returns: **String** 874 | Return description: **** 875 | Scope: **Public** 876 | Description: **** 877 | 878 | *Public Function concatFolderName(folderName As String, fileName As String) As String* 879 | 880 | *name*|*type*|*optional*|*default*|*description* 881 | ---|---|---|---|--- 882 | folderName|String|False|| 883 | fileName|String|False|| 884 | -------------------------------------------------------------------------------- /scripts/cJavaScript.cls: -------------------------------------------------------------------------------- 1 | Option Explicit 2 | Private pChunk As cStringChunker 3 | '/** 4 | ' * kind of like a script tag - adds a local script file to your code 5 | ' * @param {string} scriptFile file name 6 | ' * @return {cJavaScript} self 7 | ' */ 8 | Public Function addFile(scriptFile As String) As cJavaScript 9 | pChunk.addLine (readFromFile(scriptFile)) 10 | Set addFile = Me 11 | End Function 12 | '/** 13 | ' * kind of like a script tag - adds a local apps script stuff 14 | ' * @param {string} scriptUrl the web app providing the code 15 | ' * @return {cJavaScript} self 16 | ' */ 17 | Public Function addAppsScript(scriptUrl As String) As cJavaScript 18 | Dim s As String 19 | 20 | s = simpleUrlGet(scriptUrl) 21 | 22 | '// need to do special cleaning for apps script 23 | pChunk.addLine (removeHtmlEscape(s)) 24 | Set addAppsScript = removeScriptTags() 25 | 26 | End Function 27 | 28 | '/** 29 | ' * kind of like a script tag - adds a hosted file to your code 30 | ' * @param {string} scriptUrl file link 31 | ' * @return {cJavaScript} self 32 | ' */ 33 | Public Function addUrl(scriptUrl As String) As cJavaScript 34 | pChunk.addLine (simpleUrlGet(scriptUrl)) 35 | Set addUrl = Me 36 | End Function 37 | '/** 38 | ' * kind of like a script tag - adds a local script file to your code 39 | ' * @param {string} fn file link 40 | ' * @param {boolean} complain optional complain if an error 41 | ' * @return {string} result 42 | ' */ 43 | Public Function simpleUrlGet(fn As String, Optional complain As Boolean = True) As String 44 | 45 | '// this can be changes to a client object if firewall problems 46 | Dim ohttp As Object 47 | Set ohttp = New MSXML2.ServerXMLHTTP60 48 | 49 | With ohttp 50 | .Open "GET", fn, False 51 | .Send "" 52 | If (.status <> 200) Then 53 | MsgBox ("error getting " & fn & " code " & .status & " text " & .ResponseText) 54 | Else 55 | simpleUrlGet = .ResponseText 56 | End If 57 | 58 | 59 | End With 60 | End Function 61 | 62 | '/** 63 | ' * adds code to your script 64 | ' * @param {string} scriptCode some code 65 | ' * @return {cJavaScript} self 66 | ' */ 67 | Public Function addCode(scriptCode As String) As cJavaScript 68 | pChunk.addLine scriptCode 69 | Set addCode = Me 70 | End Function 71 | '/** 72 | ' * returns the code 73 | ' * @return {string} the code 74 | ' */ 75 | Public Property Get code() As String 76 | code = pChunk.toString 77 | End Property 78 | '/** 79 | ' * returns convenience self for with/chaining 80 | ' * @return {cJavaScript} self 81 | ' */ 82 | Public Property Get self() As cJavaScript 83 | Set self = Me 84 | End Property 85 | '/** 86 | ' * clears the code 87 | ' * @return {cJavaScript} self 88 | ' */ 89 | Public Function clear() As cJavaScript 90 | pChunk.clear 91 | Set clear = Me 92 | End Function 93 | '/** 94 | ' * expose the stringchunker 95 | ' * @return {cStringChunker} the code chunker 96 | ' */ 97 | Public Property Get chunker() As cStringChunker 98 | Set chunker = pChunk 99 | End Property 100 | 101 | '/** 102 | ' * execute code 103 | ' * @return {ScriptControl} the script control to execute run against 104 | ' */ 105 | Public Function compile() As Variant 106 | Dim sc As ScriptControl 107 | Set sc = New ScriptControl 108 | 109 | ' we can't run as a method of this as paramarray cant be passed properly in VBA 110 | With sc 111 | .Language = "JScript" 112 | .addCode pChunk.addLine("").toString 113 | End With 114 | 115 | Set compile = sc 116 | 117 | End Function 118 | '/** 119 | ' * if you need to deal with arrays, this will convert back and forwards from JS to vba 120 | ' * @return {cJavaScript} self 121 | ' */ 122 | Public Function addArraySupport() As cJavaScript 123 | pChunk.add "var XLiberation = (function(xLiberation) {" & _ 124 | "xliberation.getArray = function (arrayIn) {" & _ 125 | "return new VBArray(arrayIn).toArray();}" & _ 126 | "xLiberation.setArray = function setArray(ja) {" & _ 127 | "var dict = new ActiveXObject('Scripting.Dictionary');" & _ 128 | "for (var i=0;i < ja.length; i++ )dict.add(i,ja[i]);" & _ 129 | "return dict.items();}" & _ 130 | " return xLiberation; " & _ 131 | "})(Xliberation || {});" 132 | Set addArraySupport = Me 133 | End Function 134 | Public Function removeHtmlEscape(t As String) As String 135 | 136 | Dim oXML As Object 137 | ' as far as i know, only << are left escaped by contentservice 138 | removeHtmlEscape = Replace(t, "<", "<") 139 | 140 | End Function 141 | '/** 142 | ' * apps script sometimes have script tags 143 | ' * @return {cJavaScript} self 144 | ' */ 145 | Public Function removeScriptTags() As cJavaScript 146 | Dim s As String, t As String 147 | t = pChunk.toString 148 | Set removeScriptTags = Me 149 | s = Replace(Replace(t, "", "") 150 | If (s <> t) Then 151 | pChunk.clear.add (s) 152 | End If 153 | End Function 154 | 155 | Private Sub Class_Initialize() 156 | Set pChunk = New cStringChunker 157 | End Sub -------------------------------------------------------------------------------- /scripts/cJavaScript_cls.md: -------------------------------------------------------------------------------- 1 | # VBA Project: **vbaJavaScript** 2 | ## VBA Module: **[cJavaScript](/scripts/cJavaScript.cls "source is here")** 3 | ### Type: ClassModule 4 | 5 | This procedure list for repo (vbaJavaScript) was automatically created on 6/25/2015 10:03:23 AM by VBAGit. 6 | For more information see the [desktop liberation site](http://ramblings.mcpher.com/Home/excelquirks/drivesdk/gettinggithubready "desktop liberation") 7 | 8 | Below is a section for each procedure in cJavaScript 9 | 10 | --- 11 | VBA Procedure: **addFile** 12 | Type: **Function** 13 | Returns: **[cJavaScript](/scripts/cJavaScript_cls.md "cJavaScript")** 14 | Return description: **self** 15 | Scope: **Public** 16 | Description: **kind of like a script tag - adds a local script file to your code** 17 | 18 | *Public Function addFile(scriptFile As String) As cJavaScript* 19 | 20 | *name*|*type*|*optional*|*default*|*description* 21 | ---|---|---|---|--- 22 | scriptFile|String|False||file name 23 | 24 | 25 | --- 26 | VBA Procedure: **addAppsScript** 27 | Type: **Function** 28 | Returns: **[cJavaScript](/scripts/cJavaScript_cls.md "cJavaScript")** 29 | Return description: **self** 30 | Scope: **Public** 31 | Description: **kind of like a script tag - adds a local apps script stuff** 32 | 33 | *Public Function addAppsScript(scriptUrl As String) As cJavaScript* 34 | 35 | *name*|*type*|*optional*|*default*|*description* 36 | ---|---|---|---|--- 37 | scriptUrl|String|False||the web app providing the code 38 | 39 | 40 | --- 41 | VBA Procedure: **addUrl** 42 | Type: **Function** 43 | Returns: **[cJavaScript](/scripts/cJavaScript_cls.md "cJavaScript")** 44 | Return description: **self** 45 | Scope: **Public** 46 | Description: **kind of like a script tag - adds a hosted file to your code** 47 | 48 | *Public Function addUrl(scriptUrl As String) As cJavaScript* 49 | 50 | *name*|*type*|*optional*|*default*|*description* 51 | ---|---|---|---|--- 52 | scriptUrl|String|False||file link 53 | 54 | 55 | --- 56 | VBA Procedure: **simpleUrlGet** 57 | Type: **Function** 58 | Returns: **String** 59 | Return description: **result** 60 | Scope: **Public** 61 | Description: **kind of like a script tag - adds a local script file to your code** 62 | 63 | *Public Function simpleUrlGet(fn As String, Optional complain As Boolean = True) As String* 64 | 65 | *name*|*type*|*optional*|*default*|*description* 66 | ---|---|---|---|--- 67 | fn|String|False||file link 68 | complain|Boolean|True| True|optional complain if an error 69 | 70 | 71 | --- 72 | VBA Procedure: **addCode** 73 | Type: **Function** 74 | Returns: **[cJavaScript](/scripts/cJavaScript_cls.md "cJavaScript")** 75 | Return description: **self** 76 | Scope: **Public** 77 | Description: **adds code to your script** 78 | 79 | *Public Function addCode(scriptCode As String) As cJavaScript* 80 | 81 | *name*|*type*|*optional*|*default*|*description* 82 | ---|---|---|---|--- 83 | scriptCode|String|False||some code 84 | 85 | 86 | --- 87 | VBA Procedure: **code** 88 | Type: **Get** 89 | Returns: **String** 90 | Return description: **the code** 91 | Scope: **Public** 92 | Description: **returns the code** 93 | 94 | *Public Property Get code() As String* 95 | 96 | **no arguments required for this procedure** 97 | 98 | 99 | --- 100 | VBA Procedure: **self** 101 | Type: **Get** 102 | Returns: **[cJavaScript](/scripts/cJavaScript_cls.md "cJavaScript")** 103 | Return description: **self** 104 | Scope: **Public** 105 | Description: **returns convenience self for with/chaining** 106 | 107 | *Public Property Get self() As cJavaScript* 108 | 109 | **no arguments required for this procedure** 110 | 111 | 112 | --- 113 | VBA Procedure: **clear** 114 | Type: **Function** 115 | Returns: **[cJavaScript](/scripts/cJavaScript_cls.md "cJavaScript")** 116 | Return description: **self** 117 | Scope: **Public** 118 | Description: **clears the code** 119 | 120 | *Public Function clear() As cJavaScript* 121 | 122 | **no arguments required for this procedure** 123 | 124 | 125 | --- 126 | VBA Procedure: **chunker** 127 | Type: **Get** 128 | Returns: **[cStringChunker](/libraries/cStringChunker_cls.md "cStringChunker")** 129 | Return description: **the code chunker** 130 | Scope: **Public** 131 | Description: **expose the stringchunker** 132 | 133 | *Public Property Get chunker() As cStringChunker* 134 | 135 | **no arguments required for this procedure** 136 | 137 | 138 | --- 139 | VBA Procedure: **compile** 140 | Type: **Function** 141 | Returns: **Variant** 142 | Return description: **the script control to execute run against** 143 | Scope: **Public** 144 | Description: **execute code** 145 | 146 | *Public Function compile() As Variant* 147 | 148 | **no arguments required for this procedure** 149 | 150 | 151 | --- 152 | VBA Procedure: **addArraySupport** 153 | Type: **Function** 154 | Returns: **[cJavaScript](/scripts/cJavaScript_cls.md "cJavaScript")** 155 | Return description: **self** 156 | Scope: **Public** 157 | Description: **if you need to deal with arrays, this will convert back and forwards from JS to vba** 158 | 159 | *Public Function addArraySupport() As cJavaScript* 160 | 161 | **no arguments required for this procedure** 162 | 163 | 164 | --- 165 | VBA Procedure: **removeHtmlEscape** 166 | Type: **Function** 167 | Returns: **String** 168 | Return description: **** 169 | Scope: **Public** 170 | Description: **** 171 | 172 | *Public Function removeHtmlEscape(t As String) As String* 173 | 174 | *name*|*type*|*optional*|*default*|*description* 175 | ---|---|---|---|--- 176 | t|String|False|| 177 | 178 | 179 | --- 180 | VBA Procedure: **removeScriptTags** 181 | Type: **Function** 182 | Returns: **[cJavaScript](/scripts/cJavaScript_cls.md "cJavaScript")** 183 | Return description: **self** 184 | Scope: **Public** 185 | Description: **apps script sometimes have script tags** 186 | 187 | *Public Function removeScriptTags() As cJavaScript* 188 | 189 | **no arguments required for this procedure** 190 | 191 | 192 | --- 193 | VBA Procedure: **Class_Initialize** 194 | Type: **Sub** 195 | Returns: **void** 196 | Return description: **** 197 | Scope: **Private** 198 | Description: **** 199 | 200 | *Private Sub Class_Initialize()* 201 | 202 | **no arguments required for this procedure** 203 | -------------------------------------------------------------------------------- /scripts/jscript.vba: -------------------------------------------------------------------------------- 1 | Option Explicit 2 | ' 3 | Private Function testGas() 4 | Dim js As New cJavaScript, start As Double, numberOfTests As Long, result As Variant 5 | numberOfTests = 10000 6 | 7 | With js 8 | ' not really necessary first time in 9 | .clear 10 | 11 | ' here's a couple of polyfills to bring it more or less up to apps-script levels 12 | .addUrl "https://cdnjs.cloudflare.com/ajax/libs/json2/20150503/json2.min.js" 13 | .addUrl "https://cdnjs.cloudflare.com/ajax/libs/es5-shim/4.1.7/es5-shim.min.js" 14 | 15 | ' get my code from apps script 16 | .addAppsScript "https://script.google.com/macros/s/AKfycbzVhdyNg3-9jBu6KSLkYIwN48vuXCp6moOLQzQa7eXar7HdWe8/exec?manifests=color" 17 | 18 | ' my code 19 | .addCode ("function compareColors (rgb1, rgb2) { " & _ 20 | " return theColorProp(rgb1).compareColorProps(theColorProp(rgb2).getProperties()) ; " & _ 21 | "}" & _ 22 | "function compareColorTest (numberOfTests) {" & _ 23 | "for (var i = 0 , t = 0 ; i < numberOfTests ; i++ ) { " & _ 24 | " t += compareColors ( Math.round(Math.random() * VBCOLORS.vbWhite) , Math.round(Math.random() * VBCOLORS.vbWhite) ); " & _ 25 | "}" & _ 26 | " return 'average color distance:' + t/i;" & _ 27 | "}" & _ 28 | "function theColorProp (rgb1) { " & _ 29 | " return new ColorMath(rgb1) ; " & _ 30 | "}" & _ 31 | "function theColorPropStringified (rgb1) { " & _ 32 | " return JSON.stringify(theColorProp(rgb1).getProperties()) ; " & _ 33 | "}") 34 | 35 | 'a stringified color properties 36 | Debug.Print .compile.run("theColorPropStringified", vbBlue) 37 | 38 | 'compare a couple of colors 39 | Debug.Print .compile.run("compareColors", vbBlue, vbRed) 40 | 41 | ' do a performance test 42 | start = tinyTime 43 | result = .compile.run("compareColorTest", numberOfTests) 44 | Debug.Print "time to complete in JS " & (tinyTime - start) 45 | Debug.Print result 46 | 47 | End With 48 | 49 | End Function 50 | Private Function comparePerformance() 51 | Dim js As New cJavaScript, result As Variant, start As Double, numberOfTests As Long, i As Long, t As Double 52 | numberOfTests = 20000 53 | 54 | With js 55 | ' not really necessary first time in 56 | .clear 57 | 58 | ' its old enough not to have JSON.parse/.stringify - so we'll polyfill that 59 | .addUrl "https://cdnjs.cloudflare.com/ajax/libs/json2/20150503/json2.min.js" 60 | 61 | ' get my apps script code from git hub 62 | .addUrl "https://raw.githubusercontent.com/brucemcpherson/ColorArranger/master/scripts/ColorMath.js.html" 63 | 64 | ' apps script html/js files often have script tags embedded 65 | .removeScriptTags 66 | 67 | ' my code 68 | .addCode ("function compareColors (rgb1, rgb2) { " & _ 69 | " return theColorProp(rgb1).compareColorProps(theColorProp(rgb2).getProperties()) ; " & _ 70 | "}" & _ 71 | "function compareColorTest (numberOfTests) {" & _ 72 | "for (var i = 0 , t = 0 ; i < numberOfTests ; i++ ) { " & _ 73 | " t += compareColors ( Math.round(Math.random() * VBCOLORS.vbWhite) , Math.round(Math.random() * VBCOLORS.vbWhite) ); " & _ 74 | "}" & _ 75 | " return 'average color distance:' + t/i;" & _ 76 | "}" & _ 77 | "function theColorProp (rgb1) { " & _ 78 | " return new ColorMath(rgb1) ; " & _ 79 | "}" & _ 80 | "function theColorPropStringified (rgb1) { " & _ 81 | " return JSON.stringify(theColorProp(rgb1).getProperties()) ; " & _ 82 | "}") 83 | 84 | 'a stringified color properties 85 | Debug.Print .compile.run("theColorPropStringified", vbBlue) 86 | 87 | 'compare a couple of colors 88 | Debug.Print .compile.run("compareColors", vbBlue, vbRed) 89 | 90 | ' do a performance test 91 | start = tinyTime 92 | result = .compile.run("compareColorTest", numberOfTests) 93 | Debug.Print "time to complete in JS " & (tinyTime - start) 94 | Debug.Print result 95 | End With 96 | 97 | ' now lets do the same thing in native VBA - can't easily stringify a custom type so I'll just do one prop of it 98 | Debug.Print makeColorProps(vbBlue).htmlHex 99 | 100 | 'compare a couple of colors 101 | Debug.Print compareColors(vbBlue, vbRed) 102 | 103 | ' compare loads of colors and time it 104 | start = tinyTime 105 | t = 0 106 | For i = 1 To numberOfTests 107 | t = t + compareColors(CLng(Round(Rnd() * vbWhite)), CLng(Round(Rnd() * vbWhite))) 108 | Next i 109 | 110 | Debug.Print "time to complete in VBA " & (tinyTime - start) 111 | Debug.Print "Average Color distance: " & (t / numberOfTests) 112 | 113 | End Function 114 | Private Function testGit() 115 | Dim js As New cJavaScript, result As String 116 | 117 | With js 118 | ' not really necessary first time in 119 | .clear 120 | 121 | ' its old enough not to have JSON.parse/.stringify - so we'll polyfill that 122 | .addUrl "https://cdnjs.cloudflare.com/ajax/libs/json2/20150503/json2.min.js" 123 | 124 | ' get my apps script code from git hub 125 | .addUrl "https://raw.githubusercontent.com/brucemcpherson/ColorArranger/master/scripts/ColorMath.js.html" 126 | 127 | ' apps script html/js files often have script tags embedded 128 | .removeScriptTags 129 | 130 | ' my code 131 | .addCode "function getColorProperties (hex) { " & _ 132 | " return JSON.stringify(VBCOLORS); " & _ 133 | "}" 134 | 135 | 'try these out 136 | result = .compile.run("myTest") 137 | 138 | Debug.Print result 139 | End With 140 | 141 | End Function 142 | 143 | Private Function testJs() 144 | Dim js As New cJavaScript, encrypted As String, decrypted As String 145 | 146 | With js 147 | ' not really necessary first time in 148 | .clear 149 | 150 | ' add libraries - I want to try a few different kinds of encryption 151 | .addUrl "http://crypto-js.googlecode.com/svn/tags/3.0.2/build/rollups/aes.js" 152 | .addUrl "http://crypto-js.googlecode.com/svn/tags/3.0.2/build/rollups/tripledes.js" 153 | .addUrl "http://crypto-js.googlecode.com/svn/tags/3.0.2/build/rollups/rabbit.js" 154 | 155 | ' add my code 156 | .addCode _ 157 | "function encrypt(msg, pass, method) {" & _ 158 | " return CryptoJS[method].encrypt(msg, pass).toString();" & _ 159 | "}" & _ 160 | "function decrypt(encryptedMessage, pass,method) {" & _ 161 | " return CryptoJS[method].decrypt(encryptedMessage, pass, method).toString(CryptoJS.enc.Utf8);" & _ 162 | "}" 163 | 164 | 'various encryptions for fun 165 | encrypted = .compile.run("encrypt", "a message from aes", "my passphrase", "AES") 166 | decrypted = .compile.run("decrypt", encrypted, "my passphrase", "AES") 167 | Debug.Print decrypted, encrypted 168 | 169 | encrypted = .compile.run("encrypt", "a message from tripledes", "my passphrase", "TripleDES") 170 | decrypted = .compile.run("decrypt", encrypted, "my passphrase", "TripleDES") 171 | Debug.Print decrypted, encrypted 172 | 173 | encrypted = .compile.run("encrypt", "a message from rabbit", "my passphrase", "Rabbit") 174 | decrypted = .compile.run("decrypt", encrypted, "my passphrase", "Rabbit") 175 | Debug.Print decrypted, encrypted 176 | End With 177 | 178 | End Function 179 | 180 | Private Function jsvsvbaTests() 181 | Dim js As New cJavaScript, i As Long, vbaResult As Double, _ 182 | javaScriptResult As Double, rgb1 As Long, rgb2 As Long, _ 183 | numberOfTests As Long 184 | 185 | numberOfTests = 10000 186 | With js 187 | ' not really necessary first time in 188 | .clear 189 | 190 | ' here's a couple of polyfills to bring it more or less up to apps-script levels 191 | .addUrl "https://cdnjs.cloudflare.com/ajax/libs/json2/20150503/json2.min.js" 192 | .addUrl "https://cdnjs.cloudflare.com/ajax/libs/es5-shim/4.1.7/es5-shim.min.js" 193 | 194 | ' get my code directly from apps script 195 | .addAppsScript "https://script.google.com/macros/s/AKfycbzVhdyNg3-9jBu6KSLkYIwN48vuXCp6moOLQzQa7eXar7HdWe8/exec?manifests=color" 196 | 197 | ' add my unit test code 198 | .addCode ("function compareColors (rgb1, rgb2) { " & _ 199 | " return new ColorMath(rgb1).compareColorProps(new ColorMath(rgb2).getProperties()) ; " & _ 200 | "}") 201 | 202 | 203 | 'well run lots of random tests and check they are the same 204 | For i = 1 To numberOfTests 205 | 206 | ' get some test data 207 | rgb1 = CLng(Round(Rnd() * vbWhite)) 208 | rgb2 = CLng(Round(Rnd() * vbWhite)) 209 | 210 | ' run it in VBA 211 | vbaResult = compareColors(rgb1, rgb2) 212 | 213 | ' run it in javaScript 214 | javaScriptResult = .compile.run("compareColors", rgb1, rgb2) 215 | 216 | ' should be the same result 217 | ' but need to round a bit as you cant compare doubles for exact equality 218 | ' so we'll compare to 8 decimal places 219 | Debug.Assert Round(vbaResult, 8) = Round(javaScriptResult, 8) 220 | Next i 221 | 222 | 223 | 224 | 225 | End With 226 | End Function -------------------------------------------------------------------------------- /scripts/jscript_vba.md: -------------------------------------------------------------------------------- 1 | # VBA Project: **vbaJavaScript** 2 | ## VBA Module: **[jscript](/scripts/jscript.vba "source is here")** 3 | ### Type: StdModule 4 | 5 | This procedure list for repo (vbaJavaScript) was automatically created on 6/25/2015 10:03:23 AM by VBAGit. 6 | For more information see the [desktop liberation site](http://ramblings.mcpher.com/Home/excelquirks/drivesdk/gettinggithubready "desktop liberation") 7 | 8 | Below is a section for each procedure in jscript 9 | 10 | --- 11 | VBA Procedure: **testGas** 12 | Type: **Function** 13 | Returns: **Variant** 14 | Return description: **** 15 | Scope: **Private** 16 | Description: **** 17 | 18 | *Private Function testGas()* 19 | 20 | **no arguments required for this procedure** 21 | 22 | 23 | --- 24 | VBA Procedure: **comparePerformance** 25 | Type: **Function** 26 | Returns: **Variant** 27 | Return description: **** 28 | Scope: **Private** 29 | Description: **** 30 | 31 | *Private Function comparePerformance()* 32 | 33 | **no arguments required for this procedure** 34 | 35 | 36 | --- 37 | VBA Procedure: **testGit** 38 | Type: **Function** 39 | Returns: **Variant** 40 | Return description: **** 41 | Scope: **Private** 42 | Description: **** 43 | 44 | *Private Function testGit()* 45 | 46 | **no arguments required for this procedure** 47 | 48 | 49 | --- 50 | VBA Procedure: **testJs** 51 | Type: **Function** 52 | Returns: **Variant** 53 | Return description: **** 54 | Scope: **Private** 55 | Description: **** 56 | 57 | *Private Function testJs()* 58 | 59 | **no arguments required for this procedure** 60 | 61 | 62 | --- 63 | VBA Procedure: **jsvsvbaTests** 64 | Type: **Function** 65 | Returns: **Variant** 66 | Return description: **** 67 | Scope: **Private** 68 | Description: **** 69 | 70 | *Private Function jsvsvbaTests()* 71 | 72 | **no arguments required for this procedure** 73 | --------------------------------------------------------------------------------