VBScript・VBAの動的配列をどうにかするクラス

これは完全なるメモです。
・・・ソースを出先でコピりたかったんです。

渡された端末に自由にインストールできない、入ってるのはせいぜいOfficeぐらい。
（もちろんOSはWindowsの前提です）

そんな時タスクを自動化できそうなプログラミング環境といえば、バッチ、VBScript、Powershell、VBAぐらいでしょうか。
開発するわけでもないので、とりあえず自動化してサボることができたらいいんです ( ˘ω˘)ｽﾔｧ…

Powershellは癖が強すぎるのと実行セキュリティーポリシーの問題もあるので、なるべく避けたい（Office365が絡んでくると避けられないけど）。
バッチだとできないことが多い（あるいは複雑になりすぎて何やってるんだかわけわからなくなる）。

というわけですぐVBScriptやVBAに手を出してしまう素人なんです。

でもVB系（と、ひとまとめにしちゃいます）でとにかくイラつくのが動的配列。
いや、あんなの動的でも何でもない。なんだRedimって。

そう思われる方も多いのか、動的配列を何とかしようと色んなテクニックを公開されていますね。
そんなテクニックの中で、私の目から鱗がまとめて５、６枚ほど落ちたのがこのブログ。

dharry.hatenablog.com

連想配列であるDictionaryオブジェクトを利用してるんですが、連想配列のキーを通常配列のインデックスに見立てたというか、なんだか逆手に取ったというか。
そんな手があったのかと思いました。

このブログに書かれているソースはインデックスの処理に不完全なところがあったりしたので、自分で改良に改良を重ね、謎な機能まで付け加えました。
（ブログ主さんは考え方を示したかったので、敢えて簡単なソースにしたのだと思います）

それが↓です。

