カーソル風操作クラスをInterface化する

コンストラクタに渡した文字列を1文字ずつ処理するクラスを作成、カーソル風操作部分をInterface化、他のクラスにも適用するようにした。
使い方は以下のように非常にシンプルになる。コンストラクタで初期値を設定できるため、インターフェースに代入してしまっても不便がない。
通常インターフェース側にクラス毎に異なる部分を入れると使いずらくなってしまうためだ。
以下、2種類の呼び方でとりあえず実装していこうと思う。

呼び出し方法1

以下はインスタンスをICursorに設定して実行する方法。

Sub Test()

    Dim IC As ICursor
    
    Set IC = IConstructor(New CharCursor, "0123456789")
    Do Until IC.Eof
    
        Debug.Print IC
        
        IC.MoveNext
    Loop
    
End Sub
0
1
2
3
4
5
6
7
8
9

呼び出し方法2

以下はインスタンスをCharCursorに設定して GetCursor で ICursor インターフェースを取得し、実行する方法。
こちらは、CharCursor のメソッドも使える(この例ではGetCursor しかないけどメソッド、プロパティがあれば呼べる)し、ICursor のメソッドも使える。

Sub Test2()

    Dim CC As CharCursor
    
    Set CC = IConstructor(New CharCursor, "0123456789")
    
    With CC.GetCursor
        
        Do Until .Eof
        
            Debug.Print .Item
            
            .MoveNext
        Loop
    
    End With
    
End Sub
0
1
2
3
4
5
6
7
8
9

カーソル風操作のメソッドを定義

※以下ソースはファイルに保存してからインポートしてください。
Item プロパティが規定のプロパティになるように以下設定をする。Interface に設定すれば実装にもちゃんと効く。
Attribute Item.VB_UserMemId = 0

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "ICursor"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Public Property Get Eof() As Boolean
End Property
Public Sub MoveFirst()
End Sub
Public Sub MoveNext()
End Sub
Public Property Get Item(Optional ByVal opt As Variant) As Variant
Attribute Item.VB_UserMemId = 0
End Property
Public Property Get PreviousItem(Optional ByVal opt As Variant) As Variant
End Property

カーソル風操作のメソッドの実装

※以下ソースはファイルに保存してからインポートしてください。
IConstructor, ICursor の2つのインターフェースを定義。特に複数Interfaceを定義しても問題ありません。

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "CharCursor"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'-----------------------------------------------------------------------------------------------------
' カーソル風文字列読み込みクラス
'-----------------------------------------------------------------------------------------------------
Option Explicit
Implements IConstructor
Implements ICursor

Private mBuf As String
Private mIndex As Long
Private Sub Class_Initialize()
    mIndex = 1
End Sub
'------------------------------------------------------
' コンストラクタ
'------------------------------------------------------
Private Function IConstructor_Instancing(ClassObject As Object, ParamArray Args()) As Object

    Select Case UBound(Args)
        Case 0
            mBuf = CStr(Args(0))
            ICursor_MoveFirst
        Case Else
            'エラー
            Exit Function
    End Select
    
    Set IConstructor_Instancing = Me

End Function
'--------------------------------------------------------------
' ICursor インターフェースを取得
'--------------------------------------------------------------
Public Property Get GetCursor() As ICursor
    Set GetCursor = Me
End Property
'------------------------------------------------------
' 終了判定
'------------------------------------------------------
Private Property Get ICursor_Eof() As Boolean
    ICursor_Eof = Len(mBuf) < mIndex
End Property
'------------------------------------------------------
' 最初の行に移動
'------------------------------------------------------
Private Sub ICursor_MoveFirst()
    mIndex = 1
End Sub
'------------------------------------------------------
' 次行取得
'------------------------------------------------------
Private Sub ICursor_MoveNext()
    mIndex = mIndex + 1
End Sub
'------------------------------------------------------
' 文字取得
'------------------------------------------------------
Private Property Get ICursor_Item(Optional ByVal opt As Variant) As Variant

    Dim lngPos As Long
    
    lngPos = mIndex

    If lngPos < 1 Or lngPos > Len(mBuf) Then
        ICursor_Item = ""
    Else
        ICursor_Item = Mid$(mBuf, lngPos, 1)
    End If

End Property
'------------------------------------------------------
' 前の文字取得
'------------------------------------------------------
Private Property Get ICursor_PreviousItem(Optional ByVal opt As Variant) As Variant
    
    Dim lngPos As Long
    
    lngPos = mIndex - 1

    If lngPos < 1 Or lngPos > Len(mBuf) Then
        ICursor_PreviousItem = ""
    Else
        ICursor_PreviousItem = Mid$(mBuf, lngPos, 1)
    End If

End Property

コンストラクタ用インターフェース

※以下ソースはファイルに保存してからインポートしてください。

Instancing プロパティが規定のプロパティになるように以下を設定をする。
Attribute Item.VB_UserMemId = 0

規定のインスタンスが生成されるように以下を設定する。
Attribute VB_PredeclaredId = True

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "IConstructor"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'---------------------------------------------------
' コンストラクタ呼び出し
'---------------------------------------------------
Public Function Instancing(ThisObject As Object, ParamArray Args()) As Object
Attribute Instancing.VB_UserMemId = 0
    
    Dim c As IConstructor
    Dim pa() As Variant
    Dim max As Long
    Dim i As Long
    
    Set c = ThisObject
    
    max = UBound(Args)
    
    If max >= 0 Then
    
        Select Case max
            Case 0
                Set Instancing = c.Instancing(ThisObject, Args(0))
            Case 1
                Set Instancing = c.Instancing(ThisObject, Args(0), Args(1))
            Case 2
                Set Instancing = c.Instancing(ThisObject, Args(0), Args(1), Args(2))
            Case 3
                Set Instancing = c.Instancing(ThisObject, Args(0), Args(1), Args(2), Args(3))
            Case 4
                Set Instancing = c.Instancing(ThisObject, Args(0), Args(1), Args(2), Args(3), Args(4))
            Case 5
                Set Instancing = c.Instancing(ThisObject, Args(0), Args(1), Args(2), Args(3), Args(4), Args(5))
            Case 6
                Set Instancing = c.Instancing(ThisObject, Args(0), Args(1), Args(2), Args(3), Args(4), Args(5), Args(6))
            Case 7
                Set Instancing = c.Instancing(ThisObject, Args(0), Args(1), Args(2), Args(3), Args(4), Args(5), Args(6), Args(7))
            Case 8
                Set Instancing = c.Instancing(ThisObject, Args(0), Args(1), Args(2), Args(3), Args(4), Args(5), Args(6), Args(7), Args(8))
            Case 9
                Set Instancing = c.Instancing(ThisObject, Args(0), Args(1), Args(2), Args(3), Args(4), Args(5), Args(6), Args(8), Args(8), Args(9))
            Case Else
                Err.Raise vbObjectError + 512 + 1, "Argument Error"
        End Select
        
    Else
        Set Instancing = c.Instancing(ThisObject)
    End If
    
    '各Instancingメソッド内で設定されなかった場合、エラー
    If Instancing Is Nothing Then
        Err.Raise vbObjectError + 512 + 1, "Argument Error"
    End If
    
End Function

ABOUTこの記事をかいた人

はてなブックマークで驚愕の1600越えを記録した伝説が今明らかに! エクセル方眼紙 四天王の1人(ほぼ最弱)窓の杜大賞2014 大賞受賞! Excelを便利にする250以上の機能を体系化したアドインはこちらです。