[VBS]ArrayListの代替クラス

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