64bit環境で VBA、VBScriptからJScript(javascript)の関数を使用する。
”書いて忘れる”様
vba/vbscript:64bit環境でJSONをパース
http://bougyuusonnin.seesaa.net/article/446183415.html
”@nukie_53”様
Qiita VBAからJScriptのfunctionオブジェクトを使用する（64bit対応）
https://qiita.com/nukie_53/items/297e524bcc8e43f9b5d1
”Beginner'sMemo初心者備忘録”様
64ビット環境でのScriptControlの代わり
http://www.ka-net.org/office/of32.html
ありがとうございました。学習させていただきました。使わせていただきます。
上記3つの記事の使用方法を、学習後、もしやと思い、
吉岡さんのソースにあたってみた
googleで”吉岡照雄”で検索するとでてきます。
作者: 吉岡 照雄 - Vector
https://www.vector.co.jp/vpack/browse/person/an010222.html
Ctrl + Fで検索してください
●history.VBS
「履歴」をHTMLファイルにする、「履歴」のサブフォルダを開くVBScript
＜中身＞
History.TXT
History.VBS
History98.VBS
TechNote.TXT
最近使ったファイルメニュー.VBS
履歴／今日／マイ コンピュータ.VBS
”History98.VBS” の中に CreateObject("htmlfile")の恐ろしいサンプルがあった。
2006-07-02に既に検討済みとは、本当に驚愕した。
＜見所＞
(1) VBScript中でJavaScriptの new Array()を実現
(2) VBScript中で(1)のArray の push 、shiftを行う
(3) VBScriptから JScriptの定義関数を呼び出し、
さらにそこからVBScriptの定義関数を使用させる
吉岡さんの”History98.VBS”から、抽出、改変しました。
Sub from_history98_vbs()
Dim oHTML
Set oHTML = CreateObject("htmlfile")
oHTML.parentWindow.execScript _
"function sortNum(data){var jsArr = data.split(/\t/) ;" & _
" jsArr.sort(compareNum) ;" & _
" return jsArr.join(""\t"") ;" & _
" } ;" & _
"function compareNum(a,b){if(a * 1.0 > b * 1.0) return 1 ;" & _
" else return -1 ;" & _
" } ;" & _
"function sortStr(data){var jsArr = data.split(/\t/) ;" & _
" jsArr.sort(compareStr) ;" & _
" return jsArr.join(""\t"") ;" & _
" } ;" & _
"function compareStr(a,b){if(a + """" > b + """") return 1 ;" & _
" else return -1 ;" & _
" } ;"
Dim myData
myData = _
"999,777,888,9,7,8,99,77,88,333,111,222,3,1,2,33,11,22,666,444,555,6,4,5,66,44,55"
Dim myArr
Dim JSFunc
Set JSFunc = oHTML.parentWindow
myArr = JSFunc.sortNum(Join(Split(myData, ","), vbTab))
MsgBox Join(Split(myArr, vbTab), vbLf)
myArr = JSFunc.sortStr(Join(Split(myData, ","), vbTab))
MsgBox Join(Split(myArr, vbTab), vbLf)
End Sub
＜20190205追記STA＞Excelでの負荷テストサンプル
Sub sheed_test01()
Dim ix As Integer
Dim iy As Integer
Dim WS1 As Worksheet
Set WS1 = Sheets("Sheet1")
Dim WSFUNC As WorksheetFunction
Set WSFUNC = Application.WorksheetFunction
Application.ScreenUpdating = False
For ix = 1 To 1000
For iy = 1 To 12
WS1.Cells(ix, iy).Value = WSFUNC.RandBetween(0, 30)
Next
Next
Application.ScreenUpdating = True
MsgBox "Done"
End Sub
Sub from_history98_vbs_B()
Dim oHTML
Set oHTML = CreateObject("htmlfile")
oHTML.parentWindow.execScript _
"function sortNum(data){var jsArr = data.split(/\t/) ;" & _
" jsArr.sort(compareNum) ;" & _
" return jsArr.join(""\t"") ;" & _
" } ;" & _
"function compareNum(a,b){if(a * 1.0 > b * 1.0) return 1 ;" & _
" else return -1 ;" & _
" } ;" & _
"function sortStr(data){var jsArr = data.split(/\t/) ;" & _
" jsArr.sort(compareStr) ;" & _
" return jsArr.join(""\t"") ;" & _
" } ;" & _
"function compareStr(a,b){if(a + """" > b + """") return 1 ;" & _
" else return -1 ;" & _
" } ;"
Dim WS1 As Worksheet
Dim WS2 As Worksheet
Dim WS3 As Worksheet
Set WS1 = Sheets("Sheet1")
Set WS2 = Sheets("Sheet2")
Set WS3 = Sheets("Sheet3")
Dim JSFunc
Set JSFunc = oHTML.parentWindow
Dim WSFUNC As WorksheetFunction
Set WSFUNC = Application.WorksheetFunction
Dim ix As Integer
Dim myData As Variant
Dim myArr As String
Application.ScreenUpdating = False
For ix = 1 To 1000
myData = WSFUNC.Transpose(WSFUNC.Transpose(WS1.Range("A" & ix & ":L" & ix).Value))
myArr = JSFunc.sortNum(Join(myData, vbTab))
WS2.Range("A" & ix & ":L" & ix).Value = Split(myArr, vbTab)
Next
For ix = 1 To 1000
myData = WSFUNC.Transpose(WSFUNC.Transpose(WS1.Range("A" & ix & ":L" & ix).Value))
myArr = JSFunc.sortStr(Join(myData, vbTab))
WS3.Range("A" & ix & ":L" & ix).Value = Split(myArr, vbTab)
Next
Application.ScreenUpdating = True
MsgBox "Done"
End Sub
＜20190205追記END＞
＜20190220追記STA＞
'Sub JScrip_in_VBA4()
Dim nJS
Dim oJS
Dim strPathIn
Dim myRec
Dim oADOST_R
strPathIn = "C:\Users\user\Desktop\underscore-min.js"
Set oADOST_R = CreateObject("ADODB.Stream")
Dim adReadLine: adReadLine = -2
oADOST_R.Type = 2 '-1--adTypeBinary , 2--adTypeText
oADOST_R.Charset = "Utf-8"
oADOST_R.LineSeparator = -1 ' -1 CrLf , 10 Lf , 13 Cr
oADOST_R.Open
oADOST_R.LoadFromFile = strPathIn
myRec = ""
Do While Not oADOST_R.EOS
myRec = myRec & oADOST_R.ReadText(adReadLine) & vbCrLf
Loop
oADOST_R.Close
Set oADOST_R = Nothing
Dim oHTML
Set oHTML = CreateObject("htmlfile")
oHTML.ParentWindow.execscript myRec & vbCrLf & _
"function shuffle(data){var jsArr = data.split(/\t/) ;" & _
" var jsArr2 = _.shuffle(jsArr) ;" & _
" return jsArr2.join(""\t"") ;" & _
" } ;" & _
"function num_map(data){var jsArr = data.split(/\t/) ;" & _
" var jsArr2 = _.map(jsArr, function(v){ ;" & _
" return v * 5;}) ;" & _
" return jsArr2.join(""\t"") ;" & _
" } "
Dim JSFunc
Set JSFUNC = oHTML.ParentWindow
Dim mydata
mydata = " 1, 2, 3, 4, 5, 6, 7, 8, 9,10"
Dim res_data
res_data = JSFUNC.shuffle(Join(Split(mydata, ","), vbTab))
MsgBox Join(Split(res_data, vbTab), vbLf)
res_data = JSFUNC.num_map(Join(Split(mydata, ","), vbTab))
MsgBox Join(Split(res_data, vbTab), vbLf)
'End Sub
＜20190220追記END＞
