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