The 1001 questions about vbRichClient5 (2020-07-21)

Quote:

---

Originally Posted by Schmidt

If it's only about additional "For Each support", then the cArrayList can now be used directly (without extra-wrapper-class),
because this is supported now in verion 5.0.75...

Otherwise (when you have to write your own wrapper anyways, due to some other missing methods on cArrayList),
then the wrapping of a "normal VB-Array" should do just fine, then saving a few extra-method-calls when accessing its contents).

Just for completeness...:
How to add For Each for such "internal Array-Members" was recently described here:
http://www.vbforums.com/showthread.p...=1#post5452847


HTH

Olaf

---

OK, Much appreciated!

Removed a meaningless post.

Quote:

---

Originally Posted by wqweto

Also note, that it's very hard to come up with a regexp that can remove whitespace *only* outside of string literals in JS. It is probably at this point when most folks give up on regexp and start exploring real lexers/parsers as their needs outgrow regexp capabilties.

---

Hi @wqweto, I'd like to discuss this question further. What you mean is that any find or replace operation on JS files needs to be done through lexer/parser, not RegExp, because JS files contain comments, strings and escape chars, and find or replace operations need to avoid comments and strings, is it?

For example, I need to replace all "\n" in the JS files with vbLf, which must be done through lexer/parser instead of using RegExp, is it? Thanks.

For example:

Code:

---

"ABC\nDEF" ------------> "ABC" + Chr(10) + "DEF"
"ABC\\nDEF" -----------> "ABC\nDEF"
"ABC\\\nDEF" ----------> "ABC\" + Chr(10) + "DEF"

"ABC\rDEF" ------------> "ABC" + Chr(10) + "DEF"
"ABC\\rDEF" -----------> "ABC\rDEF"
"ABC\\\rDEF" ----------> "ABC\" + Chr(10) + "DEF"

"ABC\r\nDEF" ----------> "ABC" + Chr(10) + "DEF"
"ABC\\r\nDEF" ---------> "ABC\r" + Chr(10) + "DEF"
"ABC\\\r\nDEF" --------> "ABC\" + Chr(10) + "DEF"

---

Question 40: How to set auto_vacuum setting on a new sqlite database?

The following attempt fails with "Sorry, no open DataBase!" error

Code:

---

    Dim oConn As cConnection
   
    Set oConn = New cConnection
    oConn.Execute "PRAGMA auto_vacuum=incremental"
    oConn.Execute "PRAGMA journal_mode=WAL"
    oConn.CreateNewDB "D:\TEMP\aaa.db"

---

There are 4 pragmas that one might need to set before creating a new database and/or issuing other pragmas (like journal_mode).

These were listed on sqlite-users mailing list as:
- pragma auto_vacuum
- pragma encoding
- pragma page_size
- pragma data_store_directory

cheers,
</wqw>

Quote:

---

Originally Posted by wqweto

Question 40: How to set auto_vacuum setting on a new sqlite database?

The following attempt fails with "Sorry, no open DataBase!" error

Code:

---

    Dim oConn As cConnection
   
    Set oConn = New cConnection
    oConn.Execute "PRAGMA auto_vacuum=incremental"
    oConn.Execute "PRAGMA journal_mode=WAL"
    oConn.CreateNewDB "D:\TEMP\aaa.db"

---

---

If you instantiate a new ADODB-connection-object,
and then try to directly call its Execute-Method next, you will get a basically similar error-message.

So, first Open (or Create) a new DB, then set Pragmas on it.

Interesting to note... please take a look at the created DBFile-length in your Temp-Folder
(after the CreateNewDB-call went through, holding already an SQLite-DBHdl internally).
The file-length will be zero (still "virginal, and open for any pragmas" you might throw at it) ;)

Olaf

Doh! This

Code:

---

    oConn.CreateNewDB "D:\TEMP\aaa.db"
    oConn.Execute "PRAGMA auto_vacuum=incremental"
    oConn.Execute "PRAGMA journal_mode=WAL"

---

. . . works of course. Just had to set auto_vacuum *before* journal_mode.

cheers,
</wqw>

Quote:

---

Originally Posted by wqweto

. . . works of course. Just had to set auto_vacuum *before* journal_mode.

---

Yep - and as a side-note for RC5-users ...

The general recommendation at the "instantiating-phase" of RC5-objects is, to use a (global) cConstructor-instance
(generally available via New_c, ... but also definable in your own global Variable - using your own naming).

This will avoid later problems, when a "regfree DropIn-module" is placed in your project
(to be able to ship the RC5-Dlls in a \Bin\-folder beside your executables)...

Code:

---

  'So, code like:
  Dim oConn As cConnection
  Set oConn = New cConnection
      oConn.CreateNewDB "c:\temp\somefile.db"
 
  'should better be written using the constructor-variable like:
  Dim oConn As cConnection
  Set oConn = New_c.Connection
      oConn.CreateNewDB "c:\temp\somefile.db"
 
  'or even shorter (since most constructor-methods offer a few useful init-params):
  Dim oConn As cConnection
  Set oConn = New_c.Connection("c:\temp\somefile.db", DBCreateNewFileDB)

---

Olaf

Quote:

---

Originally Posted by wqweto

Question 40: How to set auto_vacuum setting on a new sqlite database?

The following attempt fails with "Sorry, no open DataBase!" error

Code:

---

    Dim oConn As cConnection
   
    Set oConn = New cConnection
    oConn.Execute "PRAGMA auto_vacuum=incremental"
    oConn.Execute "PRAGMA journal_mode=WAL"
    oConn.CreateNewDB "D:\TEMP\aaa.db"

---

There are 4 pragmas that one might need to set before creating a new database and/or issuing other pragmas (like journal_mode).

These were listed on sqlite-users mailing list as:
- pragma auto_vacuum
- pragma encoding
- pragma page_size
- pragma data_store_directory

cheers,
</wqw>

---

Hi wqweto, thanks for your question. I've put your question on the list in post#1.

Quote:

---

Originally Posted by wqweto

I don't think it's possible as most regexp engines use back-tracking while PEG does not (although it can recurse). Usually to get rid of back-tracking one has to re-write some of the rules of the grammar in question. There are some whitepapers that attempt mapping regexp to PEG augmented grammars, that is PEG with some more features (not the original B. Ford implementation). VbPeg is already enhanced PEG generator as it understands custom actions in VB6 and allows special rules for error handling but it's not meant as regexp replacement (it cannot produce parsers at run-time).

---

Hi @wqweto, I'd like to know more about PEG.
(1) You said that PEG cannot generate RegExp parser, does it also mean that PEG cannot generate JavaScript or VBScript parser?
(2) If PEG cannot generate a JavaScript or VBScript parser, what are the main reasons? What are the main difficulties?
(3) What can PEG do? Or what are the main applications of PEG? Thanks.

Qustion 041: Could vbRichClient5 add regular expression support?

Neither VBScript nor JScript9 seems to provide the unicode pattern "/u". For example: "/[a-z]/u" is not recognized by VBScript and JScript.

It would be great if vbRichClient5 could implement regular expression engine and support Unicode pattern ("/u")

Qustion 042: Use RC5.Collection to read JavaScript objects.

I know that RC5.Collection can read JSON strings very conveniently. I'd like to know if RC5.Collection can read JavaScript objects, for example:

Code:

---

{
    start: 0,
    end: 15,
    source: "AAA",
    type: "BBB"
}

---

IMO, the main difference between JavaScript objects and JSON strings is that Key names have no double quotes.

Quote:

---

Originally Posted by dreammanor

Qustion 042: Use RC5.Collection to read JavaScript objects.

