VBA でショート コーディングすることは難しい。ならいっそ、ロング コーディングしてみてはどうか。無論、DRY 原則を破らずに。これは VBA のライブラリ不足への挑戦だ。題材は FizzBuzzで。
まず、FizzBuzz のメインの処理と言っていい部分、数値を取って適切な文字列を返す関数を実装する。
' Program.bas
Option Explicit
Function FizzBuzz(ByVal n As Long) As String
SelectCase BitFlag(n Mod 5 = 0, n Mod 3 = 0)
Case 0: FizzBuzz = CStr(n)
Case 1: FizzBuzz = "Fizz"
Case 2: FizzBuzz = "Buzz"
Case 3: FizzBuzz = "FizzBuzz"
CaseElse: Err.Raise 51 ' UNREACHABLE
EndSelect
EndFunction
こうだ。特に難しいところはないが、BitFlag 関数がまだ未定義である。これは何か。文字通りの関数である。Boolean 型の可変長引数を取り、それがたとえば (False) であれば0、(True) であれば 1、(Ture, Flase) であれば2を返す関数であり、すなわち2進数のビット表現を整数値として返すものである。
' Core.bas
Option Explicit
PublicFunction BitFlag(ParamArray flgs() As Variant) As Long
BitFlag = 0
Dim ub As Long: ub = UBound(flgs)
Dim i As Integer
For i = 0 To ub
BitFlag = BitFlag + IIf(flgs(i), 1, 0) * 2 ^ (ub - i)
Next
EndFunction
早くも FizzBuzz の核となるコードは完成だ。
そして、あとはこれをリスト処理するだけである。一つの方向性として、僕は次のように書きたい。
' Program.bas
''' EntryPoint
Sub Main()
Debug.Print Join(ArrMap(Init(New Func, vbString, AddressOf FizzBuzz), ArrRange(1&, 100&)))
EndSub
1から100までの範囲の数値を要素に含む配列を生成し、その配列の各要素を FizzBuzz 関数で加工した配列を新たに生成し、それを Join して表示する、という流れだ。ここで未定義なものは、ArrRange 関数、ArrMap 関数、Func クラス、Init 関数である。以下にこれらの実装をそれぞれ示そう。
ArrRange はある値から値までの範囲の配列を生成する。さして難しいコードではないが、配列長が不定のものをいかにうまく伸長させるかはちょっとしたトピックだ。
' Core.bas
PublicFunction IncrPst(ByRef n As Variant, OptionalByVal stepVal As Variant = 1) As Variant
IncrPst = n: n = n + stepVal
EndFunction
PublicFunction ArrRange( _
ByVal fromVal As Variant, ByVal toVal As Variant, OptionalByVal stepVal As Variant = 1 _
) As Variant
'FIXME: parameters type check
Dim i As Long: i = 0
Dim alen As Long: alen = 32
Dim arr As Variant: ReDim arr(alen - 1)
SelectCase stepVal
CaseIs> 0
DoWhile fromVal <= toVal
arr(IncrPst(i)) = IncrPst(fromVal, stepVal)
If i >= alen Then alen = alen * 2: ReDimPreserve arr(alen - 1)
Loop
CaseIs< 0
DoWhile fromVal >= toVal
arr(IncrPst(i)) = IncrPst(fromVal, stepVal)
If i >= alen Then alen = alen * 2: ReDimPreserve arr(alen - 1)
Loop
CaseElse
Err.Raise 5
EndSelect
If i > 0 Then
ReDimPreserve arr(i - 1)
Else
arr = Array()
EndIf
ArrRange = arr
EndFunction
あわせて定義した IncrPst は、C 系言語にはよくある後置インクリメントだ。VBA では i++ のようなことができず、そのためにコードがシンプルになり切れないことがあり、このような代用品を定義した。
続いていこう。ArrMap は、配列の各要素に関数を適用して得た値で配列を生成するために、関数ポインタ（コールバック関数）を引数に取る必要がある、いわば高階関数である。VBA に関数を受け渡しする標準の方法はないから、Win32 API の DispCallFunc の力を借りて関数オブジェクトを実装し、これに対応する。それが Func クラスである。
64-bit 環境にも配慮しながら Func クラスを定義する。
' Func.cls
Option Explicit
#If VBA7 And Win64 Then
PrivateDeclare PtrSafe _
Function DispCallFunc Lib"OleAut32.dll" ( _
ByVal pvInstance As LongPtr, _
ByVal oVft As LongPtr, _
ByVal cc_ As Long, _
ByVal vtReturn As Integer, _
ByVal cActuals As Long, _
ByRef prgvt As Integer, _
ByRef prgpvarg As LongPtr, _
ByRef pvargResult As Variant _
) As Long
#Else
PrivateDeclare _
Function DispCallFunc Lib"OleAut32.dll" ( _
ByVal pvInstance As Long, _
ByVal oVft As Long, _
ByVal cc_ As Long, _
ByVal vtReturn As Integer, _
ByVal cActuals As Long, _
ByRef prgvt As Integer, _
ByRef prgpvarg As Long, _
ByRef pvargResult As Variant _
) As Long
#End If
PrivateEnum tagCALLCONV
CC_FASTCALL = 0
CC_CDECL = 1
CC_MSCPASCAL = CC_CDECL + 1
CC_PASCAL = CC_MSCPASCAL
CC_MACPASCAL = CC_PASCAL + 1
CC_STDCALL = CC_MACPASCAL + 1
CC_FPFASTCALL = CC_STDCALL + 1
CC_SYSCALL = CC_FPFASTCALL + 1
CC_MPWCDECL = CC_SYSCALL + 1
CC_MPWPASCAL = CC_MPWCDECL + 1
CC_MAX = CC_MPWPASCAL
EndEnum
PrivateConst S_OK = &H0
Private xxReturnType As VbVarType
#If VBA7 And Win64 Then
Private xxAddr As LongPtr
#Else
Private xxAddr As Long
#End If
Private xxParamTypeBinding As Boolean
Private xxUbParam As Long
Private xxParamTypes() As Integer
PrivateSub EarlyBindParamTypes(ByVal paramTypes As Variant)
' If Not IsArray(paramTypes) Then Err.Raise 5
xxParamTypeBinding = False
xxUbParam = UBound(paramTypes)
If xxUbParam >= 0 Then
Dim i As Long
ReDim xxParamTypes(xxUbParam)
For i = 0 To xxUbParam: xxParamTypes(i) = paramTypes(i): Next
xxParamTypeBinding = True
EndIf
EndSub
PrivateSub LateBindParamTypes(ByVal params As Variant)
' If Not IsArray(params) Then Err.Raise 5
xxUbParam = UBound(params)
If xxUbParam >= 0 Then
Dim i As Long
ReDim xxParamTypes(xxUbParam)
For i = 0 To xxUbParam: xxParamTypes(i) = VarType(params(i)): Next
Else
ReDim xxParamTypes(0)
EndIf
xxParamTypeBinding = True
EndSub
#If VBA7 And Win64 Then
PublicSub Init( _
ByVal retrunType As VbVarType, ByVal addr As LongPtr, ParamArray paramTypes() As Variant _
)
#Else
PublicSub Init( _
ByVal retrunType As VbVarType, ByVal addr As Long, ParamArray paramTypes() As Variant _
)
#End If
xxReturnType = retrunType
xxAddr = addr
EarlyBindParamTypes paramTypes
EndSub
PublicSub CallByPtr(ByRef returnValue As Variant, ByVal params As Variant)
' If Not IsArray(params) Then Err.Raise 5
#If VBA7 And Win64 Then
Dim lpParams() As LongPtr
#Else
Dim lpParams() As Long
#End If
If xxUbParam >= 0 Then
Dim i As Long
ReDim lpParams(xxUbParam)
For i = 0 To xxUbParam: lpParams(i) = VarPtr(params(i)): Next
Else
ReDim lpParams(0)
EndIf
Dim stat As Long, ret As Variant
stat = DispCallFunc( _
0, xxAddr, tagCALLCONV.CC_STDCALL, xxReturnType, _
xxUbParam + 1, xxParamTypes(0), lpParams(0), ret)
If stat <> S_OK Then Err.Raise 5
If IsObject(ret) ThenSet returnValue = ret ElseLet returnValue = ret
EndSub
PublicSub FastApply(ByRef returnValue As Variant, ParamArray params() As Variant)
IfNot xxParamTypeBinding Then
LateBindParamTypes params
EndIf
CallByPtr returnValue, params
EndSub
PublicFunction Apply(ParamArray params() As Variant) As Variant
IfNot xxParamTypeBinding Then
LateBindParamTypes params
Else
If xxUbParam <> UBound(params) Then Err.Raise 5
EndIf
CallByPtr Apply, params
EndFunction
いい加減ちょっと長いが、これで関数オブジェクトが手に入るのなら安いものだ。これの使い方をすこし見ておこう。
Dim f As Func: Set f = New Func
f.Init vbString, AddressOf FizzBuzz
' f.Init vbString, AddressOf FizzBuzz, vbLong
Debug.Print f.Apply(15) 'FizzBuzz
' Dim ans As String
' f.FastApply(ans, 15)
' Debug.Print ans 'FizzBuzz
Func.Init は初期化のための関数で、第1引数にコールバック関数の戻り値の型（Sub の場合は vbEmpty）、第2引数にコールバック関数のアドレス、第3引数は可変長引数でコールバック関数の仮引数の型を渡す。第3引数は、あとで渡す実引数の型が仮引数の型と一致するなら、省略もできる。
そして Func.Apply を経由してコールバック関数に引数を渡して実行する。通常は Apply を使うが、ほんのちょっとだけ高速かもしれない版として FastApply を使うこともできる。
ところで Func.Init なんてものがなぜ必要かといえば、VBA のクラスには引数をとるコンストラクタが定義できないことによる。クラスのインスタンス化時に情報を渡すことができないとはなんと煩わしいことか。
この煩わしさを、すこしばかり軽減するための関数が Init だ。
' Core.bas
PublicFunction Init(ByVal obj As Object, ParamArray args() As Variant) As Object
SelectCaseUBound(args)
Case -1: obj.Init
Case 0: obj.Init args(0)
Case 1: obj.Init args(0), args(1)
Case 2: obj.Init args(0), args(1), args(2)
Case 3: obj.Init args(0), args(1), args(2), args(3)
Case 4: obj.Init args(0), args(1), args(2), args(3), args(4)
Case 5: obj.Init args(0), args(1), args(2), args(3), args(4), args(5)
Case 6: obj.Init args(0), args(1), args(2), args(3), args(4), args(5), args(6)
Case 7: obj.Init args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7)
CaseElse: Err.Raise 5
EndSelect
Set Init = obj
EndFunction
紛れもなく純粋に泥臭いコードである。しかしながら、これのおかげでクラスのインスタンス化の記述が楽になる。
Dim f As Func: Set f = Init(New Func, vbString, AddressOf FizzBuzz)
わずか一行の削減と侮ることなかれ。クラスのインスタンス化はコードのいたるところに現れる。それがシンプルに表現できるようになるのには、思う以上のメリットがある。そしてそれは特に、書き手よりも、読み手に対して。
さて大詰。いよいよ ArrMap だ。
' Core.bas
PublicFunction ArrMap(ByVal f As Func, ByVal arr As Variant) As Variant
IfNot IsArray(arr) Then Err.Raise 13
Dim lb As Long: lb = LBound(arr)
Dim ub As Long: ub = UBound(arr)
Dim ret As Variant
If ub - lb < 0 Then
ret = Array()
GoTo Ending
EndIf
ReDim ret(lb To ub)
Dim i As Long
For i = lb To ub: f.FastApply ret(i), arr(i): Next
Ending:
ArrMap = ret
EndFunction
Func の使い方がわかってしまえばどうということはない。引数の配列から返り値の配列へ、コールバックを適用しながらループを回すだけのコードだ。
長くなってしまったから、VBA による FizzBuzz を再度示そう。BitFlag 関数、IncrPst 関数、Init 関数、Func クラス、ArrRange 関数、ArrMap 関数をライブラリとみなした上で、だ。
' Program.bas
Option Explicit
Function FizzBuzz(ByVal n As Long) As String
SelectCase BitFlag(n Mod 5 = 0, n Mod 3 = 0)
Case 0: FizzBuzz = CStr(n)
Case 1: FizzBuzz = "Fizz"
Case 2: FizzBuzz = "Buzz"
Case 3: FizzBuzz = "FizzBuzz"
CaseElse: Err.Raise 51 'UNREACHABLE
EndSelect
EndFunction
''' EntryPoint
Sub Main()
Debug.Print Join(ArrMap(Init(New Func, vbString, AddressOf FizzBuzz), ArrRange(1&, 100&)))
EndSub
長い長い FizzBuzz も、ライブラリが充実していればこの程度だ。
VBA は貧弱だ。しかし本当に貧弱なのは VBA のライブラリだ。VBA の言語機能を嘆く前に、我々はライブラリの充実と、公開と、共有をすべきなのだ。