'カスタムアレイ クラス
'連想配列(Scripting.Dictionary)のキーをインデックスとして通常配列のように扱う
class carray

	private ref_hash	'配列データーを格納する連想配列オブジェクト
	private x		'最終インデックス

	'コンストラクタ
	private sub class_initialize()

		set ref_hash = createobject("Scripting.Dictionary")
		x = -1

	end sub

	'デストラクタ
	private sub class_terminate()

		ref_hash.removeall

	end sub

	'push
	public sub push(byval v)

		dim i

		'引数がオブジェクトの参照の場合
		If IsObject(v) Then
			x = x + 1
			set ref_hash.item(x) = v
		'引数が配列の場合
		elseif isarray(v) then
			on error resume next
				for i = 0 to ubound(v)
					'引数の配列が初期化されていない場合終了
					select case err.number
						case 9
							exit function
					end select
					x = x + 1
					ref_hash.item(x) = v(i)
				next
			on error goto 0
		'引数が変数の場合
		else
			x = x + 1
			ref_hash.item(x) = v
		end if

	end sub

	'pop
	public function pop()

		dim v

		'引数xにてpullを実行
		v = pull(x)

		pop = v
		
	end function

	'pull:要素を取り出す(取り出された要素は削除されインデックスは詰められる)
	public function pull(byval idx)

		dim v

		'要素が無い場合処理を抜ける
		if x < 0 then
			exit function
		end if

		'要素がオブジェクトの参照の場合
		If IsObject(ref_hash(x)) Then

			If idx = x Then
				Set v = ref_hash(x)
				ref_hash.Remove (x)
				x = x - 1
			ElseIf idx < x Then
				Set v = ref_hash(idx)
				Do While idx < x
					Set ref_hash(idx) = ref_hash(idx + 1)
					idx = idx + 1
				Loop
				ref_hash.Remove (x)
				x = x - 1
			End If

		'要素が通常の場合
		Else

			If idx = x Then
				v = ref_hash(x)
				ref_hash.Remove (x)
				x = x - 1
			ElseIf idx < x Then
				v = ref_hash(idx)
				Do While idx < x
					ref_hash(idx) = ref_hash(idx + 1)
					idx = idx + 1
				Loop
				ref_hash.Remove (x)
				x = x - 1
			End If

		End If

		pull = v

	end function

	'shift
	Public Function shift()

		Dim v

		'引数0にてpullを実行
		v = pull(0)

		shift = v

	End Function

	'unshift
	Public sub unshift(ByVal v)

		Dim idx

		'要素が無い場合処理を抜ける
		if x < 0 then
			exit function
		end if

		idx = x

		Do While idx > -1
			'要素がオブジェクトの参照の場合
			If IsObject(ref_hash(idx)) Then
				Set ref_hash(idx + 1) = ref_hash(idx)
			'要素が通常の場合
			Else
				ref_hash(idx + 1) = ref_hash(idx)
			End If
			idx = idx - 1
		Loop

	'要素がオブジェクトの参照の場合
		If IsObject(v) Then
			Set ref_hash.item(0) = v
		'要素が通常の場合
		Else
			ref_hash.item(0) = v
		End If

		x = x + 1

	End sub

	'length : 最後の要素インデックスを返す
	public function length()

		length = x

	end function

	'value : 要素を配列データーとして返す
	public function value()

		dim i,idx
		dim temp_array()

		'要素が無い場合処理を抜ける
		if x < 0 then
			exit function
		end if

		for i = 0 to x
			redim preserve temp_array(i)
			'要素がオブジェクトの参照の場合
			If IsObject(ref_hash.item(i)) Then
				Set temp_array(i) = ref_hash.item(i)
			'要素が通常の場合
			Else
				temp_array(i) = ref_hash.item(i)
			End If
		next		

		value = temp_array

	end function

	'値を参照
	public default property get item(byval idx)

		if ref_hash.exists(idx) then
			'オブジェクトへの参照の場合
			if isobject(ref_hash(idx)) then
				set item = ref_hash(idx)
			else
				item = ref_hash(idx)
			end if
		end if

	end property

	'値を代入
	public property let item(byval idx, byval v)

		'idxが数値か判断
		if isnumeric(idx) then
			'値を代入
			ref_hash.item(idx) = v
			'ポインタよりidxが後ろの場合ポインタ移動
			if x < idx then
				x = idx
			end if
		end if

	end property

	'オブジェクトの参照を代入
	public property set item(byval idx, byval v)

		'idxが数値か判断
		if isnumeric(idx) and isobject(v) then
			'値を代入
			set ref_hash.item(idx) = v
			'ポインタよりidxが後ろの場合ポインタ移動
			if x < idx then
				x = idx
			end if
		end if

	end property

	'emptyになっているインデックスを詰める
	private sub check_empty

		dim i,idx
		dim temp_array()

		'要素が無い場合処理を抜ける
		if x < 0 then
			exit sub
		end if

		idx = 0
		for i = 0 to x
			'要素がemptyの場合処理しない
			if isempty(ref_hash.item(i)) = false then
				redim preserve temp_array(idx)
				'要素がオブジェクトの参照の場合
				If IsObject(ref_hash.item(i)) Then
					Set temp_array(idx) = ref_hash.item(i)
				'要素が通常の場合
				Else
					temp_array(idx) = ref_hash.item(i)
				End If
				idx = idx + 1
			end if
		next		

		ref_hash.removeall

		for i = 0 to ubound(temp_array)
			ref_hash.item(i) = temp_array(i)
		next

		x = ubound(temp_array)

	end sub

	'sort (要素にオブジェクトが入っているとエラー)
	public function sort()

		dim arr

		'要素が無い場合処理を抜ける
		if x < 0 then
			exit function
		end if

		check_empty

		arr = value
		call qsort(arr, 0, ubound(arr))
		cls
		push(arr)

	end function

	'reverse (要素にオブジェクトが入っているとエラー)
	public function reverse()

		dim arr

		'要素が無い場合処理を抜ける
		if x < 0 then
			exit function
		end if

		check_empty

		arr = value
		call qreverse(arr, 0, ubound(arr))
		cls
		push(arr)

	end function

	'qsort : 配列をクイックソート
	private sub qsort(byref arr, byval num_start, byval num_end)

		dim num_idxl
		dim num_idxr

		dim vnt_base
		dim vnt_temp

		if num_start >= num_end then exit sub

		'中央付近の要素を軸にする
		vnt_base = arr((num_start + num_end) \ 2)
		num_idxl = num_start
		num_idxr = num_end

		do

			'先頭から軸要素以上の値を検索
			for num_idxl = num_idxl to num_idxr step 1
				if arr(num_idxl) >= vnt_base then
					exit for
				end if
			next

			'末尾から軸要素以下の値を検索
			for num_idxr = num_idxr to num_idxl step -1
				if arr(num_idxr) =< vnt_base then
					exit for
				end if
			next

			'検索が交差すればループ脱出
			if num_idxl >= num_idxr then
				exit do
			end if

			'値を入替
			vnt_temp = arr(num_idxl)
			arr(num_idxl) = arr(num_idxr)
			arr(num_idxr) = vnt_temp

			'インデックス更新
			num_idxl = num_idxl + 1
			num_idxr = num_idxr - 1

		loop

		'再帰処理
		if (num_start < num_idxl - 1) then
			Call qsort(arr, num_start, num_idxl - 1)
		end if

		if (num_end > num_idxr + 1) then
			Call qsort(arr, num_idxr + 1, num_end)
		end if

	end sub

	'qreverse : 配列をクイックリバース
	private sub qreverse(byref arr, byval num_start, byval num_end)

		dim num_idxl
		dim num_idxr

		dim vnt_base
		dim vnt_temp

		if num_start >= num_end then exit sub

		'中央付近の要素を軸にする
		vnt_base = arr((num_start + num_end) \ 2)
		num_idxl = num_start
		num_idxr = num_end

		do

			'先頭から軸要素以下の値を検索
			for num_idxl = num_idxl to num_idxr step 1
				if arr(num_idxl) =< vnt_base then
					exit for
				end if
			next

			'末尾から軸要素以上の値を検索
			for num_idxr = num_idxr to num_idxl step -1
				if arr(num_idxr) >= vnt_base then
					exit for
				end if
			next

			'検索が交差すればループ脱出
			if num_idxl >= num_idxr then
				exit do
			end if

			'値を入替
			vnt_temp = arr(num_idxl)
			arr(num_idxl) = arr(num_idxr)
			arr(num_idxr) = vnt_temp

			'インデックス更新
			num_idxl = num_idxl + 1
			num_idxr = num_idxr - 1

		loop

		'再帰処理
		if (num_start < num_idxl - 1) then
			Call qreverse(arr, num_start, num_idxl - 1)
		end if

		if (num_end > num_idxr + 1) then
			Call qreverse(arr, num_idxr + 1, num_end)
		end if

	end sub

	'uniq

	public sub uniq()
		dim i, j, temp
		j = 0
		set temp = createobject("Scripting.Dictionary")
		for each i in ref_hash.keys
			temp.item(ref_hash(i)) = i
		next
		ref_hash.removeall
		for each i in temp.keys
			ref_hash.item(j) = i
			j = j + 1
		next
		x = j - 1
		set temp = nothing

	end sub

	'cls:要素を削除
	public sub cls()

		ref_hash.removeall
		set ref_hash = createobject("Scripting.Dictionary")
		x = -1

	end sub