I know that RC5.Collection can read JSON strings very conveniently. I'd like to know if RC5.Collection can read JavaScript objects, for example:

Code:

---

{
    start: 0,
    end: 15,
    source: "AAA",
    type: "BBB"
}

---

IMO, the main difference between JavaScript objects and JSON strings is that Key names have no double quotes.

---

If you mean, inputting the above notation "as String" into the RC5-JSON-parser - this would not work
(since it's not valid "JSON-string input-syntax" - only the newer JSON5-standard would allow such an "Object-String-notation").

But if you mean, whether it is possible to "hand over" such a (JavaScript internally) produced Object to the VB-side,
then that is of course possible (via JSON.stringify at the JS-side):

Code:

---

Option Explicit

Private SC As cActiveScript

Private Sub Form_Load()
  Set SC = New_c.ActiveScript("JScript9", False, False)
      SC.AddCode "function GetObject(value){var o={aProp:value}; return JSON.stringify(o)}"
End Sub
 
Private Sub Form_Click()
  Dim o As cCollection
  Set o = New_c.JSONDecodeToCollection(SC.CodeObject.GetObject(123))
  Debug.Print o!aProp
End Sub

---

Olaf

Hi Olaf, thank you for your reply. I mean the first case, which is to convert JSON5-standard string to JSON string. However, JSON.stringify seems to be able to do this indirectly.


Edit:

New_c.JSONDecodeToCollection seems unable to read Json-Array, for example:

Code:

---

Private Sub Test()
    Dim o As cCollection
    Dim s As String
   
    s = "{'start':0,'end':15,'source':'AAA','type':'BBB','items':[{'a':'AAAA','b':'BBBB','c':'CCCC'}]}"
    s = Replace(s, "'", Chr(34))
    Set o = New_c.JSONDecodeToCollection(s)
   
    MsgBox TypeName(o.Item(4))
   
End Sub

---

That is, the values of the items array cannot be read.

Quote:

---

Originally Posted by dreammanor

New_c.JSONDecodeToCollection seems unable to read Json-Array, for example:

Code:

---

Private Sub Test()
    Dim o As cCollection
    Dim s As String
   
    s = "{'start':0,'end':15,'source':'AAA','type':'BBB','items':[{'a':'AAAA','b':'BBBB','c':'CCCC'}]}"
    s = Replace(s, "'", Chr(34))
    Set o = New_c.JSONDecodeToCollection(s)
   
    MsgBox TypeName(o.Item(4))
   
End Sub

---

That is, the values of the items array cannot be read.

---

In your example above, you're not using the cCollection properly...

The .Item Method is the default-method (and can be left out).

But in either case (when it is used)...:
- cCollections of kind "JSON-Object" allow only to pass "a KeyString"
- cCollections of kind "JSON-Array" expect the Array-Index instead

If you're not sure, which kind within the parsed JSONObj-Hierarchy a current cCollection represents,
you can check it with cCollection.IsJSONObject or cCollection.IsJSONArray

The following code shows, what I mean:

Code:

---

Private Sub Test()
    Dim o As cCollection
    Dim s As String
   
    s = "{'start':0,'end':15,'source':'AAA','type':'BBB','items':[{'a':'AAAA','b':'BBBB','c':'CCCC'}]}"
    s = Replace(s, "'", Chr(34))
    Set o = New_c.JSONDecodeToCollection(s)
   
    Debug.Print o.IsJSONObject, o("items").IsJSONArray
    Debug.Print o.Item("items")(0)("a"), o.ItemByIndex(4)(0)("b")
End Sub

---

And as for JSON5-String to JSON-String conversion, you can use the JScript-eval-method like this:

Code:

---

Option Explicit

Private SC As cActiveScript

Private Sub Form_Load()
  Set SC = New_c.ActiveScript("JScript9", False, False)
      SC.AddCode "function JSON5StringToJSONString (sJSON5) {    " & _
                "  return JSON.stringify(eval( '('+sJSON5+')' ))" & _
                "}"
End Sub

'let's convert a JSON5-String with comments and direct Obj-Notation)
Private Sub Form_Click()
  Dim sJSON5 As String
  With New_c.ArrayList(vbString) '
    .Add "{ //a comment before Props, following the Obj-startdef  "
    .Add "  IntProp:  123, // a comment, following a Prop-Def   "
    .Add "  DblProp: .456,  // a NumLiteral with leading DecPoint "
    .Add "  StrProp: 'ABC', // a StringLiteral in SingleQuotes    "
    .Add "  ArrProp: [789,'XYZ'], //<-- note the trailing comma  "
    .Add "}"
    sJSON5 = .Join(vbLf)
    Debug.Print "JSON5-InputString:"; vbLf; sJSON5; vbLf
  End With
  Debug.Print "JSON-ResultString:"; vbLf; SC.CodeObject.JSON5StringToJSONString(sJSON5)
End Sub

---

The above Form-Code prints out:

Code:

---

JSON5-InputString:
{ //a comment before Props, following the Obj-startdef 
  IntProp:  123,  // a comment, following a Prop-Def   
  DblProp: .456,  // a NumLiteral with leading DecPoint
  StrProp: 'ABC', // a StringLiteral in SingleQuotes   
  ArrProp: [789,'XYZ'], //<-- note the trailing comma 
}

JSON-ResultString:
{"IntProp":123,"DblProp":0.456,"StrProp":"ABC","ArrProp":[789,"XYZ"]}

---

HTH

Olaf

Quote:

---

Originally Posted by Schmidt

In your example above, you're not using the cCollection properly...

The .Item Method is the default-method (and can be left out).

But in either case (when it is used)...:
- cCollections of kind "JSON-Object" allow only to pass "a KeyString"
- cCollections of kind "JSON-Array" expect the Array-Index instead

If you're not sure, which kind within the parsed JSONObj-Hierarchy a current cCollection represents,
you can check it with cCollection.IsJSONObject or cCollection.IsJSONArray

The following code shows, what I mean:

Code:

---

Private Sub Test()
    Dim o As cCollection
    Dim s As String
   
    s = "{'start':0,'end':15,'source':'AAA','type':'BBB','items':[{'a':'AAAA','b':'BBBB','c':'CCCC'}]}"
    s = Replace(s, "'", Chr(34))
    Set o = New_c.JSONDecodeToCollection(s)
   
    Debug.Print o.IsJSONObject, o("items").IsJSONArray
    Debug.Print o.Item("items")(0)("a"), o.ItemByIndex(4)(0)("b")
End Sub

---

---

Oh, I've asked this question before, my memory is really bad. Thanks for your reminder.

Quote:

---

Originally Posted by Schmidt

And as for JSON5-String to JSON-String conversion, you can use the JScript-eval-method like this:

Code:

---

Option Explicit

Private SC As cActiveScript

Private Sub Form_Load()
  Set SC = New_c.ActiveScript("JScript9", False, False)
      SC.AddCode "function JSON5StringToJSONString (sJSON5) {    " & _
                "  return JSON.stringify(eval( '('+sJSON5+')' ))" & _
                "}"
End Sub

'let's convert a JSON5-String with comments and direct Obj-Notation)
Private Sub Form_Click()
  Dim sJSON5 As String
  With New_c.ArrayList(vbString) '
    .Add "{ //a comment before Props, following the Obj-startdef  "
    .Add "  IntProp:  123, // a comment, following a Prop-Def   "
    .Add "  DblProp: .456,  // a NumLiteral with leading DecPoint "
    .Add "  StrProp: 'ABC', // a StringLiteral in SingleQuotes    "
    .Add "  ArrProp: [789,'XYZ'], //<-- note the trailing comma  "
    .Add "}"
    sJSON5 = .Join(vbLf)
    Debug.Print "JSON5-InputString:"; vbLf; sJSON5; vbLf
  End With
  Debug.Print "JSON-ResultString:"; vbLf; SC.CodeObject.JSON5StringToJSONString(sJSON5)
