Friday 28 December 2018

VBA - Persistence - CopyMemory can be used to serialise state

First, a health warning, the code in this blog comes with no warranty. Microsoft would say that copying memory can have unpredictable results. Nevertheless, if you are fascinated by VBA then you might be interested in the guts of VBA.

In the previous post I showed how LSet can be used to copy the state from a user-defined type (UDT) into a byte array and vice versa. This can be used in distributed systems but also one could save the byte array to a file and then load into a subsequent Excel session. Thus it is possible to persist a (UDT) to file, and if you use classes then you can gather all your class level variables into a UDT. One can begin to see how a whole object graph (i.e. the state of a whole hierarchy of classes) might be persist-able.

At the end of the previous post I introduced the CopyMemory() function and I used it to replace the copying of a byte array.

The copied byte array was located in a companion UDT defined solely for LSet-ting to the real UDT. I wondered if I could cut out the middle step and use CopyMemory() to copy directly from the byte array to the real UDT. I have conducted some experiments and you can so long as you use Byte arrays for your strings. Details of my experimental code follow.

modTestCopyStringToBytes Standard Module

So we need to treat strings differently because they are not inherently contiguous, we need to convert them to a byte array but this is not too difficult. What is important is ensuring that no overwriting of other memory happens. In the procedure TestCopyStringToBytes() below you can see that we find the length of the array and the length of the string we're asked to copy and we truncate the string if the byte array is not large enough. We copy over only safe number of bytes. The code has plenty of comments.

  1. Option Explicit
  2.  
  3. '* No Warranty, use this code at your own risk!
  4.  
  5. Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
  6.  
  7. '*
  8. '* Not used in the main code.
  9. '* Illustrates how strings have be treated carefully as an array of bytes
  10. '*
  11. Private Sub TestCopyStringToBytes()
  12.  
  13.     '* set up string
  14.     Dim sRHS As String
  15.     sRHS = "hello world"
  16.  
  17.     '* defining the string length here but it could passed in and thus unknown
  18.     Dim abStringAsBytes(0 To 9) As Byte
  19.  
  20.     '* standard array length determination, I know it is fixed above but ...
  21.     '* ... in other cases the array could be passed in and be of unknown length
  22.     Dim lMaxLen As Long
  23.     lMaxLen = (UBound(abStringAsBytes) - LBound(abStringAsBytes) + 1)
  24.  
  25.     '* we'd like to not overwrite the allocated memory so truncate the string
  26.     '* remember strings are two bytes for each character so we divide by 2
  27.     Dim sSafeRHS As String
  28.     sSafeRHS = Left$(sRHS, lMaxLen / 2)
  29.  
  30.     '* give a truncation warning to avoid shock
  31.     If lMaxLen < Len(sRHS) Then Debug.Print "Warning contents of sRHS will be truncated from '" & sRHS & "' to '" & sSafeRHS & "'"
  32.  
  33.     '* this next function will copy the memory from the string sSafeRHS to the first byte of the byte array, abStringAsBytes(0)
  34.     CopyMemory ByVal VarPtr(abStringAsBytes(0)), ByVal StrPtr(sSafeRHS), LenB(sSafeRHS)
  35.  
  36.     '* this next line works thanks to VBA being nice and interpreting a byte array as a string for us
  37.     '* (saves us having to reverse the memory copy operation)
  38.     Debug.Print abStringAsBytes
  39. End Sub

If you run the code you should get a truncation warning and the output of the copied truncated string like this

Warning contents of sRHS will be truncated from 'hello world' to 'hello'
hello

modCopyMemoryDirectToUdt Standard Module

