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 - 要素を降順でソートする。
と、いうことでソースはこちら。
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 |
' 動的配列 - 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 |