End Sub

---

The above Form-Code prints out:

Code:

---

JSON5-InputString:
{ //a comment before Props, following the Obj-startdef 
  IntProp:  123,  // a comment, following a Prop-Def   
  DblProp: .456,  // a NumLiteral with leading DecPoint
  StrProp: 'ABC', // a StringLiteral in SingleQuotes   
  ArrProp: [789,'XYZ'], //<-- note the trailing comma 
}

JSON-ResultString:
{"IntProp":123,"DblProp":0.456,"StrProp":"ABC","ArrProp":[789,"XYZ"]}

---

---

Excellent solution. Much appreciated, Olaf.

Qustion 043: Add fault tolerance to RC5.Collection.SerializeToJSONString

When JSONObject.Prop is Nothing or JSONObject.Prop is custom-object, JSONObject.SerializeToJSONString will fail.

If JSONObject could automatically convert Nothing to Null and convert custom-object to empty JSONObject, then it will be much more convenient to use.

Code:

---

Public Function SerializeToJSONString(Optional ByVal OnErrorResumeNext as Boolean = False)

End Function

---

The reason for this requirement is that when the JSONObject is extremely large, if we use code to perform fault tolerance processing, the speed of SerializeToJSONString will be greatly reduced.

Also, if JSONObject.SerializeToJSONString could add event-handler, that would be even better.

Quote:

---

Originally Posted by dreammanor

When JSONObject.Prop is Nothing or JSONObject.Prop is custom-object, JSONObject.SerializeToJSONString will fail.

---

Due to its nature, the only allowed Obj-Type in an RC5-JSON-Hierarchy-Tree is:
- the type cCollection (either of "SubKind" JSONArray, or JSONObject).

So, it's your responsibility (in your own "Fill-Routines"), to ensure that "no other ObjectType" gets added...

FWIW, below is (a fast throw) of a generic Serializer, which might accept also your above (blue marked) "custom object"
(automatically enumerating its Property-Names and Values - converting/serializing it to JSON)...

The line I've marked blue in the Code below, is the one which will ensure null in the JSON-Output
(in case you pass Nothing instead of New_c.Displays (in Form_Load)...

Note (in case you want to try this with your own "arbitrary Objects"),
that it probably will work with "Objects from Private Classes in the IDE" -
but when compiled, it will only work with "Public Classes from Dlls, OCXes or AxExes".

The simple Class-instance of type vbRichClient5.cDisplays which I've passed into as a Test-specimen,
works because it has a simple structure - and was loaded from a compiled Dll obviously...

The code below ensures that, when a given Object (like cDisplays) is Enumerable, that also its
Children are serialized (in my test-case below, all instances of cDisplay, which cDisplays enumerates)

Code:

---

Option Explicit
 
Private Sub Form_Load()
  Dim oJS As cCollection
  Set oJS = New_c.JSONObject
      oJS.Prop("Displays") = AddUnknownObjTo(New_c.JSONObject, New_c.Displays)
  Debug.Print oJS.SerializeToJSONString
End Sub
 
Function AddUnknownObjTo(jsObj As cCollection, Obj)
    If Obj Is Nothing Then Exit Function Else Set AddUnknownObjTo = jsObj
 
    Dim Props As cProperties, P As cProperty
    Set Props = New_c.Properties
        Props.BindTo Obj, False, "Items,NewEnum,_NewEnum" '<- exclude these "typical Enumerator-PropNames"
    For Each P In Props
        AddValueTo jsObj, P.Value, P.Name
    Next
 
  If IsEnumerable(Obj) Then jsObj.Prop("Items") = AddEnumerablesTo(New_c.JSONArray, Obj)
End Function

Function AddEnumerablesTo(jsArr As cCollection, Enumerable)
    Set AddEnumerablesTo = jsArr
    Dim V
    For Each V In Enumerable
        AddValueTo jsArr, V
    Next
End Function

Sub AddValueTo(jsCol As cCollection, V, Optional Key)
    If VarType(V) = vbDataObject Then Exit Sub
    If IsObject(V) Then
      jsCol.Add AddUnknownObjTo(New_c.JSONObject, V), Key
    ElseIf IsArray(V) Then
      jsCol.Add AddEnumerablesTo(New_c.JSONArray, V), Key
    Else
      jsCol.Add V, Key
    End If
End Sub

Function IsEnumerable(Obj) As Boolean
    On Error GoTo 1
      Dim V: For Each V In Obj: Exit For: Next
1  IsEnumerable = Err = 0
End Function

---

FWIW, here's my output-JSON-string (only my single NoteBook-Display got enumerated as "Sub-Item"):

Code:

---

{
  "Displays":{
    "Count":1,
    "Items":[
        {
            "DeviceName":"\\\\.\\DISPLAY1",
            "IsPrimary":true,
            "AbsoluteLeft":0,
            "AbsoluteTop":0,
            "AbsoluteRight":3840,
            "AbsoluteBottom":2160,
            "WorkLeft":255,
            "WorkTop":0,
            "WorkRight":3840,
            "WorkBottom":2160
        }
      ]
  }
}

---

HTH

Olaf

Hi Olaf, your generic Serializer is wonderful. Much appreciated.

In addition, cProperty and cProperties are very useful, and I've used them extensively in my programs.

Another problem is that my code parsing will generate a huge JSONObject, which may contain 100,000 to 1 million nodes (sub-JSONObjects) and more than 10 million properties. I wonder if there is a more efficient and lightweight JSONBag than RC5.Collection? Thanks.

That sounds more like a complete database/datatable...
What is the use of this?

Quote:

---

Originally Posted by Arnoutdv

That sounds more like a complete database/datatable...
What is the use of this?

---

Yes, I also consider using database.

I'm using UglifyJS and acorn to parse some JavaScript code. Acorn will generate nearly 75,000 JSON nodes and 400,000 JSON properties when parsing a 10,000-line JS file.

Qustion 044: Which object in RC5 can be used to simulate a JavaScript Map?

The keys of JavaScript Map can be of any type of variable, including objects and functions. I'd like to know which object in RC5 can be used to simulate a JavaScript Map? Thanks!

Quote:

---

Originally Posted by dreammanor

Qustion 044: Which object in RC5 can be used to simulate a JavaScript Map?

The keys of JavaScript Map can be of any type of variable, including objects and functions. I'd like to know which object in RC5 can be used to simulate a JavaScript Map?

---

In RC5 there's currently no such Object which allows to store "Objects as Keys"...

The cSortedDictionary and cCollection come near, because they allow "other Keys than String-Keys" (although no Keyed-Objects),
but then - they don't allow these different Key-Types to be used "in a mixed fashion" (it's either "Double-Keys" or "String-Keys" for the whole set).

What can be used instead, is my cHashD-Class (which also has a CodeBank-entry),
further below in a slight adaption (to match the "Map-usecase" a bit more)...

Native compiled, its performance is comparable to cSortedDictionary
(but due to its hash-based nature, it does not support any Sorting of course).

Here is, how to use it:

Code:

---

Private Sub Form_Click()
  With New cHashD
    .Add Me, Caption
    .Add 1&, "Long"
    .Add 1#, "Double"
    .Add Now, "Date"
    .Add "a String", "String"
 
    Dim Pair:
    For Each Pair In .Pairs
      Print TypeName(Pair(0)), Pair(1), .Item(Pair(0))
    Next
    Print
  End With
