トロPのVBAホビラボ 32ビット符号無し整数 その6

32ビット符号無し整数の最後に、実現してきたものを振り返ってきれいにしておきましょう。ご自身でプログラムを打ち込んできた方は、お手元にそのプログラムを用意してチェックしてみてください。

実現した順番の確認

実現してきた順にプロシージャーを並べると次のようになっています。

プロシージャー名	種類	説明	登場回
LngBitXtrVal	補助	引数のビット位置の値だけ1とした値	その1
ULngsSum	主	引数1＋引数2
ComplementOf2	補助	引数の2の補数	その2
ULngsSub	主	引数1－引数2
ULngsComp	副	引数1に対しての引数2の大小比較
ULngToStr	主	引数を10進数表現にする	その3
ShiftLeftLogically	補助	引数1を引数2のビット数だけ論理左シフトした値	その4
ULngsProd	主	引数1×引数2
BitOf	補助	引数1で引数2のビット位置の値	その5
ULngDigLevel	補助	引数のビット桁数
ULngsDiv	主	引数1÷引数2の商

各プロシージャーについて、次の3点を確認していきます。

• 上にあるプロシージャーを該当箇所で必ず使用していること
• 下にあるプロシージャーを使用していないこと
• リテラルの32ビット整数には必ず型サフィックスを付けていること

振り返り - LngBitXtrVal

鈍くさく書いているだけあって、他のプロシージャーは全く使用されていません。

Select ... Case ... 文の各条件の数値、エラー番号のリテラルに型サフィックスを付けるだけです。

&HFFFFを超えるリテラルは元々32ビットですから、&は不要です。（付けても自動的に外されます）

振り返り - ULngsSum

変数とリテラルを使っている部分を除くとLngBitXtrValを使っているだけになり、これ以上LngBitXtrValの使いどころは見あたりません。

ということは変数、リテラル、LngBitXtrVal以外は使っておらず、他のプロシージャーが使用されていないということにもなります。

リテラルの方は、条件式の比較値とエラー番号に型サフィックスを付けるだけです。

振り返り - ComplementOf2

変数、リテラル、LngBitXtrValだけが使用されており、プロシージャーの
前後関係は問題ありません。

LngBitXtrValとULngsSumの使いどころも見あたりません。

リテラルの方は、ループの指標（l_Bit）、ビット位置の値との比較値（Value And l_BitXtrVal）に型サフィックスを付ける必要があります。

見ている箱のサイズが名称に含まれていませんので、プロシージャー名をLngComplementOf2に変更します。

名称の変更というのはとかく軽く見られがちですが、インターフェイス要素のため、影響範囲が広く出やすいもの。実際はリファクタリングだと考えておいた方がよいものです。

この後に出てくるプロシージャーで書き換え忘れが無いように注意しましょう。

振り返り - ULngsSub

変数、リテラル、ULngsSum、ComplementOf2だけが使用されており、プロシージャーの前後関係は問題ありません。

変数、リテラルが用いられている箇所にはLngBitXtrVal～ComplementOf2で書き直すところも無さそうです。

リテラルの方も、全てに型サフィックスが付いており修正不要です。

LngComplementOf2への変更を忘れずにおこなっておきます。

振り返り - ULngsComp

唯一の副産物ですね。

変数、リテラル、ULngsSubだけが使用されており、プロシージャーの前後関係は問題ありません。

エラー番号の確認のところは自身が使えそうに見えますが、比較でありこれこそ自身の機能ですから、無限ループを発生させる可能性が高く、相当慎重さが求められます。

実際ここでは使うべきではないでしょう。

その他のところでもLngBitXtrVal～ULngsSubを使えるところは無さそうです。

リテラルで型サフィックスが付いていないのは「On Error GoTo 0」の部分だけで、全く同じ表現でオンラインヘルプに記載されていますので、問題無いでしょう。

振り返り - ULngToStr

変数、リテラル、ULngsSubだけですのでプロシージャーの前後関係には
問題ありません。

LngBitXtrVal～ComplementOf2の使いどころは無さそうです。