end class

変数だろうが配列だろうがオブジェクトであろうがブチ込めるようにしてあります。
.valueを駆使すれば引数や戻り値にも配列として渡せます。
ただしオブジェクトを突っ込んだ状態でソートなんかかけると死亡します。orz

サンプルも載っけておきます。

option explicit

dim i

dim hogehoge(2)

hogehoge(0) = "あ"
hogehoge(1) = "い"
hogehoge(2) = "う"

'カスタムアレイを用意する
dim test
set test = new carray

'通常配列をそのままブチ込む
test.push(hogehoge)

'for eachでなめる
for each i in test.value
	wscript.echo i
next

'push pop shift unshiftにpullとか意味不明なのもあります
test.push("え")
test.shift

'for nextでまわす
for i = 0 to test.length
	wscript.echo test(i)
next

test.push("お")
test.push("あ")
test.push("お")
test.push("あ")

'ソートにユニークも標準装備です
test.sort
test.uniq

'joinにも使えるよ
wscript.echo Join(test.value, ":")

'おしまい
set test = nothing

結果は、

あ
い
う
い
う
え
あ:い:う:え:お

になるはずです。

ほぼ同じソースをVBAにも使いまわせます。
変数の型宣言を追加するのと、Default Propertyを使うとどうも怪しい動きをするので使わない、ぐらいですかね。