End Sub

---

And here the (still relatively small) Class-Code for cHashD

Code:

---

Option Explicit 'cHashD, Olaf Schmidt in August 2016
 
Private Type SAFEARRAY1D
  cDims As Integer
  fFeatures As Integer
  cbElements As Long
  cLocks As Long
  pvData As Long
  cElements1D As Long
  lLbound1D As Long
End Type
Private Declare Sub BindArray Lib "kernel32" Alias "RtlMoveMemory" (PArr() As Any, pSrc&, Optional ByVal CB& = 4)
Private Declare Function VariantCopy Lib "oleaut32" (Dst As Any, Src As Any) As Long
Private Declare Function VariantCopyInd Lib "oleaut32" (Dst As Any, Src As Any) As Long
 
Private Const DynTakeOver As Long = 14
Private Type HashTableEntry
  Count As Long
  DataIdxsStat(0 To DynTakeOver - 1) As Long
  DataIdxsDyn() As Long
End Type
 
Private W() As Integer, saW As SAFEARRAY1D
 
Private mLastExpectedMaxCount As Long, mEnsureUniqueKeys As Boolean, mLastH As Long
Private mCount As Long, mDTUB As Long, mHashTableSize As Long, mCompareMode As VbCompareMethod
Private mKeys(), mValues(), HashTable() As HashTableEntry

Private Sub Class_Initialize()
  saW.cDims = 1:  saW.cbElements = 2
  saW.cLocks = 1: saW.fFeatures = &H11 'FADF_AUTO=&H1 || FADF_FIXEDSIZE=&H10
  BindArray W, VarPtr(saW)
 
  mCompareMode = vbBinaryCompare
  ReInit 16384 'at startup we set it up, to behave ideally for up to 16384 Items
End Sub

Public Sub ReInit(Optional ByVal ExpectedMaxCount As Long, Optional ByVal EnsureUniqueKeys As Boolean)
  If ExpectedMaxCount <= 0 Then ExpectedMaxCount = mLastExpectedMaxCount
  If ExpectedMaxCount < 100 Then ExpectedMaxCount = 100
  mLastExpectedMaxCount = ExpectedMaxCount
  mEnsureUniqueKeys = EnsureUniqueKeys
 
  mHashTableSize = 16
  Do Until mHashTableSize * 8 > ExpectedMaxCount: mHashTableSize = mHashTableSize * 2: Loop
  If mHashTableSize > 524288 Then mHashTableSize = 524288
  ReDim HashTable(0 To mHashTableSize - 1)
 
  mDTUB = mLastExpectedMaxCount
  ReDim mKeys(0 To mDTUB)
  ReDim mValues(0 To mDTUB)
  mCount = 0
End Sub

Public Sub Clear()
  ReInit
End Sub

Public Property Get Count() As Long
  Count = mCount
End Property

Public Property Get HasUniqueKeys() As Boolean
  HasUniqueKeys = mEnsureUniqueKeys
End Property

Public Property Get StringCompareMode() As VbCompareMethod
  StringCompareMode = mCompareMode
End Property
Public Property Let StringCompareMode(ByVal RHS As VbCompareMethod)
  mCompareMode = RHS
End Property
 
Public Function Keys() As Variant()
  If mCount Then mDTUB = mCount - 1 Else Keys = Array(): Exit Function
  ReDim Preserve mKeys(0 To mDTUB): Keys = mKeys
End Function
Public Function Items() As Variant()
  If mCount Then mDTUB = mCount - 1 Else Items = Array(): Exit Function
  ReDim Preserve mValues(0 To mDTUB): Items = mValues
End Function
Public Function Pairs() As Variant() 'hand-out the Key-Values in a Pairs-Array
  If mCount = 0 Then Pairs = Array(): Exit Function
  Dim P(), i As Long
  ReDim P(0 To mCount - 1)
  For i = 0 To UBound(P)
    P(i) = Array(mKeys(i), mValues(i))
  Next
  Pairs = P
End Function
 
Public Function Exists(Key) As Boolean
  Exists = FindIndex(Key) >= 0
End Function
Public Function IndexByKey(Key) As Long
  IndexByKey = FindIndex(Key)
End Function

Public Sub Add(Key, Item)
Dim H As Long, UB As Long
  If mLastH Then
    H = mLastH: mLastH = 0
  ElseIf mEnsureUniqueKeys Then
    If FindIndex(Key, H) >= 0 Then Err.Raise 457
  Else
    H = -1: FindIndex Key, H 'a Value of -1 for H will skip the Index-Search, returning only H
  End If
 
  'add the new Pair, prolonging the Keys- and Values-arrays
  If mDTUB < mCount Then
    mDTUB = (mDTUB + 16) * 1.3
    ReDim Preserve mKeys(0 To mDTUB)
    ReDim Preserve mValues(0 To mDTUB)
  End If
  VariantCopyInd ByVal VarPtr(mValues(mCount)), ByVal VarPtr(Item)
  VariantCopyInd ByVal VarPtr(mKeys(mCount)), ByVal VarPtr(Key)
 
  'add the new DataIndex to the proper Hash-Buckets
  Select Case HashTable(H).Count
    Case Is < DynTakeOver
      HashTable(H).DataIdxsStat(HashTable(H).Count) = mCount
    Case DynTakeOver
      ReDim Preserve HashTable(H).DataIdxsDyn(DynTakeOver To DynTakeOver + 3)
      HashTable(H).DataIdxsDyn(DynTakeOver) = mCount
    Case Else
      UB = UBound(HashTable(H).DataIdxsDyn)
      If UB < HashTable(H).Count Then UB = (UB + 3) * 1.3: ReDim Preserve HashTable(H).DataIdxsDyn(DynTakeOver To UB)
      HashTable(H).DataIdxsDyn(HashTable(H).Count) = mCount
  End Select
  HashTable(H).Count = HashTable(H).Count + 1
 
  mCount = mCount + 1
End Sub

Public Property Get KeyByIndex(ByVal IndexZeroBased As Long)
  If IndexZeroBased < 0 Or IndexZeroBased >= mCount Then Err.Raise 9
  If IsObject(mKeys(IndexZeroBased)) Then Set KeyByIndex = mKeys(IndexZeroBased) Else KeyByIndex = mKeys(IndexZeroBased)
End Property

Public Property Get ItemByIndex(ByVal IndexZeroBased As Long)
  If IndexZeroBased < 0 Or IndexZeroBased >= mCount Then Err.Raise 9
  VariantCopy ItemByIndex, ByVal VarPtr(mValues(IndexZeroBased))
End Property
Public Property Let ItemByIndex(ByVal IndexZeroBased As Long, RHS)
  If IndexZeroBased < 0 Or IndexZeroBased >= mCount Then Err.Raise 9
  VariantCopyInd ByVal VarPtr(mValues(IndexZeroBased)), ByVal VarPtr(RHS)
End Property
Public Property Set ItemByIndex(ByVal IndexZeroBased As Long, RHS)
  If IndexZeroBased < 0 Or IndexZeroBased >= mCount Then Err.Raise 9
  VariantCopyInd ByVal VarPtr(mValues(IndexZeroBased)), ByVal VarPtr(RHS)
End Property

Public Property Get Item(Key)
Dim Index As Long:  Index = FindIndex(Key)
 If Index >= 0 Then VariantCopy Item, ByVal VarPtr(mValues(Index))
