00001 ' Attribute VB_Name = "XCollection" 00002 00003 '! @brief オブジェクトのコレクションクラス。 00004 '! <p>Collectionが使えないのでしょうがなくこんなクラスをでっち上げ。配列では面倒 00005 '! Dictionaryを使えば早いかも知れない。</p> 00006 Class XCollection 00007 Private arr 00008 Private keys 00009 Private cnt 00010 Public debugmode 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 Redim Preserve keys(cnt) 00024 End If 00025 idx = cnt 00026 cnt = cnt + 1 '' 同じキーがあるなら件数は不変 00027 End If 00028 If(IsObject(obj)) Then 00029 Set arr(idx) = obj 00030 Set add = obj 00031 Else 00032 arr(idx) = obj 00033 add = obj 00034 End If 00035 00036 keys(idx) =CStr( key ) ''キーにオブジェクトは使えない(オブジェクトの比較がIsしかできないと同じ内容の時、という比較が出来ないから) 00037 00038 00039 End Function 00040 00041 '-------------------------------------------- 00042 '* @brief キーなし付きでオブジェクトをコレクションに追加する 00043 '* @note キーはインデックスの昇順であること。(findIndexの都合) 00044 ''-------------------------------------------- 00045 Public Function add2(obj) 00046 ''keyが既にあればそのオブジェクトを置き換え 00047 Dim idx 00048 Dim key 00049 If((cnt) >= UBound(arr)) Then 00050 Redim Preserve arr(cnt) 00051 Redim Preserve keys(cnt) 00052 End If 00053 00054 cnt = cnt + 1 '' 同じキーがあるなら件数は不変 00055 idx = cnt - 1 00056 key = Zero(idx,15) 00057 If(IsObject(obj)) Then 00058 Set arr(idx) = obj 00059 Set add2 = obj 00060 Else 00061 arr(idx) = obj 00062 add2 = obj 00063 End If 00064 00065 keys(idx) =CStr( key ) ''キーにオブジェクトは使えない(オブジェクトの比較がIsしかできないと同じ内容の時、という比較が出来ないから) 00066 00067 00068 End Function 00069 00070 '-------------------------------------------- 00071 '* @brief 指定されたキーの位置を見つける。 00072 '* @return 見つからなければ負数を返す。 00073 ''-------------------------------------------- 00074 Private Function findIndex(key) 00075 if(cnt = 0) Then 00076 findIndex = -1 00077 Exit Function 00078 End If 00079 ''キー配列の頭から探す(bin searchができればその方が良い) 00080 Dim i 00081 ' For i = 0 To cnt - 1 00082 ' If(keys(i) = key) Then 00083 ' findIndex = i 00084 ' Exit Function 00085 ' End If 00086 ' Next 00087 00088 '' 00089 Dim found 00090 found = false 00091 i = Round((cnt-1) / 2) 00092 Dim procCount 00093 procCount = 0 00094 Dim prev 00095 Dim fromnum 00096 Dim tonum 00097 fromnum = 0 00098 tonum= cnt -1 00099 if(keys(0) = key) Then 00100 findIndex = 0 00101 found = True 00102 Exit Function 00103 End If 00104 if(keys(cnt - 1) = key) Then 00105 findIndex = cnt - 1 00106 found = True 00107 Exit Function 00108 End If 00109 00110 '' fromnum = 0 00111 '' tonum= cnt -1 00112 '' do until found 00113 '' i = Round((fromnum + tonum) / 2) 00114 '' 00115 '' if(keys(i) = key) Then 00116 '' findIndex = i 00117 '' found = True 00118 '' Exit Function 00119 '' End If 00120 '' if(i = fromnum Or i = tonum) Then 00121 '' ''もうこれ以上分割できない 00122 '' if(keys(fromnum) = key) Then 00123 '' findIndex = fromnum 00124 '' found = True 00125 '' Exit Function 00126 '' ElseIf(keys(tonum) = key) Then 00127 '' findIndex = tonum 00128 '' found = True 00129 '' Exit Function 00130 '' End If 00131 '' Exit Do 00132 '' End If 00133 '' 00134 '' if(keys(i) > key) Then 00135 '' tonum = i 00136 '' ElseIf(keys(i) < key) Then 00137 '' fromnum = i 00138 '' End If 00139 '' procCount = procCount + 1 00140 '' If (procCount > cnt) Then 00141 '' Exit Do 00142 '' End If 00143 '' loop 00144 00145 '' Wscript.echo "見つからなかったので頭から" 00146 For i = 0 To cnt - 1 00147 If(keys(i) = key) Then 00148 findIndex = i 00149 Exit Function 00150 End If 00151 Next 00152 00153 findIndex = -1 00154 Exit Function 00155 00156 End Function 00157 00158 '-------------------------------------------- 00159 '* @brief 添え字でオブジェクトを取得。 00160 '* @return 範囲外ならNothingを返す。 00161 '-------------------------------------------- 00162 Public Function getAt(idx) 00163 if(idx >= cnt) Then '' array out of bounds 00164 Set getAt = Nothing 00165 Exit Function 00166 End If 00167 00168 if(idx < 0) Then '' invalid index 00169 Set getAt = Nothing 00170 Exit Function 00171 End If 00172 00173 00174 If(IsObject(arr(idx))) Then 00175 Set getAt = arr(idx) 00176 Else 00177 getAt = arr(idx) 00178 End If 00179 End Function 00180 00181 ''-------------------------------------------- 00182 '* @brief キー指定でオブジェクトを取得。 00183 '* @return 該当キーがなければNothingを返す。 00184 ''-------------------------------------------- 00185 Public Function getItem(key) 00186 Dim idx 00187 idx = findIndex(key) 00188 If idx < 0 Then 00189 Set getItem = Nothing 00190 Exit Function 00191 End If 00192 00193 Set getItem = getAt(idx) 00194 Exit Function 00195 00196 End Function 00197 00198 ''-------------------------------------------- 00199 '* @brief コレクションのサイズを返す 00200 ''-------------------------------------------- 00201 Public Function getSize() 00202 getSize = cnt 00203 End Function 00204 00205 ''-------------------------------------------- 00206 '* @brief コレクションのサイズを設定する。 00207 '* @remarks 予めRedimしておいた方がメモリーを有効に使える場合に使用する。 00208 '' 但し、オブジェクトの入ってない要素が存在するとまずいので最終的に実際のサイズを設定すること。 00209 ''-------------------------------------------- 00210 Public Function setSize(c) 00211 If(cnt < c) Then 00212 ''サイズが大きくなる時はあまった部分にNothingをつめておく 00213 Redim Preserve arr(c -1) 00214 Redim Preserve keys(c -1) 00215 Dim i 00216 For i = cnt To UBound(arr) 00217 Set arr(i) = Nothing 00218 Next 00219 ''cnt = UBound(arr) + 1 00220 Else 00221 ''サイズが同じか小さくなる時は無条件でサイズ変更してよい 00222 cnt = c 00223 Redim Preserve arr(cnt -1) 00224 Redim Preserve keys(cnt -1) 00225 End If 00226 00227 End Function 00228 00229 ''-------------------------------------------- 00230 '* 指定位置のキーを返す。 00231 ''-------------------------------------------- 00232 Public Function getKeyAt(i) 00233 00234 if(i >= cnt) Then '' array out of bounds 00235 getKeyAt = Null 00236 Exit Function 00237 End If 00238 00239 if(i < 0) Then '' invalid index 00240 getKeyAt = Null 00241 Exit Function 00242 End If 00243 00244 00245 getKeyAt = keys(i) 00246 End Function 00247 00248 '* debug out 00249 Public Sub debugout(msg) 00250 If debugmode = "1" Then 00251 Trace msg 00252 End If 00253 End Sub 00254 ''-------------------------------------------- 00255 '* デフォルトの初期化 00256 ''-------------------------------------------- 00257 Public Sub Class_Initialize() 00258 cnt = 0 00259 Redim arr(0) 00260 Redim keys(0) 00261 End Sub 00262 00263 ''-------------------------------------------- 00264 '* @brief デフォルトの破棄 00265 '* @remarks arrに含まれていた要素の参照を誰かが保持しているなら自力で破棄させること 00266 ''-------------------------------------------- 00267 Public Sub Class_Terminate() 00268 Dim i 00269 For i = 0 to cnt - 1 00270 set arr(0) = Nothing 00271 Next 00272 Redim arr(0) 'これで全ての参照がなくなるはずなので開放される? 00273 Redim keys(0) 00274 End Sub 00275 00276 end class