↓とりあえず作ってみました。
※2018/8/20追記 uniqに誤りがあったため修正

'カスタムアレイ クラス
'連想配列(Scripting.Dictionary)のキーをインデックスとして通常配列のように扱う

Option Explicit

Private ref_hash As Object  '配列データーを格納する連想配列オブジェクト
Private x As Long           '最終インデックス

'コンストラクタ
Private Sub class_initialize()

    Set ref_hash = CreateObject("Scripting.Dictionary")
    x = -1

End Sub

'デストラクタ
Private Sub class_terminate()

    ref_hash.RemoveAll

End Sub

'push
Public Sub push(ByVal v As Variant)

    Dim i As Long

    '引数がオブジェクトの参照の場合
    If IsObject(v) Then
        x = x + 1
        Set ref_hash.item(x) = v
    
    '引数が配列の場合
    ElseIf IsArray(v) Then
        On Error Resume Next
            For i = 0 To UBound(v)
                '引数の配列が初期化されていない場合終了
                Select Case Err.Number
                    Case 9
                        Exit Sub
                End Select
                x = x + 1
                ref_hash.item(x) = v(i)
            Next
        On Error GoTo 0
    
    '引数が変数の場合
    Else
        x = x + 1
        ref_hash.item(x) = v
    End If

End Sub

'pop
Public Function pop() As Variant

    Dim v As Variant

    '引数xにてpullを実行
    v = pull(x)

    pop = v

End Function

'pull:要素を取り出す(取り出された要素は削除されインデックスは詰められる)
Public Function pull(ByVal idx As Long) As Variant

    Dim v As Variant

    '要素が無い場合処理を抜ける
    If x < 0 Then
        Exit Function
    End If

    '要素がオブジェクトの参照の場合
    If IsObject(ref_hash(x)) Then
           
        If idx = x Then
            Set v = ref_hash(x)
            ref_hash.Remove (x)
            x = x - 1
        ElseIf idx < x Then
            Set v = ref_hash(idx)
            Do While idx < x
                Set ref_hash(idx) = ref_hash(idx + 1)
                idx = idx + 1
            Loop
            ref_hash.Remove (x)
            x = x - 1
        End If

    '要素が通常の場合
    Else
            
        If idx = x Then
            v = ref_hash(x)
            ref_hash.Remove (x)
            x = x - 1
        ElseIf idx < x Then
            v = ref_hash(idx)
            Do While idx < x
                ref_hash(idx) = ref_hash(idx + 1)
                idx = idx + 1
            Loop
            ref_hash.Remove (x)
            x = x - 1
        End If

    End If

    pull = v

End Function

'shift
Public Function shift() As Variant

    Dim v As Variant

    '引数0にてpullを実行
    v = pull(0)

    shift = v

End Function

