Skip to content

Instantly share code, notes, and snippets.

@furyutei

furyutei/0.README.md

Last active July 17, 2025 22:31
Show Gist options

  • Select an option

    Learn more about clone URLs
  • Save furyutei/7db8461ee439ad38e93bd4ed7a071f10 to your computer and use it in GitHub Desktop.

Select an option

Learn more about clone URLs
Save furyutei/7db8461ee439ad38e93bd4ed7a071f10 to your computer and use it in GitHub Desktop.
Download ZIP
[Excel][VBA] VBA上でJScriptの配列(Array)を操作する試み
Raw
0.README.md

[Excel][VBA] VBA上でJScriptの配列(Array)を操作する試み

VBA上でMicrosoft HTML Object Library（HTMLDocument／CreateObject("htmlfile")）経由でJScriptの配列(Array)を使えればちょっと便利なんじゃ？ と思って試していたら、例によってはまってしまったので、備忘を兼ねて。

ソースコード

Raw
Mod_JsArray.vba
Option Explicit
Public Function NewJsArray(Optional ByRef InitVbArray As Variant) As Object
Static HtmlDoc As Object
Static SavedKeyDic As Object
Dim VbKey As Variant
Dim JsKey As Variant
If (HtmlDoc Is Nothing) Or (SavedKeyDic Is Nothing) Then
Set HtmlDoc = CreateObject("htmlfile")
' Set HtmlDoc = New HTMLDocument ' "Microsoft HTML Object Library"への参照設定が必要
Call HtmlDoc.write("<!doctype html><!-- saved from url=(0014)about:internet --><html><head><meta http-equiv=""X-UA-Compatible"" content=""IE=edge"" /></head><body></body></html>")
'[備忘] [Mark of the Web (MOTW)](https://learn.microsoft.com/ja-jp/previous-versions/windows/internet-explorer/ie-developer/compatibility/ms537628(v=vs.85))やmeta[http-equiv="X-UA-Compatible"]の設定は無くても動作するかも？
With HtmlDoc.parentWindow
Debug.Assert ((LCase(.navigator.appVersion) Like "* trident/7*") And (HtmlDoc.documentMode = 11)) ' HTMLDocumentが未対応バージョンのときは停止
.execScript Join(Array( _
"Object.defineProperty(Array.prototype,'count',{enumerable:false,configurable:true,get:function(){return this.length;}});", _
"Array.prototype.at=function(index){return this[(index<0)?(index+this.length):index];};", _
"Array.prototype.set=function(index,value){this[(index<0)?(index+this.length):index]=value; return this;};", _
"Array.prototype.clear=function(){this.length=0; return this;};", _
"Array.prototype.convertFrom=function(sourceVbArray){this.splice.apply(this,[0,this.length].concat(new VBArray(sourceVbArray).toArray())); return this;};", _
"// [備忘] sourceVbArrayはVariant()型であること（String()型等はエラーになる）", _
"Array.prototype.convertTo=function(){var dic=new ActiveXObject('Scripting.Dictionary'); this.forEach(function(v,i){dic.Add(i,v);}); return dic.Items();};", _
"this.ExtendArrayProperty=function(jsKey,vbKey){Object.defineProperty(Array.prototype,vbKey,{enumerable:false,configurable:true,get:function(){return this[jsKey];}});};", _
"this.NewArray=function(){return [];};" _
), vbLf)
Set SavedKeyDic = GetKeyDic()
For Each VbKey In SavedKeyDic.Keys()
JsKey = SavedKeyDic(VbKey)
If JsKey <> VbKey Then Call .ExtendArrayProperty(JsKey, VbKey)
Next
End With
End If
With HtmlDoc.parentWindow
Dim KeyDic As Object: Set KeyDic = GetKeyDic()
For Each VbKey In KeyDic.Keys()
If Not SavedKeyDic.Exists(VbKey) Then
JsKey = KeyDic(VbKey)
If JsKey <> VbKey Then Call .ExtendArrayProperty(JsKey, VbKey)
SavedKeyDic(VbKey) = JsKey
End If
Next
Dim JsArray As Object: Set JsArray = .NewArray(Null) ' [備忘] メソッドを引数なしで呼びだした場合は(JScriptの)関数オブジェクトが返されてしまうため、ダミーの引数(Null)を付けて呼び出している
Select Case True
Case IsError(InitVbArray), IsMissing(InitVbArray), Not IsArray(InitVbArray)
' 何もしない
Case Else
Call JsArray.ConvertFrom(ConvertArrayToVariantArray(InitVbArray)) ' [備忘] convertFrom()は引数がVariant()型でないと失敗する
End Select
Set NewJsArray = JsArray
End With
End Function
'Public Function ConvertArrayToJsArray(SourceArray As Variant, Optional ByVal JsArray As Object) As Object
' If JsArray Is Nothing Then
' Set JsArray = NewJsArray()
' Else
' Call JsArray.Clear(Null)
' End If
' Dim Index As Long
' For Index = LBound(SourceArray) To UBound(SourceArray)
' Call JsArray.Push(SourceArray(Index))
' Next
' Set ConvertArrayToJsArray = JsArray
'End Function
Public Function ConvertArrayToJsArray(SourceArray As Variant, Optional ByVal JsArray As Object) As Object
If JsArray Is Nothing Then Set JsArray = NewJsArray()
Call JsArray.ConvertFrom(ConvertArrayToVariantArray(SourceArray)) ' [備忘] convertFrom()は引数がVariant()型でないと失敗する
Set ConvertArrayToJsArray = JsArray
End Function
'Public Function ConvertJsArrayToArray(ByVal JsArray As Object, Optional ByVal Origin As Long = 0) As Variant
' ReDim DestArray(Origin To Origin + JsArray.Count - 1) As Variant
' Dim Index As Long
' For Index = 0 To JsArray.Count - 1
' SetValue(DestArray(Origin + Index)) = JsArray.At(Index)
' Next
' ConvertJsArrayToArray = DestArray
'End Function
Public Function ConvertJsArrayToArray(ByVal JsArray As Object, Optional ByVal Origin As Long = 0) As Variant
Dim DestArray As Variant: DestArray = JsArray.ConvertTo(Null)
If Origin <> 0 And 0 < JsArray.Count Then
ReDim Preserve DestArray(Origin To Origin + JsArray.Count - 1)
End If
ConvertJsArrayToArray = DestArray
End Function
Function ConvertArrayToVariantArray(SourceArray As Variant) As Variant
If TypeName(SourceArray) = "Variant()" Then
ConvertArrayToVariantArray = SourceArray
Exit Function
End If
Dim FromNumber As Long: FromNumber = LBound(SourceArray)
Dim ToNumber As Long: ToNumber = UBound(SourceArray)
If FromNumber > ToNumber Then
ConvertArrayToVariantArray = VBA.Array()
Exit Function
End If
ReDim DestArray(FromNumber To ToNumber)
Dim Index As Long
For Index = FromNumber To ToNumber
SetValue(DestArray(Index)) = SourceArray(Index)
Next
ConvertArrayToVariantArray = DestArray
End Function
Private Function GetKeyDic() As Object
'[備忘]
' プロパティ名やメソッド名等、VBAでは大文字・小文字が同一視される(case-insensitive)のに対して、JScriptでは区別される(case-sensitive)ため、VBAからの呼び出し時に名前が一致しない場合がある
' この対策として、感嘆符演算子(Exclamation Point (!) Operator)を使ったときにはキーの大文字・小文字はVBA上の表現に連動することを利用して、VBAのプロパティ名→JScriptのプロパティ名を関連付ける
' ※参考: https://x.com/nukie_53/status/1945826323106275526
'
'[TODO]
' 意図したとおりにならない（大文字・小文字が一致しない）場合がある模様
' 例) !UnShift = "unshift" となっているのに、DictionaryのKeyとしては"Unshift"が設定されたりする等（うまくいく場合もある）
Dim KeyDic As Object: Set KeyDic = CreateObject("Scripting.Dictionary")
With KeyDic
.CompareMode = vbBinaryCompare
'[備忘] 使用する可能性のあるプロパティ／メソッドを列挙しておくこと
'!<VbKey> = "<JsKey>"
' ネイティブプロパティ／メソッド
!Concat = "concat"
!Join = "join"
!Length = "length"
!Pop = "pop"
!Push = "push"
!Shift = "shift"
!Slice = "slice"
!Splice = "splice"
!UnShift = "unshift"
' 独自拡張プロパティ／メソッド
!Count = "count"
!At = "at"
!Set = "set"
!Clear = "clear"
!ConvertFrom = "convertFrom"
!ConvertTo = "convertTo"
End With
Set GetKeyDic = KeyDic
End Function
Private Property Let SetValue(Variable As Variant, Value As Variant)
If IsObject(Value) Then
Set Variable = Value
ElseIf VarType(Value) = vbDataObject Then
Set Variable = Value
Else
Let Variable = Value
End If
End Property
Raw
Mod_TestJsArray.vba
Option Explicit
Sub Main()
Dim JsArray, JsArray2, JsArray3, Val
Set JsArray = NewJsArray()
Echo "[1] JsArray.Push()"
Call JsArray.Push(1, 2, "ABC")
ShowJsArray JsArray
Set JsArray2 = NewJsArray()
Echo "[2] JsArray2.Push()"
Call JsArray2.Push(999, "DEF")
ShowJsArray JsArray2
Echo "[3] [].Concat(JsArray1, JsArray2) → JsArray3"
Set JsArray3 = NewJsArray().Concat(JsArray, JsArray2)
ShowJsArray JsArray3
Echo "[4] JsArray3.Set() ※ひとつの値を更新"
Call JsArray3.Set(1, "<Updated>") ' CallByName(JsArray3, 1, VbLet, "<Updated>")
ShowJsArray JsArray3
Echo "[5] JsArray3.Slice() → JsArray"
Set JsArray = JsArray3.Slice(1, 4)
ShowJsArray JsArray
Echo "[6] JsArray.UnShift(JsArray3)"
Call JsArray.UnShift(JsArray3)
ShowJsArray JsArray
Echo "[7] JsArray.At(0) ※JsArray3を指す"
ShowJsArray JsArray.At(0)
Echo "※ObjPtr(JsArray.At(0)) = ObjPtr(JsArray3): " & (ObjPtr(JsArray.At(0)) = ObjPtr(JsArray3)) & vbCrLf
Echo "[8] JsArray.Pop()"
Val = JsArray.Pop(Null) ' CallByName(JsArray, "pop", VbMethod)
' [TODO] メソッドを引数なしで呼びだした場合、(JScriptの)関数オブジェクトが返されてしまう
' →とりあえず、ダミーの引数(Nullなど)を指定するか、CallByNameを用いてVbMethod指定で呼び出すことで対処
ShowJsArray JsArray
Echo "※Popされた値(Val): " & Val & vbCrLf
Echo "[9] JsArray.Shift()"
Set Val = JsArray.Shift(Null) ' CallByName(JsArray, "shift", VbMethod)
ShowJsArray JsArray
Echo "※Shiftされたオブジェクト(Val):"
ShowJsArray Val
Echo "※ObjPtr(Val) = ObjPtr(JsArray3): " & (ObjPtr(Val) = ObjPtr(JsArray3)) & vbCrLf
End Sub
Private Sub ShowJsArray(JsArray)
Echo JsArray.Join(", ")
Echo "Count: " & JsArray.Count
Dim Index As Long
For Index = 0 To JsArray.Count - 1
Echo Index & ": " & JsArray.At(Index) ' CallByName(JsArray, Index, VbGet)
Next
Echo ""
End Sub
Private Sub Echo(Text)
Debug.Print Text
End Sub
@furyutei
Copy link
Author