End Property
Public Property Let Item(Key, RHS)
Dim Index As Long:  Index = FindIndex(Key, mLastH)
 If Index = -1 Then Add Key, RHS Else VariantCopyInd ByVal VarPtr(mValues(Index)), ByVal VarPtr(RHS)
 mLastH = 0
End Property
Public Property Set Item(Key, RHS)
  Item(Key) = RHS
End Property
 
Private Function FindIndex(Key, Optional H As Long) As Long  'return -1, when no Key can be found
  Dim i As Long, S$, C@, D#, L&, F!, VT As VbVarType, HTUB As Long
  HTUB = mHashTableSize - 1
  FindIndex = H
  H = HTUB 'init the HashValue (all bits to 1)
 
  VT = VarType(Key)
  Select Case VT
    Case vbString
      If mCompareMode = 0 Then
        S = Key: saW.cElements1D = Len(S): saW.pvData = StrPtr(S)
          For i = 0 To saW.cElements1D - 1: H = (H + W(i)) * 3853 And HTUB: Next
        If FindIndex = -1 Then Exit Function 'it's a "Hash-Only" Calculation
       
        For i = 0 To HashTable(H).Count - 1
          If i < DynTakeOver Then FindIndex = HashTable(H).DataIdxsStat(i) Else FindIndex = HashTable(H).DataIdxsDyn(i)
          If VarType(mKeys(FindIndex)) = VT Then If S = mKeys(FindIndex) Then Exit Function
        Next
      Else
        S = LCase$(Key): saW.cElements1D = Len(S): saW.pvData = StrPtr(S)
          For i = 0 To saW.cElements1D - 1: H = (H + W(i)) * 3853 And HTUB: Next
        If FindIndex = -1 Then Exit Function 'it's a "Hash-Only" Calculation
       
        For i = 0 To HashTable(H).Count - 1
          If i < DynTakeOver Then FindIndex = HashTable(H).DataIdxsStat(i) Else FindIndex = HashTable(H).DataIdxsDyn(i)
          If VarType(mKeys(FindIndex)) = VT Then If StrComp(S, mKeys(FindIndex), mCompareMode) = 0 Then Exit Function
        Next
      End If
     
    Case vbObject
      L = ObjPtr(Key): saW.cElements1D = 2: saW.pvData = VarPtr(L)
        H = (H + W(0)) * 3853 And HTUB 'loop-unrolling (we have only 2 16Bit integers in the array)
        H = (H + W(1)) * 3853 And HTUB
      If FindIndex = -1 Then Exit Function 'it's a "Hash-Only" Calculation
     
      For i = 0 To HashTable(H).Count - 1
        If i < DynTakeOver Then FindIndex = HashTable(H).DataIdxsStat(i) Else FindIndex = HashTable(H).DataIdxsDyn(i)
        If VarType(mKeys(FindIndex)) = VT Then If Key Is mKeys(FindIndex) Then Exit Function
      Next
     
    Case vbCurrency
      C = Key: saW.cElements1D = 4: saW.pvData = VarPtr(C)
        H = (H + W(0)) * 3853 And HTUB 'loop-unrolling (we have only 4 16Bit integers in the array)
        H = (H + W(1)) * 3853 And HTUB
        H = (H + W(2)) * 3853 And HTUB
        H = (H + W(3)) * 3853 And HTUB
      If FindIndex = -1 Then Exit Function 'it's a "Hash-Only" Calculation
     
      For i = 0 To HashTable(H).Count - 1
        If i < DynTakeOver Then FindIndex = HashTable(H).DataIdxsStat(i) Else FindIndex = HashTable(H).DataIdxsDyn(i)
        If VarType(mKeys(FindIndex)) = VT Then If C = mKeys(FindIndex) Then Exit Function
      Next
     
    Case vbLong, vbInteger, vbByte
      L = Key: saW.cElements1D = 2: saW.pvData = VarPtr(L)
        H = (H + W(0)) * 3853 And HTUB 'loop-unrolling (we have only 2 16Bit integers in the array)
        H = (H + W(1)) * 3853 And HTUB
      If FindIndex = -1 Then Exit Function 'it's a "Hash-Only" Calculation
     
      For i = 0 To HashTable(H).Count - 1
        If i < DynTakeOver Then FindIndex = HashTable(H).DataIdxsStat(i) Else FindIndex = HashTable(H).DataIdxsDyn(i)
        Select Case VarType(mKeys(FindIndex))
          Case vbLong, vbInteger, vbByte: If L = mKeys(FindIndex) Then Exit Function
        End Select
      Next
 
    Case vbDouble
      D = Key: saW.cElements1D = 4: saW.pvData = VarPtr(D)
        H = (H + W(0)) * 3853 And HTUB 'loop-unrolling (we have only 4 16Bit integers in the array)
        H = (H + W(1)) * 3853 And HTUB
        H = (H + W(2)) * 3853 And HTUB
        H = (H + W(3)) * 3853 And HTUB
      If FindIndex = -1 Then Exit Function 'it's a "Hash-Only" Calculation
           
      For i = 0 To HashTable(H).Count - 1
        If i < DynTakeOver Then FindIndex = HashTable(H).DataIdxsStat(i) Else FindIndex = HashTable(H).DataIdxsDyn(i)
        If VarType(mKeys(FindIndex)) = VT Then If D = mKeys(FindIndex) Then Exit Function
      Next
   
    Case vbDate
      D = Key: saW.cElements1D = 4: saW.pvData = VarPtr(D)
        H = (H + W(0)) * 3853 And HTUB 'loop-unrolling (we have only 4 16Bit integers in the array)
        H = (H + W(1)) * 3853 And HTUB
        H = (H + W(2)) * 3853 And HTUB
        H = (H + W(3)) * 3853 And HTUB
      If FindIndex = -1 Then Exit Function 'it's a "Hash-Only" Calculation
           
      For i = 0 To HashTable(H).Count - 1
        If i < DynTakeOver Then FindIndex = HashTable(H).DataIdxsStat(i) Else FindIndex = HashTable(H).DataIdxsDyn(i)
        If VarType(mKeys(FindIndex)) = VT Then If D = mKeys(FindIndex) Then Exit Function
      Next
     
    Case vbSingle
      F = Key: saW.cElements1D = 4: saW.pvData = VarPtr(F)
        H = (H + W(0)) * 3853 And HTUB 'loop-unrolling (we have only 2 16Bit integers in the array)
        H = (H + W(1)) * 3853 And HTUB
      If FindIndex = -1 Then Exit Function 'it's a "Hash-Only" Calculation
           
      For i = 0 To HashTable(H).Count - 1
        If i < DynTakeOver Then FindIndex = HashTable(H).DataIdxsStat(i) Else FindIndex = HashTable(H).DataIdxsDyn(i)
        If VarType(mKeys(FindIndex)) = VT Then If F = mKeys(FindIndex) Then Exit Function
      Next
  End Select
 
  FindIndex = -1
End Function
 
Friend Sub CheckHashDistribution()
Dim i As Long, Count As Long, cc As Long, Min As Long, Max As Long
  Min = &H7FFFFFFF
  For i = 0 To UBound(HashTable)
    Count = HashTable(i).Count
    If Count Then
      If Min > Count Then Min = Count
      If Max < Count Then Max = Count
      cc = cc + 1
    End If
  Next
  Debug.Print "Distribution over a HashTable with"; UBound(HashTable) + 1; "slots:"
  Debug.Print "Used-HashSlots:"; cc
  Debug.Print "Min-Entries:"; Min
  Debug.Print "Max-Entries:"; Max
End Sub

---

HTH

Olaf

deleted...

deleted... (accidental double-post)

Hi Olaf, thank you very much for your patient and detailed reply. The performance of cHashD is impressive.