l_ColValと関係するリテラルは、8ビットの世界での結果と一致すればよいので型サフィックスは不要です。演算もByteの範囲での演算ですので今回作成しているプロシージャーは使用しません。

前述の通り、大きな値や「On Error GoTo 0」では型サフィックス無しで問題ありません。

10進数の各重みでの引く数で、然るべき範囲内の数値には型サフィックスを付けておきましょう。実際付けてみて自動的に外されるかやってみるのが簡単です。

但し、いくら鈍くさくと言っても、少し無駄感が強すぎる感じがしますね。各桁の計算は同じロジックですので、プロシージャーとしてこのロジックを外出ししてしまいましょう。

サンプル

Private Sub ULngToStrCol _ (ByRef RemainNum As Long, ByVal SubNum As Long, _ ByRef FoundNonZero As Boolean, ByRef Description As String) Dim l_ColVal As Byte Dim l_ErrNum As Long l_ColVal = 0 Do On Error Resume Next RemainNum = ULngsSub(RemainNum, SubNum) l_ErrNum = Err.Number On Error GoTo 0 If 9001& = l_ErrNum Then If FoundNonZero Then Description = Description & l_ColVal Else If 0 < l_ColVal Then Description = Description & l_ColVal FoundNonZero = True End If End If Exit Do Else l_ColVal = l_ColVal + 1 End If Loop End Sub

これを使うようにULngToStrを変更すると、可読性も上がるでしょう。ただし、この書き方はあまりにULngToStrの形との関係性が強く、ULngToStrColはULngToStr専用です。

他の補助プロシージャーとは異なり、必ずモジュール外からは隠蔽しておくようにします。

今までアクセススコープのケアはしてきませんでしたが、基本的には主産物と副産物以外はPrivateで、相応のケアをすることにより、補助プロシージャーはものによりPublicにしてもよいでしょう。

相応のケアというのは、次の点は考慮に入れてください。

• 理解しやすい1つの機能を表せるものであること
• 利用側の仕様を大きく制限しないこと

振り返り - ShiftLeftLogically

LngBitXtrVal～ULngToStrの使いどころはこれ以上見あたりません。また、ULngsProd～ULngsDivも使用していません。整数リテラルにも全て型サフィックスが付いています。

これにも見ている箱のサイズが名称に含まれていませんので、プロシージャー名をLngShfitLeftLogicallyに変更します。

この後のプロシージャーでの書き換え忘れに注意しましょう。

振り返り - ULngsProd

LngBitXtrVal～LngShiftLeftLogicallyの使いどころはこれ以上見あたりません。BitOf～ULngsDivも使用していません。整数リテラルにも全て型サフィックスが付いています。

先ほどのLngShiftLeftLogicallyへの名称変更を反映するだけでよいでしょう。

振り返り - BitOf

LngBitXtrVal～ULngsProdの使いどころはこれ以上見あたりません。
ULngDigLevelとULngsDivも使用していません。整数リテラルにも全て型サフィックスが付いています。

また見ている箱のサイズが含まれていませんので、プロシージャー名をLngBitOfに変更します。

この後のプロシージャーでの書き換え忘れに注意しましょう。

振り返り - ULngDigLevel

「l_ColIdx < 1&」の部分はULngsCompを使うこともできます。指標でとても小さい値の範囲ですので、今回は変更しませんが、お好みでULngsCompを使用するように変更してもよいでしょう。

それ以外のところはLngBitXtrVal～BitOfの使いどころはこれ以上見あたりません。ULngsDivも使用していません。整数リテラルにも全て型サフィックスが付いています。

BitOfを使用していますので、新しい名前に書き換えておきましょう。

振り返り - ULngsDiv

エラー番号の比較の部分は、小さい値の範囲ですので自然に書いていますが、お好みでULngsCompを使用するように変更してもよいでしょう。

それ以外のところはLngBitXtrVal～ULngDigLevelの使いどころはこれ以上見あたりません。「On Error GoTo 0」の部分以外は整数リテラルに全て型サフィックスが付いています。

LngShiftLeftLogicallyへの名称変更は反映しておきましょう。

振り返り - ULngToStrCol

今回共通ロジック切り出しで生まれた補助プロシージャーです。（「振り返り - ULngToStr」をご覧ください。）

