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