diff --git a/Ribbon/Ribbon.xml b/Ribbon/Ribbon.xml
index 1738fb3b..607abca0 100644
--- a/Ribbon/Ribbon.xml
+++ b/Ribbon/Ribbon.xml
@@ -14,7 +14,7 @@
-
+
@@ -29,6 +29,7 @@
+
diff --git a/Testing/Testing.accdb.src/dbs-properties.json b/Testing/Testing.accdb.src/dbs-properties.json
index 9d3c26e0..1b91cda3 100644
--- a/Testing/Testing.accdb.src/dbs-properties.json
+++ b/Testing/Testing.accdb.src/dbs-properties.json
@@ -72,6 +72,10 @@
"Value": "DAO",
"Type": 10
},
+ "Date stored as Text": {
+ "Value": "11/17/2023 2:15:08 PM",
+ "Type": 10
+ },
"DesignMasterID": {
"Value": "",
"Type": 15
@@ -84,6 +88,10 @@
"Value": 70,
"Type": 3
},
+ "ISO8601 Date as Text": {
+ "Value": "2023-11-17T17:51:00.000Z",
+ "Type": 10
+ },
"Name": {
"Value": "rel:Testing.accdb",
"Type": 12
@@ -132,6 +140,10 @@
"Value": "",
"Type": 15
},
+ "SavedDateValue": {
+ "Value": "2023-11-17T19:35:41.000Z",
+ "Type": 8
+ },
"Show Navigation Pane Search Bar": {
"Value": 1,
"Type": 4
diff --git a/Testing/Testing.accdb.src/forms/frmColors.bas b/Testing/Testing.accdb.src/forms/frmColors.bas
index 0452bc76..4894b2d4 100644
--- a/Testing/Testing.accdb.src/forms/frmColors.bas
+++ b/Testing/Testing.accdb.src/forms/frmColors.bas
@@ -936,9 +936,4 @@ Begin Form
End
End
CodeBehindForm
-Attribute VB_GlobalNameSpace = False
-Attribute VB_Creatable = True
-Attribute VB_PredeclaredId = True
-Attribute VB_Exposed = False
-Option Compare Database
-Option Explicit
+' See "frmColors.cls"
diff --git a/Testing/Testing.accdb.src/forms/frmColors.cls b/Testing/Testing.accdb.src/forms/frmColors.cls
new file mode 100644
index 00000000..88b9322e
--- /dev/null
+++ b/Testing/Testing.accdb.src/forms/frmColors.cls
@@ -0,0 +1,6 @@
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = True
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = False
+Option Compare Database
+Option Explicit
diff --git a/Testing/Testing.accdb.src/forms/frmExtendedChars.bas b/Testing/Testing.accdb.src/forms/frmExtendedChars.bas
index b366db29..a165e652 100644
--- a/Testing/Testing.accdb.src/forms/frmExtendedChars.bas
+++ b/Testing/Testing.accdb.src/forms/frmExtendedChars.bas
@@ -93,533 +93,4 @@ Begin Form
End
End
CodeBehindForm
-Attribute VB_GlobalNameSpace = False
-Attribute VB_Creatable = True
-Attribute VB_PredeclaredId = True
-Attribute VB_Exposed = False
-Option Compare Database
-Option Explicit
-
-
-'——————————————————————————————————————————————————————————————————————————————————————————¬
-' This module is used to prove that all ASCII characters survive the export\import cycle. |
-'——————————————————————————————————————————————————————————————————————————————————————————+
-
-' ASCII Table Using Windows-1252 codepage
-' Table generated using https://ozh.github.io/ascii-tables/
-'
-' +=====+=====+==========+=======+
-' | Dec | Hex | Binary | Char |
-' +=====+=====+==========+=======+
-' | 0 | 00 | 00000000 | NUL |
-' +-----+-----+----------+-------+
-' | 1 | 01 | 00000001 | SOH |
-' +-----+-----+----------+-------+
-' | 2 | 02 | 00000010 | STX |
-' +-----+-----+----------+-------+
-' | 3 | 03 | 00000011 | ETX |
-' +-----+-----+----------+-------+
-' | 4 | 04 | 00000100 | EOT |
-' +-----+-----+----------+-------+
-' | 5 | 05 | 00000101 | ENQ |
-' +-----+-----+----------+-------+
-' | 6 | 06 | 00000110 | ACK |
-' +-----+-----+----------+-------+
-' | 7 | 07 | 00000111 | BEL |
-' +-----+-----+----------+-------+
-' | 8 | 08 | 00001000 | BS |
-' +-----+-----+----------+-------+
-' | 9 | 09 | 00001001 | HT |
-' +-----+-----+----------+-------+
-' | 10 | 0A | 00001010 | LF |
-' +-----+-----+----------+-------+
-' | 11 | 0B | 00001011 | VT |
-' +-----+-----+----------+-------+
-' | 12 | 0C | 00001100 | FF |
-' +-----+-----+----------+-------+
-' | 13 | 0D | 00001101 | CR |
-' +-----+-----+----------+-------+
-' | 14 | 0E | 00001110 | SO |
-' +-----+-----+----------+-------+
-' | 15 | 0F | 00001111 | SI |
-' +-----+-----+----------+-------+
-' | 16 | 10 | 00010000 | DLE |
-' +-----+-----+----------+-------+
-' | 17 | 11 | 00010001 | DC1 |
-' +-----+-----+----------+-------+
-' | 18 | 12 | 00010010 | DC2 |
-' +-----+-----+----------+-------+
-' | 19 | 13 | 00010011 | DC3 |
-' +-----+-----+----------+-------+
-' | 20 | 14 | 00010100 | DC4 |
-' +-----+-----+----------+-------+
-' | 21 | 15 | 00010101 | NAK |
-' +-----+-----+----------+-------+
-' | 22 | 16 | 00010110 | SYN |
-' +-----+-----+----------+-------+
-' | 23 | 17 | 00010111 | ETB |
-' +-----+-----+----------+-------+
-' | 24 | 18 | 00011000 | CAN |
-' +-----+-----+----------+-------+
-' | 25 | 19 | 00011001 | EM |
-' +-----+-----+----------+-------+
-' | 26 | 1A | 00011010 | SUB |
-' +-----+-----+----------+-------+
-' | 27 | 1B | 00011011 | ESC |
-' +-----+-----+----------+-------+
-' | 28 | 1C | 00011100 | FS |
-' +-----+-----+----------+-------+
-' | 29 | 1D | 00011101 | GS |
-' +-----+-----+----------+-------+
-' | 30 | 1E | 00011110 | RS |
-' +-----+-----+----------+-------+
-' | 31 | 1F | 00011111 | US |
-' +-----+-----+----------+-------+
-' | 32 | 20 | 00100000 | space |
-' +-----+-----+----------+-------+
-' | 33 | 21 | 00100001 | ! |
-' +-----+-----+----------+-------+
-' | 34 | 22 | 00100010 | " |
-' +-----+-----+----------+-------+
-' | 35 | 23 | 00100011 | # |
-' +-----+-----+----------+-------+
-' | 36 | 24 | 00100100 | $ |
-' +-----+-----+----------+-------+
-' | 37 | 25 | 00100101 | % |
-' +-----+-----+----------+-------+
-' | 38 | 26 | 00100110 | & |
-' +-----+-----+----------+-------+
-' | 39 | 27 | 00100111 | ' |
-' +-----+-----+----------+-------+
-' | 40 | 28 | 00101000 | ( |
-' +-----+-----+----------+-------+
-' | 41 | 29 | 00101001 | ) |
-' +-----+-----+----------+-------+
-' | 42 | 2A | 00101010 | * |
-' +-----+-----+----------+-------+
-' | 43 | 2B | 00101011 | + |
-' +-----+-----+----------+-------+
-' | 44 | 2C | 00101100 | , |
-' +-----+-----+----------+-------+
-' | 45 | 2D | 00101101 | - |
-' +-----+-----+----------+-------+
-' | 46 | 2E | 00101110 | . |
-' +-----+-----+----------+-------+
-' | 47 | 2F | 00101111 | / |
-' +-----+-----+----------+-------+
-' | 48 | 30 | 00110000 | 0 |
-' +-----+-----+----------+-------+
-' | 49 | 31 | 00110001 | 1 |
-' +-----+-----+----------+-------+
-' | 50 | 32 | 00110010 | 2 |
-' +-----+-----+----------+-------+
-' | 51 | 33 | 00110011 | 3 |
-' +-----+-----+----------+-------+
-' | 52 | 34 | 00110100 | 4 |
-' +-----+-----+----------+-------+
-' | 53 | 35 | 00110101 | 5 |
-' +-----+-----+----------+-------+
-' | 54 | 36 | 00110110 | 6 |
-' +-----+-----+----------+-------+
-' | 55 | 37 | 00110111 | 7 |
-' +-----+-----+----------+-------+
-' | 56 | 38 | 00111000 | 8 |
-' +-----+-----+----------+-------+
-' | 57 | 39 | 00111001 | 9 |
-' +-----+-----+----------+-------+
-' | 58 | 3A | 00111010 | : |
-' +-----+-----+----------+-------+
-' | 59 | 3B | 00111011 | ; |
-' +-----+-----+----------+-------+
-' | 60 | 3C | 00111100 | < |
-' +-----+-----+----------+-------+
-' | 61 | 3D | 00111101 | = |
-' +-----+-----+----------+-------+
-' | 62 | 3E | 00111110 | > |
-' +-----+-----+----------+-------+
-' | 63 | 3F | 00111111 | ? |
-' +-----+-----+----------+-------+
-' | 64 | 40 | 01000000 | @ |
-' +-----+-----+----------+-------+
-' | 65 | 41 | 01000001 | A |
-' +-----+-----+----------+-------+
-' | 66 | 42 | 01000010 | B |
-' +-----+-----+----------+-------+
-' | 67 | 43 | 01000011 | C |
-' +-----+-----+----------+-------+
-' | 68 | 44 | 01000100 | D |
-' +-----+-----+----------+-------+
-' | 69 | 45 | 01000101 | E |
-' +-----+-----+----------+-------+
-' | 70 | 46 | 01000110 | F |
-' +-----+-----+----------+-------+
-' | 71 | 47 | 01000111 | G |
-' +-----+-----+----------+-------+
-' | 72 | 48 | 01001000 | H |
-' +-----+-----+----------+-------+
-' | 73 | 49 | 01001001 | I |
-' +-----+-----+----------+-------+
-' | 74 | 4A | 01001010 | J |
-' +-----+-----+----------+-------+
-' | 75 | 4B | 01001011 | K |
-' +-----+-----+----------+-------+
-' | 76 | 4C | 01001100 | L |
-' +-----+-----+----------+-------+
-' | 77 | 4D | 01001101 | M |
-' +-----+-----+----------+-------+
-' | 78 | 4E | 01001110 | N |
-' +-----+-----+----------+-------+
-' | 79 | 4F | 01001111 | O |
-' +-----+-----+----------+-------+
-' | 80 | 50 | 01010000 | P |
-' +-----+-----+----------+-------+
-' | 81 | 51 | 01010001 | Q |
-' +-----+-----+----------+-------+
-' | 82 | 52 | 01010010 | R |
-' +-----+-----+----------+-------+
-' | 83 | 53 | 01010011 | S |
-' +-----+-----+----------+-------+
-' | 84 | 54 | 01010100 | T |
-' +-----+-----+----------+-------+
-' | 85 | 55 | 01010101 | U |
-' +-----+-----+----------+-------+
-' | 86 | 56 | 01010110 | V |
-' +-----+-----+----------+-------+
-' | 87 | 57 | 01010111 | W |
-' +-----+-----+----------+-------+
-' | 88 | 58 | 01011000 | X |
-' +-----+-----+----------+-------+
-' | 89 | 59 | 01011001 | Y |
-' +-----+-----+----------+-------+
-' | 90 | 5A | 01011010 | Z |
-' +-----+-----+----------+-------+
-' | 91 | 5B | 01011011 | [ |
-' +-----+-----+----------+-------+
-' | 92 | 5C | 01011100 | \ |
-' +-----+-----+----------+-------+
-' | 93 | 5D | 01011101 | ] |
-' +-----+-----+----------+-------+
-' | 94 | 5E | 01011110 | ^ |
-' +-----+-----+----------+-------+
-' | 95 | 5F | 01011111 | _ |
-' +-----+-----+----------+-------+
-' | 96 | 60 | 01100000 | ` |
-' +-----+-----+----------+-------+
-' | 97 | 61 | 01100001 | a |
-' +-----+-----+----------+-------+
-' | 98 | 62 | 01100010 | b |
-' +-----+-----+----------+-------+
-' | 99 | 63 | 01100011 | c |
-' +-----+-----+----------+-------+
-' | 100 | 64 | 01100100 | d |
-' +-----+-----+----------+-------+
-' | 101 | 65 | 01100101 | e |
-' +-----+-----+----------+-------+
-' | 102 | 66 | 01100110 | f |
-' +-----+-----+----------+-------+
-' | 103 | 67 | 01100111 | g |
-' +-----+-----+----------+-------+
-' | 104 | 68 | 01101000 | h |
-' +-----+-----+----------+-------+
-' | 105 | 69 | 01101001 | i |
-' +-----+-----+----------+-------+
-' | 106 | 6A | 01101010 | j |
-' +-----+-----+----------+-------+
-' | 107 | 6B | 01101011 | k |
-' +-----+-----+----------+-------+
-' | 108 | 6C | 01101100 | l |
-' +-----+-----+----------+-------+
-' | 109 | 6D | 01101101 | m |
-' +-----+-----+----------+-------+
-' | 110 | 6E | 01101110 | n |
-' +-----+-----+----------+-------+
-' | 111 | 6F | 01101111 | o |
-' +-----+-----+----------+-------+
-' | 112 | 70 | 01110000 | p |
-' +-----+-----+----------+-------+
-' | 113 | 71 | 01110001 | q |
-' +-----+-----+----------+-------+
-' | 114 | 72 | 01110010 | r |
-' +-----+-----+----------+-------+
-' | 115 | 73 | 01110011 | s |
-' +-----+-----+----------+-------+
-' | 116 | 74 | 01110100 | t |
-' +-----+-----+----------+-------+
-' | 117 | 75 | 01110101 | u |
-' +-----+-----+----------+-------+
-' | 118 | 76 | 01110110 | v |
-' +-----+-----+----------+-------+
-' | 119 | 77 | 01110111 | w |
-' +-----+-----+----------+-------+
-' | 120 | 78 | 01111000 | x |
-' +-----+-----+----------+-------+
-' | 121 | 79 | 01111001 | y |
-' +-----+-----+----------+-------+
-' | 122 | 7A | 01111010 | z |
-' +-----+-----+----------+-------+
-' | 123 | 7B | 01111011 | { |
-' +-----+-----+----------+-------+
-' | 124 | 7C | 01111100 | | |
-' +-----+-----+----------+-------+
-' | 125 | 7D | 01111101 | } |
-' +-----+-----+----------+-------+
-' | 126 | 7E | 01111110 | ~ |
-' +-----+-----+----------+-------+
-' | 127 | 7F | 01111111 | DEL |
-' +-----+-----+----------+-------+
-' | 128 | 80 | 10000000 | € |
-' +-----+-----+----------+-------+
-' | 129 | 81 | 10000001 | |
-' +-----+-----+----------+-------+
-' | 130 | 82 | 10000010 | ‚ |
-' +-----+-----+----------+-------+
-' | 131 | 83 | 10000011 | ƒ |
-' +-----+-----+----------+-------+
-' | 132 | 84 | 10000100 | „ |
-' +-----+-----+----------+-------+
-' | 133 | 85 | 10000101 | … |
-' +-----+-----+----------+-------+
-' | 134 | 86 | 10000110 | † |
-' +-----+-----+----------+-------+
-' | 135 | 87 | 10000111 | ‡ |
-' +-----+-----+----------+-------+
-' | 136 | 88 | 10001000 | ˆ |
-' +-----+-----+----------+-------+
-' | 137 | 89 | 10001001 | ‰ |
-' +-----+-----+----------+-------+
-' | 138 | 8A | 10001010 | Š |
-' +-----+-----+----------+-------+
-' | 139 | 8B | 10001011 | ‹ |
-' +-----+-----+----------+-------+
-' | 140 | 8C | 10001100 | Π|
-' +-----+-----+----------+-------+
-' | 141 | 8D | 10001101 | |
-' +-----+-----+----------+-------+
-' | 142 | 8E | 10001110 | Ž |
-' +-----+-----+----------+-------+
-' | 143 | 8F | 10001111 | |
-' +-----+-----+----------+-------+
-' | 144 | 90 | 10010000 | |
-' +-----+-----+----------+-------+
-' | 145 | 91 | 10010001 | ‘ |
-' +-----+-----+----------+-------+
-' | 146 | 92 | 10010010 | ’ |
-' +-----+-----+----------+-------+
-' | 147 | 93 | 10010011 | “ |
-' +-----+-----+----------+-------+
-' | 148 | 94 | 10010100 | ” |
-' +-----+-----+----------+-------+
-' | 149 | 95 | 10010101 | • |
-' +-----+-----+----------+-------+
-' | 150 | 96 | 10010110 | – |
-' +-----+-----+----------+-------+
-' | 151 | 97 | 10010111 | — |
-' +-----+-----+----------+-------+
-' | 152 | 98 | 10011000 | ˜ |
-' +-----+-----+----------+-------+
-' | 153 | 99 | 10011001 | ™ |
-' +-----+-----+----------+-------+
-' | 154 | 9A | 10011010 | š |
-' +-----+-----+----------+-------+
-' | 155 | 9B | 10011011 | › |
-' +-----+-----+----------+-------+
-' | 156 | 9C | 10011100 | œ |
-' +-----+-----+----------+-------+
-' | 157 | 9D | 10011101 | |
-' +-----+-----+----------+-------+
-' | 158 | 9E | 10011110 | ž |
-' +-----+-----+----------+-------+
-' | 159 | 9F | 10011111 | Ÿ |
-' +-----+-----+----------+-------+
-' | 160 | A0 | 10100000 | |
-' +-----+-----+----------+-------+
-' | 161 | A1 | 10100001 | ¡ |
-' +-----+-----+----------+-------+
-' | 162 | A2 | 10100010 | ¢ |
-' +-----+-----+----------+-------+
-' | 163 | A3 | 10100011 | £ |
-' +-----+-----+----------+-------+
-' | 164 | A4 | 10100100 | ¤ |
-' +-----+-----+----------+-------+
-' | 165 | A5 | 10100101 | ¥ |
-' +-----+-----+----------+-------+
-' | 166 | A6 | 10100110 | ¦ |
-' +-----+-----+----------+-------+
-' | 167 | A7 | 10100111 | § |
-' +-----+-----+----------+-------+
-' | 168 | A8 | 10101000 | ¨ |
-' +-----+-----+----------+-------+
-' | 169 | A9 | 10101001 | © |
-' +-----+-----+----------+-------+
-' | 170 | AA | 10101010 | ª |
-' +-----+-----+----------+-------+
-' | 171 | AB | 10101011 | « |
-' +-----+-----+----------+-------+
-' | 172 | AC | 10101100 | ¬ |
-' +-----+-----+----------+-------+
-' | 173 | AD | 10101101 | |
-' +-----+-----+----------+-------+
-' | 174 | AE | 10101110 | ® |
-' +-----+-----+----------+-------+
-' | 175 | AF | 10101111 | ¯ |
-' +-----+-----+----------+-------+
-' | 176 | B0 | 10110000 | ° |
-' +-----+-----+----------+-------+
-' | 177 | B1 | 10110001 | ± |
-' +-----+-----+----------+-------+
-' | 178 | B2 | 10110010 | ² |
-' +-----+-----+----------+-------+
-' | 179 | B3 | 10110011 | ³ |
-' +-----+-----+----------+-------+
-' | 180 | B4 | 10110100 | ´ |
-' +-----+-----+----------+-------+
-' | 181 | B5 | 10110101 | µ |
-' +-----+-----+----------+-------+
-' | 182 | B6 | 10110110 | ¶ |
-' +-----+-----+----------+-------+
-' | 183 | B7 | 10110111 | · |
-' +-----+-----+----------+-------+
-' | 184 | B8 | 10111000 | ¸ |
-' +-----+-----+----------+-------+
-' | 185 | B9 | 10111001 | ¹ |
-' +-----+-----+----------+-------+
-' | 186 | BA | 10111010 | º |
-' +-----+-----+----------+-------+
-' | 187 | BB | 10111011 | » |
-' +-----+-----+----------+-------+
-' | 188 | BC | 10111100 | ¼ |
-' +-----+-----+----------+-------+
-' | 189 | BD | 10111101 | ½ |
-' +-----+-----+----------+-------+
-' | 190 | BE | 10111110 | ¾ |
-' +-----+-----+----------+-------+
-' | 191 | BF | 10111111 | ¿ |
-' +-----+-----+----------+-------+
-' | 192 | C0 | 11000000 | À |
-' +-----+-----+----------+-------+
-' | 193 | C1 | 11000001 | Á |
-' +-----+-----+----------+-------+
-' | 194 | C2 | 11000010 | Â |
-' +-----+-----+----------+-------+
-' | 195 | C3 | 11000011 | Ã |
-' +-----+-----+----------+-------+
-' | 196 | C4 | 11000100 | Ä |
-' +-----+-----+----------+-------+
-' | 197 | C5 | 11000101 | Å |
-' +-----+-----+----------+-------+
-' | 198 | C6 | 11000110 | Æ |
-' +-----+-----+----------+-------+
-' | 199 | C7 | 11000111 | Ç |
-' +-----+-----+----------+-------+
-' | 200 | C8 | 11001000 | È |
-' +-----+-----+----------+-------+
-' | 201 | C9 | 11001001 | É |
-' +-----+-----+----------+-------+
-' | 202 | CA | 11001010 | Ê |
-' +-----+-----+----------+-------+
-' | 203 | CB | 11001011 | Ë |
-' +-----+-----+----------+-------+
-' | 204 | CC | 11001100 | Ì |
-' +-----+-----+----------+-------+
-' | 205 | CD | 11001101 | Í |
-' +-----+-----+----------+-------+
-' | 206 | CE | 11001110 | Î |
-' +-----+-----+----------+-------+
-' | 207 | CF | 11001111 | Ï |
-' +-----+-----+----------+-------+
-' | 208 | D0 | 11010000 | Ð |
-' +-----+-----+----------+-------+
-' | 209 | D1 | 11010001 | Ñ |
-' +-----+-----+----------+-------+
-' | 210 | D2 | 11010010 | Ò |
-' +-----+-----+----------+-------+
-' | 211 | D3 | 11010011 | Ó |
-' +-----+-----+----------+-------+
-' | 212 | D4 | 11010100 | Ô |
-' +-----+-----+----------+-------+
-' | 213 | D5 | 11010101 | Õ |
-' +-----+-----+----------+-------+
-' | 214 | D6 | 11010110 | Ö |
-' +-----+-----+----------+-------+
-' | 215 | D7 | 11010111 | × |
-' +-----+-----+----------+-------+
-' | 216 | D8 | 11011000 | Ø |
-' +-----+-----+----------+-------+
-' | 217 | D9 | 11011001 | Ù |
-' +-----+-----+----------+-------+
-' | 218 | DA | 11011010 | Ú |
-' +-----+-----+----------+-------+
-' | 219 | DB | 11011011 | Û |
-' +-----+-----+----------+-------+
-' | 220 | DC | 11011100 | Ü |
-' +-----+-----+----------+-------+
-' | 221 | DD | 11011101 | Ý |
-' +-----+-----+----------+-------+
-' | 222 | DE | 11011110 | Þ |
-' +-----+-----+----------+-------+
-' | 223 | DF | 11011111 | ß |
-' +-----+-----+----------+-------+
-' | 224 | E0 | 11100000 | à |
-' +-----+-----+----------+-------+
-' | 225 | E1 | 11100001 | á |
-' +-----+-----+----------+-------+
-' | 226 | E2 | 11100010 | â |
-' +-----+-----+----------+-------+
-' | 227 | E3 | 11100011 | ã |
-' +-----+-----+----------+-------+
-' | 228 | E4 | 11100100 | ä |
-' +-----+-----+----------+-------+
-' | 229 | E5 | 11100101 | å |
-' +-----+-----+----------+-------+
-' | 230 | E6 | 11100110 | æ |
-' +-----+-----+----------+-------+
-' | 231 | E7 | 11100111 | ç |
-' +-----+-----+----------+-------+
-' | 232 | E8 | 11101000 | è |
-' +-----+-----+----------+-------+
-' | 233 | E9 | 11101001 | é |
-' +-----+-----+----------+-------+
-' | 234 | EA | 11101010 | ê |
-' +-----+-----+----------+-------+
-' | 235 | EB | 11101011 | ë |
-' +-----+-----+----------+-------+
-' | 236 | EC | 11101100 | ì |
-' +-----+-----+----------+-------+
-' | 237 | ED | 11101101 | í |
-' +-----+-----+----------+-------+
-' | 238 | EE | 11101110 | î |
-' +-----+-----+----------+-------+
-' | 239 | EF | 11101111 | ï |
-' +-----+-----+----------+-------+
-' | 240 | F0 | 11110000 | ð |
-' +-----+-----+----------+-------+
-' | 241 | F1 | 11110001 | ñ |
-' +-----+-----+----------+-------+
-' | 242 | F2 | 11110010 | ò |
-' +-----+-----+----------+-------+
-' | 243 | F3 | 11110011 | ó |
-' +-----+-----+----------+-------+
-' | 244 | F4 | 11110100 | ô |
-' +-----+-----+----------+-------+
-' | 245 | F5 | 11110101 | õ |
-' +-----+-----+----------+-------+
-' | 246 | F6 | 11110110 | ö |
-' +-----+-----+----------+-------+
-' | 247 | F7 | 11110111 | ÷ |
-' +-----+-----+----------+-------+
-' | 248 | F8 | 11111000 | ø |
-' +-----+-----+----------+-------+
-' | 249 | F9 | 11111001 | ù |
-' +-----+-----+----------+-------+
-' | 250 | FA | 11111010 | ú |
-' +-----+-----+----------+-------+
-' | 251 | FB | 11111011 | û |
-' +-----+-----+----------+-------+
-' | 252 | FC | 11111100 | ü |
-' +-----+-----+----------+-------+
-' | 253 | FD | 11111101 | ý |
-' +-----+-----+----------+-------+
-' | 254 | FE | 11111110 | þ |
-' +-----+-----+----------+-------+
-' | 255 | FF | 11111111 | ÿ |
-' +-----+-----+----------+-------+
+' See "frmExtendedChars.cls"
diff --git a/Testing/Testing.accdb.src/forms/frmExtendedChars.cls b/Testing/Testing.accdb.src/forms/frmExtendedChars.cls
new file mode 100644
index 00000000..80c58d95
--- /dev/null
+++ b/Testing/Testing.accdb.src/forms/frmExtendedChars.cls
@@ -0,0 +1,530 @@
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = True
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = False
+Option Compare Database
+Option Explicit
+
+
+'——————————————————————————————————————————————————————————————————————————————————————————¬
+' This module is used to prove that all ASCII characters survive the export\import cycle. |
+'——————————————————————————————————————————————————————————————————————————————————————————+
+
+' ASCII Table Using Windows-1252 codepage
+' Table generated using https://ozh.github.io/ascii-tables/
+'
+' +=====+=====+==========+=======+
+' | Dec | Hex | Binary | Char |
+' +=====+=====+==========+=======+
+' | 0 | 00 | 00000000 | NUL |
+' +-----+-----+----------+-------+
+' | 1 | 01 | 00000001 | SOH |
+' +-----+-----+----------+-------+
+' | 2 | 02 | 00000010 | STX |
+' +-----+-----+----------+-------+
+' | 3 | 03 | 00000011 | ETX |
+' +-----+-----+----------+-------+
+' | 4 | 04 | 00000100 | EOT |
+' +-----+-----+----------+-------+
+' | 5 | 05 | 00000101 | ENQ |
+' +-----+-----+----------+-------+
+' | 6 | 06 | 00000110 | ACK |
+' +-----+-----+----------+-------+
+' | 7 | 07 | 00000111 | BEL |
+' +-----+-----+----------+-------+
+' | 8 | 08 | 00001000 | BS |
+' +-----+-----+----------+-------+
+' | 9 | 09 | 00001001 | HT |
+' +-----+-----+----------+-------+
+' | 10 | 0A | 00001010 | LF |
+' +-----+-----+----------+-------+
+' | 11 | 0B | 00001011 | VT |
+' +-----+-----+----------+-------+
+' | 12 | 0C | 00001100 | FF |
+' +-----+-----+----------+-------+
+' | 13 | 0D | 00001101 | CR |
+' +-----+-----+----------+-------+
+' | 14 | 0E | 00001110 | SO |
+' +-----+-----+----------+-------+
+' | 15 | 0F | 00001111 | SI |
+' +-----+-----+----------+-------+
+' | 16 | 10 | 00010000 | DLE |
+' +-----+-----+----------+-------+
+' | 17 | 11 | 00010001 | DC1 |
+' +-----+-----+----------+-------+
+' | 18 | 12 | 00010010 | DC2 |
+' +-----+-----+----------+-------+
+' | 19 | 13 | 00010011 | DC3 |
+' +-----+-----+----------+-------+
+' | 20 | 14 | 00010100 | DC4 |
+' +-----+-----+----------+-------+
+' | 21 | 15 | 00010101 | NAK |
+' +-----+-----+----------+-------+
+' | 22 | 16 | 00010110 | SYN |
+' +-----+-----+----------+-------+
+' | 23 | 17 | 00010111 | ETB |
+' +-----+-----+----------+-------+
+' | 24 | 18 | 00011000 | CAN |
+' +-----+-----+----------+-------+
+' | 25 | 19 | 00011001 | EM |
+' +-----+-----+----------+-------+
+' | 26 | 1A | 00011010 | SUB |
+' +-----+-----+----------+-------+
+' | 27 | 1B | 00011011 | ESC |
+' +-----+-----+----------+-------+
+' | 28 | 1C | 00011100 | FS |
+' +-----+-----+----------+-------+
+' | 29 | 1D | 00011101 | GS |
+' +-----+-----+----------+-------+
+' | 30 | 1E | 00011110 | RS |
+' +-----+-----+----------+-------+
+' | 31 | 1F | 00011111 | US |
+' +-----+-----+----------+-------+
+' | 32 | 20 | 00100000 | space |
+' +-----+-----+----------+-------+
+' | 33 | 21 | 00100001 | ! |
+' +-----+-----+----------+-------+
+' | 34 | 22 | 00100010 | " |
+' +-----+-----+----------+-------+
+' | 35 | 23 | 00100011 | # |
+' +-----+-----+----------+-------+
+' | 36 | 24 | 00100100 | $ |
+' +-----+-----+----------+-------+
+' | 37 | 25 | 00100101 | % |
+' +-----+-----+----------+-------+
+' | 38 | 26 | 00100110 | & |
+' +-----+-----+----------+-------+
+' | 39 | 27 | 00100111 | ' |
+' +-----+-----+----------+-------+
+' | 40 | 28 | 00101000 | ( |
+' +-----+-----+----------+-------+
+' | 41 | 29 | 00101001 | ) |
+' +-----+-----+----------+-------+
+' | 42 | 2A | 00101010 | * |
+' +-----+-----+----------+-------+
+' | 43 | 2B | 00101011 | + |
+' +-----+-----+----------+-------+
+' | 44 | 2C | 00101100 | , |
+' +-----+-----+----------+-------+
+' | 45 | 2D | 00101101 | - |
+' +-----+-----+----------+-------+
+' | 46 | 2E | 00101110 | . |
+' +-----+-----+----------+-------+
+' | 47 | 2F | 00101111 | / |
+' +-----+-----+----------+-------+
+' | 48 | 30 | 00110000 | 0 |
+' +-----+-----+----------+-------+
+' | 49 | 31 | 00110001 | 1 |
+' +-----+-----+----------+-------+
+' | 50 | 32 | 00110010 | 2 |
+' +-----+-----+----------+-------+
+' | 51 | 33 | 00110011 | 3 |
+' +-----+-----+----------+-------+
+' | 52 | 34 | 00110100 | 4 |
+' +-----+-----+----------+-------+
+' | 53 | 35 | 00110101 | 5 |
+' +-----+-----+----------+-------+
+' | 54 | 36 | 00110110 | 6 |
+' +-----+-----+----------+-------+
+' | 55 | 37 | 00110111 | 7 |
+' +-----+-----+----------+-------+
+' | 56 | 38 | 00111000 | 8 |
+' +-----+-----+----------+-------+
+' | 57 | 39 | 00111001 | 9 |
+' +-----+-----+----------+-------+
+' | 58 | 3A | 00111010 | : |
+' +-----+-----+----------+-------+
+' | 59 | 3B | 00111011 | ; |
+' +-----+-----+----------+-------+
+' | 60 | 3C | 00111100 | < |
+' +-----+-----+----------+-------+
+' | 61 | 3D | 00111101 | = |
+' +-----+-----+----------+-------+
+' | 62 | 3E | 00111110 | > |
+' +-----+-----+----------+-------+
+' | 63 | 3F | 00111111 | ? |
+' +-----+-----+----------+-------+
+' | 64 | 40 | 01000000 | @ |
+' +-----+-----+----------+-------+
+' | 65 | 41 | 01000001 | A |
+' +-----+-----+----------+-------+
+' | 66 | 42 | 01000010 | B |
+' +-----+-----+----------+-------+
+' | 67 | 43 | 01000011 | C |
+' +-----+-----+----------+-------+
+' | 68 | 44 | 01000100 | D |
+' +-----+-----+----------+-------+
+' | 69 | 45 | 01000101 | E |
+' +-----+-----+----------+-------+
+' | 70 | 46 | 01000110 | F |
+' +-----+-----+----------+-------+
+' | 71 | 47 | 01000111 | G |
+' +-----+-----+----------+-------+
+' | 72 | 48 | 01001000 | H |
+' +-----+-----+----------+-------+
+' | 73 | 49 | 01001001 | I |
+' +-----+-----+----------+-------+
+' | 74 | 4A | 01001010 | J |
+' +-----+-----+----------+-------+
+' | 75 | 4B | 01001011 | K |
+' +-----+-----+----------+-------+
+' | 76 | 4C | 01001100 | L |
+' +-----+-----+----------+-------+
+' | 77 | 4D | 01001101 | M |
+' +-----+-----+----------+-------+
+' | 78 | 4E | 01001110 | N |
+' +-----+-----+----------+-------+
+' | 79 | 4F | 01001111 | O |
+' +-----+-----+----------+-------+
+' | 80 | 50 | 01010000 | P |
+' +-----+-----+----------+-------+
+' | 81 | 51 | 01010001 | Q |
+' +-----+-----+----------+-------+
+' | 82 | 52 | 01010010 | R |
+' +-----+-----+----------+-------+
+' | 83 | 53 | 01010011 | S |
+' +-----+-----+----------+-------+
+' | 84 | 54 | 01010100 | T |
+' +-----+-----+----------+-------+
+' | 85 | 55 | 01010101 | U |
+' +-----+-----+----------+-------+
+' | 86 | 56 | 01010110 | V |
+' +-----+-----+----------+-------+
+' | 87 | 57 | 01010111 | W |
+' +-----+-----+----------+-------+
+' | 88 | 58 | 01011000 | X |
+' +-----+-----+----------+-------+
+' | 89 | 59 | 01011001 | Y |
+' +-----+-----+----------+-------+
+' | 90 | 5A | 01011010 | Z |
+' +-----+-----+----------+-------+
+' | 91 | 5B | 01011011 | [ |
+' +-----+-----+----------+-------+
+' | 92 | 5C | 01011100 | \ |
+' +-----+-----+----------+-------+
+' | 93 | 5D | 01011101 | ] |
+' +-----+-----+----------+-------+
+' | 94 | 5E | 01011110 | ^ |
+' +-----+-----+----------+-------+
+' | 95 | 5F | 01011111 | _ |
+' +-----+-----+----------+-------+
+' | 96 | 60 | 01100000 | ` |
+' +-----+-----+----------+-------+
+' | 97 | 61 | 01100001 | a |
+' +-----+-----+----------+-------+
+' | 98 | 62 | 01100010 | b |
+' +-----+-----+----------+-------+
+' | 99 | 63 | 01100011 | c |
+' +-----+-----+----------+-------+
+' | 100 | 64 | 01100100 | d |
+' +-----+-----+----------+-------+
+' | 101 | 65 | 01100101 | e |
+' +-----+-----+----------+-------+
+' | 102 | 66 | 01100110 | f |
+' +-----+-----+----------+-------+
+' | 103 | 67 | 01100111 | g |
+' +-----+-----+----------+-------+
+' | 104 | 68 | 01101000 | h |
+' +-----+-----+----------+-------+
+' | 105 | 69 | 01101001 | i |
+' +-----+-----+----------+-------+
+' | 106 | 6A | 01101010 | j |
+' +-----+-----+----------+-------+
+' | 107 | 6B | 01101011 | k |
+' +-----+-----+----------+-------+
+' | 108 | 6C | 01101100 | l |
+' +-----+-----+----------+-------+
+' | 109 | 6D | 01101101 | m |
+' +-----+-----+----------+-------+
+' | 110 | 6E | 01101110 | n |
+' +-----+-----+----------+-------+
+' | 111 | 6F | 01101111 | o |
+' +-----+-----+----------+-------+
+' | 112 | 70 | 01110000 | p |
+' +-----+-----+----------+-------+
+' | 113 | 71 | 01110001 | q |
+' +-----+-----+----------+-------+
+' | 114 | 72 | 01110010 | r |
+' +-----+-----+----------+-------+
+' | 115 | 73 | 01110011 | s |
+' +-----+-----+----------+-------+
+' | 116 | 74 | 01110100 | t |
+' +-----+-----+----------+-------+
+' | 117 | 75 | 01110101 | u |
+' +-----+-----+----------+-------+
+' | 118 | 76 | 01110110 | v |
+' +-----+-----+----------+-------+
+' | 119 | 77 | 01110111 | w |
+' +-----+-----+----------+-------+
+' | 120 | 78 | 01111000 | x |
+' +-----+-----+----------+-------+
+' | 121 | 79 | 01111001 | y |
+' +-----+-----+----------+-------+
+' | 122 | 7A | 01111010 | z |
+' +-----+-----+----------+-------+
+' | 123 | 7B | 01111011 | { |
+' +-----+-----+----------+-------+
+' | 124 | 7C | 01111100 | | |
+' +-----+-----+----------+-------+
+' | 125 | 7D | 01111101 | } |
+' +-----+-----+----------+-------+
+' | 126 | 7E | 01111110 | ~ |
+' +-----+-----+----------+-------+
+' | 127 | 7F | 01111111 | DEL |
+' +-----+-----+----------+-------+
+' | 128 | 80 | 10000000 | € |
+' +-----+-----+----------+-------+
+' | 129 | 81 | 10000001 | |
+' +-----+-----+----------+-------+
+' | 130 | 82 | 10000010 | ‚ |
+' +-----+-----+----------+-------+
+' | 131 | 83 | 10000011 | ƒ |
+' +-----+-----+----------+-------+
+' | 132 | 84 | 10000100 | „ |
+' +-----+-----+----------+-------+
+' | 133 | 85 | 10000101 | … |
+' +-----+-----+----------+-------+
+' | 134 | 86 | 10000110 | † |
+' +-----+-----+----------+-------+
+' | 135 | 87 | 10000111 | ‡ |
+' +-----+-----+----------+-------+
+' | 136 | 88 | 10001000 | ˆ |
+' +-----+-----+----------+-------+
+' | 137 | 89 | 10001001 | ‰ |
+' +-----+-----+----------+-------+
+' | 138 | 8A | 10001010 | Š |
+' +-----+-----+----------+-------+
+' | 139 | 8B | 10001011 | ‹ |
+' +-----+-----+----------+-------+
+' | 140 | 8C | 10001100 | Π|
+' +-----+-----+----------+-------+
+' | 141 | 8D | 10001101 | |
+' +-----+-----+----------+-------+
+' | 142 | 8E | 10001110 | Ž |
+' +-----+-----+----------+-------+
+' | 143 | 8F | 10001111 | |
+' +-----+-----+----------+-------+
+' | 144 | 90 | 10010000 | |
+' +-----+-----+----------+-------+
+' | 145 | 91 | 10010001 | ‘ |
+' +-----+-----+----------+-------+
+' | 146 | 92 | 10010010 | ’ |
+' +-----+-----+----------+-------+
+' | 147 | 93 | 10010011 | “ |
+' +-----+-----+----------+-------+
+' | 148 | 94 | 10010100 | ” |
+' +-----+-----+----------+-------+
+' | 149 | 95 | 10010101 | • |
+' +-----+-----+----------+-------+
+' | 150 | 96 | 10010110 | – |
+' +-----+-----+----------+-------+
+' | 151 | 97 | 10010111 | — |
+' +-----+-----+----------+-------+
+' | 152 | 98 | 10011000 | ˜ |
+' +-----+-----+----------+-------+
+' | 153 | 99 | 10011001 | ™ |
+' +-----+-----+----------+-------+
+' | 154 | 9A | 10011010 | š |
+' +-----+-----+----------+-------+
+' | 155 | 9B | 10011011 | › |
+' +-----+-----+----------+-------+
+' | 156 | 9C | 10011100 | œ |
+' +-----+-----+----------+-------+
+' | 157 | 9D | 10011101 | |
+' +-----+-----+----------+-------+
+' | 158 | 9E | 10011110 | ž |
+' +-----+-----+----------+-------+
+' | 159 | 9F | 10011111 | Ÿ |
+' +-----+-----+----------+-------+
+' | 160 | A0 | 10100000 | |
+' +-----+-----+----------+-------+
+' | 161 | A1 | 10100001 | ¡ |
+' +-----+-----+----------+-------+
+' | 162 | A2 | 10100010 | ¢ |
+' +-----+-----+----------+-------+
+' | 163 | A3 | 10100011 | £ |
+' +-----+-----+----------+-------+
+' | 164 | A4 | 10100100 | ¤ |
+' +-----+-----+----------+-------+
+' | 165 | A5 | 10100101 | ¥ |
+' +-----+-----+----------+-------+
+' | 166 | A6 | 10100110 | ¦ |
+' +-----+-----+----------+-------+
+' | 167 | A7 | 10100111 | § |
+' +-----+-----+----------+-------+
+' | 168 | A8 | 10101000 | ¨ |
+' +-----+-----+----------+-------+
+' | 169 | A9 | 10101001 | © |
+' +-----+-----+----------+-------+
+' | 170 | AA | 10101010 | ª |
+' +-----+-----+----------+-------+
+' | 171 | AB | 10101011 | « |
+' +-----+-----+----------+-------+
+' | 172 | AC | 10101100 | ¬ |
+' +-----+-----+----------+-------+
+' | 173 | AD | 10101101 | |
+' +-----+-----+----------+-------+
+' | 174 | AE | 10101110 | ® |
+' +-----+-----+----------+-------+
+' | 175 | AF | 10101111 | ¯ |
+' +-----+-----+----------+-------+
+' | 176 | B0 | 10110000 | ° |
+' +-----+-----+----------+-------+
+' | 177 | B1 | 10110001 | ± |
+' +-----+-----+----------+-------+
+' | 178 | B2 | 10110010 | ² |
+' +-----+-----+----------+-------+
+' | 179 | B3 | 10110011 | ³ |
+' +-----+-----+----------+-------+
+' | 180 | B4 | 10110100 | ´ |
+' +-----+-----+----------+-------+
+' | 181 | B5 | 10110101 | µ |
+' +-----+-----+----------+-------+
+' | 182 | B6 | 10110110 | ¶ |
+' +-----+-----+----------+-------+
+' | 183 | B7 | 10110111 | · |
+' +-----+-----+----------+-------+
+' | 184 | B8 | 10111000 | ¸ |
+' +-----+-----+----------+-------+
+' | 185 | B9 | 10111001 | ¹ |
+' +-----+-----+----------+-------+
+' | 186 | BA | 10111010 | º |
+' +-----+-----+----------+-------+
+' | 187 | BB | 10111011 | » |
+' +-----+-----+----------+-------+
+' | 188 | BC | 10111100 | ¼ |
+' +-----+-----+----------+-------+
+' | 189 | BD | 10111101 | ½ |
+' +-----+-----+----------+-------+
+' | 190 | BE | 10111110 | ¾ |
+' +-----+-----+----------+-------+
+' | 191 | BF | 10111111 | ¿ |
+' +-----+-----+----------+-------+
+' | 192 | C0 | 11000000 | À |
+' +-----+-----+----------+-------+
+' | 193 | C1 | 11000001 | Á |
+' +-----+-----+----------+-------+
+' | 194 | C2 | 11000010 | Â |
+' +-----+-----+----------+-------+
+' | 195 | C3 | 11000011 | Ã |
+' +-----+-----+----------+-------+
+' | 196 | C4 | 11000100 | Ä |
+' +-----+-----+----------+-------+
+' | 197 | C5 | 11000101 | Å |
+' +-----+-----+----------+-------+
+' | 198 | C6 | 11000110 | Æ |
+' +-----+-----+----------+-------+
+' | 199 | C7 | 11000111 | Ç |
+' +-----+-----+----------+-------+
+' | 200 | C8 | 11001000 | È |
+' +-----+-----+----------+-------+
+' | 201 | C9 | 11001001 | É |
+' +-----+-----+----------+-------+
+' | 202 | CA | 11001010 | Ê |
+' +-----+-----+----------+-------+
+' | 203 | CB | 11001011 | Ë |
+' +-----+-----+----------+-------+
+' | 204 | CC | 11001100 | Ì |
+' +-----+-----+----------+-------+
+' | 205 | CD | 11001101 | Í |
+' +-----+-----+----------+-------+
+' | 206 | CE | 11001110 | Î |
+' +-----+-----+----------+-------+
+' | 207 | CF | 11001111 | Ï |
+' +-----+-----+----------+-------+
+' | 208 | D0 | 11010000 | Ð |
+' +-----+-----+----------+-------+
+' | 209 | D1 | 11010001 | Ñ |
+' +-----+-----+----------+-------+
+' | 210 | D2 | 11010010 | Ò |
+' +-----+-----+----------+-------+
+' | 211 | D3 | 11010011 | Ó |
+' +-----+-----+----------+-------+
+' | 212 | D4 | 11010100 | Ô |
+' +-----+-----+----------+-------+
+' | 213 | D5 | 11010101 | Õ |
+' +-----+-----+----------+-------+
+' | 214 | D6 | 11010110 | Ö |
+' +-----+-----+----------+-------+
+' | 215 | D7 | 11010111 | × |
+' +-----+-----+----------+-------+
+' | 216 | D8 | 11011000 | Ø |
+' +-----+-----+----------+-------+
+' | 217 | D9 | 11011001 | Ù |
+' +-----+-----+----------+-------+
+' | 218 | DA | 11011010 | Ú |
+' +-----+-----+----------+-------+
+' | 219 | DB | 11011011 | Û |
+' +-----+-----+----------+-------+
+' | 220 | DC | 11011100 | Ü |
+' +-----+-----+----------+-------+
+' | 221 | DD | 11011101 | Ý |
+' +-----+-----+----------+-------+
+' | 222 | DE | 11011110 | Þ |
+' +-----+-----+----------+-------+
+' | 223 | DF | 11011111 | ß |
+' +-----+-----+----------+-------+
+' | 224 | E0 | 11100000 | à |
+' +-----+-----+----------+-------+
+' | 225 | E1 | 11100001 | á |
+' +-----+-----+----------+-------+
+' | 226 | E2 | 11100010 | â |
+' +-----+-----+----------+-------+
+' | 227 | E3 | 11100011 | ã |
+' +-----+-----+----------+-------+
+' | 228 | E4 | 11100100 | ä |
+' +-----+-----+----------+-------+
+' | 229 | E5 | 11100101 | å |
+' +-----+-----+----------+-------+
+' | 230 | E6 | 11100110 | æ |
+' +-----+-----+----------+-------+
+' | 231 | E7 | 11100111 | ç |
+' +-----+-----+----------+-------+
+' | 232 | E8 | 11101000 | è |
+' +-----+-----+----------+-------+
+' | 233 | E9 | 11101001 | é |
+' +-----+-----+----------+-------+
+' | 234 | EA | 11101010 | ê |
+' +-----+-----+----------+-------+
+' | 235 | EB | 11101011 | ë |
+' +-----+-----+----------+-------+
+' | 236 | EC | 11101100 | ì |
+' +-----+-----+----------+-------+
+' | 237 | ED | 11101101 | í |
+' +-----+-----+----------+-------+
+' | 238 | EE | 11101110 | î |
+' +-----+-----+----------+-------+
+' | 239 | EF | 11101111 | ï |
+' +-----+-----+----------+-------+
+' | 240 | F0 | 11110000 | ð |
+' +-----+-----+----------+-------+
+' | 241 | F1 | 11110001 | ñ |
+' +-----+-----+----------+-------+
+' | 242 | F2 | 11110010 | ò |
+' +-----+-----+----------+-------+
+' | 243 | F3 | 11110011 | ó |
+' +-----+-----+----------+-------+
+' | 244 | F4 | 11110100 | ô |
+' +-----+-----+----------+-------+
+' | 245 | F5 | 11110101 | õ |
+' +-----+-----+----------+-------+
+' | 246 | F6 | 11110110 | ö |
+' +-----+-----+----------+-------+
+' | 247 | F7 | 11110111 | ÷ |
+' +-----+-----+----------+-------+
+' | 248 | F8 | 11111000 | ø |
+' +-----+-----+----------+-------+
+' | 249 | F9 | 11111001 | ù |
+' +-----+-----+----------+-------+
+' | 250 | FA | 11111010 | ú |
+' +-----+-----+----------+-------+
+' | 251 | FB | 11111011 | û |
+' +-----+-----+----------+-------+
+' | 252 | FC | 11111100 | ü |
+' +-----+-----+----------+-------+
+' | 253 | FD | 11111101 | ý |
+' +-----+-----+----------+-------+
+' | 254 | FE | 11111110 | þ |
+' +-----+-----+----------+-------+
+' | 255 | FF | 11111111 | ÿ |
+' +-----+-----+----------+-------+
diff --git a/Testing/Testing.accdb.src/forms/frmMain.bas b/Testing/Testing.accdb.src/forms/frmMain.bas
index db651d2e..e219531e 100644
--- a/Testing/Testing.accdb.src/forms/frmMain.bas
+++ b/Testing/Testing.accdb.src/forms/frmMain.bas
@@ -364,261 +364,4 @@ Begin Form
End
End
CodeBehindForm
-Attribute VB_GlobalNameSpace = False
-Attribute VB_Creatable = True
-Attribute VB_PredeclaredId = True
-Attribute VB_Exposed = False
-Option Compare Database
-Option Explicit
-
-
-' Keep track of total results
-Private m_Totals(True To False) As Integer
-
-
-'---------------------------------------------------------------------------------------
-' Procedure : cmdRunTests_Click
-' Author : Adam Waller
-' Date : 5/1/2020
-' Purpose : Trying to keep things simple here... Verify that the object exists in the
-' : correct format. (Adjust as needed)
-'---------------------------------------------------------------------------------------
-'
-Public Sub cmdRunTests_Click()
-
- Dim strTest As String
- Dim intTest As Integer
- Dim dbs As DAO.Database
- Dim rsc As SharedResource
-
- Set dbs = CurrentDb
-
- ' Clear list and totals
- lstResults.RowSource = ""
- m_Totals(True) = 0
- m_Totals(False) = 0
-
- ' Ignore any errors.
- ' NOTE: don't include the test result on a line that may throw an error.
- On Error Resume Next
-
- ' Update linked tables/CSV to use the current directory
- dbs.TableDefs("tblLinkedAccess").Connect = ";DATABASE=" & Application.CurrentProject.Path & "\Testing.accdb"
- dbs.TableDefs("tblLinkedAccess").RefreshLink
- dbs.TableDefs("tblLinkedCSV").Connect = "Text;DSN=Linked Link Specification;FMT=Delimited;HDR=NO;IMEX=2;CharacterSet=437;ACCDB=YES;DATABASE=" & Application.CurrentProject.Path
- dbs.TableDefs("tblLinkedCSV").RefreshLink
-
- '========================
- ' BEGIN TESTS
- '========================
-
- ' Tables
- strTest = dbs.TableDefs("tblInternal").Name
- ShowResult "Access Table exists", (strTest = "tblInternal")
-
- intTest = 0
- intTest = DCount("*", "tblInternal")
- ShowResult "tblInternal has data", (intTest > 0)
-
- strTest = dbs.TableDefs("tblLinkedCSV").Name
- ShowResult "Linked Table exists", (strTest = "tblLinkedCSV")
-
- intTest = 0
- intTest = DCount("*", "tblLinkedCSV")
- ShowResult "tblLinkedCSV has data", (intTest > 0)
-
- ShowResult "Saved Table Data (TDF)", FSO.FileExists(ExportFolder & "tables\tblInternal.txt")
-
- ShowResult "Saved Table Data (XML)", FSO.FileExists(ExportFolder & "tables\tblSaveXML.xml")
-
- ShowResult "Table SQL", FSO.FileExists(ExportFolder & "tbldefs\tblInternal.sql")
-
- ShowResult "Linked Table JSON", FSO.FileExists(ExportFolder & "tbldefs\tblLinkedCSV.json")
-
- ShowResult "Linked Table structure", FSO.FileExists(ExportFolder & "tbldefs\tblLinkedCSV.sql")
-
- intTest = 0
- intTest = dbs.Relations("tblInternaltblSaveXML").Fields.Count
- ShowResult "Table Relationship", (intTest = 1)
-
- intTest = 0
- intTest = DCount("*", "MSysObjects", "Not IsNull(LvExtra) and Type = 1 and [Name] = 'tblSaveXML'")
- ShowResult "Table Data Macro Exists", (intTest > 0)
-
-
- ' Queries
- strTest = dbs.QueryDefs("qryNavigationPaneGroups").Name
- ShowResult "Query exists", (strTest = "qryNavigationPaneGroups")
-
-
- ' Forms
- strTest = CurrentProject.AllForms("frmMain").Name
- ShowResult "Form exists", (strTest = "frmMain")
-
-
- ' Reports
- strTest = CurrentProject.AllReports("rptNavigationPaneGroups").Name
- ShowResult "Report exists", (strTest = "rptNavigationPaneGroups")
- ShowResult "Landscape Orientation", (Report_rptNonDefaultPaperSize.Printer.Orientation = acPRORLandscape)
- ShowResult "A4 Paper Size", (Report_rptNonDefaultPaperSize.Printer.PaperSize = acPRPSA4)
-
-
- ' Macros
- strTest = CurrentProject.AllMacros("AutoExec").Name
- ShowResult "Macro exists", (strTest = "AutoExec")
-
-
- ' Modules
- strTest = CurrentProject.AllModules("basUtility").Name
- ShowResult "Standard Module exists", (strTest = "basUtility")
- strTest = GetVBProjectForCurrentDB.VBComponents("basExtendedChars").CodeModule.Lines(6, 1)
- ShowResult "Extended ASCII text in VBA", (Mid$(strTest, 10, 1) = Chr(151))
-
- strTest = CurrentProject.AllModules("clsPerson").Name
- ShowResult "Class Module exists", (strTest = "clsPerson")
-
-
- ' Database properties
- strTest = ""
- strTest = dbs.Properties("AppIcon")
- ShowResult "Application Icon is set", (Len(strTest) > 5)
-
- strTest = dbs.Properties("DAOProperty").Value
- ShowResult "Custom Database (DAO) property", (strTest = "DAO")
-
- strTest = CurrentProject.Properties("ProjectProperty").Value
- ShowResult "Custom Project Property", (strTest = "TestValue")
-
- strTest = dbs.Containers("Databases").Documents("SummaryInfo").Properties("Title")
- ShowResult "Database Summary Property (Title)", (strTest = "VCS Testing")
-
- strTest = dbs.Containers("Tables").Documents("tblSaveXML").Properties("Description")
- ShowResult "Navigation pane object description", (strTest = "Saved description in XML table.")
-
- strTest = dbs.Containers("Modules").Documents("basUtility").Properties("Description")
- ShowResult "Module description", (strTest = "My special description on the code module.")
-
- ShowResult "Saved shared images", (CurrentProject.Resources.Count > 2)
-
- ShowResult "Saved import/export specs (XML)", (CurrentProject.ImportExportSpecifications.Count > 0)
-
- strTest = CurrentProject.ImportExportSpecifications(0).Name
- ShowResult "Name of saved specification", (strTest = "Export-MSysIMEXColumns")
-
- strTest = Nz(DLookup("SpecName", "MSysIMEXSpecs", "SpecName=""Test 2"""))
- ShowResult "Saved IMEX spec (Table based)", (strTest = "Test 2")
-
- strTest = Nz(DLookup("Name", "MSysNavPaneGroups", "Name=""My Modules"""))
- ShowResult "Custom navigation pane group", (strTest = "My Modules")
-
- ' VBE Project
- With GetVBProjectForCurrentDB
-
- ShowResult "VBE project name", (.Name = "VCS Testing")
- ShowResult "VBE project description", (.Description = "For automated testing of Version Control")
- ShowResult "Help context id", (.HelpContextId = 123456)
-
- strTest = .References("Scripting").Name
- ShowResult "GUID reference (scripting)", (strTest = "Scripting")
-
- strTest = .References("MSForms").Name
- ShowResult "MS Forms 2.0 reference", (strTest = "MSForms")
-
- End With
-
- ' Theme
- strTest = CurrentDb.Properties("Theme Resource Name")
- ShowResult "Active theme = Angles", (strTest = "Angles")
-
- strTest = vbNullString
- For Each rsc In CurrentProject.Resources
- If rsc.Type = acResourceTheme Then
- strTest = rsc.Name
- If strTest = "Angles" Then Exit For
- End If
- Next rsc
- ShowResult "Theme resource exists", (strTest = "Angles")
-
- ' Other
- ShowResult "VCS Options file exists", FSO.FileExists(ExportFolder & "vcs-options.json")
-
-
- '========================
- ' END TESTS
- '========================
-
- ' Display results
- lblResults.Caption = _
- m_Totals(True) & " tests passed" & vbCrLf & _
- m_Totals(False) & " tests failed"
-
- If m_Totals(False) = 0 Then
- imgResult.Picture = "button_ok"
- Else
- imgResult.Picture = "button_error"
- End If
-
- If Err Then Err.Clear
-
-End Sub
-
-
-
-
-'---------------------------------------------------------------------------------------
-' Procedure : ShowResult
-' Author : Adam Waller
-' Date : 5/1/2020
-' Purpose : Add the result to the list.
-'---------------------------------------------------------------------------------------
-'
-Private Function ShowResult(strText As String, blnPassed As Boolean)
- Dim strIcon As String
- If blnPassed Then
- strIcon = ChrW(10004) ' Check
- Else
- strIcon = ChrW(10060) ' X
- End If
- lstResults.AddItem strIcon & ";" & strText
- m_Totals(blnPassed) = m_Totals(blnPassed) + 1
- DoEvents
-End Function
-
-
-'---------------------------------------------------------------------------------------
-' Procedure : cmdEditTests_Click
-' Author : Adam Waller
-' Date : 5/1/2020
-' Purpose : Go to the code where you can edit the tests.
-'---------------------------------------------------------------------------------------
-'
-Private Sub cmdEditTests_Click()
- Dim intLine As Integer
- VBE.MainWindow.Visible = True
- With VBE.VBProjects("VCS Testing").VBComponents("Form_frmMain")
- .Activate
- With .CodeModule
- intLine = 27 + .ProcStartLine("cmdRunTests_Click", vbext_pk_Proc)
- .CodePane.SetSelection intLine, 1, intLine, 1
- .CodePane.Show
- End With
- End With
- AppActivate VBE.MainWindow.Caption
-End Sub
-
-
-'---------------------------------------------------------------------------------------
-' Procedure : ExportFolder
-' Author : Adam Waller
-' Date : 5/7/2020
-' Purpose : Return base export folder for testing for source files.
-'---------------------------------------------------------------------------------------
-'
-Private Function ExportFolder() As String
- ExportFolder = CurrentProject.FullName & ".src\"
-End Function
-
-
-Private Sub Form_Load()
- imgResult.Picture = vbNullString
-End Sub
+' See "frmMain.cls"
diff --git a/Testing/Testing.accdb.src/forms/frmMain.cls b/Testing/Testing.accdb.src/forms/frmMain.cls
new file mode 100644
index 00000000..c66f5f00
--- /dev/null
+++ b/Testing/Testing.accdb.src/forms/frmMain.cls
@@ -0,0 +1,258 @@
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = True
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = False
+Option Compare Database
+Option Explicit
+
+
+' Keep track of total results
+Private m_Totals(True To False) As Integer
+
+
+'---------------------------------------------------------------------------------------
+' Procedure : cmdRunTests_Click
+' Author : Adam Waller
+' Date : 5/1/2020
+' Purpose : Trying to keep things simple here... Verify that the object exists in the
+' : correct format. (Adjust as needed)
+'---------------------------------------------------------------------------------------
+'
+Public Sub cmdRunTests_Click()
+
+ Dim strTest As String
+ Dim intTest As Integer
+ Dim dbs As DAO.Database
+ Dim rsc As SharedResource
+
+ Set dbs = CurrentDb
+
+ ' Clear list and totals
+ lstResults.RowSource = ""
+ m_Totals(True) = 0
+ m_Totals(False) = 0
+
+ ' Ignore any errors.
+ ' NOTE: don't include the test result on a line that may throw an error.
+ On Error Resume Next
+
+ ' Update linked tables/CSV to use the current directory
+ dbs.TableDefs("tblLinkedAccess").Connect = ";DATABASE=" & Application.CurrentProject.Path & "\Testing.accdb"
+ dbs.TableDefs("tblLinkedAccess").RefreshLink
+ dbs.TableDefs("tblLinkedCSV").Connect = "Text;DSN=Linked Link Specification;FMT=Delimited;HDR=NO;IMEX=2;CharacterSet=437;ACCDB=YES;DATABASE=" & Application.CurrentProject.Path
+ dbs.TableDefs("tblLinkedCSV").RefreshLink
+
+ '========================
+ ' BEGIN TESTS
+ '========================
+
+ ' Tables
+ strTest = dbs.TableDefs("tblInternal").Name
+ ShowResult "Access Table exists", (strTest = "tblInternal")
+
+ intTest = 0
+ intTest = DCount("*", "tblInternal")
+ ShowResult "tblInternal has data", (intTest > 0)
+
+ strTest = dbs.TableDefs("tblLinkedCSV").Name
+ ShowResult "Linked Table exists", (strTest = "tblLinkedCSV")
+
+ intTest = 0
+ intTest = DCount("*", "tblLinkedCSV")
+ ShowResult "tblLinkedCSV has data", (intTest > 0)
+
+ ShowResult "Saved Table Data (TDF)", FSO.FileExists(ExportFolder & "tables\tblInternal.txt")
+
+ ShowResult "Saved Table Data (XML)", FSO.FileExists(ExportFolder & "tables\tblSaveXML.xml")
+
+ ShowResult "Table SQL", FSO.FileExists(ExportFolder & "tbldefs\tblInternal.sql")
+
+ ShowResult "Linked Table JSON", FSO.FileExists(ExportFolder & "tbldefs\tblLinkedCSV.json")
+
+ ShowResult "Linked Table structure", FSO.FileExists(ExportFolder & "tbldefs\tblLinkedCSV.sql")
+
+ intTest = 0
+ intTest = dbs.Relations("tblInternaltblSaveXML").Fields.Count
+ ShowResult "Table Relationship", (intTest = 1)
+
+ intTest = 0
+ intTest = DCount("*", "MSysObjects", "Not IsNull(LvExtra) and Type = 1 and [Name] = 'tblSaveXML'")
+ ShowResult "Table Data Macro Exists", (intTest > 0)
+
+
+ ' Queries
+ strTest = dbs.QueryDefs("qryNavigationPaneGroups").Name
+ ShowResult "Query exists", (strTest = "qryNavigationPaneGroups")
+
+
+ ' Forms
+ strTest = CurrentProject.AllForms("frmMain").Name
+ ShowResult "Form exists", (strTest = "frmMain")
+
+
+ ' Reports
+ strTest = CurrentProject.AllReports("rptNavigationPaneGroups").Name
+ ShowResult "Report exists", (strTest = "rptNavigationPaneGroups")
+ ShowResult "Landscape Orientation", (Report_rptNonDefaultPaperSize.Printer.Orientation = acPRORLandscape)
+ ShowResult "A4 Paper Size", (Report_rptNonDefaultPaperSize.Printer.PaperSize = acPRPSA4)
+
+
+ ' Macros
+ strTest = CurrentProject.AllMacros("AutoExec").Name
+ ShowResult "Macro exists", (strTest = "AutoExec")
+
+
+ ' Modules
+ strTest = CurrentProject.AllModules("basUtility").Name
+ ShowResult "Standard Module exists", (strTest = "basUtility")
+ strTest = GetVBProjectForCurrentDB.VBComponents("basExtendedChars").CodeModule.Lines(6, 1)
+ ShowResult "Extended ASCII text in VBA", (Mid$(strTest, 10, 1) = Chr(151))
+
+ strTest = CurrentProject.AllModules("clsPerson").Name
+ ShowResult "Class Module exists", (strTest = "clsPerson")
+
+
+ ' Database properties
+ strTest = ""
+ strTest = dbs.Properties("AppIcon")
+ ShowResult "Application Icon is set", (Len(strTest) > 5)
+
+ strTest = dbs.Properties("DAOProperty").Value
+ ShowResult "Custom Database (DAO) property", (strTest = "DAO")
+
+ strTest = CurrentProject.Properties("ProjectProperty").Value
+ ShowResult "Custom Project Property", (strTest = "TestValue")
+
+ strTest = dbs.Containers("Databases").Documents("SummaryInfo").Properties("Title")
+ ShowResult "Database Summary Property (Title)", (strTest = "VCS Testing")
+
+ strTest = dbs.Containers("Tables").Documents("tblSaveXML").Properties("Description")
+ ShowResult "Navigation pane object description", (strTest = "Saved description in XML table.")
+
+ strTest = dbs.Containers("Modules").Documents("basUtility").Properties("Description")
+ ShowResult "Module description", (strTest = "My special description on the code module.")
+
+ ShowResult "Saved shared images", (CurrentProject.Resources.Count > 2)
+
+ ShowResult "Saved import/export specs (XML)", (CurrentProject.ImportExportSpecifications.Count > 0)
+
+ strTest = CurrentProject.ImportExportSpecifications(0).Name
+ ShowResult "Name of saved specification", (strTest = "Export-MSysIMEXColumns")
+
+ strTest = Nz(DLookup("SpecName", "MSysIMEXSpecs", "SpecName=""Test 2"""))
+ ShowResult "Saved IMEX spec (Table based)", (strTest = "Test 2")
+
+ strTest = Nz(DLookup("Name", "MSysNavPaneGroups", "Name=""My Modules"""))
+ ShowResult "Custom navigation pane group", (strTest = "My Modules")
+
+ ' VBE Project
+ With GetVBProjectForCurrentDB
+
+ ShowResult "VBE project name", (.Name = "VCS Testing")
+ ShowResult "VBE project description", (.Description = "For automated testing of Version Control")
+ ShowResult "Help context id", (.HelpContextId = 123456)
+
+ strTest = .References("Scripting").Name
+ ShowResult "GUID reference (scripting)", (strTest = "Scripting")
+
+ strTest = .References("MSForms").Name
+ ShowResult "MS Forms 2.0 reference", (strTest = "MSForms")
+
+ End With
+
+ ' Theme
+ strTest = CurrentDb.Properties("Theme Resource Name")
+ ShowResult "Active theme = Angles", (strTest = "Angles")
+
+ strTest = vbNullString
+ For Each rsc In CurrentProject.Resources
+ If rsc.Type = acResourceTheme Then
+ strTest = rsc.Name
+ If strTest = "Angles" Then Exit For
+ End If
+ Next rsc
+ ShowResult "Theme resource exists", (strTest = "Angles")
+
+ ' Other
+ ShowResult "VCS Options file exists", FSO.FileExists(ExportFolder & "vcs-options.json")
+
+
+ '========================
+ ' END TESTS
+ '========================
+
+ ' Display results
+ lblResults.Caption = _
+ m_Totals(True) & " tests passed" & vbCrLf & _
+ m_Totals(False) & " tests failed"
+
+ If m_Totals(False) = 0 Then
+ imgResult.Picture = "button_ok"
+ Else
+ imgResult.Picture = "button_error"
+ End If
+
+ If Err Then Err.Clear
+
+End Sub
+
+
+
+
+'---------------------------------------------------------------------------------------
+' Procedure : ShowResult
+' Author : Adam Waller
+' Date : 5/1/2020
+' Purpose : Add the result to the list.
+'---------------------------------------------------------------------------------------
+'
+Private Function ShowResult(strText As String, blnPassed As Boolean)
+ Dim strIcon As String
+ If blnPassed Then
+ strIcon = ChrW(10004) ' Check
+ Else
+ strIcon = ChrW(10060) ' X
+ End If
+ lstResults.AddItem strIcon & ";" & strText
+ m_Totals(blnPassed) = m_Totals(blnPassed) + 1
+ DoEvents
+End Function
+
+
+'---------------------------------------------------------------------------------------
+' Procedure : cmdEditTests_Click
+' Author : Adam Waller
+' Date : 5/1/2020
+' Purpose : Go to the code where you can edit the tests.
+'---------------------------------------------------------------------------------------
+'
+Private Sub cmdEditTests_Click()
+ Dim intLine As Integer
+ VBE.MainWindow.Visible = True
+ With VBE.VBProjects("VCS Testing").VBComponents("Form_frmMain")
+ .Activate
+ With .CodeModule
+ intLine = 27 + .ProcStartLine("cmdRunTests_Click", vbext_pk_Proc)
+ .CodePane.SetSelection intLine, 1, intLine, 1
+ .CodePane.Show
+ End With
+ End With
+ AppActivate VBE.MainWindow.Caption
+End Sub
+
+
+'---------------------------------------------------------------------------------------
+' Procedure : ExportFolder
+' Author : Adam Waller
+' Date : 5/7/2020
+' Purpose : Return base export folder for testing for source files.
+'---------------------------------------------------------------------------------------
+'
+Private Function ExportFolder() As String
+ ExportFolder = CurrentProject.FullName & ".src\"
+End Function
+
+
+Private Sub Form_Load()
+ imgResult.Picture = vbNullString
+End Sub
diff --git a/Testing/Testing.accdb.src/queries/qryFormControl.bas b/Testing/Testing.accdb.src/queries/qryFormControl.bas
new file mode 100644
index 00000000..33534acc
--- /dev/null
+++ b/Testing/Testing.accdb.src/queries/qryFormControl.bas
@@ -0,0 +1,47 @@
+Operation =1
+Option =0
+Begin InputTables
+End
+Begin OutputColumns
+ Alias ="FormControl"
+ Expression ="[Forms]![frmColors]![Text18]"
+ Alias ="TestExpression"
+ Expression ="IIf([Forms]![frmVCSInstall]![chkUseRibbon],Eval(\"True\"),False)"
+End
+dbBoolean "ReturnsRecords" ="-1"
+dbInteger "ODBCTimeout" ="60"
+dbBoolean "OrderByOn" ="0"
+dbByte "Orientation" ="0"
+dbByte "DefaultView" ="2"
+dbBoolean "FilterOnLoad" ="0"
+dbBoolean "OrderByOnLoad" ="-1"
+dbByte "RecordsetType" ="0"
+dbBoolean "TotalsRow" ="0"
+Begin
+ Begin
+ dbText "Name" ="FormControl"
+ dbLong "AggregateType" ="-1"
+ dbInteger "ColumnWidth" ="1590"
+ dbBoolean "ColumnHidden" ="0"
+ End
+ Begin
+ dbText "Name" ="TestExpression"
+ dbInteger "ColumnWidth" ="1815"
+ dbBoolean "ColumnHidden" ="0"
+ dbLong "AggregateType" ="-1"
+ End
+End
+Begin
+ State =0
+ Left =0
+ Top =0
+ Right =1368
+ Bottom =856
+ Left =-1
+ Top =-1
+ Right =1352
+ Bottom =577
+ Left =0
+ Top =0
+ ColumnsShown =539
+End
diff --git a/Testing/Testing.accdb.src/queries/qryFormControl.sql b/Testing/Testing.accdb.src/queries/qryFormControl.sql
new file mode 100644
index 00000000..0b3d12ab
--- /dev/null
+++ b/Testing/Testing.accdb.src/queries/qryFormControl.sql
@@ -0,0 +1,7 @@
+SELECT
+ [Forms]![frmColors]![Text18] AS FormControl,
+ IIf(
+ [Forms]![frmVCSInstall]![chkUseRibbon],
+ Eval("True"),
+ False
+ ) AS TestExpression;
diff --git a/Testing/Testing.accdb.src/reports/rptDefaultPrinter.bas b/Testing/Testing.accdb.src/reports/rptDefaultPrinter.bas
index d3e1c296..56270d63 100644
--- a/Testing/Testing.accdb.src/reports/rptDefaultPrinter.bas
+++ b/Testing/Testing.accdb.src/reports/rptDefaultPrinter.bas
@@ -91,9 +91,4 @@ Begin Report
End
End
CodeBehindForm
-Attribute VB_GlobalNameSpace = False
-Attribute VB_Creatable = True
-Attribute VB_PredeclaredId = True
-Attribute VB_Exposed = False
-Option Compare Database
-Option Explicit
+' See "rptDefaultPrinter.cls"
diff --git a/Testing/Testing.accdb.src/reports/rptDefaultPrinter.cls b/Testing/Testing.accdb.src/reports/rptDefaultPrinter.cls
new file mode 100644
index 00000000..88b9322e
--- /dev/null
+++ b/Testing/Testing.accdb.src/reports/rptDefaultPrinter.cls
@@ -0,0 +1,6 @@
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = True
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = False
+Option Compare Database
+Option Explicit
diff --git a/Testing/Testing.accdb.src/reports/rptNavigationPaneGroups.bas b/Testing/Testing.accdb.src/reports/rptNavigationPaneGroups.bas
index f8cde805..c4309c26 100644
--- a/Testing/Testing.accdb.src/reports/rptNavigationPaneGroups.bas
+++ b/Testing/Testing.accdb.src/reports/rptNavigationPaneGroups.bas
@@ -278,9 +278,4 @@ Begin Report
End
End
CodeBehindForm
-Attribute VB_GlobalNameSpace = False
-Attribute VB_Creatable = True
-Attribute VB_PredeclaredId = True
-Attribute VB_Exposed = False
-Option Compare Database
-Option Explicit
+' See "rptNavigationPaneGroups.cls"
diff --git a/Testing/Testing.accdb.src/reports/rptNavigationPaneGroups.cls b/Testing/Testing.accdb.src/reports/rptNavigationPaneGroups.cls
new file mode 100644
index 00000000..88b9322e
--- /dev/null
+++ b/Testing/Testing.accdb.src/reports/rptNavigationPaneGroups.cls
@@ -0,0 +1,6 @@
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = True
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = False
+Option Compare Database
+Option Explicit
diff --git a/Testing/Testing.accdb.src/reports/rptNonDefaultPaperSize.bas b/Testing/Testing.accdb.src/reports/rptNonDefaultPaperSize.bas
index 5c540100..64ac69f3 100644
--- a/Testing/Testing.accdb.src/reports/rptNonDefaultPaperSize.bas
+++ b/Testing/Testing.accdb.src/reports/rptNonDefaultPaperSize.bas
@@ -90,9 +90,4 @@ Begin Report
End
End
CodeBehindForm
-Attribute VB_GlobalNameSpace = False
-Attribute VB_Creatable = True
-Attribute VB_PredeclaredId = True
-Attribute VB_Exposed = False
-Option Compare Database
-Option Explicit
+' See "rptNonDefaultPaperSize.cls"
diff --git a/Testing/Testing.accdb.src/reports/rptNonDefaultPaperSize.cls b/Testing/Testing.accdb.src/reports/rptNonDefaultPaperSize.cls
new file mode 100644
index 00000000..88b9322e
--- /dev/null
+++ b/Testing/Testing.accdb.src/reports/rptNonDefaultPaperSize.cls
@@ -0,0 +1,6 @@
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = True
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = False
+Option Compare Database
+Option Explicit
diff --git a/Testing/Testing.accdb.src/vcs-options.json b/Testing/Testing.accdb.src/vcs-options.json
index 6f864346..f01eb3e0 100644
--- a/Testing/Testing.accdb.src/vcs-options.json
+++ b/Testing/Testing.accdb.src/vcs-options.json
@@ -1,6 +1,6 @@
{
"Info": {
- "AddinVersion": "4.0.22",
+ "AddinVersion": "4.0.28",
"AccessVersion": "14.0 32-bit"
},
"Options": {
@@ -36,6 +36,7 @@
"FormatSQL": true,
"ForceImportOriginalQuerySQL": false,
"SaveTableSQL": true,
+ "SplitLayoutFromVBA": true,
"StripPublishOption": true,
"SanitizeColors": 1,
"SanitizeLevel": 2,
diff --git a/Version Control.accda.src/dbs-properties.json b/Version Control.accda.src/dbs-properties.json
index 9c197f0f..d76ba2e8 100644
--- a/Version Control.accda.src/dbs-properties.json
+++ b/Version Control.accda.src/dbs-properties.json
@@ -41,7 +41,7 @@
"Type": 10
},
"AppVersion": {
- "Value": "4.0.22",
+ "Value": "4.0.28",
"Type": 10
},
"Auto Compact": {
diff --git a/Version Control.accda.src/forms/frmVCSConflictList.bas b/Version Control.accda.src/forms/frmVCSConflictList.bas
index 8fce9846..c530c465 100644
--- a/Version Control.accda.src/forms/frmVCSConflictList.bas
+++ b/Version Control.accda.src/forms/frmVCSConflictList.bas
@@ -16,10 +16,8 @@ Begin Form
Width =5040
DatasheetFontHeight =11
ItemSuffix =31
- Left =435
- Top =2250
- Right =12315
- Bottom =7335
+ Right =15720
+ Bottom =11745
RecSrcDt = Begin
0x9bf1b7f2f3a6e540
End
@@ -481,6 +479,13 @@ Private Sub txtDiff_Click()
cboResolution.SetFocus
DoEvents
+ ' Make sure we have a valid tool defined
+ If Not (modObjects.Diff.HasValidCompareTool) Then
+ MsgBox2 "No Compare Tool Defined", _
+ "Please specify a compare tool (i.e. WinMerge, VSCode) in the add-in options.", , vbExclamation
+ Exit Sub
+ End If
+
' Make sure we have a file name to compare
strFileName = Nz(txtFileName)
If strFileName = vbNullString Then
diff --git a/Version Control.accda.src/forms/frmVCSMain.bas b/Version Control.accda.src/forms/frmVCSMain.bas
index 1f90d7b8..bdfc5463 100644
--- a/Version Control.accda.src/forms/frmVCSMain.bas
+++ b/Version Control.accda.src/forms/frmVCSMain.bas
@@ -16,10 +16,10 @@ Begin Form
Width =9360
DatasheetFontHeight =11
ItemSuffix =33
- Left =3225
- Top =2430
- Right =18945
- Bottom =14175
+ Left =20761
+ Top =2250
+ Right =-29055
+ Bottom =13995
OnUnload ="[Event Procedure]"
RecSrcDt = Begin
0x79e78b777268e540
@@ -1749,6 +1749,9 @@ Public objSingleObject As AccessObject
' (The Log object has already been reset at this point, so we can't use Log.LogFilePath.)
Public strLastLogFilePath As String
+' Use this property to set the path to the source files (such as a build triggered from the API)
+Public strSourcePath As String
+
'---------------------------------------------------------------------------------------
' Procedure : cmdBuild_Click
@@ -1760,11 +1763,6 @@ Public strLastLogFilePath As String
Public Sub cmdBuild_Click()
Dim strFolder As String
- Dim strMsg(0 To 2) As String
- Dim intChoice As VbMsgBoxResult
-
- DoCmd.Hourglass True
- DoEvents
' Make sure we use the add-in to build the add-in.
If CodeProject.FullName = CurrentProject.FullName Then
@@ -1774,6 +1772,43 @@ Public Sub cmdBuild_Click()
Exit Sub
End If
+ ' Get source files folder
+ If Len(Me.strSourcePath) Then
+ ' Use specified build folder
+ strFolder = Me.strSourcePath
+ Else
+ ' Attempt to get the source folder from the current database, or from
+ ' a folder picker dialog.
+ strFolder = GetSourceFolder
+ ' Exit out of build if the user cancelled any of the confirmations.
+ If strFolder = vbNullString Then Exit Sub
+ End If
+
+ ' Build project using the selected source folder
+ ' (Use a timer so we can release the reference to this form before beginning the
+ ' build process, just in case we need to import a form with the same name.)
+ If strFolder <> vbNullString Then SetTimer "Build", strFolder, chkFullBuild
+
+End Sub
+
+
+'---------------------------------------------------------------------------------------
+' Procedure : GetSourceFolder
+' Author : Adam Waller
+' Date : 10/19/2023
+' Purpose : Return the source files folder from either the currently open database
+' : or from a folder picker dialog. (Returns an empty string if the user
+' : cancels the selection.)
+'---------------------------------------------------------------------------------------
+'
+Private Function GetSourceFolder() As String
+
+ Dim strMsg(0 To 2) As String
+ Dim intChoice As VbMsgBoxResult
+
+ DoCmd.Hourglass True
+ DoEvents
+
' Close the current database if it is currently open.
If DatabaseFileOpen Then
If FolderHasVcsOptionsFile(Options.GetExportFolder) Then
@@ -1795,18 +1830,18 @@ Public Sub cmdBuild_Click()
End If
If intChoice = vbYes Then
' Rebuild the open project
- strFolder = Options.GetExportFolder
+ GetSourceFolder = Options.GetExportFolder
ElseIf intChoice = vbCancel Then
' Canceled out of build option.
DoCmd.Hourglass False
- Exit Sub
+ Exit Function
End If
End If
End If
' If we aren't doing the current database, then prompt user to find a folder
' with source files to use for the build.
- If strFolder = vbNullString Then
+ If GetSourceFolder = vbNullString Then
' Show a folder picker to select the file with source code.
DoCmd.Hourglass False
@@ -1820,26 +1855,21 @@ Public Sub cmdBuild_Click()
' Selected a folder
If FolderHasVcsOptionsFile(.SelectedItems(1)) Then
' Has source files
- strFolder = .SelectedItems(1) & PathSep
+ GetSourceFolder = .SelectedItems(1) & PathSep
DoCmd.Hourglass True
Else
MsgBox2 "Source files not found", "Required source files were not found in this folder.", _
"You selected: " & .SelectedItems(1), vbExclamation
- Exit Sub
+ Exit Function
End If
Else
' Canceled dialog
- Exit Sub
+ Exit Function
End If
End With
End If
- ' Build project using the selected source folder
- ' (Use a timer so we can release the reference to this form before beginning the
- ' build process, just in case we need to import a form with the same name.)
- If strFolder <> vbNullString Then SetTimer "Build", strFolder, chkFullBuild
-
-End Sub
+End Function
'---------------------------------------------------------------------------------------
@@ -1935,7 +1965,8 @@ End Sub
'
Private Sub cmdClose_Click()
' Ignore the error if the user resumes (cancels the close operation)
- If DebugMode(True) Then On Error Resume Next Else On Error Resume Next
+ LogUnhandledErrors
+ On Error Resume Next
DoCmd.Close acForm, Me.Name
Catch 2501 ' Close form was canceled.
End Sub
@@ -2108,7 +2139,13 @@ End Sub
'---------------------------------------------------------------------------------------
'
Public Sub AutoClose()
- Me.TimerInterval = 2000
+ 'The procedure may be called when the form has been closed.
+ 'In this case, a VBA error may occur, so we check if the
+ 'form is loaded before setting the property. We do not use
+ 'the Me.Name because that would be also an error.
+ If IsLoaded(acForm, "frmVCSMain", False) Then
+ Me.TimerInterval = 2000
+ End If
End Sub
diff --git a/Version Control.accda.src/forms/frmVCSOptions.bas b/Version Control.accda.src/forms/frmVCSOptions.bas
index d9bf3360..d0597872 100644
--- a/Version Control.accda.src/forms/frmVCSOptions.bas
+++ b/Version Control.accda.src/forms/frmVCSOptions.bas
@@ -15,11 +15,11 @@ Begin Form
GridY =24
Width =10080
DatasheetFontHeight =11
- ItemSuffix =250
- Left =-25575
- Top =1500
- Right =-5310
- Bottom =14085
+ ItemSuffix =252
+ Left =3225
+ Top =2430
+ Right =18945
+ Bottom =14175
RecSrcDt = Begin
0x79e78b777268e540
End
@@ -794,8 +794,8 @@ Begin Form
OverlapFlags =247
Left =1020
Top =3360
- TabIndex =2
- Name ="chkStripPublishOption"
+ TabIndex =4
+ Name ="chkExtractThemeFiles"
LayoutCachedLeft =1020
LayoutCachedTop =3360
@@ -806,14 +806,14 @@ Begin Form
OverlapFlags =247
Left =1320
Top =3300
- Width =2640
+ Width =2340
Height =315
ForeColor =5324600
- Name ="Label34"
- Caption ="Strip out Publish Option"
+ Name ="Label112"
+ Caption ="Extract Theme Files"
LayoutCachedLeft =1320
LayoutCachedTop =3300
- LayoutCachedWidth =3960
+ LayoutCachedWidth =3660
LayoutCachedHeight =3615
ForeThemeColorIndex =-1
ForeTint =100.0
@@ -830,7 +830,7 @@ Begin Form
Top =3720
Width =1980
Height =315
- TabIndex =3
+ TabIndex =2
Name ="cboSanitizeLevel"
RowSourceType ="Value List"
ColumnWidths ="0"
@@ -868,7 +868,7 @@ Begin Form
Top =4140
Width =1980
Height =315
- TabIndex =4
+ TabIndex =3
Name ="cboSanitizeColors"
RowSourceType ="Value List"
ColumnWidths ="0"
@@ -990,9 +990,39 @@ Begin Form
Begin CheckBox
OverlapFlags =247
Left =5340
- Top =4620
+ Top =4200
TabIndex =8
- Name ="chkExtractThemeFiles"
+ Name ="chkFormatSQL"
+
+ LayoutCachedLeft =5340
+ LayoutCachedTop =4200
+ LayoutCachedWidth =5600
+ LayoutCachedHeight =4440
+ Begin
+ Begin Label
+ OverlapFlags =247
+ Left =5640
+ Top =4140
+ Width =2340
+ Height =315
+ ForeColor =5324600
+ Name ="Label249"
+ Caption ="Format SQL"
+ LayoutCachedLeft =5640
+ LayoutCachedTop =4140
+ LayoutCachedWidth =7980
+ LayoutCachedHeight =4455
+ ForeThemeColorIndex =-1
+ ForeTint =100.0
+ End
+ End
+ End
+ Begin CheckBox
+ OverlapFlags =247
+ Left =5340
+ Top =4620
+ TabIndex =9
+ Name ="chkSplitLayoutFromVBA"
LayoutCachedLeft =5340
LayoutCachedTop =4620
@@ -1006,8 +1036,8 @@ Begin Form
Width =2340
Height =315
ForeColor =5324600
- Name ="Label112"
- Caption ="Extract Theme Files"
+ Name ="Label251"
+ Caption ="Split Layout from VBA"
LayoutCachedLeft =5640
LayoutCachedTop =4560
LayoutCachedWidth =7980
@@ -1024,7 +1054,7 @@ Begin Form
Top =5100
Width =2700
Height =315
- TabIndex =9
+ TabIndex =10
Name ="txtRunBeforeExport"
LayoutCachedLeft =3540
@@ -1057,7 +1087,7 @@ Begin Form
Top =5520
Width =2700
Height =315
- TabIndex =10
+ TabIndex =11
Name ="txtRunAfterExport"
LayoutCachedLeft =3540
@@ -1089,7 +1119,7 @@ Begin Form
Left =7140
Top =5640
Width =2160
- TabIndex =11
+ TabIndex =12
Name ="cmdExplainOptions"
Caption ="Explain options..."
HyperlinkAddress ="https://github.com/joyfullservice/msaccess-vcs-addin/wiki/Documentation#options"
@@ -1153,20 +1183,6 @@ Begin Form
PressedThemeColorIndex =-1
PressedShade =100.0
End
- Begin Label
- OverlapFlags =247
- Left =6120
- Top =2400
- Width =2160
- Height =240
- FontSize =10
- Name ="Label46"
- Caption ="(Blank for default)"
- LayoutCachedLeft =6120
- LayoutCachedTop =2400
- LayoutCachedWidth =8280
- LayoutCachedHeight =2640
- End
Begin CommandButton
FontUnderline = NotDefault
TabStop = NotDefault
@@ -1176,7 +1192,7 @@ Begin Form
Width =1140
Height =240
FontSize =10
- TabIndex =12
+ TabIndex =13
Name ="cmdPrintSettingsOptions"
Caption ="Options..."
OnClick ="[Event Procedure]"
@@ -1212,35 +1228,19 @@ Begin Form
PressedForeThemeColorIndex =10
PressedForeTint =100.0
End
- Begin CheckBox
+ Begin Label
OverlapFlags =247
- Left =5340
- Top =4200
- TabIndex =13
- Name ="chkFormatSQL"
-
- LayoutCachedLeft =5340
- LayoutCachedTop =4200
- LayoutCachedWidth =5600
- LayoutCachedHeight =4440
- Begin
- Begin Label
- OverlapFlags =247
- Left =5640
- Top =4140
- Width =2340
- Height =315
- ForeColor =5324600
- Name ="Label249"
- Caption ="Format SQL"
- LayoutCachedLeft =5640
- LayoutCachedTop =4140
- LayoutCachedWidth =7980
- LayoutCachedHeight =4455
- ForeThemeColorIndex =-1
- ForeTint =100.0
- End
- End
+ Left =6120
+ Top =2400
+ Width =2160
+ Height =240
+ FontSize =10
+ Name ="Label46"
+ Caption ="(Blank for default)"
+ LayoutCachedLeft =6120
+ LayoutCachedTop =2400
+ LayoutCachedWidth =8280
+ LayoutCachedHeight =2640
End
End
End
@@ -3897,7 +3897,7 @@ Private Sub LoadTableList()
rstTableData.AddNew
rstTableData!TableName = Nz(!Name)
rstTableData!Flags = Nz(!Flags)
- rstTableData!IsSystem = ((lngFlags <> 0) And (lngFlags <> 8) And (lngType = 1))
+ rstTableData!IsSystem = BitSet(lngFlags, 2)
rstTableData!IsHidden = BitSet(lngFlags, 8)
rstTableData!IsLocal = (lngType = 1)
' Determine table icon
@@ -4296,6 +4296,9 @@ Private Sub MapControlsToOptions(eAction As eMapAction)
If eAction = emaClassToForm Then
ctl = CallByName(Options, strKey, VbGet)
ElseIf eAction = emaFormToClass Then
+ ' Check for any hooks on option change
+ OnOptionChange strKey, Nz(ctl.Value)
+ ' Set the option value
CallByName Options, strKey, VbLet, Nz(ctl.Value)
End If
End Select
@@ -4328,6 +4331,46 @@ Private Sub MapControlsToOptions(eAction As eMapAction)
End Sub
+'---------------------------------------------------------------------------------------
+' Procedure : OnOptionChange
+' Author : Adam Waller
+' Date : 11/9/2023
+' Purpose : A hook to run special code or processing when specific options are changed
+' : from their existing values. Add any specific rules here.
+'---------------------------------------------------------------------------------------
+'
+Private Sub OnOptionChange(strName As String, varNewValue As Variant)
+
+ Dim blnChanged As Boolean
+
+ ' Determine if the option was changed
+ blnChanged = Not (CVar(CallByName(Options, strName, VbGet)) = varNewValue)
+ If Not blnChanged Then Exit Sub
+
+ ' Define actual rules here
+ Select Case strName
+
+ ' If a user turns on the option to split files
+ Case "SplitLayoutFromVBA"
+ If varNewValue = True Then
+ If Git.Installed Then
+ If Git.IsInsideRepository Then
+ ' Prompt user with suggestion
+ If MsgBox2("May I make a Suggestion?", _
+ "This project appears to be within a Git repository. This add-in includes a special utility " & _
+ "that can split the files (layout and VBA) while preserving this history of previous changes in BOTH files.", _
+ "Would you like to see additional information on this from the wiki?", vbQuestion + vbYesNo) = vbYes Then
+ FollowHyperlink "https://github.com/joyfullservice/msaccess-vcs-addin/wiki/Split-Files"
+ End If
+ End If
+ End If
+ End If
+
+ End Select
+
+End Sub
+
+
'---------------------------------------------------------------------------------------
' Procedure : cmdAddOtherTableData_Click
' Author : Adam Waller
diff --git a/Version Control.accda.src/forms/frmVCSSplitFiles.bas b/Version Control.accda.src/forms/frmVCSSplitFiles.bas
index d26fe877..892aab52 100644
--- a/Version Control.accda.src/forms/frmVCSSplitFiles.bas
+++ b/Version Control.accda.src/forms/frmVCSSplitFiles.bas
@@ -18,7 +18,7 @@ Begin Form
ItemSuffix =245
Left =-25575
Top =1500
- Right =-5310
+ Right =-255
Bottom =14085
RecSrcDt = Begin
0x79e78b777268e540
@@ -276,13 +276,13 @@ Begin Form
OverlapFlags =85
Left =720
Top =1440
- Width =4020
+ Width =2280
Height =315
Name ="Label241"
Caption ="List of files to split:"
LayoutCachedLeft =720
LayoutCachedTop =1440
- LayoutCachedWidth =4740
+ LayoutCachedWidth =3000
LayoutCachedHeight =1755
End
End
@@ -866,6 +866,43 @@ Begin Form
End
End
End
+ Begin CommandButton
+ FontUnderline = NotDefault
+ OverlapFlags =85
+ Left =4020
+ Top =1440
+ Width =2820
+ TabIndex =3
+ Name ="cmdAddFormsAndReports"
+ Caption ="Add Forms and Reports..."
+ OnClick ="[Event Procedure]"
+ HorizontalAnchor =1
+ BackStyle =0
+
+ CursorOnHover =1
+ LayoutCachedLeft =4020
+ LayoutCachedTop =1440
+ LayoutCachedWidth =6840
+ LayoutCachedHeight =1800
+ Alignment =3
+ ForeThemeColorIndex =10
+ ForeTint =100.0
+ Gradient =0
+ BackColor =14262935
+ BackThemeColorIndex =-1
+ BackTint =100.0
+ OldBorderStyle =0
+ BorderColor =15321539
+ BorderThemeColorIndex =-1
+ BorderTint =100.0
+ HoverColor =15321539
+ HoverThemeColorIndex =-1
+ HoverTint =100.0
+ PressedColor =13072231
+ PressedThemeColorIndex =-1
+ PressedShade =100.0
+ Overlaps =1
+ End
End
End
End
@@ -879,6 +916,69 @@ Option Compare Database
Option Explicit
+'---------------------------------------------------------------------------------------
+' Procedure : cmdAddFormsAndReports_Click
+' Author : Adam Waller
+' Date : 11/9/2023
+' Purpose : Add the forms and reports source files for the project. Doing this
+' : intelligently by only adding items that have a VBA code module.
+'---------------------------------------------------------------------------------------
+'
+Private Sub cmdAddFormsAndReports_Click()
+
+ Dim intType As AcObjectType
+ Dim cComponent As IDbComponent
+ Dim varKey As Variant
+ Dim strFile As String
+ Dim strPrefix As String
+ Dim cList As clsConcat
+
+ ' Prepare class for new list
+ Set cList = New clsConcat
+ cList.AppendOnAdd = vbCrLf
+
+ ' Process for forms and reports (2 to 3)
+ DoCmd.Hourglass True
+ For intType = acForm To acReport
+
+ ' Get component type
+ If intType = acForm Then
+ Set cComponent = New clsDbForm
+ strPrefix = "Form_"
+ ElseIf intType = acReport Then
+ Set cComponent = New clsDbReport
+ strPrefix = "Report_"
+ End If
+
+ ' Loop through files
+ For Each varKey In cComponent.GetFileList.Keys
+ strFile = SwapExtension(CStr(varKey), "cls")
+ ' Skip files that already exist
+ If Not FSO.FileExists(strFile) Then
+ ' Check for code module marker in source file
+ If InStr(1, ReadFile(CStr(varKey)), "CodeBehindForm") > 0 Then
+ ' Add to list of files to split
+ cList.Add CStr(varKey), "|", strFile
+ End If
+ End If
+ Next varKey
+ Next intType
+ DoCmd.Hourglass False
+ cmdSplitFiles.SetFocus
+
+ ' See if we found any files to split.
+ If cList.Length > 0 Then
+ ' Replace existing content.
+ txtFileList = cList.GetStr
+ Else
+ MsgBox2 "No Relevant Files Found", _
+ "Could not find any combined form or report source files that contained VBA modules", _
+ , vbInformation
+ End If
+
+End Sub
+
+
'---------------------------------------------------------------------------------------
' Procedure : cmdSplitFiles_Click
' Author : Adam Waller
@@ -912,7 +1012,7 @@ Private Sub cmdSplitFiles_Click()
AddToArray strPaths, varPaths(0)
AddToArray strNew, varPaths(1)
Else
- If UBound(varPaths) = 0 And Trim(varPaths(0)) = vbNullString Then
+ If Len(Trim(varEntries(lngLine))) = 0 Then
' Ignore blank lines
Else
strError = "Expecting two file paths, separated by | character. See line: '" & varPaths(0) & "'"
@@ -933,14 +1033,23 @@ Private Sub cmdSplitFiles_Click()
' Require clean branch with git installation
If Not Git.IsCleanBranch Then strError = "Cannot split files in Git when changes are present in the branch"
- If Not Git.GitInstalled Then strError = "Git must be installed to use this tool."
+ If Not Git.Installed Then strError = "Git must be installed to use this tool."
' Make sure we don't have any errors with the Git commands
If Len(strError) Then
MsgBox2 "Validation Failed", strError, "Please correct the problem to continue.", vbExclamation
Else
' Split the files using git commands
+ DoCmd.Hourglass True
Git.SplitFilesWithHistory strPaths, strNew, txtCommitMessage
+ DoCmd.Hourglass False
+
+ ' Show success message
+ MsgBox2 "Finished", "The operation is complete.", _
+ "For additional details, please see `git.log` in the source folder.", vbInformation
+
+ ' Clear existing list
+ txtFileList = vbNullString
End If
' Restore original working folder
diff --git a/Version Control.accda.src/modules/clsDbForm.cls b/Version Control.accda.src/modules/clsDbForm.cls
index b8a27c77..f3ca77c8 100644
--- a/Version Control.accda.src/modules/clsDbForm.cls
+++ b/Version Control.accda.src/modules/clsDbForm.cls
@@ -70,7 +70,7 @@ Private Sub IDbComponent_Import(strFile As String)
End If
' Load the form from the source file
- LoadComponentFromText acForm, strName, strFile, Me
+ LoadComponentFromText acForm, strName, strFile
Set m_Form = CurrentProject.AllForms(strName)
VCSIndex.Update Me, eatImport, GetCodeModuleHash(IDbComponent_ComponentType, strName)
@@ -124,6 +124,7 @@ End Sub
Private Sub IDbComponent_MoveSource(strFromFolder As String, strToFolder As String)
MoveFileIfExists strFromFolder & FSO.GetFileName(IDbComponent_SourceFile), strToFolder
MoveFileIfExists strFromFolder & FSO.GetBaseName(IDbComponent_SourceFile) & ".json", strToFolder
+ MoveFileIfExists strFromFolder & FSO.GetBaseName(IDbComponent_SourceFile) & ".cls", strToFolder
End Sub
@@ -180,7 +181,7 @@ End Function
'
Private Sub IDbComponent_ClearOrphanedSourceFiles()
If Not Options.SavePrintVars Then ClearFilesByExtension IDbComponent_BaseFolder, "json"
- ClearOrphanedSourceFiles Me, "bas", "json"
+ ClearOrphanedSourceFiles Me, "bas", "json", "cls"
End Sub
diff --git a/Version Control.accda.src/modules/clsDbModule.cls b/Version Control.accda.src/modules/clsDbModule.cls
index 147db934..d1b98c36 100644
--- a/Version Control.accda.src/modules/clsDbModule.cls
+++ b/Version Control.accda.src/modules/clsDbModule.cls
@@ -42,17 +42,11 @@ Implements IDbComponent
'
Private Sub IDbComponent_Export(Optional strAlternatePath As String)
- Dim strTempFile As String
- Dim strContent As String
Dim strExt As String
Dim strAlternateFile As String
- ' Export to temp file and convert to UTF-8 encoding
- strTempFile = GetTempFile
- ExportVbComponent strTempFile
- strContent = SanitizeVBA(ReadFile(strTempFile, GetSystemEncoding))
- WriteFile strContent, Nz2(strAlternatePath, IDbComponent_SourceFile)
- DeleteFile strTempFile
+ ' Export as sanitized UTF-8 file
+ ExportCodeModule m_Module.Name, Nz2(strAlternatePath, IDbComponent_SourceFile)
' Remove any file with the same name but alternate extension
strExt = IIf(GetExtension = ".bas", ".cls", ".bas")
@@ -101,7 +95,8 @@ Private Sub IDbComponent_Import(strFile As String)
DoCmd.Save acModule, strName
' Set reference to object
- If DebugMode(True) Then On Error Resume Next Else On Error Resume Next
+ LogUnhandledErrors
+ On Error Resume Next
Set m_Module = CurrentProject.AllModules(strName)
If Catch(2467) Then Log.Error eelCritical, _
"Imported module not found after import: " & strName, ModuleName(Me) & ".Import"
@@ -151,7 +146,7 @@ Private Function ParseSourceFile(strFile As String, strName As String) As udtVba
blnIsClass = True
Exit For
End If
- ' Exit after 10 lines
+ ' Exit after 9 lines
If lngLine > 8 Then Exit For
Next lngLine
@@ -211,7 +206,8 @@ Private Sub LoadVbeModuleFromFile(strFile As String, strName As String)
With proj.VBComponents
' Remove any existing component (In most cases the module will exist)
- If DebugMode(True) Then On Error Resume Next Else On Error Resume Next
+ LogUnhandledErrors
+ On Error Resume Next
.Remove .Item(strName)
If DebugMode(False) Then On Error GoTo 0 Else On Error Resume Next
@@ -243,20 +239,6 @@ Private Sub IDbComponent_Merge(strFile As String)
End Sub
-'---------------------------------------------------------------------------------------
-' Procedure : ExportVbComponent
-' Author : Adam Waller
-' Date : 5/26/2021
-' Purpose : Export the code module VB component
-'---------------------------------------------------------------------------------------
-'
-Private Sub ExportVbComponent(strFile As String)
- Perf.OperationStart "Export VBE Module"
- CurrentVBProject.VBComponents(m_Module.Name).Export strFile
- Perf.OperationEnd
-End Sub
-
-
'---------------------------------------------------------------------------------------
' Procedure : IDbComponent_MoveSource
' Author : Adam Waller
diff --git a/Version Control.accda.src/modules/clsDbProperty.cls b/Version Control.accda.src/modules/clsDbProperty.cls
index 0288a0cb..645f79c3 100644
--- a/Version Control.accda.src/modules/clsDbProperty.cls
+++ b/Version Control.accda.src/modules/clsDbProperty.cls
@@ -96,6 +96,14 @@ Private Sub IDbComponent_Import(strFile As String)
varValue = dItems(varKey)("Value")
' Check for relative path
If IsRelativePath(CStr(varValue)) Then varValue = GetPathFromRelative(CStr(varValue))
+ ' Check for UTC date that might need to be converted back to local
+ If dItems(varKey)("Type") = dbDate Then
+ If (Not IsDate(varValue)) And (Right(varValue, 1) = "Z") Then
+ ' Convert UTC date to local date
+ dItems(varKey)("Value") = modUtcConverter.ParseIso(CStr(varValue))
+ varValue = CDate(dItems(varKey)("Value"))
+ End If
+ End If
Else
ReDim bArray(0 To dItems(varKey)("Value").Count - 1)
For Each varItem In dItems(varKey)("Value")
@@ -144,7 +152,7 @@ Private Sub IDbComponent_Import(strFile As String)
End If
' Can't add a text property with a null value. See issue #126
- If dItems(varKey)("Type") = 10 Then
+ If dItems(varKey)("Type") = dbText Then
If varValue = vbNullChar Then blnAdd = False
End If
' Add the property if the flag has been set.
@@ -252,6 +260,13 @@ Private Function GetDictionary(Optional blnUseCache As Boolean) As Dictionary
varValue = GetRelativePath(CStr(varValue))
End If
End If
+ ' Convert dates to UTC
+ If prp.Type = dbDate Then
+ If IsDate(varValue) Then
+ ' Store dates in JSON as UTC dates.
+ varValue = modUtcConverter.ConvertToIsoTime(CDate(varValue))
+ End If
+ End If
Set dItem = New Dictionary
dItem.Add "Value", varValue
dItem.Add "Type", prp.Type
diff --git a/Version Control.accda.src/modules/clsDbQuery.cls b/Version Control.accda.src/modules/clsDbQuery.cls
index c09e1aa4..728716cf 100644
--- a/Version Control.accda.src/modules/clsDbQuery.cls
+++ b/Version Control.accda.src/modules/clsDbQuery.cls
@@ -62,12 +62,17 @@ Private Sub IDbComponent_Export(Optional strAlternatePath As String)
On Error GoTo 0
If strSql <> vbNullString Then
' Pass-through queries should not be formatted, since they support formatting and comments.
- If Options.SaveQuerySQL And dbs.QueryDefs(m_Query.Name).Type <> dbQSQLPassThrough Then
- With New clsSqlFormatter
- Perf.OperationStart "Format SQL"
- WriteFile .FormatSQL(strSql), strFile
- Perf.OperationEnd
- End With
+ If Options.SaveQuerySQL Then
+ Select Case dbs.QueryDefs(m_Query.Name).Type
+ Case dbQSQLPassThrough, dbQSPTBulk, dbQSetOperation
+ 'Do not format
+ Case Else
+ With New clsSqlFormatter
+ Perf.OperationStart "Format SQL"
+ WriteFile .FormatSQL(strSql, esdAccess), strFile
+ Perf.OperationEnd
+ End With
+ End Select
Else
WriteFile strSql, strFile
End If
diff --git a/Version Control.accda.src/modules/clsDbRelation.cls b/Version Control.accda.src/modules/clsDbRelation.cls
index 4d8cd14e..1ecbf3d6 100644
--- a/Version Control.accda.src/modules/clsDbRelation.cls
+++ b/Version Control.accda.src/modules/clsDbRelation.cls
@@ -95,7 +95,8 @@ Private Sub IDbComponent_Import(strFile As String)
' Relationships create indexes, so we need to make sure an index
' with this name doesn't already exist. (Also check to be sure that
' we don't already have a relationship with this name.)
- If DebugMode(True) Then On Error Resume Next Else On Error Resume Next
+ LogUnhandledErrors
+ On Error Resume Next
With m_Dbs
.TableDefs(rel.Table).Indexes.Delete rel.Name
.TableDefs(rel.ForeignTable).Indexes.Delete rel.Name
@@ -134,6 +135,7 @@ Private Sub IDbComponent_Merge(strFile As String)
On Error Resume Next
CurrentDb.Relations.Delete FSO.GetBaseName(strFile)
VCSIndex.Remove Me, strFile
+ If Err Then Err.Clear
End If
End Sub
diff --git a/Version Control.accda.src/modules/clsDbReport.cls b/Version Control.accda.src/modules/clsDbReport.cls
index 7ed0b967..755c5539 100644
--- a/Version Control.accda.src/modules/clsDbReport.cls
+++ b/Version Control.accda.src/modules/clsDbReport.cls
@@ -58,7 +58,7 @@ Private Sub IDbComponent_Import(strFile As String)
If Not strFile Like "*.bas" Then Exit Sub
strName = GetObjectNameFromFileName(strFile)
- LoadComponentFromText acReport, strName, strFile, Me
+ LoadComponentFromText acReport, strName, strFile
Set m_Report = CurrentProject.AllReports(strName)
VCSIndex.Update Me, eatImport, GetFileHash(strFile), GetCodeModuleHash(IDbComponent_ComponentType, strName)
@@ -93,6 +93,7 @@ End Sub
Private Sub IDbComponent_MoveSource(strFromFolder As String, strToFolder As String)
MoveFileIfExists strFromFolder & FSO.GetFileName(IDbComponent_SourceFile), strToFolder
MoveFileIfExists strFromFolder & FSO.GetBaseName(IDbComponent_SourceFile) & ".json", strToFolder
+ MoveFileIfExists strFromFolder & FSO.GetBaseName(IDbComponent_SourceFile) & ".cls", strToFolder
End Sub
@@ -150,7 +151,7 @@ End Function
Private Sub IDbComponent_ClearOrphanedSourceFiles()
ClearFilesByExtension IDbComponent_BaseFolder, "pv" ' Remove legacy files
If Not Options.SavePrintVars Then ClearFilesByExtension IDbComponent_BaseFolder, "json"
- ClearOrphanedSourceFiles Me, "bas", "json"
+ ClearOrphanedSourceFiles Me, "bas", "json", "cls"
End Sub
diff --git a/Version Control.accda.src/modules/clsDbSavedSpec.cls b/Version Control.accda.src/modules/clsDbSavedSpec.cls
index 713deb2f..745ad4ae 100644
--- a/Version Control.accda.src/modules/clsDbSavedSpec.cls
+++ b/Version Control.accda.src/modules/clsDbSavedSpec.cls
@@ -179,7 +179,8 @@ Private Function GetDictionary() As Dictionary
Set dSpec = New Dictionary
- If DebugMode(True) Then On Error Resume Next Else On Error Resume Next
+ LogUnhandledErrors
+ On Error Resume Next
' For some reason it throws an error if there is no
' description in the specification.
With dSpec
diff --git a/Version Control.accda.src/modules/clsDbTableData.cls b/Version Control.accda.src/modules/clsDbTableData.cls
index c16c1f8f..ed00152b 100644
--- a/Version Control.accda.src/modules/clsDbTableData.cls
+++ b/Version Control.accda.src/modules/clsDbTableData.cls
@@ -70,7 +70,10 @@ Private Sub IDbComponent_Export(Optional strAlternatePath As String)
Application.ExportXML acExportTable, m_Table.Name, strFile
End If
Perf.OperationEnd
- SanitizeXML strFile, False
+ With New clsSourceParser
+ .LoadSourceFile strFile
+ WriteFile .Sanitize(ectXML), strFile
+ End With
End Select
End If
Next intFormat
diff --git a/Version Control.accda.src/modules/clsDbTableDef.cls b/Version Control.accda.src/modules/clsDbTableDef.cls
index cbb183a1..963558e6 100644
--- a/Version Control.accda.src/modules/clsDbTableDef.cls
+++ b/Version Control.accda.src/modules/clsDbTableDef.cls
@@ -59,7 +59,12 @@ Private Sub IDbComponent_Export(Optional strAlternatePath As String)
Perf.OperationEnd
' Rewrite sanitized XML as formatted UTF-8 content
- strHash = SanitizeXML(strFile, True)
+ With New clsSourceParser
+ .LoadSourceFile strFile
+ DeleteFile strFile
+ WriteFile .Sanitize(ectXML), strFile
+ strHash = .Hash
+ End With
Else
' Linked table - Save as JSON
@@ -513,7 +518,8 @@ Private Function IndexAvailable(tdf As TableDef) As Boolean
Dim lngTest As Long
- If DebugMode(True) Then On Error Resume Next Else On Error Resume Next
+ LogUnhandledErrors
+ On Error Resume Next
lngTest = tdf.Indexes.Count
If Err Then
Err.Clear
@@ -542,7 +548,8 @@ Private Function ImportLinkedTable(strFile As String) As Boolean
Dim strSql As String
Dim strConnect As String
- If DebugMode(True) Then On Error Resume Next Else On Error Resume Next
+ LogUnhandledErrors
+ On Error Resume Next
' Read json file
Set dTable = ReadJsonFile(strFile)
diff --git a/Version Control.accda.src/modules/clsDbVbeProject.cls b/Version Control.accda.src/modules/clsDbVbeProject.cls
index df196575..5c2730b4 100644
--- a/Version Control.accda.src/modules/clsDbVbeProject.cls
+++ b/Version Control.accda.src/modules/clsDbVbeProject.cls
@@ -108,7 +108,8 @@ Private Sub SafeSetProperty(cProj As VBProject, strProperty As String, varValue
If varValue = varCurrent Then Exit Sub
' Switch to on error resume next after checking for current errors
- If DebugMode(True) Then On Error Resume Next Else On Error Resume Next
+ LogUnhandledErrors
+ On Error Resume Next
' Attempt to set the property
CallByName cProj, strProperty, VbLet, varValue
diff --git a/Version Control.accda.src/modules/clsDevMode.cls b/Version Control.accda.src/modules/clsDevMode.cls
index 7482fbdb..d1438712 100644
--- a/Version Control.accda.src/modules/clsDevMode.cls
+++ b/Version Control.accda.src/modules/clsDevMode.cls
@@ -216,7 +216,7 @@ End Function
' Purpose : Load sections from export file
'---------------------------------------------------------------------------------------
'
-Public Sub LoadFromExportFile(strFile As String)
+Public Sub LoadFromExportFile(strFileContent As String)
Dim varLines As Variant
Dim lngLine As Long
@@ -240,17 +240,11 @@ Public Sub LoadFromExportFile(strFile As String)
' Clear existing structures and create block classes.
ClearStructures
- If Not FSO.FileExists(strFile) Then Exit Sub
-
- ' Open the export file, checking to see if it is in UCS format
- If HasUcs2Bom(strFile) Then
- varLines = Split(ReadFile(strFile, "Unicode"), vbCrLf)
- Else
- varLines = Split(ReadFile(strFile), vbCrLf)
- End If
+ If Len(strFileContent) = 0 Then Exit Sub
' Read the text file line by line, loading the block data
Perf.OperationStart "Read File DevMode"
+ varLines = Split(strFileContent, vbCrLf)
For lngLine = 0 To UBound(varLines)
strLine = Trim$(varLines(lngLine))
' Look for header if not inside block
@@ -315,7 +309,7 @@ Public Sub LoadFromExportFile(strFile As String)
Next intBlock
Perf.OperationEnd
- CatchAny eelError, "Error loading printer settings from file: " & strFile, _
+ CatchAny eelError, "Error loading printer settings from file content.", _
ModuleName(Me) & ".LoadFromExportFile", True, True
End Sub
@@ -1007,18 +1001,6 @@ Public Sub ApplySettings(dSettings As Dictionary)
End Sub
-'---------------------------------------------------------------------------------------
-' Procedure : GetPrintSettingsFileName
-' Author : Adam Waller
-' Date : 1/14/2021
-' Purpose : Return the file name for the print vars json file.
-'---------------------------------------------------------------------------------------
-'
-Public Function GetPrintSettingsFileName(cDbObject As IDbComponent) As String
- GetPrintSettingsFileName = cDbObject.BaseFolder & GetSafeFileName(cDbObject.Name) & ".json"
-End Function
-
-
'---------------------------------------------------------------------------------------
' Procedure : AddToExportFile
' Author : Adam Waller
@@ -1028,27 +1010,22 @@ End Function
' : file for import into the database using the loaded print settings.
'---------------------------------------------------------------------------------------
'
-Public Function AddToExportFile(strFile As String) As String
+Public Function AddToExportFile(strFileContent As String) As String
- Dim strTempFile As String
Dim strLine As String
Dim varLines As Variant
- Dim strData As String
Dim lngLine As Long
Dim blnFound As Boolean
Dim blnInBlock As Boolean
If DebugMode(True) Then On Error GoTo 0 Else On Error Resume Next
- ' Load data from export file
- strData = ReadFile(strFile)
- varLines = Split(strData, vbCrLf)
-
' Use concatenation class for performance reasons.
With New clsConcat
.AppendOnAdd = vbCrLf
' Loop through lines in file, searching for location to insert blocks.
+ varLines = Split(strFileContent, vbCrLf)
For lngLine = LBound(varLines) To UBound(varLines)
' Get single line
@@ -1088,16 +1065,13 @@ Public Function AddToExportFile(strFile As String) As String
End If
Next lngLine
- ' Write to new file
- strTempFile = GetTempFile
- WriteFile .GetStr, strTempFile
-
+ ' Return content
+ AddToExportFile = .GetStr
End With
- ' Return path to temp file
- AddToExportFile = strTempFile
- CatchAny eelError, "Error adding to export file: " & strFile, _
+ CatchAny eelError, "Error adding print settings to export file.", _
ModuleName(Me) & ".AddToExportFile", True, True
+
End Function
diff --git a/Version Control.accda.src/modules/clsGitIntegration.cls b/Version Control.accda.src/modules/clsGitIntegration.cls
index 5d59acd3..e30e355b 100644
--- a/Version Control.accda.src/modules/clsGitIntegration.cls
+++ b/Version Control.accda.src/modules/clsGitIntegration.cls
@@ -35,11 +35,12 @@ Private Enum eGitCommand
egcGetUntrackedFiles
egcGetHeadCommit
egcGetBranchName
- egcSetTaggedCommit
egcGetReproPath
egcGetRevision
egcGetStatusPorcelain
+ egcIsInsideTree
' Action commands
+ egcSetTaggedCommit
egcInitialize
egcAddAll
egcCommit
@@ -101,6 +102,7 @@ Private Function RunGitCommand(intCmd As eGitCommand, Optional strArgument As St
Case egcCheckoutNewBranch: strCmd = "git checkout -b {MyArg}"
Case egcCheckoutHeadToCurrent: strCmd = "git checkout HEAD~ ."
Case egcDeleteBranch: strCmd = "git branch --delete {MyArg}"
+ Case egcIsInsideTree: strCmd = "git rev-parse --is-inside-work-tree"
Case Else
Log.Error eelError, "Unrecognized Git Command Enum: " & intCmd
Stop
@@ -111,7 +113,7 @@ Private Function RunGitCommand(intCmd As eGitCommand, Optional strArgument As St
' Run command, and get result
Perf.OperationStart "Git Command (id:" & intCmd & ")"
- strResult = ShellRun(strCmd)
+ strResult = ShellRun(strCmd, intCmd)
Perf.OperationEnd
' Trim any trailing vbLf
@@ -170,7 +172,7 @@ End Function
' Purpose : Returns the path to the root of the repository.
'---------------------------------------------------------------------------------------
'
-Public Function GetRepositoryRoot() As String
+Public Function GetRepositoryRoot(Optional blnFallBackToWorking As Boolean = True) As String
Static strLastFolder As String ' Working folder
Static strLastRoot As String ' Repository Root
@@ -180,6 +182,12 @@ Public Function GetRepositoryRoot() As String
' Determine the current working folder
strWorking = GetWorkingFolder
+ ' Make sure git is actually installed
+ If Not Me.Installed Then
+ If blnFallBackToWorking Then GetRepositoryRoot = strWorking
+ Exit Function
+ End If
+
' On first call, we will attempt to get the repository root from the working
' folder, or the export folder if a working folder is not specified.
If strLastRoot = vbNullString Or (strLastFolder <> strWorking) Then
@@ -189,16 +197,20 @@ Public Function GetRepositoryRoot() As String
strLastFolder = strWorking
strLastRoot = vbNullString
' Recursively call this function to verify the path with git
- GetRepositoryRoot = GetRepositoryRoot()
+ GetRepositoryRoot = GetRepositoryRoot(blnFallBackToWorking)
Else
' Run git command from last folder
strLastRoot = strLastFolder
' Use Git to look up root folder in repository.
strLastRoot = Replace(RunGitCommand(egcGetReproPath), "/", PathSep) & PathSep
If strLastRoot = PathSep Then
- ' Might not be in a git repository. Fall back to working folder.
- GetRepositoryRoot = strWorking
- strLastRoot = strWorking
+ If blnFallBackToWorking Then
+ ' Might not be in a git repository. Fall back to working folder.
+ GetRepositoryRoot = strWorking
+ strLastRoot = strWorking
+ Else
+ GetRepositoryRoot = vbNullString
+ End If
Else
' Found the root folder. Return to caller.
GetRepositoryRoot = strLastRoot
@@ -221,7 +233,20 @@ End Function
'---------------------------------------------------------------------------------------
'
Private Function GetWorkingFolder() As String
- GetWorkingFolder = StripSlash(Nz2(Me.WorkingFolder, Options.GetExportFolder)) & PathSep
+
+ Dim strWorking As String
+
+ ' Avoid calling Options if the working folder is already defined to prevent
+ ' a possible stack overflow. (That's why we don't use Nz2() here)
+ If Len(Me.WorkingFolder) Then
+ strWorking = Me.WorkingFolder
+ Else
+ strWorking = Options.GetExportFolder
+ End If
+
+ ' Return path in consistent format
+ GetWorkingFolder = StripSlash(strWorking) & PathSep
+
End Function
@@ -229,11 +254,27 @@ End Function
' Procedure : Version
' Author : Adam Waller
' Date : 3/10/2023
-' Purpose : Return git version
+' Purpose : Return git version (Cached between calls)
'---------------------------------------------------------------------------------------
'
Public Function Version() As String
- Version = Replace(RunGitCommand(egcGetVersion), "git version ", vbNullString)
+ Static strVersion As String
+ If strVersion = vbNullString Then strVersion = Replace(RunGitCommand(egcGetVersion), "git version ", vbNullString)
+ Version = strVersion
+End Function
+
+
+'---------------------------------------------------------------------------------------
+' Procedure : IsInsideRepository
+' Author : Adam Waller
+' Date : 11/6/2023
+' Purpose : Returns true if the current working folder is inside a git repository.
+'---------------------------------------------------------------------------------------
+'
+Public Function IsInsideRepository() As Boolean
+ If Me.Installed Then
+ IsInsideRepository = (RunGitCommand(egcIsInsideTree) = "true")
+ End If
End Function
@@ -356,7 +397,7 @@ End Sub
' Purpose : Pass a git command to this function to return the result as a string.
'---------------------------------------------------------------------------------------
'
-Private Function ShellRun(strCmd As String) As String
+Private Function ShellRun(strCmd As String, intCmd As eGitCommand) As String
Dim oShell As WshShell
Dim strFile As String
@@ -366,10 +407,16 @@ Private Function ShellRun(strCmd As String) As String
' Build command line string
With New clsConcat
- ' Open command prompt in repository folder
- .Add "cmd.exe /c cd ", GetRepositoryRoot
- ' Run git command
- .Add " & ", strCmd
+ Select Case intCmd
+ Case egcGetVersion
+ ' Run independent of repository
+ .Add "cmd.exe /c ", strCmd
+ Case Else
+ ' Open command prompt in repository folder
+ .Add "cmd.exe /c cd ", GetRepositoryRoot
+ ' Run git command
+ .Add " & ", strCmd
+ End Select
' Output to temp file
.Add " > """, strFile, """"
' Execute command
@@ -477,9 +524,8 @@ End Function
' Purpose : Returns true if git is installed.
'---------------------------------------------------------------------------------------
'
-Public Function GitInstalled() As Boolean
- ' Expecting something like "git version 2.29.2.windows.2"
- GitInstalled = InStr(1, RunGitCommand(egcGetVersion), "git version ") = 1
+Public Function Installed() As Boolean
+ Installed = (Len(Me.Version))
End Function
diff --git a/Version Control.accda.src/modules/clsOptions.cls b/Version Control.accda.src/modules/clsOptions.cls
index adb97d98..9769b4f8 100644
--- a/Version Control.accda.src/modules/clsOptions.cls
+++ b/Version Control.accda.src/modules/clsOptions.cls
@@ -32,6 +32,7 @@ Public SaveQuerySQL As Boolean
Public FormatSQL As Boolean
Public ForceImportOriginalQuerySQL As Boolean
Public SaveTableSQL As Boolean
+Public SplitLayoutFromVBA As Boolean
Public StripPublishOption As Boolean
Public SanitizeColors As eSanitizeLevel
Public SanitizeLevel As eSanitizeLevel
@@ -78,6 +79,7 @@ Public Sub LoadDefaults()
.FormatSQL = True
.ForceImportOriginalQuerySQL = False
.SaveTableSQL = True
+ .SplitLayoutFromVBA = True
.StripPublishOption = True
.SanitizeLevel = eslStandard
.SanitizeColors = eslMinimal
@@ -285,9 +287,65 @@ Private Sub Upgrade(ByRef dOptions As Dictionary)
End If
End If
+ ' 11/3/2023
+ ' Check option to split VBA from object layout
+ If Not dOptions.Exists("SplitLayoutFromVBA") Then
+ ' The existing options file does not have this option defined.
+ ' See if we have any source files from previous exports.
+ If HasUnifiedLayoutFilesInGit(Me.GetExportFolder) Then
+ ' Set the option as false by default, and let the user
+ ' turn it on explicitly for this project.
+ ' (That way they are not forced to make a decision immediately)
+ Me.SplitLayoutFromVBA = False
+ Else
+ ' If we already have split files, or if this project is
+ ' being exported for the first time, leave the option at
+ ' the default setting.
+ End If
+ End If
+
End Sub
+'---------------------------------------------------------------------------------------
+' Procedure : HasUnifiedLayoutFilesInGit
+' Author : Adam Waller
+' Date : 11/3/2023
+' Purpose : Returns true if the current project seems to have existing form or report
+' : source files AND appears to be in a .git repository.
+' : (This function is used when determining the default for splitting VBA
+' : from layout files in new projects.)
+' : For performance reasons this is not a fully comprehensive check of every
+' : possible source file, but should be a pretty good indication of whether
+' : existing source files need to be split in git to preserve the history in
+' : both source files.
+'---------------------------------------------------------------------------------------
+'
+Private Function HasUnifiedLayoutFilesInGit(strExportPath As String) As Boolean
+
+ Dim blnHasFiles As Boolean
+
+ ' See if we have any ".bas" files, but no corresponding ".cls" files in the
+ ' forms and reports export folders.
+ ' Hard-coding the folder names to avoid calling options.
+ If GetFileList(BuildPath2(strExportPath, "forms"), "*.bas").Count > 0 Then
+ blnHasFiles = (GetFileList(BuildPath2(strExportPath, "forms"), "*.cls").Count = 0)
+ ElseIf GetFileList(BuildPath2(strExportPath, "reports"), "*.bas").Count > 0 Then
+ blnHasFiles = (GetFileList(BuildPath2(strExportPath, "reports"), "*.cls").Count = 0)
+ End If
+
+ If blnHasFiles Then
+ ' Check to see if this folder is in a git repository
+ If Git.Installed Then
+ ' Check export path
+ Git.WorkingFolder = strExportPath
+ HasUnifiedLayoutFilesInGit = Git.IsInsideRepository
+ End If
+ End If
+
+End Function
+
+
'---------------------------------------------------------------------------------------
' Procedure : LoadProjectOptions
' Author : Adam Waller
@@ -568,6 +626,7 @@ Private Sub Class_Initialize()
.Add "FormatSQL"
.Add "ForceImportOriginalQuerySQL"
.Add "SaveTableSQL"
+ .Add "SplitLayoutFromVBA"
.Add "StripPublishOption"
.Add "SanitizeColors"
.Add "SanitizeLevel"
diff --git a/Version Control.accda.src/modules/clsPerformance.cls b/Version Control.accda.src/modules/clsPerformance.cls
index 1621c427..41dec7a0 100644
--- a/Version Control.accda.src/modules/clsPerformance.cls
+++ b/Version Control.accda.src/modules/clsPerformance.cls
@@ -20,6 +20,7 @@ Attribute VB_Exposed = False
' : microsecond level. For additional details, see the following link:
' : http://www.mendipdatasystems.co.uk/timer-comparison-tests/4594552971
'---------------------------------------------------------------------------------------
+
Option Compare Database
Option Explicit
@@ -96,6 +97,18 @@ Public Property Get CallStack() As String
End Property
+'---------------------------------------------------------------------------------------
+' Procedure : CurrentCategoryName
+' Author : hecon5
+' Date : 10/3/2023
+' Purpose : Return the current category name.
+'---------------------------------------------------------------------------------------
+'
+Public Property Get CurrentCategoryName() As String
+ CurrentCategoryName = this.CategoryName
+End Property
+
+
'---------------------------------------------------------------------------------------
' Procedure : CategoryStart
' Author : Adam Waller
@@ -105,15 +118,15 @@ End Property
'
Public Sub CategoryStart(strName As String)
If Not Me.Enabled Then Exit Sub
- If this.CategoryName <> vbNullString Then CategoryEnd
If this.Categories Is Nothing Then Set this.Categories = New Dictionary
+ If this.CategoryName <> vbNullString Then CategoryEnd
StartTimer this.Categories, strName
this.CategoryName = strName
End Sub
'---------------------------------------------------------------------------------------
-' Procedure : ComponentEnd
+' Procedure : CategoryEnd
' Author : Adam Waller
' Date : 11/3/2020
' Purpose : End the timing of the active component
@@ -199,12 +212,26 @@ Public Sub OperationEnd(Optional lngCount As Long = 1)
this.OperationName = vbNullString
End If
End With
+ Else
+ this.OperationName = vbNullString
End If
End If
End Sub
+'---------------------------------------------------------------------------------------
+' Procedure : CurrentOperationName
+' Author : hecon5
+' Date : 10/3/2023
+' Purpose : Return the current operation's name.
+'---------------------------------------------------------------------------------------
+'
+Public Property Get CurrentOperationName() As String
+ CurrentOperationName = this.OperationName
+End Property
+
+
'---------------------------------------------------------------------------------------
' Procedure : DigitsAfterDecimal
' Author : Eugen Albiker
@@ -260,7 +287,9 @@ End Function
'---------------------------------------------------------------------------------------
'
Private Sub StartTimer(dItems As Dictionary, strName As String)
+
Dim cItem As clsPerformanceItem
+
If Not dItems.Exists(strName) Then
Set cItem = New clsPerformanceItem
dItems.Add strName, cItem
@@ -331,6 +360,9 @@ Public Sub ResumeTiming()
' Resume current operation
If this.OperationName <> vbNullString Then StartTimer this.Operations, this.OperationName
+ ' Resume current Category
+ If this.CategoryName <> vbNullString Then StartTimer this.Categories, this.CategoryName
+
End Sub
@@ -415,14 +447,14 @@ Public Function GetReports() As String
.Add ListResult("Category", "Count", "Seconds", lngCol), vbCrLf, strSpacer
For Each varKey In this.Categories.Keys
.Add ListResult(CStr(varKey), CStr(this.Categories(varKey).Count), _
- Format(this.Categories(varKey).Total, "0." & String$(this.intDigitsAfterDecimal, "0")), lngCol)
+ Format$(this.Categories(varKey).Total, "0." & String$(this.intDigitsAfterDecimal, "0")), lngCol)
' Add to totals
dblCount = dblCount + this.Categories(varKey).Count
curTotal = curTotal + this.Categories(varKey).Total
Next varKey
.Add strSpacer
.Add ListResult("TOTALS:", CStr(dblCount), _
- Format(curTotal, "0." & String$(this.intDigitsAfterDecimal, "0")), lngCol)
+ Format$(curTotal, "0." & String$(this.intDigitsAfterDecimal, "0")), lngCol)
.Add strSpacer
.Add vbNullString
End If
@@ -435,13 +467,13 @@ Public Function GetReports() As String
.Add ListResult("Operations", "Count", "Seconds", lngCol), vbCrLf, strSpacer
For Each varKey In this.Operations.Keys
.Add ListResult(CStr(varKey), CStr(this.Operations(varKey).Count), _
- Format(this.Operations(varKey).Total, "0." & String$(this.intDigitsAfterDecimal, "0")), lngCol)
+ Format$(this.Operations(varKey).Total, "0." & String$(this.intDigitsAfterDecimal, "0")), lngCol)
curTotal = curTotal + this.Operations(varKey).Total
Next varKey
.Add strSpacer
If Not this.Overall Is Nothing Then
.Add ListResult("Other Operations", vbNullString, _
- Format(this.Overall.Total - curTotal, "0." & String$(this.intDigitsAfterDecimal, "0")), lngCol)
+ Format$(this.Overall.Total - curTotal, "0." & String$(this.intDigitsAfterDecimal, "0")), lngCol)
.Add strSpacer
End If
.Add vbNullString
@@ -474,15 +506,51 @@ End Function
' Author : Adam Waller
' Date : 11/3/2020
' Purpose : List the result of a test in a fixed width format. The result strings
-' : are positioned at the number of characters specified.
+' : are positioned at the number of characters specified. If the heading size
+' : exceeds the width of the column, the text will be wrapped.
' : I.e:
' : MyFancyTest 23 2.45
+' : My very long nam
+' : e that I probabl
+' : y should condens
+' : e 12 3.23
'---------------------------------------------------------------------------------------
'
-Private Function ListResult(strHeading As String, strResult1 As String, strResult2 As String, _
- lngCol() As Long) As String
- ListResult = PadRight(strHeading, lngCol(0)) & _
- PadRight(strResult1, lngCol(1)) & strResult2
+Private Function ListResult(strHeading As String, _
+ strResult1 As String, _
+ strResult2 As String, _
+ lngCol() As Long) As String
+
+ Dim strRowHeading As String
+ Dim lngPos As Long
+ Dim intMax As Integer
+
+ ' Wrap at one character less than the column width
+ intMax = lngCol(0) - 1
+
+ ' Use concatenation class in case we need to deal with line wrapping
+ With New clsConcat
+
+ ' Check for size overflow on heading. (Wrap on multiple lines)
+ strRowHeading = strHeading
+ If Len(strRowHeading) > intMax Then
+ lngPos = 1
+ Do While lngPos + intMax <= Len(strHeading)
+ ' Add segment and linebreak
+ .Add Mid$(strHeading, lngPos, intMax), " ", vbCrLf
+ lngPos = lngPos + intMax
+ Loop
+ ' Get last heading line to use with results
+ strRowHeading = Mid$(strHeading, lngPos)
+ End If
+
+ ' Display heading and amounts
+ .Add PadRight(strRowHeading, lngCol(0))
+ .Add PadRight(strResult1, lngCol(1))
+ .Add strResult2
+ ListResult = .GetStr
+ End With
+
End Function
@@ -493,7 +561,9 @@ End Function
' Purpose : Pads a string
'---------------------------------------------------------------------------------------
'
-Private Function PadRight(strText As String, lngLen As Long, Optional lngMinTrailingSpaces As Long = 1) As String
+Private Function PadRight(strText As String, _
+ lngLen As Long, _
+ Optional lngMinTrailingSpaces As Long = 1) As String
Dim strResult As String
Dim strTrimmed As String
@@ -537,8 +607,8 @@ Private Function SortItemsByTime(dItems As Dictionary) As Dictionary
' Build our list of records
For Each varKey In dItems.Keys
- ' Create a record like this: "00062840.170000|Export Form Objects ..."
- strRecord = Format(dItems(varKey).Total, "00000000.000000") & "|" & PadRight(CStr(varKey), 100)
+ ' Create a record like this: "00062840.170000|Export Form Objects"
+ strRecord = Format$(dItems(varKey).Total, "00000000.000000") & "|" & CStr(varKey)
' Add to array.
varItems(lngCnt) = strRecord
' Increment counter for array
@@ -552,8 +622,9 @@ Private Function SortItemsByTime(dItems As Dictionary) As Dictionary
' (We are walking backwards through the array to flip the sort to descending)
Set dSorted = New Dictionary
For lngCnt = dItems.Count - 1 To 0 Step -1
- ' Parse key from record
- varKey = Trim(Split(varItems(lngCnt), "|")(1))
+ ' Parse key from record (text after first pipe character)
+ strRecord = varItems(lngCnt)
+ varKey = Mid$(strRecord, InStr(1, strRecord, "|") + 1)
' Reference performance item class
Set cItem = dItems(varKey)
' Add to dictionary of resorted items
diff --git a/Version Control.accda.src/modules/modSanitize.bas b/Version Control.accda.src/modules/clsSourceParser.cls
similarity index 68%
rename from Version Control.accda.src/modules/modSanitize.bas
rename to Version Control.accda.src/modules/clsSourceParser.cls
index 2e284b39..1a1e3e26 100644
--- a/Version Control.accda.src/modules/modSanitize.bas
+++ b/Version Control.accda.src/modules/clsSourceParser.cls
@@ -1,20 +1,230 @@
-Attribute VB_Name = "modSanitize"
+VERSION 1.0 CLASS
+BEGIN
+ MultiUse = -1 'True
+END
+Attribute VB_Name = "clsSourceParser"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
'---------------------------------------------------------------------------------------
-' Module : modSanitize
+' Module : clsSourceParser
' Author : Adam Waller
' Date : 12/4/2020
' Purpose : Functions to sanitize files to remove non-essential metadata
'---------------------------------------------------------------------------------------
Option Compare Database
-Option Private Module
Option Explicit
-Private Const ModuleName = "modSanitize"
+Public ObjectName As String
-' Array of lines to skip
-Private m_SkipLines() As Long
-Private m_lngSkipIndex As Long
-Private m_colBlocks As Collection
+Public Enum eContentType
+ ectObjectDefinition
+ ectXML
+ ectVBA
+End Enum
+
+' Private type to handle internal variables
+Private Type udtThis
+ lngSkipLines() As Long ' Array of lines to skip
+ lngSkipIndex As Long
+ strFilePath As String ' Path to loaded file
+ blnOutputModified As Boolean
+ strInput As String
+ strOutput As String
+ strVBA As String
+ colBlocks As Collection
+End Type
+Private this As udtThis
+
+
+'---------------------------------------------------------------------------------------
+' Procedure : LoadFile
+' Author : Adam Waller
+' Date : 10/25/2023
+' Purpose : Load a source file to sanitize
+'---------------------------------------------------------------------------------------
+'
+Public Function LoadSourceFile(strPath As String)
+ ResetContent
+ this.strInput = ReadSourceFile(strPath)
+End Function
+
+
+'---------------------------------------------------------------------------------------
+' Procedure : LoadString
+' Author : Adam Waller
+' Date : 10/27/2023
+' Purpose : Load input from a string
+'---------------------------------------------------------------------------------------
+'
+Public Function LoadString(ByVal strContent As String)
+ ResetContent
+ this.strInput = strContent
+End Function
+
+
+'---------------------------------------------------------------------------------------
+' Procedure : GetOutput
+' Author : Adam Waller
+' Date : 11/8/2023
+' Purpose : Wrapper to return output string
+'---------------------------------------------------------------------------------------
+'
+Public Function GetOutput() As String
+ GetOutput = this.strOutput
+End Function
+
+
+'---------------------------------------------------------------------------------------
+' Procedure : OutputModified
+' Author : Adam Waller
+' Date : 11/8/2023
+' Purpose : Return true if the output has been modified
+'---------------------------------------------------------------------------------------
+'
+Public Property Get OutputModified() As Boolean
+ OutputModified = this.blnOutputModified
+End Property
+
+
+'---------------------------------------------------------------------------------------
+' Procedure : ResetContent
+' Author : Adam Waller
+' Date : 10/31/2023
+' Purpose : Resets the local variables when data is loaded from a new source.
+'---------------------------------------------------------------------------------------
+'
+Private Sub ResetContent()
+ With this
+ .strFilePath = vbNullString
+ .strInput = vbNullString
+ .strOutput = vbNullString
+ .strVBA = vbNullString
+ .blnOutputModified = False
+ End With
+ Me.ObjectName = vbNullString
+End Sub
+
+
+'---------------------------------------------------------------------------------------
+' Procedure : Sanitize
+' Author : Adam Waller
+' Date : 10/25/2023
+' Purpose : Public wrapper for sanitize functions
+'---------------------------------------------------------------------------------------
+'
+Public Function Sanitize(intContentType As eContentType) As String
+ Select Case intContentType
+ Case ectObjectDefinition: SanitizeObject
+ Case ectVBA: SanitizeVBA
+ Case ectXML: SanitizeXML
+ End Select
+ Sanitize = this.strOutput
+End Function
+
+
+'---------------------------------------------------------------------------------------
+' Procedure : MergeVBA
+' Author : Adam Waller
+' Date : 10/27/2023
+' Purpose : Merge VBA into the output content.
+'---------------------------------------------------------------------------------------
+'
+Public Sub MergeVBA(strVbaCode As String)
+
+ Dim varLines As Variant
+ Dim lngLine As Long
+
+ ' Make sure we have some output
+ If Len(this.strOutput) = 0 Then this.strOutput = this.strInput
+
+ ' Rebuild output using provided VBA code
+ With New clsConcat
+ .AppendOnAdd = vbCrLf
+
+ ' Load in existing sanitized content
+ varLines = Split(this.strOutput, vbCrLf)
+ For lngLine = 0 To UBound(varLines)
+ ' Note that the same heading name is used in both forms and reports
+ If varLines(lngLine) = "CodeBehindForm" Then
+ ' Allow merge of empty string to remove VBA code module
+ If Len(strVbaCode) Then .Add CStr(varLines(lngLine))
+ Exit For
+ Else
+ ' Add all other lines
+ .Add CStr(varLines(lngLine))
+ End If
+ Next lngLine
+
+ ' Add the VBA code here, and remove extra vbCrLf
+ .Add strVbaCode
+ .Remove 2
+
+ ' Update output with combined content
+ this.strOutput = .GetStr
+ this.strVBA = strVbaCode
+ this.blnOutputModified = True
+ End With
+
+End Sub
+
+
+'---------------------------------------------------------------------------------------
+' Procedure : MergePrintSettings
+' Author : Adam Waller
+' Date : 11/8/2023
+' Purpose : Merge print settings into the current source file.
+'---------------------------------------------------------------------------------------
+'
+Public Sub MergePrintSettings(strJson As String)
+
+ Dim dSettings As Dictionary
+
+ ' Make sure we have some output
+ If Len(this.strOutput) = 0 Then this.strOutput = this.strInput
+
+ ' Don't try to parse an empty string
+ If strJson = vbNullString Then Exit Sub
+
+ ' Read settings from JSON
+ Set dSettings = ParseJson(strJson)
+ If dSettings.Exists("Items") Then
+ With New clsDevMode
+ ' Load default printer settings, then overlay
+ ' settings saved with report.
+ .ApplySettings dSettings("Items")
+ ' Write the printer settings to the output content
+ this.strOutput = .AddToExportFile(this.strOutput)
+ this.blnOutputModified = True
+ End With
+ End If
+
+End Sub
+
+
+'---------------------------------------------------------------------------------------
+' Procedure : SaveObjectVBA
+' Author : Adam Waller
+' Date : 10/31/2023
+' Purpose : Return the extracted VBA code
+'---------------------------------------------------------------------------------------
+'
+Public Function GetObjectVBA() As String
+ GetObjectVBA = this.strVBA
+End Function
+
+
+'---------------------------------------------------------------------------------------
+' Procedure : Hash
+' Author : Adam Waller
+' Date : 10/25/2023
+' Purpose : Return a hash of the sanitized content
+'---------------------------------------------------------------------------------------
+'
+Public Function Hash(Optional blnWithBom As Boolean = True) As String
+ Hash = GetStringHash(this.strOutput, blnWithBom)
+End Function
'---------------------------------------------------------------------------------------
@@ -25,9 +235,8 @@ Private m_colBlocks As Collection
' : as saving to the specified path.
'---------------------------------------------------------------------------------------
'
-Public Function SanitizeFile(strPath As String, blnReturnHash As Boolean) As String
+Private Function SanitizeObject() As String 'strPath As String, blnReturnHash As Boolean, Optional strObjectName As String) As String
- Dim strFile As String
Dim varLines As Variant
Dim lngLine As Long
Dim strLine As String
@@ -37,42 +246,24 @@ Public Function SanitizeFile(strPath As String, blnReturnHash As Boolean) As Str
Dim blnIsReport As Boolean
Dim blnIsPassThroughQuery As Boolean
Dim curStart As Currency
- Dim strTempFile As String
- Dim strContent As String
+ Dim cVBA As clsConcat
If DebugMode(True) Then On Error GoTo 0 Else On Error Resume Next
- ' Read text from file, and split into lines
- If HasUcs2Bom(strPath) Then
- strFile = ReadFile(strPath, "Unicode")
- Else
- ' ADP projects may contain mixed Unicode content
- If CurrentProject.ProjectType = acADP Then
- strTempFile = GetTempFile
- ConvertUcs2Utf8 strPath, strTempFile, False
- strFile = ReadFile(strTempFile)
- DeleteFile strTempFile
- Else
- If DbVersion <= 4 Then
- ' Access 2000 format exports using system codepage
- ' See issue #217
- strFile = ReadFile(strPath, GetSystemEncoding)
- Else
- ' Newer versions export as UTF-8
- strFile = ReadFile(strPath)
- End If
- End If
+ ' If not sanitizing, then return output
+ If Options.SanitizeLevel = eslNone Then
+ this.strOutput = this.strInput
+ SanitizeObject = this.strOutput
+ Exit Function
End If
Perf.OperationStart "Sanitize File"
- varLines = Split(strFile, vbCrLf)
-
- If Options.SanitizeLevel = eslNone Then GoTo Build_Output
+ varLines = Split(this.strInput, vbCrLf)
' Set up index of lines to skip
- ReDim m_SkipLines(0 To UBound(varLines)) As Long
- m_lngSkipIndex = 0
- Set m_colBlocks = New Collection
+ ReDim this.lngSkipLines(0 To UBound(varLines)) As Long
+ this.lngSkipIndex = 0
+ Set this.colBlocks = New Collection
' Initialize concatenation class to include line breaks
' after each line that we add when building new file text.
@@ -164,10 +355,28 @@ Public Function SanitizeFile(strPath As String, blnReturnHash As Boolean) As Str
' Code section behind form or report object
Case "CodeBehindForm"
- ' Apply sanitize rules to VBA code
- SanitizeCodeLines lngLine, varLines
- ' Keep everything from this point on
- Exit Do
+ If Options.SplitLayoutFromVBA Then
+ ' Remove the VBA code from the layout file, but add a placeholder
+ ' comment just in case the user wonders what happened to the VBA
+ ' source code.
+ lngLine = lngLine + 1
+ Set cVBA = New clsConcat
+ cVBA.AppendOnAdd = vbCrLf
+ cVBA.Add CStr(varLines(lngLine))
+ varLines(lngLine) = "' See """ & Nz2(Me.ObjectName, "FileName") & ".cls"""
+ ' Skip remaining lines
+ Do While lngLine < UBound(varLines)
+ lngLine = lngLine + 1
+ cVBA.Add CStr(varLines(lngLine))
+ SkipLine lngLine, eslStandard
+ Loop
+ Exit Do
+ Else
+ ' Apply sanitize rules to VBA code
+ SanitizeCodeLines lngLine, varLines
+ ' Keep everything from this point on
+ Exit Do
+ End If
Case Else
If blnInsideIgnoredBlock Then
@@ -230,28 +439,34 @@ Public Function SanitizeFile(strPath As String, blnReturnHash As Boolean) As Str
Loop
' Ensure that we correctly processed the nested block sequence.
- If m_colBlocks.Count > 0 Then
- Log.Error eelWarning, Replace(Replace( _
- "Found ${BlockCount} unclosed blocks after sanitizing ${File}.", _
- "${BlockCount}", m_colBlocks.Count), _
- "${File}", strPath), ModuleName & ".SanitizeFile"
+ If this.colBlocks.Count > 0 Then
+ Log.Error eelWarning, MultiReplace( _
+ "Found ${BlockCount} unclosed blocks after sanitizing ${File}.", _
+ "${BlockCount}", this.colBlocks.Count, _
+ "${File}", Nz2(Me.ObjectName, this.strFilePath)), _
+ ModuleName(Me) & ".SanitizeFile"
End If
-Build_Output:
- ' Build the final output
- strContent = BuildOutput(varLines)
- WriteFile strContent, strPath
-
- ' Return hash of content
- If blnReturnHash Then SanitizeFile = GetStringHash(strContent, True)
+ ' Prepare primary output
+ this.strOutput = BuildOutput(varLines)
+ SanitizeObject = this.strOutput
+
+ ' Prepare VBA output (if used)
+ If Not cVBA Is Nothing Then
+ ' Build sanitized VBA string
+ With New clsSourceParser
+ .LoadString cVBA.GetStr
+ this.strVBA = .Sanitize(ectVBA)
+ End With
+ End If
' Log performance
- Set m_colBlocks = Nothing
+ Set this.colBlocks = Nothing
Perf.OperationEnd
Log.Add " Sanitized in " & Format$(Perf.MicroTimer - curStart, "0.000") & " seconds.", Options.ShowDebug
' Log any errors
- CatchAny eelError, "Error sanitizing file " & FSO.GetFileName(strPath), ModuleName & ".SanitizeFile"
+ CatchAny eelError, "Error sanitizing " & Nz2(Me.ObjectName, FSO.GetFileName(this.strFilePath)), ModuleName(Me) & ".SanitizeFile"
End Function
@@ -270,14 +485,14 @@ Private Function BuildOutput(varLines As Variant) As String
Dim lngLine As Long
' Check index of skipped lines
- If m_lngSkipIndex = 0 Then
+ If this.lngSkipIndex = 0 Then
' No lines to skip
- ReDim m_SkipLines(0 To 0)
- m_SkipLines(0) = UBound(varLines) + 1
+ ReDim this.lngSkipLines(0 To 0)
+ this.lngSkipLines(0) = UBound(varLines) + 1
Else
' Trim and sort index array
- ReDim Preserve m_SkipLines(0 To m_lngSkipIndex - 1)
- QuickSort m_SkipLines
+ ReDim Preserve this.lngSkipLines(0 To this.lngSkipIndex - 1)
+ QuickSort this.lngSkipLines
End If
' Use concatenation class to maximize performance
@@ -290,12 +505,12 @@ Private Function BuildOutput(varLines As Variant) As String
' Iterate the sorted skipped lines index to keep up with main loop
' (Using parallel loops to optimize performance)
- If m_SkipLines(lngSkip) < lngLine Then
- If lngSkip < UBound(m_SkipLines) Then lngSkip = lngSkip + 1
+ If this.lngSkipLines(lngSkip) < lngLine Then
+ If lngSkip < UBound(this.lngSkipLines) Then lngSkip = lngSkip + 1
End If
' Add content, unless the line is flagged to skip
- If m_SkipLines(lngSkip) <> lngLine Then .Add CStr(varLines(lngLine))
+ If this.lngSkipLines(lngSkip) <> lngLine Then .Add CStr(varLines(lngLine))
Next lngLine
@@ -309,6 +524,64 @@ Private Function BuildOutput(varLines As Variant) As String
End Function
+'---------------------------------------------------------------------------------------
+' Procedure : StripClassHeader
+' Author : Adam Waller
+' Date : 10/24/2023
+' Purpose : Strip the class header section from the VBA content. (Remove the version
+' : and VBE attributes lines that come before the actual VBA code.)
+'---------------------------------------------------------------------------------------
+'
+Public Function StripClassHeader(strContent As String, blnStripNameOnly As Boolean) As String
+
+ Dim lngLine As Long
+ Dim varLines As Variant
+ Dim strLine As String
+ Dim blnPastHeader As Boolean
+
+ ' Split code into lines
+ varLines = Split(strContent, vbCrLf)
+
+ With New clsConcat
+ .AppendOnAdd = vbCrLf
+
+ ' Skip the header information saved in the VBA class
+ For lngLine = 0 To UBound(varLines)
+ If Not blnPastHeader Then
+ strLine = varLines(lngLine)
+ If blnStripNameOnly Then
+ If StartsWith(strLine, "Attribute VB_Name = ") Then
+ ' Just skip that line. Keep everything else.
+ blnPastHeader = True
+ Else
+ .Add CStr(varLines(lngLine))
+ End If
+ Else
+ Select Case True
+ Case (strLine = "VERSION 1.0 CLASS")
+ Case (strLine = "BEGIN")
+ Case (strLine = " MultiUse = -1 'True")
+ Case (strLine = "END")
+ Case StartsWith(strLine, "Attribute VB_")
+ Case Else
+ blnPastHeader = True
+ .Add CStr(varLines(lngLine))
+ End Select
+ End If
+ Else
+ ' Add remaining lines
+ .Add CStr(varLines(lngLine))
+ End If
+ Next lngLine
+
+ ' remove trailing CrLf and return result
+ .Remove 2
+ StripClassHeader = .GetStr
+ End With
+
+End Function
+
+
'---------------------------------------------------------------------------------------
' Procedure : SkipLine
' Author : Adam Waller
@@ -319,8 +592,8 @@ End Function
'
Private Function SkipLine(lngLine As Long, Optional intMinSanitizeLevel As eSanitizeLevel)
If Options.SanitizeLevel >= intMinSanitizeLevel Then
- m_SkipLines(m_lngSkipIndex) = lngLine
- m_lngSkipIndex = m_lngSkipIndex + 1
+ this.lngSkipLines(this.lngSkipIndex) = lngLine
+ this.lngSkipIndex = this.lngSkipIndex + 1
End If
End Function
@@ -363,10 +636,10 @@ End Function
'
Private Sub BeginBlock(Optional strType As String)
Dim dBlock As Dictionary
- If m_colBlocks Is Nothing Then Set m_colBlocks = New Collection
+ If this.colBlocks Is Nothing Then Set this.colBlocks = New Collection
Set dBlock = New Dictionary
If strType <> vbNullString Then dBlock.Add "Type", strType
- m_colBlocks.Add dBlock
+ this.colBlocks.Add dBlock
End Sub
@@ -389,12 +662,16 @@ Private Sub CloseBlock()
If Options.SanitizeColors <= eslNone Then Exit Sub
' Bail out if we don't have a block to review
- If m_colBlocks.Count = 0 Then Exit Sub
- Set dBlock = m_colBlocks(m_colBlocks.Count)
+ If this.colBlocks.Count = 0 Then Exit Sub
+ Set dBlock = this.colBlocks(this.colBlocks.Count)
' Skip if we are not using themes for this control (UseTheme=0)
' (Applies to "CommandButton", "Tab", "ToggleButton")
- If dBlock.Exists("UseTheme") Then Exit Sub
+ If dBlock.Exists("UseTheme") Then
+ ' Remove this block
+ this.colBlocks.Remove this.colBlocks.Count
+ Exit Sub
+ End If
' Build array of base properties
varBase = Array("Back", "AlternateBack", "Border", _
@@ -437,7 +714,7 @@ Private Sub CloseBlock()
Next intCnt
' Remove this block
- m_colBlocks.Remove m_colBlocks.Count
+ this.colBlocks.Remove this.colBlocks.Count
End Sub
@@ -461,9 +738,9 @@ Private Sub CheckColorProperties(strTLine As String, lngLine As Long)
If Options.SanitizeColors <= eslNone Then Exit Sub
' Exit if we are not inside a block
- If Not m_colBlocks Is Nothing Then lngCnt = m_colBlocks.Count
+ If Not this.colBlocks Is Nothing Then lngCnt = this.colBlocks.Count
If lngCnt = 0 Then Exit Sub
- Set dBlock = m_colBlocks(m_colBlocks.Count)
+ Set dBlock = this.colBlocks(this.colBlocks.Count)
' Split on property/value
varParts = Split(strTLine, " =")
@@ -524,7 +801,7 @@ End Sub
' : - Remove extra trailing lines from the end of the module.
'---------------------------------------------------------------------------------------
'
-Public Function SanitizeVBA(strCode As String) As String
+Private Function SanitizeVBA() As String
Dim lngLine As Long
Dim varLines As Variant
@@ -532,14 +809,14 @@ Public Function SanitizeVBA(strCode As String) As String
' Skip sanitizing if not using that option.
If Options.SanitizeLevel < eslStandard Then
- SanitizeVBA = strCode
+ SanitizeVBA = this.strInput
Exit Function
End If
Perf.OperationStart "Sanitize VBA Code"
' Split code into lines
- varLines = Split(strCode, vbCrLf)
+ varLines = Split(this.strInput, vbCrLf)
' Build sanitized content
With New clsConcat
@@ -559,7 +836,9 @@ Public Function SanitizeVBA(strCode As String) As String
Next lngLine
' Return standardized code block
- SanitizeVBA = .GetStr
+ this.strOutput = .GetStr
+ this.strVBA = this.strOutput
+ SanitizeVBA = this.strOutput
Perf.OperationEnd
End With
@@ -575,11 +854,11 @@ End Function
' : back again afterwards to compute the hash.)
'---------------------------------------------------------------------------------------
'
-Public Function SanitizeXML(strPath As String, blnReturnHash As Boolean) As String
+Private Function SanitizeXML() As String
Dim curStart As Currency
Dim cData As clsConcat
- Dim strFile As String
+ Dim strXML As String
Dim rxLine As VBScript_RegExp_55.RegExp
If DebugMode(True) Then On Error GoTo 0 Else On Error Resume Next
@@ -588,15 +867,9 @@ Public Function SanitizeXML(strPath As String, blnReturnHash As Boolean) As Stri
cData.AppendOnAdd = vbCrLf
Set rxLine = New VBScript_RegExp_55.RegExp
- ' Read text from file
- If HasUcs2Bom(strPath) Then
- ' Table data macro XML is exported as UTF-16 LE BOM
- strFile = ReadFile(strPath, "Unicode")
- Else
- strFile = ReadFile(strPath)
- End If
Perf.OperationStart "Sanitize XML"
curStart = Perf.MicroTimer
+ strXML = this.strInput
' Exporting Table Def as XML does not properly encode ampersand character (See #314)
' Most likely if any ampersands are encoded correctly, all of them will be.
@@ -605,9 +878,9 @@ Public Function SanitizeXML(strPath As String, blnReturnHash As Boolean) As Stri
.Global = True
' Match & " > < etc...
.Pattern = "&[A-z]{2,6};"
- If Not .Test(strFile) Then
+ If Not .Test(strXML) Then
' Properly encode any embedded ampersand characters to make valid XML
- strFile = Replace(strFile, "&", "&")
+ strXML = Replace(strXML, "&", "&")
End If
End With
@@ -618,7 +891,14 @@ Public Function SanitizeXML(strPath As String, blnReturnHash As Boolean) As Stri
Set objXml = New MSXML2.DOMDocument60
End If
- objXml.LoadXML strFile
+ If objXml.LoadXML(strXML) = False Then
+ Log.Error eelError, _
+ "Unable to parse the XML for file '" & Nz2(this.strFilePath, Me.ObjectName) & _
+ "'. This may be due to containing malformed XML. Check the source XML document for validity. " & _
+ "In some cases, this may be due to table data containing characters not allowed in XML documents.", _
+ ModuleName(Me) & ".SanitizeXML"
+ Exit Function
+ End If
' Determine if it's a table data with schema
For Each objNode In objXml.SelectNodes("/root/dataroot")
@@ -660,17 +940,15 @@ Public Function SanitizeXML(strPath As String, blnReturnHash As Boolean) As Stri
Perf.OperationEnd
- ' Write out sanitized XML file
- WriteFile FormatXML(objXml), strPath
-
- ' Return hash, if requested
- If blnReturnHash Then SanitizeXML = GetStringHash(cData.GetStr, True)
+ ' Save the output
+ this.strOutput = FormatXML(objXml)
+ SanitizeXML = this.strOutput
' Show stats if debug turned on.
Log.Add " Sanitized in " & Format$(Perf.MicroTimer - curStart, "0.000") & " seconds.", Options.ShowDebug
' Log any errors
- CatchAny eelError, "Error sanitizing XML file " & FSO.GetFileName(strPath), ModuleName & ".SanitizeXML"
+ CatchAny eelError, "Error sanitizing XML for " & Nz2(FSO.GetFileName(this.strFilePath), Me.ObjectName), ModuleName(Me) & ".SanitizeXML"
End Function
@@ -682,7 +960,7 @@ End Function
' Purpose : Trim off tabs from beginning and end of string
'---------------------------------------------------------------------------------------
'
-Public Function TrimTabs(strText As String) As String
+Private Function TrimTabs(strText As String) As String
Dim dblStart As Double
Dim dblEnd As Double
@@ -717,31 +995,6 @@ Public Function TrimTabs(strText As String) As String
End Function
-'---------------------------------------------------------------------------------------
-' Procedure : StartsWith
-' Author : Adam Waller
-' Date : 11/5/2020
-' Purpose : See if a string begins with a specified string.
-'---------------------------------------------------------------------------------------
-'
-Public Function StartsWith(strText As String, strStartsWith As String, Optional Compare As VbCompareMethod = vbBinaryCompare) As Boolean
- StartsWith = (InStr(1, strText, strStartsWith, Compare) = 1)
-End Function
-
-
-'---------------------------------------------------------------------------------------
-' Procedure : EndsWith
-' Author : Adam Waller
-' Date : 4/29/2021
-' Purpose : See if a string ends with a specified string.
-'---------------------------------------------------------------------------------------
-'
-Public Function EndsWith(strText As String, strEndsWith As String, Optional Compare As VbCompareMethod = vbBinaryCompare) As Boolean
- EndsWith = (StrComp(Right$(strText, Len(strEndsWith)), strEndsWith, Compare) = 0)
- 'EndsWith = (InStr(1, strText, strEndsWith, Compare) = len(strtext len(strendswith) 1)
-End Function
-
-
'---------------------------------------------------------------------------------------
' Procedure : GetIndent
' Author : Adam Waller
@@ -749,7 +1002,7 @@ End Function
' Purpose : Returns the number of spaces until the first non-space character.
'---------------------------------------------------------------------------------------
'
-Public Function GetIndent(strLine As Variant) As Integer
+Private Function GetIndent(strLine As Variant) As Integer
Dim strChar As String
strChar = Left$(Trim(strLine), 1)
If strLine <> vbNullString Then GetIndent = InStr(1, strLine, strChar) - 1
@@ -763,10 +1016,8 @@ End Function
' Purpose : Format XML content for consistent and readable output.
'---------------------------------------------------------------------------------------
'
-Private Function FormatXML( _
- objInput As MSXML2.DOMDocument60, _
- Optional blnOmitDeclaration As Boolean _
-) As String
+Private Function FormatXML(objInput As MSXML2.DOMDocument60, _
+ Optional blnOmitDeclaration As Boolean) As String
' XSLT stylesheet that allow us to control indenting and also get a better indent result.
' For testing and adjusting, you can use https://www.online-toolz.com/tools/xslt-validator-tester-online.php
@@ -808,7 +1059,7 @@ Private Function FormatXML( _
End If
' Check for any errors parsing the XML
- If CatchAny(eelError, "Error parsing XML content", ModuleName & ".FormatXML") Then
+ If CatchAny(eelError, "Error parsing XML content", ModuleName(Me) & ".FormatXML") Then
' Fall back to input XML
strOutput = objInput.XML
' Output XML to log file
@@ -822,3 +1073,15 @@ Private Function FormatXML( _
FormatXML = strOutput
End Function
+
+
+'---------------------------------------------------------------------------------------
+' Procedure : Class_Terminate
+' Author : Adam Waller
+' Date : 10/25/2023
+' Purpose : Release private objects when terminating
+'---------------------------------------------------------------------------------------
+'
+Private Sub Class_Terminate()
+ Set this.colBlocks = Nothing
+End Sub
diff --git a/Version Control.accda.src/modules/clsSqlFormatter.cls b/Version Control.accda.src/modules/clsSqlFormatter.cls
index de759253..1eda5a05 100644
--- a/Version Control.accda.src/modules/clsSqlFormatter.cls
+++ b/Version Control.accda.src/modules/clsSqlFormatter.cls
@@ -82,7 +82,7 @@ Private m_varWordCache(1 To 2) As Variant
'---------------------------------------------------------------------------------------
-' Procedure : Format
+' Procedure : FormatSQL
' Author : Adam Waller
' Date : 4/1/2020
' Purpose : This is the main function used outside the class for SQL formatting.
@@ -115,11 +115,8 @@ Public Function FormatSQL(Optional strSql As String, Optional intDialect As eSql
Perf.CategoryStart "Format SQL"
Perf.OperationStart "Formating"
- ' Set SQL dialect
- m_intDialect = intDialect
-
' Tokenize the string, if provided
- If strSql <> vbNullString Then Tokenize strSql
+ If strSql <> vbNullString Then Tokenize strSql, intDialect
' Set up collection to hold types of indents
Set colIndents = New Collection
@@ -362,7 +359,9 @@ Public Function FormatSQL(Optional strSql As String, Optional intDialect As eSql
' If the token shouldn't have a space before it
If strTokenValue = "." _
Or strTokenValue = "," _
- Or strTokenValue = ";" Then
+ Or strTokenValue = ";" _
+ Or (strTokenValue = "!" And m_intDialect = esdAccess) _
+ Or (strTokenValue = ":" And m_intDialect = esdAccess) Then
' Trim any whitespace
cReturn.RTrim
End If
@@ -371,7 +370,10 @@ Public Function FormatSQL(Optional strSql As String, Optional intDialect As eSql
cReturn.Add strTokenValue, " "
' If the token shouldn't have a space after it
- If strTokenValue = "(" Or strTokenValue = "." Then
+ If strTokenValue = "(" _
+ Or strTokenValue = "." _
+ Or (strTokenValue = "!" And m_intDialect = esdAccess) _
+ Or (strTokenValue = ":" And m_intDialect = esdAccess) Then
cReturn.RTrim
End If
@@ -437,7 +439,7 @@ End Function
' : Each token is an array with type(0) and value(1).
'---------------------------------------------------------------------------------------
'
-Private Sub Tokenize(strSql As String)
+Private Sub Tokenize(strSql As String, intDialect As eSqlDialect)
Const cstrBreakAfter As String = "LIMIT" & ";;;;"
@@ -451,6 +453,9 @@ Private Sub Tokenize(strSql As String)
m_varWordCache(1) = Empty
m_varWordCache(2) = Empty
+ ' Set SQL dialect
+ m_intDialect = intDialect
+
Perf.CategoryStart "Tokenize SQL"
' Loop through SQL, converting string into tokens
@@ -487,7 +492,8 @@ Private Sub Tokenize(strSql As String)
AddToken ttQuote, GetQuotedString
' User defined variable
- ElseIf (NextChar("@") Or NextChar(":")) And (RemainingChars > 1) Then
+ ElseIf (NextChar("@") Or NextChar(":")) _
+ And (RemainingChars > 1) And (m_intDialect <> esdAccess) Then
' Check for quoted variable name
If PeekChar(1, """") Or PeekChar(1, "`") Or PeekChar(1, "'") Then
@@ -512,7 +518,9 @@ Private Sub Tokenize(strSql As String)
' A reserved word cannot be preceded by a "."
' This makes it so in "mytable.from", "from" is not considered a reserved word
- ElseIf PeekChar(-1, ".") Then
+ ElseIf PeekChar(-1, ".") _
+ Or (PeekChar(-1, "!") And m_intDialect = esdAccess) _
+ Or (PeekChar(-1, ":") And m_intDialect = esdAccess) Then
' Likely an object name
If HasMatches("^(.*?)($|\s|[""\'`]|" & RegExBoundaries & ")", strMatch) Then
@@ -720,7 +728,9 @@ End Function
' Procedure : GetQuotedString
' Author : Adam Waller
' Date : 8/12/2023
-' Purpose : Return a quoted string (Applies four possible rules)
+' Purpose : Return a quoted string (dialect-specific)
+' : https://stackoverflow.com/q/10573922/4121863
+' : https://stackoverflow.com/q/9719869/4121863
'---------------------------------------------------------------------------------------
'
Private Function GetQuotedString(Optional lngStartOffset As Long = 0) As String
@@ -1229,6 +1239,12 @@ End Function
'
Private Function GetNextTokenID(lngCurrentToken As Long, Optional intExceptType As eTokenTypes) As Long
Dim intToken As Integer
+
+ If lngCurrentToken + 1 > m_colTokens.Count Then
+ GetNextTokenID = lngCurrentToken + 1
+ Exit Function
+ End If
+
For intToken = lngCurrentToken + 1 To m_colTokens.Count
If m_colTokens(intToken)(0) <> intExceptType Then
GetNextTokenID = intToken
@@ -1306,16 +1322,13 @@ Public Sub SelfTest()
Dim strActual As String
- ' Test performance
- TestPerformance
-
' Test GetNextWords
- Tokenize " LEFT " & vbTab & vbCrLf & " JOIN test on 1=2"
+ Tokenize " LEFT " & vbTab & vbCrLf & " JOIN test on 1=2", esdAccess
Debug.Assert GetNextWords(2) = "LEFT JOIN"
Debug.Assert GetNextWords(1) = "LEFT"
' Test simple query with a few features
- Tokenize "SELECT 5 AS `TEST`"
+ Tokenize "SELECT 5 AS `TEST`", esdMySQL
' Verify tokens
Debug.Assert m_colTokens.Count = 7
@@ -1340,7 +1353,7 @@ Public Sub SelfTest()
' Test Access date literal with MySQL inline comment
- Tokenize "SELECT (#1/1/2000#) AS SampleDate # MySQL inline ## comment"
+ Tokenize "SELECT (#1/1/2000#) AS SampleDate # MySQL inline ## comment", esdAccess
' Verify tokens
Debug.Assert m_colTokens.Count = 11
@@ -1371,7 +1384,7 @@ Public Sub SelfTest()
' Example query from https://github.com/doctrine/sql-formatter
Tokenize "SELECT count(*),`Column1`,`Testing`, `Testing Three` FROM `Table1`" & _
" WHERE Column1 = 'testing' AND ( (`Column2` = `Column3` OR Column4 >= NOW()) )" & _
- " GROUP BY Column1 ORDER BY Column3 DESC LIMIT 5,10"
+ " GROUP BY Column1 ORDER BY Column3 DESC LIMIT 5,10", esdMySQL
' Verify tokens
Debug.Assert m_colTokens.Count = 66
@@ -1473,9 +1486,111 @@ Public Sub SelfTest()
If (strActual <> FormatSQL) Then Diff.Strings strActual, FormatSQL
- 'PrintTokens
- 'BuildTestFromTokens
- 'Diff.Strings strActual, FormatSQL
+ ' Test multi-part names
+ Tokenize "SELECT [dbo].[field] FROM [server].[schema].[table];", esdMSSQL
+
+ ' Verify tokens
+ Debug.Assert m_colTokens.Count = 13
+ Debug.Assert VerifyToken(1, ttReservedTopLevel, "SELECT")
+ Debug.Assert VerifyToken(2, ttWhitespace, " ")
+ Debug.Assert VerifyToken(3, ttQuote, "[dbo]")
+ Debug.Assert VerifyToken(4, ttBoundary, ".")
+ Debug.Assert VerifyToken(5, ttQuote, "[field]")
+ Debug.Assert VerifyToken(6, ttWhitespace, " ")
+ Debug.Assert VerifyToken(7, ttReservedTopLevel, "FROM")
+ Debug.Assert VerifyToken(8, ttWhitespace, " ")
+ Debug.Assert VerifyToken(9, ttQuote, "[server]")
+ Debug.Assert VerifyToken(10, ttBoundary, ".")
+ Debug.Assert VerifyToken(11, ttQuote, "[schema]")
+ Debug.Assert VerifyToken(12, ttBoundary, ".")
+ Debug.Assert VerifyToken(13, ttQuote, "[table]")
+
+ ' Verify result
+ With New clsConcat
+ .AppendOnAdd = vbCrLf
+ .Add "SELECT"
+ .Add " [dbo].[field]"
+ .Add "FROM"
+ .Add " [server].[schema].[table]"
+ .Remove 2
+ strActual = .GetStr
+ End With
+ Debug.Assert (strActual = FormatSQL)
+ If (strActual <> FormatSQL) Then Diff.Strings strActual, FormatSQL
+
+
+ ' Test parameter expression
+ Tokenize "SELECT [Forms]![frmColors]![Text18];", esdAccess
+
+ ' Verify tokens
+ Debug.Assert m_colTokens.Count = 7
+ Debug.Assert VerifyToken(1, ttReservedTopLevel, "SELECT")
+ Debug.Assert VerifyToken(2, ttWhitespace, " ")
+ Debug.Assert VerifyToken(3, ttQuote, "[Forms]")
+ Debug.Assert VerifyToken(4, ttBoundary, "!")
+ Debug.Assert VerifyToken(5, ttQuote, "[frmColors]")
+ Debug.Assert VerifyToken(6, ttBoundary, "!")
+ Debug.Assert VerifyToken(7, ttQuote, "[Text18]")
+
+ ' Verify result
+ With New clsConcat
+ .AppendOnAdd = vbCrLf
+ .Add "SELECT"
+ .Add " [Forms]![frmColors]![Text18]"
+ .Remove 2
+ strActual = .GetStr
+ End With
+ Debug.Assert (strActual = FormatSQL)
+ If (strActual <> FormatSQL) Then Diff.Strings strActual, FormatSQL
+
+
+ ' Test unquoted path (See issue #447)
+ Tokenize "SELECT foo.* INTO (C:\path\to\bar.accdb) fizz FROM bazz;", esdAccess
+
+ ' Verify tokens
+ Debug.Assert m_colTokens.Count = 21
+ Debug.Assert VerifyToken(1, ttReservedTopLevel, "SELECT")
+ Debug.Assert VerifyToken(2, ttWhitespace, " ")
+ Debug.Assert VerifyToken(3, ttWord, "foo")
+ Debug.Assert VerifyToken(4, ttBoundary, ".")
+ Debug.Assert VerifyToken(5, ttBoundary, "*")
+ Debug.Assert VerifyToken(6, ttWhitespace, " ")
+ Debug.Assert VerifyToken(7, ttReserved, "INTO")
+ Debug.Assert VerifyToken(8, ttWhitespace, " ")
+ Debug.Assert VerifyToken(9, ttBoundary, "(")
+ Debug.Assert VerifyToken(10, ttWord, "C")
+ Debug.Assert VerifyToken(11, ttBoundary, ":")
+ Debug.Assert VerifyToken(12, ttWord, "\path\to\bar")
+ Debug.Assert VerifyToken(13, ttBoundary, ".")
+ Debug.Assert VerifyToken(14, ttWord, "accdb")
+ Debug.Assert VerifyToken(15, ttBoundary, ")")
+ Debug.Assert VerifyToken(16, ttWhitespace, " ")
+ Debug.Assert VerifyToken(17, ttWord, "fizz")
+ Debug.Assert VerifyToken(18, ttWhitespace, " ")
+ Debug.Assert VerifyToken(19, ttReservedTopLevel, "FROM")
+ Debug.Assert VerifyToken(20, ttWhitespace, " ")
+ Debug.Assert VerifyToken(21, ttWord, "bazz")
+
+ ' Verify result
+ With New clsConcat
+ .AppendOnAdd = vbCrLf
+ .Add "SELECT"
+ .Add " foo.* INTO (C:\path\to\bar.accdb) fizz"
+ .Add "FROM"
+ .Add " bazz"
+ .Remove 2
+ strActual = .GetStr
+ End With
+ Debug.Assert (strActual = FormatSQL)
+ If (strActual <> FormatSQL) Then Diff.Strings strActual, FormatSQL
+
+
+' PrintTokens
+' BuildTestFromTokens
+' Diff.Strings strActual, FormatSQL
+
+ ' Test performance
+ TestPerformance
End Sub
@@ -1531,7 +1646,7 @@ Private Function BuildTestFromTokens()
Dim intLine As Integer
Debug.Print vbCrLf & vbCrLf & " ' Verify tokens"
- Debug.Print vbCrLf & " Debug.Assert m_colTokens.Count = " & m_colTokens.Count
+ Debug.Print " Debug.Assert m_colTokens.Count = " & m_colTokens.Count
' Loop through tokens
For intToken = 1 To m_colTokens.Count
@@ -1559,6 +1674,7 @@ Private Function BuildTestFromTokens()
Debug.Print " strActual = .GetStr"
Debug.Print " End With"
Debug.Print " Debug.Assert (strActual = FormatSQL)"
+ Debug.Print " If (strActual <> FormatSQL) Then Diff.Strings strActual, FormatSQL"
End Function
@@ -1637,6 +1753,7 @@ End Function
' Author : Adam Waller
' Date : 8/18/2023
' Purpose : Print out AscW indexes of each character in the string.
+' : (Use this when building case statements)
'---------------------------------------------------------------------------------------
'
Private Function GetAscWFromString(strText As String) As String
@@ -1669,7 +1786,7 @@ Private Function TestPerformance()
For lngCnt = 1 To lngMax
Tokenize "SELECT count(*),`Column1`,`Testing`, `Testing Three` FROM `Table1`" & _
" WHERE Column1 = 'testing' AND ( (`Column2` = `Column3` OR Column4 >= NOW()) )" & _
- " GROUP BY Column1 ORDER BY Column3 DESC LIMIT 5,10"
+ " GROUP BY Column1 ORDER BY Column3 DESC LIMIT 5,10", esdMySQL
Next lngCnt
' Test performance of formatting SQL
diff --git a/Version Control.accda.src/modules/clsVCSIndex.cls b/Version Control.accda.src/modules/clsVCSIndex.cls
index 837a3ce1..f430c269 100644
--- a/Version Control.accda.src/modules/clsVCSIndex.cls
+++ b/Version Control.accda.src/modules/clsVCSIndex.cls
@@ -59,6 +59,7 @@ Public Sub LoadFromFile(Optional strFile As String)
Dim dFile As Dictionary
Dim dItem As Dictionary
Dim varKey As Variant
+ Dim blnSavedValue As Boolean
' Exit if we have disabled the index functionality
If Me.Disabled Then Exit Sub
@@ -70,7 +71,11 @@ Public Sub LoadFromFile(Optional strFile As String)
m_strFile = strFile
If m_strFile = vbNullString Then m_strFile = DefaultFilePath
If FSO.FileExists(m_strFile) Then
+ ' Convert dates back to local time for processing
+ blnSavedValue = JsonOptions.ConvertDateToIso
+ JsonOptions.ConvertDateToIso = True
Set dFile = ReadJsonFile(m_strFile)
+ JsonOptions.ConvertDateToIso = blnSavedValue
If Not dFile Is Nothing Then
If dFile.Exists("Items") Then
' Load properties from class
@@ -106,6 +111,7 @@ Public Sub Save(Optional strInFolder As String)
Dim varKey As Variant
Dim varValue As Variant
Dim strFile As String
+ Dim blnSavedValue As Boolean
' Exit if we have disabled the index functionality
If Me.Disabled Then Exit Sub
@@ -118,7 +124,7 @@ Public Sub Save(Optional strInFolder As String)
varValue = CallByName(Me, CStr(varKey), VbGet)
' Save blank dates as null
If Right(varKey, 4) = "Date" Then
- m_dIndex(varKey) = ZNDate(CStr(varValue))
+ m_dIndex(varKey) = ZNDate(varValue)
Else
m_dIndex(varKey) = CStr(varValue)
End If
@@ -139,11 +145,18 @@ Public Sub Save(Optional strInFolder As String)
strFile = StripSlash(strInFolder) & PathSep & cstrFileName
End If
+ ' Turn on ISO date conversion to save index dates in UTC
+ blnSavedValue = JsonOptions.ConvertDateToIso
+ JsonOptions.ConvertDateToIso = True
+
' Save index to file
If m_strFile <> vbNullString Then
WriteFile BuildJsonFile(TypeName(Me), m_dIndex, "Version Control System Index"), strFile
End If
+ ' Restore previous setting
+ JsonOptions.ConvertDateToIso = blnSavedValue
+
End Sub
@@ -222,14 +235,14 @@ Public Function Update(cItem As IDbComponent, intAction As eIndexOperationType,
If dteDateTime = 0 Then dteDateTime = Now
Select Case intAction
Case eatExport, eatAltExport
- .Item("ExportDate") = CStr(dteDateTime)
+ .Item("ExportDate") = dteDateTime
Case eatImport
- .Item("ImportDate") = CStr(dteDateTime)
+ .Item("ImportDate") = dteDateTime
End Select
' Save timestamp of exported source file.
dteDateTime = GetLastModifiedDate(cItem.SourceFile)
- .Item("SourceModified") = ZNDate(CStr(dteDateTime))
+ .Item("SourceModified") = ZNDate(dteDateTime)
' Save hash of file properties
.Item("FilePropertiesHash") = GetFilePropertyHash(cItem.SourceFile)
@@ -494,7 +507,7 @@ Public Function GetModifiedSourceFiles(cCategory As IDbComponent) As Dictionary
strPath = Join(Array("Components", cCategory.Category, FSO.GetFileName(strFile), "SourceModified"), PathSep)
' Compare modified date of file with modified date in index.
' File is considered not modified if the index date matches the file modification date.
- blnModified = Not (dNZ(m_dIndex, strPath) = CStr(GetLastModifiedDate(strFile)))
+ blnModified = Not (dNZ(m_dIndex, strPath) = GetLastModifiedDate(strFile))
End If
' Add modified files to collection
If blnModified Then .Add strFile, vbNullString
@@ -776,7 +789,8 @@ End Property
Public Sub ClearTempExportFolder()
If m_strTempExportFolderPath <> vbNullString Then
If FSO.FolderExists(m_strTempExportFolderPath) Then
- If DebugMode(True) Then On Error Resume Next Else On Error Resume Next
+ LogUnhandledErrors
+ On Error Resume Next
' Use FSO to delete the folder and contents
FSO.DeleteFolder m_strTempExportFolderPath, True
CatchAny eelWarning, "Unable to delete temp folder: '" & m_strTempExportFolderPath & _
diff --git a/Version Control.accda.src/modules/clsVersionControl.cls b/Version Control.accda.src/modules/clsVersionControl.cls
index e3c32285..bf0743a4 100644
--- a/Version Control.accda.src/modules/clsVersionControl.cls
+++ b/Version Control.accda.src/modules/clsVersionControl.cls
@@ -118,11 +118,12 @@ End Sub
' Purpose : Initiate a full build from source
'---------------------------------------------------------------------------------------
'
-Public Sub Build()
+Public Sub Build(Optional strSourceFolder As String)
DoCmd.OpenForm "frmVCSMain", , , , , acHidden
With Form_frmVCSMain
' Make sure we are doing a full build.
If Not .chkFullBuild Then .chkFullBuild = True
+ .strSourcePath = strSourceFolder
.cmdBuild_Click
End With
End Sub
@@ -372,6 +373,18 @@ Public Sub RepairColors()
End Sub
+'---------------------------------------------------------------------------------------
+' Procedure : SplitFiles
+' Author : Adam Waller
+' Date : 11/14/2023
+' Purpose :
+'---------------------------------------------------------------------------------------
+'
+Public Sub SplitFiles()
+ DoCmd.OpenForm "frmVCSSplitFiles"
+End Sub
+
+
'---------------------------------------------------------------------------------------
' Procedure : LocalizeLibraryReferences
' Author : Adam Waller
@@ -426,6 +439,7 @@ Public Sub ActivateHook()
End If
End Sub
+
'---------------------------------------------------------------------------------------
' Procedure : Class_Initialize
' Author : Adam Waller
@@ -435,6 +449,10 @@ End Sub
'
Private Sub Class_Initialize()
SaveState
+ ' When the class is initialized, make sure the ribbon is active (if installed).
+ ' This way if the COM add-in is not active, it will be automatically activated
+ ' when the add-in is opened from the [Database Tools\Add-ins] menu. (See #451)
+ modCOMAddIn.VerifyRibbon
End Sub
diff --git a/Version Control.accda.src/modules/clsViewDiff.cls b/Version Control.accda.src/modules/clsViewDiff.cls
index b895c808..1d863e02 100644
--- a/Version Control.accda.src/modules/clsViewDiff.cls
+++ b/Version Control.accda.src/modules/clsViewDiff.cls
@@ -140,7 +140,8 @@ Public Sub ClearTempFiles()
Dim varFile As Variant
If Not m_colTempFiles Is Nothing Then
- If DebugMode(True) Then On Error Resume Next Else On Error Resume Next
+ LogUnhandledErrors
+ On Error Resume Next
For Each varFile In m_colTempFiles
If FSO.FileExists(varFile) Then DeleteFile CStr(varFile)
Next varFile
@@ -185,7 +186,8 @@ Private Sub RunCompare(strFile1 As String, strFile2 As String)
End Select
' Run command to launch compare
- If DebugMode(True) Then On Error Resume Next Else On Error Resume Next
+ LogUnhandledErrors
+ On Error Resume Next
If strCmd <> vbNullString Then
With New WshShell
.Run strCmd
@@ -219,7 +221,7 @@ End Function
' : valid for use.
'---------------------------------------------------------------------------------------
'
-Private Function HasValidCompareTool() As Boolean
+Public Function HasValidCompareTool() As Boolean
' Check the current option for compare tool.
Select Case Me.ToolName
diff --git a/Version Control.accda.src/modules/modAPI.bas b/Version Control.accda.src/modules/modAPI.bas
index b6a230ca..e83c3c34 100644
--- a/Version Control.accda.src/modules/modAPI.bas
+++ b/Version Control.accda.src/modules/modAPI.bas
@@ -44,7 +44,7 @@ End Enum
' : Access add-in.)
'---------------------------------------------------------------------------------------
'
-Public Function HandleRibbonCommand(strCommand As String) As Boolean
+Public Function HandleRibbonCommand(strCommand As String, Optional strArgument As String) As Boolean
' The function is called by Application.Run which can be re-entrant but we really
' don't want it to be since that'd cause errors. To avoid this, we will ignore any
' commands while the current command is running.
@@ -62,17 +62,21 @@ Public Function HandleRibbonCommand(strCommand As String) As Boolean
' Make sure we are not attempting to run this from the current database when making
' changes to the add-in itself. (It will re-run the command through the add-in.)
If RunningOnLocal() Then
- RunInAddIn "HandleRibbonCommand", True, strCommand
+ RunInAddIn "HandleRibbonCommand", True, strCommand, strArgument
GoTo CleanUp
End If
' If a function is not found, this will throw an error. It is up to the ribbon
' designer to ensure that the control IDs match public procedures in the VCS
- ' (clsVersionControl) class module. Additional parameters are not supported.
+ ' (clsVersionControl) class module.
' For example, to run VCS.Export, the ribbon button ID should be named "btnExport"
' Trim off control ID prefix when calling command
- CallByName VCS, Mid(strCommand, 4), VbMethod
+ If Len(strArgument) Then
+ CallByName VCS, Mid(strCommand, 4), VbMethod, strArgument
+ Else
+ CallByName VCS, Mid(strCommand, 4), VbMethod
+ End If
CleanUp:
IsRunning = False
@@ -220,7 +224,7 @@ Public Function ExampleLoadAddInAndRunExport()
Dim objAddIn As Object ' VBProject
' Build default add-in path
- strAddInPath = GetAddInFileName
+ strAddInPath = Environ$("AppData") & "\MSAccessVCS\Version Control.accda"
' See if add-in project is already loaded.
For Each proj In VBE.VBProjects
@@ -256,3 +260,62 @@ Public Function ExampleLoadAddInAndRunExport()
End If
End Function
+
+
+'---------------------------------------------------------------------------------------
+' Procedure : ExampleBuildFromSource
+' Author : Adam Waller
+' Date : 9/6/2023
+' Purpose : This function can be copied to a local database and triggered with a
+' : command line argument or other automation technique to load the VCS
+' : add-in file and build this project from source.
+' : NOTE: This expects the add-in to be installed in the default location
+' : and using the default file name.
+'---------------------------------------------------------------------------------------
+'
+Public Function ExampleBuildFromSource()
+
+ Dim strAddInPath As String
+ Dim proj As Object ' VBProject
+ Dim objAddIn As Object ' VBProject
+
+ ' Build default add-in path
+ strAddInPath = Environ$("AppData") & "\MSAccessVCS\Version Control.accda"
+
+ ' See if add-in project is already loaded.
+ For Each proj In VBE.VBProjects
+ If StrComp(proj.FileName, strAddInPath, vbTextCompare) = 0 Then
+ Set objAddIn = proj
+ End If
+ Next proj
+
+ ' If not loaded, then attempt to load the add-in.
+ If objAddIn Is Nothing Then
+
+ ' The following lines will load the add-in at the application level,
+ ' but will not actually call the function. Ignore the error of function not found.
+ ' https://stackoverflow.com/questions/62270088/how-can-i-launch-an-access-add-in-not-com-add-in-from-vba-code
+ On Error Resume Next
+ Application.Run strAddInPath & "!DummyFunction"
+ On Error GoTo 0
+
+ ' See if it is loaded now...
+ For Each proj In VBE.VBProjects
+ If StrComp(proj.FileName, strAddInPath, vbTextCompare) = 0 Then
+ Set objAddIn = proj
+ End If
+ Next proj
+ End If
+
+ If objAddIn Is Nothing Then
+ MsgBox "Unable to load Version Control add-in. Please ensure that it has been installed" & vbCrLf & _
+ "and is functioning correctly. (It should be available in the Add-ins menu.)", vbExclamation
+ Else
+ ' Set the application interaction level to silent to skip confirmation dialogs.
+ Application.Run "MSAccessVCS.SetInteractionMode", 1
+ ' Launch the build process (as if we clicked the button on the ribbon)
+ ' Optionally specify a specific folder of source files to build from.
+ Application.Run "MSAccessVCS.HandleRibbonCommand", "btnBuild" ', "c:\path\to\source\folder"
+ End If
+
+End Function
diff --git a/Version Control.accda.src/modules/modComAddIn.bas b/Version Control.accda.src/modules/modComAddIn.bas
index f6e328ba..0c801f7d 100644
--- a/Version Control.accda.src/modules/modComAddIn.bas
+++ b/Version Control.accda.src/modules/modComAddIn.bas
@@ -87,6 +87,9 @@ Public Sub VerifyComAddIn()
' Reload the add-in to refresh the ribbon
UnloadAddIn
LoadAddIn
+ Else
+ ' Verify that the ribbon is active
+ VerifyRibbon
End If
End If
@@ -107,6 +110,24 @@ Public Sub ReloadRibbon()
End Sub
+'---------------------------------------------------------------------------------------
+' Procedure : VerifyRibbon
+' Author : Adam Waller
+' Date : 11/3/2023
+' Purpose : A lightweight function to verify that the ribbon add-in is active.
+' : (It may get turned off if Access is opened in administrator mode.)
+'---------------------------------------------------------------------------------------
+'
+Public Sub VerifyRibbon()
+ Dim objAddIn As COMAddIn
+ Set objAddIn = GetCOMAddIn
+ If Not objAddIn Is Nothing Then
+ ' Activate the add-in if it is not currently active
+ If Not objAddIn.Connect Then objAddIn.Connect = True
+ End If
+End Sub
+
+
'---------------------------------------------------------------------------------------
' Procedure : UninstallComAddIn
' Author : Adam Waller
@@ -285,7 +306,8 @@ Private Function DllIsRegistered() As Boolean
' Check HKLM registry key
With New IWshRuntimeLibrary.WshShell
' We should have a value here if the install ran in the past.
- If DebugMode(True) Then On Error Resume Next Else On Error Resume Next
+ LogUnhandledErrors
+ On Error Resume Next
' Look up the class ID from the COM registration
strTest = .RegRead("HKCU\SOFTWARE\Classes\MSAccessVCSLib.AddInRibbon\CLSID\")
If strTest <> vbNullString Then
@@ -297,6 +319,7 @@ Private Function DllIsRegistered() As Boolean
DllIsRegistered = FSO.FileExists(strTest)
End If
End If
+ If Err Then Err.Clear
End With
End Function
diff --git a/Version Control.accda.src/modules/modDatabase.bas b/Version Control.accda.src/modules/modDatabase.bas
index 35e10d5d..89ed41c7 100644
--- a/Version Control.accda.src/modules/modDatabase.bas
+++ b/Version Control.accda.src/modules/modDatabase.bas
@@ -392,9 +392,11 @@ Public Function ObjectExists(intType As AcObjectType, strName As String, Optiona
Log.Error eelError, "Parent container not supported for this object type: " & intType, ModuleName & ".ObjectExists"
Else
' Attempt to reference the object by name
- If DebugMode(True) Then On Error Resume Next Else On Error Resume Next
+ LogUnhandledErrors
+ On Error Resume Next
Set objTest = objContainer(strName)
ObjectExists = Not Catch(2467)
+ If Err Then Err.Clear
End If
End Function
@@ -573,7 +575,8 @@ Public Function DatabaseFileOpen() As Boolean
Else
' For ADP projects, CurrentProject may be an invalid object reference
' after the database file (adp) is closed.
- If DebugMode(True) Then On Error Resume Next Else On Error Resume Next
+ LogUnhandledErrors
+ On Error Resume Next
strTest = CurrentProject.FullName
CatchAny eelNoError, vbNullString
DatabaseFileOpen = (strTest <> vbNullString)
@@ -637,7 +640,8 @@ Public Function DeleteObjectIfExists(intType As AcObjectType, strName As String)
End Select
' Trap errors when attempting to delete the object
- If DebugMode(True) Then On Error Resume Next Else On Error Resume Next
+ LogUnhandledErrors
+ On Error Resume Next
If Not blnExistsInAddIn Then
' Nice! We can use a simple call to delete the object
@@ -718,10 +722,12 @@ Public Function FormLoaded(frmMe As Form) As Boolean
' If no forms are open, we already have our answer. :-)
If Forms.Count > 0 Then
' We will throw an error accessing the name property if the form is closed
- If DebugMode(True) Then On Error Resume Next Else On Error Resume Next
+ LogUnhandledErrors
+ On Error Resume Next
strName = frmMe.Name
' Return true if we were able to read the name property
FormLoaded = strName <> vbNullString
+ If Err Then Err.Clear
End If
End Function
@@ -747,7 +753,8 @@ Public Function VerifyFocus(ctlWithFocus As Control) As Boolean
Set frmParent = objParent
' Ignore any errors with Screen.* functions
- If DebugMode(True) Then On Error Resume Next Else On Error Resume Next
+ LogUnhandledErrors
+ On Error Resume Next
' Verify focus of parent form
Set frmParent = Screen.ActiveForm
diff --git a/Version Control.accda.src/modules/modErrorHandling.bas b/Version Control.accda.src/modules/modErrorHandling.bas
index 78bb4272..0cbf3713 100644
--- a/Version Control.accda.src/modules/modErrorHandling.bas
+++ b/Version Control.accda.src/modules/modErrorHandling.bas
@@ -9,6 +9,7 @@ Option Compare Database
Option Private Module
Option Explicit
+Private Const ModuleName As String = "modErrorHandling"
Private Type udtThis
blnInError As Boolean ' Monitor error state
@@ -41,20 +42,22 @@ End Function
' Purpose : Log any unhandled error condition, also breaking code execution if that
' : option is currently set. (Run this before any ON ERROR directive which
' : will siently reset any current VBA error condition.)
+'
+' Example : See Sub `CatchTest` for example use.
+'
'---------------------------------------------------------------------------------------
'
-Public Sub LogUnhandledErrors()
-
- Dim blnBreak As Boolean
+Public Sub LogUnhandledErrors(Optional ByRef CallingFunction As String = vbNullString)
' Check for any unhandled errors
If (Err.Number <> 0) And Not this.blnInError Then
- ' Don't reference the property this till we have loaded the options.
- If OptionsLoaded Then blnBreak = Options.BreakOnError
+ this.blnInError = True ' Set flag so we don't create a loop while logging the error
+ ' With the above flag, options will load in background and we don't depend on
+ ' flags outside of this routine.
' Check current BreakOnError mode
- If blnBreak Then
+ If Options.BreakOnError Then
' Stop the code here so we can investigate the source of the error.
Debug.Print "Error " & Err.Number & ": " & Err.Description
Stop
@@ -81,20 +84,48 @@ Public Sub LogUnhandledErrors()
'===========================================================================
Else
' Log otherwise unhandled error
- If Not Log(False) Is Nothing Then
- ' Set flag so we don't create a loop while logging the error
- this.blnInError = True
- ' We don't know the procedure that it originated from, but we should at least
- ' log that the error occurred. A review of the log file may help identify the source.
- Log.Error eelError, "Unhandled error, likely before `On Error` directive", "Unknown"
- this.blnInError = False
- End If
+ ' We don't know the procedure that it originated from, but we should at least
+ ' log that the error occurred. A review of the log file may help identify the source.
+ Log.Error eelError, "Unhandled error, likely before `On Error` directive", CallingFunction & ".Unknown.LogUnhandledErrors"
End If
+ this.blnInError = False
End If
End Sub
+'---------------------------------------------------------------------------------------
+' Procedure : CatchTest
+' Author : hecon5
+' Date : 10/20/2023
+' Purpose : Validates that Catch operates correctly and that LogUnhandledErrors
+' : doesn't create an infinite loop whether or not log exists.
+' :
+' : To use, run normally, after loading options / other core dependancies.
+' : Then Stop the code (in VBA IDE) and then run again. Stopping code execution
+' :
+'---------------------------------------------------------------------------------------
+'
+Public Sub CatchTest()
+
+ ' Specifiying a Const FunctionName allows copy/paste code and having the wrong FunctionName
+ ' names if (when) they change.
+ Const FunctionName As String = ModuleName & ".CatchTest"
+
+ On Error Resume Next ' Clear out any errors that may happen, and continue on when errors happen.
+ Err.Raise 24601, "Pre Log Test"
+
+ ' This is the "standard" way of catching errors without losing them.
+ LogUnhandledErrors FunctionName
+ On Error Resume Next
+
+ ' "Pretend" code tossing an error.
+ Err.Raise 24602, "Post Log Test"
+ ' Checking for any issues post code execution.
+ CatchAny eelError, "Catch Test Validation", FunctionName
+
+End Sub
+
'---------------------------------------------------------------------------------------
' Procedure : Catch
' Author : Adam Waller
diff --git a/Version Control.accda.src/modules/modFileAccess.bas b/Version Control.accda.src/modules/modFileAccess.bas
index a6c68029..85f7e436 100644
--- a/Version Control.accda.src/modules/modFileAccess.bas
+++ b/Version Control.accda.src/modules/modFileAccess.bas
@@ -138,7 +138,8 @@ Public Sub WriteFile(strText As String, strPath As String, Optional strEncoding
' Write to disk
VerifyPath strPath
' Watch out for possible write error
- If DebugMode(True) Then On Error Resume Next Else On Error Resume Next
+ LogUnhandledErrors
+ On Error Resume Next
.SaveToFile strPath, adSaveCreateOverWrite
If Catch(3004) Then
' File is locked. Try again after 1 second, just in case something
@@ -529,11 +530,14 @@ End Function
' Purpose : Returns the UNC path for a network location (if applicable)
'---------------------------------------------------------------------------------------
'
-Public Function GetUncPath(strPath As String)
+Public Function GetUncPath(strPath As String) As String
Dim strDrive As String
Dim strUNC As String
+ LogUnhandledErrors
+ On Error Resume Next
+
strUNC = strPath
strDrive = FSO.GetDriveName(strPath)
If strDrive <> vbNullString Then
@@ -543,6 +547,11 @@ Public Function GetUncPath(strPath As String)
End If
End With
End If
+
+ ' Log warning if unable to access a drive.
+ CatchAny eelWarning, "Unable to determine UNC path for " & strPath, ModuleName & ".GetUncPath"
+
+ ' Return UNC Path
GetUncPath = strUNC
End Function
diff --git a/Version Control.accda.src/modules/modFunctions.bas b/Version Control.accda.src/modules/modFunctions.bas
index ffb07d17..12bcaeb0 100644
--- a/Version Control.accda.src/modules/modFunctions.bas
+++ b/Version Control.accda.src/modules/modFunctions.bas
@@ -789,6 +789,9 @@ Public Function IsEmptyArray(varArray As Variant) As Boolean
lngLowBound = clngTest
lngLowBound = LBound(varArray)
+ ' Clear any error thrown while attempting to read LBound()
+ If Err Then Err.Clear
+
' If the above assignment fails, we have an empty array
IsEmptyArray = (lngLowBound = clngTest)
@@ -877,6 +880,31 @@ Public Function DeDupString(strText As String, strDuplicated As String) As Strin
End Function
+'---------------------------------------------------------------------------------------
+' Procedure : StartsWith
+' Author : Adam Waller
+' Date : 11/5/2020
+' Purpose : See if a string begins with a specified string.
+'---------------------------------------------------------------------------------------
+'
+Public Function StartsWith(strText As String, strStartsWith As String, Optional Compare As VbCompareMethod = vbBinaryCompare) As Boolean
+ StartsWith = (InStr(1, strText, strStartsWith, Compare) = 1)
+End Function
+
+
+'---------------------------------------------------------------------------------------
+' Procedure : EndsWith
+' Author : Adam Waller
+' Date : 4/29/2021
+' Purpose : See if a string ends with a specified string.
+'---------------------------------------------------------------------------------------
+'
+Public Function EndsWith(strText As String, strEndsWith As String, Optional Compare As VbCompareMethod = vbBinaryCompare) As Boolean
+ EndsWith = (StrComp(Right$(strText, Len(strEndsWith)), strEndsWith, Compare) = 0)
+ 'EndsWith = (InStr(1, strText, strEndsWith, Compare) = len(strtext len(strendswith) 1)
+End Function
+
+
'---------------------------------------------------------------------------------------
' Procedure : SwapExtension
' Author : Adam Waller
@@ -885,10 +913,10 @@ End Function
' : I.e. c:\test.bas > c:\test.cls
'---------------------------------------------------------------------------------------
'
-Public Function SwapExtension(strFilePath As String, strNewExtension As String) As String
+Public Function SwapExtension(strFilePath As String, strNewExtensionWithoutDelimiter As String) As String
Dim strCurrentExt As String
strCurrentExt = FSO.GetExtensionName(strFilePath)
- SwapExtension = Left(strFilePath, Len(strFilePath) - Len(strCurrentExt)) & strNewExtension
+ SwapExtension = Left(strFilePath, Len(strFilePath) - Len(strCurrentExt)) & strNewExtensionWithoutDelimiter
End Function
diff --git a/Version Control.accda.src/modules/modHash.bas b/Version Control.accda.src/modules/modHash.bas
index 6045bc0f..56d2071e 100644
--- a/Version Control.accda.src/modules/modHash.bas
+++ b/Version Control.accda.src/modules/modHash.bas
@@ -132,14 +132,16 @@ End Function
'---------------------------------------------------------------------------------------
'
Private Function HashBytes(Data() As Byte, Optional HashingAlgorithm As String = DefaultHashAlgorithm) As Byte()
- If DebugMode(True) Then On Error Resume Next Else On Error Resume Next
+ LogUnhandledErrors
+ On Error Resume Next
HashBytes = NGHash(VarPtr(Data(LBound(Data))), UBound(Data) - LBound(Data) + 1, HashingAlgorithm)
If Catch(9) Then HashBytes = NGHash(VarPtr(Null), UBound(Data) - LBound(Data) + 1, HashingAlgorithm)
CatchAny eelCritical, "Error hashing data!", ModuleName & ".HashBytes", True, True
End Function
Private Function HashString(str As String, Optional HashingAlgorithm As String = DefaultHashAlgorithm) As Byte()
- If DebugMode(True) Then On Error Resume Next Else On Error Resume Next
+ LogUnhandledErrors
+ On Error Resume Next
HashString = NGHash(StrPtr(str), Len(str) * 2, HashingAlgorithm)
If Catch(9) Then HashString = NGHash(StrPtr(vbNullString), Len(str) * 2, HashingAlgorithm)
CatchAny eelCritical, "Error hashing string!", ModuleName & ".HashString", True, True
@@ -274,7 +276,8 @@ Public Function GetCodeModuleHash(intType As eDatabaseComponentType, strName As
Set proj = CurrentVBProject
' Attempt to locate the object in the VBComponents collection
- If DebugMode(True) Then On Error Resume Next Else On Error Resume Next
+ LogUnhandledErrors
+ On Error Resume Next
Set cmpItem = proj.VBComponents(strPrefix & strName)
Catch 9 ' Component not found. (Could be an object with no code module)
CatchAny eelError, "Error accessing VBComponent for '" & strPrefix & strName & "'", ModuleName & ".GetCodeModuleHash"
@@ -383,4 +386,7 @@ Public Function GetSimpleHash(strText As String) As String
' Return short hash
GetSimpleHash = Left(strHash, 7)
+ ' Clear any errors
+ If Err Then Err.Clear
+
End Function
diff --git a/Version Control.accda.src/modules/modImportExport.bas b/Version Control.accda.src/modules/modImportExport.bas
index 5ad113b0..cbbaa4ab 100644
--- a/Version Control.accda.src/modules/modImportExport.bas
+++ b/Version Control.accda.src/modules/modImportExport.bas
@@ -1489,7 +1489,8 @@ Public Sub InitializeForms(cContainers As Dictionary)
Dim varKey As Variant
' Trap any errors that may occur when opening forms
- If DebugMode(True) Then On Error Resume Next Else On Error Resume Next
+ LogUnhandledErrors
+ On Error Resume Next
' See if we imported any forms
For Each cont In cContainers
diff --git a/Version Control.accda.src/modules/modInstall.bas b/Version Control.accda.src/modules/modInstall.bas
index 4ad9f2f9..9008a6b4 100644
--- a/Version Control.accda.src/modules/modInstall.bas
+++ b/Version Control.accda.src/modules/modInstall.bas
@@ -115,7 +115,7 @@ Public Sub InstallVCSAddin(ByRef blnTrustFolder As Boolean, ByRef blnUseRibbon A
.blnTrustAddInFolder = blnTrustFolder
If .strInstallFolder <> strInstallFolder Then
' Attempt to migrate any saved user settings files
- MigrateUserFiles .strInstallFolder, strInstallFolder, GetFilePathsInFolder(.strInstallFolder)
+ MigrateUserFiles strInstallFolder, GetFilePathsInFolder(.strInstallFolder)
' Update install folder to new path
.strInstallFolder = strInstallFolder
End If
@@ -334,7 +334,7 @@ End Sub
' : the source file.
'---------------------------------------------------------------------------------------
'
-Private Sub MigrateUserFiles(strFromFolder As String, strToFolder As String, colNames As Dictionary)
+Private Sub MigrateUserFiles(strToFolder As String, colNames As Dictionary)
Dim varKey As Variant
Dim strFile As String
@@ -468,7 +468,8 @@ Private Sub RemoveMenuItem(ByVal strName As String, Optional Hive As eHive = ehH
strPath = GetAddinRegPath(Hive) & strName & "\"
With New IWshRuntimeLibrary.WshShell
' Just in case someone changed some of the keys...
- If DebugMode(True) Then On Error Resume Next Else On Error Resume Next
+ LogUnhandledErrors
+ On Error Resume Next
.RegDelete strPath & "Expression"
.RegDelete strPath & "Library"
.RegDelete strPath & "Version"
@@ -582,7 +583,8 @@ Private Sub RunUpgrades()
' Check for installation in HKLM hive.
strOldPath = GetAddinRegPath(ehHKLM) & "&Version Control\Library"
Set objShell = New IWshRuntimeLibrary.WshShell
- If DebugMode(True) Then On Error Resume Next Else On Error Resume Next
+ LogUnhandledErrors
+ On Error Resume Next
strTest = objShell.RegRead(strOldPath)
If Err Then Err.Clear
On Error GoTo 0
@@ -664,7 +666,8 @@ End Sub
Public Function HasLegacyRC4Keys()
Dim strValue As String
With New IWshRuntimeLibrary.WshShell
- If DebugMode(True) Then On Error Resume Next Else On Error Resume Next
+ LogUnhandledErrors
+ On Error Resume Next
strValue = .RegRead("HKCU\SOFTWARE\VB and VBA Program Settings\MSAccessVCS\Private Keys\")
HasLegacyRC4Keys = Not Catch(-2147024894)
CatchAny eelError, "Checking for legacy RC4 keys", ModuleName & ".HasLegacyRC4Keys"
@@ -827,7 +830,8 @@ Public Sub RemoveTrustedLocation(Optional strName As String)
strPath = GetTrustedLocationRegPath(strName)
With New IWshRuntimeLibrary.WshShell
- If DebugMode(True) Then On Error Resume Next Else On Error Resume Next
+ LogUnhandledErrors
+ On Error Resume Next
.RegDelete strPath & "Path"
.RegDelete strPath & "Date"
.RegDelete strPath & "Description"
@@ -1028,6 +1032,8 @@ Private Function CheckRegKey(strPath As String, ParamArray AllowedValues() As Va
End If
Next intCnt
+ If Err Then Err.Clear
+
End Function
diff --git a/Version Control.accda.src/modules/modJsonConverter.bas b/Version Control.accda.src/modules/modJsonConverter.bas
index 1fe4fba9..5dc15a3b 100644
--- a/Version Control.accda.src/modules/modJsonConverter.bas
+++ b/Version Control.accda.src/modules/modJsonConverter.bas
@@ -157,6 +157,10 @@ Private Type json_Options
' The solidus (/) is not required to be escaped, use this option to escape them as \/ in ConvertToJson
EscapeSolidus As Boolean
+ ' Before version 2.3.1 dates were converted to UTC in ConvertToJson method, but not when json was parsed.
+ ' Convert datetime values to UTC/ISO8601 (true, slower) or dont change local <-> global times (false, faster)
+ ConvertDateToIso As Boolean
+
' Allow Unicode characters in JSON text. Set to True to use native Unicode or false for escaped values.
AllowUnicodeChars As Boolean
End Type
@@ -240,11 +244,18 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp
Select Case VBA.VarType(JsonValue)
Case VBA.vbNull
ConvertToJson = "null"
+
Case VBA.vbDate
' Date
- json_DateStr = ConvertToIso(VBA.CDate(JsonValue))
-
+ If JsonOptions.ConvertDateToIso Then
+ Perf.OperationStart "Convert JSON Date to ISO"
+ json_DateStr = ConvertToIsoTime(VBA.CDate(JsonValue))
+ Perf.OperationEnd
+ Else
+ json_DateStr = VBA.CStr(JsonValue)
+ End If
ConvertToJson = """" & json_DateStr & """"
+
Case VBA.vbString
' String (or large number encoded as string)
If Not JsonOptions.UseDoubleForLargeNumbers And json_StringIsLargeNumber(JsonValue) Then
@@ -556,7 +567,9 @@ Private Function json_ParseValue(json_String As String, ByRef json_Index As Long
End Select
End Function
-Private Function json_ParseString(json_String As String, ByRef json_Index As Long) As String
+Private Function json_ParseString(ByRef json_String As String _
+ , ByRef json_Index As Long) As Variant
+
Dim json_Quote As String
Dim json_Char As String
Dim json_Code As String
@@ -609,6 +622,13 @@ Private Function json_ParseString(json_String As String, ByRef json_Index As Lon
End Select
Case json_Quote
json_ParseString = json_BufferToString(json_Buffer, json_BufferPosition)
+ If JsonOptions.ConvertDateToIso Then ' Only convert and test for condition if needed for speed boost.
+ If (json_ParseString Like "####-##-##T##:##:##*") Then
+ Perf.OperationStart "Parse JSON ISO Date"
+ json_ParseString = ParseIso(VBA.CStr$(json_ParseString)) ' Return as a date
+ Perf.OperationEnd
+ End If
+ End If
json_Index = json_Index + 1
Exit Function
Case Else
@@ -881,265 +901,7 @@ Private Function json_BufferToString(ByRef json_Buffer As String, ByVal json_Buf
End If
End Function
-''
-' VBA-UTC v1.0.6
-' (c) Tim Hall - https://github.com/VBA-tools/VBA-UtcConverter
-'
-' UTC/ISO 8601 Converter for VBA
-'
-' Errors:
-' 10011 - UTC parsing error
-' 10012 - UTC conversion error
-' 10013 - ISO 8601 parsing error
-' 10014 - ISO 8601 conversion error
-'
-' @module UtcConverter
-' @author tim.hall.engr@gmail.com
-' @license MIT (http://www.opensource.org/licenses/mit-license.php)
-'' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ '
-
-' (Declarations moved to top)
-
-' ============================================= '
-' Public Methods
-' ============================================= '
-
-''
-' Parse UTC date to local date
-'
-' @method ParseUtc
-' @param {Date} UtcDate
-' @return {Date} Local date
-' @throws 10011 - UTC parsing error
-''
-Public Function ParseUtc(utc_UtcDate As Date) As Date
- On Error GoTo utc_ErrorHandling
-
-#If Mac Then
- ParseUtc = utc_ConvertDate(utc_UtcDate)
-#Else
- Dim utc_TimeZoneInfo As utc_TIME_ZONE_INFORMATION
- Dim utc_LocalDate As utc_SYSTEMTIME
-
- utc_GetTimeZoneInformation utc_TimeZoneInfo
- utc_SystemTimeToTzSpecificLocalTime utc_TimeZoneInfo, utc_DateToSystemTime(utc_UtcDate), utc_LocalDate
-
- ParseUtc = utc_SystemTimeToDate(utc_LocalDate)
-#End If
-
- Exit Function
-
-utc_ErrorHandling:
- Err.Raise 10011, "UtcConverter.ParseUtc", "UTC parsing error: " & Err.Number & " - " & Err.Description
-End Function
-
-''
-' Convert local date to UTC date
-'
-' @method ConvertToUrc
-' @param {Date} utc_LocalDate
-' @return {Date} UTC date
-' @throws 10012 - UTC conversion error
-''
-Public Function ConvertToUtc(utc_LocalDate As Date) As Date
- On Error GoTo utc_ErrorHandling
-
-#If Mac Then
- ConvertToUtc = utc_ConvertDate(utc_LocalDate, utc_ConvertToUtc:=True)
-#Else
- Dim utc_TimeZoneInfo As utc_TIME_ZONE_INFORMATION
- Dim utc_UtcDate As utc_SYSTEMTIME
-
- utc_GetTimeZoneInformation utc_TimeZoneInfo
- utc_TzSpecificLocalTimeToSystemTime utc_TimeZoneInfo, utc_DateToSystemTime(utc_LocalDate), utc_UtcDate
-
- ConvertToUtc = utc_SystemTimeToDate(utc_UtcDate)
-#End If
-
- Exit Function
-
-utc_ErrorHandling:
- Err.Raise 10012, "UtcConverter.ConvertToUtc", "UTC conversion error: " & Err.Number & " - " & Err.Description
-End Function
-
-''
-' Parse ISO 8601 date string to local date
-'
-' @method ParseIso
-' @param {Date} utc_IsoString
-' @return {Date} Local date
-' @throws 10013 - ISO 8601 parsing error
-''
-Public Function ParseIso(utc_IsoString As String) As Date
- On Error GoTo utc_ErrorHandling
-
- Dim utc_Parts() As String
- Dim utc_DateParts() As String
- Dim utc_TimeParts() As String
- Dim utc_OffsetIndex As Long
- Dim utc_HasOffset As Boolean
- Dim utc_NegativeOffset As Boolean
- Dim utc_OffsetParts() As String
- Dim utc_Offset As Date
-
- utc_Parts = VBA.Split(utc_IsoString, "T")
- utc_DateParts = VBA.Split(utc_Parts(0), "-")
- ParseIso = VBA.DateSerial(VBA.CInt(utc_DateParts(0)), VBA.CInt(utc_DateParts(1)), VBA.CInt(utc_DateParts(2)))
-
- If UBound(utc_Parts) > 0 Then
- If VBA.InStr(utc_Parts(1), "Z") Then
- utc_TimeParts = VBA.Split(VBA.Replace(utc_Parts(1), "Z", vbNullString), ":")
- Else
- utc_OffsetIndex = VBA.InStr(1, utc_Parts(1), "+")
- If utc_OffsetIndex = 0 Then
- utc_NegativeOffset = True
- utc_OffsetIndex = VBA.InStr(1, utc_Parts(1), "-")
- End If
-
- If utc_OffsetIndex > 0 Then
- utc_HasOffset = True
- utc_TimeParts = VBA.Split(VBA.Left$(utc_Parts(1), utc_OffsetIndex - 1), ":")
- utc_OffsetParts = VBA.Split(VBA.Right$(utc_Parts(1), Len(utc_Parts(1)) - utc_OffsetIndex), ":")
-
- Select Case UBound(utc_OffsetParts)
- Case 0
- utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), 0, 0)
- Case 1
- utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), VBA.CInt(utc_OffsetParts(1)), 0)
- Case 2
- ' VBA.Val does not use regional settings, use for seconds to avoid decimal/comma issues
- utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), VBA.CInt(utc_OffsetParts(1)), Int(VBA.Val(utc_OffsetParts(2))))
- End Select
-
- If utc_NegativeOffset Then: utc_Offset = -utc_Offset
- Else
- utc_TimeParts = VBA.Split(utc_Parts(1), ":")
- End If
- End If
-
- Select Case UBound(utc_TimeParts)
- Case 0
- ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), 0, 0)
- Case 1
- ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), VBA.CInt(utc_TimeParts(1)), 0)
- Case 2
- ' VBA.Val does not use regional settings, use for seconds to avoid decimal/comma issues
- ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), VBA.CInt(utc_TimeParts(1)), Int(VBA.Val(utc_TimeParts(2))))
- End Select
-
- ParseIso = ParseUtc(ParseIso)
-
- If utc_HasOffset Then
- ParseIso = ParseIso - utc_Offset
- End If
- End If
-
- Exit Function
-
-utc_ErrorHandling:
- Err.Raise 10013, "UtcConverter.ParseIso", "ISO 8601 parsing error for " & utc_IsoString & ": " & Err.Number & " - " & Err.Description
-End Function
-
-''
-' Convert local date to ISO 8601 string
-'
-' @method ConvertToIso
-' @param {Date} utc_LocalDate
-' @return {Date} ISO 8601 string
-' @throws 10014 - ISO 8601 conversion error
-''
-Public Function ConvertToIso(utc_LocalDate As Date) As String
- On Error GoTo utc_ErrorHandling
-
- ConvertToIso = VBA.Format$(ConvertToUtc(utc_LocalDate), "yyyy-mm-ddTHH:mm:ss.000Z")
-
- Exit Function
-
-utc_ErrorHandling:
- Err.Raise 10014, "UtcConverter.ConvertToIso", "ISO 8601 conversion error: " & Err.Number & " - " & Err.Description
-End Function
-
-' ============================================= '
-' Private Functions
-' ============================================= '
-
-#If Mac Then
-
-Private Function utc_ConvertDate(utc_Value As Date, Optional utc_ConvertToUtc As Boolean = False) As Date
- Dim utc_ShellCommand As String
- Dim utc_Result As utc_ShellResult
- Dim utc_Parts() As String
- Dim utc_DateParts() As String
- Dim utc_TimeParts() As String
-
- If utc_ConvertToUtc Then
- utc_ShellCommand = "date -ur `date -jf '%Y-%m-%d %H:%M:%S' " & _
- "'" & VBA.Format$(utc_Value, "yyyy-mm-dd HH:mm:ss") & "' " & _
- " +'%s'` +'%Y-%m-%d %H:%M:%S'"
- Else
- utc_ShellCommand = "date -jf '%Y-%m-%d %H:%M:%S %z' " & _
- "'" & VBA.Format$(utc_Value, "yyyy-mm-dd HH:mm:ss") & " +0000' " & _
- "+'%Y-%m-%d %H:%M:%S'"
- End If
-
- utc_Result = utc_ExecuteInShell(utc_ShellCommand)
-
- If utc_Result.utc_Output = "" Then
- Err.Raise 10015, "UtcConverter.utc_ConvertDate", "'date' command failed"
- Else
- utc_Parts = Split(utc_Result.utc_Output, " ")
- utc_DateParts = Split(utc_Parts(0), "-")
- utc_TimeParts = Split(utc_Parts(1), ":")
-
- utc_ConvertDate = DateSerial(utc_DateParts(0), utc_DateParts(1), utc_DateParts(2)) + _
- TimeSerial(utc_TimeParts(0), utc_TimeParts(1), utc_TimeParts(2))
- End If
-End Function
-
-Private Function utc_ExecuteInShell(utc_ShellCommand As String) As utc_ShellResult
-#If VBA7 Then
- Dim utc_File As LongPtr
- Dim utc_Read As LongPtr
-#Else
- Dim utc_File As Long
- Dim utc_Read As Long
-#End If
-
- Dim utc_Chunk As String
- On Error GoTo utc_ErrorHandling
- utc_File = utc_popen(utc_ShellCommand, "r")
-
- If utc_File = 0 Then: Exit Function
-
- Do While utc_feof(utc_File) = 0
- utc_Chunk = VBA.Space$(50)
- utc_Read = CLng(utc_fread(utc_Chunk, 1, Len(utc_Chunk) - 1, utc_File))
- If utc_Read > 0 Then
- utc_Chunk = VBA.Left$(utc_Chunk, CLng(utc_Read))
- utc_ExecuteInShell.utc_Output = utc_ExecuteInShell.utc_Output & utc_Chunk
- End If
- Loop
-
-utc_ErrorHandling:
- utc_ExecuteInShell.utc_ExitCode = CLng(utc_pclose(utc_File))
+Private Function ConvertToIso(utc_LocalDate As Date) As String
+ ConvertToIso = ConvertToUTCISO8601TimeStamp(utc_LocalDate)
End Function
-
-#Else
-
-Private Function utc_DateToSystemTime(utc_Value As Date) As utc_SYSTEMTIME
- utc_DateToSystemTime.utc_wYear = VBA.Year(utc_Value)
- utc_DateToSystemTime.utc_wMonth = VBA.Month(utc_Value)
- utc_DateToSystemTime.utc_wDay = VBA.Day(utc_Value)
- utc_DateToSystemTime.utc_wHour = VBA.Hour(utc_Value)
- utc_DateToSystemTime.utc_wMinute = VBA.Minute(utc_Value)
- utc_DateToSystemTime.utc_wSecond = VBA.Second(utc_Value)
- utc_DateToSystemTime.utc_wMilliseconds = 0
-End Function
-
-Private Function utc_SystemTimeToDate(utc_Value As utc_SYSTEMTIME) As Date
- utc_SystemTimeToDate = DateSerial(utc_Value.utc_wYear, utc_Value.utc_wMonth, utc_Value.utc_wDay) + _
- TimeSerial(utc_Value.utc_wHour, utc_Value.utc_wMinute, utc_Value.utc_wSecond)
-End Function
-
-#End If
diff --git a/Version Control.accda.src/modules/modOrphaned.bas b/Version Control.accda.src/modules/modOrphaned.bas
index cbad9677..5b04f387 100644
--- a/Version Control.accda.src/modules/modOrphaned.bas
+++ b/Version Control.accda.src/modules/modOrphaned.bas
@@ -279,4 +279,7 @@ Public Sub RemoveOrphanedDatabaseObjects(cCategory As IDbComponent)
End If
Next varKey
+ ' Handle any uncaught errors
+ CatchAny eelError, "Error removing orphaned objects.", ModuleName & ".RemoveOrphanedDatabaseObjects"
+
End Sub
diff --git a/Version Control.accda.src/modules/modUIAutomation.bas b/Version Control.accda.src/modules/modUIAutomation.bas
index 6c5990ef..7b07c492 100644
--- a/Version Control.accda.src/modules/modUIAutomation.bas
+++ b/Version Control.accda.src/modules/modUIAutomation.bas
@@ -73,7 +73,8 @@ Private Function GetUnderlyingDbObjectFromButton(oClient As CUIAutomation, oElem
strImage = GetImageName(oClient, oElement)
' Just in case something doesn't work right...
- If DebugMode(True) Then On Error Resume Next Else On Error Resume Next
+ LogUnhandledErrors
+ On Error Resume Next
' There are multiple icons for some objects
If LikeAny(strImage, "Table*", "*Tabelle") Then
diff --git a/Version Control.accda.src/modules/modUtcConverter.bas b/Version Control.accda.src/modules/modUtcConverter.bas
index fa996bb5..2e45c59e 100644
--- a/Version Control.accda.src/modules/modUtcConverter.bas
+++ b/Version Control.accda.src/modules/modUtcConverter.bas
@@ -297,14 +297,43 @@ utc_ErrorHandling:
Err.Raise 10012, "UtcConverter.ConvertToUtc", "UTC conversion error: " & Err.Number & " - " & Err.Description
End Function
+
+Public Function TimeStampDate(Optional LocalTimeStamp As Boolean = False) As Date
+
+ Dim TimeStampOut As Date
+
+#If Mac Then
+ ' I'm sure there's a way to do this better, but this works for now.
+ TimeStampOut = ConvertToUtc(VBA.Now())
+ If Not LocalTimeStamp Then TimeStampOut = ConvertToUtc(TimeStampOut)
+
+#Else
+ Dim tSysTime As utc_SYSTEMTIME
+
+ If Not LocalTimeStamp Then
+ GetSystemTime tSysTime
+ TimeStampOut = utc_SystemTimeToDate(tSysTime)
+
+ Else
+ GetLocalTime tSysTime
+ TimeStampOut = utc_SystemTimeToDate(tSysTime)
+ End If
+#End If
+
+ TimeStampDate = TimeStampOut
+
+End Function
+
+
' NOTE: As of now, "LocalTimeStamp" does nothing on a Mac; need to build "getTimeZoneOffset" for Mac, and I don't have one.
' It will, however, output a UTC string that is correct for local time (eg, in the correct UTC for the given local time)
' I also don't know how to get millisecond values out of a Mac, so that'll return zero, as well.
Public Function ISO8601TimeStamp(Optional IncludeMilliseconds As Boolean = True _
, Optional LocalTimeStamp As Boolean = False) As String
- Dim CurrentTimeVB As Date
+ Dim CurrentTimeVB As Date
Dim tString_Buffer As StringBufferCache
+
' Note: This varies slightly from ConvertToISO8601Time because it's faster to do on Windows if you have SYSTEMTIME
#If Mac Then
' I'm sure there's a way to do this better, but this works for now.
@@ -534,18 +563,38 @@ Public Function ConvertToISO8601Time(ByVal DateIn As Date _
End If
ConvertToISO8601Time = String_BufferToString(tString_Buffer)
+
End Function
' Provides a format string to other functions that complies with ISO8601
-Private Function ISOTimeFormatStr(Optional IncludeMilliseconds As Boolean = False _
- , Optional includeTimeZone As Boolean = False) As String
- Dim tString_Buffer As StringBufferCache
+Public Function ISOTimeFormatStr(Optional ByVal IncludeMilliseconds As Boolean = False _
+ , Optional ByVal IncludeTimeZonePart As Boolean = False _
+ , Optional ByVal IncludeLocalTimeZone As Boolean = False) As String
+
+ Static f_dFormatString As Scripting.Dictionary
+
+ Dim DictPosition As Long
+
+ If f_dFormatString Is Nothing Then Set f_dFormatString = New Scripting.Dictionary
+
+ DictPosition = (4 And IncludeMilliseconds) + (2 And IncludeTimeZonePart) + (1 And IncludeLocalTimeZone)
+
+ If Not f_dFormatString.Exists(DictPosition) Then
+ With New clsConcat
+ .Add "yyyy-mm-ddTHH:mm:ss"
+ If IncludeMilliseconds Then .Add ".000"
+ If IncludeTimeZonePart And IncludeLocalTimeZone Then
+ .Add CurrentISOTimezoneOffset
+ ElseIf IncludeTimeZonePart Then
+ .Add ISO8601UTCTimeZone
+ End If
+ f_dFormatString.Add DictPosition, .GetStr
+ End With
+ End If
+
+ ISOTimeFormatStr = f_dFormatString.Item(DictPosition)
- String_BufferAppend tString_Buffer, "yyyy-mm-ddTHH:mm:ss"
- If IncludeMilliseconds Then String_BufferAppend tString_Buffer, ".000"
- If includeTimeZone Then String_BufferAppend tString_Buffer, ISOTimezoneOffset
- ISOTimeFormatStr = String_BufferToString(tString_Buffer)
End Function
@@ -615,6 +664,7 @@ Private Function utc_ConvertDate(utc_Value As Double _
End If
End Function
+
Private Function utc_ExecuteInShell(utc_ShellCommand As String) As utc_ShellResult
#If VBA7 Then
' 64bit Mac
@@ -648,8 +698,10 @@ End Function
#Else
' Windows
+
' Pass in a date, this will return a Windows SystemTime structure with millisecond accuracy.
Private Function utc_DateToSystemTime(ByRef utc_Value As Date) As utc_SYSTEMTIME ' "Helper Functions
+
With utc_DateToSystemTime
.utc_wYear = VBA.Year(utc_Value)
.utc_wMonth = VBA.Month(utc_Value)
@@ -663,10 +715,13 @@ Private Function utc_DateToSystemTime(ByRef utc_Value As Date) As utc_SYSTEMTIME
.utc_wSecond = VBA.Second(utc_Value)
End If
End With
+
End Function
-Private Function utc_SystemTimeToDate(ByRef utc_Value As utc_SYSTEMTIME) As Date ' "Helper Function" for Public Functions (below)
+Private Function utc_SystemTimeToDate(ByRef utc_Value As utc_SYSTEMTIME) As Date
+' "Helper Function" for Public Functions (below)
+
utc_SystemTimeToDate = DateSerial(utc_Value.utc_wYear _
, utc_Value.utc_wMonth _
, utc_Value.utc_wDay) + _
@@ -674,15 +729,39 @@ Private Function utc_SystemTimeToDate(ByRef utc_Value As utc_SYSTEMTIME) As Date
, utc_Value.utc_wMinute _
, utc_Value.utc_wSecond _
, utc_Value.utc_wMilliseconds)
+
+End Function
+
+
+'---------------------------------------------------------------------------------------
+' Procedure : ConvDateUTC2
+' Author : Adam Waller
+' Date : 11/14/2023
+' Purpose : Attempt a higher performance conversion first, then fall back to RegEx.
+'---------------------------------------------------------------------------------------
+'
+Private Function ConvDateUTC(ByRef InVal As String) As Date
+
+ Dim varParts As Variant
+
+ If InVal Like "####-##-##" Then
+ ' Use high-performance conversion to date
+ varParts = Split(InVal, "-")
+ ConvDateUTC = DateSerial(varParts(0), varParts(1), varParts(2))
+ Else
+ ' Fall back to slower RegEx function
+ ConvDateUTC = ConvDateUTC2(InVal)
+ End If
+
End Function
-Private Function ConvDateUTC(ByVal InVal As String) As Date
+Private Function ConvDateUTC2(ByRef InVal As String) As Date
+
Dim RetVal As Variant
+ Dim RegEx As New RegExp ' Object
-' Dim RegEx As Object
' Set RegEx = CreateObject("VBScript.RegExp")
- Dim RegEx As New RegExp
With RegEx
.Global = True
.Multiline = True
@@ -721,16 +800,42 @@ Private Function ConvDateUTC(ByVal InVal As String) As Date
End If
End With
- ConvDateUTC = RetVal
+ ConvDateUTC2 = RetVal
+
End Function
+
+'---------------------------------------------------------------------------------------
+' Procedure : ConvTimeUTC2
+' Author : Adam Waller
+' Date : 11/14/2023
+' Purpose : Attempt a higher performance conversion first, then fall back to RegEx.
+'---------------------------------------------------------------------------------------
+'
Private Function ConvTimeUTC(ByRef InVal As String) As Date
+ Dim varParts As Variant
+ Dim InValSeconds As String
+
+ If InVal Like "##:##:##.###Z" Then
+ ' Use high-performance conversion to date
+ varParts = Split(InVal, ":")
+ InValSeconds = Mid(varParts(2), 1, Len(varParts(2)) - 1)
+ ConvTimeUTC = TimeSerialDbl(varParts(0), varParts(1), InValSeconds)
+ Else
+ ' Fall back to slower RegEx function
+ ConvTimeUTC = ConvTimeUTC2(InVal)
+ End If
+
+End Function
+
+
+Private Function ConvTimeUTC2(ByRef InVal As String) As Date
+
Dim dblHours As Double
Dim dblMinutes As Double
Dim dblSeconds As Double
Dim dblMilliseconds As Double
-
Dim RegEx As New RegExp ' Object
'Set RegEx = CreateObject("VBScript.RegExp")
@@ -764,10 +869,11 @@ Private Function ConvTimeUTC(ByRef InVal As String) As Date
dblSeconds = CDbl(NzEmpty(.SubMatches(2), vbNullString))
End With
- ConvTimeUTC = TimeSerialDbl(dblHours, dblMinutes, dblSeconds)
+ ConvTimeUTC2 = TimeSerialDbl(dblHours, dblMinutes, dblSeconds)
End Function
+
Private Function NzEmpty(ByVal Value As Variant, Optional ByVal value_when_null As Variant = 0) As Variant
Dim return_value As Variant
@@ -793,9 +899,11 @@ Public Function TimeSerialDbl(ByVal HoursIn As Double _
, ByVal MinutesIn As Double _
, ByVal SecondsIn As Double _
, Optional ByVal MillisecondsIn As Double = 0) As Double
+
Dim tMS As Double
Dim tSec As Double
Dim tSecTemp As Double
+
tSec = VBA.CDbl(RoundDown(SecondsIn))
tSecTemp = SecondsIn - tSec
tMS = (tSecTemp * (TotalMillisecondsInDay / TotalSecondsInDay)) \ 1
@@ -803,10 +911,13 @@ Public Function TimeSerialDbl(ByVal HoursIn As Double _
If (tSecTemp > 0.5) Then tSec = tSec - 1
If tMS = 500 Then tMS = tMS - 0.001 ' Shave a hair, because otherwise it'll round up too much.
TimeSerialDbl = (HoursIn / TotalHoursInDay) + (MinutesIn / TotalMinutesInDay) + CDbl((tSec / TotalSecondsInDay)) + (tMS / TotalMillisecondsInDay)
+
End Function
+
' If given a time double, will return the millisecond portion of the time.
-Private Function GetMilliseconds(ByVal TimeIn As Double) As Variant
+Private Function GetMilliseconds(ByRef TimeIn As Date) As Variant
+
Dim IntDatePart As Long
Dim DblTimePart As Double
Dim LngSeconds As Long ' Used to remove whole seconds.
@@ -828,6 +939,7 @@ Private Function GetMilliseconds(ByVal TimeIn As Double) As Variant
MSCount = ((DblMS * (TotalMillisecondsInDay))) \ 1
If MSCount >= 1000 Then MSCount = 0
GetMilliseconds = MSCount
+
End Function
@@ -863,13 +975,15 @@ Public Function CurrentLocalBiasFromUTC(Optional ByVal OutputAsHours As Boolean
End Function
+
Public Function CurrentISOTimezoneOffset() As String
CurrentISOTimezoneOffset = ISOTimezoneOffset(CurrentLocalBiasFromUTC)
End Function
-Public Function GetBiasForGivenLocalDate(ByVal LocalDateIn As Date _
+Public Function GetBiasForGivenLocalDate(ByRef LocalDateIn As Date _
, Optional ByVal OutputAsHours As Boolean = False) As Long
+
Dim DateUTCNow As Date
DateUTCNow = ConvertToUtc(LocalDateIn)
@@ -882,40 +996,44 @@ Public Function GetBiasForGivenLocalDate(ByVal LocalDateIn As Date _
Else
GetBiasForGivenLocalDate = VBA.DateDiff("h", LocalDateIn, DateUTCNow)
End If
+
End Function
+
Public Function ISOTimezoneOffsetOnDate(ByVal LocalDateIn As Date) As String
ISOTimezoneOffsetOnDate = ISOTimezoneOffset(GetBiasForGivenLocalDate(LocalDateIn))
End Function
' Provides the ISO Offset time from an input (or current offset if none is passed in) to build an ISO8601 output String
+'
Private Function ISOTimezoneOffset(Optional TimeBias As Long = 0) As String
- Dim strOffsetOut As String
-
- Dim tString_Buffer As StringBufferCache
-
Dim OffsetLong As Long
Dim hourOffset As Long
Dim minOffset As Long
- ' Counterintuitively, the Bias is postive (time ahead), the offset is the negative value of bias.
- OffsetLong = TimeBias * -1
-
- hourOffset = OffsetLong \ 60
- minOffset = OffsetLong Mod 60
+ If TimeBias = 0 Then
- If OffsetLong = 0 Then
ISOTimezoneOffset = ISO8601UTCTimeZone
- Else
- If OffsetLong > 0 Then String_BufferAppend tString_Buffer, "+"
- String_BufferAppend tString_Buffer, VBA.CStr(VBA.Format(hourOffset, "00"))
- String_BufferAppend tString_Buffer, ISO8601TimeDelimiter
- String_BufferAppend tString_Buffer, VBA.CStr(VBA.Format(minOffset, "00"))
- ISOTimezoneOffset = String_BufferToString(tString_Buffer)
+ Else
+ ' Counterintuitively, the Bias is postive (time ahead),
+ ' and the offset is the negative value of bias.
+ OffsetLong = TimeBias * -1
+ hourOffset = OffsetLong \ 60
+ minOffset = OffsetLong Mod 60
+
+ With New clsConcat
+ If OffsetLong > 0 Then .Add "+"
+ .Add VBA.CStr(VBA.Format(hourOffset, "00"))
+ .Add ISO8601TimeDelimiter
+ .Add VBA.CStr(VBA.Format(minOffset, "00"))
+
+ ISOTimezoneOffset = .GetStr
+ End With
End If
+
End Function
diff --git a/Version Control.accda.src/modules/modVCSUtility.bas b/Version Control.accda.src/modules/modVCSUtility.bas
index 40c424b9..700c507d 100644
--- a/Version Control.accda.src/modules/modVCSUtility.bas
+++ b/Version Control.accda.src/modules/modVCSUtility.bas
@@ -409,8 +409,11 @@ Public Function SaveComponentAsText(intType As AcObjectType, _
Optional cDbObjectClass As IDbComponent = Nothing) As String
Dim strTempFile As String
+ Dim strAltFile As String
+ Dim strContent As String
Dim strPrintSettingsFile As String
Dim strHash As String
+ Dim cParser As clsSourceParser
On Error GoTo ErrHandler
@@ -421,16 +424,25 @@ Public Function SaveComponentAsText(intType As AcObjectType, _
Perf.OperationEnd
VerifyPath strFile
+ ' Delete any existing source file
+ If FSO.FileExists(strFile) Then DeleteFile strFile
+
' Sanitize certain object types
+ Set cParser = New clsSourceParser
Select Case intType
Case acForm, acReport
+
+ ' Load content from file
+ strContent = ReadSourceFile(strTempFile)
+
+ ' Process any saved devmode settings
With New clsDevMode
' Build print settings file name.
- strPrintSettingsFile = .GetPrintSettingsFileName(cDbObjectClass)
+ strPrintSettingsFile = SwapExtension(strFile, "json")
' See if we are exporting print vars.
If Options.SavePrintVars = True Then
' Grab the printer settings before sanitizing the file.
- .LoadFromExportFile strTempFile
+ .LoadFromExportFile strContent
' Only need to save print settings if they are different
' from the default printer settings.
If (.GetHash <> VCSIndex.DefaultDevModeHash) And .HasData Then
@@ -445,25 +457,44 @@ Public Function SaveComponentAsText(intType As AcObjectType, _
If FSO.FileExists(strPrintSettingsFile) Then DeleteFile strPrintSettingsFile
End If
End With
+
' Sanitizing converts to UTF-8
- If FSO.FileExists(strFile) Then DeleteFile strFile
- strHash = SanitizeFile(strTempFile, True)
- FSO.MoveFile strTempFile, strFile
+ With cParser
+ .LoadString strContent
+ .ObjectName = FSO.GetBaseName(strFile)
+ WriteFile .Sanitize(ectObjectDefinition), strFile
+ strHash = .Hash
+
+ ' Process any VBA
+ strAltFile = SwapExtension(strFile, "cls")
+ If Options.SplitLayoutFromVBA And Len(.GetObjectVBA) Then
+ ' Write VBA code as separate .cls file.
+ WriteFile .GetObjectVBA, strAltFile
+ Else
+ ' Remove any split VBA file
+ If FSO.FileExists(strAltFile) Then DeleteFile strAltFile
+ End If
+ End With
Case acQuery, acMacro
' Sanitizing converts to UTF-8
- If FSO.FileExists(strFile) Then DeleteFile strFile
- strHash = SanitizeFile(strTempFile, True)
- FSO.MoveFile strTempFile, strFile
+ With cParser
+ .LoadSourceFile strTempFile
+ WriteFile .Sanitize(ectObjectDefinition), strFile
+ strHash = .Hash
+ End With
' Case acModule - Use VBE export instead.
Case acTableDataMacro
' Table data macros are stored in XML format
+ ' The file may not exist if no TD Macro was found
If FSO.FileExists(strTempFile) Then
- strHash = SanitizeXML(strTempFile, True)
- If FSO.FileExists(strFile) Then DeleteFile strFile
- FSO.MoveFile strTempFile, strFile
+ With cParser
+ .LoadSourceFile strTempFile
+ WriteFile .Sanitize(ectXML), strFile
+ strHash = .Hash
+ End With
End If
Case Else
@@ -472,6 +503,9 @@ Public Function SaveComponentAsText(intType As AcObjectType, _
End Select
+ ' Remove any leftover temp file.
+ If FSO.FileExists(strTempFile) Then DeleteFile strTempFile
+
' Normal exit
On Error GoTo 0
@@ -498,41 +532,50 @@ End Function
' Purpose : Load the object into the database from the saved source file.
'---------------------------------------------------------------------------------------
'
-Public Sub LoadComponentFromText(intType As AcObjectType, _
- strName As String, _
- strFile As String, _
- Optional cDbObjectClass As IDbComponent = Nothing)
+Public Sub LoadComponentFromText(intType As AcObjectType, strName As String, strFile As String)
Dim strTempFile As String
- Dim strPrintSettingsFile As String
Dim strSourceFile As String
+ Dim strAltFile As String
+ Dim strContent As String
+ Dim blnVbaOverlay As Boolean
Dim blnConvert As Boolean
- Dim dFile As Dictionary
- ' The path to the source file may change if we add print settings.
+ ' In most cases we are importing/converting the actual source file.
strSourceFile = strFile
- ' Add DevMode structures back into forms/reports
+ ' Add DevMode structures and VBA code back into forms/reports
Select Case intType
Case acForm, acReport
- 'Insert print settings (if needed)
- If Not (cDbObjectClass Is Nothing) Then
- With New clsDevMode
- ' Manually build the print settings file path since we don't have
- ' a database object we can use with the clsDevMode.GetPrintSettingsFileName
- strPrintSettingsFile = cDbObjectClass.BaseFolder & GetSafeFileName(strName) & ".json"
- Set dFile = ReadJsonFile(strPrintSettingsFile)
- ' Check to ensure dictionary was loaded
- If Not (dFile Is Nothing) Then
- ' Insert DevMode structures into file before importing.
- ' Load default printer settings, then overlay
- ' settings saved with report.
- .ApplySettings dFile("Items")
- ' Insert the settings into a combined export file.
- strSourceFile = .AddToExportFile(strFile)
- End If
- End With
- End If
+
+ ' Read file content. (Should be UTF-8)
+ strContent = ReadFile(strFile)
+ With New clsSourceParser
+ .LoadString strContent
+
+ ' Check for print settings file
+ strAltFile = SwapExtension(strFile, "json")
+ If FSO.FileExists(strAltFile) Then
+ ' Merge the print settings into the source file content
+ .MergePrintSettings ReadFile(strAltFile)
+ End If
+
+ ' For forms and reports, check for VBA code file that needs to be merged
+ strAltFile = SwapExtension(strFile, "cls")
+ If FSO.FileExists(strAltFile) Then
+ ' Found a companion class file.
+ .MergeVBA ReadFile(strAltFile)
+ blnVbaOverlay = RequiresOverlay(.GetObjectVBA)
+ End If
+
+ ' Write ouput to a new file if anything has changed
+ If .OutputModified Then
+ strSourceFile = GetTempFile
+ WriteFile .GetOutput, strSourceFile
+ End If
+
+ End With
+
End Select
' Check UCS-2-LE requirement for the current database.
@@ -568,12 +611,119 @@ Public Sub LoadComponentFromText(intType As AcObjectType, _
Perf.OperationEnd
End If
- ' Remove any temporary combined source file
- If strSourceFile <> strFile Then DeleteFile strSourceFile
+ ' Clean up any additional temp file used in the building process
+ If strFile <> strSourceFile Then
+ If FSO.FileExists(strSourceFile) Then DeleteFile strSourceFile
+ End If
+
+ ' Check for VBA overlay
+ If blnVbaOverlay Then OverlayCodeModule strName, SwapExtension(strFile, "cls")
End Sub
+'---------------------------------------------------------------------------------------
+' Procedure : ExportVbComponent
+' Author : Adam Waller
+' Date : 5/26/2021
+' Purpose : Export the code module VB component and convert to UTF-8
+'---------------------------------------------------------------------------------------
+'
+Public Sub ExportCodeModule(strName As String, strFile As String)
+
+ Dim strTempFile As String
+ Dim strContent As String
+
+ Perf.OperationStart "Export VBE Module"
+
+ ' Export to a temp file so we can convert to UTF-8 encoding
+ strTempFile = GetTempFile
+ CurrentVBProject.VBComponents(strName).Export strTempFile
+
+ ' Sanitize the VBA code while reading the temp file
+ With New clsSourceParser
+ .LoadString ReadFile(strTempFile, GetSystemEncoding)
+ strContent = .Sanitize(ectVBA)
+ End With
+
+ ' Write the content as UTF-8 to the final destination
+ WriteFile strContent, strFile
+ DeleteFile strTempFile
+
+ Perf.OperationEnd
+
+End Sub
+
+
+'---------------------------------------------------------------------------------------
+' Procedure : OverlayCodeModule
+' Author : Adam Waller
+' Date : 10/24/2023
+' Purpose : Overlay VBA code from an object's *.cls file to the form or report
+' : Note that this opens the object in design view, which may slow the build
+' : process if a large number of items are invovled.
+'---------------------------------------------------------------------------------------
+'
+Public Sub OverlayCodeModule(strName As String, strClassFile As String)
+
+ Dim objModule As VBIDE.CodeModule
+ Dim strContent As String
+ Dim intType As AcObjectType
+ Dim strShortName As String
+ Dim cParser As clsSourceParser
+
+ LogUnhandledErrors
+ 'On Error Resume Next
+ Set objModule = CurrentVBProject.VBComponents(strName).CodeModule
+ If CatchAny(eelError, "Could not find code module for " & strName, ModuleName & ".OverlayCodeModule") Then Exit Sub
+
+ ' Read class file content
+ strContent = ReadFile(strClassFile)
+ If strContent = vbNullString Then
+ Log.Error eelError, "Unable to read " & strClassFile, ModuleName & ".OverlayCodeModule"
+ Exit Sub
+ End If
+
+ ' Get object type and short name
+ If strName Like "Form_*" Then
+ intType = acForm
+ strShortName = Mid$(strName, 6)
+ DoCmd.OpenForm strShortName, acDesign, , , , acHidden
+ ElseIf strName Like "Report_*" Then
+ intType = acReport
+ strShortName = Mid$(strName, 8)
+ DoCmd.OpenReport strShortName, acViewDesign, , , acHidden
+ End If
+
+ ' Overlay the VBA code, replacing any existing code.
+ Set cParser = New clsSourceParser
+ objModule.DeleteLines 1, objModule.CountOfLines
+ objModule.AddFromString cParser.StripClassHeader(strContent, False)
+
+ ' Close any form or report object
+ Select Case intType
+ Case acForm, acReport
+ DoCmd.Close intType, strShortName, acSaveYes
+ End Select
+
+End Sub
+
+
+'---------------------------------------------------------------------------------------
+' Procedure : RequiresOverlay
+' Author : Adam Waller
+' Date : 11/2/2023
+' Purpose : Returns true if we need to overlay the VBA code through VBE for a form
+' : or report object.
+'---------------------------------------------------------------------------------------
+'
+Private Function RequiresOverlay(strVbaCode As String) As Boolean
+ If modEncoding.GetSystemEncoding(True) = "utf-8" Then
+ RequiresOverlay = StringHasExtendedASCII(strVbaCode)
+ End If
+End Function
+
+
'---------------------------------------------------------------------------------------
' Procedure : RemoveNonBuiltInReferences
' Author : Adam Waller
@@ -773,8 +923,10 @@ End Function
Public Sub LoadVCSAddIn()
' The following lines will load the add-in at the application level,
' but will not actually call the function. Ignore the error of function not found.
- If DebugMode(True) Then On Error Resume Next Else On Error Resume Next
+ LogUnhandledErrors
+ On Error Resume Next
Application.Run GetAddInFileName & "!DummyFunction"
+ If Err Then Err.Clear
End Sub
@@ -786,6 +938,7 @@ End Sub
' : it contains a .gitignore and .gitattributes file. If it doesn't, then
' : the default files are extracted and added to the project, and the user
' : notified that these have been added.
+' : Checks both the export folder and the current folder.
'---------------------------------------------------------------------------------------
'
Public Sub CheckGitFiles()
@@ -794,36 +947,43 @@ Public Sub CheckGitFiles()
Dim strFile As String
Dim blnAdded As Boolean
- strPath = CurrentProject.Path & PathSep
- If FSO.FolderExists(strPath & ".git") Then
-
- ' gitignore file
- strFile = strPath & ".gitignore"
- If Not FSO.FileExists(strFile) Then
- ExtractResource "Default .gitignore", strPath
- Name strFile & ".default" As strFile
- Log.Add "Added default .gitignore file", , , "blue"
- blnAdded = True
- End If
-
- ' gitattributes file
- strFile = strPath & ".gitattributes"
- If Not FSO.FileExists(strFile) Then
- ExtractResource "Default .gitattributes", strPath
- Name strFile & ".default" As strFile
- Log.Add "Added default .gitattributes file", , , "blue"
- blnAdded = True
+ ' Check export folder
+ strPath = Options.GetExportFolder
+ If Not FSO.FolderExists(strPath & ".git") Then
+ ' Check current folder for repository root
+ ' (This would be the default usage)
+ strPath = CurrentProject.Path & PathSep
+ If Not FSO.FolderExists(strPath & ".git") Then
+ ' No git folder found.
+ Exit Sub
End If
+ End If
- ' Notify user
- If blnAdded Then MsgBox2 "Added Default Git File(s)", _
- "Added a default .gitignore and/or .gitattributes file to your project.", _
- "By default these files exclude the binary database files from version control," & vbCrLf & _
- "allowing you to track changes at the source file level." & vbCrLf & vbCrLf & _
- "You may wish to customize these further for your environment.", vbInformation
+ ' gitignore file
+ strFile = strPath & ".gitignore"
+ If Not FSO.FileExists(strFile) Then
+ ExtractResource "Default .gitignore", strPath
+ Name strFile & ".default" As strFile
+ Log.Add "Added default .gitignore file", , , "blue"
+ blnAdded = True
+ End If
+ ' gitattributes file
+ strFile = strPath & ".gitattributes"
+ If Not FSO.FileExists(strFile) Then
+ ExtractResource "Default .gitattributes", strPath
+ Name strFile & ".default" As strFile
+ Log.Add "Added default .gitattributes file", , , "blue"
+ blnAdded = True
End If
+ ' Notify user
+ If blnAdded Then MsgBox2 "Added Default Git File(s)", _
+ "Added a default .gitignore and/or .gitattributes file to your project.", _
+ "By default these files exclude the binary database files from version control," & vbCrLf & _
+ "allowing you to track changes at the source file level." & vbCrLf & vbCrLf & _
+ "You may wish to customize these further for your environment.", vbInformation
+
End Sub
@@ -958,3 +1118,39 @@ Public Function PassesSchemaFilter(strItem As String, varFilterArray As Variant)
PassesSchemaFilter = blnPass
End Function
+
+
+'---------------------------------------------------------------------------------------
+' Procedure : ReadSourceFile
+' Author : Adam Waller
+' Date : 11/8/2023
+' Purpose : Load source file content into a string. (Considers BOM and file type)
+'---------------------------------------------------------------------------------------
+'
+Public Function ReadSourceFile(strPath As String) As String
+
+ Dim strTempFile As String
+
+ ' Read text from file, and split into lines
+ If HasUcs2Bom(strPath) Then
+ ReadSourceFile = ReadFile(strPath, "Unicode")
+ Else
+ ' ADP projects may contain mixed Unicode content
+ If CurrentProject.ProjectType = acADP Then
+ strTempFile = GetTempFile
+ ConvertUcs2Utf8 strPath, strTempFile, False
+ ReadSourceFile = ReadFile(strTempFile)
+ DeleteFile strTempFile
+ Else
+ If DbVersion <= 4 Then
+ ' Access 2000 format exports using system codepage
+ ' See issue #217
+ ReadSourceFile = ReadFile(strPath, GetSystemEncoding)
+ Else
+ ' Newer versions export as UTF-8
+ ReadSourceFile = ReadFile(strPath)
+ End If
+ End If
+ End If
+
+End Function
diff --git a/Version Control.accda.src/modules/modVbeForm.bas b/Version Control.accda.src/modules/modVbeForm.bas
index 44e53636..fbba0dd9 100644
--- a/Version Control.accda.src/modules/modVbeForm.bas
+++ b/Version Control.accda.src/modules/modVbeForm.bas
@@ -144,6 +144,7 @@ Private Sub AddProperty(dic As Dictionary, o As Object, strName As Variant)
' Use CallByName on object to get value if the property exists
On Error Resume Next
dic.Add strName, CallByName(o, strName, VbGet)
+ If Err Then Err.Clear
End Select
End Sub
diff --git a/Version Control.accda.src/vcs-options.json b/Version Control.accda.src/vcs-options.json
index 7e3f5716..f1a2424a 100644
--- a/Version Control.accda.src/vcs-options.json
+++ b/Version Control.accda.src/vcs-options.json
@@ -1,6 +1,6 @@
{
"Info": {
- "AddinVersion": "4.0.22",
+ "AddinVersion": "4.0.28",
"AccessVersion": "14.0 32-bit"
},
"Options": {
@@ -36,6 +36,7 @@
"FormatSQL": true,
"ForceImportOriginalQuerySQL": false,
"SaveTableSQL": true,
+ "SplitLayoutFromVBA": false,
"StripPublishOption": true,
"SanitizeColors": 3,
"SanitizeLevel": 2,
diff --git a/Wiki/Split-Files.md b/Wiki/Split-Files.md
new file mode 100644
index 00000000..211085d1
--- /dev/null
+++ b/Wiki/Split-Files.md
@@ -0,0 +1,29 @@
+One of the challenges with the .git system is that when a single file is split into two different files the line history *might* follow one of the files, but not both. You loose the line history in one or both files.
+
+That might be a serious problem if you have years of history that you are wanting to preserve. Thankfully, there is a [technical workaround](https://devblogs.microsoft.com/oldnewthing/20190919-00/?p=102904) that does allow you to preserve the history in both files.
+
+# Please Read Before Splitting Files in Existing .git Projects
+
+You can turn on the option and simply perform an export to split the files, **but if you want to preserve the .git history in both files**, please read this section carefully. This add-in includes a utility to help you split the files while retaining the line history in both files. Because this involves **committing** to the repository as part of the process, I want to clarify exactly how this works.
+
+# How This Works
+
+Because this isn't a built-in feature in .git, we need to implement a bit of a clever workaround as documented by Raymond Chen in [this article](https://devblogs.microsoft.com/oldnewthing/20190919-00/?p=102904). In a nutshell, we will create a (temporary) new branch in git, rename the file in the new branch, restore the original file, then merge the new branch back into the original. This will result in two files that both carry the history of the original file.
+
+# Before You Start
+
+You will need to run this process from a **clean branch**. If you have any outstanding changes, please commit or discard them before splitting files. Be aware that this will create **two additional commits** in your repository, so it can be helpful to do this for batches of files, rather than individually for each file.
+
+# Select and Split Layout from VBA
+
+On the VCS ribbon, click Open the **Advanced Tools > Split Files** to open the following dialog.
+
+
+
+Click the *Add Forms and Reports...* link to automatically load in the source files for the forms and reports in the current project and create the corresponding `*.cls` files.
+
+Click the button to Split Files. This will begin the automated process of splitting the files while preserving change history. Details and the full output of the git commands can be found in `git.log` in the source files folder.
+
+With the files now split, turn on the VCS option to **Split Layout from VBA** and run an export. At this point you should see both source files modified for each object as the layout is removed from the class file, and the VBA is removed from the layout file.
+
+That's it! Now the VBA code changes can be tracked in the `*.cls` file, and the layout in the `*.bas` file.
\ No newline at end of file
diff --git a/Wiki/Supported-Objects.md b/Wiki/Supported-Objects.md
index 41294c1d..1caa779b 100644
--- a/Wiki/Supported-Objects.md
+++ b/Wiki/Supported-Objects.md
@@ -16,7 +16,6 @@ Most types of objects can be exported and imported using this tool.
|Modules |✔️|✔️|
|Database Settings|✔️|✔️|
-
## Detailed List
If you are looking for a specific type of object or property that you want to export or import, you can refer to the following more comprehensive list. (Updates and additions welcome.)
@@ -88,4 +87,7 @@ The *Testing* column indicates whether a test item and testing code has been cre
Working with *.adp files is very similar to working with regular (MDB) Microsoft Access databases. All of the main database objects can be exported and imported just like MDB files. When it comes to SQL server objects, the object definitions are exported for tracking in source control, but this system does not attempt to modify any SQL server objects. (Hence the n/a note on importing SQL objects.)
+## Supported Versions
+This add-in is designed to work in Microsoft Access 2010 and newer. Access 2007 users, please see [this issue](https://github.com/joyfullservice/msaccess-vcs-addin/issues/464).
+
Missing something? Create an issue or a pull request.
\ No newline at end of file
diff --git a/Wiki/img/split-files-dialog.jpg b/Wiki/img/split-files-dialog.jpg
new file mode 100644
index 00000000..e6884a81
Binary files /dev/null and b/Wiki/img/split-files-dialog.jpg differ