furyutei commented Jul 17, 2025

Mod_TestJsArray.Main実行時のイミディエイトウィンドウ出力例

[1] JsArray.Push()
1, 2, ABC
Count: 3
0: 1
1: 2
2: ABC

[2] JsArray2.Push()
999, DEF
Count: 2
0: 999
1: DEF

[3] [].Concat(JsArray1, JsArray2) → JsArray3
1, 2, ABC, 999, DEF
Count: 5
0: 1
1: 2
2: ABC
3: 999
4: DEF

[4] JsArray3.Set() ※ひとつの値を更新
1, <Updated>, ABC, 999, DEF
Count: 5
0: 1
1: <Updated>
2: ABC
3: 999
4: DEF

[5] JsArray3.Slice() → JsArray
<Updated>, ABC, 999
Count: 3
0: <Updated>
1: ABC
2: 999

[6] JsArray.UnShift(JsArray3)
1,<Updated>,ABC,999,DEF, <Updated>, ABC, 999
Count: 4
0: 1,<Updated>,ABC,999,DEF
1: <Updated>
2: ABC
3: 999

[7] JsArray.At(0) ※JsArray3を指す
1, <Updated>, ABC, 999, DEF
Count: 5
0: 1
1: <Updated>
2: ABC
3: 999
4: DEF

※ObjPtr(JsArray.At(0)) = ObjPtr(JsArray3): True

[8] JsArray.Pop()
1,<Updated>,ABC,999,DEF, <Updated>, ABC
Count: 3
0: 1,<Updated>,ABC,999,DEF
1: <Updated>
2: ABC

※Popされた値(Val): 999

[9] JsArray.Shift()
<Updated>, ABC
Count: 2
0: <Updated>
1: ABC

※Shiftされたオブジェクト(Val):
1, <Updated>, ABC, 999, DEF
Count: 5
0: 1
1: <Updated>
2: ABC
3: 999
4: DEF

※ObjPtr(Val) = ObjPtr(JsArray3): True

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment