00001 ' Attribute VB_Name = "XStringCollection"
00002 '! @brief String専用コレクション。キーでのアクセス、配列インデックスでのアクセスを提供する
00003 '! <p>Collectionが使えないのでしょうがなくこんなクラスをでっち上げ。配列では面倒(Dictionaryを使ったときのキー順序が不明だから)</p>
00004 Class XStringCollection
00005 Private arr
00006 Private keys
00007 Private cnt
00008 Public debugmode
00009
00010 Private orderdKey
00011 ''--------------------------------------------
00012 '* @brief キー付きでオブジェクトをコレクションに追加する
00013 '* @note 追加する順序はキーの昇順であること。(findIndexの都合)
00014 ''--------------------------------------------
00015 Public Function add(obj,key)
00016 ''keyが既にあればそのオブジェクトを置き換え
00017 Dim idx
00018
00019 idx = findIndex(key)
00020 If (idx < 0) Then '見つからない
00021 If((cnt) >= UBound(arr)) Then
00022 Redim Preserve arr(cnt)
00023 End If
00024 idx = cnt
00025 addKey key,idx
00026 cnt = cnt + 1 '' 同じキーがあるなら件数は不変
00027 End If
00028 arr(idx) = obj
00029 add = obj
00030
00031
00032 End Function
00033
00034 Private Function addKey(key,idx)
00035 Dim newKey
00036 Set newKey = New XStringCollectionKey
00037 newKey.key = key
00038 newKey.idx = idx
00039
00040
00041 if(cnt = 0) Then
00042 Set keys(0,0) = newKey
00043 Exit Function
00044 End If
00045
00046 Dim i
00047 Dim j
00048 ''
00049 Dim found
00050 found = false
00051 Dim procCount
00052 procCount = 0
00053
00054 Dim prev
00055 Dim fromnum
00056 Dim tonum
00057 fromnum = 0
00058 tonum= UBound(keys,2)
00059
00060 if(keys(0,0).key = key) Then 'キーリストの先頭だった
00061 Set keys(0,0) = newKey
00062 Exit Function
00063 End If
00064 if(keys(0,tonum).key = key) Then 'キーリストの最後だった
00065 Set keys(0,tonum) = newKey
00066 Exit Function
00067 End If
00068
00069 if(keys(0,tonum).key < key) Then 'キーリストの最後よりも大きい
00070 Redim Preserve keys(100,tonum + 1)
00071 For j = 0 To 100
00072 Set keys(j,tonum + 1 ) = Nothing
00073 Next
00074 Set keys(0,tonum + 1 ) = newKey
00075 Exit Function
00076 End If
00077
00078
00079 fromnum = 0
00080 tonum= UBound(keys,2)
00081 do until found
00082 i = Round((fromnum + tonum) / 2)
00083
00084 if(keys(0,i).key = key) Then
00085 found = True
00086 Exit Function
00087 End If
00088 if(i = fromnum Or i = tonum) Then
00089 ''もうこれ以上分割できない
00090 if(keys(0,fromnum).key = key) Then
00091 Exit Function
00092 ElseIf(keys(0,tonum).key = key) Then
00093 Exit Function
00094 End If
00095 For j = 0 To 100
00096 If keys(j,fromnum) Is Nothing Then
00097 Set keys(j,fromnum) = newKey
00098 Exit Function
00099 End If
00100 If keys(j,fromnum).key = key Then
00101 Exit Function
00102 End If
00103
00104 Next
00105 Exit Do
00106 End If
00107
00108 if(keys(0,i).key > key) Then
00109 tonum = i
00110 ElseIf(keys(0,i).key < key) Then
00111 fromnum = i
00112 End If
00113 procCount = procCount + 1
00114 If (procCount > cnt) Then
00115 Exit Do
00116 End If
00117 loop
00118
00119 Exit Function
00120
00121 End Function
00122 ''--------------------------------------------
00123 '* @brief 指定されたキーの位置を見つける。
00124 '* @note 見つからなければ負数を返す。
00125 ''--------------------------------------------
00126 Private Function findIndex(key)
00127 if(cnt = 0) Then
00128 findIndex = -1
00129 Exit Function
00130 End If
00131 Dim i
00132 Dim found
00133 found = false
00134
00135 Dim procCount
00136 procCount = 0
00137 Dim prev
00138 Dim fromnum
00139 Dim tonum
00140 fromnum = 0
00141 tonum= UBound(keys,2)
00142 if(keys(0,0).key = key) Then
00143 findIndex = keys(0,0).idx
00144 found = True
00145 Exit Function
00146 End If
00147
00148 if(keys(0,tonum).key = key) Then
00149 findIndex = keys(0,tonum).idx
00150 found = True
00151 Exit Function
00152 End If
00153
00154 fromnum = 0
00155 tonum= UBound(keys,2)
00156 do until found
00157 i = Round((fromnum + tonum) / 2)
00158
00159 if(keys(0,i).key = key) Then
00160 findIndex = keys(0,i).idx
00161 found = True
00162 Exit Function
00163 End If
00164 if(i = fromnum Or i = tonum) Then
00165 ''もうこれ以上分割できない
00166 if(keys(0,fromnum).key = key) Then
00167 findIndex = keys(0,fromnum).idx
00168 found = True
00169 Exit Function
00170 ElseIf(keys(0,tonum).key = key) Then
00171 findIndex = keys(0,tonum).idx
00172 found = True
00173 Exit Function
00174 End If
00175 For j = 0 To 100
00176 If keys(j,fromnum) Is Nothing Then
00177 findIndex = -1
00178 Exit Function
00179 End If
00180 If keys(j,fromnum).key = key Then
00181 findIndex = keys(j,fromnum).idx
00182 found = True
00183 Exit Function
00184 End If
00185
00186 Next
00187
00188 Exit Do
00189 End If
00190
00191 if(keys(0,i).key > key) Then
00192 tonum = i
00193 ElseIf(keys(0,i).key < key) Then
00194 fromnum = i
00195 End If
00196 procCount = procCount + 1
00197 If (procCount > cnt) Then
00198 Exit Do
00199 End If
00200 loop
00201
00202 findIndex = -1
00203 Exit Function
00204
00205 End Function
00206
00207 ''--------------------------------------------
00208 '* @brief 添え字でオブジェクトを取得。
00209 '* @note 範囲外なら""を返す。
00210 ''--------------------------------------------
00211 Public Function getAt(idx)
00212 if(idx >= cnt) Then '' array out of bounds
00213 getAt = ""
00214 Exit Function
00215 End If
00216
00217 if(idx < 0) Then '' invalid index
00218 getAt = ""
00219 Exit Function
00220 End If
00221
00222
00223 getAt = arr(idx)
00224 End Function
00225
00226 ''--------------------------------------------
00227 '* @brief キー指定でオブジェクトを取得。
00228 '* 該当キーがなければ""を返す。
00229 ''--------------------------------------------
00230 Public Function getItem(key)
00231 Dim idx
00232 idx = findIndex(key)
00233 If idx < 0 Then
00234 getItem = ""
00235 Exit Function
00236 End If
00237
00238 getItem = getAt(idx)
00239 Exit Function
00240
00241 End Function
00242
00243 ''--------------------------------------------
00244 '* @brief コレクションのサイズを返す
00245 ''--------------------------------------------
00246 Public Function getSize()
00247 getSize = cnt
00248 End Function
00249
00250 ''--------------------------------------------
00251 '* @brief コレクションのサイズを設定する。
00252 '* @note 予めRedimしておいた方がメモリーを有効に使える場合に使用する。
00253 '* 但し、オブジェクトの入ってない要素が存在するとまずいので最終的に実際のサイズを設定すること。
00254 ''--------------------------------------------
00255 Public Function setSize(c)
00256 If(cnt < c) Then
00257 ''サイズが大きくなる時はあまった部分にNullをつめておく
00258 Redim Preserve arr(c -1)
00259 Redim Preserve keys(c -1)
00260 Dim i,j
00261 For i = cnt To UBound(arr)
00262 arr(i) = ""
00263 For j = 0 To 100
00264 Set keys(j,i ) = Nothing
00265 Next
00266
00267 Next
00268 ''cnt = UBound(arr) + 1
00269 Else
00270 ''サイズが同じか小さくなる時は無条件でサイズ変更してよい
00271 cnt = c
00272 Redim Preserve arr(cnt -1)
00273 Redim Preserve keys(cnt -1)
00274 End If
00275
00276 End Function
00277
00278 ''--------------------------------------------
00279 '* @brief 指定位置のキーを返す。
00280 ''--------------------------------------------
00281 Public Function getKeyAt(i)
00282
00283 if(i >= cnt) Then '' array out of bounds
00284 getKeyAt = Null
00285 Exit Function
00286 End If
00287
00288 if(i < 0) Then '' invalid index
00289 getKeyAt = Null
00290 Exit Function
00291 End If
00292
00293
00294 getKeyAt = keys(i)
00295 End Function
00296
00297 Public Sub dumpKeys()
00298 Wscript.echo "---- dump keys ----"
00299 Dim i,j
00300 For i = 0 To ubound(keys,2) - 1
00301 For j = 0 To 100
00302 If keys(j,i) Is Nothing Then
00303 Else
00304 Wscript.echo "keys " & keys(j,i).key & ":" & keys(j,i).idx
00305 End If
00306 Next
00307 Next
00308 Wscript.echo "---- dump end ----"
00309 End Sub
00310
00311 ''debug out
00312 Public Sub debugout(msg)
00313 Wscript.echo msg
00314 End Sub
00315 ''--------------------------------------------
00316 '* @brief デフォルトの初期化
00317 ''--------------------------------------------
00318 Public Sub Class_Initialize()
00319 cnt = 0
00320 Redim arr(0)
00321 Redim keys(100,0)
00322 Dim i
00323 For i = 0 To 100
00324 Set keys(i,0) = Nothing
00325 Next
00326 End Sub
00327
00328 ''--------------------------------------------
00329 '* @brief デフォルトの破棄
00330 '* @note arrに含まれていた要素の参照を誰かが保持しているなら自力で破棄させること
00331 ''--------------------------------------------
00332 Public Sub Class_Terminate()
00333 Redim arr(0) 'これで全ての参照がなくなるはずなので開放される?
00334 Dim i,j
00335 For i = 0 To ubound(keys,2) - 1
00336 For j = 0 To 100
00337 Set keys(j,i) = Nothing
00338 Next
00339 Next
00340 Redim keys(0,0)
00341 End Sub
00342
00343 end class
00344
00345 Class XStringCollectionKey
00346 Dim key
00347 Dim idx
00348 End Class