Here is a a very full listing with plenty of debug code to illustrate what is going on. The code is heavily commented. The indented code in Main() is not strictly necessary but it serves as a guide as to what is going on.

  1. Option Explicit
  2.  
  3. '* No Warranty, use this code at your own risk!
  4.  
  5. Private Const mlPAD As Long = 28 '* just for formatting
  6.  
  7. Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
  8.  
  9. '*
  10. '* See here we only need one type per entity/class
  11. '* DO NOT USE   "aFixedString As String * 20" as it is not contiguous!
  12. '* INSTEAD USE  "aFixedStringAsBytes(0 To 19) As Byte"
  13. '*
  14. Public Type udtContiguousType
  15.     aLong As Long
  16.     anInt As Integer
  17.     aDouble As Double
  18.     aFixedStringAsBytes(0 To 9) As Byte  '
  19.     aSecondLong As Long
  20.     aSecondDouble As Double
  21. End Type
  22.  
  23. '*
  24. '* The following property procedures could be adjusted to sit in a class
  25. '* the class could store the string as a byte array in the class's state UDT
  26. '* to the callers of the class the property could look like just a string
  27. '*
  28. Property Let MyFixedString(ByRef uType As udtContiguousType, ByVal sRHS As String)
  29.  
  30.     '* array length determination
  31.     Dim lMaxLen As Long
  32.     lMaxLen = ByteArrayLen(uType.aFixedStringAsBytes)
  33.  
  34.     '* we'd like to not overwrite the allocated memory so truncate the string
  35.     '* remember strings are two bytes for each character so we divide by 2
  36.     Dim sSafeRHS As String
  37.     sSafeRHS = Left$(sRHS, lMaxLen / 2)
  38.  
  39.     '* give a truncation warning to avoid shock
  40.     If lMaxLen < Len(sRHS) Then Debug.Print "Warning contents of sRHS will be truncated from '" & sRHS & "' to '" & sSafeRHS & "'"
  41.  
  42.     '* this next function will copy the memory from the string sSafeRHS ...
  43.     '* ... to the first byte of the byte array, uType.aFixedStringAsBytes(0)
  44.     CopyMemory ByVal VarPtr(uType.aFixedStringAsBytes(0)), ByVal StrPtr(sSafeRHS), LenB(sSafeRHS)
  45. End Property
  46.  
  47. Property Get MyFixedString(ByRef uType As udtContiguousType) As String
  48.     '* this line works thanks to VBA being nice and interpreting a byte array as a string for us
  49.     '* (saves us having to reverse the memory copy operation)
  50.     MyFixedString = uType.aFixedStringAsBytes
  51. End Property
  52.  
  53.  
  54. '*
  55. '* the main code, run this code
  56. '*
  57. Private Sub Main()
  58.     Dim bDebug As Boolean
  59.     bDebug = True
  60.  
  61.     Dim uTypeSrc As udtContiguousType
  62.     Dim uTypeDest As udtContiguousType
  63.  
  64.     '* set some values just like any other UDT, except for the strings
  65.     uTypeSrc.aLong = 1
  66.     uTypeSrc.anInt = 2
  67.     uTypeSrc.aDouble = 3.141
  68.     uTypeSrc.aSecondLong = -434634634
  69.     uTypeSrc.aSecondDouble = Sqr(10) * -1
  70.  
  71.     '* we have to treat strings specially
  72.     '* the string's special treatment is abstracted by the property procedures
  73.     MyFixedString(uTypeSrc) = "hello world"
  74.  
  75.     If bDebug Then
  76.         '* we have to be aware of truncation
  77.         Debug.Assert MyFixedString(uTypeSrc) = Left$("hello world", ByteArrayLen(uTypeSrc.aFixedStringAsBytes) / 2)
  78.  
  79.         '* for illustration we print the memory addresses so that one can see the udt's memory layout , not strictly necessary
  80.         PrintMemoryAddresses "uTypeSrc", uTypeSrc
  81.  
  82.         '* these next lines highlight the byte length of each member
  83.         '* not strictly necessary
  84.         Debug.Assert VarPtr(uTypeSrc) = VarPtr(uTypeSrc.aLong)
  85.         Debug.Assert VarPtr(uTypeSrc.anInt) - VarPtr(uTypeSrc.aLong) = 4
  86.         Debug.Assert VarPtr(uTypeSrc.aDouble) - VarPtr(uTypeSrc.anInt) = 4
  87.         Debug.Assert VarPtr(uTypeSrc.aFixedStringAsBytes(0)) - VarPtr(uTypeSrc.aDouble) = 8
  88.         Debug.Assert VarPtr(uTypeSrc.aSecondLong) - VarPtr(uTypeSrc.aFixedStringAsBytes(0)) =
  89.                                                             BytesAlignedLen(ByteArrayLen(uTypeSrc.aFixedStringAsBytes))
  90.         Debug.Assert VarPtr(uTypeSrc.aSecondDouble) - VarPtr(uTypeSrc.aSecondLong) = 4
  91.  
  92.         '* for illustration we print the memory addresses so that one can see the udt's memory layout , not strictly necessary
  93.         PrintMemoryAddresses "uTypeDest", uTypeDest
  94.  
  95.         '* more layout illustration
  96.         Debug.Assert VarPtr(uTypeDest) = VarPtr(uTypeDest.aLong)
  97.     End If
  98.  
  99.     CopyMemory ByVal (VarPtr(uTypeDest.aLong)), ByVal (VarPtr(uTypeSrc.aLong)), LenB(uTypeSrc)
  100.  
  101.     If bDebug Then
  102.         Debug.Assert MyFixedString(uTypeDest) = Left$("hello world", ByteArrayLen(uTypeSrc.aFixedStringAsBytes) / 2)
  103.         Debug.Assert uTypeDest.aLong = uTypeSrc.aLong
  104.         Debug.Assert uTypeDest.anInt = uTypeSrc.anInt
  105.         Debug.Assert uTypeDest.aDouble = uTypeSrc.aDouble
  106.         Debug.Assert MyFixedString(uTypeDest) = MyFixedString(uTypeSrc)
  107.         Debug.Assert uTypeDest.aSecondLong = uTypeSrc.aSecondLong
  108.         Debug.Assert uTypeDest.aSecondDouble = uTypeSrc.aSecondDouble
  109.     End If
  110.     Stop 'please go look at the Locals window
  111. End Sub
  112.  
  113. '*
  114. '* standard array length calculation
  115. '*
  116. Private Function ByteArrayLen(ByRef abBytes() As ByteAs Long
  117.     ByteArrayLen = (UBound(abBytes()) - LBound(abBytes()) + 1)
  118. End Function
  119.  
  120. '*
  121. '* each member of a user defined type is 32-bit aligned so this function calcs the aligned byte length
  122. '*
  123. Private Function BytesAlignedLen(ByVal cbByteCount As LongAs Long
  124.     If cbByteCount \ 4 = cbByteCount / 4 Then
  125.         BytesAlignedLen = cbByteCount
  126.     Else
  127.         BytesAlignedLen = ((cbByteCount \ 4) + 1) * 4
  128.     End If
  129. End Function
  130.  
  131. '*
  132. '* this prints the memory addresses so one can see the memory laid out
  133. '*
  134. Private Function PrintMemoryAddresses(ByVal sVarName As StringByRef uType As udtContiguousType)
  135.     Debug.Print()
  136.     Debug.Print Pad("&" & sVarName & "", mlPAD) & " = " & VarPtr(uType)
  137.     Debug.Print Pad("&" & sVarName & ".aLong", mlPAD) & " = " & VarPtr(uType.aLong) & " a Long has 4 bytes"
  138.     Debug.Print Pad("&" & sVarName & ".anInt", mlPAD) & " = " & VarPtr(uType.anInt) &
  139.         " an Int has 2 bytes but is 32-bit aligned so has 4 bytes"
  140.     Debug.Print Pad("&" & sVarName & ".aDouble", mlPAD) & " = " & VarPtr(uType.aDouble) & " a Double has 8 bytes"
  141.  
  142.     Dim lMaxLen As Long
  143.     lMaxLen = ByteArrayLen(uType.aFixedStringAsBytes)
  144.  
  145.     Dim lAlignedMaxLen As Long
  146.     lAlignedMaxLen = BytesAlignedLen(lMaxLen)
  147.  
  148.     Dim sByteLen As String
  149.     sByteLen = " this byte array has " & lMaxLen & " bytes" &
  150.         VBA.IIf(lAlignedMaxLen <> lMaxLen, " but is 32-bit aligned to " & lAlignedMaxLen & " bytes""")
  151.  
  152.     Debug.Print Pad("&" & sVarName & ".aFixedStringAsBytes", mlPAD) & " = " & VarPtr(uType.aFixedStringAsBytes(0)) & sByteLen
  153.     Debug.Print Pad("&" & sVarName & ".aSecondLong", mlPAD) & " = " & VarPtr(uType.aSecondLong) & " a Long has 4 bytes"
  154.     Debug.Print Pad("&" & sVarName & ".aSecondDouble", mlPAD) & " = " & VarPtr(uType.aSecondDouble) & " a Double has 8 bytes"
  155.     Debug.Print Pad("&" & sVarName & " total length", mlPAD) & " = " & LenB(uType)
  156.  
  157. End Function
  158.  
  159. '*
  160. '* this pads a string to help it looks columnar
  161. '*
  162. Private Function Pad(ByVal sText As StringByVal lLen As LongAs String
  163.     Pad = Left$(sText & String(lLen, " "), lLen)
  164. End Function

So when the Main() code runs we have two things to look at (1) the Immediate Window and (2) the Locals Window. Here are mine, firstly the Immediate Window

Warning contents of sRHS will be truncated from 'hello world' to 'hello'

&uTypeSrc                    = 5240168
&uTypeSrc.aLong              = 5240168 a Long has 4 bytes
&uTypeSrc.anInt              = 5240172 an Int has 2 bytes but is 32-bit aligned so has 4 bytes
&uTypeSrc.aDouble            = 5240176 a Double has 8 bytes
&uTypeSrc.aFixedStringAsByte = 5240184 this byte array has 10 bytes but is 32-bit aligned to 12 bytes
&uTypeSrc.aSecondLong        = 5240196 a Long has 4 bytes
&uTypeSrc.aSecondDouble      = 5240200 a Double has 8 bytes
&uTypeSrc total length       = 40

&uTypeDest                   = 5240128
&uTypeDest.aLong             = 5240128 a Long has 4 bytes
&uTypeDest.anInt             = 5240132 an Int has 2 bytes but is 32-bit aligned so has 4 bytes
&uTypeDest.aDouble           = 5240136 a Double has 8 bytes
&uTypeDest.aFixedStringAsByt = 5240144 this byte array has 10 bytes but is 32-bit aligned to 12 bytes
&uTypeDest.aSecondLong       = 5240156 a Long has 4 bytes
&uTypeDest.aSecondDouble     = 5240160 a Double has 8 bytes
&uTypeDest total length      = 40

Now here is my Locals Window screenshot with the variables expanded to show the members. It shows the contents successfully copied from uTypeSrc to uTypeDest.

Commentary

It is interesting that VBA could potentially participate in a persistence scheme. I am minded to investigate the persistence interfaces of the COM specification such as IPersist to see if VBA could indeed play in this league. One problem is that IPersist has non Automation types so one would need to define a proxy component and a proxy interface.

Final Warranty Warning

I can't give a warranty for this code (nor any code on this blog for that matter).

Thursday 27 December 2018

VBA - Persistence - Use LSet to serialise user defined type to a byte array

First, a health warning; there is no warranty for this code in this blog post; use at your own risk.

Transmitting State In a Distributed System

Years ago, I encountered a technique from a great technical author called Rockford Lhotka who wrote a classic VB6 book called Professional Visual Basic 6 Distributed Objects; as its title suggests it's concerned with using VB6 to build systems that distributed objects across machines. VBA is a version of VB6 so the techniques found therein apply to Excel Developers. In this blog post (and some planned future posts), I comment upon those techniques; specifically the serialisation/persistence technique.

In a distributed system, at some point one inevitably passes an object as a parameter and this raises the potential problem of excessive network traffic. So, if an instance of Class1 residing on MachineA wants to call an instance of Class2 residing on MachineB and passes as a parameter a pointer to an instance of Class3 which was created on MachineA then MachineB will make network calls to query the state of Class3. If these network calls are excessive then you will want to redesign your system to instead serialise the state of Class3 to a byte stream (or other state vessel), pass the byte stream over the network as the parameter, instantiate a duplicate of Class3 on MachineB initialising its state from the passed parameter byte stream and make local calls to the local duplicate. If you change the state of Class3 you'll need to serialise the state and return it back to Machine1 back so its original instance of Class3 is synchronised.

As you can imagine designing distributed systems can be hard and actually this is not what this blog post is to be about. This blog post is meant to be about the persistence mechanism used by Rockford Lhotka, using the LSet keyword. But if you're interested in this problem, Rockford Lhotka, has gone to become a big name in the problem space of distributed systems, promoting his solution Component-based Scalable Logical Architecture (CSLA) an early version of which is found in the above referenced book.

The key takeaway from this section is that there are techniques to serialise a (VB6/VBA) class's state to a an array of bytes and then instantiate a duplicate. Just bear that in mind as a use case for the code below.

Microsoft seems to frown upon LSet (and by implication Rockford Lhotka's CSLA)

Above, I've written above quite a lot about Rockford Lhotka because his ideas seems to be a little at odds with the the official Microsoft documentation on LSet, here's an eye-catching quote ...

Using LSet to copy a variable of one user-defined type into a variable of a different user-defined type is not recommended.

But this is exactly how Rockford Lhotka achieves his trick of serialisation. We'll move onto an example before discussing the point at issue further.

Sample LSet to Byte Array Code

So how does Rockford Lhotka serialise state in VB6 and VBA? Here is some code which demonstrates an instance of a user-defined-type being serialised and the state then used in turn to create a second identical instance of the same user-defined-type.

modUdtToByteArrayByLSet Standard Module

  1. Option Explicit
  2.  
  3. '* No Warranty, use this code at your own risk!
  4.  
  5. 'Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
  6.  
  7. Public Type udtMyType
  8.     aLong As Long
  9.     anInt As Integer
  10.     aDouble As Double
  11.     aFixedString As String * 10
  12.     aSecondLong As Long
  13.     aSecondDouble As Double
  14. End Type
  15.  
  16. Public Type udtByteArray48
  17.     value(0 To 47) As Byte
  18. End Type
  19.  
  20. Private Sub TestSaveToByteArray()
  21.     Dim uContiguousType As udtMyType
  22.     uContiguousType.aLong = 1
  23.     uContiguousType.anInt = 2
  24.     uContiguousType.aDouble = 3.141
  25.  
  26.     uContiguousType.aFixedString = "Hello"
  27.     uContiguousType.aSecondLong = -434634634
  28.     uContiguousType.aSecondDouble = Sqr(10) * -1
  29.  
  30.     Dim abSaved() As Byte
  31.     abSaved() = SaveToByteArray(uContiguousType, 48)
  32.  
  33.     Dim uContiguousType2 As udtMyType
  34.     LoadFromByteArray abSaved(), uContiguousType2, 48
  35.  
  36.     Debug.Assert uContiguousType2.aDouble = uContiguousType.aDouble
  37.     Debug.Assert uContiguousType2.aFixedString = uContiguousType.aFixedString
  38.     Debug.Assert uContiguousType2.aLong = uContiguousType.aLong
  39.     Debug.Assert uContiguousType2.anInt = uContiguousType.anInt
  40.     Debug.Assert uContiguousType2.aSecondLong = uContiguousType.aSecondLong
  41.     Debug.Assert uContiguousType2.aSecondDouble = uContiguousType.aSecondDouble
  42.     Stop
  43. End Sub
  44.  
  45. '******************************************************************************************************
  46. '*
  47. '* Persistence routines, you'll need these three for each type you intend to persist
  48. '* and customise the signatures
  49. '*
  50. '******************************************************************************************************
  51. Public Sub LoadFromByteArray(ByRef abBytes() As ByteByRef puContiguousType As udtMyType, ByVal lSizeOf As Long)
  52.  
  53.     CheckSizeOf puContiguousType, lSizeOf
  54.     Dim uByteArray48 As udtByteArray48
  55.  
  56.     'CopyMemory ByVal (VarPtr(uByteArray48.value(0))), ByVal (VarPtr(abBytes(0))), lSizeOf
  57.     Dim idx As Long
  58.     For idx = 0 To lSizeOf - 1
  59.         uByteArray48.value(idx) = abBytes(idx)
  60.     Next idx
  61.  
  62.     LSet puContiguousType = uByteArray48
  63. End Sub
  64.  
  65. Private Sub CheckSizeOf(ByRef puContiguousType As udtMyType, ByVal lSizeOf As Long)
  66.     Dim uByteArray48 As udtByteArray48
  67.     If Not LenB(puContiguousType) = LenB(uByteArray48) Then Err.Raise vbObjectError, , "#size of byte arrays do not match!"
  68.     If Not LenB(puContiguousType) = lSizeOf Then Err.Raise vbObjectError, , "#size of byte arrays do not match size_of!"
  69. End Sub
  70.  
  71. Public Function SaveToByteArray(ByRef puContiguousType As udtMyType, ByVal lSizeOf As LongAs Byte()
  72.  
  73.     CheckSizeOf puContiguousType, lSizeOf
  74.  
  75.     Dim uByteArray48 As udtByteArray48
  76.     LSet uByteArray48 = puContiguousType
  77.     SaveToByteArray = uByteArray48.value
  78.  
  79. End Function
  80.  

So to run the above code run TestSaveToByteArray() whose Stop statement conveniently allows inspection of the Locals Window which should look something like that below which shows two instances of the user-defined type myType with identical contents but the second has been populated from a byte array calculated from the first. Both reading and writing the byte array to the user-defined-typed is done with LSet...

Commentary

So whilst the above code works there is quite a lot with which I am unhappy. Primarily, if your UDT is 48 bytes long then you need to separately define another type, the serialisation type, to have one single member byte array of length 48 bytes. Now, I'm assuming that this technique implies that each class has a UDT to contain the state for the class (for I do not know any trick to access the state of a VBA class, if you know do please comment below). So imagine if you have twenty classes in your project of varying byte lengths then you'd need twenty separate UDTs for serialisation to cope with the varying lengths.

For each class, one would need the three persistence routines given in the code: LoadFromByteArray(), CheckSizeOf() and SaveToByteArray()

I just wonder if we can do better than this.

One immediate change I see is to optimise the copying of the array as given in LoadFromByteArray(). Iterating through each byte in the byte array in VBA is clearly sub-optimal, much better here to copy memory directly because an array of bytes is guaranteed to be contiguous. So there is a replacement for the array loop on lines 57-60, you need to uncomment line 56 and line 03; then comment out line 57-60.

But if you cross the Rubicon and start using CopyMemory() then aren't even more optimisations available? This will be the subject of the following posts.

Wednesday 5 December 2018

VBA - WIN32 API : Parse strings to numbers

VBA can call into the COM run-time parsing functions to get some serious help with parsing. In this example I show string being parsed to a numeric type. This code also handles exponential notation in case you not sufficiently impressed.

One point of note is that if you pass a number with 4 or fewer decimal places then the COM runtime will by default parse to the Currency type. I think most programmers would expect as Double so I've added some post-processing code whilst keeping the Currency option open.

If you really want a currency then I suggest you read this blog post where I parse currencies.

modVarNumFromStr Standard Module

  1. Option Explicit
  2.  
  3. '*
  4. '* Brought to you by the Excel Development Platform blog
  5. '* https://exceldevelopmentplatform.blogspot.com/2018/12
  6. '*
  7.  
  8. Private Type NUMPARSE
  9.     cDig As Long
  10.     dwInFlags As Long
  11.     dwOutFlags As Long
  12.     cchUsed As Long
  13.     nBaseShift As Long
  14.     nPwr10 As Long
  15. End Type
  16.  
  17. Private Declare Function VarParseNumFromStr Lib "oleaut32" (ByVal strIn As LongByVal LCID As Long, _
  18.     ByVal dwFlags As LongByRef numprs As NUMPARSE, ByRef rgbDig As ByteAs Long
  19.  
  20. Private Declare Function VarNumFromParseNum Lib "oleaut32" (ByRef pnumprs As NUMPARSE, _
  21.     ByRef rgbDig As ByteByVal dwVtBits As LongByRef pvar As Variant) As Long
  22.  
  23. Sub TestVarNumFromStr()
  24.     Dim v(0 To 9)
  25.     v(0) = VarNumFromStr("14")
  26.     Debug.Assert v(0) = 14
  27.     Debug.Assert VarType(v(0)) = VbVarType.vbInteger
  28.  
  29.     v(1) = VarNumFromStr("15.1234")
  30.     Debug.Assert v(1) = 15.1234
  31.     Debug.Assert VarType(v(1)) = VbVarType.vbCurrency
  32.  
  33.     v(2) = VarNumFromStr("15.11111")
  34.     Debug.Assert v(2) = 15.11111
  35.     Debug.Assert VarType(v(2)) = VbVarType.vbDouble
  36.  
  37.     v(3) = VarNumFromStr("1.512E6")
  38.     Debug.Assert v(3) = 1512000
  39.     Debug.Assert VarType(v(3)) = VbVarType.vbLong
  40.  
  41.     v(4) = VarNumFromStr("1.512E-6")
  42.     Debug.Assert v(4) = 0.000001512
  43.     Debug.Assert VarType(v(4)) = VbVarType.vbDouble
  44.  
  45.     Stop
  46. End Sub
  47.  
  48. Public Function VarNumFromStr(ByRef sText As StringOptional bConvertCurrencyToDouble As Boolean TrueAs Variant
  49.  
  50.     Dim rgbDig() As Byte
  51.     Dim uNUMPARSE As NUMPARSE
  52.  
  53.     Dim lLen As Long
  54.     lLen = VBA.Len(sText)
  55.  
  56.     If lLen > 0 Then
  57.         ReDim rgbDig(lLen - 1)
  58.  
  59.         '* https://technet.microsoft.com/ru-ru/ms221690(v=vs.90)
  60.         With uNUMPARSE
  61.             .cDig = lLen
  62.             .dwInFlags = &H1FFF& 'NUMPRS_STD
  63.         End With
  64.  
  65.         '* https://docs.microsoft.com/en-us/windows/desktop/api/oleauto/nf-oleauto-varparsenumfromstr
  66.         If VarParseNumFromStr(StrPtr(sText), 0, 0, uNUMPARSE, rgbDig(0)) = 0 Then
  67.  
  68.             '* https://docs.microsoft.com/en-us/windows/desktop/api/oleauto/nf-oleauto-varnumfromparsenum#vtbit_decimal
  69.             If VarNumFromParseNum(uNUMPARSE, rgbDig(0), 2047, VarNumFromStr) = 0 Then
  70.                 '* do we need any post-processing
  71.                 If bConvertCurrencyToDouble And InStr(1, sText, ".", vbTextCompare) > 0 And _
  72.                                 VarType(VarNumFromStr) = vbCurrency Then
  73.                     VarNumFromStr = CDbl(VarNumFromStr) '* convert decimal currency
  74.                 End If
  75.  
  76.             Else
  77.  
  78.                 Err.Raise vbObjectError, , "#Error whilst parsing '" & sText & "'!"
  79.             End If
  80.         Else
  81.             Err.Raise vbObjectError, , "#Error whilst parsing '" & sText & "'!"
  82.         End If
  83.     End If
  84. End Function

HTML5 Animations with CSS & VBA: Fading in text

Browser GUI technologies are clearly better than VBA's. Html5 is a wonderful leap forward with its animation capabilities. However, sometimes you'll want some code to help avoid fiddling with CSS. Why not VBA?

First Message
Second Message
Third Message
Fourth Message

So I hope you just seen the above messages fade in one after the after. How is this achieved? Firstly, there is the opacity attribute (0 = invisible, 1 = visible). Then we have to animate the opacity and for that need the animation-name, animation-delay and animation-duration attributes. We also need a @keyframes rule to give the schedule for the opacity to change over time, in this example given as percentages. The animation-name attribute must tie in to the identifier given in the @keyframes rule. What follows is the source to drive this simple animation.

HTML to fade in text messages

  1. <style>
  2.     .allText {
  3.         font-size2rem;
  4.         font-familysans-serif;
  5.         color#000000;
  6.     }
  7.  
  8.     @keyframes FadeIn10_20 {
  9.         0% opacity0; }
  10.         10% opacity0; }
  11.         20% opacity1; }
  12.         100% opacity1; }
  13.     }
  14.  
  15.     .text0 {
  16.         animation-nameFadeIn10_20;
  17.         animation-delay0s;
  18.         animation-duration10s;
  19.     }
  20.  
  21.     @keyframes FadeIn30_40 {
  22.         0% opacity0; }
  23.         30% opacity0; }
  24.         40% opacity1; }
  25.         100% opacity1; }
  26.     }
  27.  
  28.     .text1 {
  29.         animation-nameFadeIn30_40;
  30.         animation-delay0s;
  31.         animation-duration10s;
  32.     }
  33.  
  34.     @keyframes FadeIn50_60 {
  35.         0% opacity0; }
  36.         50% opacity0; }
  37.         60% opacity1; }
  38.         100% opacity1; }
  39.     }
  40.  
  41.     .text2 {
  42.         animation-nameFadeIn50_60;
  43.         animation-delay0s;
  44.         animation-duration10s;
  45.     }
  46.  
  47.     @keyframes FadeIn70_80 {
  48.         0% opacity0; }
  49.         70% opacity0; }
  50.         80% opacity1; }
  51.         100% opacity1; }
  52.     }
  53.  
  54.     .text3 {
  55.         animation-nameFadeIn70_80;
  56.         animation-delay0s;
  57.         animation-duration10s;
  58.     }
  59. </style>
  60. <div class='allText text0'>First Message</div>
  61. <div class='allText text1'>Second Message</div>
  62. <div class='allText text2'>Third Message</div>
  63. <div class='allText text3'>Fourth Message</div>

