Hi jj2007, The RE I mentioned above means Regular-Expression, not RichEdit.Quote:
Originally Posted by jj2007
Printable View
Hi jj2007, The RE I mentioned above means Regular-Expression, not RichEdit.Quote:
Originally Posted by jj2007
Question 38: A strange problem with ActiveScript
If a function in ActiveScript has no input parameters, the function cannot return the function value, but it can be obtained using CallByName. E.g:
Code:Set SC = New_c.ActiveScript("JScript9", False, False)
SC.AddCode "function Test() { " & _
" return arguments.length;" & _
"}"
Set CO = SC.CodeObject
MsgBox CO.Test()
Just for the experiment I just impl a VbPeg based JS tokenizer w/ the requirements of the RE "competition" but also one that strips whitespace outside of string literals (minifies JS) and it turned quite fast
Here is the PEG grammar for the simple tokenizerCode:---------------------------
VBPCRE2Minimal
---------------------------
VBScript--RegExp: 7'641.44msec
RC5--ActiveScript: 9'452.59msec
jpbro--VBPCRE2: 11'239.36msec
PEG: 3'798.06msec
---------------------------
OK
---------------------------
VbPeg produced a 500 lines recursive-descent parser as a VB6 class that is included in the attachment.Code:start
= token+
token
= < SPACE > { '--- do nothing }
| < LINE_COMMENT | BLOCK_COMMENT > { '--- do nothing }
| < IDENT > { '--- do nothing }
| < STRING > { '--- do nothing }
| < . > { '--- do nothing }
SPACE = [ \t\r\n]+
LINE_COMMENT = '//' [^\r\n]* '\r'? '\n'?
BLOCK_COMMENT = '/*' (!'*/' .)* '*/'
IDENT = [a-zA-Z][a-zA-Z]*
STRING = '"' [^"]* '"'
cheers,
</wqw>
This not a problem I can fix easily in RC5...Quote:
Originally Posted by dreammanor
It is a general problem with the CodeObject of the MS ActiveScripting-support in JScript-mode...
Also the MS-ScriptControl shows this behaviour in JScript-mode, as the following test shows...:
As an explanation might serve, that JS allows to "pass functions around as normal Objects",Code:Private Sub Form_Load()
With CreateObject("ScriptControl")
.Language = "JScript"
.AddCode "function Test(){ return 42 }"
MsgBox .CodeObject.Test() 'this returns the "whole Function" instead of 42
MsgBox .Run("Test") 'whilst this will return the correct answer
End With
With CreateObject("ScriptControl")
.Language = "VBScript"
.AddCode "Function Test(): Test = 42: End Function"
MsgBox .CodeObject.Test() 'this will return the correct answer
MsgBox .Run("Test") 'this will return the correct answer
End With
End Sub
when you leave out the parentheses...
Here some DemoCode, which shows that the "weird behaviour" (as seen in the JS-CodeObject-call without arguments),
makes perfect sense in that "function-passing-context"...
I've marked the line which shows "why this stuff is, as it is" in dark-red above...Code:Private Sub Form_Load()
Dim SC As cActiveScript, CO As Object, MyObj As Object
Set SC = New_c.ActiveScript("JScript9", False, False)
Set CO = SC.CodeObject
'let's say, you have a predefined Object in your JSCode like this one (MyObj)
SC.AddCode "var MyObj = {}; " & _
" MyObj.OnClick=null;" & _
" MyObj.fireOnClick = function(info){ if (this.OnClick) return this.OnClick(info)}"
'it contains an EventHandler-slot (OnClick) which is not (yet) defined
'but also (in the last line) a pre-implemented Method which "fires the Event to the Handler" (if there is one)
Set MyObj = CO.MyObj 'now, for convenience at the VB-COM-side, we store this JS-Obj in a VB-Object-Variable
'...
'later on in your code, you might want to define an Event-Handler for MyObj.OnClick
'so you will add a JS-function which implements such an EventHandler with your own specific code
SC.AddCode "function MyOnClickHandler(info){ return 'from inside my handler: ' + info }"
'what you can do now (and where the previously seen "weird behaviour" comes into play),
'is a "direct assignment of the function itself" (via the CodeObject)
Set MyObj.OnClick = CO.MyOnClickHandler '<- so here the "no passed arguments return the whole function"-case makes sense
MsgBox MyObj.fireOnClick("Hello World") 'test it
End Sub
HTH
Olaf
Nice...Quote:
Originally Posted by wqweto
FWIW, here's a performance-improvement for the ActiveScript-JSCode based replacements
(which also corrects a few errors in the reg-expressions):
With these changes it is now faster than the (VB)Scripting-Regex-Code -Code:With New_c.StringBuilder
.AppendNL "'use strict';"
.AppendNL "var regCmtSngLine1 = /(^\/\/.*?(\r|\n))/gm ;"
.AppendNL "var regCmtSngLine2 = /(?!([""']([^\\[""']]*).*[""'])).(\/\/.*?(\r|\n))/g ;"
.AppendNL "var regCmtMultiLine = /(\/\*[\w\'\s\r\n\*]*\*\/)/g ;"
.AppendNL "var regLet = /^\s*[\{\(]*let \b/gm ;"
.AppendNL "var regEmptyLines = /^\s*[\r\n]/gm ;"
.AppendNL "function CompressJavaScript(code){"
.AppendNL " return code"
.AppendNL " .replace(regCmtSngLine1,'')"
.AppendNL " .replace(regCmtSngLine2,'')"
.AppendNL " .replace(regCmtMultiLine,'')"
.AppendNL " .replace(regLet,'var ')"
.AppendNL " .replace(regEmptyLines,'')"
.AppendNL "}"
mSC.AddCode .ToString
End With
(also note, that "JScript" works - surprisingly - a bit faster than the newer "JScript9" engine).
Olaf
One can use the Call statement to force execution but cannot retrieve the result unfortunately.Quote:
Originally Posted by Schmidt
Here are more tests w/ the JScript version
cheers.Code:MsgBox CallByName(.CodeObject, "Test", VbMethod) '-- executes and returns 42
MsgBox CallByName(.CodeObject, "Test", VbMethod Or VbGet) '--- returns source
.CodeObject.Test '--- discards source
Call .CodeObject.Test '--- executes and discards 42
</wqw>
I learned some valuable knowledge from you again. Much appreciated.Quote:
Originally Posted by Schmidt
It's wonderful, thank you very much, wqweto. I'll take a closer look at why your cCompressPEG has such high performance. I'll upload a new test program in a while.Quote:
Originally Posted by wqweto
Also, I'd like to know if your PEG could generate a RegExp parser instead of VBScript.RegExp? Thanks again.
Wonderful. I'll upload a new test program in a while. Thank you very much, Olaf.Quote:
Originally Posted by Schmidt
This is really good news for me because I use JScript more than JScript9.Quote:
Originally Posted by Schmidt
Here is the new test program. The new test program uses Olaf's better and more accurate regular expression patterns,
Olaf's regular expression patterns not only improves the performance of RC5.ActiveScript, but also improves the performance of VBScript.RegExp. Now, the performance difference between RC5.ActiveScript and VBScript.RegExp is very small.
But it is strange that the speed of jpbro's method is reduced by 3 times after using the new regular expression patterns.
Code:VBScript----RegExp: 7,939.62msec
Olaf--ActiveScript: 11,237.48msec (JScript9)
Olaf--ActiveScript: 8,664.79msec (JScript)
jpbro------VBPCRE2: 11,601.61msec
wqweto---------PEG: 6,488.98msec
@dreammanor, I can't reproduce your timings (though I still come in last place unsurprisingly considering the competition).
Using your latest demo compiled (that uses pcre2_substitute method instead of the older, slower Split and loop approach that @wqweto's timings were based on) I'm getting the following:
Code:VBScript---RegExp: 5,258.81msec
Olaf--ActiveScript: 6,714.93msec (JScript)
jpbro------VBPCRE2: 6,848.40msec
wqweto---------PEG: 4,067.19msec
Hi jpbro, are you using the test code in post #190?Quote:
Originally Posted by jpbro
Yes, I'm running it compiled too in case that makes a difference.
I was running each test separately and compiling my own results, but I get similar numbers using the Comparison Test button:
Code:VBScript--RegExp: 5,444.31msec
Olaf--ActiveScript: 9,265.44msec (JScript9)
Olaf--ActiveScript: 6,841.76msec (JScript)
jpbro--VBPCRE2: 7,238.35msec
wqweto--PEG: 4,410.03msec
This is really strange. I restarted my Windows 10 computer and tested again with the same result as post #190. That is, after using the new regular expression patterns, your method is 3-4 times slower on my computer. I guess it's because the new regular expression patterns splits the Comment pattern into three separate patterns.
Note: I also tested it on an XP computer, and the test results were the same.
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).Quote:
Originally Posted by dreammanor
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.
cheers,
</wqw>
Understand. Thank you for your detailed explanation.Quote:
Originally Posted by wqweto
Agree completely. I'm already trying to write a lexer/parser. But I still need to use some regular expressions in the lexer/parser.Quote:
Originally Posted by wqweto
Hi Olaf, is your regular expression pattern "[\w\'\s\r\n\*]" equivalent to "[^]" ?
In addition, "\w" can only match characters in the Latin alphabet, not Chinese characters.
Also, if "\'" is included in the pattern, why not include double-quote and "`"? Thanks.
Question 39: VB.Array or RC5.ArrayList?
Since VB6.Array has some limitations (details :Add an element to an arbitrary array), I need to encapsulate an Array object of my own. Now I have two options:
(1) Encapsulating an array of VB variables, for example: Private mItems () as Variant ...
(2) Encapsulate vbRichClient5.ArrayList, for example: Private mItems As vbRichClient5.cArrayList
This array object will be used a lot as a base object (to replace VB.Array). I wonder if this array object is built on the basis of vbRichClient5.ArrayList, will it take up a lot of memory? Hope to hear Olaf's suggestions, thanks.
MyArrayObject:
Code:Option Explicit
Private mItems() As Variant
'Or
'Private mItems As vbRichClient5.cArrayList '???
Public Property Get Item(ByVal Index As Long) As Variant
Item = mItems(Index)
End Property
Public Property Let Item(ByVal Index As Long, NewVal As Variant)
mItems(Index) = NewVal
End Property
Public Function NewEnum() As IUnknown
Set NewEnum = mItems.[_NewEnum]
End Function
...
...
...
...
Private Sub Class_Initialize()
mItems = Array()
End Sub
If it's only about additional "For Each support", then the cArrayList can now be used directly (without extra-wrapper-class),Quote:
Originally Posted by dreammanor
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!Quote:
Originally Posted by Schmidt
Removed a meaningless post.
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?Quote:
Originally Posted by wqweto
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
There are 4 pragmas that one might need to set before creating a new database and/or issuing other pragmas (like journal_mode).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"
These were listed on sqlite-users mailing list as:
- pragma auto_vacuum
- pragma encoding
- pragma page_size
- pragma data_store_directory
cheers,
</wqw>
If you instantiate a new ADODB-connection-object,Quote:
Originally Posted by wqweto
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
. . . works of course. Just had to set auto_vacuum *before* journal_mode.Code:oConn.CreateNewDB "D:\TEMP\aaa.db"
oConn.Execute "PRAGMA auto_vacuum=incremental"
oConn.Execute "PRAGMA journal_mode=WAL"
cheers,
</wqw>
Yep - and as a side-note for RC5-users ...Quote:
Originally Posted by wqweto
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)...
OlafCode:'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)
Hi wqweto, thanks for your question. I've put your question on the list in post#1.Quote:
Originally Posted by wqweto
Hi @wqweto, I'd like to know more about PEG.Quote:
Originally Posted by wqweto
(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:
IMO, the main difference between JavaScript objects and JSON strings is that Key names have no double quotes.Code:{
start: 0,
end: 15,
source: "AAA",
type: "BBB"
}
If you mean, inputting the above notation "as String" into the RC5-JSON-parser - this would not workQuote:
Originally Posted by dreammanor
(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):
OlafCode: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
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:
That is, the values of the items array cannot be read.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
In your example above, you're not using the cCollection properly...Quote:
Originally Posted by dreammanor
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:
And as for JSON5-String to JSON-String conversion, you can use the JScript-eval-method like this: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
The above Form-Code prints out: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
HTHCode: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"]}
Olaf
Oh, I've asked this question before, my memory is really bad. Thanks for your reminder.Quote:
Originally Posted by Schmidt
Excellent solution. Much appreciated, Olaf.Quote:
Originally Posted by Schmidt
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.
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.Code:Public Function SerializeToJSONString(Optional ByVal OnErrorResumeNext as Boolean = False)
End Function
Also, if JSONObject.SerializeToJSONString could add event-handler, that would be even better.
Due to its nature, the only allowed Obj-Type in an RC5-JSON-Hierarchy-Tree is:Quote:
Originally Posted by dreammanor
- 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)
FWIW, here's my output-JSON-string (only my single NoteBook-Display got enumerated as "Sub-Item"):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
HTHCode:{
"Displays":{
"Count":1,
"Items":[
{
"DeviceName":"\\\\.\\DISPLAY1",
"IsPrimary":true,
"AbsoluteLeft":0,
"AbsoluteTop":0,
"AbsoluteRight":3840,
"AbsoluteBottom":2160,
"WorkLeft":255,
"WorkTop":0,
"WorkRight":3840,
"WorkBottom":2160
}
]
}
}
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?
Yes, I also consider using database.Quote:
Originally Posted by Arnoutdv
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!
In RC5 there's currently no such Object which allows to store "Objects as Keys"...Quote:
Originally Posted by dreammanor
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:
And here the (still relatively small) Class-Code for cHashDCode: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
End With
End Sub
HTHCode: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
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.
The String-Variant-based version is based on an older (in this mode slightly faster) cHashD-version.Quote:
Originally Posted by dreammanor
(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
Very nice. Much appreciated.Quote:
Originally Posted by Schmidt
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.Quote:
Originally Posted by Schmidt
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
http://www.vbforums.com/showthread.p...=1#post4644043Quote:
Originally Posted by Resurrected
http://www.vbforums.com/showthread.p...=1#post4644077
http://www.vbforums.com/showthread.p...=1#post4646095
I don't think that tinyjpg does anything special ...Quote:
Originally Posted by Resurrected
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
HTHCode: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
Olaf
I'd like to know whether it is possible to automatically turn the keys in a RC5.Collection into dynamic properties?
In other words, change oItems.Prop("Name") to oItems.Name.Code:Dim oItems As cCollection
Set oItems = New_c.JSONObject
oItems.Prop("Name") = "ABC" ' => oItems.Name = "ABC"
oItems.Prop("Department") = "DEF" ' => oItems.Department = "DEF"
Yes, since the newer RC5-versions come with the cInterfaces-Helper (vbFriendly Interface-Subclassing),Quote:
Originally Posted by dreammanor
a first demo-implementation (also supporting dynamic Function-Defs) is quite straight forward:
cDynFactory
Form1Code: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
HTHCode: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
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".
Have no time to research that behaviour with the older JScript-engine,Quote:
Originally Posted by dreammanor
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
Here the updated Usage-example, which also shows, how to initialize (or merge existing) Properties from a JSON5-string.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
(a little performance-test for the dynamic-functions is included as well... about 100Tsd calls per second are possible with JScript9)
Form1
OlafCode: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
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.