スキルアップ・問題解決なら、モーグにおまかせ！

「VBAのクラスの話題が極端に少ない」という現状に風穴を開けたくこのスレッドを
立ち上げます。とは言っても堅苦しくなく楽しい雰囲気で進めれればと思います^^
  
スーパーテクニックをお持ちの識者の方から、クラスをまだ使った事がないという方まで
ご参加頂ければ幸いです。
 
VBAクラス研究室（１）
http://www.moug.net/faq/viewtopic.php?t=62306
 
VBAクラス研究室（２）
http://www.moug.net/faq/viewtopic.php?t=62566
 
それでは皆様、よろしくお願い致します。

みそじのおじさん さんの引用:
どこまで出来て何が足りないのか皆様には見えているのではないでしょうか？
こんな私に「足りない物」をざくっと指摘頂けないないでしょうか。

みそじのおじさん さんの引用:
・将来、業務システムを一人（もしくはチーム）で構築出来る男になりたい
・その為にクラスモジュールは絶対押さえておきたい
・がむしゃらにクラスを作り続けているが、しっくりこない
...
クラスモジュールを扱っていて感じる、この「モヤモヤ感」を打破する
ために一つ背中を押してもらえるようご支援頂けると幸いです。

みそじのおじさん様　はじめましてm(_ _)m
 
いつもは主に Excel VBA 板の ROM 、時々別板で質問者をやっていますm(_ _)m
クラスモジュールに文字を書いたことなどほとんどないド素人です。
 
VBAクラス研究室（１） の　みそじのおじさん様のコードを動かしてみました。
 
