vbscriptで、よくSystem.Collection.ArrayListを使っていたけども、こんな情報を見つけた。
Windows10で実行したスクリプトでArrayListの作成がエラーになった
まだ、そういった場面には出会ったことないんだけども
RPA風vbsめーかー作ってる手前、無視できない情報だ。
っということで、.Netバージョンを意識せず使えればと思って
Dictionaryオブジェクトを内包してArrayListっぽいクラスを書いてみました。
実装している機能。
・プロパティ
Count - 要素数を取得。
Item(index) - 要素を取得。
Items - 要素をコレクションで取得。
・メソッド
Add(Object) - 要素を追加。型はなんでもOK。
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