Re: The 1001 questions about vbRichClient5 (2020-02-14)
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).
Re: The 1001 questions about vbRichClient5 (2020-02-14)
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.
Re: The 1001 questions about vbRichClient5 (2020-02-14)
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
Re: The 1001 questions about vbRichClient5 (2020-02-14)
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)
Re: The 1001 questions about vbRichClient5 (2020-02-14)
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
Last edited by Schmidt; Feb 23rd, 2020 at 08:00 AM.
Re: The 1001 questions about vbRichClient5 (2020-02-14)
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.
Re: The 1001 questions about vbRichClient5 (2020-02-14)
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.
Re: Qustion 042: Use RC5.Collection to read JavaScript objects
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
Re: The 1001 questions about vbRichClient5 (2020-03-09)
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.
Last edited by dreammanor; Mar 10th, 2020 at 10:19 AM.
Re: The 1001 questions about vbRichClient5 (2020-03-09)
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"]}
Re: The 1001 questions about vbRichClient5 (2020-03-09)
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.
Re: The 1001 questions about vbRichClient5 (2020-03-09)
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"]}
Qustion 043: Add fault tolerance to RC5.Collection.SerializeToJSONString
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.
Last edited by dreammanor; Mar 16th, 2020 at 05:00 AM.
Re: Qustion 043: Add fault tolerance to RC5.Collection.SerializeToJSONString
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"):
Re: The 1001 questions about vbRichClient5 (2020-03-13)
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.
Re: The 1001 questions about vbRichClient5 (2020-03-13)
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?
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!
Re: Qustion 044: Which object in RC5 can be used to simulate a JavaScript Map?
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
Re: The 1001 questions about vbRichClient5 (2020-03-17)
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.
Last edited by dreammanor; Mar 18th, 2020 at 10:10 AM.
Re: The 1001 questions about vbRichClient5 (2020-03-17)
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). HashD_Test_2020_opt.zip
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").
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).
Re: The 1001 questions about vbRichClient5 (2020-03-17)
Originally Posted by Schmidt
So, now we have the <String-Key><Long-Item> combination as the winner -
Very nice. Much appreciated.
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.
Last edited by dreammanor; Mar 19th, 2020 at 10:02 AM.
Re: The 1001 questions about vbRichClient5 (2020-03-31)
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!
Last edited by dreammanor; Apr 4th, 2020 at 05:38 AM.
Re: The 1001 questions about vbRichClient5 (2020-03-31)
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.
Re: The 1001 questions about vbRichClient5 (2020-03-31)
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.
Re: The 1001 questions about vbRichClient5 (2020-03-31)
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
Re: Qustion 045: Turn the keys in a RC5.Collection into dynamic properties
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
Last edited by Schmidt; Apr 18th, 2020 at 02:20 PM.
Reason: small performance-update
Re: The 1001 questions about vbRichClient5 (2020-04-17)
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".
Last edited by dreammanor; Apr 19th, 2020 at 10:55 AM.
Re: The 1001 questions about vbRichClient5 (2020-04-17)
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
Originally Posted by Schmidt
Reply With Quote