Initially, I struggled with the animation directives, I grew frustrated editing source CSS manually so I wrote some VBA to help set the timings because a change in duration of one message had a knock-on effect on the following messages. I needed some code to total the timings in seconds and then express the timing of the animation events as percentages.

I am aware that there are CSS pre-processors out there such as LESS and SASS but I'd rather use VBA. Here is the source

modCSSFadeInAnimation Standard Module

  1. Option Explicit 
  2. Option Private Module
  3.  
  4. '*
  5. '* Brought to you by the Excel Development Platform Blog
  6. '* http://exceldevelopmentplatform.blogspot.com/2018/12/
  7. '*
  8.  
  9. Private mdicLines As Scripting.Dictionary
  10.  
  11. Private Type udtMessage
  12.     sText As String
  13.     dStart As Double 'In seconds
  14.     dFadeIn As Double 'In seconds
  15.     lStartPercentage As Long
  16.     lFadeInPercentage As Long
  17.     lTop As Long
  18.     dDuration As Double 'In seconds
  19. End Type
  20.  
  21. Private Type udtMessages
  22.     Messages() As udtMessage
  23. End Type
  24.  
  25. Private mlTotalSeconds As Long
  26.  
  27. Private Sub Main()
  28.  
  29.     Dim bFullHtmlDocument As Boolean
  30.     bFullHtmlDocument = False '*<---- change to True to get a full html document instead of a fragment
  31.  
  32.     Dim uMessages As udtMessages
  33.  
  34.     AddMessage uMessages, 10, 2, "First Message", 2
  35.     AddMessage uMessages, 20, 2, "Second Message"
  36.     AddMessage uMessages, 30, 2, "Third Message"
  37.     AddMessage uMessages, 40, 2, "Fourth Message"
  38.  
  39.     CalcFades uMessages
  40.     OpenStyleTag bFullHtmlDocument
  41.     If bFullHtmlDocument Then WritePositioningCSS uMessages
  42.     WriteAnimationCSS uMessages ', 30
  43.     WriteEndOfStyleBlock bFullHtmlDocument
  44.     WriteBody uMessages, bFullHtmlDocument
  45.  
  46.     Debug.Print Join(mdicLines.Items, vbNewLine)
  47.  
  48. End Sub
  49.  
  50. Private Sub AddMessage(ByRef uMessages As udtMessages, ByVal lTop As LongByVal dDuration As DoubleByVal sText As String,
  51.         Optional dStart0 As Double)
  52.     Dim lIndex As Long
  53.  
  54.     If Not IsArrayInitialized(uMessages) Then
  55.         '* not yet initialised
  56.         lIndex = 0
  57.         ReDim uMessages.Messages(0 To 0) As udtMessage
  58.  
  59.     Else
  60.         lIndex = UBound(uMessages.Messages) + 1
  61.         ReDim Preserve uMessages.Messages(0 To lIndex) As udtMessage
  62.     End If
  63.  
  64.     If lIndex = 0 Then
  65.         uMessages.Messages(lIndex).dStart = dStart0
  66.     Else
  67.         uMessages.Messages(lIndex).dStart = uMessages.Messages(lIndex - 1).dStart + uMessages.Messages(lIndex - 1).dDuration
  68.     End If
  69.     uMessages.Messages(lIndex).sText = sText
  70.     uMessages.Messages(lIndex).lTop = lTop
  71.     uMessages.Messages(lIndex).dDuration = dDuration
  72.  
  73. End Sub
  74.  
  75. Private Function IsArrayInitialized(ByRef uMessages As udtMessages)
  76.     On Error GoTo ErrHand
  77.     Dim lUbound As Long
  78.     lUbound = UBound(uMessages.Messages)
  79.     IsArrayInitialized = True
  80.     Exit Function
  81. ErrHand:
  82.  
  83. End Function
  84.  
  85. Private Sub CalcFades(ByRef uMessages As udtMessages, Optional dDefaultFade As Double = 1)
  86.  
  87.     Dim lLoop As Long
  88.  
  89.     For lLoop = LBound(uMessages.Messages) To UBound(uMessages.Messages)
  90.         If uMessages.Messages(lLoop).dFadeIn = 0 Then
  91.             uMessages.Messages(lLoop).dFadeIn = uMessages.Messages(lLoop).dStart - dDefaultFade
  92.         End If
  93.         If uMessages.Messages(lLoop).dFadeIn < 0 Then uMessages.Messages(lLoop).dFadeIn = 0
  94.     Next
  95.  
  96.     mlTotalSeconds = uMessages.Messages(UBound(uMessages.Messages)).dStart +
  97.                     uMessages.Messages(UBound(uMessages.Messages)).dDuration
  98.  
  99.     For lLoop = LBound(uMessages.Messages) To UBound(uMessages.Messages)
  100.         uMessages.Messages(lLoop).lStartPercentage = 100 * uMessages.Messages(lLoop).dStart / mlTotalSeconds
  101.         uMessages.Messages(lLoop).lFadeInPercentage = 100 * uMessages.Messages(lLoop).dFadeIn / mlTotalSeconds
  102.     Next
  103.  
  104. End Sub
  105.  
  106. Private Sub OpenStyleTag(Optional bWriteHtmlTags As Boolean False)
  107.     Set mdicLines = New Scripting.Dictionary
  108.     If bWriteHtmlTags Then
  109.         AddLine "<!DOCTYPE html>"
  110.         AddLine "<html>"
  111.         AddLine "<head>"
  112.         AddLine "<title>Presentation</title>"
  113.         AddLine "<meta name='viewport' content='width=device-width, initial-scale=1'></meta>"
  114.     End If
  115.     AddLine "<style>"
  116.     AddLine ".allText {"
  117.     AddLine "  font-size:2rem;"
  118.     AddLine "  font-family:sans-serif;"
  119.     AddLine "  color: #000000;"
  120.     AddLine "}"
  121.     AddLine ""
  122.  
  123. End Sub
  124.  
  125. Private Sub WritePositioningCSS(ByRef uMessages As udtMessages)
  126.     Dim lLoop As Long
  127.     For lLoop = LBound(uMessages.Messages) To UBound(uMessages.Messages)
  128.         AddLine ".text" & lLoop & " {"
  129.         AddLine "  position: absolute;"
  130.         AddLine "  left: 5%;"
  131.  
  132.         If uMessages.Messages(lLoop).lTop = 0 Then
  133.             AddLine "  top: " & 5 * (lLoop + 1) & "%;"
  134.         Else
  135.             AddLine "  top: " & uMessages.Messages(lLoop).lTop & "%;"
  136.         End If
  137.         AddLine "}"
  138.         AddLine ""
  139.     Next
  140. End Sub
  141.  
  142. Private Sub WriteAnimationCSS(ByRef uMessages As udtMessages, Optional lTotalSeconds As Variant)
  143.  
  144.     If Not IsMissing(lTotalSeconds) Then mlTotalSeconds = lTotalSeconds
  145.  
  146.     Dim lLoop As Long
  147.     For lLoop = LBound(uMessages.Messages) To UBound(uMessages.Messages)
  148.  
  149.         '* write keyframe, store keyframe name
  150.         Dim sKeyFrameName As String
  151.         KeyFramesFadeIn uMessages.Messages(lLoop).lFadeInPercentage, uMessages.Messages(lLoop).lStartPercentage, sKeyFrameName
  152.  
  153.         AddLine ".text" & lLoop & " {"
  154.         AddLine "  animation-name: " & sKeyFrameName & ";"
  155.         AddLine "  animation-delay: 0s;"
  156.         AddLine "  animation-duration: " & mlTotalSeconds & "s;"
  157.  
  158.         AddLine "}"
  159.         AddLine ""
  160.     Next
  161. End Sub
  162.  
  163. Private Sub WriteEndOfStyleBlock(Optional bWriteHeadTag As Boolean False)
  164.     AddLine "</style>"
  165.     If bWriteHeadTag Then AddLine "</head>"
  166.  
  167. End Sub
  168.  
  169. Private Sub WriteBody(ByRef uMessages As udtMessages, Optional bWriteHtmlAndBodyTags As Boolean False)
  170.     If bWriteHtmlAndBodyTags Then AddLine "<body>"
  171.  
  172.     Dim lLoop As Long
  173.     For lLoop = LBound(uMessages.Messages) To UBound(uMessages.Messages)
  174.  
  175.         AddLine "<div class='allText text" & lLoop & "'>" & uMessages.Messages(lLoop).sText & "</div>" 'position: absolute;"
  176.     Next
  177.  
  178.     If bWriteHtmlAndBodyTags Then
  179.         AddLine "</body>"
  180.         AddLine "</html>"
  181.     End If
  182.  
  183. End Sub
  184.  
  185. Private Function KeyFramesFadeIn(ByVal lStartPercent As LongByVal lEndPercent As LongByRef psKeyFrameName As String)
  186.  
  187.     psKeyFrameName = "FadeIn" & Pad(lStartPercent, 2, "0") & "_" & Pad(lEndPercent, 2, "0")
  188.  
  189.     AddLine "@keyframes " & psKeyFrameName & " {"
  190.     AddLine "    0% { opacity: 0; }"
  191.     AddLine "  " & Pad(lStartPercent, 3, " ") & "% { opacity: 0; }"
  192.     AddLine "  " & Pad(lEndPercent, 3, " ") & "% { opacity: 1; }"
  193.     AddLine "  100% { opacity: 1; }"
  194.     AddLine "}"
  195.     AddLine ""
  196.  
  197. End Function
  198.  
  199. Private Sub AddLine(ByVal sLine As String)
  200.     mdicLines.Add mdicLines.Count, sLine
  201. End Sub
  202.  
  203. Private Function Pad(ByVal lNum As LongByVal lLen As LongByVal sChar As StringAs String
  204.     If Len(CStr(lNum)) > lLen Then lLen = Len(CStr(lNum))
  205.     Pad = Right$(String$(lLen, sChar) & CStr(lNum), lLen)
  206. End Function
  207.  
  208.