'unshift
Public Sub unshift(ByVal v As Variant)

    Dim idx As Long

    '要素が無い場合処理を抜ける
    If x < 0 Then
        Exit Sub
    End If

    idx = x

    Do While idx > -1
        '要素がオブジェクトの参照の場合
        If IsObject(ref_hash(idx)) Then
            Set ref_hash(idx + 1) = ref_hash(idx)
        '要素が通常の場合
        Else
            ref_hash(idx + 1) = ref_hash(idx)
        End If
        idx = idx - 1
    Loop

    '要素がオブジェクトの参照の場合
    If IsObject(v) Then
        Set ref_hash.item(0) = v
    '要素が通常の場合
    Else
        ref_hash.item(0) = v
    End If

    x = x + 1

End Sub

'length : 最後の要素インデックスを返す
Public Function length() As Long

    length = x

End Function

'value : 要素を配列データーとして返す
Public Function value() As Variant

    Dim i, idx As Long
    Dim temp_array() As Variant

    '要素が無い場合処理を抜ける
    If x < 0 Then
        Exit Function
    End If

    For i = 0 To x
        ReDim Preserve temp_array(i)
        '要素がオブジェクトの参照の場合
        If IsObject(ref_hash.item(i)) Then
            Set temp_array(i) = ref_hash.item(i)
        '要素が通常の場合
        Else
            temp_array(i) = ref_hash.item(i)
        End If
    Next

    value = temp_array

End Function

'値を参照
Public Property Get item(ByVal idx As Long) As Variant

    If ref_hash.exists(idx) Then
        'オブジェクトへの参照の場合
        If IsObject(ref_hash(idx)) Then
            Set item = ref_hash(idx)
        Else
            item = ref_hash(idx)
        End If
    End If

End Property

'値を代入
Public Property Let item(ByVal idx As Long, ByVal v As Variant)

    'idxが数値か判断
    If IsNumeric(idx) Then
        '値を代入
        ref_hash.item(idx) = v
        'ポインタよりidxが後ろの場合ポインタ移動
        If x < idx Then
            x = idx
        End If
    End If

End Property

'オブジェクトの参照を代入
Public Property Set item(ByVal idx As Long, ByVal v As Object)

    'idxが数値か判断
    If IsNumeric(idx) And IsObject(v) Then
        '値を代入
        Set ref_hash.item(idx) = v
        'ポインタよりidxが後ろの場合ポインタ移動
        If x < idx Then
            x = idx
        End If
    End If

End Property

'emptyになっているインデックスを詰める
Private Sub check_empty()

    Dim i, idx As Long
    Dim temp_array() As Variant
       
    '要素が無い場合処理を抜ける
    If x < 0 Then
        Exit Sub
    End If

    idx = 0
    For i = 0 To x
        '要素がemptyの場合処理しない
        If IsEmpty(ref_hash.item(i)) = False Then
            ReDim Preserve temp_array(idx)
            '要素がオブジェクトの参照の場合
            If IsObject(ref_hash.item(i)) Then
                Set temp_array(idx) = ref_hash.item(i)
            '要素が通常の場合
            Else
                temp_array(idx) = ref_hash.item(i)
            End If
            idx = idx + 1
        End If
    Next

    ref_hash.RemoveAll

    For i = 0 To UBound(temp_array)
        ref_hash.item(i) = temp_array(i)
    Next

    x = UBound(temp_array)

End Sub

'sort (要素にオブジェクトが入っているとエラー)
Public Function sort() As Variant

    Dim arr As Variant

    '要素が無い場合処理を抜ける
    If x < 0 Then
        Exit Function
    End If

    check_empty

    arr = value
    Call qsort(arr, 0, UBound(arr))
    cls
    push (arr)

End Function

'reverse (要素にオブジェクトが入っているとエラー)
Public Function reverse() As Variant

    Dim arr As Variant
    
    '要素が無い場合処理を抜ける
    If x < 0 Then
        Exit Function
    End If

    check_empty

    arr = value
    Call qreverse(arr, 0, UBound(arr))
    cls
    push (arr)

