vbscriptで、よくSystem.Collection.ArrayListを使っていたけども、こんな情報を見つけた。
Windows10で実行したスクリプトでArrayListの作成がエラーになった
まだ、そういった場面には出会ったことないんだけども
RPA風vbsめーかー作ってる手前、無視できない情報だ。
っということで、.Netバージョンを意識せず使えればと思って
Dictionaryオブジェクトを内包してArrayListっぽいクラスを書いてみました。
実装している機能。
・プロパティ
Count - 要素数を取得。
Item(index) - 要素を取得。
Items - 要素をコレクションで取得。
・メソッド
Add(Object) - 要素を追加。型はなんでもＯＫ。
Clear - 配列を初期化。
Clone - コピーを生成して取得。
Concat(Object) - 配列を統合する。
Contains(Object) - 配列に含まれるかを返す。
Filter(Pattern) - フィルタ済みの配列を返す。
Join - 配列を文字列化してカンマ区切りで繋げた文字列を返す。
JoinSep(Separator) - 配列を文字列化してSeparatorで繋げた文字列を返す。
Sort - 要素を昇順でソートする。
Reverse - 要素を降順でソートする。
と、いうことでソースはこちら。
' 動的配列 - System.Collection.ArrayListが動かない環境があるらしい。
' Dictionaryを内包してArrayListっぽいクラスにしてみた。
' 【参考】：https://evergreen-nage.blog.so-net.ne.jp/2018-06-16
Class clsArrayList
Private innerItems
Public Property Get Count
Count = innerItems.Count
End Property
Public Property Get Items
Items = innerItems.Items
End Property
Private Sub Class_Initialize
Set innerItems = CreateObject("Scripting.Dictionary")
End Sub
Private Sub Class_Terminate
Set innerItems = Nothing
End Sub
Public Function Item(ByVal idx)
If innerItems.Exists(idx) Then
If IsObject(innerItems(idx)) Then
Set Item = innerItems(idx)
Else
Item = innerItems(idx)
End If
Else
Item = -1
End If
End Function
Public Sub Add(ByRef Val)
innerItems.Add UBound(innerItems.Keys) + 1, Val
End Sub
Public Sub Clear()
innerItems.RemoveAll
End Sub
Public Function Clone()
Dim cloneAry
Set cloneAry = New clsArrayList
For Each i In innerItems.Items
cloneAry.Add i
Next
Set Clone = cloneAry
End Function
Public Sub Concat(ByRef Val)
Dim i
If TypeName(Val) = "clsArrayList" then
For Each i In Val.Items
innerItems.Add i
Next
Else
Select Case VarType(Val)
Case 8194, 8195, 8196, 8197, 8198, 8199, 8200, 8201, 8202, 8203, 8204
For Each i In Val
innerItems.Add i
Next
Case Else
innerItems.Add Val
End Select
End If
End Sub
Public Function Contains(ByRef Obj)
Dim Rslt, oType, itm, tmpFlg
Rslt = False
oType = TypeName(Obj)
On Error Resume Next
For Each itm In innerItems.Items
If TypeName(itm) = oType Then
If IsObject(itm) Then
If itm Is Obj Then Rslt = True
ElseIf IsArray(itm) Then
If UBound(itm) = UBound(Obj) Then
tmpFlg = True
For i = 0 To UBound(i)
If itm(i) <> Obj(i) Then tmpFlg = False
Next
Rslt = Rslt Or tmpFlg
End If
Else
If itm = Obj Then Rslt = True
End If
End If
Next
On Error GoTo 0
Contains = Rslt
End Function
' 要素をフィルタして返す
Public Function Filter(ByVal Pattern)
Dim Reg, RegPtn, FilAry
Set FilAry = New clsArrayList
Set Reg = CreateObject("VBScript.RegExp")
RegPtn = Replace(Pattern, "*", ".*")
RegPtn = Replace(RegPtn, "?", ".")
RegPtn = "^" & RegPtn & "$"
Reg.Pattern = RegPtn
For Each i In innerItems.Items
If Reg.Test(ItemToString(i)) Then FilAry.Add i
Next
Set Filter = FilAry
End Function
' 結合
Public Function Join()
Join = JoinSep(", ")
End Function
Public Function JoinSep(ByVal separator)
Dim Rslt, i
For Each i In InnerItems.Items
If Len(Rslt) > 0 Then Rslt = Rslt & separator
Rslt = Rslt & ItemToString(i)
Next
JoinSep = Rslt
End Function
' 文字列として要素を取得
Private Function ItemToString(ByRef itm)
Dim bf
Select Case TypeName(itm)
Case "File", "Folder"
ItemToString = "{" & TypeName(itm) & " : """ & itm.Name & """}"
Case Else
Select Case VarType(itm)
Case 2, 3, 4, 5, 6, 7, 11, 12, 17
ItemToString = itm
Case 8
ItemToString = """" & itm & """"
Case 9
ItemToString = "{" & TypeName(itm) & "}"
Case 8194, 8195, 8196, 8197, 8198, 8199, 8200, 8203
bf = ""
For Each i In itm
If Len(bf) > 0 Then bf = bf & ", "
bf = bf & i
Next
ItemToString = "[" & bf & "]"
Case 8201, 8202, 8204
bf = ""
For Each i In itm
If Len(bf) > 0 Then bf = bf & ", "
bf = bf & """" & i & """"
Next
ItemToString = "[" & bf & "]"
Case Else
ItemToString = "{" & TypeName(itm) & "(" & VarType(itm) & ")}"
End Select
End Select
End Function
' ソート 昇順
Public Sub Sort()
Dim itms ,i ,tmpDic
itms = innerItems.Items
For i = 0 To UBound(itms) - 1
Dim j
For j = i + 1 To UBound(itms)
If CompareTo(itms(j), itms(i)) < 0 Then
Call swap(itms(i), itms(j))
End If
Next
Next
Set tmpDic = CreateObject("Scripting.Dictionary")
For i = 0 To UBound(itms)
tmpDic.Add i, itms(i)
Next
Set innerItems = tmpDic
End Sub
' ソート 降順
Public Sub Reverse()
Dim itms ,i ,tmpDic
itms = innerItems.Items
For i = 0 To UBound(itms) - 1
Dim j
For j = i + 1 To UBound(itms)
If CompareTo(itms(j), itms(i)) > 0 Then
Call swap(itms(i), itms(j))
End If
Next
Next
Set tmpDic = CreateObject("Scripting.Dictionary")
For i = 0 To UBound(itms)
tmpDic.Add i, itms(i)
Next
Set innerItems = tmpDic
End Sub
' 要素の比較
Private Function CompareTo(ByRef x, ByRef y)
Dim xType, yType, xVal, yVal
xType = TypeName(x)
yType = TypeName(y)
If xType = yType Then
If xType = "Boolean" Then
If x = y Then
CompareTo = 0
ElseIf x = False And y = True Then
CompareTo = -1
Else
CompareTo = 1
End If
Exit Function
End If
' 型によって規定のプロパティでソートできる様に。
If xType = "File" Or xType = "Folder" Then
xVal = x.Name
yVal = y.Name
Else
xVal = x
yVal = y
End If
If xVal = yVal Then
CompareTo = 0
ElseIf xVal < yVal Then
CompareTo = -1
Else
CompareTo = 1
End If
Else
' 型の違うオブジェクトは型名でソート
If xType = yType Then
CompareTo = 0
ElseIf xType < yType Then
CompareTo = -1
Else
CompareTo = 1
End If
End If
End Function
' 要素の入れ替え
Private Sub swap(ByRef x, ByRef y)
Dim d
SetVariable d, x
SetVariable x, y
SetVariable y, d
End Sub
Private Function SetVariable(ByRef TargetVal, ByRef SrcVal)
If IsObject(SrcVal) Then
Set TargetVal = SrcVal
Else
TargetVal = SrcVal
End If
End Function
End Class