In addition, I carefully tested multiple versions of cHashD. When I changed the Key-Value from Variant-Variant to String-Vairant or String-Long, the speed of cHashD was further improved. But String-Vairant is actually faster than String-Long, I don't know why.

Edit:
I deleted the wrong test program and re-uploaded the new test program.

Quote:

---

Originally Posted by dreammanor

Hi Olaf, thank you very much for your patient and detailed reply. The performance of cHashD is impressive.

In addition, I carefully tested multiple versions of cHashD. When I changed the Key-Value from Variant-Variant to String-Vairant or String-Long, the speed of cHashD was further improved. But String-Vairant is actually faster than String-Long, I don't know why.

---

The String-Variant-based version is based on an older (in this mode slightly faster) cHashD-version.
(because the newer ones were not yet fully optimized - but I did that now...).

Here is your Zip again (which contains these Optimizations for all newer cHashD-implementations).
Attachment 175393

I've also rearranged the test-order in the Form_Click to list the Dictionaries according to their speed -
and this is the result for Binary-Comparemode (the TextCompare-mode is slightly slower, but does not change the order of this "Hit-List").

http://vbRichClient.com/Downloads/Dictionaries.png

So, now we have the <String-Key><Long-Item> combination as the winner -
but only slightly faster than <String-Key><Variant-Item>
and both not that much faster than the "Any KeyType"-"Any ItemType" variation (which came in at 3rd place).

So the question is, whether it is really worthwhile to include one of the "specialized versions" in a Dll as well (alongside the "any Key"-version).

HTH

Olaf

Quote:

---

Originally Posted by Schmidt

So, now we have the <String-Key><Long-Item> combination as the winner -

---

Very nice. Much appreciated.

Quote:

---

Originally Posted by Schmidt

So, now we have the <String-Key><Long-Item> combination as the winner -
but only slightly faster than <String-Key><Variant-Item>
and both not that much faster than the "Any KeyType"-"Any ItemType" variation (which came in at 3rd place).

So the question is, whether it is really worthwhile to include one of the "specialized versions" in a Dll as well (alongside the "any Key"-version).

---

The key-value pairs I finally need to deal with are <String-Boolean>. How to deal with key-value pairs <String-Boolean> as quickly as possible is very important to me.

Currently, the key-value pair <String-Boolean> is only 5% faster than <String-Long>, which is already satisfying me. It would be great if it could be faster.

New test project including key-value pair <String-Boolean>.

Removed meaningless question.

JavaScript: (Babel7) ES6 code conversion tool for web browsers

This question is not about VB6 and RC5.

I studied the source code of the latest babel-generator of babel7.9, but I don't know how to test (debug) it in the web browser. The latest babel7.9 only supports NodeJS, not web browsers. I'd like to know how to package the source code of babel7.9 into the code that can be used by the web browser. Thanks!

Hi all

Is there any place I can learn about the JPG class in RC5? Can't find any example usage on the Web.

New_c.JPG.DecodeJPG
New_c.JPG.EncodeJPG

Furthermore, is there any VB6 library to utilize to further compress JPG file without losing much of its quality? Like those online services from tinyjpg or similar.

Removed

Quote:

---

Originally Posted by Resurrected

Hi all

Is there any place I can learn about the JPG class in RC5? Can't find any example usage on the Web.

New_c.JPG.DecodeJPG
New_c.JPG.EncodeJPG

Furthermore, is there any VB6 library to utilize to further compress JPG file without losing much of its quality? Like those online services from tinyjpg or similar.

---

http://www.vbforums.com/showthread.p...=1#post4644043

http://www.vbforums.com/showthread.p...=1#post4644077

http://www.vbforums.com/showthread.p...=1#post4646095

Quote:

---

Originally Posted by Resurrected

Furthermore, is there any VB6 library to utilize to further compress JPG file without losing much of its quality? Like those online services from tinyjpg or similar.

---

I don't think that tinyjpg does anything special ...
IMO their algo just determines a normal (new) JPG-Encoding-Quality-factor,
based on the analysis of a Diff-image.

I think you can mimick what tinyjpg does with relative ease...

Here's (the beginning) of something like that:
- which shows the recompressed JPG (along with the used Quality and JPGsize) when you move the mouse
- and when you hold the MouseDown (whilst moving in x-direction), you'll see the Diff-Pixels to the original

Here's a link to the original (627kB) JPG, which tinyjpg is using in its own comparison:
https://tinyjpg.com/images/jpg/example-original.jpg
I've saved that into my tempfolder as "c:\temp\example-original.jpg" (needed to make the example below work)

Judging from my own "subjective visual comparison":
- with a JPG-compression-factor of 70
- I get a recompressed size of 150kB (smaller than the result on tinyjpg.com)
- as said, personally not detecting much of a difference visually

Code:

---

Option Explicit

Private Sub Form_Load()
  Me.WindowState = vbMaximized
  Cairo.ImageList.AddImage "orig", "c:\temp\example-original.jpg"
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  Dim JpgReWr() As Byte, Qual&  'rewrite the orig-JPG with varying Percent-Factors (along the X-axis)
  Qual = 100 * X / ScaleWidth
  Cairo.ImageList("orig").WriteContentToJpgByteArray JpgReWr, Qual
  Caption = "Qual: " & Qual & " Rewr.-Size: " & (UBound(JpgReWr) + 1) \ 1024 & "kB (hold down the mouse, to see a diff-image)"
 
  With Cairo.ImageList.AddImage("rewritten", JpgReWr).CreateContext
    'when a MouseButton is pressed, we show a difference-image to the original (the "blacker", the less the differences)
    If Button Then .Operator = CAIRO_OPERATOR_DIFFERENCE: .RenderSurfaceContent "orig", 0, 0
   
    'when no MouseButton is down, we just show the JPG in its current "rewrite-quality"
    Set Picture = .Surface.Picture
  End With
End Sub

Private Sub Form_Terminate()
  New_c.CleanupRichClientDll
End Sub

---

HTH

Olaf

I'd like to know whether it is possible to automatically turn the keys in a RC5.Collection into dynamic properties?

Code:

---

    Dim oItems As cCollection
   
    Set oItems = New_c.JSONObject
   
    oItems.Prop("Name") = "ABC"              ' => oItems.Name = "ABC"
    oItems.Prop("Department") = "DEF"      ' => oItems.Department = "DEF"

---

In other words, change oItems.Prop("Name") to oItems.Name.

Quote:

---

Originally Posted by dreammanor

I'd like to know whether it is possible to automatically turn the keys in a RC5.Collection into dynamic properties?

Code:

---

    Dim oItems As cCollection
   
    Set oItems = New_c.JSONObject
   
    oItems.Prop("Name") = "ABC"              ' => oItems.Name = "ABC"
    oItems.Prop("Department") = "DEF"      ' => oItems.Department = "DEF"

---

In other words, change oItems.Prop("Name") to oItems.Name.

---

Yes, since the newer RC5-versions come with the cInterfaces-Helper (vbFriendly Interface-Subclassing),
a first demo-implementation (also supporting dynamic Function-Defs) is quite straight forward:

cDynFactory

Code:

---

Option Explicit

Private Declare Function VariantCopy Lib "oleaut32" (Dst As Any, Src As Any) As Long

Implements vbIUnknown
Implements vbIDispatch
 
Private VBI As cInterfaces, SC As cActiveScript, CO As Object

Private Sub Class_Initialize()
  Set VBI = New_c.VBI
  Set SC = New_c.ActiveScript("JScript9", False, False)
  Set CO = SC.CodeObject
End Sub

'****** since this Class works as a Factory, this is the only Public Method here *******
Public Function NewDynObj() As Object 'our IDispatch-supporting DispObject, which allows LateBound Method-Calling "per Dot"
  VBI.NewInstance VBI.pVT(vtbl_IDispatch), Me, VarPtr(NewDynObj)
  CallByName CO, "eval", VbMethod, "var o_" & ObjPtr(NewDynObj) + 12 & "={props:[]}"
End Function


'************* IUnknown-Implementation *****************
Private Sub vbIUnknown_QueryInterface(UserData As Long, ByVal pVTable As Long, RefCount As Long, sReqIID As String, Unk As stdole.IUnknown)
  If VBI.IIDsEqual(sReqIID, VBI.sIID_IDispatch) Then RefCount = RefCount + 1
End Sub
Private Sub vbIUnknown_Terminate(UserData As Long, ByVal pVTable As Long)
End Sub

'************* IDispatch-Implementation ****************
Private Function vbIDispatch_GetIDForMemberName(UserData As Long, ByVal pVTable As Long, MemberName As String) As Long
  Dim so As String: so = "o_" & VarPtr(UserData)
  Dim sm As String: sm = LCase$(MemberName)
  On Error GoTo 1
  vbIDispatch_GetIDForMemberName = CallByName(CO, "eval", VbMethod, so & ".idx_" & sm)
 
1 If Err <> 0 Or vbIDispatch_GetIDForMemberName = 0 Then
    vbIDispatch_GetIDForMemberName = CallByName(CO, "eval", VbMethod, so & ".props.push('" & sm & "');" & so & "." & sm & "=null;" & so & ".idx_" & sm & "=" & so & ".props.length")
  End If
End Function

Private Function vbIDispatch_Invoke(UserData As Long, ByVal pVTable As Long, ByVal DispID As Long, ByVal CallType As VbCallType, VResult As Variant, ParamArray P() As Variant) As hResult
  If DispID < 1 Then vbIDispatch_Invoke = DISP_E_MEMBERNOTFOUND: Exit Function
 
  Dim so As String: so = "o_" & VarPtr(UserData)
  Dim sm As String: sm = CallByName(CO, "eval", VbMethod, so & ".props[" & DispID - 1 & "]")
 
  If CallType And (VbGet Or VbMethod) Then 'handle PropRead-direction or function-calls
 
    If UBound(P) < 0 Then 'might be a Prop-Get or a function-call without arguments
      so = so & "." & sm
      VariantCopy VResult, ByVal VarPtr(CallByName(CO, "eval", VbMethod, "(typeof " & so & "=='function')? " & so & "():" & so))
    Else 'a call with arguments, so it has to be a function-call
      Dim o As Object: Set o = CallByName(CO, so, VbGet)
      Select Case UBound(P) + 1 'calling-cascade for currently 6 Params max.
        Case 1: VariantCopy VResult, ByVal VarPtr(CallByName(o, sm, VbMethod, P(0)))
        Case 2: VariantCopy VResult, ByVal VarPtr(CallByName(o, sm, VbMethod, P(0), P(1)))
        Case 3: VariantCopy VResult, ByVal VarPtr(CallByName(o, sm, VbMethod, P(0), P(1), P(2)))
        Case 4: VariantCopy VResult, ByVal VarPtr(CallByName(o, sm, VbMethod, P(0), P(1), P(2), P(3)))
        Case 5: VariantCopy VResult, ByVal VarPtr(CallByName(o, sm, VbMethod, P(0), P(1), P(2), P(3), P(4)))
        Case 6: VariantCopy VResult, ByVal VarPtr(CallByName(o, sm, VbMethod, P(0), P(1), P(2), P(3), P(4), P(5)))
      End Select
    End If
   
  ElseIf CallType And (VbLet Or VbSet) Then 'handle PropWrite-direction
    If VarType(P(0)) = vbString Then
      If InStr(P(0), "function") = 1 And InStrRev(P(0), "}") = Len(P(0)) Then
        CallByName CO, "eval", VbMethod, so & "." & sm & "=" & LCase$(P(0))
      Else
        CallByName CallByName(CO, so, VbGet), sm, VbLet, P(0)
      End If
    Else
      CallByName CallByName(CO, so, VbGet), sm, VbLet, P(0)
    End If
1 End If
End Function

---

Form1

Code:

---

Option Explicit

Private DynFactory As New cDynFactory

Private Sub Form_Click()
  AutoRedraw = True: Cls
 
  Dim oD As Object 'the DynObjects always have to be defined As Object
  Set oD = DynFactory.NewDynObj 'the only method in our Factory-Class, will hand out a new "DynProp-Object"
 
  oD.foo = "foo"
  oD.bar = "bar"
  oD.foobar = "function(){return this.foo + this.bar}" '<- read-out-test for the dynamic props .foo and .bar
  oD.SomeLong = 123 'fill-in some long-value...
  oD.SomeLong = 2 * oD.SomeLong '<- over-write-test of an existing Value under the same PropertyName
  oD.TestFunc = "function(a, b){return a * b + this.SomeLong}" 'another function, this time with Param-defs
  oD.TheForm = Me 'test for storing an Object-Reference (in this case our Form in .TheForm ...  using Set is not really required)

  'Ok, now the Test-PrintOuts for the above
  Print "foo: "; oD.foo
  Print "bar: "; oD.bar
  Print "foobar: "; oD.foobar '<- note, that this is a function-call, not a property-readout
  Print "SomeLong: "; oD.SomeLong
  Print "TestFunc: "; oD.TestFunc(-4, 51) 'and our other dynamic function (called with 2 Params, which should give the right answer)
  Print "TheForm.Caption: "; oD.TheForm.Caption 'test, whether Properties of the stored Form-Reference can be accessed
End Sub

---

HTH

Olaf

Fantastic. I tested your code and it works very well. I asked this question with a try mentality, I originally thought it was impossible to get an answer. But I still got a wonderful answer/solution. Thank you so much, Olaf.

In addition, I also found a phenomenon. If I use JScript9, the code runs very well. But if I use JScript, the system prompts "Application-defined or object-defined error".

Quote:

---

Originally Posted by dreammanor

If I use JScript9, the code runs very well. But if I use JScript, the system prompts "Application-defined or object-defined error".

---

Have no time to research that behaviour with the older JScript-engine,
but my guess is, that JScript9 allows better interaction with "outside COM-Objects".

Besides, it is quite a lot faster with the supported "dyn-function-calls",
and it also supports JSON-serialization directly, which the updated Code now supports (via toJSON) as well:

cDynFactory

Code:

---

Option Explicit

Private Declare Function VariantCopy Lib "oleaut32" (Dst As Any, Src As Any) As Long

Implements vbIUnknown
Implements vbIDispatch
 
Private VBI As cInterfaces, SC As cActiveScript, CO As Object

Private Sub Class_Initialize()
  Set VBI = New_c.VBI
  Set SC = New_c.ActiveScript("JScript9", False, False)
  Set CO = SC.CodeObject
End Sub

'****** since this Class works as a Factory, this is the only Public Method here *******
Public Function NewDynObj() As Object 'our IDispatch-supporting DispObject, which allows LateBound Method-Calling "per Dot"
  VBI.NewInstance VBI.pVT(vtbl_IDispatch), Me, VarPtr(NewDynObj)
  Dim so As String: so = "o_" & ObjPtr(NewDynObj) + 12
  CallByName CO, "eval", VbMethod, "var " & so & "={props:[]}; var v" & so & "={};"
End Function