End Function

'qsort : 配列をクイックソート
Private Sub qsort(ByRef arr As Variant, ByVal num_startas As Long, ByVal num_end As Long)

    Dim num_idxl As Long
    Dim num_idxr As Long

    Dim vnt_base As Long
    Dim vnt_temp As Long

    If num_start >= num_end Then Exit Sub

    '中央付近の要素を軸にする
    vnt_base = arr((num_start + num_end) \ 2)
    num_idxl = num_start
    num_idxr = num_end

    Do

        '先頭から軸要素以上の値を検索
        For num_idxl = num_idxl To num_idxr Step 1
            If arr(num_idxl) >= vnt_base Then
                Exit For
            End If
        Next

        '末尾から軸要素以下の値を検索
        For num_idxr = num_idxr To num_idxl Step -1
            If arr(num_idxr) <= vnt_base Then
                Exit For
            End If
        Next

        '検索が交差すればループ脱出
        If num_idxl >= num_idxr Then
            Exit Do
        End If

        '値を入替
        vnt_temp = arr(num_idxl)
        arr(num_idxl) = arr(num_idxr)
        arr(num_idxr) = vnt_temp

        'インデックス更新
        num_idxl = num_idxl + 1
        num_idxr = num_idxr - 1

    Loop

    '再帰処理
    If (num_start < num_idxl - 1) Then
        Call qsort(arr, num_start, num_idxl - 1)
    End If

    If (num_end > num_idxr + 1) Then
        Call qsort(arr, num_idxr + 1, num_end)
    End If

End Sub

'qreverse : 配列をクイックリバース
Private Sub qreverse(ByRef arr As Variant, ByVal num_start As Long, ByVal num_end As Long)

    Dim num_idxl As Long
    Dim num_idxr As Long

    Dim vnt_base As Long
    Dim vnt_temp As Long

    If num_start >= num_end Then Exit Sub

    '中央付近の要素を軸にする
    vnt_base = arr((num_start + num_end) \ 2)
    num_idxl = num_start
    num_idxr = num_end

    Do

        '先頭から軸要素以下の値を検索
        For num_idxl = num_idxl To num_idxr Step 1
            If arr(num_idxl) <= vnt_base Then
                Exit For
            End If
        Next

        '末尾から軸要素以上の値を検索
        For num_idxr = num_idxr To num_idxl Step -1
            If arr(num_idxr) >= vnt_base Then
                Exit For
            End If
        Next

        '検索が交差すればループ脱出
        If num_idxl >= num_idxr Then
            Exit Do
        End If

        '値を入替
        vnt_temp = arr(num_idxl)
        arr(num_idxl) = arr(num_idxr)
        arr(num_idxr) = vnt_temp

        'インデックス更新
        num_idxl = num_idxl + 1
        num_idxr = num_idxr - 1

    Loop
        
    '再帰処理
    If (num_start < num_idxl - 1) Then
        Call qreverse(arr, num_start, num_idxl - 1)
    End If

    If (num_end > num_idxr + 1) Then
        Call qreverse(arr, num_idxr + 1, num_end)
    End If

End Sub

'uniq
Public Sub uniq()

    Dim i, j As Variant
    Dim temp As Object

    j = 0
    Set temp = CreateObject("Scripting.Dictionary")
    For Each i In ref_hash.keys
        temp(ref_hash.item(i)) = i
    Next
    ref_hash.RemoveAll
    For Each i In temp.keys
        ref_hash.item(j) = i
        j = j + 1
    Next
    x = j - 1
    Set temp = Nothing

End Sub

'cls:要素を削除
Public Sub cls()

    ref_hash.RemoveAll
    Set ref_hash = CreateObject("Scripting.Dictionary")
    x = -1

End Sub

RedimやUBoundをアホみたいに並べる手間が無くなってお手軽になりますよ。