すごいですね(￣□￣;
こんな UserForm 見たこと無かったです。
カッコイイですね！
私の仕事にも応用できないかとアレコレ探してみたのですが、
普段から UserForm はほとんど使わないので、応用できそうなものが見つかりませんでした(^-^A
 
コピペで動くクラスモジュールのコード、とても勉強になります。
しかも、参加されてるメンバーの皆様の凄いこと、凄いこと(@o@)
今後も興味津々で ROM させていただきますm(_ _)m
 
 
余談ですが、私も先週テイネハイランドでスキーでコケて、
左膝を負傷してしまいました(ToT)
何故かみそじのおじさん様には親近感を感じる真下でしたm(_ _)m
お邪魔しました。
 

みそじのおじさん さんの引用:
どこまで出来て何が足りないのか皆様には見えているのではないでしょうか？
こんな私に「足りない物」をざくっと指摘頂けないないでしょうか。

みなさん、こんばんは。
 
▼月さん
ちょっと抽象的すぎましたね。。
自己分析してみます。
 
・対象物を分析し「これは２つ以上のクラスが必要だと」判断するものの、どのクラスに
　どのメンバを持つべきか考えがまとまらない。自分が出来る定型パターンにもっていく
　傾向が強い為出来上がる物はどれも似た感じになる。デザインパターンという言葉を
　知った今チャレンジしてみたいが、どういった勉強方法が良いか迷ってしまう。
 
 
　これは藤代さんの引用ですが、

藤代 さんの引用:

クラスを使おうのが当たり前になるためには、
・対象業務のオブジェクト分析
・プログラムの構造設計
なんかが必要になると思うのですよ。

おはようございます。
皆さん。はじめまして。
 
ここでクラスの勉強をさせていただいています。
残念ながら。まだまだといったところですが。
 

引用:

藤代千尋さんの引用：
思い出せば、以前、構造だけで 100 クラスを超えたプロジェクトをやりましたが、「後から考えると、かなり無駄の多い、失敗した構造だったな」とか思ったり。
 
みそじのおじさんの引用：
# この２年間余りで４本大きいのを作りましたが、３万行を下回ったのはありません。

こんにちは。
 
yayadonさん、コードの掲載ありがとうございました。m(__)m
前スレの
> 投稿日時: 12/03/28 21:56:08 No.91
(ITypeInfoの使い方もよくわかってないので)助かります。
# DebugViewに出力しました。
 
また、プラグマで(リンカに対して)名前修飾無しのエクスポート関数の指定は知りませんでした。
 
---
 
ろひさん、コメントありがとうございました。
http://www.moug.net/faq/viewtopic.php?t=62676
もAccessible Explorerでクリックを確認しましたが、
ウィンドウの階層が深いので、APIだと大変そうと感想と言うか連絡です。

> ( ･∀･)つﾄﾞｿﾞｰ ブドウ糖
 
(￣∇+￣)□ゝｳﾏｲﾝﾀﾞﾅｧ ｺﾚｶ

> # DebugViewに出力しました。
あ，そうですね。
 
Sysinternals Suite
http://technet.microsoft.com/en-us/sysinternals/bb842062
　
　
# VBA でも，そういえば，例の DispCallFunc でやれそうですね。
　
　

yayadon さんの引用:

# VBA でも，そういえば，例の DispCallFunc でやれそうですね。

kumatti さんの引用:
ITypeInfo は
某VB MVPの方のTypeLibを使った方がいいのではないかと。
(可読性の面から)

yayadon さんの引用:

別途 "TypeLib を用意する派" なのは意外でした。(泣)

みそじのおじさん さんの引用:
・対象物を分析し「これは２つ以上のクラスが必要だと」判断するものの、どのクラスに
　どのメンバを持つべきか考えがまとまらない。自分が出来る定型パターンにもっていく
　傾向が強い為出来上がる物はどれも似た感じになる。デザインパターンという言葉を
　知った今チャレンジしてみたいが、どういった勉強方法が良いか迷ってしまう。

PC研究室2nd 投稿日時: 11/10/25 14:05:02 投稿者: 月 さんの引用:
クラスについて。
   
既存のクラスを参考にするとよいと思います。
Range、FileSystemObject、Collection、Dictionary、すべてクラスです。
   
・どのようなメンバ(メソッド、プロパティ、イベントのこと)があるか
・何を1個のクラスとしているか
 
参考になると思います。

> IDispatchは仕方無いですけど、
 
mktyplibコマンドでは可能。実際、自分は IDispatchCallable名を付けて
使っています。但し、32bit OS限定。

Abyss さんの引用:

mktyplibコマンドでは可能。実際、自分は IDispatchCallable名を付けて
使っています。但し、32bit OS限定。

> (64bit向けで試していました)
 
なるほどです。mktyplibはVB6まででMicrosoftから捨てられています。
ちなみに、yayadonさんのをTyplibに定義してからテストしてみました。
大変、参考になります。ありがとうございます。
 

    Dim Disp As IDispatchCallable
    Dim ti As ITypeInfo
    Dim ta As TYPEATTR
    Dim fd As FUNCDESC
    Dim p&, ret&, i&, S$, j&
    Dim bstr&(10)
    
    Set Disp = New Class1
    Disp.GetTypeInfo 0, 0, VarPtr(ti)
    
    ti.GetTypeAttr VarPtr(p)
    MoveMemory ta, ByVal p, LenB(ta)
    ti.ReleaseTypeAttr p
    
    For i = 0 To ta.cFuncs - 1
        ti.GetFuncDesc i, VarPtr(p)
        MoveMemory fd, ByVal p, LenB(fd)
        ti.ReleaseFuncDesc p
        ti.GetNames fd.memid, VarPtr(bstr(0)), 10, VarPtr(ret)
        For j = 0 To ret - 1
            MoveMemory ByVal VarPtr(S), bstr(j), 4
            Debug.Print S
        Next
    Next

みそじのおじさん様
 
誤解されたままではいけませんので、本題には関係ありませんが、
少しだけお邪魔させてくださいm(_ _)m
 
 
> # オラクルやられているのですね。
 
(￣□￣;　やっているのではなく、近くにたまたまあっただけです。
何もできません(/-＼*)
 
藤代様が仰るところの、「b.業務を簡単にすます技術（マクロ）があると知った」
こちら側の人間です。
 
 
> # 道産子ですか！！
 
すみません、違います。そちらの言葉で、「内地の人」です(^-^A
 
 
> オリンピアの中央の大きい木（わかります？笑）
 
多分わかります！その横の方で滑っていました(*^-^*)♪
 
難しいお話の中に割り込んでしまい、大変失礼致しましたm(_ _)m　お邪魔しました。

みそじのおじさん さんの引用:

・対象物を分析し「これは２つ以上のクラスが必要だと」判断するものの、どのクラスに
　どのメンバを持つべきか考えがまとまらない。自分が出来る定型パターンにもっていく
　傾向が強い為出来上がる物はどれも似た感じになる。デザインパターンという言葉を
　知った今チャレンジしてみたいが、どういった勉強方法が良いか迷ってしまう。

みなさん、こんばんは。
 
▼藤代さん
 
相変わらず深いですね、藤代さん。この藤代さん節が「たまらなく好き！」と思っているのは
私だけではないはずです。背中をグイっと押された気がしました。真っ暗闇の中に足を踏み出す
気持ちですが、その時はどうぞ明かりを灯してやって下さい。よろしくお願い致します。
 

藤代 さんの引用:

なので、『オブジェクト指向分析』や『オブジェクト指向設計』は必修。
  
分析はそんな難しいものではないですが、設計はかなり悩むでしょうね。そんなとき『デザインパターン』や『アンチパターン』、『アナリシスパターン』などが参考になります。
  
と言っても、経験を積まないとなかなか良い物は作れなかったりはします。
  
作りましょう、クラスで問題領域を抽象化したプログラムを！　そして経験を積み上げましょう！　そして、濃密な経験にするために（多くの気づきを得るために）知識を蓄えましょう！

月さん さんの引用:

他人のコードを見て、真似て、感覚を覚える、ですかね。

みそじのおじさん さんの引用:
# 月さんのツールでmougを見たほうが見易いです。

みそじのおじさん さんの引用:
ぱっと書けてしまう月さんにも「脱帽」です。

/mktyplib203 switch
http://msdn.microsoft.com/en-us/library/windows/desktop/aa367332%28v=vs.85%29.aspx

error MIDL2270 : duplicate UUID. Same as : IDispatch [ Interface 'IDispatchCallable'  ]

みそじのおじさん さんの引用:
デザインパターンという言葉を知った今チャレンジしてみたい

どんきち さんの引用:
「増補改訂版Java言語で学ぶデザインパターン入門」（ソフトバンククリエイティブ／結城 浩 (著)）に書かれているサンプルコードを、すべてExcel VBAに移植してみました。

みなさん、こんばんは。
 
ろひさん、ご紹介ありがとうございます！
 
なんとなんと、どんきちさんのHPではありませんか！！
さっそくDLさせて頂きました。
 
まずは、デザインパターンとは「何か？」と味わさせて頂きます。
どんきちさん、ありがとうございます。
 
# 一つ目はAdapterに挑戦します！！

みそじのおじさん さんの引用:
なんとなんと、どんきちさんのHPではありませんか！！さっそくDLさせて頂きました。

kumatti さんの引用:
http://www.moug.net/faq/viewtopic.php?t=62676
もAccessible Explorerでクリックを確認しましたが、 ウィンドウの階層が深いので、APIだと大変そうと感想と言うか連絡です。

●みそじのおじさん　へ
「増補改訂版Java言語で学ぶデザインパターン入門」に書かれている説明を読んで、サンプルコードとつきあわせてみないと、プログラムだけを見てもチンプンカンプンだと思います。図書館で借りてくるなりして、いちど書籍の方にも目を通してみてください。
 
●るろひ　さんへ
「VBAにおいては、これを実際の業務や開発でテンプレートとしてこのまま使うか、と考えると、どうだろう」という疑問はまったくそのとおりだと思います。Javaの場合はクラスライブラリで提供されているクラスがデザインパターンを適用された形になっていて無理なく使えます。VBAにJavaのデザインパターンをそのまま移植してもも、Javaの比べてコード量が多くなってメンテナンスしづらいものになってしまいます。
 
デザインパターンで実現しようとしていることを理解した上で、使えるところだけ使うとか、VBAの類似機能に置き換えるといったことが必要になりそうです。
 
ぱっとおもいつくのは以下の３つぐらいですかね。
・Iteratorパターン
Collectionの要素を取得するのにFor Eachを利用すると、Collcetionの_NewEnumメソッドが実行される。
_NewEnumはIteratorパターンに近いことをやっているので、For Eachを使うのであれば、わざわざIteratorパターンを自作する必要はない。
 
・Observerパターン
RaiseEventとWithEventsを利用した形におきかえれるのであれば、置き換える。
　
・Singletonパターン
将来的にインスタンスの生成を限定する数が２つや３つになる可能性がないのであれば標準モジュールとして実装してしまう。
 

参考スレッド:
オブジェクト？プロパティ？
http://www.moug.net/faq/viewtopic.php?t=62751
 
 
ここで問題です。
 
-----
以下のように，一見，いわゆる メソッド チェーン のように見える
 

Private Sub Method1()

    ActiveCell.Font.Bold = True

End Sub

Private Sub Method1()

    Dim rng As Range
    Dim fnt As Font
    
    Set rng = ActiveCell
    Set fnt = rng.Font
    fnt.Bold = True

End Sub

みなさん、おはようございます。
 
▼どんきちさん
 
どんきちさんの仰る通りでした。これは本を読まなければチンプンカンプンですね^^;;
 
「増補改訂版Java言語で学ぶデザインパターン入門」
この本のHPがあったので見てみました。
対象読者について触れていましたが、「全てではないが、私にあてはまる」と感じました^^
Javaの方のサンプルコードがDL出来るようになっていましたので中身をみましたが
全く読めないことも無い自分に少し驚きました。（多少C、C++をかじったお陰かな^^）
 
今までJavaのソースはほとんど読んだ事がないのですけど、.netに似ている感じが
しました。（JavaもTry Catch構文なんですね！）
 
どんきちさんと、ろひさんから「VBAにデザインパターンを持ち込む弊害」についてアドバイス
を頂いておりますので、見極める力を勉強して身につけたいです。
 
ですが、私は皆様へ追いつく為に「多言語を習得する」事を最終目標にしていますので
たとえVBAで使えなかったとしても、今後の私の糧になると！信じております。
 
# 目次も拝見しましたが、面白そうです。本はamazonで注文する事にします^^
 
▼yayadonさん
 
「Termメソッドがあったら、VBAもお手上げ」
む、難しいです。。
 
質問者さんが、「ひょっとして、アホな質問してるわけじゃないですよね。」と
言われていましたが、「とんでもない。それを疑問に思えた事自体がすばらしい」
と感じました。普段から「これはオブジェクト？いやオブジェクト返すプロパティだ」
などと意識してコーディングしておりますが、説明してと言われると冷や汗をかきますね^^;
 
皆様、yayadonさんの問題に是非参加してくださいね！！
 
# で、おじさんの答えは？とつっこまないで下さい（笑）

yayadon さんの引用:
それはなぜでしょうか？

みそじのおじさん さんの引用:

藤代千尋 さんの引用:

なので、『オブジェクト指向分析』や『オブジェクト指向設計』は必修。
  
作りましょう、クラスで問題領域を抽象化したプログラムを！　そして経験を積み上げましょう！　そして、濃密な経験にするために（多くの気づきを得るために）知識を蓄えましょう！

 
私はこのスタートラインについた（つけた）と考えてもよろしいでしょうか？

山里人 さんの引用:

藤代千尋 さんの引用:

思い出せば、以前、構造だけで 100 クラスを超えたプロジェクトをやりましたが

みそじのおじさん さんの引用:

# この２年間余りで４本大きいのを作りましたが、３万行を下回ったのはありません。

 
私が作るプログラムは２千行いくかいかないかですが、それでもメンテナンスが大変です。
 
お二人は平気なんでしょうか。
なにかコツでもあるのでしょうか。

藤代千尋 様
みそじのおじさん 様
 
唐突な質問にご回答いただきましてありがとうございます。
 
お時間をとらせてしまい恐縮しています。
 
何度も読み返しながら身に付けていきたいと思います。
 
ありがとうございました。
 
 
 
 

月 さんの引用:

yayadon さんの引用:
それはなぜでしょうか？

子オブジェクトも弱参照で取得するから！

'' メソッド チェーンで書いたもの
Private Sub MethodChaining()

    Dim t As Single
    Dim i As Long
    Const cIterate As Long = 10000
    
    t = Timer
    
    For i = 1 To cIterate
        ActiveCell.Font.Bold = True
    Next
    
    Debug.Print Timer - t, "MethodChaining"
    
End Sub

'' オブジェクト変数に設定していくもの
Private Sub NoMethodChaining()

    Dim rng As Range
    Dim fnt As Font
    
    Dim t As Single
    Dim i As Long
    Const cIterate As Long = 10000
    
    t = Timer
    
    For i = 1 To cIterate
        Set rng = ActiveCell
        Set fnt = rng.Font
        fnt.Bold = True
        [      �@       ]   <--- ここに 一文
        [      �A       ]   <--- ここに 一文
    Next
    
    Debug.Print Timer - t, "NoMethodChaining"
    
End Sub

'' どのようにでも構わないが，例えば，以下のような感じで呼び出したとする。
Private Sub Test1()

    '' 面倒なので，だらだらと書いてます。
    Call MethodChaining
    Call NoMethodChaining
    Call MethodChaining
    Call NoMethodChaining
    Call MethodChaining
    Call NoMethodChaining
    Call MethodChaining
    Call NoMethodChaining
    Call MethodChaining
    Call NoMethodChaining
    
    MsgBox "終了"
    
End Sub

こんにちは〜

yayadon さんの引用:
以下の MethodChaining メソッドの For ループの中身と
実質同じになるように，
NoMethodChaining の �@ と �A のところにそれぞれ一文が必要になります。
 

        [      �@       ]   <--- ここに 一文
        [      �A       ]   <--- ここに 一文

        Set fnt = Nothing
        Set rng = Nothing

kanabun さんの引用:

根拠も何もなく あてずっぽなんですけど、
 

        Set fnt = Nothing
        Set rng = Nothing

ActiveCell.Font.Bold = True

With ActiveCell
    With .Font
        .Bold = True
    End With
End With

Private Sub Test()
    Dim cn As ADODB.Connection
    Set cn = New ADODB.Connection
    '略
    cn.Close
    Set cn = Nothing     '(X)
End Sub

ActiveCell.Font.Bold = True

補足:

参照が何のことかわからない場合は，
# リンク先で kanabun さんも書かれていますが

このコードでは，Excel から

　・Range オブジェクト
　・Font オブジェクト

の２つを受け取っています。

のように，"参照" ではなくても，とりあえず構いません。

最近の説明の傾向？として，全く新しい事柄を教える際には，
無理に比喩で教えようとすることは避けられてきている気がします。
説明した側とされた側が同じイメージを共有するとは限らないからです。

SetSourceData

Dim rng As Range
Set rng = Range("A1").CurrentRegion   '(A)
.Chart.SetSourceData(rng, xlColumns)

Set rng = Nothing

Dim rng As Range
Set rng = Range("A1").CurrentRegion   '(A)
rng に対して AddRef  (参照カウントを +1 する)   '(B)
.Chart.SetSourceData(rng, xlColumns)

Set rng = Nothing

yayadon さんの引用:
どうやってうまくやっているか？を知る前に
各メソッドがどのように定義されているか？
を OLE / COM Object Viewer で確認することにします。

[
  odl,
  uuid(000208D5-0000-0000-C000-000000000046),
  helpcontext(0x00020001),
  dual,
  oleautomation
]
interface _Application : IDispatch {

    [id(0x00000131), propget, helpcontext(0x00010131)]
    HRESULT ActiveCell([out, retval] Range** RHS);

};

[
  odl,
  uuid(00020846-0001-0000-C000-000000000046),
  helpcontext(0x00020006),
  hidden
]
interface IRange : IDispatch {

    [propget, helpcontext(0x00010092)]
    HRESULT _stdcall Font([out, retval] Font** RHS);

};

[
  odl,
  uuid(000208D6-0000-0000-C000-000000000046),
  helpcontext(0x00020007),
  dual,
  nonextensible,
  oleautomation
]
interface _Chart : IDispatch {

    [id(0x00000585), helpcontext(0x00010585)]
    HRESULT SetSourceData(
                    [in] Range* Source, 
                    [in, optional] VARIANT PlotBy);

}

Dim rng As Range

Dim rng As Range

VarPtr(rng)

　[out, retval] Range** RHS
　[out, retval] Font** RHS
　[in] Range* Source

HRESULT ActiveCell([out, retval] Range** RHS);

HRESULT _stdcall Font([out, retval] Font** RHS);

yayadonさん
 
わかりやすいし面白いし勉強になります！

# 知ってたw が連発されていそうで怖いのですが...
# 以下，知ってたw 禁止 ってことでお願いします。(爆)
 
 
最後に最初の問題の正解を載せておきます。
もちろん，正解はこのとおりでなくても構いません。
 
 

yayadon さんの引用:
-----
以下のように，一見，いわゆる メソッド チェーン のように見える

Private Sub Method1()
    ActiveCell.Font.Bold = True
End Sub

という感じのコードがあった時に，
VBA は，必ず以下のように疑似的にばらして解釈してくれます。

Private Sub Method1()
    Dim rng As Range
    Dim fnt As Font
    
    Set rng = ActiveCell
    Set fnt = rng.Font
    fnt.Bold = True
End Sub

それはなぜでしょうか？

Private Sub Method1()
    ActiveCell.Font.Bold = True
End Sub

Private Sub Method1()
    Dim rng As Range
    Dim fnt As Font
    
    Set rng = ActiveCell
    Set fnt = rng.Font
    fnt.Bold = True
    fnt.Term
    Set fnt = Nothing    ' 無くても可
    rng.Term
    Set rng = Nothing    ' 無くても可
End Sub

Private Sub Method1()
    With ActiveCell
        With .Font
            .Bold = True
            .Term
        End Witn
        .Term
    End With
End Sub

yayadon さんの引用:
正確には，型や要素に付加するこれらの目印を "属性(attribute)" といいます。

▼藤代さん
 
遅くなりました。すみません。
本当にありがとうございます。
 
「Code Analyze Tool」評価版というソフトを使って自ファイルを分析してみました。
 
以前、藤代さんには書きましたが、
 
UserForm数 72
標準モジュール 22
クラスモジュール 32
 
総行数 48,000行
 
全プロシージャ数 約1800
48000/1800 = 約27行　（宣言部、空白行を含んだ計算の為、目安程度です）
 
私のイメージでは平均27行どころではなく、もっと書いていたかなと思っていたのですが、、
最大で300行くらいでした。
 
・プロシージャの分割
　今回、（１）で提示したクラスも、まだまだ追い出せる物がありそうですし
　分析したファイルも、もっともっと出来ると思います。
 
・低依存、責任範囲
　これも以前藤代さんからアドバイス頂きました。
　「このクラスは知りすぎている」と藤代さんに言われた言葉は、今でも忘れていません。
　フォームの推移で失敗するのは、このフォームもまだ「知りすぎている」のだと思います。
　フォーム（クラス）は誰から呼ばれるのかは知らない。依存するのは、引数のみ。
　結果を返す相手も知らなくていい。結果を準備しておくだけでいい（プロパティで）
　「コントローラから操作する」これを念頭にやっていきます。
 
藤代さんから頂いた事を実践できたのが約２、３割で残りは「過去の遺物の再利用」でして
この過去の遺物が私の足を引っ張っております^^;
 

藤代 さんの引用:

●閑話２
こういう話はプログラミングの学校とか、割と初歩の話のような気もしてきた。掲示板で説明することなのか。＝□○＿

ほとんど番外編ですが一応、クラス絡みと言うことで。
あまり親切にコメントしていませんが、ご興味のある方はお試し下さい。
「Windows リボンフレームワーク」
https://gist.github.com/2287862

●Implementsが連鎖した場合にインスタンスを代入できる変数の型について
 
突然ですが、ここで問題です。
 
クラスモジュール clsA でImplments clsBと指定しするとclsA のインスタンスをclsB型の変数に代入できるようになります。
しかし、clsB のインスタンスは clsA 型の変数に代入すると実行時エラーになります。
インターフェイスは一方通行なのです。
 
そこで、Implementsが複数のクラスで連鎖した場合にどういった場合に代入できて、
どういった場合に代入できないのかを調べるコードを以下に示します。
 
１回で代入できない場合は、複数回にわけて代入してみました。
結果からいうと、１回で代入できない場合は、２回にわけても、３回にわけても代入できません。
 
それぞれのケースで、代入できるとしたら、なぜ代入できるのか。
代入でないとしたら、なぜ代入できないのか。
１回で代入できない場合は、２回にわけても、３回にわけても代入できないのはなぜなのか。
その理由が説明できますか？
 
また、代入できないときに代入できるようにするために、どうすればよいかわわかりますか？
 
インターフェイスは一方通行、変数の型に指定するクラス名が意味するもの、
別の型の変数に代入したときにインスタンスの内容はどうなるか、
といったことを考えてみると答がわかる……かもしれません。
 
 
●パターン１
clsA
clsB で clsA をインプリメント(実装)
 

'*** クラスモジュール clsA
Option Explicit
Public Sub SubA()
    Debug.Print "clsA.SubA"
End Sub

'*** クラスモジュール clsB
Option Explicit
'clsAをインプリメント
Implements clsA
Public Sub SubB()
    Debug.Print "clsB.SubB"
End Sub
'インプリメントしたプロシージャ名は
'クラス名_プロシージャ名 となる。
Private Sub clsA_SubA()
    Debug.Print "clsB.clsA_SubA"
End Sub

'*** 標準モジュール Module1
Option Explicit
Sub Test11()
''' １回で代入できる型を調べてみる
    Dim objA As clsA
    Dim objB As clsB
    
''' No.01-01 clsAのインスタンス（実体）はclsA型の変数に代入できる
    Set objA = New clsA 'OK

''' No.01-02 clsBのインスタンス（実体）はclsA型の変数に代入できる
    Set objA = New clsB 'OK

''' No.01-03 clsAのインスタンス（実体）はclsB型の変数に代入できない
'    Set objB = New clsA 'NG

''' No.01-04 clsBのインスタンス（実体）はclsB型の変数に代入できる
    Set objB = New clsB 'OK
End Sub

'*** クラスモジュール clsC
Option Explicit
'clsXをインプリメント
Implements clsX
Public Sub SubC()
    Debug.Print "clsC.SubC"
End Sub
'インプリメントしたプロシージャ名は
'クラス名_プロシージャ名 となる。
Private Sub clsX_SubX()
    Debug.Print "clsC.SubC"
End Sub

'*** クラスモジュール clsD
Option Explicit
'clsXをインプリメント
Implements clsX
Public Sub SubD()
    Debug.Print "clsD.SubD"
End Sub
'インプリメントしたプロシージャ名は
'クラス名_プロシージャ名 となる。
Private Sub clsX_SubX()
    Debug.Print "clsD.clsX_SubX"
End Sub

'*** クラスモジュール clsX
Option Explicit
Public Sub SubX()
    Debug.Print "clsX.subX"
End Sub

'*** 標準モジュール Module2
Option Explicit
Sub Test21()
''' １回で代入できる型を調べてみる
    Dim objC As clsC
    Dim objD As clsD
    Dim objX As clsX
    
'No.02-01
    Set objC = New clsC 'OK

'No.02-02
'    Set objC = New clsD 'NG

'No.02-03
'    Set objC = New clsX 'NG
    
    
'No.02-04
'    Set objD = New clsC 'NG

'No.02-05
    Set objD = New clsD 'OK

'No.02-06
'    Set objD = New clsX 'NG
    
    
'No.02-07
    Set objX = New clsC 'OK

'No.02-08
    Set objX = New clsD 'OK

'No.02-09
    Set objX = New clsX 'OK
End Sub
Sub Test22()
''' １回で代入できないので複数回にわけて代入
    Dim objC As clsC
    Dim objD As clsD
    Dim objX As clsX
    
'No.02-02-10  Set objC = New clsD を複数回にわけて実行
''' clsDとclsCの両方でclsXをインプリメントしているので
''' clsDのインスタンスをclsX型の変数に代入した後で
''' clsC型の変数に代入
    Set objD = New clsD 'OK
    Set objX = objD 'OK
'    Set objC = objX 'NG

'No.02-02-11  Set objC = New clsX を複数回にわけて実行
''' clsCはclsXをインプリメントしているので
''' clsXのインスタンスをclsX型の変数に代入した後で
''' clsC型の変数に代入
    Set objX = New clsX 'OK
'    Set objC = objX 'NG
    
'No.02-02-12  Set objD = New clsC を複数回にわけて実行
''' clsCとclsDの両方でclsXをインプリメントしているので
''' clsCのインスタンスをclsX型の変数に代入した後で
''' clsD型の変数に代入
    Set objC = New clsC 'OK
    Set objX = objC 'OK
'    Set objD = objX 'NG
    
'No.02-02-13  Set objD = New clsX を複数回にわけて実行
''' clsDはclsXをインプリメントしているので
''' clsXのインスタンスをclsX型の変数に代入した後で
''' clsD型の変数に代入
   Set objX = New clsX 'OK
'    Set objD = objX 'NG
End Sub

'*** クラスモジュール clsE
Option Explicit
Public Sub SubE()
    Debug.Print "clsE.subE"
End Sub

'*** クラスモジュール clsF
Option Explicit
'clsEをインプリメント
Implements clsE
Public Sub SubF()
    Debug.Print "clsF.SubF"
End Sub
'インプリメントしたプロシージャ名は
'クラス名_プロシージャ名 となる。
Private Sub clsE_SubE()
    Debug.Print "clsF.clsE_SubE"
End Sub

'*** クラスモジュール clsG
Option Explicit
'clsFをインプリメント
Implements clsF
Public Sub SubG()
    Debug.Print "clsG.SubG"
End Sub
'インプリメントしたプロシージャ名は
'クラス名_プロシージャ名 となる。
Private Sub clsF_SubF()
    Debug.Print "clsG.clsF_SubF"
End Sub

'*** 標準モジュール Module3
Option Explicit
Sub Test21()
''' １回で代入できる型を調べてみる
    Dim objE As clsE
    Dim objF As clsF
    Dim objG As clsG
    
'No.03-01
    Set objE = New clsE 'OK

'No.03-02
    Set objE = New clsF 'OK

'No.03-03
'    Set objE = New clsG 'NG
    
    
'No.03-04
'    Set objF = New clsE 'NG

'No.03-05
    Set objF = New clsF 'OK

'No.03-06
    Set objF = New clsG 'OK
    
    
'No.03-07
'    Set objG = New clsE 'NG

'No.03-08
'    Set objG = New clsF 'NG

'No.03-09
    Set objG = New clsG 'OK
End Sub
Sub Test22()
''' １回で代入できないので複数回にわけて代入
    Dim objE As clsE
    Dim objF As clsF
    Dim objG As clsG
    
'No.03-10  Set objE = New clsG を複数回にわけて実行
''' clsFでclsEをインプリメントしていて
''' clsGでclsFをインプリメントしているので
''' clsGのインスタンスをclsF型の変数に代入した後で
''' clsE型の変数に代入
    Set objG = New clsG 'OK
    Set objF = objG 'OK
'    Set objE = objF 'NG

'No.03-11  Set objF = New clsE を複数回にわけて実行
''' clsFでclsEをインプリメントしているので
''' clsEのインスタンスをclsE型の変数に代入した後で
''' clsF型の変数に代入
    Set objE = New clsE 'OK
'    Set objF = objE 'NG

'No.03-12  Set objG = New clsE を複数回にわけて実行
''' clsFでclsEをインプリメントしていて
''' clsGでclsFをインプリメントしているので
''' clsEのインスタンスをclsF型の変数に代入した後で
''' clsG型の変数に代入
    Set objE = New clsE 'OK
'    Set objF = objE 'NG
'    Set objG = objF 'NG

'No.03-13  Set objG = New clsF を複数回にわけて実行
''' clsGでclsFをインプリメントしているので
''' clsFのインスタンスをclsF型の変数に代入した後で
''' clsG型の変数に代入
    Set objF = New clsF 'OK
'    Set objG = objF 'NG
End Sub

みなさん、こんばんは。
 
勢いのあったスレッドを止めてしまい申し訳ありません。
「母が手術で・・」なんて書きましたので、もしかして？なんて思われた方も
いるかも知れませんが、全然違うのです。母は無事手術は成功しピンピンしております^^
 
私の方がやられていました。「腹痛かな？」なんて思っていましたらあれよあれよの内に
激痛に変わり「盲腸」でした^^; 病院に行ったきりそのまま入院でしたのでmougを見る事
も出来ずでした。すみません。（私の携帯は嫁にweb機能はあんたにはいらん！と切られて
います。。）
 
10日あまりの入院でしたが、ノートパソコン（これまたネットに繋がらない、、）は
持ってきてもらったので、相当な時間をかけて復習をしておりました。
こんなにじっくりコーディングをしたのは初めてでした。
 
今日退院しまして、体の調子はイマイチですが、頭の充電は完了しております。
 
引き続きよろしくお願い致します。

▼yayadonさん
 
「知ってたw」まったく言えませんでした^^;;
スレッドの流れでいうと私が一番言えないといけなかったのかな？と思っていたのですが、、
 
今日、UO3さんのスレッドを見ましたが凄い事になっていましたね。
私もまさにUO3さんの感覚に近い所にいる人間ですので、じっくり読んで研究してみます。
 
▼どんきちさん
 
考えてみました。
「Implementsは一方方向」という言葉がとてもヒントになりました。
複数回に分けても代入ができない場合どうするか？という問いですが
パターン３だと私の答えは
 
'*** クラスモジュール clsE
Option Explicit
Implements clsF
Implements clsG
Public Sub SubE()
    Debug.Print "clsE.subE"
End Sub
 
Private Sub clsF_SubF()
    Debug.Print "clsE.clsF_SubF"
End Sub
 
Private Sub clsG_SubG()
    Debug.Print "clsE.clsG_SubG"
End Sub
 
'*** クラスモジュール clsF
Option Explicit
Implements clsE
Implements clsG
Public Sub SubF()
    Debug.Print "clsF.subF"
End Sub
 
Private Sub clsE_SubE()
    Debug.Print "clsF.clsE_SubE"
End Sub
 
Private Sub clsG_SubG()
    Debug.Print "clsF.clsG_SubG"
End Sub
 
'*** クラスモジュール clsG
Option Explicit
Implements clsE
Implements clsF
 
Public Sub SubG()
    Debug.Print "clsG.SubG"
End Sub
 
Private Sub clsE_SubE()
     Debug.Print "clsG.clsE_SubE"
End Sub
Private Sub clsF_SubF()
    Debug.Print "clsG.clsF_SubF"
End Sub
 
「互いにImplementsをする」と思ったのですが、あっていますでしょうか？
 
# 入院中にImplementsを使ったお題をと自分に課して「オセロ」を作ってみました。
# これが多態性（ポリモーフィズム）と言えるのか皆様に見て頂きたいです^^

みそじのおじさん さんの引用:
今日退院しまして、体の調子はイマイチですが、頭の充電は完了しております。

前に出した問題について、まずは、代入できるとしたら、なぜ代入できるのか。代入でないとしたら、なぜ代入できないのか。
１回で代入できない場合は、２回にわけても、３回にわけても代入できないのはなぜなのか。
といったことを簡単な図解で説明してみたいと思います。
 
VBAのクラスモジュールでは、クラス内で定義されているpublicなプロパティやプロシージャを集めてインターフェイスが作られます。
あるクラスで別のクラスをインプリメントすると、クラスには別クラスの情報が実装されますが、インターフェイスには、別クラスのインターフェイスは含まれません。
clsBでclsAをインプリメントしている場合、clsBのクラスのインスタンスにはclsAのインターフェイスが実装されます。
しかし、clsBのインターフェイスには、clsAのインターフェイスは含まれません。
変数の宣言文でDim objA As clsA と記述したときに、Asの後のクラス名が意味するものはクラスではなく、インターフェイスです。
 
パターン１〜３の代入文で代入できるか、できないかを以下のルールに従って図解してみたいと思います。
・代入先の変数の型を丸括弧"()"、代入元の変数やインスタンスを角括弧"[]"で記述する。
・代入先の変数の丸括弧の中にはその変数が保持できるインターフェイスの型を記述する。
・代入元の角括弧の中には変数やインスタンスが持っているインターフェイスをカンマ区切りで記述する。
・代入元の角括弧の中で、現在使用している変数が利用しているインターフェイスの前にアスタリスク"*"をつける。
 
代入先の丸括弧の中と、代入元の角括弧の中に同じインターフェイスが存在すれば代入できます。
代入先の丸括弧の中と、代入元の角括弧の中に同じインターフェイスが存在しなければ代入できません。
変数やインスタンスを別の型の変数に代入してもインスタンスの中身は変わらないため、１度で代入できなければ、２回にわけても３回にわけても代入できません。
 
 
パターン１の代入文を図解すると以下のようになります。
 
No.01-01
<プログラム>
Set objA = New clsA 'OK
<図解>
objA(clsA) = clsA[clsA]
 
No.01-02
<プログラム>
Set objA = New clsB 'OK
<図解>
objA(clsA) = clsB[clsB,clsA]
 
No.01-03
<プログラム>
Set objB = New clsA 'NG
<図解>
objB(clsB) = clsA[clsA]
 
No.01-04
<プログラム>
Set objB = New clsB 'OK
<図解>
objB(clsB) = clsB[clsB,clsA]
 
 
パターン２の代入文を図解すると以下のようになります。
 
No.02-01
<プログラム>
Set objC = New clsC 'OK
<図解>
objC(clsC) = clsC[clsC,clsX]
 
No.02-02
<プログラム>
Set objC = New clsD 'NG
<図解>
objC(clsC) = clsD[clsD,clsX]
 
No.02-03
<プログラム>
Set objC = New clsX 'NG
<図解>
objC(clsC) = clsX[clsX]
     
     
No.02-04
<プログラム>
Set objD = New clsC 'NG
<図解>
objD(clsD) = clsC[clsC,clsX]
 
No.02-05
<プログラム>
Set objD = New clsD 'OK
<図解>
objD(clsD) = clsD[clsD,clsX]
 
No.02-06
<プログラム>
Set objD = New clsX 'NG
<図解>
objD(clsD) = clsX[clsX]
     
     
No.02-07
<プログラム>
Set objX = New clsC 'OK
<図解>
objX(clsX) = clsC[clsC,clsX]
 
No.02-08(OK)
<プログラム>
Set objX = New clsD 'OK
<図解>
objX(clsX) = clsD[clsD,clsX]
 
'No.02-09(OK)
<プログラム>
Set objX = New clsX 'OK
<図解>
objX(clsX) = clsX[clsX]
 
 
No.02-02-10
<プログラム>
Set objD = New clsD 'OK
Set objX = objD 'OK
Set objC = objX 'NG
<図解>
objD(clsD) = clsD[clsD,clsX]
objX(clsX) = objD[*clsD,clsX]
objC(clsC) = objX[clsD,*clsX]
 
No.02-02-11
<プログラム>
Set objX = New clsX 'OK
Set objC = objX 'NG
<図解>
objX(clsX) = clsX[clsX]
objC(clsC) = objX[*clsX]
 
No.02-02-12
<プログラム>
Set objC = New clsC 'OK
Set objX = objC 'OK
Set objD = objX 'NG
<図解>
objC(clsC) = clsC[clsC,clsX]
objX(clsX) = objC[*clsC,clsX]
objD(clsD) = objX[clsC,*clsX]
'
No.02-02-13
<プログラム>
Set objX = New clsX 'OK
Set objD = objX 'NG
<図解>
objX(clsX) = clsX[clsX]
objD(clsD) = objX[*clsX]
 
 
パターン３の代入文を図解すると以下のようになります。
 
No.03-01
<プログラム>
Set objE = New clsE 'OK
<図解>
objE(clsE) = clsE[clsE]
 
No.03-02
<プログラム>
Set objE = New clsF 'OK
<図解>
objE(clsE) = clsF[clsF,clsE]
 
No.03-03
<プログラム>
Set objE = New clsG 'NG
<図解>
objE(clsE) = clsG[clsG,clsF]
 
 
No.03-04
<プログラム>
Set objF = New clsE 'NG
<図解>
objF(clsF) = clsE[clsE]
 
No.03-05
<プログラム>
Set objF = New clsF 'OK
<図解>
objF(clsF) = clsF[clsF,clsE]
 
No.03-06
<プログラム>
' Set objF = New clsG 'OK
<図解>
objF(clsF) = clsG[clsG,clsF]
 
 
No.03-07
<プログラム>
Set objG = New clsE 'NG
<図解>
objG(clsG) = clsE[clsE]
 
No.03-08
<プログラム>
Set objG = New clsF 'NG
<図解>
objG(clsG) = clsF[clsF,clsE]
 
No.03-09
<プログラム>
Set objG = New clsG 'OK
<図解>
objG(clsG) = clsG[clsG,clsF]
 
 
No.03-10
<プログラム>
Set objG = New clsG 'OK
Set objF = objG 'OK
Set objE = objF 'NG
<図解>
objG(clsG) = clsG[clsG,clsF]
objF(clsF) = objG[*clsG,clsF]
objE(clsE) = objF[clsG,*clsF]
 
No.03-11
<プログラム>
Set objE = New clsE 'OK
Set objF = objE 'NG
<図解>
objE(clsE) = clsE[clsE]
objF(clsF) = objE[*clsE]
 
No.03-12
<プログラム>
Set objE = New clsE 'OK
Set objF = objE 'NG
Set objG = objF 'NG
<図解>
objE(clsE) = clsE[clsE]
objF(clsF) = objE[*clsE]
 
No.03-13
<プログラム>
Set objF = New clsF 'OK
Set objG = objF 'NG
<図解>
objF(clsF) = clsF[clsF,clsE]
objG(clsG) = objF[*clsF,clsE]
 
 
あるクラスのインスタンスを別の型の変数に代入しても、代入元のインスタンスの中身は変わっていません。
そのため、１回で代入できなければ複数回にわけても代入できません。
以下のように１回で代入した場合と、複数回にわけた場合の図解を比較してみれば、そのことがよくわかります。
 
 
No.02-02-10はNo.02-02を複数回にわけて実行しています。
 
No.02-02
objC(clsC) = clsD[clsD,clsX]
 
No.02-02-10
objD(clsD) = clsD[clsD,clsX]
objX(clsX) = objD[*clsD,clsX]
objC(clsC) = objX[clsD,*clsX]
 
 
No.03-10はNo.03-03を複数回にわけて実行しています。
 
No.03-03
objE(clsE) = clsG[clsG,clsF]
 
No.03-10
objG(clsG) = clsG[clsG,clsF]
objF(clsF) = objG[*clsG,clsF]
objE(clsE) = objF[clsG,*clsF]
 

みそじのおじさん さんの引用:
▼どんきちさん
 
考えてみました。
「Implementsは一方方向」という言葉がとてもヒントになりました。
複数回に分けても代入ができない場合どうするか？という問いですが
パターン３だと私の答えは
 
「互いにImplementsをする」と思ったのですが、あっていますでしょうか？

みなさん、こんにちは。
 
▼YU-TANGさん、どんきちさん
お見舞いのお言葉ありがとうございます。
私の悪友達も見舞いに来てくれたのですが、「くしゃみ、笑う」が一番辛いと言って
いるのに、痛がっている私をみてそれはもう面白がってかなり笑わされました^^　
腹筋を使う動作がかなりきつかったです。来てくれただけでもありがたいですが^^
 
▼皆様へ
入院中に「オセロ」を作成してみました。
すぐに投稿出来る状態だったのですが、仲良くなった向かいのベットにいた小５の男の子に
オセロをやってもらったところ「おじさん、これ弱い！」（笑）と言われてしまった為
Comのロジックを練り直しておりました^^;
 
さて本題ですが、今回このクラスを作成した目的は
 
・Implementsの練習（ポリモーフィズムを体感してみる）
・弱参照の体得（皆様解説ありがとうございました^^）
・低依存、責任範囲　（知り過ぎない事に注意しました）
・プロシージャの分割（粒度を意識して）
・メインコードをすっきりさせる　（ぱっと見で処理がわかるように）
・皆様との対戦で「私のロジックで勝利する」（笑）
 
です。
是非お為しになって頂き、これが「ポリモーフィズム」と言えるのかどうか教えて
頂きたいです。どんきちさんからもImplementsの例を出して頂いておりますが
実際どういった局面で使用するのか？といつも悩んでおりますのでアドバイスを
頂けると幸いです。Implemnets以外にもお気づきの点がありましたら宜しくお願い
致します。
　それと、ComのExpartモードを用意しておりますので是非勝敗の行方も教えてください（笑）
 
それではコードです。
今回はクラス４つです。規定のメンバは作成しておりませんのでそのまま
新規ワークブックにコピペして頂いて標準モジュールの「OthelloMain」を実行して
下さい。
 
操作方法
白・黒はランダムに決定します。黒が先攻です。
Comの強さを聞いてきますのでNormalかExpartを選択して下さい。
セルを選択してダブルクリックをすると駒を置きます。
ゲームを途中で止める時には右クリックして下さい。その旨が出ます。
白黒共に置ける場所が無い場合はその時点でジャッジします。
 
標準モジュール

Option Explicit

''列挙体 プレーヤーのタイプ
Public Enum EPlayerType
    otManualPlayer = 0 'Manual
    otComPlayer = 1    'Com
End Enum

''ユーザー定義型 オセロ盤基準位置
Public Type UDatumPoint
    Row As Long       '行
    Column As Long    '列
End Type

''列挙体 盤の状態
Public Enum EBoardState
    otNone = 0        '何も置かれていない
    otBlackHas = 1    '黒
    otWhiteHas = 2    '白
End Enum

''ユーザー定義型 駒を置いた位置
Public Type UPutPos
    Row As Long
    Column As Long
End Type

''列挙体 駒の色
Public Enum EPieceColor
    otBlack = 1
    otWhite = 2
End Enum

''ユーザー定義型　駒反転用
Public Type UTurnUp
    Row   As Long
    Column As Long
    Color As Long
End Type

''列挙体 VSモード
Public Enum EVsMode
    otManualVsCom = 0
    otComVsCom = 1
    otManualVsManual = 2
End Enum

''列挙体　進行状態
Public Enum EPlayState
    otPlayNotBegin = 0 '未スタート
    otPlayCancel = 1   'Cancelした
    otPlayTwoPass = 2  '2回連続でパスをした
    otPlaying = 3      'プレイ中
End Enum

''ユーザー定義型  盤のデータ
Public Type UMemoryBoard
    State As EBoardState
    Level As Long
    TurnUpCount As Long
    Puted As Boolean
    WinCount As Long
End Type

''ユーザー定義型 オセロプレーヤーのプロパティ
Public Type UOthelloPlayer
    Name          As String      ''名前
    PlayerType    As EPlayerType ''Type
    PeiceColor    As EPieceColor ''駒の色
    PeiceCount    As Long        ''駒の数
    PutPos        As UPutPos     ''駒を置いた場所
    Puted         As Boolean     ''駒を置いた
    Parent        As Long        ''親参照用 OthelloManagerの参照先アドレス
End Type

''タイトル
Public Const OTHELLO_TITLE As String = "OJN's Othello"

Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" _
            (Destination As Any, Source As Any, ByVal Length As Long)


Public Sub OthelloMain()

    Dim Othello As OthelloManager
    Dim DatumPoint As UDatumPoint
        
        ''オセロ盤を作成する基準位置
        With DatumPoint
            .Row = 2
            .Column = 2
        End With
        
        ''オセロ管理者のインスタンス作成
        Set Othello = New OthelloManager
        
        With Othello
            
            ''初期化処理が完了しなかったらExit
            ''（高速にゲームを進めるなら第3引数をTrueに）
            If Not .Init(Worksheets(1), DatumPoint, False) Then Exit Sub
            
            ''VSモードが選択されなかったらExit
            If Not .VsModeSelect() Then Exit Sub
            
            ''Othelloスタート
            Do
                ''カレントプレーヤーの変更
                .ChangePlayer IsMsg:=True   ''メッセージが必要なければFalse
                                
                ''一つ以上相手の駒を反転させられる場所があるなら
                If .HasPutPosition(.Board, .CurrentPlayer.PeiceColor) Then
                    ''マスを指定する
                    If .CurrentPlayer.SelectPos() Then
                        ''駒を置く
                        Call .PutPiece(.CurrentPlayer.PutPos, _
                                       .CurrentPlayer.PeiceColor)
                    End If
                End If
                               
                ''白黒の駒の数をカウント
                .PeiceCount
                
                ''シートのイベントを受け付ける為DoEvnets
                DoEvents
                
                ''残りマスが0個ならExit
                If .LeftOverCount(.Board) = 0 Then Exit Do
                
                ''ユーザーの割り込みによるCancel時 Exit
                If .PlayState <= 2 Then Exit Do
            Loop
            
            ''判定する
            .Judge
            
        End With
                
        Set Othello = Nothing
End Sub

Option Explicit
''※※IsVirtualの引数を受け付けるプロシージャは仮想盤上での計算です
''※※False時は全ての結果を盤上に返しますが、True時は計算のみの使用です
''※※IsVirtual=TrueはComPlayerが使用しています。

''シートのダブル・ライトクリックを取得する為WithEvents宣言
Private WithEvents mOthelloSheet As Worksheet

Private Const BOARD_SIZE As Long = 8   ''マスの数
Private Const CELL_WIDTH As Single = 6 ''マスの幅
Private Const PEICE_LINE_WEIGHT As Single = 0.25 ''駒の外枠太さ
Private Const PEICE_OFFSET As Single = 8 ''駒のサイズ調整用
Private Const BOARD_COLOR As Long = 32768 ''盤の色

''ゲームの進行を止めない為に、自動的に閉じるMsgBoxを使用
Private Declare Function MessageBoxTimeoutA Lib "user32" _
                       (ByVal hwnd As Long, _
                        ByVal lpText As String, _
                        ByVal lpCaption As String, _
                        ByVal uType As Long, _
                        ByVal wLanguageId As Long, _
                        ByVal dwMilliseconds As Long) As Long

''MyProperties
Private Type UOthelloManager
    OthelloSheet   As Worksheet
    VsMode         As EVsMode
    Player(1)      As IOthelloPlayer
    CurrentPlayer  As IOthelloPlayer
    DatumPoint     As UDatumPoint
    PutPos         As UPutPos
    LeftOverCount  As Long
    PlayState      As EPlayState
    PassCount      As Long
    WaitSkip       As Boolean
    Board(BOARD_SIZE - 1, BOARD_SIZE - 1) As UMemoryBoard
End Type

''PlayerInfo
Private Type UPlayerInfo
    Name As String
    PeiceColorName As String
    PeiceCount As Long
End Type

Private mp As UOthelloManager

Private Sub Class_Terminate()
    
    Application.EnableCancelKey = xlInterrupt
    SetStatusBar False
    Call BoardProtect(False)
    Set mOthelloSheet = Nothing
    
    Debug.Print "OthelloManager_Term!"
End Sub

''オセロゲームの初期化
Public Function Init(ByVal OthelloSheet As Worksheet, _
                     ByRef DatumPoint As UDatumPoint, _
                     ByVal WaitSkip As Boolean) As Boolean
    
    Set mp.OthelloSheet = OthelloSheet
    Set mOthelloSheet = mp.OthelloSheet
        
    mp.DatumPoint = DatumPoint
    mp.WaitSkip = WaitSkip
    
    Call BoardProtect(False)
    
    If Not CreateOthelloBoard() Then Exit Function
    If Not DeleteAllPiece() Then Exit Function
    If Not InitPiece() Then Exit Function
    
    Call BoardProtect(True)
    
    Init = True
    
End Function

''オセロ盤を作成する
Private Function CreateOthelloBoard() As Boolean
             
    Dim r As Long
    Dim c As Long
    Dim myR As Range
    
        On Error GoTo Err_Handle
            
            With mp.DatumPoint
                r = .Row
                c = .Column
            End With
                        
            With mp.OthelloSheet
                
                Set myR = .Range(.Cells(r, c), _
                                 .Cells(r + BOARD_SIZE - 1, c + BOARD_SIZE - 1))
                With myR
                    .Locked = False
                    .Interior.Color = BOARD_COLOR
                    .ColumnWidth = CELL_WIDTH
                    .RowHeight = .Item(1).Width
                    
                    .BorderAround xlContinuous, xlThin, , vbGreen
                    
                    With .Borders(xlInsideHorizontal)
                        .LineStyle = xlContinuous
                        .Color = vbWhite
                        .Weight = xlHairline
                    End With
                    
                    With .Borders(xlInsideVertical)
                        .LineStyle = xlContinuous
                        .Color = vbWhite
                        .Weight = xlHairline
                    End With
                End With
            End With
                        
        On Error GoTo 0
    
    CreateOthelloBoard = True
    
    Exit Function
Err_Handle:
    MsgBox Err.Description
End Function

''VSモードを決定する
Public Function VsModeSelect() As Boolean
    Dim vm As Variant
    
        Do
            vm = Application.InputBox("VSモードを選択" & vbLf & vbLf & _
                                    "0 : Manual Vs Com    " & vbLf & _
                                    "1 : Com    Vs Com" & vbLf & _
                                    "2 : Manual Vs Manual", _
                                    OTHELLO_TITLE, 0, , , , , 1)
                                    
            If VarType(vm) = vbBoolean Then Exit Function
            vm = CLng(vm)
        Loop Until (vm >= 0) And (vm <= 2)
         
        VsMode = vm
        VsModeSelect = True
        mp.PlayState = otPlaying
         
End Function

''VSモード選択時 プレイヤー２名を動的に作成する
Private Property Let VsMode(ByVal NewVsMode As EVsMode)
    
    Dim ptr As Long
    
    ptr = ObjPtr(Me)
    
    With mp
        .VsMode = NewVsMode
        
        Select Case .VsMode
            Case otManualVsCom
            
                Set .Player(0) = New ManualPlayer
                    .Player(0).Init "Player1", ptr
                    
                Set .Player(1) = New ComPlayer
                    .Player(1).Init "Com1", ptr
                    
            Case otComVsCom
            
                Set .Player(0) = New ComPlayer
                    .Player(0).Init "Com1", ptr
                    
                Set .Player(1) = New ComPlayer
                    .Player(1).Init "Com2", ptr
                    
            Case otManualVsManual
            
                Set .Player(0) = New ManualPlayer
                    .Player(0).Init "Player1", ptr
                    
                Set .Player(1) = New ManualPlayer
                    .Player(1).Init "Player2", ptr
        End Select
    End With
    
End Property

''既存の駒を全て削除する関数
Private Function DeleteAllPiece() As Boolean
    
    Dim PieceShape As Shape
      
        On Error GoTo Err_Handle
        
            For Each PieceShape In mp.OthelloSheet.Shapes
               If PieceShape.AutoShapeType = msoShapeOval Then
                  PieceShape.Delete
               End If
            Next
       
        On Error GoTo 0
    
    DeleteAllPiece = True
     
    Exit Function
Err_Handle:

End Function

''対角上に白黒の駒を配置する関数
Private Function InitPiece() As Boolean
    Dim Pos As UPutPos
    
        With Pos
            .Row = 3
            .Column = 4
        End With
        PutPiece Pos, otBlack
        
        With Pos
            .Row = 4
            .Column = 3
        End With
        PutPiece Pos, otBlack
    
        With Pos
            .Row = 3
            .Column = 3
        End With
        PutPiece Pos, otWhite
        
        With Pos
            .Row = 4
            .Column = 4
        End With
        PutPiece Pos, otWhite
        
        InitPiece = True
End Function

''指定したマスに指定した色の駒を置く関数
Public Function PutPiece(ByRef PutPos As UPutPos, _
                         ByVal PeiceColor As EPieceColor) As Boolean
    
    Dim r  As Range
    Dim sp As Shape
    Dim p  As Single
    
    On Error GoTo Err_Handle:
        
        
        With mp
            
            .PutPos = PutPos
            
            Set r = .OthelloSheet.Cells(.DatumPoint.Row + .PutPos.Row, _
                    .DatumPoint.Column + .PutPos.Column)
        
            If .Board(.PutPos.Row, .PutPos.Column).State = otNone Then
            
                r.Select
                p = r.Width / PEICE_OFFSET ''駒のサイズ調整用
                
                Call BoardProtect(False)
                Set sp = .OthelloSheet.Shapes.AddShape _
                         (msoShapeOval, r.Left + p, r.Top + p, _
                          r.Width - 2 * p, r.Height - 2 * p)
                With sp
                    .Fill.ForeColor.RGB = GetColor(PeiceColor)
                    .Line.Weight = PEICE_LINE_WEIGHT
                End With
                
                Call BoardProtect(True)
                Call Wait(200)
                
                .Board(.PutPos.Row, .PutPos.Column).State = PeiceColor
                TurnUpCount .Board(), PutPos.Row, PutPos.Column, PeiceColor, True
                
                
            End If
            
        End With
    On Error GoTo 0
    
    PutPiece = True
    Exit Function
Err_Handle:

End Function

''ManualPlayer時 マスの選択を検知する
Private Sub mOthelloSheet_BeforeDoubleClick(ByVal Target As Range, _
                                            Cancel As Boolean)
    Dim Pos As UPutPos
    
    Cancel = True
        
    If Not mp.CurrentPlayer Is Nothing Then
        With mp.CurrentPlayer
            ''カレントプレイヤーのタイプがManual時
            If .PlayerType = otManualPlayer Then
                If Target.Count = 1 Then
                    Pos.Row = Target.Row - mp.DatumPoint.Row
                    Pos.Column = Target.Column - mp.DatumPoint.Column
                    
                    ''指定したマスに駒を置いた時、一枚でも相手の駒が反転するなら
                    If TurnUpCount(mp.Board, Pos.Row, Pos.Column, _
                                                    .PeiceColor, False) > 0 Then
                        .PutPos = Pos
                        .Puted = True
                        ''実際に駒を置く
                        PutPiece Pos, .PeiceColor
                    Else
                        MsgBoxEx .PeiceColorName & "は、そこには置けません。", _
                                 vbExclamation, OTHELLO_TITLE, 1
                    End If
                End If
            End If
        End With
    End If
    
End Sub

''オセロをキャンセル出来るよう右クリックを検知する
Private Sub mOthelloSheet_BeforeRightClick(ByVal Target As Range, _
                                           Cancel As Boolean)
    Cancel = True
  
    If MsgBox(OTHELLO_TITLE & "を終了しますか？", _
              vbQuestion Or vbYesNo Or _
              vbDefaultButton2, OTHELLO_TITLE) = vbYes Then
        mp.PlayState = otPlayCancel
    End If
    
End Sub

''駒の色をLong値で返す
Private Function GetColor(ByVal PeiceColor As Long) As Long
    
    Dim lngColor As Long
    
        Select Case PeiceColor
            Case otBlack
                lngColor = vbBlack
            Case otWhite
                lngColor = vbWhite
        End Select
        
        GetColor = lngColor
End Function


''盤の状態を配列で返す
Public Property Get Board() As UMemoryBoard()
    Board = mp.Board()
End Property

''カレントプレーヤーを変更する
Public Sub ChangePlayer(Optional ByVal IsMsg As Boolean = True)

    Call Wait(500)
    
    ''先攻後攻が未決定時
    If CurrentPlayer Is Nothing Then
        ''ランダムにプレーヤーを抽出する
        Set CurrentPlayer = ChoosePlayer()
        Exit Sub
    End If
    
    ''プレーヤーを変更する
    If CurrentPlayer Is mp.Player(0) Then
        Set CurrentPlayer = mp.Player(1)
    Else
        Set CurrentPlayer = mp.Player(0)
    End If
    
    ''変更した事を告げる
    If IsMsg Then
        MsgBoxEx CurrentPlayer.PeiceColorName & " " & _
                 CurrentPlayer.Name, vbInformation, OTHELLO_TITLE, 1
    End If
    
End Sub

''先攻後攻をランダムに決定する
Private Function ChoosePlayer() As IOthelloPlayer
    Dim i As Single
    Dim msg$, msg2$
        
        Randomize Now()
        i = Round(Rnd(), 0)
        
        Set ChoosePlayer = mp.Player(i)
        
        If CBool(i) Then
            mp.Player(1).PeiceColor = otBlack
            mp.Player(0).PeiceColor = otWhite
            msg = "先攻 黒 " & mp.Player(1).Name & vbLf _
                  & "後攻 白 " & mp.Player(0).Name
        Else
            mp.Player(0).PeiceColor = otBlack
            mp.Player(1).PeiceColor = otWhite
            msg = "先攻 黒 " & mp.Player(0).Name & vbLf _
                  & "後攻 白 " & mp.Player(1).Name
        End If
        
        msg2 = "ダブルクリック : 駒を置く" & vbLf & "右クリック : 終了する"
        
        MsgBoxEx msg & vbLf & vbLf & msg2, vbInformation, OTHELLO_TITLE, 2
        
End Function

Public Property Get CurrentPlayer() As IOthelloPlayer
    Set CurrentPlayer = mp.CurrentPlayer
End Property

Private Property Set CurrentPlayer(ByVal NewPlayer As IOthelloPlayer)
    Set mp.CurrentPlayer = NewPlayer
End Property

''指定時間で自動的に閉じるMsgBox
Private Sub MsgBoxEx(ByVal msg As String, ByVal mode As VbMsgBoxStyle, _
                     ByVal Title As String, ByVal Interval As Long)

    MessageBoxTimeoutA 0&, msg, Title, mode, 0&, Interval * 1000&
       
End Sub

''進行状態を返す
Public Property Get PlayState() As EPlayState
    PlayState = mp.PlayState
End Property

''残りマスの数を返す
Public Property Get LeftOverCount(ByRef m() As UMemoryBoard) As Long
    Dim r&, c&
    
        For r = LBound(m, 1) To UBound(m, 1)
            For c = LBound(m, 2) To UBound(m, 2)
                If m(r, c).State = otNone Then
                    LeftOverCount = LeftOverCount + 1
                End If
            Next
        Next
End Property

''指定したプレーヤーが一つ以上駒を置ける場所があるか返す
Public Property Get HasPutPosition(ByRef m() As UMemoryBoard, _
                                   ByVal TargetColor As EPieceColor, _
                                   Optional ByVal IsVirtual As Boolean = False) As Boolean
    
    Dim Count As Long
    Dim r&, c&
                   
        For r = LBound(m, 1) To UBound(m, 1)
            For c = LBound(m, 2) To UBound(m, 2)
                If m(r, c).State = otNone Then
                    If TurnUpCount(m, r, c, TargetColor, False) > 0 Then
                        If Not IsVirtual Then
                            Me.PassCount = 0
                        End If
                        HasPutPosition = True
                        Exit Property
                    End If
                End If
            Next
        Next
        
        If Not IsVirtual Then
            With mp.CurrentPlayer
                If Not HasPutPosition Then
                    MsgBoxEx .PeiceColorName & " " & .Name & _
                             "は置ける場所がありません。" & _
                             vbLf & "パスします。", vbInformation, OTHELLO_TITLE, 2
                    ''パス時
                    ''プロパティのカウントアップ
                    Me.PassCount = Me.PassCount + 1
                End If
            End With
        End If
End Property

''(IsTurnUp=False時）指定したマスに置くと相手の駒を何枚反転させれるか返す
''(IsTurnUp=True 時）計算と同時に実際に相手の駒を反転する
Public Function TurnUpCount(ByRef m() As UMemoryBoard, _
                            ByVal ixRow As Long, ByVal ixCol As Long, _
                            ByVal Color As EPieceColor, _
                            ByVal IsTurnUp As Boolean, _
                            Optional ByVal IsVirtual As Boolean = False) As Long
    Dim Count As Long
               
    Count = Count + BoardSearch(m, ixRow, ixCol, 0, 1, Color, IsTurnUp, IsVirtual)
    Count = Count + BoardSearch(m, ixRow, ixCol, 1, 1, Color, IsTurnUp, IsVirtual)
    Count = Count + BoardSearch(m, ixRow, ixCol, 1, 0, Color, IsTurnUp, IsVirtual)
    Count = Count + BoardSearch(m, ixRow, ixCol, 1, -1, Color, IsTurnUp, IsVirtual)
    Count = Count + BoardSearch(m, ixRow, ixCol, 0, -1, Color, IsTurnUp, IsVirtual)
    Count = Count + BoardSearch(m, ixRow, ixCol, -1, -1, Color, IsTurnUp, IsVirtual)
    Count = Count + BoardSearch(m, ixRow, ixCol, -1, 0, Color, IsTurnUp, IsVirtual)
    Count = Count + BoardSearch(m, ixRow, ixCol, -1, 1, Color, IsTurnUp, IsVirtual)
        
    TurnUpCount = Count
    
End Function

''配列上の駒の並びより、計算する
Private Function BoardSearch(ByRef m() As UMemoryBoard, _
                             ByVal ixRow As Long, ByVal ixCol As Long, _
                             ByVal StepR As Long, StepC As Long, _
                             ByVal CheckColor As EPieceColor, _
                             ByVal IsTurnUp As Boolean, _
                             Optional ByVal IsVirtual As Boolean = False) As Long
    
    Dim r As Long, c As Long
    Dim Count As Long, i As Long
    Dim Flag As Boolean
    Dim TurnUpArray() As UTurnUp
       
    
    Count = 0: Flag = False: i = 0
    r = ixRow + StepR: c = ixCol + StepC
            
    Select Case True
        ''右
        Case StepR = 0 And StepC = 1
            Do While c <= UBound(m, 2)
                If Not Calc(m, r, c, CheckColor, Count, Flag) Then Exit Do
                ReDim Preserve TurnUpArray(i)
                TurnUpArray(i).Color = CheckColor
                TurnUpArray(i).Row = r
                TurnUpArray(i).Column = c
                r = r + StepR: c = c + StepC: i = i + 1
            Loop
        ''右下
        Case StepR = 1 And StepC = 1
            Do While r <= UBound(m, 1) And c <= UBound(m, 2)
                If Not Calc(m, r, c, CheckColor, Count, Flag) Then Exit Do
                ReDim Preserve TurnUpArray(i)
                TurnUpArray(i).Color = CheckColor
                TurnUpArray(i).Row = r
                TurnUpArray(i).Column = c
                r = r + StepR: c = c + StepC: i = i + 1
            Loop
            
        ''下
        Case StepR = 1 And StepC = 0
            Do While r <= UBound(m, 1)
                If Not Calc(m, r, c, CheckColor, Count, Flag) Then Exit Do
                ReDim Preserve TurnUpArray(i)
                TurnUpArray(i).Color = CheckColor
                TurnUpArray(i).Row = r
                TurnUpArray(i).Column = c
                r = r + StepR: c = c + StepC: i = i + 1
            Loop
            
        ''左下
        Case StepR = 1 And StepC = -1
            Do While r <= UBound(m, 1) And c >= LBound(m, 2)
                If Not Calc(m, r, c, CheckColor, Count, Flag) Then Exit Do
                ReDim Preserve TurnUpArray(i)
                TurnUpArray(i).Color = CheckColor
                TurnUpArray(i).Row = r
                TurnUpArray(i).Column = c
                r = r + StepR: c = c + StepC: i = i + 1
            Loop

        ''左
        Case StepR = 0 And StepC = -1
            Do While c >= LBound(m, 2)
                If Not Calc(m, r, c, CheckColor, Count, Flag) Then Exit Do
                ReDim Preserve TurnUpArray(i)
                TurnUpArray(i).Color = CheckColor
                TurnUpArray(i).Row = r
                TurnUpArray(i).Column = c
                r = r + StepR: c = c + StepC: i = i + 1
            Loop
        
         ''左上
        Case StepR = -1 And StepC = -1
            Do While r >= LBound(m, 1) And c >= LBound(m, 2)
                If Not Calc(m, r, c, CheckColor, Count, Flag) Then Exit Do
                ReDim Preserve TurnUpArray(i)
                TurnUpArray(i).Color = CheckColor
                TurnUpArray(i).Row = r
                TurnUpArray(i).Column = c
                r = r + StepR: c = c + StepC: i = i + 1
            Loop
        
         ''上
        Case StepR = -1 And StepC = 0
            Do While r >= LBound(m, 1)
                If Not Calc(m, r, c, CheckColor, Count, Flag) Then Exit Do
                ReDim Preserve TurnUpArray(i)
                TurnUpArray(i).Color = CheckColor
                TurnUpArray(i).Row = r
                TurnUpArray(i).Column = c
                r = r + StepR: c = c + StepC: i = i + 1
            Loop
            
        ''右上
        Case StepR = -1 And StepC = 1
            Do While r >= LBound(m, 1) And c <= UBound(m, 2)
                If Not Calc(m, r, c, CheckColor, Count, Flag) Then Exit Do
                ReDim Preserve TurnUpArray(i)
                TurnUpArray(i).Color = CheckColor
                TurnUpArray(i).Row = r
                TurnUpArray(i).Column = c
                r = r + StepR: c = c + StepC: i = i + 1
            Loop
    End Select
    
    ''FlagがFalseは挟む駒がない状態
    If Not Flag Then
        Count = 0
        Erase TurnUpArray
    End If
    
    ''True時　TurnUpメソッドを呼び出し駒を反転させる
    If IsTurnUp Then
        If Count > 0 Then
            Call TurnUp(m, TurnUpArray, CheckColor, IsVirtual)
        End If
    End If
    
    BoardSearch = Count
End Function

''駒が置かれた駒に挟まれているか計算
Private Function Calc(ByRef m() As UMemoryBoard, _
                      ByVal ixRow As Long, ByVal ixCol As Long, _
                      ByVal CheckColor As EPieceColor, _
                      ByRef Count&, ByRef Flag As Boolean) As Boolean
    
    If m(ixRow, ixCol).State = 0 Then Exit Function
    
    If m(ixRow, ixCol).State = CheckColor Then
        Flag = True
        Exit Function
    End If
    
    Count = Count + 1
    Calc = True
    
End Function

''駒を反転する
Private Sub TurnUp(ByRef m() As UMemoryBoard, TurnUpArray() As UTurnUp, _
                   ByVal TargetColor As EPieceColor, _
                   Optional ByVal IsVirtual As Boolean = False)

    Dim r&, c&
    Dim ps As Shape, ts As Shape
    Dim pr As Range
    Dim i&
    
    If Not IsVirtual Then ''盤上の駒を反転
        For i = 0 To UBound(TurnUpArray)
            With TurnUpArray(i)
                Set pr = mp.OthelloSheet.Cells(mp.DatumPoint.Row + .Row, _
                                               mp.DatumPoint.Column + .Column)
                For Each ps In mp.OthelloSheet.Shapes
                    If ps.AutoShapeType = msoShapeOval Then
                        If pr.Address(0, 0) = ps.TopLeftCell.Address(0, 0) Then
                            ps.Fill.ForeColor.RGB = GetColor(TargetColor)
                            mp.Board(.Row, .Column).State = TargetColor
                            Call Wait(100)
                         End If
                    End If
                Next
            End With
        Next
    Else ''仮想盤の駒反転
        For i = 0 To UBound(TurnUpArray)
            With TurnUpArray(i)
                m(.Row, .Column).State = TargetColor
            End With
        Next
    End If
    
End Sub


''オセロ盤の保護・保護解除
Private Sub BoardProtect(ByVal blnProtect As Boolean)

    With mp.OthelloSheet
        If blnProtect Then
            .Protect , True, , , True
            .EnableSelection = xlUnlockedCells
        Else
            .Unprotect
            .EnableSelection = xlNoRestrictions
        End If
    End With
    
End Sub

''指定秒プレイを中断する
Public Sub Wait(ByVal dwMilliseconds As Long)
    If Not mp.WaitSkip Then
        Application.EnableCancelKey = xlDisabled
        DoEvents
        Call Sleep(dwMilliseconds)
        Application.EnableCancelKey = xlErrorHandler
    End If
End Sub

'白黒それぞれの数を数える
Public Sub PeiceCount()

    Dim r&, c&
    Dim bc&, wc&
    Dim i&
    
        For r = LBound(mp.Board, 1) To UBound(mp.Board, 1)
            For c = LBound(mp.Board, 2) To UBound(mp.Board, 2)
                
                Select Case mp.Board(r, c).State
                    Case otNone
                    Case otBlackHas
                        bc = bc + 1
                    Case otWhiteHas
                        wc = wc + 1
                End Select
            Next
        Next
        
        For i = 0 To UBound(mp.Player)
            With mp.Player(i)
                If .PeiceColor = otBlack Then
                    .PeiceCount = bc
                Else
                    .PeiceCount = wc
                End If
            End With
        Next
        
        SetStatusBar "白 : " & wc & " 黒 :" & bc
End Sub

''ステータスバーにMsgを表示
Private Sub SetStatusBar(ByVal msg As Variant)
    Application.StatusBar = msg
End Sub

''終了時 駒の数より判定する
Public Sub Judge()

    Dim p(1) As UPlayerInfo
    Dim i&
    Dim msg$
    
    If mp.PlayState >= 2 Then
        For i = 0 To 1
            With p(i)
                .Name = mp.Player(i).Name
                .PeiceColorName = mp.Player(i).PeiceColorName
                .PeiceCount = mp.Player(i).PeiceCount
            End With
        Next
        
        Select Case True
            Case p(0).PeiceCount > p(1).PeiceCount
                msg = p(0).PeiceColorName & " " & p(0).PeiceCount & " : " & _
                      p(1).PeiceColorName & " " & p(1).PeiceCount & vbLf & vbLf & _
                      "Winner " & p(0).PeiceColorName & " " & p(0).Name
                
            Case p(0).PeiceCount = p(1).PeiceCount
                msg = p(0).PeiceColorName & " " & p(0).PeiceCount & " : " & _
                      p(1).PeiceColorName & " " & p(1).PeiceCount & vbLf & vbLf & _
                      "同点で引き分けです。 "
                      
            Case p(0).PeiceCount < p(1).PeiceCount
                msg = p(0).PeiceColorName & " " & p(0).PeiceCount & " : " & _
                      p(1).PeiceColorName & " " & p(1).PeiceCount & vbLf & vbLf & _
                      "Winner " & p(1).PeiceColorName & " " & p(1).Name
        End Select
    
    Else
        msg = "終了しました。"
    End If
    
    MsgBox msg, vbInformation, OTHELLO_TITLE
End Sub

Public Property Get PassCount() As Long
    PassCount = mp.PassCount
End Property

''パスを２回連続ですると、オセロは続行出来ない為
''PlayStateにotPlayTwoPassを設定しループを抜け出す
Public Property Let PassCount(ByVal NewPassCount As Long)

    mp.PassCount = NewPassCount
    
    If mp.PassCount = 2 Then
        mp.PassCount = 0
        mp.PlayState = otPlayTwoPass
        MsgBoxEx "白黒共に置ける場所がありません。" & vbLf & _
                 "この状態で、ジャッジします。", vbInformation, OTHELLO_TITLE, 2
    End If
End Property

Option Explicit

Public Sub Init(ByVal PlayerName As String, ByVal Parent As Long)

End Sub
Public Function SelectPos() As Boolean

End Function

Public Property Get Name() As String

End Property

Public Property Let Name(ByVal NewName As String)

End Property

Public Property Get PlayerType() As EPlayerType
    
End Property

Public Property Get PeiceColor() As EPieceColor
    
End Property

Public Property Let PeiceColor(ByVal NewPeiceColor As EPieceColor)
    
End Property

Public Property Get PeiceColorName() As String
    
End Property

Public Property Get Puted() As Boolean

End Property

Public Property Let Puted(ByVal blnPuted As Boolean)

End Property

Public Property Get PutPos() As UPutPos

End Property

Public Property Let PutPos(ByRef NewPutPos As UPutPos)

End Property

Public Function GetParent(ByVal vptr As Long) As OthelloManager

End Function

Public Property Get PeiceCount() As Long

End Property

Public Property Let PeiceCount(ByVal Count As Long)

End Property

Option Explicit

Implements IOthelloPlayer

Private mp As UOthelloPlayer

Private Sub Class_Initialize()
    mp.PlayerType = otManualPlayer
End Sub

Private Sub Class_Terminate()
   Debug.Print mp.Name & "_Term!"
End Sub
            
Private Function IOthelloPlayer_GetParent(ByVal vptr As Long) As OthelloManager
    Dim tmp As OthelloManager
    
        MoveMemory tmp, vptr, 4&
        Set IOthelloPlayer_GetParent = tmp
        MoveMemory tmp, 0&, 4&
        
End Function

Private Sub IOthelloPlayer_Init(ByVal PlayerName As String, ByVal Parent As Long)
    
    Dim Name
    
        Do
            Name = Application.InputBox("名前を入力", _
                                OTHELLO_TITLE, PlayerName, , , , , 2)
                                
        Loop Until TypeName(Name) = "String" And Name <> ""
        
        IOthelloPlayer_Name = Name
        mp.Parent = Parent
End Sub

Private Property Let IOthelloPlayer_Name(ByVal RHS As String)
    mp.Name = RHS
End Property

Private Property Get IOthelloPlayer_Name() As String
    IOthelloPlayer_Name = mp.Name
End Property

Private Property Let IOthelloPlayer_PeiceColor(ByVal RHS As EPieceColor)
    mp.PeiceColor = RHS
End Property

Private Property Get IOthelloPlayer_PeiceColor() As EPieceColor
    IOthelloPlayer_PeiceColor = mp.PeiceColor
End Property

Private Property Get IOthelloPlayer_PeiceColorName() As String
    IOthelloPlayer_PeiceColorName = IIf(mp.PeiceColor = otBlack, "黒", "白")
End Property

Private Property Let IOthelloPlayer_PeiceCount(ByVal RHS As Long)
    mp.PeiceCount = RHS
End Property

Private Property Get IOthelloPlayer_PeiceCount() As Long
    IOthelloPlayer_PeiceCount = mp.PeiceCount
End Property

Private Property Get IOthelloPlayer_PlayerType() As EPlayerType
    IOthelloPlayer_PlayerType = mp.PlayerType
End Property

Private Property Let IOthelloPlayer_Puted(ByVal RHS As Boolean)
    mp.Puted = RHS
End Property

Private Property Get IOthelloPlayer_Puted() As Boolean
    IOthelloPlayer_Puted = mp.Puted
End Property

Private Property Let IOthelloPlayer_PutPos(RHS As UPutPos)
    mp.PutPos = RHS
End Property

Private Property Get IOthelloPlayer_PutPos() As UPutPos
    IOthelloPlayer_PutPos = mp.PutPos
End Property

''ManualPlayerのマス選択関数
''Do Loopにより選択されるまで待機する
Private Function IOthelloPlayer_SelectPos() As Boolean

    Dim Parent As OthelloManager
    
        IOthelloPlayer_Puted = False
        
        Set Parent = IOthelloPlayer_GetParent(mp.Parent)
        
        Do
            DoEvents
            If (Parent.PlayState <= 1) Then Exit Function
            
        Loop While Not mp.Puted
        
        IOthelloPlayer_SelectPos = True
        
End Function

Option Explicit

Implements IOthelloPlayer

Public Enum EComLevel
    otComNormal = 0
    otComExpart = 1
End Enum

''戦術を切り替える残りマス数
Private Const TACTICS_SWITCH_COUNT As Long = 16

Private mp As UOthelloPlayer
Private SectionLevel(9) As Long
Private mComLevel       As EComLevel


Private Sub Class_Initialize()
    mp.PlayerType = otComPlayer
End Sub

Private Sub Class_Terminate()
    Debug.Print mp.Name & "_Term!"
End Sub

''「弱参照」でOthelloManagerを得る
Private Function IOthelloPlayer_GetParent _
                                (ByVal vptr As Long) As OthelloManager
    Dim tmp As OthelloManager
    
        MoveMemory tmp, vptr, 4&
        Set IOthelloPlayer_GetParent = tmp
        MoveMemory tmp, 0&, 4&
        
End Function

''ComPlayer初期化処理
Private Sub IOthelloPlayer_Init(ByVal PlayerName As String, _
                                ByVal Parent As Long)
                                
    IOthelloPlayer_Name = PlayerName
    mp.Parent = Parent
    
    mComLevel = SetComLevel()
    If mComLevel = otComNormal Then
        Call LevelSet
    End If
    
End Sub

''Comのレベルを決定する
Private Function SetComLevel() As EComLevel

    Dim vLevel As Variant
    
        Do
            vLevel = Application.InputBox _
                            (mp.Name & " のLevelを選択" & vbLf & vbLf & _
                             "0 : Normal" & vbLf & _
                             "1 : Expart ", OTHELLO_TITLE, 0, , , , , 1)
                                    
            If VarType(vLevel) = vbBoolean Then Exit Function
            vLevel = CLng(vLevel)
        Loop Until (vLevel >= 0) And (vLevel <= 1)
         
        SetComLevel = vLevel

End Function

Private Property Let IOthelloPlayer_Name(ByVal RHS As String)
    mp.Name = RHS
End Property

Private Property Get IOthelloPlayer_Name() As String
    IOthelloPlayer_Name = mp.Name
End Property

Private Property Let IOthelloPlayer_PeiceColor(ByVal RHS As EPieceColor)
    mp.PeiceColor = RHS
End Property

Private Property Get IOthelloPlayer_PeiceColor() As EPieceColor
    IOthelloPlayer_PeiceColor = mp.PeiceColor
End Property

Private Property Get IOthelloPlayer_PeiceColorName() As String
    IOthelloPlayer_PeiceColorName = IIf(mp.PeiceColor = otBlack, "黒", "白")
End Property

Private Property Let IOthelloPlayer_PeiceCount(ByVal RHS As Long)
    mp.PeiceCount = RHS
End Property

Private Property Get IOthelloPlayer_PeiceCount() As Long
    IOthelloPlayer_PeiceCount = mp.PeiceCount
End Property

Private Property Get IOthelloPlayer_PlayerType() As EPlayerType
    IOthelloPlayer_PlayerType = mp.PlayerType
End Property

Private Property Let IOthelloPlayer_Puted(ByVal RHS As Boolean)
    mp.Puted = RHS
End Property

Private Property Get IOthelloPlayer_Puted() As Boolean
    IOthelloPlayer_Puted = mp.Puted
End Property

Private Property Let IOthelloPlayer_PutPos(RHS As UPutPos)
    mp.PutPos = RHS
End Property

Private Property Get IOthelloPlayer_PutPos() As UPutPos
    IOthelloPlayer_PutPos = mp.PutPos
End Property

Private Function IOthelloPlayer_SelectPos() As Boolean
    mp.PutPos = DecidePos()
    IOthelloPlayer_Puted = True
    IOthelloPlayer_SelectPos = True
End Function

''Com独自の関数
''駒を置く場所を思考し決定する
Private Function DecidePos() As UPutPos
    Dim r&, c&
    Dim Parent As OthelloManager
    Dim p() As UMemoryBoard
    Dim m() As UMemoryBoard

        ''「弱参照」によりOthelloManager（親）を取得
        Set Parent = IOthelloPlayer_GetParent(mp.Parent)

        With Parent
            
            Call .Wait(GetRandomNo(2000, 800))
            
            ''残りマスより思考のロジック（呼び出す関数）を切り替える
            If .LeftOverCount(.Board) > TACTICS_SWITCH_COUNT Then
                ReDim m(UBound(.Board, 1), UBound(.Board, 2))
                                
                If GetComMemoryBord(m) Then
                    p = .Board()
                    For r = LBound(p, 1) To UBound(p, 1)
                        For c = LBound(p, 2) To UBound(p, 2)
                            If p(r, c).State = otNone Then
                                m(r, c).Puted = False
                                m(r, c).TurnUpCount = .TurnUpCount _
                                    (.Board, r, c, mp.PeiceColor, False)
                            Else
                                m(r, c).Puted = True
                            End If
                        Next
                    Next
    
                    DecidePos = GetPos(m, .LeftOverCount(p))
    
                End If
            Else
                DecidePos = GetPosByRecursive(Parent)
            End If
        End With

        Set Parent = Nothing

End Function

''駒を置く場所を返す関数
Private Function GetPos(ByRef m() As UMemoryBoard, _
                        ByVal LeftOverCount As Long) As UPutPos

    Dim r&, c&
    Dim tmp As UMemoryBoard
    Dim Rs&, Re&, RStep&, Cs&, Ce&, CStep&
    Dim Outs&, Oute&, OutStep&, Ins&, Ine&, InStep&
    Dim i As Integer
    Dim ru&, cu&
    Dim IsSecondHarf As Boolean
    
    ''配列のUbound取得
    ru = UBound(m, 1): cu = UBound(m, 2)
       
    ''ループの形態をランダムに決定
    Select Case GetOneOrTwo()
        Case 1
            Rs = 0: Re = ru: RStep = 1
        Case 2
            Rs = ru: Re = 0: RStep = -1
    End Select
       
    Select Case GetOneOrTwo()
        Case 1
            Cs = 0: Ce = cu: CStep = 1
        Case 2
            Cs = cu: Ce = 0: CStep = -1
    End Select
        
    Select Case GetOneOrTwo()
        Case 1
            Outs = Rs: Oute = Re: OutStep = RStep
            Ins = Cs: Ine = Ce: InStep = CStep
        Case 2
            Outs = Cs: Oute = Ce: OutStep = CStep
            Ins = Rs: Ine = Re: InStep = RStep
    End Select
    
    ''残りマスより戦術変更
    If LeftOverCount <= TACTICS_SWITCH_COUNT Then
        IsSecondHarf = True
        tmp.TurnUpCount = 0
    Else
        IsSecondHarf = False
        tmp.TurnUpCount = UBound(m, 1) * UBound(m, 2)
    End If
    
    ''駒を置く場所を決定
    For r = Outs To Oute Step OutStep
        For c = Ins To Ine Step InStep
            If Not m(r, c).Puted Then
                If tmp.Level <= m(r, c).Level Then
                    If m(r, c).TurnUpCount > 0 Then
                    
                        If Not IsSecondHarf Then
                            If tmp.Level < m(r, c).Level Then
                                tmp.Level = m(r, c).Level
                                tmp.TurnUpCount = m(r, c).TurnUpCount
                                With GetPos
                                    .Row = r
                                    .Column = c
                                End With
                            ElseIf tmp.Level = m(r, c).Level Then
                                If tmp.TurnUpCount > m(r, c).TurnUpCount Then
                                    tmp.Level = m(r, c).Level
                                    tmp.TurnUpCount = m(r, c).TurnUpCount
                                    With GetPos
                                        .Row = r
                                        .Column = c
                                    End With
                                End If
                            End If
                            
                        Else
                        
                            If tmp.Level < m(r, c).Level Then
                                tmp.Level = m(r, c).Level
                                tmp.TurnUpCount = m(r, c).TurnUpCount
                                With GetPos
                                    .Row = r
                                    .Column = c
                                End With
                            ElseIf tmp.Level = m(r, c).Level Then
                                If tmp.TurnUpCount <= m(r, c).TurnUpCount Then
                                    tmp.Level = m(r, c).Level
                                    tmp.TurnUpCount = m(r, c).TurnUpCount
                                    With GetPos
                                        .Row = r
                                        .Column = c
                                    End With
                                End If
                            End If
                            
                        End If
                        
                    End If
                End If
            End If
        Next
    Next
    
    
End Function

''駒を置く場所を再帰処理で思考し返す関数
Private Function GetPosByRecursive(ByVal Parent As OthelloManager) As UPutPos
    Dim r&, c&
    Dim m() As UMemoryBoard
    Dim v() As UMemoryBoard
    Dim WinCount&
    Dim tmp As Long
               
    With Parent
            
        m() = .Board()
                   
        For r = LBound(m, 1) To UBound(m, 1)
            For c = LBound(m, 2) To UBound(m, 2)
                If m(r, c).State = otNone Then
                    
                    v() = m()
                    
                    If .TurnUpCount(v, r, c, mp.PeiceColor, False, True) > 0 Then
                        v(r, c).State = mp.PeiceColor
                        .TurnUpCount v, r, c, mp.PeiceColor, True, True
                        
                        WinCount = 0
                        Call VirtualOthello(v, _
                                IIf(mp.PeiceColor = otBlack, otWhite, otBlack), _
                                mp.PeiceColor, Parent, WinCount)
                                
                        m(r, c).WinCount = WinCount
                        If tmp <= m(r, c).WinCount Then
                            tmp = m(r, c).WinCount
                            
                            With GetPosByRecursive
                                .Row = r
                                .Column = c
                            End With
                            
                        End If
                        
                    End If
                End If
            Next
        Next
            
    End With
        
    Set Parent = Nothing
        
End Function

''再帰処理　仮想の盤上でオセロを進め勝敗を求める
Private Function VirtualOthello(ByRef m() As UMemoryBoard, _
                                ByVal CurrentColor As EPieceColor, _
                                ByVal TargetPlayer As EPieceColor, _
                                ByVal Parent As OthelloManager, _
                                ByRef WinCount As Long) As Boolean
    Dim r&, c&
    Dim v() As UMemoryBoard
        
    v() = m()
    
    With Parent
        If .HasPutPosition(v, CurrentColor, True) Then
            
            For r = 0 To UBound(v, 1)
                For c = 0 To UBound(v, 2)
                    If v(r, c).State = otNone Then
                        If .TurnUpCount(v, r, c, CurrentColor, False, True) > 0 Then
                            v(r, c).State = CurrentColor
                            .TurnUpCount v, r, c, CurrentColor, True, True
                            
                            If .LeftOverCount(v) > 0 Then
                                VirtualOthello v, _
                                    IIf(CurrentColor = otBlack, otWhite, otBlack), _
                                    TargetPlayer, Parent, WinCount
                            Else
                                If Win(v) = TargetPlayer Then
                                    WinCount = WinCount + 1
                                End If
                            End If
                            
                        End If
                    End If
                Next
            Next
        End If
    End With
    
End Function

''仮想盤上で勝者を求める
Private Function Win(ByRef m() As UMemoryBoard) As EBoardState

    Dim r&, c&
    Dim bc&, wc&
    Dim i&
    
        For r = LBound(m, 1) To UBound(m, 1)
            For c = LBound(m, 2) To UBound(m, 2)
                
                Select Case m(r, c).State
                    Case otNone
                    Case otBlackHas
                        bc = bc + 1
                    Case otWhiteHas
                        wc = wc + 1
                End Select
            Next
        Next
        
        Select Case True
            Case bc = wc
                Win = otNone
            Case bc > wc
                Win = otBlackHas
            Case wc > bc
                Win = otWhiteHas
        End Select
       
End Function

''2か1をランダムで返す関数
Private Function GetOneOrTwo() As Integer
    GetOneOrTwo = Int(2 * Rnd + 1)
End Function

''指定した範囲の整数をランダムで返す関数
Private Function GetRandomNo(ByVal UpperBound As Integer, _
                             ByVal LowerBound As Integer) As Integer
    GetRandomNo = Int((UpperBound - LowerBound + 1) * Rnd + LowerBound)
End Function

''マスのレベルをランダムに決定
Private Sub LevelSet()

    SectionLevel(9) = 9
    SectionLevel(8) = GetRandomNo(8, 7)
    SectionLevel(7) = GetRandomNo(8, 6)
    SectionLevel(6) = GetRandomNo(7, 5)
    SectionLevel(5) = GetRandomNo(6, 4)
    SectionLevel(4) = GetRandomNo(5, 3)
    SectionLevel(3) = GetRandomNo(8, 4)
    SectionLevel(2) = GetRandomNo(7, 3)
    SectionLevel(1) = GetRandomNo(2, 1)
    SectionLevel(0) = GetRandomNo(1, 0)
    
End Sub

''マスにレベルをセットし配列として返す関数
Private Function GetComMemoryBord(ByRef m() As UMemoryBoard) As Boolean

    If mComLevel = otComNormal Then
        m(0, 0).Level = SectionLevel(9)
        m(0, 1).Level = SectionLevel(2)
        m(0, 2).Level = SectionLevel(3)
        m(0, 3).Level = SectionLevel(4)
        m(0, 4).Level = SectionLevel(4)
        m(0, 5).Level = SectionLevel(3)
        m(0, 6).Level = SectionLevel(2)
        m(0, 7).Level = SectionLevel(9)
        m(1, 0).Level = SectionLevel(2)
        m(1, 1).Level = SectionLevel(1)
        m(1, 2).Level = SectionLevel(5)
        m(1, 3).Level = SectionLevel(6)
        m(1, 4).Level = SectionLevel(6)
        m(1, 5).Level = SectionLevel(5)
        m(1, 6).Level = SectionLevel(1)
        m(1, 7).Level = SectionLevel(2)
        m(2, 0).Level = SectionLevel(3)
        m(2, 1).Level = SectionLevel(5)
        m(2, 2).Level = SectionLevel(7)
        m(2, 3).Level = SectionLevel(8)
        m(2, 4).Level = SectionLevel(8)
        m(2, 5).Level = SectionLevel(7)
        m(2, 6).Level = SectionLevel(5)
        m(2, 7).Level = SectionLevel(3)
        m(3, 0).Level = SectionLevel(4)
        m(3, 1).Level = SectionLevel(6)
        m(3, 2).Level = SectionLevel(8)
        m(3, 3).Level = SectionLevel(0)
        m(3, 4).Level = SectionLevel(0)
        m(3, 5).Level = SectionLevel(8)
        m(3, 6).Level = SectionLevel(6)
        m(3, 7).Level = SectionLevel(4)
        m(4, 0).Level = SectionLevel(4)
        m(4, 1).Level = SectionLevel(6)
        m(4, 2).Level = SectionLevel(8)
        m(4, 3).Level = SectionLevel(0)
        m(4, 4).Level = SectionLevel(0)
        m(4, 5).Level = SectionLevel(8)
        m(4, 6).Level = SectionLevel(6)
        m(4, 7).Level = SectionLevel(4)
        m(5, 0).Level = SectionLevel(3)
        m(5, 1).Level = SectionLevel(5)
        m(5, 2).Level = SectionLevel(7)
        m(5, 3).Level = SectionLevel(8)
        m(5, 4).Level = SectionLevel(8)
        m(5, 5).Level = SectionLevel(7)
        m(5, 6).Level = SectionLevel(5)
        m(5, 7).Level = SectionLevel(7)
        m(6, 0).Level = SectionLevel(2)
        m(6, 1).Level = SectionLevel(1)
        m(6, 2).Level = SectionLevel(5)
        m(6, 3).Level = SectionLevel(6)
        m(6, 4).Level = SectionLevel(6)
        m(6, 5).Level = SectionLevel(5)
        m(6, 6).Level = SectionLevel(1)
        m(6, 7).Level = SectionLevel(2)
        m(7, 0).Level = SectionLevel(9)
        m(7, 1).Level = SectionLevel(2)
        m(7, 2).Level = SectionLevel(3)
        m(7, 3).Level = SectionLevel(4)
        m(7, 4).Level = SectionLevel(4)
        m(7, 5).Level = SectionLevel(3)
        m(7, 6).Level = SectionLevel(2)
        m(7, 7).Level = SectionLevel(9)
        
    ElseIf mComLevel = otComExpart Then
    
        m(0, 0).Level = 9
        m(0, 1).Level = 2
        m(0, 2).Level = 8
        m(0, 3).Level = 5
        m(0, 4).Level = 5
        m(0, 5).Level = 8
        m(0, 6).Level = 2
        m(0, 7).Level = 9
        m(1, 0).Level = 1
        m(1, 1).Level = 1
        m(1, 2).Level = 6
        m(1, 3).Level = 7
        m(1, 4).Level = 7
        m(1, 5).Level = 6
        m(1, 6).Level = 1
        m(1, 7).Level = 2
        m(2, 0).Level = 8
        m(2, 1).Level = 6
        m(2, 2).Level = 3
        m(2, 3).Level = 8
        m(2, 4).Level = 8
        m(2, 5).Level = 3
        m(2, 6).Level = 6
        m(2, 7).Level = 8
        m(3, 0).Level = 5
        m(3, 1).Level = 7
        m(3, 2).Level = 8
        m(3, 3).Level = 0
        m(3, 4).Level = 0
        m(3, 5).Level = 8
        m(3, 6).Level = 7
        m(3, 7).Level = 5
        m(4, 0).Level = 5
        m(4, 1).Level = 7
        m(4, 2).Level = 8
        m(4, 3).Level = 0
        m(4, 4).Level = 0
        m(4, 5).Level = 8
        m(4, 6).Level = 7
        m(4, 7).Level = 5
        m(5, 0).Level = 8
        m(5, 1).Level = 6
        m(5, 2).Level = 3
        m(5, 3).Level = 8
        m(5, 4).Level = 8
        m(5, 5).Level = 3
        m(5, 6).Level = 6
        m(5, 7).Level = 8
        m(6, 0).Level = 2
        m(6, 1).Level = 1
        m(6, 2).Level = 6
        m(6, 3).Level = 7
        m(6, 4).Level = 7
        m(6, 5).Level = 6
        m(6, 6).Level = 1
        m(6, 7).Level = 2
        m(7, 0).Level = 9
        m(7, 1).Level = 2
        m(7, 2).Level = 8
        m(7, 3).Level = 5
        m(7, 4).Level = 5
        m(7, 5).Level = 8
        m(7, 6).Level = 2
        m(7, 7).Level = 9
    End If

    GetComMemoryBord = True
End Function

42 vs 22
 
# フフフフフッ、圧倒的じゃないか、我が軍は --- Normal 相手(笑)
　

みそじのおじさん様
 
盲腸、大変でしたね(ToT)
そんな大変な中、凄いですね(￣□￣;
思わず真剣に遊んでしまいました（笑）
 
41 vs 23
 
Expart に勝てましたっ♪褒めて下さい♪
 
ちょっと真剣になってしまいました（笑）
それにしても手強かったです。
 
 
あ、じゃなくて、クラス勉強しないと。。。
（１）のスレッドから全然進みません(^-^A
素人には難しいですね。。。ゆっくり頑張りますm(_ _)m

●オセロゲームについて
実現したいことが正しく実現できていれば、それでいいのであって、これが正解というのはないと思います。
ただ、自分だったらこうするかなと思ったことをいくつか列挙してみます。
 
まず、インターフェースにinit処理は含めないと思います。
同じインターフェイスを実装していても、クラスごとに初期処理で必要になる引数が異なることがあると思うからです。
自分だったら、ManualPlayerとComPlayerのInit処理はPublicなsubプロシージャにします。
そしてComPlayerのInit処理の引数にはレベルも持たせて、クラスをnewする前にレベルを取得して、Init処理の引数として渡します。
 
OthelloManagerクラスのmOthelloSheet_BeforeDoubleClickプロシージャ内で、PlayerType が otManualPlayerのときという判定をしています。
ManualPlayerとComPlayerを同じインターフェイス型の変数に代入して利用しているので、こういった条件文を使わずに同等の処理が実行できないか考えるような気がします。
 
OthelloManagerクラスのVsModeプロシージャでは、select case で、VsModeの値によって、Player(0)とPlyery(1)に設定するクラスを切り替えています。
今回のプログラムでは処理数が少ないのであまり気になりませんが、パターンごとに設定するプロパティ等の数が多くなるようであれば、Stateパターンを適用するかもしれません。
 
また、ComPlayerはレベルによって処理内容が異なりますが、レベルの数が多くなるようであればレベルごとにstrategyパターンを適用するかもしれません。

# Excel VBA のプログラミングに正解があるのかどうかは謎ですが，
# パッと見で思ったことです。
 
駒オブジェクトは，
現在の構造体(UMemoryBoard)に取り込まれる形ではなく，
別途クラスにしたいです。
このスレの流れ的にもそうでしょう。(笑)
 
冗談はさておき，
Observer や Callback で，盤 側に通知したいと考えるからです。
# 盤 を View と分離している場合は，さらに 盤 から View へ通知をするためです。
 
また，駒オブジェクトには，
OthelloManager から呼び出される Flip メソッドと，
OthelloManager から利用される，読み取り専用の State プロパティが欲しいです。
そして，
UPutPos 型の Position プロパティも欲しいです。
 
 
どういうことかというと，自分のイメージだと，
フリップ時は以下のような流れになっていたいということです。
 
　　　↑ Piece の Position や State プロパティを見て，描画
　　SheetView (Shape オブジェクトでの描画担当)
　　　↑
　　イベント
　　　│ OnChanged(ByVal obj As Piece)
　　Board
　　　↑ ICallback.NotifyStateChanged(obj As Piece)
　　Callback 呼び出し ※弱参照
　　　│
　　Piece
　　　↑ Flip
　　メソッド呼び出し
　　　│
　　OthelloManager
 
 
あ〜，オブジェクト指向ってめんどくさいなぁ〜 と実感できると思います。(笑)
でも，Worksheet でなく UserForm に描画しようとなった時，
SheetView を UserFormView に変えることになるのですが，
UserFormView だけ新規に作って，他は再利用できるので，
ありがたさがわかると思います。
　

みんさん、こんばんは。
 
お試し頂きありがとうございます。
 
▼どんきちさん
コメントありがとうございます。とても参考になります。

どんきち さんの引用:

OthelloManagerクラスのmOthelloSheet_BeforeDoubleClickプロシージャ内で、PlayerType が otManualPlayerのときという判定をしています。
ManualPlayerとComPlayerを同じインターフェイス型の変数に代入して利用しているので、こういった条件文を使わずに同等の処理が実行できないか考えるような気がします。

Excel のオブジェクト モデル等でコレクションが出てきます。
Worksheet オブジェクトの集まりは，Worksheets コレクションのような類のものです。
ただし，
それは，あくまでモデルとしてコレクションになっているという意味です。
内部では，配列やリスト等の構造で管理しているハズです。
(たぶん，リスト構造でしょう)
 
今回の場合，Board 内部で持つ Piece への参照は，
配列で構わない気がします。
 
Piece からのイベントは多対一になるためイベントは使えないので，
Observer か Callback で実現することになります。
Flip は頻繁に起きるので，速度を考えて，Callback がいいでしょう。
なので，
Callback インターフェースを先に定義しておく必要があります。
それを Board が実装します。
そして，Piece は弱参照でそれを呼び出します。
 
　
あと，View は，先に IBoardView のような名前で，
インターフェースを定義しておく必要があります。
それを SheetView で実装する感じです。
 
 
あとは，ユーザーからのインプットを，どうやって，どこで処理するかです。
　
 
 

みそじのおじさん さんの引用:

どんきち さんの引用:

OthelloManagerクラスのmOthelloSheet_BeforeDoubleClickプロシージャ内で、PlayerType が otManualPlayerのときという判定をしています。
ManualPlayerとComPlayerを同じインターフェイス型の変数に代入して利用しているので、こういった条件文を使わずに同等の処理が実行できないか考えるような気がします。

今思えば、If TypeOf .CurrentPlayer Is ManualPlayer Then でよかったかな？と思います。

OthelloManager クラスは，現在の
 

Private WithEvents mOthelloSheet As Worksheet

Public Sub Cancel()
End Sub

Public Sub PlaceAPiece(DatumPoint As UDatumPoint, Cancel As Boolean)
End Sub

オセロゲームのプログラムを見ていて気がついたことがあります。
OthelloManagerの弱参照の取得処理の独立化させてみてはどうでしょう。
 
今後オセロゲームの改良をすすめていくにあたりクラスの数が増えてくると、OthelloManagerの弱参照を必要とするクラスも増えてくるはずです。
 
ComPlayerクラスのIOthelloPlayer_GetParentプロシージャと、ManualPlayerクラスのIOthelloPlayer_GetParentプロシージャは処理内容がまったく同じで、モジュールレベル変数を使っていません。
そのため、標準モジュールに独立したプロシージャとして作成したほうがいいかもしれません。
 
変更手順として、まず、以下のプロシージャを削除します。
・IOthelloPlayerクラスのGetParentプロシージャ
・ComPlayerクラスのIOthelloPlayer_GetParentプロシージャ
・ManualPlayerクラスのIOthelloPlayer_GetParentプロシージャ
 
次に、以下の標準モジュールを作成します。

'標準モジュール　modOthelloManager
Option Explicit
'''OthelloManagerの弱参照の取得
Private Function GetWeakRef( _
ByVal vptr As Long _
) As OthelloManager
    Dim tmp As OthelloManager
    MoveMemory tmp, vptr, 4&
    Set GetWeakRef = tmp
    MoveMemory tmp, 0&, 4&
End Function

Private Function DecidePos() As UPutPos
    Dim r&, c&
    Dim Parent As OthelloManager
    Dim p() As UMemoryBoard
    Dim m() As UMemoryBoard

        '''「弱参照」によりOthelloManager（親）を取得するために
        '''独立させた標準モジュールのプロシージャを呼び出す。
        Set Parent = modOthelloManager.GetWeakRef(mp.Parent)

みなさん、こんばんは。
 
返信が遅れ気味で申し訳ありません。
 
今日はあまり時間が取れなかったのですが、それでも頭の中でずっと考えておりました。
今回は、ゴールが見えないままスタートを切るのはやめて紙面上でしっかりとした
構成を固めてからとりかかりたいと思います。
 
Peiceクラスの配列の件ですが、イメージが固まりません。。
OthelloManagerが持つ
Private p(63) As Peice？
 
それとも
OthellManager
Private p As Peice
Class Peice内に
Dim p(63) As ユーザー定義型？
 
まだまだこんな所でつまづいております^^
 

yayadon さんの引用:

あ〜，オブジェクト指向ってめんどくさいなぁ〜 と実感できると思います。(笑)

みそじのおじさん さんの引用:
Peiceクラスの配列の件ですが、イメージが固まりません。。
OthelloManagerが持つ
Private p(63) As Peice？

みそじのおじさん さんの引用:
この山は絶対登りきり、UserFormViewまで完成させたいです^^

オセロ試してみました。
Normalで31対33で負けました。
 
ユーザーインターフェイスはとてもいいんじゃないでしょうか。
コードは標準モジュールだけスクロールしてみましたが、スッキリしていてとてもいいですね。

みなさん、おはようございます。
 
PeiceクラスとBoardクラスだけ軽くコードを書いてみました。（とICallbackPeiceクラス）
 
PeiceクラスのFlipメソッドなのですが、yayadonさん提言の構成ですと、
FlipメソッドをOthelloManagerが呼び出すにはBoard内にPeiceクラスを持っているので
BoardクラスにPeiceクラスを公開するプロパティを作って呼び出すイメージでしょうか？
 
OthelloManager.Board.PeiceItem(0,0).Flip ?
 
軽く書いたコードも一緒にお出ししたかったのですが、「弱参照」で落としてしまいました。
MoveMemoryで強制終了しました^^びっくりする事に標準モジュールとクラスモジュールが
全て吹き飛びました！！（実行前に保存はしてあるのですが、、もう一度立ち上げてもコードは
全てなくなっていました。。）もう一度書き直してデバックしましたらまた同じ現象に。。
結局原因は、「VarPtr」でした。ObjPtrではなくVarPtrを使っていました^^;;
（みなさん「弱参照」は、やっぱり要注意です（笑））
 
次回投稿はコードをお出ししますので見て頂きたいです。すみません。
 
▼月さん
ご無沙汰しております。
コメントありがとうございます。スレッドを立ち上げた張本人ですから少しでも成長
できなければと必死でやっております^^

# 何度も書くけど，このネタは，ここだけのクラス遊びという意味ですよね？
 
# View が代わっても他が再利用可能なようにコードを書き直しなさいという出題の時，
# 基本的には，View と Model ( Board ) が一応分離していれば，それだけで 80点。
# あとは，そこから，加点か減点かという風に採点することになるでしょう。
# View に依存している箇所ごとに -5点
# 出題者の意図を超えた優れた箇所には +10 点
# モデルとして Board が存在していない場合は，採点対象としないとなると思います。-> F
# Piece オブジェクトは必須ではないでしょう。
 
 

みそじのおじさん さんの引用:
PeiceクラスとBoardクラスだけ軽くコードを書いてみました。（とICallbackPeiceクラス）
 
PeiceクラスのFlipメソッドなのですが、yayadonさん提言の構成ですと、
FlipメソッドをOthelloManagerが呼び出すにはBoard内にPeiceクラスを持っているので
BoardクラスにPeiceクラスを公開するプロパティを作って呼び出すイメージでしょうか？
 
OthelloManager.Board.PeiceItem(0,0).Flip ?

---
Private m_myPieceColor As EPieceColor
Private m_othelloManager As Long  ' 弱参照
---
Public Sub Init(myPieceColor As EPieceColor, ByVal othelloManager As Long)
    m_myPieceColor = myPieceColor
    m_othelloManager = othelloManager
End Sub
Private Property Get IOthelloPlayer_PieceColor() As EPieceColor
    PieceColor = m_myPieceColor
End Property
---
Private Sub IOthelloPlayer_PlaceAPiece(newPoint As UDatumPoint)
    GetRef(m_othelloManager).PlaceAPiece Me, newPoint
End Sub

Public Sub PlaceAPiece(thisPlayer As IOthelloPlayer, newPoint As UDatumPoint)
    Dim result As Boolean
    Dim newPiece As Piece
    Set newPiece = New Piece
    newPiece.Init thisPlayer.PieceColor
    result = PlaceAPiece(newPiece, newPoint) 
    
End Sub

Public Function PlaceAPiece(newPiece As Piece, newPoint As UDatumPoint) As Boolean

   ' 可能なら newPiece を置く。置けない時は False
   ' すでに置いてある Piece の Flip は，この Boardクラスが行う。

End Sub

''列挙体 マス目の状態
Public Enum ESquareState
    None = 0     '何も置かれていない
    Dark = 1     '黒
    Light = 2    '白
End Enum

Public Function CurrentStates() As ESquareState()
    8*8 の 現在の ESquareState 値の動的配列を返す。
End Function

yayadon さんの引用:
OthelloManager が呼び出すのは，
Board クラスの PlaceAPiece(newPiece As Piece, Point As UDatumPoint) だけです。
Flip するのは，Board クラス内部の役割です。

OthelloManager クラスを中心に
OthelloManager のクライアント側を見てみます。
 
 
　Client　　　　　　　　　　　　　窓口
 
　Main
　View　　　　　　　======>　　OthelloManager
　ManualPlayer
　COMPlayer
 
 
そうすると，OthelloManager に必要なメソッドが見えてくると思います。
 
上記の図の
窓口の右側にあるオブジェクトからは，窓口を呼ばないのがお約束となっています。
お約束通りにいくのならば，OthelloRules は，OthelloManager 内に設けないようにします。
　

みんさん、こんばんは。
 

yayadon さんの引用:

# 何度も書くけど，このネタは，ここだけのクラス遊びという意味ですよね？

Option Explicit

Public Const BOARD_SIZE As Long = 8   ''マスの数

Public Type UDatumPoint
    Row As Long
    Column As Long
End Type

Public Enum EBoardState
    otNone = 0
    otBlackHas = 1
    otWhiteHas = 2
End Enum

Public Enum EPieceColor
    otBlack = 1
    otWhite = 2
End Enum

Public Enum EPeiceState
    otNotPuted = 0
    otBlackPeice = 1
    otWhitePeice = 2
End Enum

Public Type UPeice
    State As EPeiceState
    Position As UDatumPoint
    OthelloManager As Long
End Type

Public Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" _
            (Destination As Any, Source As Any, ByVal Length As Long)


Sub test()

    Dim Point As UDatumPoint
    Dim OthelloBoard As Board
    Set OthelloBoard = New Board
    
    Point.Row = 3
    Point.Column = 3
    OthelloBoard.PeiceItem(Point).PutPeice otBlack
    
End Sub

Option Explicit

Private mp As UPeice

Public Function Init(ByRef Point As UDatumPoint, ByVal OthellManager As Long) As Peice
    mp.Position = Point
    mp.OthelloManager = OthellManager
End Function

Public Function PutPeice(ByVal PeiceColor As EPieceColor) As Boolean
    If mp.State <> otNotPuted Then Exit Function
        
    State = PeiceColor
    
    PutPeice = True
End Function

Public Function Flip() As Boolean

    If mp.State = otNotPuted Then Exit Function
    
    Select Case mp.State
        Case otBlackPeice
            State = otWhitePeice
        Case otWhitePeice
            State = otBlackPeice
    End Select
    
    Flip = True
End Function

Public Property Get Position() As UDatumPoint
    Position = mp.Position
End Property

Public Property Get State() As EPeiceState
    State = mp.State
End Property

Private Property Let State(ByVal NewState As EPeiceState)
    Dim obj As Board
        
        If mp.State = NewState Then Exit Property
        mp.State = NewState
        
        Set obj = GetParent(mp.OthelloManager)
        CastToICallbackPeice(obj).NotifyOnStateChanged Me
End Property

Private Function GetParent(ByVal vptr As Long) As Board
    Dim tmp As Board
    
        MoveMemory tmp, vptr, 4&
        Set GetParent = tmp
        MoveMemory tmp, 0&, 4&
        
End Function

Private Function CastToICallbackPeice(ByVal obj As Board) As ICallbackPeice
    Set CastToICallbackPeice = obj
End Function

Option Explicit

Public Sub NotifyOnStateChanged(ByVal obj As Peice)

End Sub

Option Explicit
Implements ICallbackPeice

Private mPeice(BOARD_SIZE - 1, BOARD_SIZE - 1) As Peice
Private mBoard(BOARD_SIZE - 1, BOARD_SIZE - 1) As EBoardState

Private Sub Class_Initialize()
    Dim r&, c&
    Dim ptr&
    Dim Point As UDatumPoint
    
        ptr = ObjPtr(Me)
        
        For r = 0 To BOARD_SIZE - 1
            For c = 0 To BOARD_SIZE - 1
                Set mPeice(r, c) = New Peice
                    With Point
                        .Row = r
                        .Column = c
                    End With
                    mPeice(r, c).Init Point, ptr
            Next
        Next
End Sub
Public Property Get PeiceItem(ByRef Point As UDatumPoint) As Peice
    
    With Point
        Set PeiceItem = mPeice(.Row, .Column)
    End With
    
End Property

Private Sub ICallbackPeice_NotifyOnStateChanged(ByVal obj As Peice)
    Dim PeiceItem As Peice
        
        Set PeiceItem = obj
        With PeiceItem
            mBoard(.Position.Row, .Position.Column) = .State
        End With
        
        ''さらに、ここからViewクラスへ伝達
End Sub

書き忘れた事がありました。
 
現在の構成は、OthelloManagerは存在しない状態でテストしていました。
「存在しない」と書きましたがコード上にOthelloManagerが出てきています。
これはBoardクラスの間違いでした。OthelloManagerは「Boardクラス」と読み変えて
頂けますでしょうか。すみません。
 
それでは、引き続きよろしくお願い致します。

みそじのおじさん さんの引用:
一つ気になりましたのが、

yayadon さんの引用:

# OthelloManager が，Board クラスの PlaceAPiece を呼び出す。
Public Sub PlaceAPiece(thisPlayer As IOthelloPlayer, newPoint As UDatumPoint)
    Dim result As Boolean
    Dim newPiece As Piece
    Set newPiece = New Piece
    newPiece.Init thisPlayer.PieceColor
    result = PlaceAPiece(newPiece, newPoint)
     
End Sub

このnewPeiceは、このプロシージャ内での使いきり？というお考えでしょうか。
私のコードでは、Boardクラスが64個のPeiceクラスを生成（色情報はなく、位置のみ）
しております。

みそじのおじさん さんの引用:
例え使用するクラスがかなり増えたり、実行速度の低下を招いたとしても構いません。

yayadon さんの引用:

みそじのおじさん さんの引用:
一つ気になりましたのが、

yayadon さんの引用:

# OthelloManager が，Board クラスの PlaceAPiece を呼び出す。
Public Sub PlaceAPiece(thisPlayer As IOthelloPlayer, newPoint As UDatumPoint)
    Dim result As Boolean
    Dim newPiece As Piece
    Set newPiece = New Piece
    newPiece.Init thisPlayer.PieceColor
    result = PlaceAPiece(newPiece, newPoint)
     
End Sub

このnewPeiceは、このプロシージャ内での使いきり？というお考えでしょうか。
私のコードでは、Boardクラスが64個のPeiceクラスを生成（色情報はなく、位置のみ）
しております。

result が True だった時は，参照をどこかに保存しておかないといけないですね。
そして，更新イベントを発生させる形でしょうか。

result = Board参照.PlaceAPiece(newPiece, newPoint) 

あと，
自分なら，Piece 側では位置情報は持たないと思います。
Piece 側で保持すると，Board 側とで，二重に保持することになるので，
色情報の時と同じで，人には見せたくないコードになりますね。
　

# Expert相手に最速で勝てました。
タッチパネルでとか、BGMがあったらとか、効果音とか
素人的にはそう思ったりしました。
単なる願望です。^^;

---------------------------
OJN's Othello
---------------------------
黒 13 : 白 0

Winner 黒 Player1
---------------------------
OK   
---------------------------

Piece は，とりあえずは，ユーザー定義型で，
 

Public Type UPeice
    State As EPeiceState
End Type

みなさん、こんばんは。
 
色情報、位置情報を２重に持たない為には？と色々思考錯誤していました。
（DBのテーブルの正規化みたいですね^^）
 
BoardクラスとPieceクラスの関係をこう考えました。
（今までPeiceと綴りが間違っておりました。すみません^^;）
 
Boradクラスのマスは、Pieceクラスの参照を保持する為に提供する。
Board側に位置情報のみ、Piece側に色情報のみとしてコードを書いてみました。
が、今度はView側にイベントで OnChanged(Byval obj As Piece)と渡しても位置情報を
持たない為に「あれれ・・どうしましょう」となってしまいました^^;
下記にコードを示しますが、この構成はどうでしょうか？
 
OthelloManagerの骨子だけを追加しました。テストはOthelloManagerとManualPlayerを
生成して流れを追ってみました。
 
標準モジュール
modOthello

Option Explicit

Public Const BOARD_SIZE As Long = 8   ''マスの数

Public Type UPutPos
    Row As Long
    Column As Long
End Type

Public Enum EPlayerType
    otManualPlayer = 0 'Manual
    otComPlayer = 1    'Com
End Enum

Public Type UDatumPoint
    Row As Long
    Column As Long
End Type

Public Enum EBoardState
    otNone = 0
    otBlackHas = 1
    otWhiteHas = 2
End Enum

Public Enum EPieceColor
    otBlack = 1
    otWhite = 2
End Enum

Public Enum EPieceState
    otNone = 0
    otDark = 1
    otLight = 2
End Enum

Public Enum ESquareState
    None = 0     '何も置かれていない
    Dark = 1     '黒
    Light = 2    '白
End Enum

Public Type UPiece
    State As EPieceState
    BoardRef As Long  ''Boardクラスへの参照アドレスを持ってみました。
End Type

Public Enum EView
    otSheetView = 0
    otFormView = 1
End Enum

Public Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" _
            (Destination As Any, Source As Any, ByVal Length As Long)


Sub test()

    Dim Othello As OthelloManager
    Dim Player As IOthelloPlayer
    Dim Pos As UDatumPoint
   
        Set Othello = New OthelloManager
        
        ''とりあえずManualPlayerを生成
        Set Player = New ManualPlayer
        Player.PieceColor = otBlack
        
        Pos.Row = 3
        Pos.Column = 3
        Othello.PlaceAPiece Player, Pos
         
        ''ボードのカレントステータスを受け取ってみる
        Dim cs
        cs = Othello.Board.CurrentStatus()
   
End Sub

Option Explicit
Implements ICallbackPiece

''※この様に宣言してみましたがどうでしょうか？
Private mBoard(BOARD_SIZE - 1, BOARD_SIZE - 1) As Piece

Private Sub Class_Terminate()
    Debug.Print "Board_Term!"
End Sub

Public Function PlaceAPiece(ByRef newPiece As Piece, _
                            ByRef newPoint As UDatumPoint) As Boolean
    ''その場所に駒を置けなければExitする処理
    
    Set mBoard(newPoint.Row, newPoint.Column) = newPiece
    PlaceAPiece = True
End Function

Private Sub ICallbackPiece_NotifyOnStateChanged(ByVal obj As Piece)
    Dim Piece As Piece
        
        Set Piece = obj
               
        ''さらに、ここからViewクラスへ伝達
End Sub

''Pieceクラスの配列をそのまま渡さず、値に置き換えてから引き渡す
Public Function CurrentStatus() As ESquareState()

    Dim r&, c&
    Dim cs() As EBoardState
    ReDim cs(BOARD_SIZE - 1, BOARD_SIZE - 1)
    
    For r = 0 To BOARD_SIZE - 1
        For c = 0 To BOARD_SIZE - 1
            If mBoard(r, c) Is Nothing Then
                cs(r, c) = None
            Else
                cs(r, c) = mBoard(r, c).State
            End If
        Next
    Next
    
    CurrentStatus = cs()
    
End Function

Option Explicit

Public Sub NotifyOnStateChanged(ByVal obj As Piece)

End Sub

Option Explicit

Private mp As UPiece

Public Function Init(ByRef newPieceColor As EPieceColor, _
                     ByVal BoardRef As Long) As Piece
    mp.BoardRef = BoardRef
    State = newPieceColor
End Function

Public Property Get State() As EPieceState
    State = mp.State
End Property

Private Property Let State(ByVal NewState As EPieceState)
    Dim obj As Board
        
        If mp.State = NewState Then Exit Property
        mp.State = NewState
        
        Set obj = GetBoardRef(mp.BoardRef)
        CastToICallbackPiece(obj).NotifyOnStateChanged Me
End Property

Private Function GetBoardRef(ByVal vptr As Long) As Board
    Dim tmp As Board
    
        MoveMemory tmp, vptr, 4&
        Set GetBoardRef = tmp
        MoveMemory tmp, 0&, 4&
        
End Function

Private Function CastToICallbackPiece(ByVal obj As Board) As ICallbackPiece
    Set CastToICallbackPiece = obj
End Function

Private Sub Class_Terminate()
    Debug.Print "Piece_Term!"
End Sub

みそじのおじさん さんの引用:

ここまで考えてみましたが、どうでしょうか？
yayadonさんのイメージとかけ離れていってしまっているなら、指摘ください。

yayadonさん、コメントありがとうございます。
 
最初はPositionをKey（Row & vbtab & columnの様な形で）にDictionaryでもやってみ
たのですが、mBoard(,)との組み合わせに戸惑いまして提示した形になってしまい
ました。keyには位置情報があるが、毎回そのKeyから位置情報を取り出すのは「んん・・」
結局位置情報を持っているのと変わらない？と思ってしまったのです。
うまいやり方が在ったのかもしれませんが。。
 
Flip部はOthelloRulesが関係してくると思いますので、先にやった方がいいか、それとも
先にView側をもっと明確にしておいた方がよろしいでしょうか？
 
今までの自分はMainコードが必要としてくる順番に上から作成する手法でよくやっていたので
すが、この辺りの考え方もご教示頂けると幸いです。
 
 

すみません。肝心のOthelloManagerのコードを忘れていました^^;
 

Option Explicit

Private mBoard As Board
''Private mView  As IBoardView


Private Sub Class_Initialize()
    Set mBoard = New Board
End Sub

Private Sub Class_Terminate()
    Debug.Print "OthelloManager_Term!"
End Sub

Private Function GetBoardRef(ByVal vptr As Long) As Board
    Dim tmp As Board
    
        MoveMemory tmp, vptr, 4&
        Set GetBoardRef = tmp
        MoveMemory tmp, 0&, 4&
        
End Function

Public Property Get Board() As Board
    Set Board = mBoard
End Property

Public Function PlaceAPiece(thisPlayer As IOthelloPlayer, _
                            newPoint As UDatumPoint) As Boolean
    Dim newPiece As Piece
    
    Set newPiece = New Piece
    ''色情報とBoardクラスの参照アドレスを渡してInit
    newPiece.Init thisPlayer.PieceColor, ObjPtr(mBoard)
    
    ''View側に結果を返す
    PlaceAPiece = mBoard.PlaceAPiece(newPiece, newPoint)
   
End Function

View と Board の関係は，そこがポイントなので，
先に決めておきますね。
 
いずれにしても，
色情報と位置情報が分散したままなのも嫌な予感がします。
 
# ここらあたりで，助け舟が欲しいかもしれません。
　

おはようございます。
 
了解致しました。
一部分しかコードを書いていませんので、この状態がどの様に足を引っ張っていくのか
私自身みえておりません^^
 
「ここまで書いたのだから、このまま突っ走る！！」なんて輩ではありませんので
もうちょっと試行錯誤してみます。これが藤代さんがいう「不吉な匂い」という所で
しょうか？
 
ViewとBoardの関係も考えながら、Piece部をもう一度考え直してみます。
（ずばっとPiece部を切り落とすのも手ですかね！？）
 
 

みそじのおじさん さんの引用:
リソースを配布出来る場所

みそじのおじさん さんの引用:
Piece部をもう一度考え直してみます。

Public Type UPiece
    State As EPieceColor     '' EPieceColor に変更
    pICallbackPiece As Long  '' ICallbackPiece 型への参照アドレス。
End Type                                     ''↑

Option Explicit

Private mp As UPiece

Public Function Init(ByRef newPieceColor As EPieceColor, _
                     ByVal pICallbackPiece As Long) As Piece
    mp.pICallbackPiece = pICallbackPiece
    State = newPieceColor
End Function

Public Property Get State() As EPieceColor ''EPieceColor に変更
    State = mp.State
End Property

Private Property Let State(ByVal NewState As EPieceColor) ''EPieceColor に変更
    Dim obj As ICallbackPiece
        
    If mp.State = NewState Then Exit Property
    mp.State = NewState
        
    Set obj = GetBoardRef(mp.pICallbackPiece)
    obj.NotifyOnStateChanged Me
End Property

Private Function GetBoardRef(ByVal vptr As Long) As ICallbackPiece
    Dim tmp As ICallbackPiece
    
    MoveMemory tmp, vptr, 4&
    Set GetBoardRef = tmp
    MoveMemory tmp, 0&, 4&    
End Function

Private Sub Class_Terminate()
    Debug.Print "Piece_Term!"
End Sub

Public Enum EPieceColor
    otBlack = 0
    otWhite = -1
End Enum

Public Fuction Flip()
    State = Not mp.State
End Fuction

Public Sub TestEPieceColor()
    Dim tmp As EPieceColor
    tmp = otBlack
    Debug.Print tmp = otWhite
    tmp = Not tmp
    Debug.Print tmp = otWhite
    
    tmp = otWhite
    Debug.Print tmp = otBlack
    tmp = Not tmp
    Debug.Print tmp = otBlack
End Sub

# Enum が ByRef 渡しになっていたので，書き直しました。
# また If mp.Color = NewColor Then Exit Property があると具合が悪いので削除しました。
 
 
Piece モデルは，以下で行きましょう。
依存も無く，スッキリしてて悪くないと思います。
# コーディング規約はみそじのおじさんにあわせました。
# 但し，生ポインタだけは，プレフィクスに p を付けてあります。
 
 
◆ Piece モデル
 
駒の色識別用 Enum

Public Enum EPieceColor
    otDark = 0
    otLight = -1
End Enum

Option Explicit

Public Sub OnStateChanged(ByVal obj As Piece)
    ''
End Sub

Option Explicit

Private Type UPiece
    Color As EPieceColor
    pICallbackPiece As Long  '' ICallbackPiece 型への参照アドレス。
End Type

Private mp As UPiece

Public Function Init(ByVal NewColor As EPieceColor, _
                     ByVal pICallbackPiece As Long) As Piece
    mp.pICallbackPiece = pICallbackPiece
    Color = NewColor
    Set Init = Me
End Function

Public Fuction Flip() As Piece
    Color = Not mp.Color
    Set Flip = Me
End Fuction

Public Property Get Color() As EPieceColor
    Color = mp.Color
End Property

Private Property Let Color(ByVal NewColor As EPieceColor)
    Dim obj As ICallbackPiece

    'If mp.Color = NewColor Then Exit Property   '' 初期化時対策のため削除
    mp.Color = NewColor
        
    Set obj = GetICallbackPieceRef(mp.pICallbackPiece)
    obj.OnStateChanged Me
End Property

Private Function GetICallbackPieceRef(ByVal vptr As Long) As ICallbackPiece
    Dim tmp As ICallbackPiece
    
    MoveMemory tmp, vptr, 4&
    Set GetICallbackPieceRef = tmp
    MoveMemory tmp, 0&, 4&    
End Function

Private Sub Class_Terminate()
    Debug.Print "Piece_Term!"
End Sub

みそじのおじさん さんの引用:
この状態がどの様に足を引っ張っていくのか
私自身みえておりません^^

Public Event OnStateChanged(ByVal obj As Piece, pos As UDatumPoint)

Private Sub ICallbackPiece_OnStateChanged(ByVal obj As Piece)
    Dim pos As UDatumPoint
    '' ここ
    RaiseEvent OnStateChanged(obj, pos)
End Sub

みなさん、こんばんは。
 
yayadonさん、ありがとうございます。
Pieceクラスすっきりしましたね^^
 
Boardクラス内のPieceクラスの参照保持ををDictionaryでもう一度考えてみました。
KeyにnewPiece、ItemにDatumPointクラス型のnewPoint（下記に説明致します）
で参照を保持してみました。
 
ItemにUDatumPos型はつかえない旨のコンパイルエラーが出ていまして、
回避できませんでした。
　パブリックオブジェクトモジュールでPublicで宣言したユーザー定義型は、
ByRef扱いにしておけば、他に気をつける点はないと思っていたのですが、
DictionaryのAdd時とRaiseEvent時のposがコンパイルエラーで引っかかってしま
いました^^;;
 
苦肉の策で
DatumPointクラス

Public Row As Long
Public Column As Long

Public Function CreatePos() As DatumPoint
    Set CreatePos = New DatumPoint
End Function

Dim pos As DatumPoint
Set pos = CreatePos()
pos.Row = 3
pos.Column = 3

Public Enum EPieceColor
    otNone = 1 ''こちらは必要ありませんか？
    otDark = 0
    otLight = -1
End Enum

''値を上に合わせ変更しました
Public Enum ESquareState
    None = 1     '何も置かれていない
    Dark = 0     '黒
    Light = -1   '白
End Enum

Option Explicit
Implements ICallbackPiece

Public Event OnStateChanged(ByVal obj As Piece, ByRef Pos As DatumPoint)

Private mPieces As Object
Private mBoard(BOARD_SIZE - 1, BOARD_SIZE - 1) As ESquareState

Private Sub Class_Initialize()
    Set mPieces = CreateObject("Scripting.Dictionary")
    Call Board_Init ''ボードの初期化をしてみました
End Sub

Private Sub Class_Terminate()
    Set mPieces = Nothing
    Debug.Print "Board_Term!"
End Sub
Private Sub Board_Init()
    Dim r&, c&
        For r = 0 To BOARD_SIZE - 1
            For c = 0 To BOARD_SIZE - 1
                mBoard(r, c) = None
            Next
        Next
End Sub
Public Function PlaceAPiece(newPiece As Piece, _
                            newPoint As DatumPoint) As Boolean
                            
    ''その場所に駒を置けなければExitする処理
    
    If Not mPieces.Exists(newPiece) Then
        mPieces.Add newPiece, newPoint
        newPiece.OnBoard  
        ''↑をCallしなければICallbackPiece_OnStateChangedが呼ばれない
        ''Flip時はよいが、マスに駒を置いた時はCallBackされない
        PlaceAPiece = True
    End If
    
End Function

Public Function CurrentStatus() As ESquareState()
    CurrentStatus = mBoard()
End Function

Private Sub ICallbackPiece_OnStateChanged(ByVal obj As Piece)
    Dim Pos As DatumPoint
        
    ''DictionaryにKey(Peice)を与えItem(DatumPoint)を得る
    Set Pos = mPieces.Item(obj)
    
    ''Item(DatumPoint)が得られなければExit
    If Pos Is Nothing Then Exit Sub
        
    mBoard(Pos.Row, Pos.Column) = obj.Color
    
    RaiseEvent OnStateChanged(obj, Pos)
End Sub

Option Explicit

Private Type UPiece
    Color As EPieceColor
    pICallbackPiece As Long  '' ICallbackPiece 型への参照アドレス。
End Type

Private mp As UPiece

Public Function Init(ByRef NewColor As EPieceColor, _
                     ByVal pICallbackPiece As Long) As Piece
    mp.pICallbackPiece = pICallbackPiece
    Color = NewColor
    Set Init = Me
    
End Function

''このプロシージャは必要な気がするのですが、いかがでしょうか？
Public Sub OnBoard()
    Dim obj As ICallbackPiece
        
    Set obj = GetICallbackPieceRef(mp.pICallbackPiece)
    obj.OnStateChanged Me
End Sub

Public Function Flip() As Piece
    Color = Not mp.Color
    Set Flip = Me
End Function

Public Property Get Color() As EPieceColor
    Color = mp.Color
End Property

Private Property Let Color(ByVal NewColor As EPieceColor)
    Dim obj As ICallbackPiece
        
    If mp.Color = NewColor Then Exit Property
    mp.Color = NewColor
        
    Set obj = GetICallbackPieceRef(mp.pICallbackPiece)
    obj.OnStateChanged Me
End Property

Private Function GetICallbackPieceRef(ByVal vptr As Long) As ICallbackPiece
    Dim tmp As ICallbackPiece
    
    MoveMemory tmp, vptr, 4&
    Set GetICallbackPieceRef = tmp
    MoveMemory tmp, 0&, 4&
End Function

Private Sub Class_Initialize()
    'mp.Color = otNone 初期化は必要ありませんか？
    ''白でInitをするとOnStateChangedが働いてしまいます。
End Sub

Private Sub Class_Terminate()
    Debug.Print "Piece_Term!"
End Sub

Public Function PlaceAPiece(thisPlayer As IOthelloPlayer, _
                            newPoint As DatumPoint) As Boolean
    Dim newPiece As Piece
    Set newPiece = New Piece
        
    ''↓ここ悩みました！！キャストせず渡して、またExcel君が落ちました^^
    Dim obj As ICallbackPiece
    ''mBoardクラスをICallbackPiece型にキャスト
    Set obj = mBoard
        
    ''色情報とICallbackPieceへの参照アドレスを渡してInit
    newPiece.Init thisPlayer.PieceColor, ObjPtr(obj)
    
    ''View側に結果を返す
    PlaceAPiece = mBoard.PlaceAPiece(newPiece, newPoint)
   
End Function

ああっ。今yayadonさんの訂正が入っている事に気付きました^^;;
今から読み直してみます！少し話しが前後するかも知れません。
すみません。
 
▼kumattiさん
コメントありがとうございます。
そうですね。ファイルへの直リンは規約違反ですもんね。
 
LabelのCaption辺りじゃ（●○）では、見た目がちょっとなーと思いますが
いた仕方ありませんね。
 

# 書き直しました。
 
初期化時は，まだ，場所が決まっていなかったですね。
 
Piece に駒を置くメソッドを付けるのは微妙なので，
Piece の Init 時に vptr をセットする今の形ではなく，
PlaceAPiece 時に vptr をセットするのがいいんじゃないでしょうか。
 
 
また，親子関係のインターフェースは統一して，
 
IParent

Public Sub Attach(ByVal vptr As Long)
End Sub

Public Sub Detach()
End Sub

Implements IParent

Private Type UPiece
    Color As EPieceColor
    pICallbackPiece As Long  '' ICallbackPiece 型への参照アドレス。
End Type

Private mp As UPiece

Public Function Init(ByVal NewColor As EPieceColor) As Piece
    Color = NewColor
    Set Init = Me
End Function

Private Sub IParent_Attach(ByVal pICallbackPiece As Long)
    mp.pICallbackPiece = pICallbackPiece
End Sub

Private Sub IParent_Detach()
    mp.pICallbackPiece = 0&
End Sub

Public Fuction Flip() As Piece
    Color = Not mp.Color
    Set Flip = Me
End Fuction

Public Property Get Color() As EPieceColor
    Color = mp.Color
End Property

Private Property Let Color(ByVal NewColor As EPieceColor)
    Dim obj As ICallbackPiece

    mp.Color = NewColor        
    Set obj = GetICallbackPieceRef(mp.pICallbackPiece)
    If obj Is Nothing Then Exit Property
    obj.OnStateChanged Me
End Property

Private Function GetICallbackPieceRef(ByVal pICallbackPiece As Long) As ICallbackPiece
    Dim tmp As ICallbackPiece
    
    MoveMemory tmp, pICallbackPiece, 4&
    Set GetICallbackPieceRef = tmp
    MoveMemory tmp, 0&, 4&    
End Function

Private Sub Class_Terminate()
    Debug.Print "Piece_Term!"
End Sub

Implements ICallbackPiece

Private なんらかの形

Public Event OnStateChanged(ByVal obj As Piece, ByVal pos As UDatumPoint)

'' Add に相当
Public Sub PlaceAPiece(obj As Piece, ByVal pos As UDatumPoint)
    '' ここで，なんらかの形 に追加

    Dim icp As ICallbackPiece
    Set icp = Me
    Dim ipar As IParent
    Set ipar = obj
    ipar.Attach ObjPtr(icp)
    RaiseEvent OnStateChanged(obj, pos)
End Sub

Private Sub ICallbackPiece_OnStateChanged(ByVal obj As Piece)
    Dim pos As UDatumPoint
    '' ここで なんらかの形 を探索して pos 作成
    RaiseEvent OnStateChanged(obj, pos)
End Sub

おはようございます。
 
今までの私はクラスをInitする時には、必要な物はその時に！と考えが凝り固まって
いたのですが、「Attachするタイミングが重要」という事が学べました。これは
私にとって大変大きなな事でした。ありがとうございます。
 
BoardとViewですが

IBoardView
  ┗ SheetView
  ┗ FormView　　←←←Inputのcallback
　　　 ┃              ┃
　　　 ┃        ICallBackSquare
       ┗ Square（64個のマス目）

位置情報ですが，現在は
 
　　　1　2　3　4　5　6　7　8
　1
　2
　3
　4
　5
　6
　7
　8
 
ですよね。
それを
 
　　　1　2　3　4　5　6　7　8
　10
　20
　30
　40
　50
　60
　70
　80
 
にしたらどうでしょうか？
 
そうすると，位置は，11 〜 88 の単なる整数値になりますよね。
Scripting.Dictionary 等の連想配列で扱い易くなるんじゃないかと思います。
　
 
 
 

みそじのおじさん さんの引用:
DictionaryのAdd時とRaiseEvent時のposがコンパイルエラーで引っかかってしま
いました^^;;

Option Explicit

Public Sub OnStateChanged(ByVal obj As Piece, pos As UDatumPoint)
    ''
End Sub

みなさん、こんばんは。
 
日中の返信をみる事ができず、Dictionaryの件出来ておりません。
（DatumPointクラス型のままです、、）すみません。
CurrentStatus()は、以前作成した計算ロジックを利用するには(7,7)の配列で返す
必要があるのですが、Index値で管理をしますとDatumPoint型（または、UDatumPoint型）
に変換するのには
 
Public Function PosFromIndex(ByVal Index As Long) As DatumPoint
    Set PosFromIndex = New DatumPoint
    With PosFromIndex
        .Row = (Index \ 10) - 1
        .Column = (Index Mod 10) - 1
    End With
End Function
 
みたいな変換が常々必要になるという事ですかね？！それとも最後の最後までIndex値で
管理をするという事でしょうか？　的を得ていない発言かも知れません^^;
 
 
Viewに取り組むには、まずインターフェースを切り出してからというお話だったの
ですが、自分で「AttachしてCallBackの流れが作成出来るか」と先走りぎみにやって
おりました。
 
下記に示した構成でコードは作成しておりますが、コードの提示の前に
「インターフェースの洗い出し」についてお伺いします。
Viewが実装するべき物を私なりに考えましたら
・盤の作成
・Boardの状態変化の通知を受け、描画する
・View側からの（Sheet,Userform）インプットをOthelloManagerに返す
この辺りが重要な役割かなと思いました。
 

[内はImplements]

OthelloManager [ICallbackView]  ← ViewからInput通知　← ← ←
   ┃                                                         ↑
   ┗ ━━ ━   Board [ICallbackPiece]　　← 駒の状態通知     ↑
   ┃    　　    ↓   ┃　　　　　　　　　　　　　　↑        ↑
   ┃  　        ↓   ┗ Piece ----------------------　　　　 ↑
 　┃　　　　　　↓                                           ↑  
　 ┃  ↓-------←　　　　　　　　　　　　　　　　　　　　　  ↑
   ┃ 現在はWithEvents BoardでFormViewに状態変化の通知 　　　 ↑
　 ┃  ↓　 →-------------------------------------------------
   ┃  ↓  ↑
   ┗  FormView [IBoardView　ICallBackSquare ]← Input通知
         ┃ ↓描画の指示                           ↑
         ┗　Square --------------------------------

みそじのおじさん さんの引用:
それとも最後の最後までIndex値で
管理をするという事でしょうか？　

Public Type UDatumPoint
    Row As Short       '行
    Column As Short    '列
End Type

みなさん、こんばんは。
長期休暇を過ごしておりました^^申し訳ありません。
（こんなに休ませて私の会社は、大丈夫？ってくらいお休みを貰っておりました。）
 
▼yayadonさん
やはり、経験がある方は「ぱっと」アイデアがでるものですね^^
以前、藤代さんにはお話した事があるのですが、
私は一応理系出身でして数学は苦手では無い方なのですが、規則性を見出すのが苦手
です。学生時代には論理演算の授業も受けていたのですが、、応用が利きませんね^^;
 
サブクラス化中に、WinMessageをHighWord、LowWordで取り出す事はやっておりますが
MoveMemoryで「ペローン」ですか！（笑）
とても私の頭の中からは出てこない発想です。ありがとうございます。
 
UserFormView見たさに、手順違いで先に進んでしまい申し訳ありません。
とりあえず先に進みたく、その部分はDictionaryとCollectionで位置情報を持たせて
しまいました。（これはyayadonさんが言われる「人に見せたくないコード」になって
しまうのですが、「後からでも修正が利くかな？」とやってしまいました。
 
▼みなさまへ
現在までの修正でクラス数16、標準モジュール1、UserForm1の計18個のモジュールに
なっております。
 
いつものように「お試し下さい。」とはとても言いづらいくらいのボリュームになって
おります。
そこでお聞きしたいのですが、皆様への負担を減らしたいと思いVBEに全てのモジュールを
インポートするプログラムを作成しました。
 
手順は
・私が、このスレッドに全てのモジュールとVBEにインポートするプログラムを投稿
・試して頂ける方に、全てのモジュールを１つのファイル「Othello.txt」として
　任意に作成して頂くフォルダに保存
・新規ワークブックにVBEにインポートするプログラムを記述
・ツール→マクロ→セキュリティ→「Visual Basicプロジェクトへのアクセスを信頼する」
　にチェックをご自身で入れて頂きます。
・インポートするプログラムを実行します。
・「Othello.txt」をSplitして必要なファイルを自動で作成していきます。作成した
　モジュール郡が全てインポートされます。
 
この手順ですと、作業自体は５分くらいで完了するのですが
・ウイルスまがいの行為？
・そもそもVBE自体を扱うコード自体アウト？
 
この辺りのお話が絡んできてしまいますので、「アウト」との指摘がありましたら
インポートするプログラムの公開は控えたいなと思っておりますので、指摘よろしく
お願い致します。（コード自体はOfficeTanakaさん辺りで普通に書かれている内容
なのですが）
 
# FormViewに「遊び心を」と見た目のEffect効果+音も付けてみました（Beepですが、、）

遅くなりました^^;
 
VBEを操作するコードは載せませんが、下記に提示する「Othello.txt」を自動で分割
し必要なファイルを生成するコードを載せます。
 
手順です。
１．　４に提示するクラスモジュール郡を任意のフォルダを作成して頂き一つのファイル
　　　「Othello.txt」として、保存して下さい。
 
２．新規ワークブックの標準モジュールに次のコードをコピペして、Folder部をOthello.txt
　　を保存したフォルダのパスに適宜変更して下さい。

Option Explicit

Public Sub File_Split()
    
    Dim Folder As String
    Dim FileName As String, FilePath As String
    Dim Files As Collection
    Dim File
    Dim ImportFile As String
    Dim Fg As Boolean
    Dim f As Integer, ff As Integer
    Dim buf As String
    
    
    ImportFile = "Othello.txt"
    Folder = "Othello.txtを格納したフォルダのパスを適宜記入"
    
    Set Files = New Collection
           
    f = FreeFile()
    Open Folder & "\" & ImportFile For Input As #f
    Do While Not EOF(f)
        Line Input #f, buf
        Select Case Left$(buf, 3)
            Case "BOF"
                ff = FreeFile()
                FileName = Split(buf, ",")(1)
                FilePath = Folder & "\" & FileName
                Files.Add FilePath
                Fg = True
                Open FilePath For Output As #ff
            Case "EOF"
                Fg = False
                Close #ff
            Case Else
                If Fg Then
                    Print #ff, buf
                End If
        End Select
        
    Loop
    
    Close #f
    
    ''VBEを操作出来る方は
    For Each File In Files
        ''Fileにはインポートすべきファイルのフルパスが入っているので
        ''インポートをするコード記入
    Next
    
    ''VBEを操作出来ない方は、手作業で全てのファイルをインポート
    ''必要なファイルは全て「Folder」で指定したフォルダに作成されております。
End Sub

*****************************************************

Board.cls

*****************************************************
BOF,Board.cls
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Board"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Implements IParent
Implements ICallbackPiece

Private Type UBoard
    pOthelloManager As Long
    pIBoardView     As Long
    Pieces          As Object
    PieceItems      As Collection
    Board()         As ESquareState
End Type

Private mp As UBoard

Private Sub Class_Initialize()
    Set mp.Pieces = CreateObject("Scripting.Dictionary")
    Set mp.PieceItems = New Collection
    Call Board_Init
End Sub

Private Sub Class_Terminate()
    Set mp.Pieces = Nothing
    Set mp.PieceItems = Nothing
    ''Debug.Print "Board_Term!"
End Sub

''ボードの初期化
Private Sub Board_Init()
    Dim r&, c&
    
    ReDim mp.Board(BOARD_SIZE - 1, BOARD_SIZE - 1)
    
        For r = 0 To BOARD_SIZE - 1
            For c = 0 To BOARD_SIZE - 1
                mp.Board(r, c) = None
            Next
        Next
End Sub

Public Function PlaceAPiece(newPiece As Piece, _
                            newPoint As DatumPoint) As Boolean
                            
    Dim icp         As ICallbackPiece
    Dim ipar        As IParent
    Dim ibv         As IBoardView
    Dim om          As OthelloManager
    Dim items       As Collection
    Dim item        As DatumPoint
    Dim pc          As Piece
    Dim SoundIndex  As Long
    Dim SoundEffect As Boolean
        
        ''Pieceオブジェクト作成
        mp.Pieces.Add newPiece, newPoint
        
        ''ここは人に見せたくないコードです^^
        ''Pieceの位置情報をキープ
        mp.PieceItems.Add newPiece, CStr(newPoint.Row & "," & _
                                        newPoint.Column)
        Set icp = Me
        Set ipar = newPiece
        ipar.Attach ObjPtr(icp)
        
        ''標準モジュールに置いたGetOthelloManagerRef()から
        ''弱参照でOthelloManagerを得る
        Set om = modOthello.GetOthelloManagerRef(Parent)
        
        SoundEffect = om.SoundEffect
        
        ''newPointに駒を置いた時に反転する駒の位置をCollectionで取得
        Set items = om.Rules.GetFlipItems(CurrentStatus, _
                                          newPoint, newPiece.Color)
        ''Stateプロパティを更新
        State(newPoint.Row, newPoint.Column) = newPiece.Color
        
        Set ibv = GetIBoardViewRef(mp.pIBoardView)
        ibv.OnStateChanged newPiece, newPoint, CBool(items.Count > 0)
        
        If SoundEffect Then
            Call modOthello.BeepEx(SoundIndex, 50, True)
        End If
        
        om.Wait 250
                
        For Each item In items
            Set pc = mp.PieceItems(item.Row & "," & item.Column)
            pc.Flip ''駒の反転指令
            If SoundEffect Then
                Call modOthello.BeepEx(SoundIndex, 50, True)
            End If
            om.Wait 150
            
        Next
        PlaceAPiece = True
   
    
End Function

Public Property Get Parent() As Long
    Parent = mp.pOthelloManager
End Property


Public Property Let Parent(ByVal ptr As Long)
    mp.pOthelloManager = ptr
End Property

Private Property Get State(ByVal ixRow As Long, _
                           ByVal ixCol As Long) As ESquareState
    State = mp.Board(ixRow, ixCol)
End Property

Private Property Let State(ByVal ixRow As Long, _
                           ByVal ixCol As Long, _
                           ByVal newState As ESquareState)
    mp.Board(ixRow, ixCol) = newState
End Property

''ボードのカレントステータスを配列で返す関数
Public Function CurrentStatus() As ESquareState()
    CurrentStatus = mp.Board()
End Function

Private Sub ICallbackPiece_OnStateChanged(ByVal obj As Piece)
    Dim pos As DatumPoint
    Dim ibv As IBoardView
    
    ''DictionaryにKey(Peice)を与えItem(DatumPoint)を得る
    Set pos = mp.Pieces.item(obj)
    
    ''Item(DatumPoint)が得られなければExit
    If pos Is Nothing Then Exit Sub
        
    State(pos.Row, pos.Column) = obj.Color
    
    Set ibv = GetIBoardViewRef(mp.pIBoardView)
    ibv.OnStateChanged obj, pos
    
End Sub
Private Sub IParent_Attach(ByVal vptr As Long)
    mp.pIBoardView = vptr
End Sub

Private Sub IParent_Remove()
    mp.pIBoardView = 0&
End Sub

Private Function GetIBoardViewRef(ByVal vptr As Long) As IBoardView
    Dim tmp As IBoardView
    
    MoveMemory tmp, vptr, 4&
    Set GetIBoardViewRef = tmp
    MoveMemory tmp, 0&, 4&
End Function

EOF



*****************************************************

ComPlayer.cls

*****************************************************
BOF,ComPlayer.cls
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "ComPlayer"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Implements IParent
Implements IOthelloPlayer

Public Enum EComLevel
    otComNormal = 0
    otComExpart = 1
End Enum

''戦術を切り替える残りマス数
Private Const TACTICS_SWITCH_COUNT As Long = 16

Private mp              As UOthelloPlayer
Private SectionLevel(9) As Long
Private mComLevel       As EComLevel

Private Sub Class_Initialize()
    mp.PlayerType = otComPlayer
End Sub

Private Sub Class_Terminate()
    ''Debug.Print mp.Name & "_Term!"
End Sub

''ComPlayer初期化処理
Private Sub IOthelloPlayer_Init(ByVal PlayerName As String)
                                
    IOthelloPlayer_Name = PlayerName
        
    mComLevel = SetComLevel()
    If mComLevel = otComNormal Then
        Call LevelSet
    End If
    
End Sub

''Comのレベルを決定する
Private Function SetComLevel() As EComLevel

    Dim vLevel As Variant
    
        Do
            vLevel = Application.InputBox _
                            (mp.Name & " のLevelを選択" & vbLf & vbLf & _
                             "0 : Normal" & vbLf & _
                             "1 : Expart ", OTHELLO_TITLE, 0, , , , , 1)
                                    
            If VarType(vLevel) = vbBoolean Then Exit Function
            vLevel = CLng(vLevel)
        Loop Until (vLevel >= 0) And (vLevel <= 1)
         
        SetComLevel = vLevel

End Function

Private Property Let IOthelloPlayer_Name(ByVal RHS As String)
    mp.Name = RHS
End Property

Private Property Get IOthelloPlayer_Name() As String
    IOthelloPlayer_Name = mp.Name
End Property

Private Property Let IOthelloPlayer_PieceColor(ByVal RHS As EPieceColor)
    mp.PieceColor = RHS
End Property

Private Property Get IOthelloPlayer_PieceColor() As EPieceColor
    IOthelloPlayer_PieceColor = mp.PieceColor
End Property

Private Property Get IOthelloPlayer_ColorToString() As String
    IOthelloPlayer_ColorToString = IIf(mp.PieceColor = otDark, "黒", "白")
End Property

Private Property Let IOthelloPlayer_PieceCount(ByVal RHS As Long)
    mp.PieceCount = RHS
End Property

Private Property Get IOthelloPlayer_PieceCount() As Long
    IOthelloPlayer_PieceCount = mp.PieceCount
End Property

Private Function IOthelloPlayer_PlaceAPiece(newPoint As DatumPoint) As Boolean
    Dim om As OthelloManager
     
    Set om = modOthello.GetOthelloManagerRef(mp.pOthelloManager)
    om.PlaceAPiece Me, newPoint
    IOthelloPlayer_Puted = True
End Function

Private Property Get IOthelloPlayer_PlayerType() As EPlayerType
    IOthelloPlayer_PlayerType = mp.PlayerType
End Property

Private Property Let IOthelloPlayer_Puted(ByVal RHS As Boolean)
    mp.Puted = RHS
End Property

Private Property Get IOthelloPlayer_Puted() As Boolean
    IOthelloPlayer_Puted = mp.Puted
End Property

Private Function IOthelloPlayer_SelectPlace() As Boolean
    Call IOthelloPlayer_PlaceAPiece(DecidePos())
    IOthelloPlayer_SelectPlace = True
End Function

''Com独自の関数
''駒を置く場所を思考し決定する
Private Function DecidePos() As DatumPoint
    
    Dim r&, c&
    Dim om As OthelloManager
    Dim p() As ESquareState
    Dim m() As UMemoryBoard

    ''「弱参照」によりOthelloManager（親）を取得
    Set om = modOthello.GetOthelloManagerRef(mp.pOthelloManager)

    With om

        Call .Wait(GetRandomNo(1500, 500))

        ''残りマスより思考のロジック（呼び出す関数）を切り替える
        If .Rules.LeftOverCount(.Board.CurrentStatus) > TACTICS_SWITCH_COUNT Then
            ReDim m(UBound(.Board.CurrentStatus, 1), UBound(.Board.CurrentStatus, 2))

            If GetComMemoryBord(m) Then
                p = .Board.CurrentStatus()
                For r = LBound(p, 1) To UBound(p, 1)
                    For c = LBound(p, 2) To UBound(p, 2)
                        If p(r, c) = None Then
                            m(r, c).Puted = False
                            m(r, c).FlipCount = _
                                    .Rules.GetFlipItems(p, InsPos(r, c), mp.PieceColor).Count
                        Else
                            m(r, c).Puted = True
                        End If
                    Next
                Next

                Set DecidePos = GetPos(m, .Rules.LeftOverCount(p))

            End If
        Else
            Set DecidePos = GetPosByRecursive(om)
        End If
    End With

    Set om = Nothing

End Function

''駒を置く場所を返す関数
Private Function GetPos(ByRef m() As UMemoryBoard, _
                        ByVal LeftOverCount As Long) As DatumPoint

    Dim r&, c&
    Dim tmp As UMemoryBoard
    Dim Rs&, Re&, RStep&, cs&, Ce&, CStep&
    Dim Outs&, Oute&, OutStep&, Ins&, Ine&, InStep&
    Dim i As Integer
    Dim ru&, cu&
    Dim IsSecondHarf As Boolean
    Dim obj As DatumPoint
    
    Set obj = New DatumPoint
    ''配列のUbound取得
    ru = UBound(m, 1): cu = UBound(m, 2)
       
    ''ループの形態をランダムに決定
    Select Case GetOneOrTwo()
        Case 1
            Rs = 0: Re = ru: RStep = 1
        Case 2
            Rs = ru: Re = 0: RStep = -1
    End Select
       
    Select Case GetOneOrTwo()
        Case 1
            cs = 0: Ce = cu: CStep = 1
        Case 2
            cs = cu: Ce = 0: CStep = -1
    End Select
        
    Select Case GetOneOrTwo()
        Case 1
            Outs = Rs: Oute = Re: OutStep = RStep
            Ins = cs: Ine = Ce: InStep = CStep
        Case 2
            Outs = cs: Oute = Ce: OutStep = CStep
            Ins = Rs: Ine = Re: InStep = RStep
    End Select
    
    ''残りマスより戦術変更
    If LeftOverCount <= TACTICS_SWITCH_COUNT Then
        IsSecondHarf = True
        tmp.FlipCount = 0
    Else
        IsSecondHarf = False
        tmp.FlipCount = UBound(m, 1) * UBound(m, 2)
    End If
    
    ''駒を置く場所を決定
    For r = Outs To Oute Step OutStep
        For c = Ins To Ine Step InStep
            If Not m(r, c).Puted Then
                If tmp.Level <= m(r, c).Level Then
                    If m(r, c).FlipCount > 0 Then
                    
                        If Not IsSecondHarf Then
                            If tmp.Level < m(r, c).Level Then
                                tmp.Level = m(r, c).Level
                                tmp.FlipCount = m(r, c).FlipCount
                                With obj
                                    .Row = r
                                    .Column = c
                                End With
                            ElseIf tmp.Level = m(r, c).Level Then
                                If tmp.FlipCount > m(r, c).FlipCount Then
                                    tmp.Level = m(r, c).Level
                                    tmp.FlipCount = m(r, c).FlipCount
                                    With obj
                                        .Row = r
                                        .Column = c
                                    End With
                                End If
                            End If
                            
                        Else
                        
                            If tmp.Level < m(r, c).Level Then
                                tmp.Level = m(r, c).Level
                                tmp.FlipCount = m(r, c).FlipCount
                                With obj
                                    .Row = r
                                    .Column = c
                                End With
                            ElseIf tmp.Level = m(r, c).Level Then
                                If tmp.FlipCount <= m(r, c).FlipCount Then
                                    tmp.Level = m(r, c).Level
                                    tmp.FlipCount = m(r, c).FlipCount
                                    With obj
                                        .Row = r
                                        .Column = c
                                    End With
                                End If
                            End If
                            
                        End If
                        
                    End If
                End If
            End If
        Next
    Next
    
    Set GetPos = obj
    
End Function

''駒を置く場所を再帰処理で思考し返す関数
Private Function GetPosByRecursive(ByVal om As OthelloManager) As DatumPoint
    
    Dim r&, c&, rr&, cc&
    Dim m() As ESquareState
    Dim v() As ESquareState
    Dim WinCount&
    Dim tmp&
    Dim FlipItems As Collection
    Dim FlipItem As DatumPoint
    Dim obj As DatumPoint
    
    Set obj = New DatumPoint
    
    With om

        m() = .Board.CurrentStatus()

        For r = LBound(m, 1) To UBound(m, 1)
            For c = LBound(m, 2) To UBound(m, 2)
                If m(r, c) = None Then
                    
                    v() = m()
                                        
                    Set FlipItems = .Rules.GetFlipItems(v, InsPos(r, c), mp.PieceColor)
                    
                    If FlipItems.Count > 0 Then
                        v(r, c) = mp.PieceColor
                        For Each FlipItem In FlipItems
                            With FlipItem
                                v(.Row, .Column) = Not v(.Row, .Column)
                            End With
                        Next

                        WinCount = 0
                        Call VirtualOthello(v, _
                                IIf(mp.PieceColor = otDark, otLight, otDark), _
                                mp.PieceColor, om, WinCount)
                        
                        If tmp <= WinCount Then
                            tmp = WinCount

                            With obj
                                .Row = r
                                .Column = c
                            End With

                        End If

                    End If
                End If
            Next
        Next

    End With
    
    Set GetPosByRecursive = obj
   
End Function

''再帰処理　仮想の盤上でオセロを進め勝敗を求める
Private Function VirtualOthello(ByRef m() As ESquareState, _
                                ByVal CurrentColor As EPieceColor, _
                                ByVal TargetPlayer As EPieceColor, _
                                ByVal om As OthelloManager, _
                                ByRef WinCount As Long) As Boolean
    Dim r&, c&
    Dim v() As ESquareState
    Dim FlipItems As Collection
    Dim FlipItem As DatumPoint
    
    v() = m()

    With om
        If .Rules.HasAPlace(v, CurrentColor) Then

            For r = 0 To UBound(v, 1)
                ''DoEvents
                For c = 0 To UBound(v, 2)
                    If v(r, c) = None Then
                        Set FlipItems = .Rules.GetFlipItems(v, InsPos(r, c), CurrentColor)
                        If FlipItems.Count > 0 Then
                            v(r, c) = CurrentColor
                            For Each FlipItem In FlipItems
                                With FlipItem
                                    v(.Row, .Column) = Not v(.Row, .Column)
                                End With
                            Next

                            If .Rules.LeftOverCount(v) > 0 Then
                                VirtualOthello v, _
                                    IIf(CurrentColor = otDark, otLight, otDark), _
                                    TargetPlayer, om, WinCount
                            Else
                                If Win(v) = TargetPlayer Then
                                    WinCount = WinCount + 1
                                End If
                            End If

                        End If
                    End If
                Next
            Next
        End If
    End With
    
End Function

''仮想盤上で勝者を求める
Private Function Win(ByRef m() As ESquareState) As ESquareState

    Dim r&, c&
    Dim bc&, wc&
    Dim i&

        For r = LBound(m, 1) To UBound(m, 1)
            For c = LBound(m, 2) To UBound(m, 2)

                Select Case m(r, c)
                    Case None
                    Case Dark
                        bc = bc + 1
                    Case Light
                        wc = wc + 1
                End Select
            Next
        Next

        Select Case True
            Case bc = wc
                Win = 1
            Case bc > wc
                Win = Dark
            Case wc > bc
                Win = Light
        End Select
       
End Function

''2か1をランダムで返す関数
Private Function GetOneOrTwo() As Integer
    'Randomize Now()
    GetOneOrTwo = Int(2 * Rnd + 1)
End Function

''指定した範囲の整数をランダムで返す関数
Private Function GetRandomNo(ByVal UpperBound As Integer, _
                             ByVal LowerBound As Integer) As Integer
    'Randomize Now()
    GetRandomNo = Int((UpperBound - LowerBound + 1) * Rnd + LowerBound)
End Function

''マスのレベルをランダムに決定
Private Sub LevelSet()

    SectionLevel(9) = 9
    SectionLevel(8) = GetRandomNo(8, 7)
    SectionLevel(7) = GetRandomNo(8, 6)
    SectionLevel(6) = GetRandomNo(7, 5)
    SectionLevel(5) = GetRandomNo(6, 4)
    SectionLevel(4) = GetRandomNo(5, 3)
    SectionLevel(3) = GetRandomNo(4, 2)
    SectionLevel(2) = GetRandomNo(3, 1)
    SectionLevel(1) = GetRandomNo(2, 1)
    SectionLevel(0) = GetRandomNo(1, 0)
    
End Sub

''マスにレベルをセットし配列として返す関数
Private Function GetComMemoryBord(ByRef m() As UMemoryBoard) As Boolean
    Dim r&, c&, i&, v
    
    If mComLevel = otComNormal Then
    
        i = 0
        For Each v In Array(9, 2, 3, 4, 4, 3, 2, 9, _
                            2, 1, 5, 6, 6, 5, 1, 2, _
                            3, 5, 7, 8, 8, 7, 5, 3, _
                            4, 6, 8, 0, 0, 8, 6, 4, _
                            4, 6, 8, 0, 0, 8, 6, 4, _
                            3, 5, 7, 8, 8, 7, 5, 3, _
                            2, 1, 5, 6, 6, 5, 1, 2, _
                            9, 2, 3, 4, 4, 3, 2, 9)
                            
            m(i \ 8, i Mod 8).Level = SectionLevel(v)
            i = i + 1
        Next
        
    ElseIf mComLevel = otComExpart Then
        
        i = 0
        For Each v In Array(9, 2, 8, 5, 5, 8, 2, 9, _
                            2, 1, 6, 7, 7, 6, 1, 2, _
                            8, 6, 3, 8, 8, 3, 6, 8, _
                            5, 7, 8, 0, 0, 8, 7, 5, _
                            5, 7, 8, 0, 0, 8, 7, 5, _
                            8, 6, 3, 8, 8, 3, 6, 8, _
                            2, 1, 6, 7, 7, 6, 1, 2, _
                            9, 2, 8, 5, 5, 8, 2, 9)
                            
            m(i \ 8, i Mod 8).Level = v
            i = i + 1
        Next
     
    End If
    
    GetComMemoryBord = True
End Function

Private Sub IParent_Attach(ByVal vptr As Long)
    mp.pOthelloManager = vptr
End Sub

Private Sub IParent_Remove()
    mp.pOthelloManager = 0&
End Sub
EOF



*****************************************************

DatumPoint.cls

*****************************************************
BOF,DatumPoint.cls
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "DatumPoint"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Public Row As Long
Public Column As Long
EOF



*****************************************************

IBoardView.cls

*****************************************************
BOF,IBoardView.cls
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "IBoardView"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Public Sub OnStateChanged(ByVal obj As Piece, _
                          ByVal pos As DatumPoint, _
                          Optional ByVal SetFocus As Boolean = False)

End Sub

Public Sub NotifySelectPos(ByVal pos As DatumPoint)
    
End Sub

Public Sub MsgShow(ByVal msg As String)

End Sub

Public Sub ScoreShow(ByVal Score As String)

End Sub

Public Function GetHwnd() As Long

End Function

Public Sub Finalize()

End Sub
EOF



*****************************************************

ICallbackPiece.cls

*****************************************************
BOF,ICallbackPiece.cls
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "ICallbackPiece"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Public Sub OnStateChanged(ByVal obj As Piece)

End Sub
EOF



*****************************************************

ICallbackSquare.cls

*****************************************************
BOF,ICallbackSquare.cls
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "ICallbackSquare"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Public Sub OnDoubleClick(ByVal obj As Square)

End Sub

Public Sub OnMouseMove(ByVal obj As Square)

End Sub

Public Sub Cancel()

End Sub
EOF



*****************************************************

ICallbackView.cls

*****************************************************
BOF,ICallbackView.cls
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "ICallbackView"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Public Sub OnSelectPos(ByVal pos As DatumPoint)

End Sub

Public Sub Cancel(ByRef Cancel As Boolean)

End Sub
EOF



*****************************************************

IOthelloPlayer.cls

*****************************************************
BOF,IOthelloPlayer.cls
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "IOthelloPlayer"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Public Sub Init(ByVal PlayerName As String)

End Sub

Public Function SelectPlace() As Boolean

End Function

Public Property Get Name() As String

End Property

Public Property Let Name(ByVal NewName As String)

End Property

Public Property Get PlayerType() As EPlayerType
    
End Property

Public Property Get PieceColor() As EPieceColor
    
End Property

Public Property Let PieceColor(ByVal newPieceColor As EPieceColor)
    
End Property

Public Property Get ColorToString() As String
    
End Property

Public Property Get Puted() As Boolean

End Property

Public Property Let Puted(ByVal blnPuted As Boolean)

End Property

Public Property Get PieceCount() As Long

End Property

Public Property Let PieceCount(ByVal Count As Long)

End Property

Public Function PlaceAPiece(newPoint As DatumPoint) As Boolean

End Function
EOF



*****************************************************

IParent.cls

*****************************************************
BOF,IParent.cls
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "IParent"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Public Sub Attach(ByVal vptr As Long)
    
End Sub

Public Sub Remove()

End Sub
EOF



*****************************************************

ManualPlayer.cls

*****************************************************
BOF,ManualPlayer.cls
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "ManualPlayer"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Implements IParent
Implements IOthelloPlayer

Private mp As UOthelloPlayer

Private Sub Class_Initialize()
    mp.PlayerType = otManualPlayer
End Sub

Private Sub Class_Terminate()
   ''Debug.Print mp.Name & "_Term!"
End Sub

Private Sub IOthelloPlayer_Init(ByVal PlayerName As String)
    
    Dim Name
    
    Do
        Name = Application.InputBox("名前を入力", _
                            OTHELLO_TITLE, PlayerName, , , , , 2)
                            
    Loop Until TypeName(Name) = "String" And Name <> ""
    
    IOthelloPlayer_Name = Name
        
End Sub

Private Property Let IOthelloPlayer_Name(ByVal RHS As String)
    mp.Name = RHS
End Property

Private Property Get IOthelloPlayer_Name() As String
    IOthelloPlayer_Name = mp.Name
End Property

Private Property Let IOthelloPlayer_PieceColor(ByVal RHS As EPieceColor)
    mp.PieceColor = RHS
End Property

Private Property Get IOthelloPlayer_PieceColor() As EPieceColor
    IOthelloPlayer_PieceColor = mp.PieceColor
End Property

Private Property Get IOthelloPlayer_ColorToString() As String
    IOthelloPlayer_ColorToString = IIf(mp.PieceColor = otDark, "黒", "白")
End Property

Private Property Let IOthelloPlayer_PieceCount(ByVal RHS As Long)
    mp.PieceCount = RHS
End Property

Private Property Get IOthelloPlayer_PieceCount() As Long
    IOthelloPlayer_PieceCount = mp.PieceCount
End Property

Private Function IOthelloPlayer_PlaceAPiece(newPoint As DatumPoint) As Boolean
    Dim om As OthelloManager
    Dim result As Boolean
    
    Set om = modOthello.GetOthelloManagerRef(mp.pOthelloManager)
    result = om.PlaceAPiece(Me, newPoint)
    If result Then
        mp.Puted = True
    End If
End Function

Private Property Get IOthelloPlayer_PlayerType() As EPlayerType
    IOthelloPlayer_PlayerType = mp.PlayerType
End Property

Private Property Let IOthelloPlayer_Puted(ByVal RHS As Boolean)
    mp.Puted = RHS
End Property

Private Property Get IOthelloPlayer_Puted() As Boolean
    IOthelloPlayer_Puted = mp.Puted
End Property

''ManualPlayerのマス選択関数
''Do Loopにより選択されるまで待機する
Private Function IOthelloPlayer_SelectPlace() As Boolean

    Dim om As OthelloManager

        IOthelloPlayer_Puted = False

        Set om = modOthello.GetOthelloManagerRef(mp.pOthelloManager)

        Do
            DoEvents
            Sleep 100
            If (om.State <= 1) Then Exit Function

        Loop While Not mp.Puted

        IOthelloPlayer_SelectPlace = True

End Function

Private Sub IParent_Attach(ByVal vptr As Long)
    mp.pOthelloManager = vptr
End Sub

Private Sub IParent_Remove()
    mp.pOthelloManager = 0&
End Sub
EOF



*****************************************************

modOthello.bas

*****************************************************
BOF,modOthello.bas
Attribute VB_Name = "modOthello"
Option Explicit

Public Const BOARD_SIZE As Long = 8   ''マスの数

Public Enum EPlayerType
    otManualPlayer = 0 'Manual
    otComPlayer = 1    'Com
End Enum

Public Enum EPieceColor
    otDark = 0
    otLight = -1
End Enum

''列挙体 VSモード
Public Enum EVsMode
    otManualVsCom = 0
    otComVsCom = 1
    otManualVsManual = 2
End Enum

Public Enum ESquareState
    None = 1     '何も置かれていない
    Dark = 0     '黒
    Light = -1   '白
End Enum

Public Enum EView
    otSheetView = 0
    otFormView = 1
End Enum

''列挙体　進行状態
Public Enum EOthelloState
    otNotBegin = 0 '未スタート
    otCancel = 1   'Cancelした
    otTwoPass = 2  '2回連続でパスをした
    otPlay = 3      'プレイ中
End Enum

''ユーザー定義型  盤のデータ
Public Type UMemoryBoard
    State     As ESquareState
    Level     As Long
    FlipCount As Long
    Puted     As Boolean
    WinCount  As Long
End Type

''ユーザー定義型 オセロプレーヤーのプロパティ
Public Type UOthelloPlayer
    pOthelloManager As Long
    Name            As String      ''名前
    PlayerType      As EPlayerType ''Type
    PieceColor      As EPieceColor ''駒の色
    PieceCount      As Long        ''駒の数
    Puted           As Boolean     ''駒を置いた
End Type

'''タイトル
Public Const OTHELLO_TITLE As String = "OJN's Othello"
'
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" _
                                (Destination As Any, _
                                 Source As Any, _
                                 ByVal Length As Long)
Public Declare Function beep Lib "kernel32" _
                                Alias "Beep" (ByVal dwFreq As _
                                Long, ByVal dwDuration As Long) As Long

Public Sub OthelloMain()

    Dim Othello As OthelloManager
    Dim View
    
    ''Viewの選択
    Do
        View = Application.InputBox("1 = UserFormView" & vbLf & _
                                    "0 = SheetView", "Viewを指定して下さい。", 1, , , , , 1)
        
        If VarType(View) = vbBoolean Then Exit Sub
        If View = 0 Or View = 1 Then Exit Do
       
    Loop
    
    ''選択したViewによるインスタンシング
    Select Case View
        Case otFormView
            Set Othello = modOthello.Create(otFormView, UserForm1, True)
        Case otSheetView
            Set Othello = modOthello.Create(otSheetView, Worksheets(1), True)
    End Select
    
    If Othello Is Nothing Then Exit Sub
    
    With Othello
        
        ''高速に進めるならTrue
        ''.WaitSkip = True
        
        Do
            Call .Wait(200)
            ''カレントプレーヤーの交代
            .ChangePlayer IsMsg:=True
            
            ''OthelloRulesにカレントプレーヤーが駒を置ける場所
            ''を持っているか問い合わせ
            If .Rules.HasAPlace(.Board.CurrentStatus, _
                                .CurrentPlayer.PieceColor, True) Then
                ''カレントプレーヤーのマスを選択するメソッド呼び出し
                Call .CurrentPlayer.SelectPlace
            End If
                           
            DoEvents
            
            ''両者の駒の数のチェックと数えた駒の数をそれぞれのプレーヤーに設定
            If Not .Rules.CheckPieceCount(.Board.CurrentStatus, .Players) Then Exit Do
            ''残りマスのチェック
            If .Rules.LeftOverCount(.Board.CurrentStatus) = 0 Then Exit Do
            ''Stateのチェック
            If .State < otPlay Then Exit Do
            
            ''ViewにScoreを表示
            .ScoreToView .Rules.Score(.Players)
        Loop
        
        .ScoreToView .Rules.Score(.Players)
        ''ViewにMsgの表示
        .MsgToView .Rules.Judge(.State, .Players)
        
    End With
    
    Set Othello = Nothing
    
End Sub

Public Function InsPos(ByVal ixRow As Long, ByVal ixCol As Long) As DatumPoint
    Set InsPos = New DatumPoint
    With InsPos
        .Row = ixRow
        .Column = ixCol
    End With
End Function

Public Function GetOthelloManagerRef(ByVal vptr As Long) As OthelloManager
    Dim tmp As OthelloManager
    
        MoveMemory tmp, vptr, 4&
        Set GetOthelloManagerRef = tmp
        MoveMemory tmp, 0&, 4&
        
End Function

''OthelloManagerのコンストラクタ関数
Public Function Create(ByVal View As EView, _
                       ByVal ViewObject As Object, _
                       Optional SoundEffect As Boolean = True, _
                       Optional BoardTopRow As Long = 1, _
                       Optional BoardLeftCol As Long = 1) As OthelloManager
                       
    Dim tmp As OthelloManager
    
    Set tmp = New OthelloManager
    Set Create = tmp.Init(View, ViewObject, SoundEffect, _
                          BoardTopRow, BoardLeftCol)
    
End Function

''Beepによる効果音
Public Sub BeepEx(ByRef Index As Long, _
                   Optional ByVal msec As Long = 50&, _
                   Optional ByVal CountUp As Boolean = True)
                   
    Dim bp As Variant
    
    bp = Array(262, 294, 330, 349, 392, 440, 494, 523)
    If Index < LBound(bp) Then Index = UBound(bp)
    If Index > UBound(bp) Then Index = LBound(bp)
    
    Call beep(bp(Index), msec)
    
    If CountUp Then
        Index = Index + 1
    Else
        Index = Index - 1
    End If
End Sub


EOF



*****************************************************

OthelloManager.cls

*****************************************************
BOF,OthelloManager.cls
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "OthelloManager"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Implements ICallbackView

Private Declare Function GetWindowThreadProcessId Lib "user32" _
                         (ByVal hwnd As Long, lpdwProcessId As Long) As Long
                         
Private Declare Function AttachThreadInput Lib "user32" _
                         (ByVal idAttach As Long, _
                          ByVal idAttachTo As Long, _
                          ByVal fAttach As Long) As Long

                         
Private Declare Function GetForegroundWindow Lib "user32" () As Long

Private Declare Function MessageBoxTimeoutA Lib "user32" _
                       (ByVal hwnd As Long, _
                        ByVal lpText As String, _
                        ByVal lpCaption As String, _
                        ByVal uType As Long, _
                        ByVal wLanguageId As Long, _
                        ByVal dwMilliseconds As Long) As Long
Private Declare Function GetActiveWindow Lib "user32" () As Long
Private Declare Function SetActiveWindow Lib "user32.dll" _
                                    (ByVal hwnd As Long) As Long
Private Declare Function SetForegroundWindow Lib "user32" _
                                    (ByVal hwnd As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
                                    (ByVal hwnd As Long, _
                                     ByVal nMsg As Long, _
                                     ByVal wParam As Long, _
                                     lParam As Any) As Long
Private Const WM_ACTIVATE = &H6
Private Const WM_SETFOCUS = &H7

''MyProperties
Private Type UOthelloManager
    VsMode         As EVsMode
    State          As EOthelloState
    FlipEffect     As Boolean
    PassCount      As Long
    LeftOverCount  As Long
    WaitSkip       As Boolean
    SoundEffect    As Boolean
    Player(1)      As IOthelloPlayer
    CurrentPlayer  As IOthelloPlayer
    Rules          As OthelloRules
    Board          As Board
    BoardView      As IBoardView
End Type

Private mp As UOthelloManager

Public Function Init(ByVal View As EView, _
                     ByVal ViewObject As Object, _
                     ByVal SoundEffect As Boolean, _
                     Optional ByVal BoardTopRow As Long = 1, _
                     Optional ByVal BoardLeftCol As Long = 1) As OthelloManager

    Dim ipar As IParent
    Dim icbv As ICallbackView
    Dim ibv  As IBoardView
    
    Select Case View
        
        Case otSheetView
        
            Set mp.Board = New Board
            mp.Board.Parent = ObjPtr(Me)
                      
            Dim sv As SheetView
            Set sv = New SheetView
            Set mp.BoardView = sv.Init(ViewObject, ObjPtr(Me), BoardTopRow, BoardLeftCol)
            
        Case otFormView
        
            Set mp.Board = New Board
            mp.Board.Parent = ObjPtr(Me)
            
            Dim fv As FormView
            Set fv = New FormView
            Set mp.BoardView = fv.Init(ViewObject, ObjPtr(Me))
    End Select
    
    Set ipar = mp.Board
    Set ibv = mp.BoardView
    ipar.Attach ObjPtr(ibv)
       
    Set ipar = mp.BoardView
    Set icbv = Me
    ipar.Attach ObjPtr(icbv)
    
    Set mp.Rules = New OthelloRules
    Set ipar = mp.Rules
    ipar.Attach ObjPtr(Me)
    
    mp.SoundEffect = SoundEffect
    
    If Not VsModeSelect() Then Exit Function
    If Not FourPieceSet() Then Exit Function
    
    Set Init = Me
    Me.State = otPlay
    
    Call ActivateView
End Function

Private Function FourPieceSet() As Boolean
    Dim r&, c&
    
    On Error GoTo Err_Handle
    
        r = BOARD_SIZE / 2
        c = BOARD_SIZE / 2
        
        With Me
           .PlaceAPiece .CurrentPlayer, InsPos(r - 1, c - 1)
           .ChangePlayer False
           .PlaceAPiece .CurrentPlayer, InsPos(r - 1, c)
           .ChangePlayer False
           .PlaceAPiece .CurrentPlayer, InsPos(r, c)
           .ChangePlayer False
           .PlaceAPiece .CurrentPlayer, InsPos(r, c - 1)
        End With
        
        FourPieceSet = True
    Exit Function

Err_Handle:

End Function
Private Sub Class_Initialize()
   mp.State = otNotBegin
   mp.WaitSkip = False
End Sub

Private Sub Class_Terminate()
    Dim ibv As IBoardView
    Set ibv = mp.BoardView
    Call ibv.Finalize
    ''Debug.Print "OthelloManager_Term!"
End Sub

Private Sub ICallbackView_Cancel(Cancel As Boolean)
    If MsgBox(OTHELLO_TITLE & "を終了しますか？", _
              vbQuestion Or vbYesNo, OTHELLO_TITLE) = vbYes Then
        State = otCancel
        Cancel = True
    End If
End Sub

''Viewからマスが選択された通知を受け
''CurrentPlayerのPlaceAPieceメソッドを呼出す
Private Sub ICallbackView_OnSelectPos(ByVal pos As DatumPoint)
    Call CurrentPlayer.PlaceAPiece(pos)
End Sub

''各プレーヤーから駒を置く為に呼ばれるメソッド
''指定した場所に駒が置けなければFalseを返す
Public Function PlaceAPiece(thisPlayer As IOthelloPlayer, _
                            newPoint As DatumPoint) As Boolean
    Dim newPiece As Piece
    
    PlaceAPiece = False
    
    Set newPiece = New Piece
    newPiece.Init thisPlayer.PieceColor
           
    If Rules.GetFlipItems(Board.CurrentStatus, newPoint, _
                          thisPlayer.PieceColor).Count > 0 Or State = otNotBegin Then
        FlipEffect = True
        PlaceAPiece = mp.Board.PlaceAPiece(newPiece, newPoint)
        FlipEffect = False
    Else
        
        MsgToView thisPlayer.ColorToString & "は、そこには置けません。"
        Call modOthello.BeepEx(0, 500, False)
        Wait 1000
        MsgToView CurrentPlayer.ColorToString & " " & _
                  CurrentPlayer.Name & "の番です。"
    End If
    
End Function

Public Property Get Board() As Board
    Set Board = mp.Board
End Property

Public Property Get State() As EOthelloState
    State = mp.State
End Property

Public Property Let State(ByVal newState As EOthelloState)
    mp.State = newState
End Property

Public Property Get Rules() As OthelloRules
    Set Rules = mp.Rules
End Property

Public Property Get Players() As IOthelloPlayer()
    Players = mp.Player()
End Property

'''VSモードを決定する
Public Function VsModeSelect() As Boolean
    Dim vm As Variant

    Do
        vm = Application.InputBox("VSモードを選択" & vbLf & vbLf & _
                                  "0 : Manual Vs Com    " & vbLf & _
                                  "1 : Com    Vs Com" & vbLf & _
                                  "2 : Manual Vs Manual", _
                                  OTHELLO_TITLE, 0, , , , , 1)

        If VarType(vm) = vbBoolean Then Exit Function
        vm = CLng(vm)
    Loop Until (vm >= 0) And (vm <= 2)

    VsMode = vm
    VsModeSelect = True
    
    Set mp.CurrentPlayer = ChoosePlayer()
    
End Function

''VSモード選択時 プレイヤー２名を動的に作成する
Private Property Let VsMode(ByVal NewVsMode As EVsMode)

    Dim ptr As Long
    Dim ipr As IParent
    
    With mp
        .VsMode = NewVsMode

        Select Case .VsMode
            Case otManualVsCom

                Set .Player(0) = New ManualPlayer
                    .Player(0).Init "Player1"
                    
                Set .Player(1) = New ComPlayer
                    .Player(1).Init "Com1"

            Case otComVsCom

                Set .Player(0) = New ComPlayer
                    .Player(0).Init "Com1"

                Set .Player(1) = New ComPlayer
                    .Player(1).Init "Com2"

            Case otManualVsManual

                Set .Player(0) = New ManualPlayer
                    .Player(0).Init "Player1"

                Set .Player(1) = New ManualPlayer
                    .Player(1).Init "Player2"
        End Select
        
        ''Attach
        ptr = ObjPtr(Me)
        Set ipr = .Player(0)
        ipr.Attach ptr
        Set ipr = .Player(1)
        ipr.Attach ptr
        
    End With

End Property

''駒の色をLong値で返す
Public Function GetColor(ByVal PieceColor As Long) As Long

    Dim lngColor As Long

        Select Case PieceColor
            Case otDark
                lngColor = vbBlack
            Case otLight
                lngColor = vbWhite
        End Select

        GetColor = lngColor
End Function

''カレントプレーヤーを変更する
Public Sub ChangePlayer(Optional ByVal IsMsg As Boolean = True)
    
    ''先攻後攻が未決定時
    If CurrentPlayer Is Nothing Then
        ''ランダムにプレーヤーを抽出する
        Set CurrentPlayer = ChoosePlayer()
        Exit Sub
    End If

    ''プレーヤーを変更する
    If CurrentPlayer Is mp.Player(0) Then
        Set CurrentPlayer = mp.Player(1)
    Else
        Set CurrentPlayer = mp.Player(0)
    End If

    ''変更した事を告げる
    If IsMsg Then
        MsgToView CurrentPlayer.ColorToString & " " & _
                  CurrentPlayer.Name & "の番です。"
    End If
    
    Call ActivateView
End Sub

Private Sub ActivateView()

    Dim hActiveWindow   As Long
    Dim hActiveThreadId As Long
    Dim hAppThread      As Long
    Dim ret As Long
    Dim hwnd&
    Dim ibv As IBoardView
    
    Set ibv = mp.BoardView
    
    hwnd = ibv.GetHwnd
    
    hActiveWindow = GetActiveWindow()
         
    If hActiveWindow <> hwnd Then
        hActiveThreadId = GetWindowThreadProcessId(hActiveWindow, ByVal 0&)
        hAppThread = GetWindowThreadProcessId(hwnd, ByVal 0&)
        ret = AttachThreadInput(hAppThread, hActiveThreadId, 1&)
        ret = SetActiveWindow(hwnd)
        ret = AttachThreadInput(hAppThread, hActiveThreadId, 0&)
    End If
End Sub

''先攻後攻をランダムに決定する
Private Function ChoosePlayer() As IOthelloPlayer
    Dim i As Single
    Dim msg$, msg2$

        Randomize Now()
        i = Round(Rnd(), 0)

        Set ChoosePlayer = mp.Player(i)

        If CBool(i) Then
            mp.Player(1).PieceColor = otDark
            mp.Player(0).PieceColor = otLight
            msg = "先攻 黒 " & mp.Player(1).Name
                 
        Else
            mp.Player(0).PieceColor = otDark
            mp.Player(1).PieceColor = otLight
            msg = "先攻 黒 " & mp.Player(0).Name
                  
        End If
  
        MsgToView msg
        Wait 500
End Function

Public Property Get CurrentPlayer() As IOthelloPlayer
    Set CurrentPlayer = mp.CurrentPlayer
End Property

Private Property Set CurrentPlayer(ByVal NewPlayer As IOthelloPlayer)
    Set mp.CurrentPlayer = NewPlayer
End Property

Public Sub MsgToView(ByVal msg As String)
    mp.BoardView.MsgShow msg
End Sub

Public Sub ScoreToView(ByVal Score As String)
    mp.BoardView.ScoreShow Score
End Sub

Public Property Get PassCount() As Long
    PassCount = mp.PassCount
End Property

Public Property Let PassCount(ByVal Value As Long)
    mp.PassCount = Value
    If mp.PassCount = 2 Then
        State = otTwoPass
        MsgToView "白黒共に置ける場所がありません。" & vbLf & _
                       "この状態で、ジャッジします。"
        Wait 2000
    End If
End Property

Public Property Get SoundEffect() As Boolean
    SoundEffect = mp.SoundEffect
End Property

Public Property Let SoundEffect(ByVal newSoundEffect As Boolean)
    mp.SoundEffect = newSoundEffect
End Property

Public Property Get WaitSkip() As Boolean
    WaitSkip = mp.WaitSkip
End Property

Public Property Let WaitSkip(ByVal newWaitSkip As Boolean)
    mp.WaitSkip = newWaitSkip
End Property

Public Property Get FlipEffect() As Boolean
    FlipEffect = mp.FlipEffect
End Property

Public Property Let FlipEffect(ByVal newFlipEffect As Boolean)
    mp.FlipEffect = newFlipEffect
End Property
''指定時間で自動的に閉じるMsgBox
Private Sub MsgBoxEx(ByVal msg As String, ByVal mode As VbMsgBoxStyle, _
                     ByVal Title As String, ByVal Interval As Long)

    MessageBoxTimeoutA 0&, msg, Title, mode, 0&, Interval * 1000&

End Sub

''指定秒プレイを中断する
Public Sub Wait(ByVal dwMilliseconds As Long)
    If Not mp.WaitSkip Then
         DoEvents
         Call Sleep(dwMilliseconds)
    End If
End Sub

EOF



*****************************************************

OthelloRules.cls

*****************************************************
BOF,OthelloRules.cls
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "OthelloRules"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Implements IParent

Private pOthelloManager As Long

''指定したプレーヤーが一つ以上駒を置ける場所があるか返す
Public Function HasAPlace(ByRef ss() As ESquareState, _
                          ByVal TargetColor As EPieceColor, _
                          Optional IsPassCheck As Boolean = False) As Boolean

    Dim Count As Long
    Dim Flag  As Boolean
    Dim r&, c&
    Dim om As OthelloManager
    
    For r = LBound(ss, 1) To UBound(ss, 1)
        For c = LBound(ss, 2) To UBound(ss, 2)
            If ss(r, c) = None Then
                If Not GetFlipItems(ss, InsPos(r, c), TargetColor) Is Nothing Then
                    Flag = True
                    Exit For
                End If
            End If
        Next
        If Flag Then Exit For
    Next
    
    HasAPlace = Flag
    If IsPassCheck Then
        Set om = modOthello.GetOthelloManagerRef(pOthelloManager)
        If Flag Then
            om.PassCount = 0
        Else
         om.PassCount = om.PassCount + 1
        End If
    End If
    
End Function

''残りマスの数を返す
Public Property Get LeftOverCount(ByRef m() As ESquareState) As Long
    Dim r&, c&

        For r = LBound(m, 1) To UBound(m, 1)
            For c = LBound(m, 2) To UBound(m, 2)
                If m(r, c) = None Then
                    LeftOverCount = LeftOverCount + 1
                End If
            Next
        Next
End Property

''反転する位置をCollectionで返す
Public Function GetFlipItems(ByRef ss() As ESquareState, _
                             ByVal newPoint As DatumPoint, _
                             ByVal Color As EPieceColor) As Collection
    Dim Count As Long
    Dim items As Collection
    Dim ixRow As Long, ixCol As Long
    
        With newPoint
            ixRow = .Row
            ixCol = .Column
        End With
        
        Set items = New Collection
        If ss(ixRow, ixCol) <> None Then
            Set GetFlipItems = items
            Exit Function
        End If
        
        Count = Count + LineSearch(ss, ixRow, ixCol, 0, 1, Color, items)
        Count = Count + LineSearch(ss, ixRow, ixCol, 1, 1, Color, items)
        Count = Count + LineSearch(ss, ixRow, ixCol, 1, 0, Color, items)
        Count = Count + LineSearch(ss, ixRow, ixCol, 1, -1, Color, items)
        Count = Count + LineSearch(ss, ixRow, ixCol, 0, -1, Color, items)
        Count = Count + LineSearch(ss, ixRow, ixCol, -1, -1, Color, items)
        Count = Count + LineSearch(ss, ixRow, ixCol, -1, 0, Color, items)
        Count = Count + LineSearch(ss, ixRow, ixCol, -1, 1, Color, items)
    
        Set GetFlipItems = items

End Function

''配列上の駒の並びより、計算する
Private Function LineSearch(ByRef ss() As ESquareState, _
                            ByVal ixRow As Long, ByVal ixCol As Long, _
                            ByVal StepR As Long, StepC As Long, _
                            ByVal CheckColor As EPieceColor, _
                            ByRef items As Collection) As Long

    Dim r As Long, c As Long
    Dim Count As Long, i As Long, j As Long
    Dim Flag As Boolean
    
    Count = 0: Flag = False: i = 0
    r = ixRow + StepR: c = ixCol + StepC

    Select Case True
        ''右
        Case StepR = 0 And StepC = 1
            Do While c <= UBound(ss, 2)
                If Not Calc(ss, r, c, CheckColor, Count, Flag) Then Exit Do
                items.Add InsPos(r, c)
                r = r + StepR: c = c + StepC: i = i + 1
            Loop
        ''右下
        Case StepR = 1 And StepC = 1
            Do While r <= UBound(ss, 1) And c <= UBound(ss, 2)
                If Not Calc(ss, r, c, CheckColor, Count, Flag) Then Exit Do
                items.Add InsPos(r, c)
                r = r + StepR: c = c + StepC: i = i + 1
            Loop

        ''下
        Case StepR = 1 And StepC = 0
            Do While r <= UBound(ss, 1)
                If Not Calc(ss, r, c, CheckColor, Count, Flag) Then Exit Do
                items.Add InsPos(r, c)
                r = r + StepR: c = c + StepC: i = i + 1
            Loop

        ''左下
        Case StepR = 1 And StepC = -1
            Do While r <= UBound(ss, 1) And c >= LBound(ss, 2)
                If Not Calc(ss, r, c, CheckColor, Count, Flag) Then Exit Do
                items.Add InsPos(r, c)
                r = r + StepR: c = c + StepC: i = i + 1
            Loop

        ''左
        Case StepR = 0 And StepC = -1
            Do While c >= LBound(ss, 2)
                If Not Calc(ss, r, c, CheckColor, Count, Flag) Then Exit Do
                items.Add InsPos(r, c)
                r = r + StepR: c = c + StepC: i = i + 1
            Loop

         ''左上
        Case StepR = -1 And StepC = -1
            Do While r >= LBound(ss, 1) And c >= LBound(ss, 2)
                If Not Calc(ss, r, c, CheckColor, Count, Flag) Then Exit Do
                items.Add InsPos(r, c)
                r = r + StepR: c = c + StepC: i = i + 1
            Loop

         ''上
        Case StepR = -1 And StepC = 0
            Do While r >= LBound(ss, 1)
                If Not Calc(ss, r, c, CheckColor, Count, Flag) Then Exit Do
                items.Add InsPos(r, c)
                r = r + StepR: c = c + StepC: i = i + 1
            Loop

        ''右上
        Case StepR = -1 And StepC = 1
            Do While r >= LBound(ss, 1) And c <= UBound(ss, 2)
                If Not Calc(ss, r, c, CheckColor, Count, Flag) Then Exit Do
                items.Add InsPos(r, c)
                r = r + StepR: c = c + StepC: i = i + 1
            Loop
    End Select

    ''FlagがFalseは挟む駒がない状態
    If Not Flag Then
        Count = 0
        For j = items.Count To items.Count - (i - 1) Step -1
            items.Remove items.Count
        Next
    End If
    
    LineSearch = Count
End Function

''駒が置かれた駒に挟まれているか計算
Private Function Calc(ByRef ss() As ESquareState, _
                      ByVal ixRow As Long, ByVal ixCol As Long, _
                      ByVal CheckColor As EPieceColor, _
                      ByRef Count&, ByRef Flag As Boolean) As Boolean

    If ss(ixRow, ixCol) = None Then Exit Function

    If ss(ixRow, ixCol) = CheckColor Then
        Flag = True
        Exit Function
    End If

    Count = Count + 1
    Calc = True

End Function

''白黒それぞれの数を数え各プレイヤーに値を設定
''駒の数が０個ならFalseを返す
Public Function CheckPieceCount(ByRef ss() As ESquareState, _
                                ByRef p() As IOthelloPlayer) As Boolean

    Dim r&, c&
    Dim bc&, wc&
    Dim i&

        For r = LBound(ss, 1) To UBound(ss, 1)
            For c = LBound(ss, 2) To UBound(ss, 2)

                Select Case ss(r, c)
                    Case None
                    Case Dark
                        bc = bc + 1
                    Case Light
                        wc = wc + 1
                End Select
            Next
        Next

        For i = 0 To UBound(p)
            With p(i)
                If .PieceColor = otDark Then
                    .PieceCount = bc
                Else
                    .PieceCount = wc
                End If
            End With
        Next

        If (bc = 0) Or (wc = 0) Then
            CheckPieceCount = False
        Else
            CheckPieceCount = True
        End If
End Function

''終了時 駒の数より判定しMsgを文字列で返す
Public Function Judge(ByVal OthelloState As EOthelloState, _
                      ByRef p() As IOthelloPlayer) As String
    
    Dim i&
    Dim msg$

    If OthelloState >= 2 Then
       
        Select Case True
            Case p(0).PieceCount > p(1).PieceCount
                msg = "Winner " & p(0).ColorToString & " " & p(0).Name

            Case p(0).PieceCount = p(1).PieceCount
                msg = "同点で引き分けです。 "

            Case p(0).PieceCount < p(1).PieceCount
                msg = "Winner " & p(1).ColorToString & " " & p(1).Name
        End Select
       
    Else
        msg = "終了しました。"
    End If

    Judge = msg
    
End Function

''スコアを文字列で返す
Public Function Score(ByRef p() As IOthelloPlayer) As String
 
    Dim msg$
            
    Score = p(0).ColorToString & " " & Format(p(0).PieceCount, "@@") & " : " & _
            p(1).ColorToString & " " & Format(p(1).PieceCount, "@@")
    
End Function

Private Sub IParent_Attach(ByVal vptr As Long)
    pOthelloManager = vptr
End Sub

Private Sub IParent_Remove()
    pOthelloManager = 0&
End Sub
EOF



*****************************************************

Piece.cls

*****************************************************
BOF,Piece.cls
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Piece"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Implements IParent

Private Type UPiece
    Color           As EPieceColor
    pICallbackPiece As Long  '' ICallbackPiece 型への参照アドレス。
End Type

Private mp As UPiece

Public Function Init(ByRef NewColor As EPieceColor) As Piece
    
    Color = NewColor
    Set Init = Me
    
End Function

Public Function Flip() As Piece
    Color = Not mp.Color
    Set Flip = Me
End Function

Public Property Get Color() As EPieceColor
    Color = mp.Color
End Property

Private Property Let Color(ByVal NewColor As EPieceColor)
    Dim obj As ICallbackPiece
        
    mp.Color = NewColor
    If mp.pICallbackPiece = 0 Then Exit Property
    Set obj = GetICallbackPieceRef(mp.pICallbackPiece)
    obj.OnStateChanged Me
End Property

Private Function GetICallbackPieceRef(ByVal vptr As Long) As ICallbackPiece
    Dim tmp As ICallbackPiece
    
    MoveMemory tmp, vptr, 4&
    Set GetICallbackPieceRef = tmp
    MoveMemory tmp, 0&, 4&
End Function

Private Sub Class_Terminate()
    ''Debug.Print "Piece_Term!"
End Sub

Private Sub IParent_Attach(ByVal pICallbackPiece As Long)
    mp.pICallbackPiece = pICallbackPiece
End Sub

Private Sub IParent_Remove()
    mp.pICallbackPiece = 0&
End Sub
EOF



*****************************************************

SheetView.cls

*****************************************************
BOF,SheetView.cls
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "SheetView"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Implements IParent
Implements IBoardView

Private Const CELL_WIDTH As Single = 3 ''マスの幅
Private Const PEICE_LINE_WEIGHT As Single = 0.25 ''駒の外枠太さ
Private Const PEICE_OFFSET As Single = 8 ''駒のサイズ調整用
Private Const BOARD_COLOR As Long = 32768

Private Type USheetView
    SheetDatumPoint   As DatumPoint
    MsgBoard          As Range
    ScoreBoard        As Range
    pICallbackView    As Long
    pOthelloManager   As Long
End Type

Private mp As USheetView

Private WithEvents mSheet As Excel.Worksheet
Attribute mSheet.VB_VarHelpID = -1

Public Function Init(ByVal ViewObject As Object, _
                     ByVal OthelloManager As Long, _
                     ByVal BoardBaseRow As Long, _
                     ByVal BoardBaseCol As Long) As SheetView
        
    Set mSheet = ViewObject
    mp.pOthelloManager = OthelloManager
    Set mp.SheetDatumPoint = InsPos(BoardBaseRow, BoardBaseCol)
    Call CreateBoard
        
    Set Init = Me
End Function

Private Sub IBoardView_Finalize()
    Call IBoardView_MsgShow("")
End Sub

Private Function IBoardView_GetHwnd() As Long
    IBoardView_GetHwnd = Application.hwnd
End Function

Private Sub IBoardView_MsgShow(ByVal msg As String)
    mp.MsgBoard.Value = "Msg   : " & msg
End Sub

Private Sub IBoardView_ScoreShow(ByVal Score As String)
    mp.ScoreBoard.Value = "Score : " & Score
End Sub

''OthelloManagerにマスが選択された事を通知
Private Sub IBoardView_NotifySelectPos(ByVal pos As DatumPoint)
    Dim icbv As ICallbackView
    
    Set icbv = GetICallbackViewRef(mp.pICallbackView)
    icbv.OnSelectPos pos
End Sub

Private Sub IBoardView_OnStateChanged(ByVal obj As Piece, _
                                      ByVal pos As DatumPoint, _
                                      Optional ByVal SetFocus As Boolean = False)
    Dim om  As OthelloManager
    Dim myR As Range
    Dim sp  As Shape
    Dim p   As Single
    
    Set om = modOthello.GetOthelloManagerRef(mp.pOthelloManager)
                  
    Set myR = mSheet.Cells(mp.SheetDatumPoint.Row + pos.Row, _
                           mp.SheetDatumPoint.Column + pos.Column)
        
        p = myR.Width / PEICE_OFFSET ''駒のサイズ調整用
        
        Call Protect(False)
        
        If SetFocus Then
            myR.Select
            Set sp = CreateShape(myR, p)
        Else
            Set sp = GetPieceShape(myR)
            If sp Is Nothing Then
                Set sp = CreateShape(myR, p)
            End If
        End If
        With sp
            .Fill.ForeColor.RGB = om.GetColor(obj.Color)
            .Line.Weight = PEICE_LINE_WEIGHT
        End With
        
        Call Protect(True)
       

End Sub

Private Function CreateShape(ByVal place As Range, _
                             ByVal p As Single) As Shape
     Set CreateShape = mSheet.Shapes.AddShape _
                        (msoShapeOval, place.Left + p, place.Top + p, _
                        place.Width - 2 * p, place.Height - 2 * p)
End Function

''Target内にあるShapeを取得
Private Function GetPieceShape(ByVal Target As Range) As Shape
    Dim ps As Shape
    
    If Target.Count > 1 Then Exit Function
    
    For Each ps In mSheet.Shapes
       If ps.AutoShapeType = msoShapeOval Then
           If Target.Address(0, 0) = ps.TopLeftCell.Address(0, 0) Then
               Set GetPieceShape = ps
               Exit For
           End If
       End If
    Next
End Function

''既存の駒を全て削除する関数
Private Function DeleteAllPiece() As Boolean
    
    Dim ps As Shape
      
        On Error GoTo Err_Handle
        
            For Each ps In mSheet.Shapes
               If ps.AutoShapeType = msoShapeOval Then
                  ps.Delete
               End If
            Next
       
        On Error GoTo 0
    
    DeleteAllPiece = True
     
    Exit Function
Err_Handle:

End Function

Private Sub CreateBoard()

    Dim r As Long
    Dim c As Long
    Dim myR As Range

        On Error GoTo Err_Handle
        
        Call Protect(False)
        Call DeleteAllPiece
        
        r = mp.SheetDatumPoint.Row
        c = mp.SheetDatumPoint.Column
       
        With mSheet
            .Cells.ClearFormats
            .Cells.Clear
            
            Set myR = .Range(.Cells(r, c), _
                             .Cells(r + BOARD_SIZE - 1, _
                             c + BOARD_SIZE - 1))
            Set mp.MsgBoard = .Range(.Cells(r + BOARD_SIZE, c), _
                            .Cells(r + BOARD_SIZE, c + BOARD_SIZE - 1))
            
            Set mp.ScoreBoard = .Range(.Cells(r + BOARD_SIZE + 1, c), _
                            .Cells(r + BOARD_SIZE + 1, c + BOARD_SIZE - 1))
            With myR
                .Locked = False
                .Interior.Color = BOARD_COLOR
                .ColumnWidth = CELL_WIDTH
                .RowHeight = .item(1).Width
                                    
                .BorderAround xlContinuous, xlThin, , vbGreen

                With .Borders(xlInsideHorizontal)
                    .LineStyle = xlContinuous
                    .Color = vbWhite
                    .Weight = xlHairline
                End With

                With .Borders(xlInsideVertical)
                    .LineStyle = xlContinuous
                    .Color = vbWhite
                    .Weight = xlHairline
                End With
            End With
                           
            With mp.MsgBoard
                .Merge True
                .RowHeight = myR.RowHeight
                .BorderAround xlContinuous, xlThin, , vbGreen
                .Font.Size = 9
            End With
            With mp.ScoreBoard
                .Merge True
                .RowHeight = myR.RowHeight
                .BorderAround xlContinuous, xlThin, , vbGreen
                .Font.Size = 9
            End With
        End With
        
        Call Protect(True)
    On Error GoTo 0

    Exit Sub
Err_Handle:
    MsgBox Err.Description
        
End Sub

Private Sub mSheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Cancel = True
    If Target.Count > 1 Then Exit Sub
    
    Call IBoardView_NotifySelectPos(InsPos(Target.Row - mp.SheetDatumPoint.Row, _
                                    Target.Column - mp.SheetDatumPoint.Column))
End Sub

Private Sub mSheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    Cancel = True
    Call NotifyCancel
End Sub

Private Sub IParent_Attach(ByVal vptr As Long)
    mp.pICallbackView = vptr
End Sub

Private Sub IParent_Remove()
    mp.pICallbackView = 0&
End Sub

Private Function GetICallbackViewRef(ByVal vptr As Long) As ICallbackView
    Dim tmp As ICallbackView
    
    MoveMemory tmp, vptr, 4&
    Set GetICallbackViewRef = tmp
    MoveMemory tmp, 0&, 4&
    
End Function

''OthelloManagerのCancelメソッド呼び出し
Private Sub NotifyCancel()
    Dim result As Boolean
    Dim icbv As ICallbackView
    
    Set icbv = GetICallbackViewRef(mp.pICallbackView)
    Call icbv.Cancel(result)
    
    If result Then
        ''Cancelの結果を受けFinalize処理
        Call IBoardView_Finalize
    End If
    
End Sub

''オセロ盤の保護・保護解除
Private Sub Protect(ByVal blnProtect As Boolean)

    With mSheet
        If blnProtect Then
            .Protect , True, , , True
            .EnableSelection = xlUnlockedCells
        Else
            .Unprotect
            .EnableSelection = xlNoRestrictions
        End If
    End With

End Sub
EOF



*****************************************************

Square.cls

*****************************************************
BOF,Square.cls
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Square"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Implements IParent

Private Const SQUARE_BACK_COLOR   As Long = 32768
Private Const SQUARE_LINE_COLOR   As Long = vbWhite
Private Const SQUARE_FOCUS_COLOR  As Long = &H8080FF
Private Const PIECE_SYMBOL        As String = "●"
Private Const PIECE_DAMMY_SYMBOL  As String = "○"

Private Type USquare
    Point             As DatumPoint
    Selected          As Boolean
    pICallbackSquare  As Long
End Type

Private mp As USquare
Private WithEvents mSquare As MSForms.Label
Attribute mSquare.VB_VarHelpID = -1



Public Function Init(ByVal newPos As DatumPoint, _
                     ByVal newSquare As MSForms.Label, _
                     ByVal newLeft As Single, _
                     ByVal newTop As Single, _
                     ByVal newHeight As Single, _
                     ByVal newWidth As Single) As Square
                     
    Set mSquare = newSquare
    Set mp.Point = newPos
    
    With mSquare
        .Left = newLeft
        .Top = newTop
        .Height = newHeight
        .Width = newWidth
        .BackColor = SQUARE_BACK_COLOR
        .SpecialEffect = fmSpecialEffectFlat
        .BorderStyle = fmBorderStyleSingle
        .BorderColor = SQUARE_LINE_COLOR
        .TextAlign = fmTextAlignCenter
        .Font.Size = ((.Height * 100 * 0.85) \ 75) * 0.75
        .ForeColor = vbYellow
    End With
    
    Set Init = Me
End Function
Private Sub IParent_Attach(ByVal vptr As Long)
    mp.pICallbackSquare = vptr
End Sub

Private Sub IParent_Remove()
    mp.pICallbackSquare = 0&
End Sub

Private Sub mSquare_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    Dim obj As ICallbackSquare
    
    Cancel = True
    
    Set obj = GetICallbackSquareRef(mp.pICallbackSquare)
    obj.OnDoubleClick Me
End Sub


Public Sub WillFlipEffect()
    With mSquare
        .SpecialEffect = fmSpecialEffectFlat
        .BorderStyle = fmBorderStyleSingle
        .BorderColor = vbRed
        DoEvents
    End With
End Sub

Public Sub FocusEffect()
    With mSquare
        .BackColor = SQUARE_FOCUS_COLOR
    End With
End Sub

Public Sub MouseMoveEffect()
    With mSquare
    
        If .Caption <> PIECE_SYMBOL Then
            .Caption = PIECE_DAMMY_SYMBOL
        End If

    End With
End Sub

Public Sub UndoEffect()
    
    With mSquare
        
        If Not Selected Then
            If .BackColor <> SQUARE_BACK_COLOR Then
               .BackColor = SQUARE_BACK_COLOR
            End If
        End If
        
        If .Caption = PIECE_DAMMY_SYMBOL Then
            .Caption = ""
        End If
        If .SpecialEffect <> fmSpecialEffectFlat Then
            .SpecialEffect = fmSpecialEffectFlat
        End If
        If .BorderStyle <> fmBorderStyleSingle Then
            .BorderStyle = fmBorderStyleSingle
        End If
        If .BorderColor <> SQUARE_LINE_COLOR Then
           .BorderColor = SQUARE_LINE_COLOR
        End If
        
        
    End With
   
End Sub

Private Sub mSquare_MouseMove(ByVal Button As Integer, _
                              ByVal Shift As Integer, _
                              ByVal X As Single, _
                              ByVal Y As Single)
                              
    Dim icbs As ICallbackSquare
        
    Set icbs = GetICallbackSquareRef(mp.pICallbackSquare)
    icbs.OnMouseMove Me
End Sub

Private Sub mSquare_MouseUp(ByVal Button As Integer, _
                            ByVal Shift As Integer, _
                            ByVal X As Single, _
                            ByVal Y As Single)
    
    Dim icbs As ICallbackSquare
    
    If Button = 2 Then
        Set icbs = GetICallbackSquareRef(mp.pICallbackSquare)
        icbs.Cancel
    End If
End Sub

Private Function GetICallbackSquareRef(ByVal vptr As Long) As ICallbackSquare
    Dim tmp As ICallbackSquare
    
    MoveMemory tmp, vptr, 4&
    Set GetICallbackSquareRef = tmp
    MoveMemory tmp, 0&, 4&
End Function

Public Property Get Point() As DatumPoint
    Set Point = mp.Point
End Property

Public Sub Show(ByVal obj As Piece)
    With mSquare
        If Not obj Is Nothing Then
            .Caption = PIECE_SYMBOL
        Else
             .Caption = ""
        End If
        .ForeColor = IIf(obj.Color = otDark, vbBlack, vbWhite)
    End With
End Sub

Public Property Get Selected() As Boolean
    Selected = mp.Selected
End Property

Public Property Let Selected(ByVal newValue As Boolean)
    mp.Selected = newValue
    If mp.Selected Then
        Call FocusEffect
    Else
        Call UndoEffect
    End If
End Property
EOF



*****************************************************

FormView.cls

*****************************************************
BOF,FormView.cls
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "FormView"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Implements IParent
Implements IBoardView
Implements ICallbackSquare

Private Type UFormView
    Squares          As Collection
    MsgBoard         As MSForms.Label
    ScoreBoard       As MSForms.Label
    pICallbackView   As Long
    pOthelloManager  As Long
    Wstyle           As Long
    hwnd             As Long
End Type

Private mp As UFormView
Private WithEvents mForm  As UserForm
Attribute mForm.VB_VarHelpID = -1

Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" _
                                    (ByVal lpClassName As String, _
                                     ByVal lpWindowName As String) As Long
                                             
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
                                    (ByVal hwnd As Long, _
                                     ByVal nIndex As Long, _
                                     ByVal dwNewLong As Long) As Long
                                             
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
                                    (ByVal hwnd As Long, _
                                     ByVal nIndex As Long) As Long

Private Declare Function DrawMenuBar Lib "user32" _
                                    (ByVal hwnd As Long) As Long
                                    
Private Const SQUARE_SIZE As Single = 30
Private Const BOARD_COLOR As Long = 32768
Private Const WS_SYSMENU = &H80000
Private Const GWL_STYLE = -16

Private Sub IBoardView_Finalize()
    
    Call UndoSysMenu(mp.hwnd)
    Call UndoEffect
End Sub

Private Function IBoardView_GetHwnd() As Long
    IBoardView_GetHwnd = mp.hwnd
End Function

Public Function Init(ByVal ViewObject As Object, _
                     ByVal OthelloManager As Long) As FormView
    
    Dim obj As Object
    Dim hwnd As Long, lngWstyle As Long
    
    Set mForm = ViewObject
    mp.pOthelloManager = OthelloManager
    
    Load mForm
    
    Call CreateBoard
    
    Set obj = ViewObject
    With obj
        .Caption = OTHELLO_TITLE
        .Width = (.Width - mForm.InsideWidth) + SQUARE_SIZE * BOARD_SIZE
        .Height = (.Height - mForm.InsideHeight) + _
                  SQUARE_SIZE * (BOARD_SIZE + 2)
    End With
    
    obj.Show vbModeless
    mp.hwnd = GetHwnd(obj)
    Call RemoveSysMenu(mp.hwnd)
    
    Set Init = Me
   
End Function

''UserFormの「×」を消す
Private Sub RemoveSysMenu(ByVal hwnd As Long)
    mp.Wstyle = GetWindowLong(hwnd, GWL_STYLE)
    SetWindowLong hwnd, GWL_STYLE, mp.Wstyle And (Not WS_SYSMENU)
    DrawMenuBar hwnd
End Sub

''UserFormのSysMenuを元に戻す
Private Sub UndoSysMenu(ByVal hwnd As Long)
    SetWindowLong mp.hwnd, GWL_STYLE, mp.Wstyle
    DrawMenuBar mp.hwnd
End Sub

Private Sub IBoardView_MsgShow(ByVal msg As String)
    mp.MsgBoard.Caption = "Msg   : " & msg
End Sub

Private Sub IBoardView_ScoreShow(ByVal Score As String)
    mp.ScoreBoard.Caption = "Score : " & Score
End Sub

Private Sub IBoardView_NotifySelectPos(ByVal pos As DatumPoint)
    Dim icbv As ICallbackView
    
    Set icbv = GetICallbackViewRef(mp.pICallbackView)
    icbv.OnSelectPos pos
End Sub

Private Sub IBoardView_OnStateChanged(ByVal pc As Piece, _
                                      ByVal pos As DatumPoint, _
                                      Optional ByVal SetFocus As Boolean = False)
    Dim sq As Square

    If mp.Squares Is Nothing Then Exit Sub
        
    Set sq = mp.Squares(CStr(pos.Row & "," & pos.Column))

    If sq Is Nothing Then Exit Sub
    
    sq.Show pc
    
    If SetFocus Then
        sq.Selected = True
        SelectCancel sq
    End If
    
    Call UndoEffect(sq)
    
End Sub

''盤の作成
Private Sub CreateBoard()

    Dim ctl  As MSForms.Label
    Dim sq   As Square
    Dim ics  As ICallbackSquare
    Dim ipar As IParent
    Dim pos  As DatumPoint
    Dim r&, c&, i&
    
        Set ics = Me
        Set mp.Squares = New Collection
        
        For r = 0 To BOARD_SIZE - 1
            For c = 0 To BOARD_SIZE - 1
                                
                Set ctl = mForm.Controls.Add("Forms.Label.1", , True)
                Set sq = New Square
                Set pos = InsPos(r, c)
                sq.Init pos, ctl, c * SQUARE_SIZE, _
                        r * SQUARE_SIZE, SQUARE_SIZE, SQUARE_SIZE
                                
                Set ipar = sq
                ipar.Attach ObjPtr(ics)
                              
                mp.Squares.Add sq, CStr(r & "," & c)
            Next
        Next
        
        Set mp.MsgBoard = mForm.Controls.Add("Forms.Label.1", , True)
        With mp.MsgBoard
            .Left = 0
            .Top = SQUARE_SIZE * BOARD_SIZE
            .Height = SQUARE_SIZE
            .Width = SQUARE_SIZE * BOARD_SIZE
            .BackColor = vbWhite
            .ForeColor = vbBlue
            .SpecialEffect = fmSpecialEffectEtched
        End With
        
        Set mp.ScoreBoard = mForm.Controls.Add("Forms.Label.1", , True)
        With mp.ScoreBoard
            .Left = 0
            .Top = SQUARE_SIZE * (BOARD_SIZE + 1)
            .Height = SQUARE_SIZE
            .Width = SQUARE_SIZE * BOARD_SIZE
            .BackColor = vbWhite
            .ForeColor = vbBlue
            .SpecialEffect = fmSpecialEffectEtched
        End With
End Sub

Private Sub mForm_MouseMove(ByVal Button As Integer, _
                                  ByVal Shift As Integer, _
                                  ByVal X As Single, _
                                  ByVal Y As Single)
    Call UndoEffect
End Sub

Private Sub mForm_MouseUp(ByVal Button As Integer, _
                          ByVal Shift As Integer, _
                          ByVal X As Single, _
                          ByVal Y As Single)
    If Button = 2 Then
        Call NotifyCancel
    End If
End Sub

Private Sub ICallbackSquare_OnDoubleClick(ByVal obj As Square)
    Call IBoardView_NotifySelectPos(obj.Point)
End Sub

Private Sub ICallbackSquare_OnMouseMove(ByVal obj As Square)
    Dim om      As OthelloManager
    Dim items   As Collection
    Dim item    As DatumPoint
    Dim sq      As Square
    Dim sqItems As Collection
    Dim wsq     As Square
    Dim tmp     As Square
    Dim cp      As IOthelloPlayer
    Static o    As Square
           
    If o Is obj Then Exit Sub
    Set o = obj
    
    Set om = modOthello.GetOthelloManagerRef(mp.pOthelloManager)
    
    If om.State = otNotBegin Then Exit Sub
    If om.FlipEffect Then Exit Sub
    Set cp = om.CurrentPlayer
    If TypeOf cp Is ComPlayer Then Exit Sub
    If cp.Puted Then Exit Sub
    
    Set items = om.Rules.GetFlipItems(om.Board.CurrentStatus, _
                                      obj.Point, _
                                      om.CurrentPlayer.PieceColor)
    
    Set sqItems = New Collection
    For Each item In items
        Set sq = mp.Squares(item.Row & "," & item.Column)
        sqItems.Add sq, item.Row & "," & item.Column
    Next
    
    If sqItems.Count > 0 Then
        
        For Each sq In mp.Squares
            On Error Resume Next
           
            Set tmp = sqItems(CStr(sq.Point.Row & "," & sq.Point.Column))
            If Err.Number <> 0 Then
                If Not obj Is sq Then
                    sq.UndoEffect
                End If
            Else
                sq.WillFlipEffect
                DoEvents
            End If
            Set tmp = Nothing
            On Error GoTo 0
        Next
    Else
        Call UndoEffect(obj)
    End If
    
    obj.MouseMoveEffect

End Sub

Private Sub ICallbackSquare_Cancel()
    Call NotifyCancel
End Sub

Private Sub IParent_Attach(ByVal vptr As Long)
    mp.pICallbackView = vptr
End Sub

Private Sub IParent_Remove()
    mp.pICallbackView = 0&
End Sub

Private Function GetICallbackViewRef(ByVal vptr As Long) As ICallbackView
    Dim tmp As ICallbackView
    
    MoveMemory tmp, vptr, 4&
    Set GetICallbackViewRef = tmp
    MoveMemory tmp, 0&, 4&
    
End Function

Private Sub UndoEffect(Optional ByVal obj As Square = Nothing)
    Dim sq As Square
    
    For Each sq In mp.Squares
        If Not (sq Is obj) Then
           sq.UndoEffect
        End If
    Next
    
End Sub

Private Sub SelectCancel(ByVal obj As Square)
    Dim sq As Square
    
    For Each sq In mp.Squares
        If Not (sq Is obj) Then
           sq.Selected = False
        End If
    Next
    
End Sub

Private Sub NotifyCancel()
    Dim result As Boolean
    Dim icbv As ICallbackView
    
    Set icbv = GetICallbackViewRef(mp.pICallbackView)
    Call icbv.Cancel(result)
    
    If result Then
        Call UndoSysMenu(mp.hwnd)
    End If
    
End Sub

Public Property Get GetHwnd(ByVal o As Object) As Long

    If o Is Nothing Then Exit Property
    GetHwnd = FindWindow(vbNullString, o.Caption)
   
End Property


EOF

いい記事を見つけたので。
 
codic_project on Twishort
http://twishort.com/af3js
 

codic_project さんの引用:
ネーミングとプログラム設計は、対で考える。
自分が作ろうとしているクラスやメソッドなどが、どの様な責務を持ち、何を隠蔽し、どういう機能を外部に提供するかが言葉で説明できるのであれば、名前は自然に出てくる。
だから、うまくネーミングできない場合は、プログラム設計が悪い場合が多い。
共通化の名目で、なし崩し的に共通処理を外部化するような場合にネーミングに困るのは、そんな理由（ボキャブラリーが少ないとかはさておき）。

なにか部品として使えるクラスがあって，簡単に導入できて効果がすばらしいものがあれば，このスレッドで紹介するにふさわしいわけですが，考えたらあった．
 
自分が一番ほしかったのが【進行状況の表示】．処理に時間がかかるものも結構あって，でも進行状況が出せれば待っているストレスも減るってものでしょう．だけど，あとから付け足しで，簡単なものってのがね．ないね．
 
検索すれば「進行状況の表示」は出てくるのですが，「プログレスバーを利用しなさい」しか出てこないし，たいていは１重ループだ．
 
そうじゃないんだ．「開いているすべてのブック，のすべてのシート，の使用しているすべてのセル」なんて処理が普通にある．３重ループだよ．しかも，以下のようになってたりする．
    For Each wb In Application.Workbooks
        For Each ws In wb.Worksheets
           hoge ws.UsedRange
別プロシージャだよ！
 
それで自作することにしましたが，やっぱりメインロジックに報告コードを書かないとダメだよね．報告コード分，コードが長く汚くなる．避けたい．でも検討したけど無理だと思う（ログ処理に含める？無理！というかログ処理いつもは無いし）．
 
こんな進行状況の表示．さて，最適解は？
 
要件：
Q1.表示先はユーザーフォームと限らない
Q2.多重ループ対応や，他プロシージャ対応
Q3.導入にそれほど手間がかからない
 
時間のある方は考えてみてください．(^^)/
 
 
 
私の回答：
A1.表示と状況把握は分離．
「進行状況の表示 IProgressViewer」と「進行状況の管理 ProgressCounter」と分ける．
ただし，クラス数を増やしたくないので，IProgressViewer インターフェイスは実際には設定しない．した方が安全ではあるが，実装クラスのみとする．
 
 
A2.多重ループは内部スタックで対応，他プロシージャはインスタンスをどこかで保持で対応．
 
 
A3.デフォルト値を多用．クラス最小限．表示はカウンタが制御．
クラス構造は，普通に考えれば以下．
<ロジック> → <カウンタ> → <表示>
 
<カウンタ>と<表示>の強結合にならないだろうか？　こんな決め打ちで良いのだろうか？なんて考えたりする．
 
ならこっちか？
<ロジック> → <表示>
↓
<カウンタ>
 
<ロジック>が２つとも相手にしないといけないなんて嫌すぎる．これは初期化時だ．初期化時は，<ロジック>が<カウンタ>や<表示>を決める．でもその後は，<カウンタ>と<表示>が強調動作してくれるのがいい．
 
さて，<ロジック>がカウントアップするたびに表示更新していたのでは表示に時間が取られるが・・・単純に<カウンタ>が表示更新を抑制すればいいのか？
 
別方向．<表示>から考えれば，表示変更はイベント発生時．WithEvents で<カウンタ>を受ける．って，標準モジュールから使えなくなるから，この案は却下．ということは，コールバックしかないか．VBA は関数ポインタは使えないしなぁ．CallByName もあるけどオブジェクトの指定は必要だし，100 倍時間がかかるし，プロシージャ名決め打ちのコールバックでしょう．
 
 
話はもういいや．コード！
 
こんなコードがあるとする．
 
'' すべてのシートのある範囲をランダム値で埋める．
Public Sub Test()
    Dim ws As Worksheet
    Dim cel As Range
     
    For Each ws In ThisWorkbook.Worksheets
        For Each cel In ws.Range("A1:Z500")
            cel.Value = Rnd
        Next
    Next
End Sub
 
進行状況コードを追加する．
 
Public Sub TestWithProg()
    Dim ws As Worksheet
    Dim rng As Range
    Dim cel As Range
    Dim pc As ProgressCounter
     
    Set pc = New ProgressCounter
     
    pc.Start "ランダムフィル", 0, ThisWorkbook.Worksheets.Count
    For Each ws In ThisWorkbook.Worksheets
        Set rng = ws.Range("A1:Z500")
         
        pc.CreateChild 1
        pc.Start ws.Name, 0, rng.Count
        For Each cel In rng
            cel.Value = Rnd
            pc.Increment
        Next
        pc.DestroyChild
    Next
End Sub
 
こんぐらいは増えてしまう．
・進行状況コードで 7 行
・範囲を明確にする必要があるので + 2 行
 
元のコードが長ければそんなに気にならないけど，どうか．
 
コードの書き方としては，Start/Increment/Finish(上では省略) があれば良い．入れ子の中も Start/Increment なので，上位ループを気にする必要はない．だから別プロシージャも可能．もちろん，その仕組みとして入れ子を CreateChild/DestoryChild で作成・破棄する．
 
別プロシージャにするときにはモジュールレベル変数とか，グローパルプロパティにしておく．
 
Public m_pc As ProgressCounter
 
Public Property Get pc() As ProgressCounter '' 初期化する場合はプロシージャにする．
    If m_pc Is Nothing Then
        Set m_pc = New ProgressCounter
' m_pc.SetCallBackObject ...
    End If
    Set pc = m_pc
End Property
 
Public Sub TestWithProg2()
    Dim ws As Worksheet
     
    pc.Start "ランダムフィル", 0, ThisWorkbook.Worksheets.Count
    For Each ws In ThisWorkbook.Worksheets
        pc.CreateChild 1
        testWithProg2_2 ws.Range("A1:Z500")
        pc.DestroyChild
    Next
    pc.Finish True
End Sub
 
Private Sub testWithProg2_2(ByVal Target As Range)
    Dim cel As Range
     
    pc.Start Target.Worksheet.Name, 0, Target.Count
    For Each cel In Target
        cel.Value = Rnd
        pc.Increment
    Next
End Sub
 
 
■クラス：ProgressStatusbar
※ステータスバーに出力する．
 
Option Explicit
 
Public Sub CallBack(ByVal Caller As Object, ByVal Arg As Variant)
    Dim s As String
     
    Select Case TypeName(Caller)
        Case "ProgressCounter"
            If Arg(0) = -1 Then
                Application.StatusBar = False
            Else
                s = String(20, "□")
                Mid(s, 1, 20 * Arg(0)) = String(20, "■")
                Application.StatusBar = s & "" & Format(Arg(0), " #0.0%") & " " & Arg(1)
            End If
    End Select
End Sub
 
Private Sub Class_Terminate()
    Application.StatusBar = False
End Sub
 
 
■クラス：ProgressCounter
※そんなに複雑な状況で使っていないから漏れとか，使いづらさがあるかも．
 
' @(h) ProgressCounter.cls ver 1.4 '12.06.18
 
' @(s)
' 目的：入れ子対応のカウンタークラス。表示は別クラス。
' インスタンスを常に生成する場合は、以下のように簡単に使える。
' With New ProgressCounter
' .Start "Processing", 0, 2
'' '' Step.1
' .CreateChild 1
' .Start "Child Processing", 0, 10
' For i = 1 To 10
' ...
' .Increment
' Next
' .DestroyChild '' この分の Increment は不要。
' '' Step.2
' ...
' .Increment
' End With
'
' ・インスタンスを生成せずに再入させる場合は、レベルゼロの最後で .Finish が必要。
' ・表示先がステータスバー（ProgressStatusbar）でなければ、.Start の前に .SetCallBackObject が必要。
'
' インターフェース：
' 　・プロパティ
' ItemText ループ内の個々のアイテム名。
' Level 現レベル。レベルゼロが最初。
' Min 現レベルの範囲の最小。
' Max 現レベルの範囲の最大。
' Percentage 現レベルのパーセンテージ。値を指定することで、その値のパーセンテージも取得可能。
' TotalPercentage 全体での現在のパーセンテージ。
' TotalText レベルテキストやアイテムテキストをすべてつなげた文字列。
' Value 現レベルの値。
' 　・メソッド
' CreateChild 子レベルの作成。親レベルのいくつを割り当てるか指定する。
' DestroyChild 子レベルの削除。子の進行状況がどうであれ、割り当てられた量が完了したとなる。
' Increment カウントアップ。デフォルトは 1 アップ。指定可能。
' SetCallBackObject 報告先オブジェクトの設定。呼び出されるメソッド：CallBack、渡す値：Me, Array(トータル％, トータルテキスト)、※トータル％が -1 なら Finish。
' デフォルトは ProgressStatusbar。
' Start カウントの開始。レベルタイトルと範囲を指定する。範囲にはゼロ同等の値を含むこと。100 ループなら範囲は101個になる。
' Finish カウントの終了。ProgressCounter の破棄があれば不要。
' 　・イベント
'
' 依存関係：
' ・報告先オブジェクト（デフォルトは ProgressStatusbar）
' オブジェクトは前述のコールバックプロシージャを持つ必要がある。
'
' 問題点：
' ・報告方法
' 現在はイベントなどにはせず、コールバックとしている。また報告タイミングは 0.2秒ごと／Finished 時としている。
'
' 改善点：
'
' 方法：
'
                                     
 
Option Explicit
 
'' 97 だと使えないし、この速度で更新はせわしない。
'Event Update(ByVal Percentage As Single, ByVal Text As String)
 
Private Type UCounter
    FullText As String
    ItemText As String
    Min As Long
    Max As Long
    Value As Long
    Finished As Boolean
    ChildValue As Long '' 子が使用する Value 量。
    ChildPercentage As Single '' 子の全体に対する百分率。
    StartPercentage As Single '' 子の全体に対する百分率開始位置。
End Type
Private Type UProgressCounter
    CounterStack() As UCounter
    CurrCounter As UCounter
     
    StartTime As Single
    LastUpdate As Single
     
    CallBackObject As Object
End Type
Private mp As UProgressCounter
 
Private Sub Class_Initialize()
    With mp
        Set .CallBackObject = New ProgressStatusbar
    End With
    With mp.CurrCounter
        .ChildValue = 0
        .ChildPercentage = 1
        .StartPercentage = 0
    End With
End Sub
Private Sub Class_Terminate()
    Dim i As Long
     
    For i = 1 To Level
        popCounter
    Next
    Finish
End Sub
 
Private Sub raiseUpdateEvent()
    With mp
        If Level = 0 And .CurrCounter.Finished Then
            .CallBackObject.CallBack Me, Array(-1, "")
        Else
            If (Timer - .LastUpdate) < 0.2 Then Exit Sub
            .LastUpdate = Timer
         
            '' RaiseEvent Update(Me.TotalPercentage, Me.FullText)
            .CallBackObject.CallBack Me, Array(Me.TotalPercentage, Me.TotalText)
        End If
    End With
End Sub
 
Public Sub SetCallBackObject(ByVal CallBackObject As Object)
    Set mp.CallBackObject = CallBackObject
End Sub
 
Private Function StrConnect(ByVal s1 As String, ByVal s2 As String, ByVal Delimiter As String) As String
    If s1 = "" And s2 = "" Then Exit Function
     
    If s1 <> "" And s2 <> "" Then
        StrConnect = s1 & Delimiter & s2
    ElseIf s1 <> "" Then
        StrConnect = s1
    Else
        StrConnect = s2
    End If
End Function
Public Sub Start(Optional ByVal LevelText As String, _
                 Optional ByVal Min As Long = 0, _
                 Optional ByVal Max As Long = 100)
    If Me.Level = 0 Then
        mp.StartTime = Timer
        mp.CurrCounter.FullText = ""
    End If
     
    With mp.CurrCounter
        .FullText = StrConnect(.FullText, LevelText, ",")
        .Min = Min
        .Max = Max
        .Value = Min
        .Finished = False
    End With
     
    raiseUpdateEvent
End Sub
Public Sub Finish(Optional ByVal DebugPrintTime As Boolean = False)
    With mp.CurrCounter
        .Value = .Max
        .Finished = True
    End With
 
    raiseUpdateEvent
     
    If Me.Level = 0 Then
        Debug.Print Me.TotalText, (Timer - mp.StartTime) & "s"
    End If
End Sub
 
Public Property Let ItemText(ByVal NewValue As String)
    With mp.CurrCounter
        .ItemText = NewValue
    End With
     
    raiseUpdateEvent
End Property
Public Property Get ItemText() As String
    ItemText = mp.CurrCounter.ItemText
     
    raiseUpdateEvent
End Property
Public Sub Increment(Optional ByVal IncrementalValue As Long = 1)
    With mp.CurrCounter
        .Value = .Value + IncrementalValue
    End With
     
    raiseUpdateEvent
End Sub
Public Sub CreateChild(ByVal ChildValue As Single)
    Dim s As String
     
    With mp.CurrCounter
        .ChildValue = ChildValue
        s = TotalText
    End With
     
    pushCounter
         
    With mp.CurrCounter
        .StartPercentage = TotalPercentage
        .ChildPercentage = Percentage(ChildValue) * .ChildPercentage
        .FullText = s
    End With
End Sub
Public Sub DestroyChild()
    popCounter
    With mp.CurrCounter
        .Value = .Value + .ChildValue
    End With
     
    raiseUpdateEvent
End Sub
 
Public Property Get Min() As Single
    Min = mp.CurrCounter.Min
End Property
Public Property Get Max() As Single
    Max = mp.CurrCounter.Max
End Property
Public Property Get Value() As Single
    Value = mp.CurrCounter.Value
End Property
Public Property Let Value(ByVal NewValue As Single)
    mp.CurrCounter.Value = NewValue
End Property
Public Property Get TotalText() As String
    With mp.CurrCounter
        TotalText = StrConnect(.FullText, .ItemText, ",")
    End With
End Property
Public Property Get Percentage(Optional ByVal Value As Variant = Empty) As Single
    With mp.CurrCounter
        If IsEmpty(Value) Then Value = .Value
         
        Percentage = (Value - .Min) / (.Max - .Min)
    End With
End Property
Public Property Get TotalPercentage() As Single
    With mp.CurrCounter
        TotalPercentage = .StartPercentage + (.ChildPercentage * Percentage)
    End With
End Property
 
 
Public Property Get Level() As Long
    On Error Resume Next
     
    Level = 0
    Level = UBound(mp.CounterStack) + 1
End Property
 
Private Sub pushCounter()
    Dim ix As Long
    On Error Resume Next
         
    With mp
        ix = UBound(.CounterStack) + 1
        If Err.Number <> 0 Then
            ix = 0
            ReDim .CounterStack(0 To 0)
        Else
            ReDim Preserve .CounterStack(0 To ix)
        End If
        .CounterStack(ix) = .CurrCounter
    End With
End Sub
Private Sub popCounter()
    Dim ix As Long
    With mp
        ix = UBound(.CounterStack)
        .CurrCounter = .CounterStack(ix)
        If ix = 0 Then
            Erase .CounterStack
        Else
            ReDim Preserve .CounterStack(0 To ix - 1)
        End If
    End With
End Sub