'************* IUnknown-Implementation *****************
Private Sub vbIUnknown_QueryInterface(UserData As Long, ByVal pVTable As Long, RefCount As Long, sReqIID As String, Unk As stdole.IUnknown)
  If VBI.IIDsEqual(sReqIID, VBI.sIID_IDispatch) Then RefCount = RefCount + 1
End Sub
Private Sub vbIUnknown_Terminate(UserData As Long, ByVal pVTable As Long)
End Sub

'************* IDispatch-Implementation ****************
Private Function vbIDispatch_GetIDForMemberName(UserData As Long, ByVal pVTable As Long, MemberName As String) As Long
  Dim so As String: so = "o_" & VarPtr(UserData)
  Dim sm As String: sm = LCase$(MemberName)
  If sm = "tojson" Then vbIDispatch_GetIDForMemberName = 1000: Exit Function
 
  On Error GoTo 1
  vbIDispatch_GetIDForMemberName = CallByName(CO, "eval", VbMethod, so & ".idx_" & sm)
 
1 If Err <> 0 Or vbIDispatch_GetIDForMemberName = 0 Then
    vbIDispatch_GetIDForMemberName = CallByName(CO, "eval", VbMethod, so & ".props.push('" & sm & "'); v" & so & "." & sm & "=null;" & so & ".idx_" & sm & "=" & so & ".props.length")
  End If
End Function

Private Function vbIDispatch_Invoke(UserData As Long, ByVal pVTable As Long, ByVal DispID As Long, ByVal CallType As VbCallType, VResult As Variant, ParamArray P() As Variant) As hResult
  Select Case DispID
    Case 1 To 999 'normal Prop-Range... do nothing here (proceed)
   
    Case 0 'potential JSON-input
      If CallType <> VbLet Then vbIDispatch_Invoke = DISP_E_MEMBERNOTFOUND: Exit Function
 
      Dim JSCol As cCollection, i As Long, Obj As Object
      If IsObject(P(0)) Then 'we assume an RC5.cCollection with JSON-input was passed as the initializer
        Set JSCol = P(0)
      ElseIf VarType(P(0)) = vbString Then 'we assume a JSON-String was passed
        Set JSCol = New_c.JSONDecodeToCollection(CallByName(CO, "eval", VbMethod, "JSON.stringify(eval(" & P(0) & "))"))
      Else
        vbIDispatch_Invoke = DISP_E_MEMBERNOTFOUND: Exit Function
      End If
      Set Obj = VBI.GetInstanceByUserDataOffs(UserData) 'get the current instance
      On Error Resume Next
        For i = 0 To JSCol.Count - 1 'copy the Props into the VB-DynObject
            CallByName Obj, JSCol.KeyByIndex(i), VbLet, JSCol.ItemByIndex(i)
        Next
      On Error GoTo 0
      Exit Function
     
    Case 1000 'toJSON-output-function
      If (CallType And (VbGet Or VbMethod)) = 0 Then vbIDispatch_Invoke = DISP_E_MEMBERNOTFOUND: Exit Function
      VResult = CallByName(CO, "eval", VbMethod, "JSON.stringify(vo_" & VarPtr(UserData) & ")")
      Exit Function
    Case Else: vbIDispatch_Invoke = DISP_E_MEMBERNOTFOUND: Exit Function
  End Select
 
  Dim so As String: so = "vo_" & VarPtr(UserData)
  Dim sm As String: sm = CallByName(CO, "eval", VbMethod, "o_" & VarPtr(UserData) & ".props[" & DispID - 1 & "]")
 
  If CallType And (VbGet Or VbMethod) Then 'handle PropRead-direction or function-calls
 
    If UBound(P) < 0 Then 'might be a Prop-Get or a function-call without arguments
      so = so & "." & sm
      VariantCopy VResult, ByVal VarPtr(CallByName(CO, "eval", VbMethod, "(typeof " & so & "=='function')? " & so & "():" & so))
    Else 'a call with arguments, so it has to be a function-call
      Dim o As Object: Set o = CallByName(CO, so, VbGet)
      Select Case UBound(P) + 1 'calling-cascade for currently 6 Params max.
        Case 1: VariantCopy VResult, ByVal VarPtr(CallByName(o, sm, VbMethod, P(0)))
        Case 2: VariantCopy VResult, ByVal VarPtr(CallByName(o, sm, VbMethod, P(0), P(1)))
        Case 3: VariantCopy VResult, ByVal VarPtr(CallByName(o, sm, VbMethod, P(0), P(1), P(2)))
        Case 4: VariantCopy VResult, ByVal VarPtr(CallByName(o, sm, VbMethod, P(0), P(1), P(2), P(3)))
        Case 5: VariantCopy VResult, ByVal VarPtr(CallByName(o, sm, VbMethod, P(0), P(1), P(2), P(3), P(4)))
        Case 6: VariantCopy VResult, ByVal VarPtr(CallByName(o, sm, VbMethod, P(0), P(1), P(2), P(3), P(4), P(5)))
      End Select
    End If
   
  ElseIf CallType And (VbLet Or VbSet) Then 'handle PropWrite-direction
    If VarType(P(0)) = vbString Then
      If InStr(P(0), "function") = 1 And InStrRev(P(0), "}") = Len(P(0)) Then
        CallByName CO, "eval", VbMethod, so & "." & sm & "=" & LCase$(P(0))
      Else
        CallByName CallByName(CO, so, VbGet), sm, VbLet, P(0)
      End If
    Else
      CallByName CallByName(CO, so, VbGet), sm, VbLet, P(0)
    End If
1 End If
End Function

---

Here the updated Usage-example, which also shows, how to initialize (or merge existing) Properties from a JSON5-string.
(a little performance-test for the dynamic-functions is included as well... about 100Tsd calls per second are possible with JScript9)
Form1

Code:

---

Option Explicit

Private DynFactory As New cDynFactory

Private Sub Form_Click()
  AutoRedraw = True: Cls
 
  Dim oD As Object
  Set oD = DynFactory.NewDynObj
 
  'explicit initializing of Props
  oD.foo = "foo"
  oD.bar = "bar"
  oD.SomeLong = 123 'fill-in some long...
 
  'merging additional props from a JSON5-string is now also possible
  oD = "{foo2:'foo2', FloatValue: .123}"
 
  oD.foobar = "function(){return this.foo + this.bar}" '<- read-out-test for the dynamic props .foo and .bar
  oD.SomeLong = 2 * oD.SomeLong '<- over-write-test of an existing Value under the same PropertyName
  oD.TestFunc = "function(a, b){return a * b + this.SomeLong}" 'another function, this time with Param-defs
  oD.TheForm = Me 'test for storing an Object-Reference (in this case our Form in .TheForm ... Set is not really required)

  'Ok, now the Test-PrintOuts for the above
  Print "foo: "; oD.foo
  Print "bar: "; oD.bar
  Print "foobar: "; oD.foobar '<- note, that this is a function-call, not a property-readout
  Print "SomeLong: "; oD.SomeLong
  Print "TestFunc: "; oD.TestFunc(-4, 51)
  Print "TheForm.Caption: "; oD.TheForm.Caption

  Debug.Print oD.toJSON 'also added, was serialization-support for the current Props (not the functions)
 
  New_c.Timing True
  Dim i As Long
  For i = 1 To 100000 'about 100,000 calls per second are possible on the dynamic functions
'    Call oD.foobar
    Call oD.TestFunc(-4, 15)
  Next
  Caption = New_c.Timing
End Sub

---

Olaf

Hi Olaf, it's wonderful. Much appreciated.

In order to adapt to JScript9, I have started to migrate the development environment from XP to Win7. Hope this process can proceed smoothly.