ULngToStrに使われる側ですから、不注意にULngToStrは使えません。

LngBitXtrVal～ULngsCompの使いどころはこれ以上見あたりません。

l_ColValと関係するリテラルや足し算、「On Error GoTo 0」の部分は、もともとの形で確認した通りです。

ULngToStr～ULngsDivは使用していません。

まとめ

以上の青字の部分を直すと32ビット符号無し整数の四則演算の用意が完了します。

正直、これぐらいの機能は最初から提供しておいて欲しいようなレベルですが、これだけ細かいことをできるのですから、VBA言語の力はなかなか強力ですね。

最後に全体を掲載しておきます。使用したいだけの場合はこちらをコピーしてください。

サンプル

Option Explicit '************************************************************ '* 32ビット符号無し整数の四則演算 by トロP '************************************************************ '------------------------------------------------------------ ' 補助プロシージャー '------------------------------------------------------------ Private Function LngBitOf(ByVal Value As Long, ByVal Column As Long) As Long Dim l_Bit As Long Dim l_ColPos As Long Dim l_ColVal As Long l_ColVal = LngBitXtrVal(Column) If 0& <> (Value And l_ColVal) Then l_Bit = 1& Else l_Bit = 0& End If LngBitOf = l_Bit End Function Private Function LngBitXtrVal(ByVal Bit As Long) As Long Dim l_BitXtrVal As Long Select Case Bit Case 1& l_BitXtrVal = 1& Case 2& l_BitXtrVal = 2& Case 3& l_BitXtrVal = 4& Case 4& l_BitXtrVal = 8& Case 5& l_BitXtrVal = &H10& Case 6& l_BitXtrVal = &H20& Case 7& l_BitXtrVal = &H40& Case 8& l_BitXtrVal = &H80& Case 9& l_BitXtrVal = &H100& Case 10& l_BitXtrVal = &H200& Case 11& l_BitXtrVal = &H400& Case 12& l_BitXtrVal = &H800& Case 13& l_BitXtrVal = &H1000& Case 14& l_BitXtrVal = &H2000& Case 15& l_BitXtrVal = &H4000& Case 16& l_BitXtrVal = &H8000& Case 17& l_BitXtrVal = &H10000 Case 18& l_BitXtrVal = &H20000 Case 19& l_BitXtrVal = &H40000 Case 20& l_BitXtrVal = &H80000 Case 21& l_BitXtrVal = &H100000 Case 22& l_BitXtrVal = &H200000 Case 23& l_BitXtrVal = &H400000 Case 24& l_BitXtrVal = &H800000 Case 25& l_BitXtrVal = &H1000000 Case 26& l_BitXtrVal = &H2000000 Case 27& l_BitXtrVal = &H4000000 Case 28& l_BitXtrVal = &H8000000 Case 29& l_BitXtrVal = &H10000000 Case 30& l_BitXtrVal = &H20000000 Case 31& l_BitXtrVal = &H40000000 Case 32& l_BitXtrVal = &H80000000 Case Else Err.Raise 9001&, , "The specified bit is out of range from 1 to 32." End Select LngBitXtrVal = l_BitXtrVal End Function Private Function LngComplementOf2(ByVal Value As Long) As Long Dim l_Bit As Long Dim l_BitXtrVal As Long Dim l_AlreadyFound As Boolean Dim l_Complement As Long l_Complement = 0& l_AlreadyFound = False For l_Bit = 1& To 32& l_BitXtrVal = LngBitXtrVal(l_Bit) If 0& <> (Value And l_BitXtrVal) Then If Not l_AlreadyFound Then l_Complement = l_Complement Or l_BitXtrVal l_AlreadyFound = True End If Else If l_AlreadyFound _ Then l_Complement = l_Complement Or l_BitXtrVal End If Next l_Bit LngComplementOf2 = l_Complement End Function Private Function LngShiftLeftLogically _ (ByVal Value As Long, Optional ByVal Bits As Long = 1&, _ Optional ByVal OverFlowStop As Boolean = False) _ As Long Dim l_Bit As Long Dim l_Shifted As Long If (ULngsComp(Bits, 1&) < 0&) Or (0& < ULngsComp(Bits, 32&)) _ Then Err.Raise _ 9001&, , "The value of Bits is out of range from 1 to 32." If OverFlowStop Then For l_Bit = 32& To ULngsSub(33&, Bits) Step -1& If 0& <> (Value And LngBitXtrVal(l_Bit)) _ Then Err.Raise 9002&, , "An overflow has occurred." Next l_Bit End If l_Shifted = 0& For l_Bit = 32& To ULngsSum(Bits, 1&) Step -1& If 0& <> (Value And LngBitXtrVal(ULngsSub(l_Bit, Bits))) _ Then l_Shifted = (l_Shifted Or LngBitXtrVal(l_Bit)) Next l_Bit LngShiftLeftLogically = l_Shifted End Function Private Function ULngDigLevel(ByVal Value As Long) As Long Dim l_ColIdx As Long Dim l_ColVal As Long l_ColIdx = 32& Do l_ColVal = LngBitOf(Value, l_ColIdx) If 0& < l_ColVal _ Then Exit Do On Error Resume Next l_ColIdx = ULngsSub(l_ColIdx, 1&) If l_ColIdx < 1& _ Then Exit Do Loop ULngDigLevel = l_ColIdx End Function Private Sub ULngToStrCol _ (ByRef RemainNum As Long, ByVal SubNum As Long, _ ByRef FoundNonZero As Boolean, ByRef Description As String) Dim l_ColVal As Byte Dim l_ErrNum As Long l_ColVal = 0 Do On Error Resume Next RemainNum = ULngsSub(RemainNum, SubNum) l_ErrNum = Err.Number On Error GoTo 0 If 9001& = l_ErrNum Then If FoundNonZero Then Description = Description & l_ColVal Else If 0 < l_ColVal Then Description = Description & l_ColVal FoundNonZero = True End If End If Exit Do Else l_ColVal = l_ColVal + 1 End If Loop End Sub '------------------------------------------------------------ ' 主産物 '------------------------------------------------------------ Public Function ULngsDiv(ByVal Value1 As Long, ByVal Value2 As Long) As Long Dim l_DigLv1 As Long Dim l_DigLv2 As Long Dim l_Div As Long Dim l_EditedVal2 As Long Dim l_Upgrade As Long If ULngsComp(Value2, 1&) < 0& _ Then Err.Raise 9001&, , "Division by zero" l_DigLv1 = ULngDigLevel(Value1) l_DigLv2 = ULngDigLevel(Value2) If ULngsComp(l_DigLv1, l_DigLv2) < 0& Then ULngsDiv = 0& Exit Function End If l_Upgrade = ULngsSub(l_DigLv1, l_DigLv2) l_Div = 0& Do If ULngsComp(0&, l_Upgrade) < 0& Then l_EditedVal2 = LngShiftLeftLogically(Value2, l_Upgrade) Else l_EditedVal2 = Value2 End If On Error Resume Next Value1 = ULngsSub(Value1, l_EditedVal2) If 9001& <> Err.Number _ Then l_Div = ULngsSum _ (l_Div, LngBitXtrVal(ULngsSum(l_Upgrade, 1&))) On Error GoTo 0 On Error Resume Next l_Upgrade = ULngsSub(l_Upgrade, 1&) If 9001& = Err.Number _ Then Exit Do On Error GoTo 0 Loop On Error GoTo 0 ULngsDiv = l_Div End Function Public Function ULngsProd(ByVal Value1 As Long, ByVal Value2 As Long) As Long Dim l_Bit As Long Dim l_Prod As Long Dim l_RoopCnt As Long l_Prod = 0& If 0& <> (Value2 And LngBitXtrVal(1)) Then l_Prod = Value1 Else l_Prod = 0& End If For l_Bit = 2& To 32& If 0& <> (Value2 And LngBitXtrVal(l_Bit)) _ Then l_Prod = ULngsSum _ (l_Prod, _ LngShiftLeftLogically(Value1, ULngsSub(l_Bit, 1&), True)) Next l_Bit ULngsProd = l_Prod End Function Public Function ULngsSub(ByVal Value1 As Long, ByVal Value2 As Long) As Long If Value1 < 0& Then If Value2 < 0& Then If Value1 < Value2 _ Then Err.Raise 9001&, , "Value2 is greater than Value1" End If Else If Value2 < 0& Then Err.Raise 9001&, , "Value2 is greater than Value1" Else If Value1 < Value2 _ Then Err.Raise 9001&, , "Value2 is greater than Value1" End If End If ULngsSub = ULngsSum(Value1, LngComplementOf2(Value2), True) End Function Public Function ULngsSum _ (ByVal Value1 As Long, ByVal Value2 As Long, _ Optional ByVal Force As Boolean = False) _ As Long Dim l_Bit As Long Dim l_BitXtrVal As Long Dim l_Carry As Long Dim l_CurVal1 As Long Dim l_CurVal2 As Long Dim l_PrevVal1 As Long Dim l_PrevVal2 As Long Dim l_Sum As Long l_Sum = 0& l_Carry = 0& l_PrevVal1 = 0& l_PrevVal2 = 0& For l_Bit = 1& To 32& l_BitXtrVal = LngBitXtrVal(l_Bit) l_CurVal1 = Value1 And l_BitXtrVal l_CurVal2 = Value2 And l_BitXtrVal If 0& <> ( _ (l_PrevVal1 And l_PrevVal2) Or _ (l_PrevVal1 And l_Carry) Or _ (l_PrevVal2 And l_Carry) _ ) Then l_Carry = l_BitXtrVal Else l_Carry = 0& End If If 0& <> ( _ (l_CurVal1 And (Not (l_CurVal2 Xor l_Carry))) Or _ (l_CurVal2 And (Not (l_CurVal1 Xor l_Carry))) Or _ (l_Carry And (Not (l_CurVal1 Xor l_CurVal2))) _ ) _ Then l_Sum = l_Sum Or l_BitXtrVal l_PrevVal1 = l_CurVal1 l_PrevVal2 = l_CurVal2 Next l_Bit If Not Force Then If 0& <> ( _ (l_PrevVal1 And l_PrevVal2) Or _ (l_PrevVal1 And l_Carry) Or _ (l_PrevVal2 And l_Carry) _ ) Then Err.Raise 9002&, , "An overflow has occurred." End If ULngsSum = l_Sum End Function Public Function ULngToStr(ByVal Value As Long) As String Dim l_FoundNonZero As Boolean Dim l_Sub As Long Dim l_Str As String l_Str = "" l_Sub = Value l_FoundNonZero = False ULngToStrCol l_Sub, 1000000000, l_FoundNonZero, l_Str ULngToStrCol l_Sub, 100000000, l_FoundNonZero, l_Str ULngToStrCol l_Sub, 10000000, l_FoundNonZero, l_Str ULngToStrCol l_Sub, 1000000, l_FoundNonZero, l_Str ULngToStrCol l_Sub, 100000, l_FoundNonZero, l_Str ULngToStrCol l_Sub, 10000&, l_FoundNonZero, l_Str ULngToStrCol l_Sub, 1000&, l_FoundNonZero, l_Str ULngToStrCol l_Sub, 100&, l_FoundNonZero, l_Str ULngToStrCol l_Sub, 10&, l_FoundNonZero, l_Str l_Str = l_Str & l_Sub ULngToStr = l_Str End Function '------------------------------------------------------------ ' 副産物 '------------------------------------------------------------ Public Function ULngsComp _ (ByVal Value1 As Long, ByVal Value2 As Long) _ As Long Dim l_Sub As Long On Error Resume Next l_Sub = ULngsSub(Value1, Value2) If 9001& = Err.Number Then ULngsComp = -1& Exit Function End If On Error GoTo 0 On Error Resume Next l_Sub = ULngsSub(Value2, Value1) If 9001& = Err.Number Then ULngsComp = 1& Exit Function End If On Error GoTo 0 ULngsComp = 0& End Function

今のところ、64ビットの整数はどうするかということが気になっております。こちらの方も何か考えていければと思います。

タグ：アクセススコープ 振り返り 符号無し整数 32ビット トロPのVBAホビラボ