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

みなさん、こんにちは。
 
「VBAのクラスの話題が極端に少ない」という現状に風穴を開けたくこのスレッドを
立ち上げます。とは言っても堅苦しくなく楽しい雰囲気で進めれればと思います^^
 
スーパーテクニックをお持ちの識者の方から、クラスをまだ使った事がないという方まで
ご参加頂ければ幸いです。
 
例えば
 
・何をクラスにするのか？みなさんの判断基準。
 
・クラス化にするメリット
　構造体や標準モジュールに機能別にまとめたプロシージャ郡では駄目なのか？
 
・こんなクラスを使っています！
　これに相当興味があります。みなさんどうぞ御紹介して下さい。
 
・他言語から見た、VBAのクラスの可能性や制限事項。
　とっても難しい話題ですが、、解説お願いします。私自身は.netの猛勉強中です。
 
ざっくり書きましたが、クラスに関する話題なら何でもうれしいです^^
 
私自身が最近作っていたクラスは
 
UserForm上の部品偏
 
・Userformの見栄えを向上する為にグラデーションをかけるクラス
　Usefrorm内にFrameやMultiPageがあってもその中にまでくまなくグラデーションをか
　けます。
 
・4つのクラスを使って作成した視覚的にグループ分けが出来るクラス
　ListBox間のItem交換をイメージしたクラスで、コンテナやアイテムをLabelで作成し
　コンテナにアイテムをドラッグして移動するとアイテムがコンテナに吸い込まれ自動
　で整列します。
  MaxItemCountプロパティを実装しコンテナ内のアイテム数が指定数を上回ると
　アイテムが自動的に元の位置に戻る機能なんかも付けました。
 
データ処理偏
 
.クラスを勉強したいなら既存のオブジェクトモデルを参考にしたらと何方かが書かれ
　ていたのを見ましてADOのオブジェクトモデルを参考にして、
　ワークシートをRecordset風に扱うクラスを作成しました。
 
　VBAのプロジェクト名をOJNDB(おじさんのDB）と名づけ参照設定して
　使用する様にしました(笑）
 
  OJNDB.Connectionオブジェクト
  　�楼JNDB.Recordsetオブジェクト
  　　�楼JNDB.Feildsオブジェクト
  　　　�楼JNDB.Feildオブジェクト
 
　既存のADOを一切含めていないので、SQL句での処理ができないのが泣き所です。
　本来ならRs.Feilds.Item(0).Valueと書く所を Rs(0).Valueと省略して書けるまでに
　なるように規定のプロパティの作成方法も学べました。
　実用化まではまだまだ試行錯誤が必要ですが、すごく勉強になりました。
　
どんな話題でも結構です。ふるって御参加下さい。
 
（yayadonさん。どうかsimpleさんの問いに解説お願いします！！別スレッドでの
　解説はくまなく 試して勉強させて頂いております。ありがとうございます。
　こちらの方でも是非お願いします！）
 
# simpleさん。お返事遅くなり申し訳ありません。本業が激務になっておりました^^;
# 余談ですが先週、スノーボードでエアー着地時に膝が肋骨に入り２本逝きました、、
# 今は息をするのもつらい状態です。みなさんウインタースポーツには注意しましょう^^

# すみません。
# 用語を間違えていた(構造体->ユーザー定義型)ので書き直しました。
 
 
VBA で，(特に習い始めでは)
ごまかして教えたり，あえて教えなかったりするものを上げてみると...
 
　・Variant型
　・暗黙の型強制(各種の型変換)
　・ユーザー定義型とクラスの違い
　・オブジェクト参照
　・コレクション
　・ActiveX コントロール
 
あたりでしょうか？
Windows API のネタはWEB上に多いのですが，
これら周辺のネタが少ないので，
そこを学びたいという場合は，大変かもしれません。
 
このスレ的には，
ユーザー定義型とクラスの違い や オブジェクト参照 あたりをクリアすれば，
他の人のすばらしいコードの応用が利きますね。
 
 
いずれにしても，覚えるタイミングというのがあって，
何かのネタ(自身の持っているVBAの知識では不思議なこと)が出てきたとき，
それと絡めて覚えていくことで，
不思議なことの裏事情(カラクリ)がわかってくる
というパターンが王道な気がします。
また，検索する際も，そういう不思議ネタで検索する時に，
新たな情報に巡り合えることが多いような気がします。
 
# 例えば，自分が思うには，
# コレクションの意味を本当に理解しているか？を確認するには
# Rangeオブジェクト を題材にするのがいいような気がします。
 
逆に，疑問に思うことが出てこない場合は，
VBA は抽象的に理解して使うもの という認識で使っている
ということで，それはそれで，また，OKということでしょう。
 
 
# 別スレでの simple さんの疑問は，
# アグリゲーション と呼ばれているものが相当すると思うのですが，
# VBA の場合，UserForm 上で ActiveX コントロール を扱うときなど，
# ユーザーは知らずにつかっています。
# VBA ではあえて教えない/触れないことになってると思います。
　
　

みそじのおじさん さんの引用:
・何をクラスにするのか？
　みなさんの判断基準。
・クラス化にするメリット
　構造体や標準モジュールに機能別にまとめたプロシージャ郡では駄目なのか？
・こんなクラスを使っています！
　これに相当興味があります。みなさんどうぞ御紹介して下さい。
・他言語から見た、VBAのクラスの可能性や制限事項。
　とっても難しい話題ですが、、解説お願いします。私自身は.netの猛勉強中です。

・そもそもVBAにおけるクラスやオブジェクトって、どういう理解や考え方をしたらいいのか

うぉー 　　　　# って、ボキャ貧にも程がある？
念願のスレッドを建てていただき、ありがとうございます。
これからの議論大変楽しみにしております。
よろしくお願いします。
 
とりあえず情報だけですが、
みそじのおじさんのこの掲示版でのクラス使用例は
http://www.moug.net/faq/viewtopic.php?t=60582
のスレッドです。
 
取り急ぎ御礼を申し述べさせていただきます。
追々コメントをさせていただきたく思います。
 
# > 今は息をするのもつらい状態です。
# それは大変ですね。どうぞご自愛下さい。

◆ コレクション と 列挙子
 
コレクションの説明をする中で，
VBA では説明をしない事柄が少なくとも一つあります。
それは
 
　列挙子(イテレータ/iterator/enumerator)
 
と呼ばれているものです。
 
 
最初の納得から，勉強するにつれて疑問に変わっていくもので，
何かいい例はないかと思っていたのですが，
以下のスレッド
 
シートの非表示
http://www.moug.net/faq/viewtopic.php?t=62238
 
に，初心者にわかりやすい喩があったので，これで行くことにします。
 
このスレッドの中で，
 
For Each の例
 
　Dim c As Range
　Set myRng = Range("C1:C10")
　For Each c In myRng
 
に対して，
 
　For Each みかん In みかん箱
 
という比喩が出てきます。
これは，
 
　みかん箱の中からみかんを一個ずつ取り出す
 
という意味です。最初はこれでOKでしょう。
VBA を習って，慣れていくにつれて，
VBA で習った知識だけだと，疑問が出てくる人がいるかもしれません。
 
　みかん箱からみかんを取り出すのは誰か？
 
ということです。
とりあえず，VBA だろうか？と考えたとします。
 
　みかん箱が配列
 
ならば，VBA は取り出せるでしょう。
というのは，配列の構造は丸見えだからで，
各みかんが，どのように並んでいるのかが分かるからです。
実際に，この In の後ろに 配列 を持ってくることは可能です。
 
では，
 
　みかん箱がコレクション
 
だったらどうでしょう？
 
コレクションとオブジェクトは，
階層的にあるように扱われ，別物にされがちですが，
コレクションは，見方を変えると，
オブジェクトが提供する機能の内のひとつにすぎないので，
 
　コレクション自体もオブジェクト
 
ということになります。そして，VBA を習っていくと，
 
　オブジェクトは，カプセル化されている
 
ということを習うでしょう。そして，その意味は，
 
　オブジェクト内部の構造を外部に直接には見せない
 
というようなことである... と習うことになります。
 
ということは，
みかん箱がコレクションだった場合，
 
　内部で，各みかんがどのように並んでいるのか？が，外からはわからない
 
ということになります。
ということで，VBA もどう取り出したらよいかわからないということになります。
 
その解決のため，
 
　コレクション自体が，みかんを取り出す代理人を提供
 
することになっています。以下のような関係になります。
 
　　　　　みかん箱が
　VBA <=>　提供した　<=> みかん箱(みかんコレクション)
　　　　　　代理人
 
この代理人のことを
 
　列挙子
 
といいます。なので，上の図は，
 
　　　　　みかん箱用
　VBA <=> 　列挙子　 <=> みかん箱(みかんコレクション)
 
のような関係になります。
この列挙子というものが，VBA の指示に従って，みかん箱からみかんを取り出してくれます。
そして，
みかん箱用列挙子を提供するのは，みかん箱(みかんコレクション)自身です。
 
 
 
ここからは，みかん箱でなく，実際のコレクションの話に移していきます。
-----
 
コレクションは，自身用の列挙子を提供するためのメンバを用意しています。
それは
 
　_NewEnum
 
というメンバ/プロパティです。
 
VBA のオブジェクトブラウザで，
 
　[非表示のメンバを表示]　にチェックを入れる
 
と，コレクションと呼ばれているオブジェクトのメンバを見ると
上記の _NewEnum というプロパティが見つかるはずです。
例えば，Range オブジェクトにも _NewEnum が見つかるはずです。
 
みかんの話に戻ると，
VBA は，みかん箱 の _NewEnum プロパティから列挙子を取得して，
その列挙子に対して命令することで，みかんを取り出すことになるわけです。
 
列挙子自体もオブジェクトで，
VBA が扱う列挙子は，
 
　・Next
　・Skip
　・Reset
　・Clone
 
というメソッドメンバを持つ IEnumなんとか という名前のインターフェース
を実装して，公開しています。
また，
IEnumなんとか インターフェースというものは，
IUnknown インターフェースを継承しているので，
なんとか というところの名前は変わっても，
提供するメソッドは，
 
　・QueryInterface
　・AddRef
　・Release
　・Next
　・Skip
　・Reset
　・Clone
 
という順になり，
VBA が利用する Next メソッドは，先頭からの相対位置が決まっています。
そして，
メソッドの呼び出しは，名前ではなく相対位置で呼び出すので，
_NewEnum で列挙子を取得すれば，Next メソッドを呼び出すことが可能になるわけです。
 
ということで，
 
　For Each ... In コレクション で，VBA が使うものは，
　コレクションから取得した列挙子の Next メソッドというもので，
　それを順次呼び出して，次のオブジェクトを取り出していく。
 
ということになります。
 
For Each の場合は，一度に，一個ずつ取り出しますが，
Next メソッド自体は，一度にひとつでも複数個でも取り出せるメソッドになっています。
 
-----
 
コレクションは，列挙子を _NewEnum メンバで提供すると書きました。
COM仕様上は，コレクションは，少なくとも，他に
 
　・Count　コレクションが所持する項目(オブジェクト)の数
　・Item　 コレクションが所持する項目(オブジェクト)をインデックスやタグ(名前)でアクセス
 
というプロパティを提供する決まりになっています。
Range オブジェクトは，この Count も Item も提供しているため，
機能的には，コレクションの役割を果たしています。
 
 
-----
 
 
最後に
 

Dim myItem As Range
For Each myItem In Range("C1:C10")
    myItem.Value = ...
Next

Dim myRange As Range
Dim myItem As Range
Set myRange = Range("C1:C10")
For Each myItem In myRange
    myItem.Value = ...
Next

Dim i As Long
Dim cnt As Long
Dim myRange As Range
Set myRange = Range("C1:C10")
cnt = myRange.Count
For i = 1 To cnt
    myItem.Item(i).Value = ...
Next

みそじのおじさん さんの引用:
・何をクラスにするのか？みなさんの判断基準。

みそじのおじさん さんの引用:
・クラス化にするメリット
　構造体や標準モジュールに機能別にまとめたプロシージャ郡では駄目なのか？

みそじのおじさん さんの引用:
・こんなクラスを使っています！
　これに相当興味があります。みなさんどうぞ御紹介して下さい。

みそじのおじさん さんの引用:
・他言語から見た、VBAのクラスの可能性や制限事項。
　とっても難しい話題ですが、、解説お願いします。私自身は.netの猛勉強中です。

みそじのおじさん さんの引用:
クラスを勉強したいなら既存のオブジェクトモデルを参考にしたらと何方かが書かれていたのを見まして

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

一昔前、モーグ・スキルアップ講座
大村あつし さんの【クラスモジュールを使った究極のVBAプログラム】抜粋です。
前略
・・・・・
■クラスモジュールを使う場面
　最初に、「クラスモジュールを使わないとできないこと」と、「クラスモジュールを使うとできること」を合わせて3つ挙げておきます。細かく分析すれば他にもあるのですが、紙面の都合も考えてここでは3つにしておきます。
●クラスモジュールを使わないとできないこと
　(1)アプリケーションレベルのイベント処理
●クラスモジュールを使うとできること
　(2)擬似コントロール配列の作成
　(3)同一データの並列処理
VBAユーザーがクラスモジュールを使う理由のほとんどが、(1)のアプリケーションレベルのイベント処理です。この処理方法については後述しますが、唯一これだけは嫌でもクラスモジュールを使わなければならないケースです。(2)と(3)については、ほとんどの方がクエスチョンマークではないでしょうか。もし、この箇条書きだけでピンと来るようであれば、間違いなくクラスモジュールの超上級者です。そのような方には、この記事も不要と思われます（でも最後まで読んでください）。もちろん、ピンと来ない方もご安心を。あとで懇切丁寧に解説いたします。
・・・・・
中略
・・・・・
■擬似コントロール配列の作成
VBAはイベントドリブン（イベント駆動型）の側面も併せ持ちますが、基本的にアプリケーションを構成するオブジェクトを処理するための開発言語です。したがって、フォームやコントロールの領域ではどうしても本家のVBに見劣りします。もっとも、この領域で差別化が図られなかったら、何のためのVBなのか、ということになってしまいますが。そして、Microsoftのこうした思惑が絡んでいるのかは定かではありませんが、VBにできてVBAにできない典型的なコントロール処理に「コントロール配列」があります。
VBでの開発経験がない方のために簡単にコントロール配列を紹介しますと、フォーム上の同種のコントロールにインデックス値を与えて、あたかも変数の配列を扱うかのようにコントロールを扱う手法をコントロール配列と呼びます。つまり、コマンドボタンが5個あって、各ボタンの表示文字列を「コマンドボタン1」〜「コマンドボタン5」に変更するときには、リスト5のコードを実行すればいいのです。
・・・・・
中略
・・・・・
今から紹介するのは、自分で申し上げるのもなんですが、クラスモジュールを使ったハイクラステクニックです。コントロール配列の壁に阻まれ苦悩していたVBAユーザーにとっては、このテクニックを習得するだけでも、本誌を購入した甲斐があると言うものです（これは言いすぎ？しかし、少なくともコントロール配列（VB）を購入しなくて済むのは事実です）。
まず、ユーザーフォームとクラスモジュールを1枚ずつ挿入してください。このとき、ユーザーフォームのオブジェクト名は「UserForm1」、クラスモジュールのオブジェクト名は「Class1」のままで結構です。そして、ユーザーフォームに「CommandButton1」〜「CommandButton5」の5個のコマンドボタンを貼り付け、リスト9のコードをUserForm1モジュールに、リスト10のコードをClass1モジュールに作成してください。
あとは、UserForm1を表示して任意のコマンドボタンをクリックすれば、そのコマンドボタン名がメッセージとして表示されます。
この事例は、クラスモジュールに作成した1つのイベントプロシージャが、どのコントロールに対して発生したイベントであるかが検知できていることを証明しています。もう一度繰り返します。VBAでもクラスモジュールを活用すればコントロール配列が操作できるのです。
・・・・・
後略
 
上記のコントロール配列は非常に便利で応用して使っています。
参考までに掲載されていたサンプルコードは
リスト9：UserForm1モジュールに作成
Option Explicit
Option Base 1
 
Dim myClass1(5) As New Class1
 
Private Sub UserForm_Initialize()
      Dim myCmdBtns As New Collection
      Dim i As Integer
 
      With myCmdBtns
            .Add Item:=CommandButton1
            .Add Item:=CommandButton2
            .Add Item:=CommandButton3
            .Add Item:=CommandButton4
            .Add Item:=CommandButton5
      End With
 
      For i = 1 To 5
            Set myClass1(i) = New Class1
            With myClass1(i)
                  .Cmd = myCmdBtns(i)
                  .Index = i
            End With
      Next
End Sub
 
リスト10：Class1モジュールに作成
Option Explicit
 
Private WithEvents myCmd As MSForms.CommandButton
Private m_intIndex As Integer
 
Public Property Get Cmd() As MSForms.CommandButton
      Set Cmd = myCmd
End Property
 
Public Property Let Cmd(ByVal cmdNewValue As MSForms.CommandButton)
      Set myCmd = cmdNewValue
End Property
 
Public Property Get Index() As Integer
      Index = m_intIndex
End Property
 
Public Property Let Index(ByVal intNewValue As Integer)
      m_intIndex = intNewValue
End Property
 
 
Private Sub myCmd_Click()
      MsgBox "クリックしたボタンは CommandButton" & m_intIndex
End Sub
 
標準モジュールに作成
Sub 擬似コントロール()
 
    UserForm1.Show
 
End Sub
 
モーグ運営事務局で意図的に削除されたコラムでしたらレスを削除して下さい。

yayadonさん、ろひさん、simpleさん、月さん、ゴマさん。
みなさん。ご参加ありがとうございます^^
立ち上げた時はどなたも来てくれないんじゃないかと、とても不安でしたが
とてもうれしいです。ありがとうございます。
 
▽yayadonさん
とても詳しい解説をありがとうございます。コレクションクラスの解説としてこれ以上の
ものは見た事がありません。貴重な解説です。
 
VBAだけをやってきた人はVBAの知識だけでは説明の出来ない事にでくわす。←私です、、
疑問にも思わず通り過ぎてしまう。←これも私です、、
 
最近ずっと思っているのは、「VBAを深く知りたければ、よりネイティブな言語に一度どっぷり
浸かってみないとダメじゃないか？」と思っています。
私はみなさんとのレスのやり取りの中で、この方のバックグラウンドは何か？といつも気にかけ
ています。どういった言語をバックボーンとして持っているとこういった考え方が出来るのかと。
みなさんのバックボーンもお聞きしてみたいですね。（VBAオンリーな方と他言語を生業とされ
ている方とではクラスの捕らえ方が違うと私は思っています。）
 
私のプログラミング暦は
学生時代に
・QuickBasicを少々
・生Cを少々（落第です、、）
社会人になってから
・本業で使っているNCプログラム言語。14年（工作機械を動かす為の言語、Basicをまねて作
　られていると思われます。制御構文はIFとGOTOのみ、扱えるのはDouble型の数値だけと
　いったとても古い言語です。世界一の某自動車メーカーの金型など製作しております。）
・会社に入ってから始めたVBA。約7〜8年excelとAccess両方やります。
・別サイトで勧められもう一度はじめたC,C++（猫でもわかる。で勉強させてもらいました
　しかし私C,C++を出来ます！といったレベルではありません、）、
・現在 .netを本気で始めて1年も経っていない。
 
といった感じです。
クラスのお話と共にみなさんのバックボーンもお聞かせ下さるととても参考になります。
 
▽ろひさん
ご参加ありがとうございます。
 

引用:

みそじのおじさんが扱われているような、Webや書籍でもなかなか見つからない実務・実例的な観点を含んだクラスについての話題が増えるのを、非常に期待しております。
（※他人事のような書き方ですが、私自身、クラスに関してはたいして実務的な経験やネタを持ち合わせてないものですみません。）

# 既にご存知でしょうけど、ROMの方向けに。
 
井川さんのコレクションクラスのサンプル
http://excelfactory.net/excelboard/excelvba/cfs.cgi?word=%97%F1%8B%93%82%C6%83u%83b%83N&andor=and&logs=14.txt

# 話が脱線するんですが...
# 井川さんは他の意図があって言われたと思いますが
 
kumatti さんのリンク先の説明で，
(オブジェクト)参照の参照は，間接参照になるようなことが書いてあるのですが，
現存のすべての言語にあてはまるのかは知りませんが，
いくつか知ってる言語では，
参照という概念は何度参照渡ししても，
参照のままです。
 
で，VBA の仕様書を見ても，
参照の引数は実引数のいわゆる別名として扱うことになっています。
別名に何度別名を付けても，それは，実態への別名になります。
 
念のため，
VarPtr で場所を確認してみるとわかります。
 

Private Sub Ref3(ByRef wsh As Worksheet)
    Debug.Print Hex(VarPtr(wsh))
End Sub

Private Sub Ref2(ByRef wsh As Worksheet)
    Debug.Print Hex(VarPtr(wsh))
    Call Ref3(wsh)
End Sub

Private Sub Ref1(ByRef wsh As Worksheet)
    Debug.Print Hex(VarPtr(wsh))
    Call Ref2(wsh)
End Sub

Private Sub CommandButton1_Click()
    Dim wsh As Worksheet
    Set wsh = ActiveSheet
    Debug.Print Hex(VarPtr(wsh))
    Call Ref1(wsh)
End Sub

' 12E2B4
' 12E2B4
' 12E2B4
' 12E2B4

yayadonnさん、情報ありがとうございました。
こちらの事実は知りませんでした。

私は、IT企業とは無縁の会社に勤める、単なる物好き？です。
蓄積も経験もありませんので、とんでもないことを言い出すかも知れませんが、
おつきあいください。
 
--------
yayadonさん、どうもありがとうございます。
 
VBAのコレクション等に共通に使われている、IEnumeratorなどのインターフェイスの
説明をいただきました。
VBAを地面の近くからではなく、少し高いところから俯瞰すると、
見通しがよくなるということなんでしょうね。ありがとうございます。
(kumattiさんの参照された例、難しいですねえ。
 カスタマイズされたコレクションですかあ。）
 
--------
月さんどうもありがとうございます。大変参考になります。
 
提示下さったものについて少し教えて下さい。
(1)
・メンバー（と呼ぶのが適当かよく知りませんが）についてですが、
  email, passwordをメンバーにすることについてはどのように
  お考えですか？
  （initializeに引数を与えられないということと関係するとは思いますが）
・tokenをメンバーにされていますが、プロシージャレベルの変数ではまずいですか？
・クラスというからには、メソッドのみならずそれに使用する要素（属性）も
  含んだほうがいいという考え方もあれば、それにこだわらず、機能のかたまりであれば、
  それでいいという考え方もあるかと思います。
  このあたりについてのお考えをお聞かせください。
(2)
素朴な質問ですみませんが、クラスを使わないで、例えば以下のような
仕組みで実現した場合、例えばカプセル化といった方面から何か違いが
出てきますでしょうか。
GoogleCalendarという標準モジュールにほぼ同様の内容を書いて
    GoogleCalendar.Initialize
    GoogleCalendar.login email, password
    GoogleCalendar.add xml
    MsgBox "OK"
    GoogleCalendar.Terminate
などとする場合です。
（もちろん、こうすべきなどと言っているわけでは無く、考えの整理のため
  教えて欲しいのです。）
一応、名前空間を別にするという意味では成功しているわけですけど。

kumattiさん。ご参加ありがとうございます。（ご無沙汰しております^^）
yayadonさん。有益な情報ありがとうございます。
simpleさんの問題の提起の仕方！さすがですね。
 
コレクションのお話が出ていますので、私の方からもお１つ。
 
コレクションクラスを作成出来なかった当時、私のクラスの使い方というのは
とてもひどいもので、１つのクラスを無数にインスタンシングしては管理はいったいどうしたら
いいのか？と疑問にぶち当たり行き詰っておりました。
別サイトですが「コレクションクラスを作成しては？」と藤代千尋さん（VB板ではとても
有名な方ですね）からご指導を頂き「コレクションクラス」が何とか作成出来る様になりました。
 
コレクションクラスが見よう見真似で作成出来る様になると、私のコーディングの幅がぐっと
広がりました^^
 

引用:

・4つのクラスを使って作成した視覚的にグループ分けが出来るクラス
　ListBox間のItem交換をイメージしたクラスで、コンテナやアイテムをLabelで作成し
　コンテナにアイテムをドラッグして移動するとアイテムがコンテナに吸い込まれ自動
　で整列します。
  MaxItemCountプロパティを実装しコンテナ内のアイテム数が指定数を上回ると
　アイテムが自動的に元の位置に戻る機能なんかも付けました。

　
clsMoveItems ←→ 協調関係（互いに存在しないと動作しない） ←→ clsContainers
    ↑                                                              ↑
　親子関係                                                       親子関係
    ↓                                                              ↓
clsMoveItem                                                     clsContainer

Option Explicit
Private mMoveItems                As clsMoveItems
Private WithEvents mContainers    As clsContainers
Private WithEvents mCommandButton As MSForms.CommandButton
Private mTextBox                  As MSForms.TextBox
Private Const cnsTop              As Single = 30

Private Sub UserForm_Initialize()

    Dim ctl       As Control
    Dim i         As Long
    Dim Container As MSForms.Label
    Dim Item      As MSForms.Label
        
        With Me
            .Width = 640
            .Height = 320
        End With
        
        ''コンテナのコレクションクラス作成
        Set mContainers = New clsContainers
        ''コンテナの作成
        With mContainers
            .CreateContainer Me, "Moug", 20, cnsTop, 100, 140
            .CreateContainer Me, "Excel", 170, cnsTop, 100, 140
            .CreateContainer Me, "Access", 320, cnsTop, 100, 140
            .CreateContainer Me, "Word", 470, cnsTop, 100, 140
        End With
        
        With mContainers("Moug")
            .Value = "モーグ"
            .CreateTitle "Moug"
        End With
        
        With mContainers("Excel")
            .Value = "Excel"
            .CreateTitle "ExcelVBA講座"
            .MaxItemCount = 3
        End With
        
        With mContainers("Access")
            .Value = "Access"
            .CreateTitle "AccessVBA講座"
            .MaxItemCount = 6
        End With
        
        With mContainers("Word")
            .Value = "Word"
            .CreateTitle "WordVBA講座"
            .MaxItemCount = 3
        End With
            
        ''アイテムのコレクションクラス作成
        Set mMoveItems = New clsMoveItems
        Set mMoveItems.Containers = mContainers
        
        ''アイテムの作成
        Dim vntName
        Dim Member
        
        Member = Array("yayadonさん", "ろひさん", "simpleさん", _
                  "月さん", "ゴマさん", "kumattiさん", "YU-TANGさん", _
                  "Kanabunさん", "Abyssさん", "みそじのおじさん")
                
        For Each vntName In Member
            Set Item = Me.Controls.Add("Forms.Label.1", "Label" & vntName, True)
            With Item
                .Height = 20
                .Width = 70
                .Caption = vntName
            End With
            
            mMoveItems.Add Item, Me
            mMoveItems(Item.Name).Value = vntName
            mContainers("Moug").AddItem mMoveItems(Item.Name)
        Next
        
        
        ''コマンドボタンの作成
        Set mCommandButton = Me.Controls.Add("Forms.CommandButton.1", _
                                             "myCommandButton", True)
        With mCommandButton
            .Left = 20
            .Top = 140
            .Height = 20
            .Width = 50
            .Caption = "決定"
        End With
        
        ''グループ分け結果の表示用テキストボックス作成
        Set mTextBox = Me.Controls.Add("Forms.TextBox.1", "myTextBox", True)
        With mTextBox
            .Left = 80
            .Top = 160
            .Height = 120
            .SpecialEffect = fmSpecialEffectEtched
            .Width = 140
            .MultiLine = True
        End With
        
        ''見出しのラベル作成
        Set Item = Me.Controls.Add("Forms.Label.1", "lbl1", True)
        With Item
            .Left = 80
            .Top = 140
            .Height = 20
            .SpecialEffect = fmSpecialEffectEtched
            .Width = 140
            .Caption = "グループ分け結果"
            .TextAlign = fmTextAlignCenter
        End With
        
End Sub
Private Sub mCommandButton_Click()

    Dim ContainerItems  As Collection
    Dim ContainerItem   As clsContainer
    Dim MoveItems       As Collection
    Dim MoveItem        As clsMoveItem
    Dim v()             As Variant
    Dim i               As Long
    
        Set ContainerItems = mContainers.Items
        For Each ContainerItem In ContainerItems
            For Each MoveItem In ContainerItem.Items
                ReDim Preserve v(i)
                v(i) = ContainerItem.Value & vbTab & MoveItem.Value
                i = i + 1
            Next
        Next
        
        mTextBox.Text = Join(v, vbCrLf)
End Sub

Private Sub mContainers_MaxItemCountOver(ByVal AlertContainer As clsContainer, _
                                         ByVal MaxItemCount As Long)
    MsgBox AlertContainer.Title & "の最大定員は、" & MaxItemCount & "名です。", vbExclamation

End Sub

Private Sub UserForm_Terminate()
    mMoveItems.Tearm
    mContainers.Term
    Set mMoveItems = Nothing
    Set mContainers = Nothing
End Sub

Option Explicit
'***************************************************
'クラス名 clsContainers
'***************************************************
Public Event MaxItemCountOver(ByVal AlertContainer As clsContainer, _
                              ByVal MaxItemCount As Long)
Private mContainerItems As Collection

Private Sub Class_Initialize()
    Set mContainerItems = New Collection
End Sub
Public Sub Term()
    Dim Container As clsContainer
        
        For Each Container In mContainerItems
            Container.Team
        Next
        
        Set mContainerItems = Nothing
End Sub
Private Sub Class_Terminate()
    'Debug.Print "clsContainers_Term!"
End Sub
Public Function Add(ByVal NewContainerItem As MSForms.Label) As Boolean

    Dim ContainerItem As clsContainer
    
        Set ContainerItem = New clsContainer
        mContainerItems.Add ContainerItem.Init(NewContainerItem, Me), _
                            CStr(NewContainerItem.Name)
        
End Function
Public Function CreateContainer(ByVal Parent As Object, _
                                ByVal ContainerName As String, _
                                ByVal Left As Single, _
                                ByVal Top As Single, _
                                ByVal Height As Single, _
                                ByVal Width As Single) As Boolean
                                
    Dim ContainerItem As clsContainer
    Dim CreateContainerLabel As MSForms.Label
    
        Set ContainerItem = New clsContainer
        Set CreateContainerLabel = Parent.Controls.Add _
                                ("Forms.Label.1", ContainerName, True)
        
        With CreateContainerLabel
            .Left = Left
            .Top = Top
            .Height = Height
            .Width = Width
            .SpecialEffect = fmSpecialEffectEtched
        End With
        mContainerItems.Add ContainerItem.Init(CreateContainerLabel, Me), _
                                               CStr(CreateContainerLabel.Name)
    
End Function
Public Property Get Items() As Collection
    Set Items = mContainerItems
End Property
Public Property Get Item(ByVal Index As Variant) As clsContainer
    On Error GoTo Err_Trap:
         Select Case TypeName(Index)
             Case "Long", "Integer"
                  'CollectionのLBoundは1の為+1
                  Set Item = mContainerItems(CLng(Index) + 1&)
             Case "String"
                  'フィールド名でアクセス
                  Set Item = mContainerItems(Index)
         End Select
      On Error GoTo 0
Err_Trap:
End Property

Public Sub Alert(ByVal c As clsContainer)
    RaiseEvent MaxItemCountOver(c, c.MaxItemCount)
End Sub

Public Sub OverLapEffect(ByVal TargetContainer As clsContainer)
    Dim Container As clsContainer
        
        For Each Container In mContainerItems
            If TargetContainer Is Container Then
                Container.OverLapEffect
            Else
                Container.UndoOverLapEffect
            End If
        Next
End Sub

Public Sub UndoOverLapEffect()
    Dim Container As clsContainer
        
        For Each Container In mContainerItems
            Container.UndoOverLapEffect
        Next
End Sub

Option Explicit
'***************************************************
'クラス名 clsContainer
'***************************************************

Private mContainer             As MSForms.Label
Private mTitleLabel            As MSForms.Label
Private mItems                 As Collection
Private mItemPositions         As Collection
Private mParent                As clsContainers
Private mValue                 As Variant
Private mMaxItemCount          As Long
Private mMaxCountCheck         As Boolean
Private mTitle                 As String
Private mTitleForeColor        As Long
Private mTitleBackColor        As Long
Private mContainerForeColor    As Long
Private mContainerBackColor    As Long

Private Const cnsTitleHeight        As Single = 18
Private Const cnsTitleForeColor     As Long = vbWhite
Private Const cnsTitleBackColor     As Long = &H800000
Private Const cnsContainerForeColor As Long = vbBlue
Private Const cnsContainerBackColor As Long = vbWhite

Public Function Init(ByVal NewContainer As MSForms.Label, _
                     ByVal NewParent As clsContainers)
                     
    Set mContainer = NewContainer
        With mContainer
            .BackColor = cnsContainerBackColor
            .SpecialEffect = fmSpecialEffectEtched
        End With
    Set mParent = NewParent
    Set Init = Me
    
End Function

Private Sub Class_Initialize()

    Set mItems = New Collection
    Set mItemPositions = New Collection
    
    mMaxCountCheck = False
    mTitleForeColor = cnsTitleForeColor
    mTitleBackColor = cnsTitleBackColor
End Sub

Private Sub Class_Terminate()
    Set mContainer = Nothing
    Set mTitleLabel = Nothing
End Sub
Public Sub Team()
    Dim MoveItem As clsMoveItem
        For Each MoveItem In mItems
            MoveItem.Term
        Next
        Set mItems = Nothing
        Set mParent = Nothing
End Sub
Public Function CreateTitle(ByVal NewTitle As String) As Boolean

    If Not mTitleLabel Is Nothing Then Exit Function
    
    Set mTitleLabel = mContainer.Parent.Controls.Add _
                        ("Forms.Label.1", "Label" & Title, True)
    
    With mTitleLabel
        .Left = mContainer.Left
        .Top = mContainer.Top - cnsTitleHeight
        .Height = cnsTitleHeight
        .Width = mContainer.Width
        .SpecialEffect = fmSpecialEffectEtched
        .ForeColor = mTitleForeColor
        .BackColor = mTitleBackColor
        .TextAlign = fmTextAlignCenter
        .Font.Bold = True
         Title = NewTitle
    End With
    
End Function
Public Property Get Title() As String
    Title = mTitle
End Property
Public Property Let Title(ByVal NewTitle As String)
    mTitle = NewTitle
    If Not mTitleLabel Is Nothing Then
        mTitleLabel.Caption = mTitle
    End If
End Property

Public Property Get ItemPositions() As Collection
    Set ItemPositions = mItemPositions
End Property

Property Get ContainerRect() As Rect
    With mContainer
        ContainerRect.Left = .Left
        ContainerRect.Top = .Top
        ContainerRect.Width = .Width
        ContainerRect.Height = .Height
    End With
End Property
Public Function AddItem(ByVal tItem As clsMoveItem) As MoveItemAddResultEnum
    
    Dim Item As clsMoveItem
    
        If Not IsInCollection(tItem) Then
            If (MaxItemCount >= ItemCount + 1) Or (Not mMaxCountCheck) Then
                Call ItemMove(tItem)
                mItems.Add tItem, CStr(tItem.Name)
                With tItem.ItemRect
                    mItemPositions.Add Array(.Left, .Top, .Width, .Height, _
                                            CStr(tItem.Name)), CStr(tItem.Name)
                End With
                AddItem = MoveItemAddOk
            Else
                mParent.Alert Me
                AddItem = MoveItemMaxCountOver
            End If
        Else
            Set mItemPositions = Nothing
            Set mItemPositions = New Collection
            For Each Item In Me.Items
                With Item.OldPositionRect
                    mItemPositions.Add Array(.Left, .Top, .Width, .Height, _
                                            CStr(Item.Name)), CStr(Item.Name)
                End With
            Next
            Call ItemMoveAnchor(tItem, mItemPositions(CStr(tItem.Name)))
            AddItem = MoveItemAlreadyAdd
        End If
End Function

Public Sub RemoveItem(ByVal rItem As clsMoveItem)
    If IsInCollection(rItem) Then
        mItems.Remove CStr(rItem.Name)
        mItemPositions.Remove CStr(rItem.Name)
        AllItemMove
    End If
End Sub
Private Sub AllItemMove()

    Dim Item As clsMoveItem
    Dim t As Single, lw As Single
    Dim Ih As Single, Iw As Single
    Dim OldRect As Rect
    Dim NewRect As Rect
    Dim MaxWidth As Single
    Dim SameFg As Boolean
    
        For Each Item In mItems
            OldRect = Item.ItemRect
            Iw = Item.ItemRect.Width
            
            If MaxWidth < Iw Then
                MaxWidth = Iw
            End If
            
            If t + OldRect.Height > mContainer.Height Then
                t = 0
                lw = lw + MaxWidth
                MaxWidth = 0
            End If
            
            With NewRect
                .Left = mContainer.Left + lw
                .Top = mContainer.Top + t
                .Width = OldRect.Width
                .Height = OldRect.Height
            End With
            
            Item.ItemRect = NewRect
            t = t + OldRect.Height
           
        Next
        
End Sub
Private Sub ItemMove(ByVal MoveItem As clsMoveItem)

    Dim Item As clsMoveItem
    Dim t As Single, lw As Single
    Dim Ih As Single, Iw As Single
    Dim OldRect As Rect
    Dim NewRect As Rect
    Dim MaxWidth As Single
       
        OldRect = MoveItem.ItemRect
        
        For Each Item In mItems
        
            Ih = Item.ItemRect.Height
            Iw = Item.ItemRect.Width
            t = t + Ih
            If MaxWidth < Iw Then
                MaxWidth = Iw
            End If
            
            If t + Ih > mContainer.Height Then
                t = 0
                lw = lw + MaxWidth
                MaxWidth = 0
            End If
        Next
        
        With NewRect
            .Left = mContainer.Left + lw
            .Top = mContainer.Top + t
            .Width = OldRect.Width
            .Height = OldRect.Height
        End With
        
        MoveItem.ItemRect = NewRect
        
End Sub
Private Sub ItemMoveAnchor(ByVal MoveItem As clsMoveItem, _
                           RectArray As Variant)
                           
    Dim DefaultRect As Rect
    
        With DefaultRect
            .Left = RectArray(0)
            .Top = RectArray(1)
            .Width = RectArray(2)
            .Height = RectArray(3)
        End With
        MoveItem.ItemRect = DefaultRect
    
End Sub
Private Function IsInCollection(ByVal Item As clsMoveItem) As Boolean
    
    Dim obj As clsMoveItem
    
        IsInCollection = False
        
        For Each obj In mItems
            If obj Is Item Then
                IsInCollection = True
                Exit For
            End If
        Next
End Function
Property Get Value() As Variant
    Value = mValue
End Property
Property Let Value(ByVal NewValue As Variant)
    mValue = NewValue
End Property
Property Get Name() As Variant
    Name = mContainer.Name
End Property
Property Get Items() As Collection
    Set Items = mItems
End Property
Property Get ItemCount() As Long
    ItemCount = 0
    If mItems Is Nothing Then Exit Property
    ItemCount = mItems.Count
End Property
Property Get MaxItemCount() As Long
    MaxItemCount = mMaxItemCount
End Property
Property Let MaxItemCount(ByVal NewMaxCount As Long)
    If NewMaxCount < 0 Then
        MsgBox "MaxItemCountniに設定できるのは0以上です。", vbCritical
        Exit Property
    End If
    mMaxItemCount = NewMaxCount
    MaxCountCheck = True
End Property

Public Property Get MaxCountCheck() As Boolean
    MaxCountCheck = mMaxCountCheck
End Property

Public Property Let MaxCountCheck(ByVal blnMaxCountCheck As Boolean)
    mMaxCountCheck = blnMaxCountCheck
End Property

Public Property Get TitleForeColor() As Long
    TitleForeColor = mTitleForeColor
End Property

Public Property Let TitleForeColor(ByVal lngNewColor As Long)
    mTitleForeColor = lngNewColor
    
    If Not mTitleLabel Is Nothing Then
        mTitleLabel.ForeColor = mTitleForeColor
    End If
End Property

Public Property Get TitleBackColor() As Long
    TitleBackColor = mTitleBackColor
End Property

Public Property Let TitleBackColor(ByVal lngNewColor As Long)
    mTitleBackColor = lngNewColor
    
    If Not mTitleLabel Is Nothing Then
        mTitleLabel.BackColor = mTitleBackColor
    End If
End Property

Public Sub OverLapEffect()
    With mContainer
        .BorderStyle = fmBorderStyleSingle
        .BorderColor = vbBlue
    End With
End Sub

Public Sub UndoOverLapEffect()
    With mContainer
        .SpecialEffect = fmSpecialEffectEtched
    End With
End Sub

Option Explicit
'***************************************************
'クラス名 clsMoveItems
'***************************************************
Private mMoveItems      As Collection
Private mFormObject     As Object
Private mContainers     As clsContainers
Public Function Add(ByVal NewMoveItem As MSForms.Label, _
                    ByVal mFormObject As Object) As Boolean
    
    Dim mMoveItem As clsMoveItem
    
        Set mMoveItem = New clsMoveItem
        Set mFormObject = mFormObject
        mMoveItems.Add mMoveItem.Init(NewMoveItem, mFormObject, Me), _
                                      CStr(NewMoveItem.Name)
    
End Function

Private Sub Class_Initialize()
    Set mMoveItems = New Collection
End Sub

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

Public Sub Tearm()
    Dim MoveItem As clsMoveItem
    
        For Each MoveItem In mMoveItems
            MoveItem.Term
        Next
        
        Set mMoveItems = Nothing
        Set mFormObject = Nothing
        Set mContainers = Nothing
End Sub
Property Get Containers() As clsContainers
    Set Containers = mContainers
End Property
Property Set Containers(ByVal NewContainers As clsContainers)
    Set mContainers = NewContainers
End Property
Property Get Item(ByVal Index As Variant) As clsMoveItem
    On Error GoTo Err_Trap:
         Select Case TypeName(Index)
             Case "Long", "Integer"
                  'CollectionのLBoundは1の為+1
                  Set Item = mMoveItems(CLng(Index) + 1&)
             Case "String"
                  'フィールド名でアクセス
                  Set Item = mMoveItems(Index)
         End Select
    On Error GoTo 0
Err_Trap:

End Property

Option Explicit
'***************************************************
'クラス名 clsMoveItem
'***************************************************
Private WithEvents mMoveLabel As MSForms.Label

Private mFormObject  As Object
Private mParent      As clsMoveItems
Private mCapture     As Boolean
Private mValue       As Variant
Private mOldPositionRect As Rect

Private Type StructOffsetValue
    x As Single
    y As Single
End Type

Private o As StructOffsetValue
Private Const cnsItemBackColor As Long = vbWhite
Private Const cnsItemForeColor As Long = vbBlue
Public Function Init(ByVal NewMoveLabel As MSForms.Label, _
                     ByVal NewmFormObject As Object, _
                     ByVal NewParent As clsMoveItems) As clsMoveItem
                     
    Set mMoveLabel = NewMoveLabel
        With mMoveLabel
            .TextAlign = fmTextAlignCenter
            .ForeColor = cnsItemForeColor
            .BackColor = cnsItemBackColor
            .SpecialEffect = fmSpecialEffectEtched
        End With
    Set mFormObject = NewmFormObject
    Set mParent = NewParent
    Set Init = Me
    
End Function
Public Sub Term()
    Set mFormObject = Nothing
    Set mParent = Nothing
    
End Sub
Private Sub Class_Terminate()
    Set mMoveLabel = Nothing
End Sub

Private Sub mMoveLabel_MouseDown(ByVal Button As Integer, _
                                 ByVal Shift As Integer, _
                                 ByVal x As Single, _
                                 ByVal y As Single)
    mCapture = True
    With mMoveLabel
        .SpecialEffect = fmSpecialEffectBump
        .BackColor = vbYellow
    End With
    o.x = x
    o.y = y
    Call OldPositionSet
    
End Sub

Private Sub mMoveLabel_MouseMove(ByVal Button As Integer, _
                                 ByVal Shift As Integer, _
                                 ByVal x As Single, _
                                 ByVal y As Single)
    If mCapture Then
    
        Static p As StructMovePoint
                       
        With mMoveLabel
                       
            If p.x + .Width <= mFormObject.InsideWidth Then
                If p.x >= 0 Then
                    If p.y >= 0 Then
                        If p.y + .Height - o.y <= mFormObject.InsideHeight Then
                            .Left = .Left + x - o.x
                            .Top = .Top + y - o.y
                        Else
                            .Top = mFormObject.InsideHeight - .Height
                        End If
                    Else
                        .Top = 0
                    End If
                Else
                    .Left = 0
                End If
            Else
                .Left = mFormObject.InsideWidth - .Width
            End If
            
            p.x = .Left
            p.y = .Top
            
            .ZOrder 0
            
            Call mParent.Containers.OverLapEffect(OverlapContainer())
            
        End With
    End If
End Sub

Private Sub mMoveLabel_MouseUp(ByVal Button As Integer, _
                               ByVal Shift As Integer, _
                               ByVal x As Single, _
                               ByVal y As Single)
       
    o.x = 0
    o.y = 0
    
    If mCapture Then
        Call PositionCheck
    End If
    
    mCapture = False
    
    With mMoveLabel
        .SpecialEffect = fmSpecialEffectEtched
        .BackColor = cnsItemBackColor
    End With
    
    Call mParent.Containers.UndoOverLapEffect
    
End Sub

Public Sub PositionCheck()
    
    Dim Containers As clsContainers
    Dim Container  As clsContainer
    Dim ret        As MoveItemAddResultEnum
    Dim tContainer As clsContainer
    Dim Area As Long, MaxArea As Long
    Dim ConItems As Collection
    
        Set Containers = mParent.Containers
        
        Set tContainer = OverlapContainer()
       
        Set ConItems = New Collection
        If Not tContainer Is Nothing Then
            ConItems.Add tContainer
        End If
        
        For Each Container In Containers.Items
            If Not Container Is tContainer Then
                ConItems.Add Container
            End If
        Next
               
        For Each Container In ConItems
            If OverLapArea(Container.ContainerRect) > 0 Then
                ret = Container.AddItem(Me)
                
                Select Case ret
                    Case MoveItemMaxCountOver
                        ItemRect = OldPositionRect()
                    Case Else
                End Select
            Else
                Container.RemoveItem Me
            End If
        Next
        
        Set ConItems = Nothing
        Call OldPositionSet
    
End Sub

Private Function OverlapContainer() As clsContainer
    Dim Containers As clsContainers
    Dim Container  As clsContainer
    Dim Area As Long, MaxArea As Long
    
        Set Containers = mParent.Containers
        
        ''重なっている領域が最大のコンテナを取得
        For Each Container In Containers.Items
                       
            Area = OverLapArea(Container.ContainerRect)
            If Area > MaxArea Then
                Set OverlapContainer = Container
                MaxArea = Area
            End If
            
        Next
        
End Function

Private Function OverLapArea(ContainerRect As Rect) As Long
    
    Dim lngMoveItem  As Long
    Dim MoveItemRect As Rect
    Dim ConRect As Rect
    Dim lngRet  As Long
    Dim InRect  As Rect
    Dim mRect   As Rect
    
        MoveItemRect = ItemRect()
        With MoveItemRect
            mRect.Left = .Left
            mRect.Top = .Top
            mRect.Width = .Left + .Width
            mRect.Height = .Top + .Height
        End With
        
        ConRect = ContainerRect
        With ConRect
            .Left = .Left
            .Top = .Top
            .Width = .Left + .Width
            .Height = .Top + .Height
        End With
            
        lngRet = IntersectRect(InRect, mRect, ConRect)
        With InRect
            OverLapArea = (.Width - .Left) * (.Height - .Top)
        End With
    
End Function

Property Get OldPositionRect() As Rect
    OldPositionRect = mOldPositionRect
End Property

Private Sub OldPositionSet()
    With mMoveLabel
        mOldPositionRect.Left = .Left
        mOldPositionRect.Top = .Top
        mOldPositionRect.Width = .Width
        mOldPositionRect.Height = .Height
    End With
End Sub

Property Get ItemRect() As Rect
    With mMoveLabel
        ItemRect.Left = .Left
        ItemRect.Top = .Top
        ItemRect.Width = .Width
        ItemRect.Height = .Height
    End With
End Property

Property Let ItemRect(NewRect As Rect)
    With mMoveLabel
         .Left = NewRect.Left
         .Top = NewRect.Top
         .Width = NewRect.Width
         .Height = NewRect.Height
    End With
    Call OldPositionSet
End Property

Property Get Name() As String
    Name = mMoveLabel.Name
End Property

Property Get Value() As Variant
    Value = mValue
End Property

Property Let Value(ByVal NewValue As Variant)
    mValue = NewValue
End Property

Option Explicit

Public Type StructMovePoint
    x As Single
    y As Single
End Type

Public Type Rect
    Left As Long
    Top  As Long
    Width As Long
    Height As Long
End Type

Public Declare Function CreateRectRgn Lib "gdi32.dll" _
                                (ByVal nLeft As Long, _
                                 ByVal nTop As Long, _
                                 ByVal nRight As Long, _
                                 ByVal nBotomm As Long) As Long

Public Declare Function RectInRegion Lib "gdi32.dll" _
                                (ByVal hrgn As Long, _
                                 lprc As Rect) As Long

Public Declare Function IntersectRect Lib "user32" _
                                (lpDestRc As Rect, _
                                 lprc1 As Rect, _
                                 lprc2 As Rect) As Long
    
Public Enum MoveItemAddResultEnum
    MoveItemNotAdd = 0
    MoveItemAddOk = 1
    MoveItemAlreadyAdd = 2
    MoveItemMaxCountOver = 3
End Enum

こんばんは、YU-TANG です。
 
呼ばれたようなので、お邪魔します。
 

みそじのおじさん さんの引用:
まずは、言いだしっぺの私から勉強の為に作成した上記のクラスを提示してみます。
ご感想や、改善点など頂けると幸いです

月 さんの引用:
とりあえずインスタンス作成時に引数を渡したいですね。

みそじのおじさん さんの引用:
・こんなクラスを使っています！

simpleさん、ご質問ありがとうございます。
 

simple さんの引用:
・メンバー（と呼ぶのが適当かよく知りませんが）についてですが、
  email, passwordをメンバーにすることについてはどのように
  お考えですか？

simple さんの引用:
・tokenをメンバーにされていますが、プロシージャレベルの変数ではまずいですか？

simple さんの引用:
・クラスというからには、メソッドのみならずそれに使用する要素（属性）も
  含んだほうがいいという考え方もあれば、それにこだわらず、機能のかたまりであれば、
  それでいいという考え方もあるかと思います。
  このあたりについてのお考えをお聞かせください。

こんにちは。
 
みそじのおじさん さんのコードを試してみたところ、エラーが出ました。
 
UserFormモジュールの
With mContainers("Moug")
同じく、mContainersのExcel、Access、Wordを指定しているところと、
 
mMoveItems(Item.Name).Value = vntName
mContainers("Moug").AddItem mMoveItems(Item.Name)
 
で、おそらくデフォルトプロパティが設定されてないせいかと思い、
clsContainersクラスと、clsMoveItemsクラスの
Items、ItemをProperty Getしているところに、
Attribute Value.VB_UserMemId = 0
を指定して、インポートしなおしたところ、エラーが解消されました。
 
WinXP、Excel2000で試しました。

simple さんの引用:
素朴な質問ですみませんが、クラスを使わないで、例えば以下のような
仕組みで実現した場合、例えばカプセル化といった方面から何か違いが
出てきますでしょうか。
GoogleCalendarという標準モジュールにほぼ同様の内容を書いて
    GoogleCalendar.Initialize
    GoogleCalendar.login email, password
    GoogleCalendar.add xml
    MsgBox "OK"
    GoogleCalendar.Terminate
などとする場合です。
（もちろん、こうすべきなどと言っているわけでは無く、考えの整理のため
  教えて欲しいのです。）
一応、名前空間を別にするという意味では成功しているわけですけど。

Option Explicit

' GoogleCalendarモジュール

Public Sub Initialize()
    
End Sub

Public Sub login()
    
End Sub

Public Sub add()
    
End Sub

Public Sub Terminate()
    
End Sub

' Module1モジュール
Public Sub login()

End Sub

' Module2モジュール
Sub test()
    login
End Sub

YU-TANG さんの引用:
あと Google カレンダーの操作クラスもあったんですが、HDD と共にお亡くなりになりました。生きていれば月さんのクラスと対戦できたんですが…。

先ほどのみそじのおじさん さんのコードのエラーの対策ですが、
メモ帳でAttribute Value.VB_UserMemId = 0
指定してインポートしなおすなんてことせずとも、
 
With mContainers.Items("Moug")
や、
mMoveItems.Item(Item.Name).Value = vntName
mContainers.Items("Moug").AddItem mMoveItems.Item(Item.Name)
としてもエラーにはなりませんでした。
プロパティは省略しないって事でしょうか。
 
 
エラーメッセージを書き忘れてた。
実行時エラー'438':
オブジェクトは、このプロパティまたはメソッドをサポートしていません。
 
でした。

ちび坊主さんが仰るようにプロパティを省略しないようにして試しました。
すごーいの一言です。

みそじのおじさんへ。
 
ぱっと目に付いたところだけコメントします。
 
UserForm1クラス

For Each vntName In Member

mMoveItems.Add Item, Me
mMoveItems.Item(Item.Name).Value = vntName
mContainers.Items("Moug").AddItem mMoveItems.Item(Item.Name)

メソッドチェーンをご存知ですか？
 
メソッドの戻り値として自分を返すことで、続けてメソッドを記述できるようにする方法のことです。こんなのもあるよ、ということで紹介します。
 
VBAでメソッドチェーンの例 ― Gist
https://gist.github.com/1956111

みそじのおじさん さんへ
 
コードを修正して動かしてみました。
マウス ポインタではなく
これは，指で移動させたくなりました(笑)。
VBA の UI っぽくなくて新鮮ですね。
というか，エフェクトのかかり方が違うだけで，
Metro 先取りって感じです。
　
　

今iPhoneでみそじのおじさんのコード読み中。幅がなくてつらい。
 
まだ読み始めですが、こういう階層はどうです？
既になってたらごめんなさい。
 
clsContainers コンテナのコレクションクラス
↓
clsContainer　アイテムを収容するコンテナ
↓
clsMoveItems　アイテムのコレクションクラス
↓
clsMoveItem アイテム

もっと言うと、clsContainers コンテナのコレクションクラス は、ユーザーフォームのプロパティにしたいですね。そうすればMeを渡さなくて済むのでは。

余談ですが、私がAccess VBAで画面がある物を作っていた時も、フォームのメンバとして実装していましたね。親フォームと子フォームという状況があって、フォーム同士でデータか何かをやりとりすることがよくあったんですが、そういう時に相手のメンバを呼び出すということです。

CreateContainerメソッド、名前が冗長ですかね。AddとかCreateでいいのでは。

clsMoveItems　アイテムのコレクションクラス は、clsContainer　アイテムを収容するコンテナ のインスタンス作成時にNewして、プロパティとして公開
 
メモを兼ねて思いつくまま書いてます。

CreateContainerメソッドとは別にAddメソッドもあるんですね。どっちかいらなくないですか？
 
MaxItemCountOverイベントを定義するのはclsContainersじゃなくてclsContainerじゃないですかね。
 
コメントはこれくらいにして、あとでいじってみますね。

遅くなりました。申し訳ありません。
沢山の反響に驚いています^^
 
先に、みなさんにお詫びです。
ちび坊主さん、指摘ありがとうございます。昼間の返信が出来ない為大変助かりました。
オブジェクトブラウザで確認しましたらItemに規定のプロパティのマーク（水色の○）が
ありましたので、２つのクラスをエクスポートして確認したところ
Attribute Feilds.VB_UserMemId = 0　がありました。
Property Get Itemを規定のプロパティにしておりました。大変申し訳ありません。
このクラスの大枠は数ヶ月前に作成してあった為、規定のプロパティを設定した事を
すっかり忘れていました。大変申し訳ありません。
 
これから試される方がおられるとまずいので、規定のプロパティの作成方法を一応書いておきます。
 
clsContainersとclsMoveItemsを一度エクスポートします。エクスポート後に２つのクラスを
解放して下さい。
 
エクスポートしたファイルをメモ帳などで開きます。
clsContainersは
Public Property Get Item(ByVal Index As Variant) As clsContainer
Attribute Feilds.VB_UserMemId = 0 'この行を追加し上書き保存します。
 
clsMoveItemsも
Property Get Item(ByVal Index As Variant) As clsMoveItem
Attribute Feilds.VB_UserMemId = 0 'この行を追加し上書き保存します。
 
メモ帳での作業が終わったら２つのクラスをVBEにインポートします。
 
これで２つのクラスの規定のプロパティがItemになります。
規定のプロパティはオブジェクトブラウザで水色の丸印が付き確認できます。
 
 
▽YU-TANGさん
ご参加ありがとうございます。
YU-TANGさんに「Implements」のご紹介を受けてからコツコツと勉強してきましたが
まだまだ私のレベルは「クラス初級者」から抜け出せません^^;
YU-TANGさんのHPはTipsから公開しているクラスまでくまなく拝見させて頂いております。
ありがとうございます。
（Accessで困ったら、YU-TANGさんかhatenaさんの所へ行けば何とかなる！と思っていますし
実際何とかなっています（笑））
   
引き続きご参加よろしくお願い致します。
 
▽ちび坊主さん
ご参加ありがとうございます。
私は、画像処理関係でちび坊主さんの右にでる方はいないのでは？と思っています^^
「画像処理関係のクラスを沢山お持ちなんだろうな」と勝手に想像しておりました。
よろしかったら是非ご紹介して下さい。
 
▽yayadonさん
突っ込み所は満載なのですが、やさしい目線でのご感想ありがとうございます（笑）
美的センスには自身がないのですが、Metroですか^^ありがとうございます。
 
引き続きご参加お願い致します。
 
▽月さん
細かく見て頂きありがとうございます。ソースにコメントを付けておらず大変見づらいと
思います。ご負担をかけてしまい申し訳ありません。
一人でやっていると「良いのか、悪いのか」分らなくなってきますので
こういった指摘が大変参考になります。ありがとうございます。
ご指摘の内容をもっと精査してからコメントしたいと思います。
 
それではみなさま引き続きよろしくお願い致します。
 
 
 
 
 
 
 

すごいソースが提示されまして、インパクトがありすぎますね。
これからよく見てみたいと思います。
 
月さん、コメントいただき、ありがとうございました。
全般にご指摘のとおりです。
 
(email, passwordをメンバーにすることについて）
>必要ないと思っています。
これは関数的な構成にしているということですね。
なお、
>特にpasswordについてはやっちゃマズイだろうと思っています。
>予期せず漏れたりしたら大変なので。
>Excelファイルもパスワードを設定できますが、取得できませんよね。
インスタンスを Newで作成したあと、
  GoogleCalendar.Init email, password
などとして、m_email, m_password に値をセットし、
password には getterを定義しないなどということは、
よく見られる方法かと思います。
 
> クラスから見て考えるのではなく、散らばったものをまとめたものが
> クラスだと思っています。
おっしゃるとおりだと思います。
( Ruby言語なんかでは、機能だけを集めたものをModuleという機構を使って
  構成することがあります。これに似た感じですね。
  Moduleはインスタンス作成能力はありません。
  includeしてその機能を使うことになります。
  ClassクラスはModuleクラスのサブクラスなので、「クラスは、モジュールに
  インスタンス作成能力を追加したもの」と考えることができます。
  Classのなかに、Moduleをincludeすることで、多重継承と同様な機能を
  果たすことが可能です。
  まったく別言語の話を持ち出して何を言いたかったかというと、
  「クラス」という考え方は、ご指摘の通り、広い概念ととらえて良いのだ、
  ということでした。）
 
後半のカプセル化のお話は、ご指摘のおかげで差異が明確に整理できました。
ありがとうございます。

# 上級者の方々がコメントされていまして、大して言える事もないのですが。
 
私の方は、動作確認されたコードを張り付けているのだから、
「Attribute文絡みで動かないのかな」で止まっていました。
 
相当、昔のスレッドを見ると井川さんが、VBAでも使える事を見付けた(広めた)印象を受けます。
(shiraさんがビックリされてたのを、覚えています)
 
yayadonさんの言われるタッチ関連のAPIは、Windows7にはありますので、
理屈上はVBAでも出来るのではと。
http://wlog.flatlib.jp/item/1320

> 井川さんが、VBAでも使える事を見付けた(広めた)印象を受けます。
 
否定はしませんが、それ以前に「Microsoft Excel MVP」の人、Stephen Bullen氏より
レポートが有ったような。それに、VB6が手元にあれば、Class Attributeはウィザードで
付けられますし。

引用:
# お名前を勝手に上げさせてもらい申し訳ありません。このスレッドへのお誘いの意味も
# 含めております^^

.., ByVal NewmFormObject As Object,...

またまたお詫びです^^;
一行追加して下さいと書きました、
Attribute Feilds.VB_UserMemId = 0
が思いっきり間違っていました。大変失礼しました。
正しくは
Attribute Item.VB_UserMemId = 0
です。
もう一度正しい手順を書いておきます。
 

clsContainersとclsMoveItemsを一度エクスポートします。エクスポート後に２つのクラスを 
解放して下さい。 
 
エクスポートしたファイルをメモ帳などで開きます。 
clsContainersは 
Public Property Get Item(ByVal Index As Variant) As clsContainer 
Attribute Item.VB_UserMemId = 0 'この行を追加し上書き保存します。 
 
clsMoveItemsも 
Property Get Item(ByVal Index As Variant) As clsMoveItem 
Attribute Item.VB_UserMemId = 0 'この行を追加し上書き保存します。 
 
メモ帳での作業が終わったら２つのクラスをVBEにインポートします。 
 
これで２つのクラスの規定のプロパティがItemになります。 
規定のプロパティはオブジェクトブラウザで水色の丸印が付き確認できます。 

みそじのおじさん さんの引用:
月さん。まだ内容の精査中です。申し訳ありません。

コードをざっと見てみました。
やっぱり人のコードを読むのって大変ですね。
 
この独特の雰囲気は，
全部ラベルでやってるからなんですね。
 
話はそれるんですが，
Metro は，WinRT と呼ばれているAPIを使って作ります。
UI を作る部分が XAML と呼ばれているものになります。
現在あるものだと WPF がそれとほぼ同等の役割のものになります。
 
その XAML or WPF では，
ListBox や ListView や GridView というような
あらかじめ繰り返す機能が付いているものでなくても
Panel と呼ばれているものの系統(WrapPanel等)で，
要素を繰り返し表示することが可能なんですが，
それと感じが似てます。
 
 
# 自分は VBA のクラスをここまで活用していないので，
# つまり，ここまでのクラスの活用の実際のノウハウがわかっていないので，
# 以下，なんとなく "今" 思ったことで，こうした方が良いということではないです。
-----
 
Term メソッドがあるのは，循環参照の弊害のためだと思うのですが，
例えば，以下にいくつかあげるような仕組みを入れれば，
循環参照をやめれて，そのメソッドを廃止できるかもしれません。
(でも，できないかもしれません。)
 
 
コレクション側の方が，扱っているクラスより
必ず寿命が長いハズなので，
クラスが，メンバとして，コレクションへの参照を保持しているところは，
例外的に，弱参照※としてもっておくことがいいような気がします。
※ COM仕様上?の back-pointers での AddRef 例外
 
VBA で弱参照を表現するには，
ObjPtr() で値をとって，それを Long 型の変数に入れておいて，
利用時は，Object型 に一度入れてから使う感じにすることで，
それを表現できます。
 
以前，
http://www.moug.net/faq/viewtopic.php?t=61598
で，Abyssさん が String型 で
MoveMemory を使ってやっていたのと，
理屈は，似たような感じでやります。
 
大抵の場合，
クラス内の数か所で使うことになるでしょうから，
単なる仮想ポインタのアドレス値をオブジェクト参照に変える関数を
(クラス内部に)あらかじめ作っておくことになります。
 
例えば，
 

Private Declare Sub MoveMemory Lib "Kernel32" Alias "RtlMoveMemory" _
    (Destination As Any, Source As Any, ByVal Length As Long)
''-----
'' 引数 vptr は，ObjPtr関数で取得して保持しておいたLong値
Private Function GetTarget(ByVal vptr As Long) As Object    ' or 固有オブジェクト型
    Dim tmp As Object               ' or 固有オブジェクト型
    MoveMemory tmp, vptr, 4&        ' 値を入れるだけなので AddRef されない
    Set GetTarget = tmp             ' この時に AddRef されます。意味的には強参照化。
    MoveMemory tmp, 0&, 4&          ' 自動的に Release されないように 0 にしておく
End Function

'' target は，出力パラメータ
Private Function TryGetTarget(ByVal vptr As Long, target As Object) As Boolean
On Error Goto ErrHandler
    'TryGetTarget = False
    Dim tmp As Object
    MoveMemory tmp, vptr, 4&
    Set target = tmp
    MoveMemory tmp, 0&, 4&
    TryGetTarget = True
ExitHandler:
    Exit Function
ErrHandler:
    'MsgBox ...
    'Resume ExitHandler
End Function

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

Private m_vptr As Long

Public Sub SetTarget(target As Object)
    m_vptr = ObjPtr(target)
End Sub

Public Function GetTarget() As Object
    Dim tmp As Object
    MoveMemory tmp, m_vptr, 4&
    Set GetTarget = tmp
    MoveMemory tmp, 0&, 4&
End Function

Abyss さんの引用:
それ以前に「Microsoft Excel MVP」の人、Stephen Bullen氏より
レポートが有ったような。

みなさん。おはようございます。
 
▽月さん
お気使いありがとうございます。
月さんがコメントして下さった事に一つ一つにはすぐに表面上のコメントは出来るのですが、
そうしたくない自分がいまして、、簡単にお返事をしたいくないといいますか、、
「こんなに細かく見て頂いていて貰っているいるアドバイス。こんなチャンスは滅多にない。
しっかり考えてから返答しなければ」と思っているのです^^
 
・クラス同士の関係について
　作った自分が良いのか悪いのか判断できていない。言われてはじめて「なるほど！そういった階層の
　方が自然なのか！」
　
・Eventの定義はclsContainersではなくてclsContainerではないか
　clsContainerがRaiseEventするとUserForm側ではそのイベントをどうキャッチするのか？
（現在の作りでは、UserForm側で複数あるclsContainerをWithEvents定義が出来ない。）
 
等々、色々考えていまして頭が沸騰しております^^（若干脳みそが溶け始めた気が、、）
 
▽yayadonさん
「弱参照」とは強烈なキーワードですね！初めて聞きました。
Termメソッドはおっしゃる通り循環参照を解き放つ為に作成したものです。
 
「弱参照」という手法を私が手に入れる事が出来れば、引き渡す引数にも変化がおきて
私の「クラス作成の手法」にかなりの影響を与えて貰えそうです。しっかり考えて見ます。
 
▽kumattiさん
kumattiさんがたち上げられ別スレッド内の「VBAの呼出履歴」は、かなり興味をもっております。
（別板での同話題の時にはお世話になりました^^）コアの情報がまたお聞きできそうで
期待しております。
 
 
# 硬い話ばかりでは、あれなので少し雑談も交えまして。
# simpleさんが昨日「公園を散歩して、春を感じた」と書き込まれていました。
# 私は札幌の人間なのですが、今日は珍しくまとまった雪が降っています。昨日までは暖かく
# せっかく路面も出始めたのですけど、、まだまだ北海道の春は遠いです^^
# 冬場になると私の愛車'94 Jeepチェロキー（18年前！）なのですが、この「テイネンピ、
# テイネンピ」と騒いでるいる時代にリッター5kmも走りません。通勤に使っている為ガソリン
# 代がハンパありません^^;（妻に白い目で見られております、、）
# 良くも悪くも「アメ車」ですが、その大雑把さが好きなのだから私も「困った人」ですね^^

こんばんは、YU-TANG です。
 

yayadon さんの引用:
循環参照をなくすために，VBA でここまでやるべきかは，よくわかりません。

みそじのおじさん さんの引用:
・Eventの定義はclsContainersではなくてclsContainerではないか
　clsContainerがRaiseEventするとUserForm側ではそのイベントをどうキャッチするのか？
（現在の作りでは、UserForm側で複数あるclsContainerをWithEvents定義が出来ない。）

クラスって使ったことなかったので、どんなものかと試してみたいと思い、
ユーザーフォーム、標準モジュール、クラスモジュール４つ用意して、提示の
コードをコピペしました。
 
>Attribute Item.VB_UserMemId = 0 'この行を追加し上書き保存します。
をエクスポート、インポートして、さて実行と思ったのですが、これってどう
起動させるんでしょう？
 
ユーザーフォームから実行しようとすると、「コンパイルエラー　ユーザー定義型は
定義されていません」と出て
 
>Private mMoveItems As clsMoveItems
 
が反転します。
 
お試しもできない初心者で申し訳ないですが、せっかくなのでちょっと見てみたいので
どうやって起動させるのか教えてください。
 
Win7 Excel2010です。

めんたん さんの引用:
ユーザーフォームから実行しようとすると、「コンパイルエラー　ユーザー定義型は定義されていません」と出て
>Private mMoveItems As clsMoveItems
が反転します。

話の流れをぶったぎって申し訳ありません。
 
VBAのクラスモジュールを使ったプログラムについて、なんでもご自由にどうぞ。
ということみたいなので、サンプルコードを２つほど書いてみます。
 
まずはVBAで引数付きのコンストラクタを定義する方法です。
やっていることは単純で、クラスモジュールとペアになる標準モジュールを作って、標準モジュールからクラスに定義されているメソッドを呼び出しているだけです。
 
Javaなどのコンストラクタと違って、引数を指定しなかったら、コンパイル時にエラーになるというような強制力はありません。
コンストラクタが２回以上実行されたら、メッセージ表示するなどして、なにもせずに処理を抜ける。
Publicメソッドの先頭でコンストラクタが実行済みかどうかをチェックして、実行済みだったらメッセージ表示するなどして、なにもせずに処理を抜ける。
などして実行時にエラーにすることぐらいしかできません。
 
開発時の規約等で、インスタンスを生成する場合は、標準モジュールのコンストラクタに見立てたプロシージャを呼び出すことに順守できるのであれば、この方法で引数付きコンストラクタとおなじようなことができます。
 
●クラスモジュール：clsHoge

'====================  こ　こ　か　ら　=============================>>>>>>>>>>
Option Explicit
'コンストラクタ実行済みフラグ
Private mblnInit As Boolean
'モジュール変数
Private mstrName As String
Private mlngTotal As Long
Private mlngNums As Long
'***** コンストラクタの実体 *****
'外部から読み書きできないモジュール変数も変更できるようにするために
'コンストラクタの実体はクラスに定義する。
Public Sub Init2(pstrName As String)
    'コンストラクタ実行済みならメッセージ表示
    If mblnInit = True Then
        MsgBox "コンストラクタは２回以上実行できません"
        Exit Sub
    End If
    'コンストラクタ実行済みフラグを設定
    mblnInit = True
    'モジュール変数の設定
    mstrName = pstrName
    mlngNums = 0
    mlngTotal = 0
End Sub
Public Sub Clear()
    'Publicメソッドの先頭でコンストラクタ実行済みかチェック
    'コンストラクタ実行済みならメッセージ表示
    If mblnInit = False Then
        MsgBox "コンストラクタが実行されていません。"
        Exit Sub
    End If
    mlngTotal = 0
    mlngNums = 0
End Sub
Public Sub Add(plngVal As Long)
    If mblnInit = False Then
        MsgBox "コンストラクタが実行されていません。"
        Exit Sub
    End If
    mlngTotal = mlngTotal + plngVal
    mlngNums = mlngNums + 1
End Sub
Public Sub MsgAvg()
    Dim strR As String
    Dim lngAvg As String
    If mblnInit = False Then
        MsgBox "コンストラクタが実行されていません。"
        Exit Sub
    End If
    lngAvg = mlngTotal / mlngNums
    MsgBox mstrName & "：平均=" & CStr(lngAvg)
End Sub
Public Sub MsgTotal()
    If mblnInit = False Then
        MsgBox "コンストラクタが実行されていません。"
        Exit Sub
    End If
    MsgBox mstrName & "：合計=" & CStr(mlngTotal)
End Sub
'<<<<<<<<<<==========　こ　こ　ま　で　=======================================

'====================  こ　こ　か　ら　=============================>>>>>>>>>>
Option Explicit
'*****　コンストラクタ　*****
'１文で実行できるようにするためにコンストラクタの呼び出し口は
'標準モジュールに定義する。
Public Function Init2(pstrName As String) As clsHoge
    Dim objRtn As clsHoge
    Set objRtn = New clsHoge
    Call objRtn.Init2(pstrName)
    Set Init2 = objRtn
End Function
'<<<<<<<<<<==========　こ　こ　ま　で　=======================================

'====================  こ　こ　か　ら　=============================>>>>>>>>>>
Option Explicit
'テスト１１
Public Sub Test11()
    Dim objA As clsHoge
    'コンストラクタの実行
    Set objA = modHoge.Init2("ほげ太郎")
    Call objA.Add(1)
    Call objA.Add(2)
    Call objA.Add(3)
    Call objA.MsgTotal
End Sub
'テスト１２
Public Sub Test12()
    Dim objA As clsHoge
    'コンストラクタを２回実行
    Set objA = New clsHoge
    Set objA = modHoge.Init2("ほげ太郎")
    Call objA.Init2("ほげ")
End Sub
'テスト１３
Public Sub Test13()
    Dim objA As clsHoge
    'コンストラクタを実行せずにNew
    Set objA = New clsHoge
    Call objA.Add(1)
End Sub
'<<<<<<<<<<==========　こ　こ　ま　で　=======================================

サンプルコードの２つ目として、VBAでクラスのインスタンスを生成するリフレクション機能を実現するコードを掲載します。
  
CallByNameではインスタンスが設定された後のオブジェクトに対して文字列指定でメソッドを実行することができますが、インスタンスを生成する処理を実行することはできません。
  
VB6.0とVBAを比べるとVBAではできないことのほうが多いですが、VB6.0にできなくてVBAにできることの１つにApplication.Runを使って文字列で指定した標準モジュールのプロシージャを実行する機能があります。
このApplicatio.Runを使って、文字列指定でクラスのインスタンスを生成します。
  
クラスモジュールとペアになる標準モジュールが存在する。
クラスモジュールとペアになる標準モジュールの名前に規則性がある。
リフレクションで使用する全てのクララスモジュールとペアの標準モジュールに同じ名前のコンストラクタ用のメソッドがある。
という前提が成り立つときにしか利用できません。
 
●クラスモジュール：clsPiyoA

'====================  こ　こ　か　ら　=============================>>>>>>>>>>
Option Explicit
'モジュール変数
Private mstrName As String
'引数なしのコンストラクタ
Public Sub Init1()
    'モジュール変数の設定
    mstrName = "名無しの権兵衛"
End Sub
'引数ありのコンストラクタ
Public Sub Init2(pstrName As String)
    mstrName = pstrName
End Sub
'メソッド
Public Sub SubA()
    MsgBox "clsPiyoA(" & mstrName & ").SubA"
End Sub
'<<<<<<<<<<==========　こ　こ　ま　で　=======================================

Option Explicit
'コンストラクタ
'１文で実行できるようにするためにコンストラクタの呼び出し口は
'標準モジュールに定義する。
Public Function Init1() As clsPiyoA
    Dim objRtn As clsPiyoA
    Set objRtn = New clsPiyoA
    Call objRtn.Init1
    Set Init1 = objRtn
End Function
'コンストラクタ
'１文で実行できるようにするためにコンストラクタの呼び出し口は
'標準モジュールに定義する。
Public Function Init2(pstrName As String) As clsPiyoA
    Dim objRtn As clsPiyoA
    Set objRtn = New clsPiyoA
    Call objRtn.Init2(pstrName)
    Set Init2 = objRtn
End Function
'<<<<<<<<<<==========　こ　こ　ま　で　=======================================

'====================  こ　こ　か　ら　=============================>>>>>>>>>>
Option Explicit
'モジュール変数
Private mstrName As String
'引数なしのコンストラクタ
Public Sub Init1()
    'モジュール変数の設定
    mstrName = "名無しの権兵衛"
End Sub
'引数ありのコンストラクタ
Public Sub Init2(pstrName As String)
    mstrName = pstrName
End Sub
'メソッド
Public Sub SubB()
    MsgBox "clsPiyoB(" & mstrName & ").SubB"
End Sub
'<<<<<<<<<<==========　こ　こ　ま　で　=======================================

'====================  こ　こ　か　ら　=============================>>>>>>>>>>
Option Explicit
'コンストラクタ
'１文で実行できるようにするためにコンストラクタの呼び出し口は
'標準モジュールに定義する。
Public Function Init1() As clsPiyoB
    Dim objRtn As clsPiyoB
    Set objRtn = New clsPiyoB
    Call objRtn.Init1
    Set Init1 = objRtn
End Function
'コンストラクタ
'１文で実行できるようにするためにコンストラクタの呼び出し口は
'標準モジュールに定義する。
Public Function Init2(pstrName As String) As clsPiyoB
    Dim objRtn As clsPiyoB
    Set objRtn = New clsPiyoB
    Call objRtn.Init2(pstrName)
    Set Init2 = objRtn
End Function
'<<<<<<<<<<==========　こ　こ　ま　で　=======================================

'====================  こ　こ　か　ら　=============================>>>>>>>>>>
Option Explicit
'***** 引数なしのコンストラクタ *****
'インスタンスの生成対象のクラスモジュールと
'そのクラス用標準モジュールとが同じ命名規約で存在する。
'コンストラクタのメソッド名がInit1
Public Function Init1(pstrClsallName As String) As Object
    Dim objRtn As Object
    Dim strProcName As String
    strProcName = "mod" & Mid(pstrClsallName, 4) & ".Init1"
    Set objRtn = Application.Run(strProcName)
    Set Init1 = objRtn
End Function
'***** 引数ありのコンストラクタ *****
'インスタンスの生成対象のクラスモジュールと
'そのクラス用標準モジュールとが同じ命名規約で存在する。
'コンストラクタのメソッド名はInit2で、
'String型の引数が１つ
Public Function Init2(pstrClsallName As String, pstrName As String) As Object
    Dim objRtn As Object
    Dim strProcName As String
    strProcName = "mod" & Mid(pstrClsallName, 4) & ".Init2"
    Set objRtn = Application.Run(strProcName, pstrName)
    Set Init2 = objRtn
End Function
'<<<<<<<<<<==========　こ　こ　ま　で　=======================================

'====================  こ　こ　か　ら　=============================>>>>>>>>>>
Option Explicit
'テスト２１
Public Sub Test21()
    Dim objA As clsPiyoA
    Dim objB As clsPiyoB
    Set objA = monNewInstance.Init1("clsPiyoA")
    Call objA.SubA
    Set objB = monNewInstance.Init1("clsPiyoB")
    Call objB.SubB
End Sub
'テスト２２
Public Sub Test22()
    Dim objA As clsPiyoA
    Dim objB As clsPiyoB
    Set objA = monNewInstance.Init2("clsPiyoA", "あああ")
    Call objA.SubA
    Set objB = monNewInstance.Init2("clsPiyoB", "いいい")
    Call objB.SubB
End Sub
'<<<<<<<<<<==========　こ　こ　ま　で　=======================================

みなさん、こんばんは。
 
めんたんさん。ご参加ありがとうございます。その後どうでしょうか？
ろひさん。フォローありがとうございます。
どんきちさん。どうぞどうぞご自由にお使い下さい。こんな風にみなさんに参加してもらえ
とてもうれしいです^^
 
 
▼月さん
 
遅くなりました。考えがまとまっていませんが、これ以上お待ちになってもらうのは申し訳
ありませんので^^
 

引用:

For Each Member In Members
の方が自然に見える。

引用:

mMoveItems.Add Item, Me
mMoveItems.Item(Item.Name).Value = vntName
mContainers.Items("Moug").AddItem mMoveItems.Item(Item.Name)
1. 追加して
2. 追加したものを取得して
3. また追加
に違和感を感じる。

引用:

clsContainers コンテナのコレクションクラス
↓
clsContainer　アイテムを収容するコンテナ
↓
clsMoveItems　アイテムのコレクションクラス
↓
clsMoveItem アイテム

引用:

もっと言うと、clsContainers コンテナのコレクションクラス は、ユーザーフォームのプロパティにしたいですね。そうすればMeを渡さなくて済むのでは。

>プロパティウィンドウを表示させて、「（オブジェクト名）」の項目に、正確にクラスモジュール名を入力してください。
 
ありがとうございました。起動できました〜
 
これすごいなぁ。。エクセルでこんなこともできるなんて。。。
 
がぜん興味が沸いてきましたが、どこから見たらいいのかさっぱりですので、初心者用のページを探してみることにします〜

みそじのおじさん さんの引用:
「メソッドチェーン」という呼ばれ方をしているのは知りませんでしたが、clsMoveItemのInitがこれにあたるんですね。

みそじのおじさん さんの引用:
組み立て直してみようと思っていますが、TermDown Or 弱参照の
どっちにするかを見極めてから取り掛かりたいと思います。

みそじのおじさん さんの引用:
「UserFromにプロパティを作成する」といった手法はよく利用しますが、
ごめんなさい。これに関しては何回考えてもわかりませんでした^^;

Friendスコープのメソッドは、Privateメソッド、Publicメソッド一部の
特徴を持っています。
 
1）Friendメソッドには、Publicメソッドのように外部から（但し、同Project限定）
　アクセス可能。対して、Privateメソッドには不可。
2）Friendメソッドは、Privateメソッドの同様、仮想関数テーブル（VTable）には
　載らない。
 
簡単なサンプルを書いてからテストします。
-----Class1

Public Sub PublicMethod()
    Debug.Print "Public Method"
End Sub

Friend Sub FrendMethod()
    Debug.Print "Friend Method"
End Sub

Sub Test()
    Dim o As Object
    Set o = New Class1
    
    o.PublicMethod
    o.FriendMethod  '←実行時Error(DISP_E_MEMBERNOTFOUND)
End Sub

失礼！！

引用:
# RECTの定義が間違っております。終盤になって気づき手遅れになってしまいました^^;

こんばんは。あっという間にレスが48件です。皆様ありがとうございます。
（めざすはkanabunさん率いるMy Favorite Songsに追いつけ追い越せ！です^^）
 
▼Abyssさん
Friendの詳しい解説ありがとうございます。
速度重視での選択とは、凡人には全く気が付きませんでした。
ウインドウメッセージの嵐に対応する手段だったのですね！
 
私　　　 →クラスから標準モジュールに置いたWndProcをCall
Abyssさん→標準モジュールからクラスに置いたWndProcをCall!!
　　　　　（これはとんでもないスキルを要します）
 
# 早くそちら側の世界に入りたいものです^^
 
▼YU-TANGさん。
Implementsを使用してメンバを隔離してみましたが、使用方法に自信が持てません。
少し見て頂けますか？
 
標準モジュール

Option Explicit

Sub Sample()

    Dim p As Class1
    Set p = New Class1

    p.Value = -2
    'このpから見えるのはValueプロパティとTestMethodメソッドのみ
    'Alertメソッドは見えない
    
    p.TermDown
    Set p = Nothing
    
End Sub

Option Explicit

Public Sub Alert(ByVal AlertValue As Long)

End Sub

Option Explicit

Implements ICallBackClass1

Public Event Alert(ByVal AlertValue As Long)
Private mChild As Class2

Private Sub Class_Initialize()
    Dim Child As Class2
        Set Child = New Class2
        Set mChild = Child.Init(Me)
End Sub

Private Sub Class_Terminate()
    Set mChild = Nothing
    Debug.Print "Class1 Term!"
End Sub

Private Sub ICallBackClass1_Alert(ByVal Value As Long)
    'RaiseEvent Alert(Value)
    '今回は標準モジュールでテストしたのでRaiseEventは使用しません
    MsgBox "Valueが0以下になりました"
End Sub

Public Property Get Value() As Long
    Value = mChild.Value
End Property

Public Property Let Value(ByVal NewValue As Long)
    mChild.Value = NewValue
End Property

Public Sub TestMethod()
    MsgBox "TestMethod"
End Sub

Public Sub TermDown()
    mChild.TermDown
    Set mChild = Nothing
End Sub

Option Explicit

Private mParent As ICallBackClass1 '※1
Private mValue  As Long

Public Function Init(ByVal NewParent As Class1) As Class2
    Set mParent = NewParent
    Set Init = Me
End Function

Public Property Get Value() As Long
    Value = mValue
End Property

Public Property Let Value(ByVal NewValue As Long)
    mValue = NewValue
    If mValue < 0 Then
        mParent.Alert mValue
    End If
End Property

Public Sub TermDown()
    Set mParent = Nothing
End Sub

Private Sub Class_Terminate()
    Debug.Print "Class2 Term!"
End Sub

こんばんは、YU-TANG です。
 

みそじのおじさん さんの引用:
Class2の※1の宣言部ですが、mParentをIcallBackClass1で宣言しましたがこの
部分に自信がもてません。As Class1で宣言するとClass1のICallBackClass1_Alertメソッド
が見えませんのでこうするしかなかったのですが、これで正解でしょうか？

Public Property Let Value(ByVal NewValue As Long)
    mValue = NewValue
    If mValue < 0 Then
        If TypeOf mParent Is ICallBackClass1 Then    ' コールバック インターフェイスを実装していたら
            CallBackClass1From(mParent).Alert mValue ' コールバックしてあげる
        End If
    End If
End Property

Private Function CallBackClass1From(o As Class1) As ICallBackClass1
    Set CallBackClass1From = o
End Function

> 直訳すると「涙落」みたいな感じでしょうか。
  
もしかして、冗談？ （笑）
  
TearDownとは「テアダウン」の発音するのでは？
訳すと、「ビリビリ破って捨てる」イメージだと思います。

いやいや、大真面目ですｗ
英語はぜんぜんダメで、おそらく周囲から見てギャグと区別がつかないレベルのダメっぷりと思われます。
 

Abyss さんの引用:
訳すと、「ビリビリ破って捨てる」イメージだと思います。

▼YU-TANGさん
２つの使い分けが、よく分りました！！その案件によって使い分ける事にします。
「TypeOfでの判定からコールバックする」VB6.0をやられていた方だと常套手段だったのかも
しれませんが、VBA育ちの私にはYU-TANGさんとこのお話をしていなければ辿り着けなかった
と思います。今後のコーディングにかなり影響があると思います！ありがとうございます。
 
# 「主義・主張がない」と書かれていましたが、どんどん主張して下さい！(笑）私と同じ様に
# クラスを使い始めて「モヤモヤ」している人にとって、こういったお話がとても大事だと
# 思うのです。どうぞよろしくお願い致します。
 
 
以下余談です。
 
「TearDown」すみません。。 Terminateのお話だったのでてっきり「Term」だと思い込んで
おりました。最近の私はweb上だけではなく、実際にプログラミングしている方と知り合いに
なろうと日々行動していまして、知り合った方との会話で
 
私　「この関数は、Boolean型でTrueかFalseを返すんだよね？」
知人「えっ、今なんて言ったの？」
私　（やばっ、なにか間違ったか！）
私　「トゥルーかフェールス」
知人　（爆笑）
知人　「falseはフォルス！」
 
しばらくプログラミング用語を声に出して人と話をしたくありません^^
 
 

Abyss さんの引用:
2）Friendメソッドは、Privateメソッドの同様、仮想関数テーブル（VTable）には
　載らない。

Option Explicit

Private Sub PrivateMethod()
    Debug.Print , "PrivateMethod was called."
End Sub

Friend Sub FriendMethod()
    Debug.Print , "FriendMethod was called."
End Sub

Public Sub PublicMethod()
    Debug.Print , "PublicMethod was called."
    Call PrivateMethod
End Sub

Option Explicit

Private Declare Function IsBadWritePtr Lib "kernel32" _
        (ByVal lp As Long, ByVal ucb As Long) As Long
        
Private Declare Function VirtualProtect Lib "kernel32" _
        (ByVal lpAddress As Long, ByVal dwSize As Long, _
        ByVal flNewProtect As Long, lpflOldProtect As Long) As Long
        
Private Const PAGE_EXECUTE_READWRITE = &H40

Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" _
    (Destination As Any, Source As Any, ByVal Length As Long)
    
Private Declare Function DispCallFunc Lib "oleaut32" _
        (ByVal pvInstance As Long, _
         ByVal oVft As Long, _
         ByVal cc As Long, _
         ByVal vtReturn As Integer, _
         ByVal cActuals As Long, _
         prgvt As Integer, _
         prgpvarg As Long, _
         pvargResult As Variant) As Long
         
Private Const CC_STDCALL = 4
Private Const VT_EMPTY = 0                  ' 引数無し用


'' PrivateMethod 用
Private m_pPrivateMethodHookProc As Long    ' フックプロシージャのアドレス値
Private m_PrevPrivateMethod As Long         ' 以前の関数ポインタ値
Private m_pSlotForPrivateMethod As Long     ' スロットのアドレス値

'' FriendMethod 用
Private m_pFriendMethodHookProc As Long     ' フックプロシージャのアドレス値
Private m_PrevFriendMethod As Long          ' 以前の関数ポインタ値
Private m_pSlotForFriendMethod As Long      ' スロットのアドレス値

'' StartHookOnXXXXMethod 内で使用
Public CustomInterface As CMethodTest
'

'' ここから PrivateMethod 用
Private Function PrivateMethodHookProc(ByVal This As Object) As Long
On Error Resume Next

    Debug.Print , "PrivateMethodHookProc was called."
    
    
    Dim oVft As Long    ' スロット位置
    oVft = 32           ' 7 + 2 個目  4 * (9 - 1)
     
    ' 再帰呼び出し回避のため
    Call EndHookOnPrivateMethod
    
    Dim hr As Long
    Dim vntResult As Variant
    
    hr = DispCallFunc(ObjPtr(This), oVft, CC_STDCALL, _
                      VT_EMPTY, 0&, ByVal 0&, ByVal 0&, vntResult)

    Call StartHookOnPrivateMethod
    
    If hr < 0 Then
        PrivateMethodHookProc = hr
    Else
        PrivateMethodHookProc = vntResult
    End If
    
    
End Function

Sub StartHookOnPrivateMethod()

    Debug.Print "---StartHookOnPrivateMethod---"
 

    Dim pvptr As Long
    Dim pVtbl As Long
    
    If m_pSlotForPrivateMethod Then Exit Sub ' すでに開始している
    
    pvptr = ObjPtr(CustomInterface)
    Call MoveMemory(pVtbl, ByVal pvptr, 4&)
    
    ' スロット位置
    pVtbl = pVtbl + 32           ' 4 * (9 - 1) : PrivateMethod メソッド

    ' 以前のポインタを退避
    Call MoveMemory(m_PrevPrivateMethod, ByVal pVtbl, 4&)
    
    m_pPrivateMethodHookProc = VBA.CLng(AddressOf PrivateMethodHookProc)
    
    ' 差し替え
    If Not ForceCopyLong(pVtbl, m_pPrivateMethodHookProc) Then Exit Sub
    
    m_pSlotForPrivateMethod = pVtbl
    
End Sub

Sub EndHookOnPrivateMethod()

    Debug.Print "---EndHookOnPrivateMethod---"
   
    Dim p As Long
    If m_pSlotForPrivateMethod = 0 Then Exit Sub
    Call MoveMemory(p, ByVal m_pSlotForPrivateMethod, 4&)
    If p = m_pPrivateMethodHookProc Then
        Call ForceCopyLong(m_pSlotForPrivateMethod, m_PrevPrivateMethod)
    End If
    m_pSlotForPrivateMethod = 0

End Sub

'' ここから FriendMethod 用
Private Function FriendMethodHookProc(ByVal This As Object) As Long
On Error Resume Next

    Debug.Print , "FriendMethodHookProc was called."
    
    
    Dim oVft As Long    ' スロット位置
    oVft = 36           ' 7 + 3 個目  4 * (10 - 1)
    
    ' 再帰呼び出し回避のため
    Call EndHookOnFriendMethod
    
    Dim hr As Long
    Dim vntResult As Variant
    
    hr = DispCallFunc(ObjPtr(This), oVft, CC_STDCALL, _
                      VT_EMPTY, 0&, ByVal 0&, ByVal 0&, vntResult)

    Call StartHookOnFriendMethod
    
    If hr < 0 Then
        FriendMethodHookProc = hr
    Else
        FriendMethodHookProc = vntResult
    End If
    
    
End Function

Sub StartHookOnFriendMethod()

    Debug.Print "---StartHookOnFriendMethod---"
 

    Dim pvptr As Long
    Dim pVtbl As Long
    
    If m_pSlotForFriendMethod Then Exit Sub ' すでに開始している
    
    pvptr = ObjPtr(CustomInterface)
    Call MoveMemory(pVtbl, ByVal pvptr, 4&)
    
    ' スロット位置
    pVtbl = pVtbl + 36        ' 4 * (10 - 1) : FriendMethod メソッド

    ' 以前のポインタを退避
    Call MoveMemory(m_PrevFriendMethod, ByVal pVtbl, 4&)
    
    m_pFriendMethodHookProc = VBA.CLng(AddressOf FriendMethodHookProc)
    
    ' 差し替え
    If Not ForceCopyLong(pVtbl, m_pFriendMethodHookProc) Then Exit Sub
    
    m_pSlotForFriendMethod = pVtbl
    
End Sub

Sub EndHookOnFriendMethod()

    Debug.Print "---EndHookOnFriendMethod---"
   
    Dim p As Long
    If m_pSlotForFriendMethod = 0 Then Exit Sub
    Call MoveMemory(p, ByVal m_pSlotForFriendMethod, 4&)
    If p = m_pFriendMethodHookProc Then
        Call ForceCopyLong(m_pSlotForFriendMethod, m_PrevFriendMethod)
    End If
    m_pSlotForFriendMethod = 0

End Sub

'' メモリ上の指定されたアドレスに32ビット値を書き込み
Private Function ForceCopyLong(ByVal Address As Long, _
                               ByVal Value As Long) As Boolean
                               
    Dim lngOld As Long
    
    If IsBadWritePtr(Address, 4&) Then
        Debug.Print "IsBadWritePtr is True"
        If VirtualProtect(Address, 4&, _
                          PAGE_EXECUTE_READWRITE, lngOld) = 0 Then
            Exit Function
        End If
        Call MoveMemory(ByVal Address, Value, 4&)
        VirtualProtect Address, 4&, lngOld, lngOld
    Else
        Call MoveMemory(ByVal Address, Value, 4&)
    End If
    
    ForceCopyLong = True
    
End Function

Private Sub Test()

    Dim pUnk As stdole.IUnknown
    Dim pDisp As Object
    Dim pCustom As CMethodTest

    Debug.Print "開始"

    ' 各インターフェース ポインタの位置の確認。
    Set pUnk = New CMethodTest
    Debug.Print "pUnk   : ", Hex(ObjPtr(pUnk))
    
    Set pDisp = pUnk
    Debug.Print "pDisp  : ", Hex(ObjPtr(pDisp))
    
    Set pCustom = pUnk
    Debug.Print "pCustom: ", Hex(ObjPtr(pCustom))
    
    Debug.Print
    
    ' 仮想関数テーブルのスロット位置の関数ポインタの確認。
    Dim hr As Long
    Dim rgvt As Integer
    Dim rgpvarg As Long
    Dim vntResult As Variant
    
    Debug.Print "Call  8番目 --- 4 * 7 オフセット目"
    hr = DispCallFunc(ObjPtr(pCustom), 28, CC_STDCALL, _
                      VT_EMPTY, 0&, ByVal 0&, ByVal 0&, vntResult)
    
    Debug.Print "Call  9番目 --- 4 * 8 オフセット目"
    hr = DispCallFunc(ObjPtr(pCustom), 32, CC_STDCALL, _
                      VT_EMPTY, 0&, ByVal 0&, ByVal 0&, vntResult)
    
    Debug.Print "Call 10番目 --- 4 * 9 オフセット目"
    hr = DispCallFunc(ObjPtr(pCustom), 36, CC_STDCALL, _
                      VT_EMPTY, 0&, ByVal 0&, ByVal 0&, vntResult)

    Debug.Print

    ' スロットをフックして，そこを通過するか？を確認。
    Set ModuleHook.CustomInterface = pCustom
    
    ' Public -> Private
    Call ModuleHook.StartHookOnPrivateMethod
    Debug.Print "Call pCustom.PublicMethod"
    Call pCustom.PublicMethod
    Call ModuleHook.EndHookOnPrivateMethod
    
    Debug.Print
    
    ' Friend
    Call ModuleHook.StartHookOnFriendMethod
    Debug.Print "Call pCustom.FriendMethod"
    Call pCustom.FriendMethod
    Call ModuleHook.EndHookOnFriendMethod
    
    Debug.Print
    
    Call ModuleHook.StartHookOnFriendMethod
    Debug.Print "DispCallFunc オフセット 36"
    hr = DispCallFunc(ObjPtr(pCustom), 36, CC_STDCALL, _
                      VT_EMPTY, 0&, ByVal 0&, ByVal 0&, vntResult)
    Call ModuleHook.EndHookOnFriendMethod
    
    Set ModuleHook.CustomInterface = Nothing

    Debug.Print "終了"

End Sub

開始
pUnk   :      4DD4424
pDisp  :      4DD4408
pCustom:      4DD4408

Call  8番目 --- 4 * 7 オフセット目
              PublicMethod was called.
              PrivateMethod was called.
Call  9番目 --- 4 * 8 オフセット目
              PrivateMethod was called.
Call 10番目 --- 4 * 9 オフセット目
              FriendMethod was called.

---StartHookOnPrivateMethod---
Call pCustom.PublicMethod
              PublicMethod was called.
              PrivateMethodHookProc was called.
---EndHookOnPrivateMethod---
              PrivateMethod was called.
---StartHookOnPrivateMethod---
---EndHookOnPrivateMethod---

---StartHookOnFriendMethod---
Call pCustom.FriendMethod
              FriendMethod was called.
---EndHookOnFriendMethod---

---StartHookOnFriendMethod---
DispCallFunc オフセット 36
              FriendMethodHookProc was called.
---EndHookOnFriendMethod---
              FriendMethod was called.
---StartHookOnFriendMethod---
---EndHookOnFriendMethod---
終了

---StartHookOnPrivateMethod---
Call pCustom.PublicMethod
              PublicMethod was called.
              PrivateMethodHookProc was called.     (A)
---EndHookOnPrivateMethod---
              PrivateMethod was called.             (B)
---StartHookOnPrivateMethod---
---EndHookOnPrivateMethod---

---StartHookOnFriendMethod---
Call pCustom.FriendMethod
              FriendMethod was called.              (C)
---EndHookOnFriendMethod---

---StartHookOnFriendMethod---
DispCallFunc オフセット 36
              FriendMethodHookProc was called.     (D)
---EndHookOnFriendMethod---
              FriendMethod was called.             (E)
---StartHookOnFriendMethod---
---EndHookOnFriendMethod---

補足:
上で，
PublicMethod は，8番目の位置
と表現しましたが，
仮想テーブルのスロットは，0 から数えるので，
上記の 8番目のスロットは，スロット7 (slot 7) と表現します。
 
スロット0 (slot 0) は QueryInterface
スロット1 (slot 1) は AddRef
　　　　　　　　　：
　
　

yayadonさん、ここまで分析するとは、流石ですね！
 

引用:
　・PublicMethod メソッド　　　　 <--- ここに移動
　・PrivateMethod メソッド　　　　<--- 以下，順に後ろに移動のもよう
　・FriendMethod メソッド　　　　 <--- 存在しているもよう

Public mPublicMember As Long
Private mPrivateMember As Long

Private Sub PrivateMethod1()
'    Debug.Print "Private Method1"
End Sub

Public Sub PublicMethod1()
'    Debug.Print "Public Method2"
End Sub

Friend Sub FriendMethod3()
'    Debug.Print "Friend Method3"
End Sub

Public Function PublicFunction4() As String
'    Debug.Print "Public Method4"
End Function

Sub Test1()
    Dim m   'MemberInfo
    With CreateObject("TLI.TLIApplication")
        For Each m In .InterfaceInfoFromObject(New Class1).VTableInterface.Members
            Debug.Print m.VTableOffset, m.Name
        Next
        
    End With
    
End Sub

Sub Test2()
    Const cIterate = 30000000
    Dim t As Single, i As Long, c As Class1
    
    Set c = New Class1
    
    t = Timer
    For i = 1 To cIterate
        c.PublicMethod1
    Next
    Debug.Print Timer - t, "public"
    
    t = Timer
    For i = 1 To cIterate
        c.FriendMethod3
    Next
    Debug.Print Timer - t, "friend"
    
End Sub

WithEventsを使って複数のクラスの同じ形式のイベントを１つのイベントプロシージャで受け取る（１）
 
クラスにイベントを通知するオブジェクトが複数存在するときに、それらのクラスから通知される全てのイベントに対して何らかの処理を実行しなければいけないとします。
 
WithEventsを使ってその処理を実現しようとすると、通知元のオブジェクトの数と通知されるイベントの数を掛け合わせた数だけイベントプロシージャを記述しなければいけません。
イベントを通知するクラスが10個あって、1つのクラスから通知されるイベントの数が5個だった場合は50個のイベントプロシージャを記述しなければいけません。
 
複数のクラスから通知される同じ形式のイベントに対する処理の内容がまったく異なるのであれば、面倒でも別々にイベントプロシージャを記述したほうがいいでしょう。
しかし、複数のクラスから通知される同じ形式のイベントに対する処理の内容の７〜８割が同じ内容になるのであれば、複数のクラスから通知される同じ形式のイベントに対するイベントプロシージャは１つで済ませたいのではないでしょうか。
 
イベントの通知元クラスと通知先クラスの間に、イベント中継用クラスを１つはさむことで、そういったことが可能になります。
そのときに、通知元クラスと通知先クラスでイベント中継用クラスの同じインスタンスを利用しないと、通知元と通知先のひもづけがされないので注意が必要です。
 
まずは、イベント中継クラスを使わなかった場合のサンプルコードを示します。
 

'============================================================
'クラスモジュール：clsFrom1
'============================================================
'イベント通知元クラス１
Option Explicit
'イベント
Public Event EvtA()
Public Event EvtB(p1 As Long)
Public Event EvtC(p1 As Long, p2 As Long)

Public Sub OnEvtA()
    Debug.Print "clsFrom1.OnEvtA"
    RaiseEvent EvtA
End Sub

Public Sub OnEvtB(p1 As Long)
    Debug.Print "clsFrom1.OnEvtB"
    RaiseEvent EvtB(p1)
End Sub

Public Sub OnEvtC(p1 As Long, p2 As Long)
    Debug.Print "clsFrom1.OnEvtC"
    RaiseEvent EvtC(p1, p2)
End Sub

'============================================================
'クラスモジュール：clsFrom2
'============================================================
'イベント通知元クラス２
Option Explicit
'イベント
Public Event EvtA()
Public Event EvtB(p1 As Long)
Public Event EvtC(p1 As Long, p2 As Long)

Public Sub OnEvtA()
    Debug.Print "clsFrom2.OnEvtA"
    RaiseEvent EvtA
End Sub

Public Sub OnEvtB(p1 As Long)
    Debug.Print "clsFrom2.OnEvtB"
    RaiseEvent EvtB(p1)
End Sub

Public Sub OnEvtC(p1 As Long, p2 As Long)
    Debug.Print "clsFrom2.OnEvtC"
    RaiseEvent EvtC(p1, p2)
End Sub

'============================================================
'クラスモジュール：clsFrom3
'============================================================
'イベント通知元クラス３
Option Explicit
'イベント
Public Event EvtA()
Public Event EvtB(p1 As Long)
Public Event EvtC(p1 As Long, p2 As Long)

Public Sub OnEvtA()
    Debug.Print "clsFrom3.OnEvtA"
    RaiseEvent EvtA
End Sub

Public Sub OnEvtB(p1 As Long)
    Debug.Print "clsFrom3.OnEvtB"
    RaiseEvent EvtB(p1)
End Sub

Public Sub OnEvtC(p1 As Long, p2 As Long)
    Debug.Print "clsFrom3.OnEvtC"
    RaiseEvent EvtC(p1, p2)
End Sub

'============================================================
'クラスモジュール：clsTo1
'============================================================
'イベント通知先クラス１
Option Explicit
Private WithEvents mobjFrom1 As clsFrom1
Private WithEvents mobjFrom2 As clsFrom2
Private WithEvents mobjFrom3 As clsFrom3
'初期処理
Public Sub Init1()
    Set mobjFrom1 = New clsFrom1
    Set mobjFrom2 = New clsFrom2
    Set mobjFrom3 = New clsFrom3
End Sub
'イベントEvtAの発生処理の実行
Public Sub OnEvtA()
    Debug.Print "clsTo1.onEvtA:>>>"
    Debug.Print "clsTo1.onEvtA:001"
    Call mobjFrom1.OnEvtA
    Debug.Print
    Debug.Print "clsTo1.onEvtA:002"
    Call mobjFrom2.OnEvtA
    Debug.Print
    Debug.Print "clsTo1.onEvtA:003"
    Call mobjFrom3.OnEvtA
    Debug.Print "clsTo1.onEvtA:<<<"
End Sub
'イベントEvtBの発生処理の実行
Public Sub OnEvtB()
    Debug.Print "clsTo1.OnEvtB:>>>"
    Debug.Print "clsTo1.OnEvtB:001"
    Call mobjFrom1.OnEvtB(1)
    Debug.Print
    Debug.Print "clsTo1.OnEvtB:002"
    Call mobjFrom2.OnEvtB(2)
    Debug.Print
    Debug.Print "clsTo1.OnEvtB:003"
    Call mobjFrom3.OnEvtB(3)
    Debug.Print "clsTo1.OnEvtB:<<<"
End Sub
'イベントEvtCの発生処理の実行
Public Sub OnEvtC()
    Debug.Print "clsTo1.OnEvtC:>>>"
    Debug.Print "clsTo1.OnEvtC:001"
    Call mobjFrom1.OnEvtC(1, 2)
    Debug.Print
    Debug.Print "clsTo1.OnEvtC:002"
    Call mobjFrom2.OnEvtC(2, 3)
    Debug.Print
    Debug.Print "clsTo1.OnEvtC:003"
    Call mobjFrom3.OnEvtC(3, 4)
    Debug.Print "clsTo1.OnEvtC:<<<"
End Sub
'mobjFrom1のイベントプロシージャ
Private Sub mobjFrom1_EvtA()
    Debug.Print "clsTo1.mobjFrom1_EvtA"
    'イベントEvtAの共通処理を実行
    Call doEvtA(mobjFrom1)
End Sub
Private Sub mobjFrom1_EvtB( _
p1 As Long)
    Debug.Print "clsTo1.mobjFrom1_EvtB(" _
        & Trim(p1) & ")"
    'イベントEvtBの共通処理を実行
    Call doEvtB(mobjFrom1, p1)
End Sub
Private Sub mobjFrom1_EvtC( _
p1 As Long, p2 As Long)
    Debug.Print "clsTo1.mobjFrom2_EvtC(" _
        & Trim(p1) & "," & Trim(p2) & ")"
    'イベントEvtCの共通処理を実行
    Call doEvtC(mobjFrom1, p1, p2)
End Sub
'mobjFrom2のイベントプロシージャ
Private Sub mobjFrom2_EvtA()
    Debug.Print "clsTo1.mobjFrom2_EvtA"
    'イベントEvtAの共通処理を実行
    Call doEvtA(mobjFrom2)
End Sub
Private Sub mobjFrom2_EvtB( _
p1 As Long)
    Debug.Print "clsTo1.mobjFrom2_EvtB(" _
        & Trim(p1) & ")"
    'イベントEvtBの共通処理を実行
    Call doEvtB(mobjFrom2, p1)
End Sub
Private Sub mobjFrom2_EvtC( _
p1 As Long, p2 As Long)
    Debug.Print "clsTo1.mobjFrom2_EvtC(" _
        & Trim(p1) & "," & Trim(p2) & ")"
    'イベントEvtCの共通処理を実行
    Call doEvtC(mobjFrom2, p1, p2)
End Sub
'mobjFrom3のイベントプロシージャ
Private Sub mobjFrom3_EvtA()
    Debug.Print "clsTo1.mobjFrom3_EvtA"
    'イベントEvtAの共通処理を実行
    Call doEvtA(mobjFrom3)
End Sub
Private Sub mobjFrom3_EvtB( _
p1 As Long)
    Debug.Print "clsTo1.mobjFrom3_EvtB(" _
        & Trim(p1) & ")"
    'イベントEvtBの共通処理を実行
    Call doEvtB(mobjFrom3, p1)
End Sub
Private Sub mobjFrom3_EvtC( _
p1 As Long, p2 As Long)
    Debug.Print "clsTo1.mobjFrom3_EvtC(" _
        & Trim(p1) & "," & Trim(p2) & ")"
    'イベントEvtCの共通処理を実行
    Call doEvtC(mobjFrom3, p1, p2)
End Sub
'イベントEvtAの共通処理
Private Sub doEvtA( _
pobjFrom As Object)
    Debug.Print "clsTo1.doEvtA(" _
        & TypeName(pobjFrom) & ")"
End Sub
'イベントEvtBの共通処理
Private Sub doEvtB( _
pobjFrom As Object, p1 As Long)
    Debug.Print "clsTo1.doEvtB(" _
        & TypeName(pobjFrom) _
        & "," & Trim(p1) & ")"
End Sub
'イベントEvtCの共通処理
Private Sub doEvtC( _
pobjFrom As Object, p1 As Long, p2 As Long)
    Debug.Print "clsTo1.doEvtC(" _
        & TypeName(pobjFrom) _
        & "," & Trim(p1) & "," & Trim(p2) & ")"
End Sub

'============================================================
'標準モジュール：modMain
'============================================================
Option Explicit
'テスト実行処理
Sub Test1()
    Dim objTo1 As clsTo1
    Set objTo1 = New clsTo1
    Call objTo1.Init1
    Debug.Print "MOD1.001"
    Call objTo1.OnEvtA
    Debug.Print
    Debug.Print "MOD1.002"
    Call objTo1.OnEvtB
    Debug.Print
    Debug.Print "MOD1.003"
    Call objTo1.OnEvtC
End Sub

WithEventsを使って複数のクラスの同じ形式のイベントを１つのイベントプロシージャで受け取る（２）
 
中継クラスを使った場合のサンプルコードを示します。
 

'============================================================
'クラスモジュール：clsEvt1
'============================================================
'イベント中継クラス１
Option Explicit
'イベント（通知元オブジェクトを識別する引数を追加）
Public Event EvtA( _
    pobjFrom As Object)
Public Event EvtB( _
    pobjFrom As Object, p1 As Long)
Public Event EvtC( _
    pobjFrom As Object, p1 As Long, p2 As Long)
'イベント中継メソッド
Public Sub OnEvtA( _
pobjFrom As Object)
    Debug.Print "clsEvt1.OnEvtA"
    RaiseEvent EvtA(pobjFrom)
End Sub
Public Sub OnEvtB( _
pobjFrom As Object, p1 As Long)
    Debug.Print "clsEvt1.OnEvtB"
    RaiseEvent EvtB(pobjFrom, p1)
End Sub
Public Sub OnEvtC( _
pobjFrom As Object, p1 As Long, p2 As Long)
    Debug.Print "clsEvt1.OnEvtC"
    RaiseEvent EvtC(pobjFrom, p1, p2)
End Sub

'============================================================
'クラスモジュール：clsFrom1
'============================================================
'イベント通知元クラス１
Option Explicit
Private mobjEvt1 As clsEvt1

Public Property Set ObjEvt1(p1 As clsEvt1)
    Set mobjEvt1 = p1
End Property

Public Sub OnEvtA()
    Debug.Print "clsFrom1.OnEvtA"
    Call mobjEvt1.OnEvtA(Me)
End Sub

Public Sub OnEvtB(p1 As Long)
    Debug.Print "clsFrom1.OnEvtB"
    Call mobjEvt1.OnEvtB(Me, p1)
End Sub

Public Sub OnEvtC(p1 As Long, p2 As Long)
    Debug.Print "clsFrom1.OnEvtC"
    Call mobjEvt1.OnEvtC(Me, p1, p2)
End Sub

'============================================================
'クラスモジュール：clsFrom2
'============================================================
'イベント通知元クラス２
Option Explicit
Private mobjEvt1 As clsEvt1

Public Property Set ObjEvt1(p1 As clsEvt1)
    Set mobjEvt1 = p1
End Property

Public Sub OnEvtA()
    Debug.Print "clsFrom2.OnEvtA"
    Call mobjEvt1.OnEvtA(Me)
End Sub

Public Sub OnEvtB(p1 As Long)
    Debug.Print "clsFrom2.OnEvtB"
    Call mobjEvt1.OnEvtB(Me, p1)
End Sub

Public Sub OnEvtC(p1 As Long, p2 As Long)
    Debug.Print "clsFrom2.OnEvtC"
    Call mobjEvt1.OnEvtC(Me, p1, p2)
End Sub

'============================================================
'クラスモジュール：clsFrom3
'============================================================
'イベント通知元クラス３
Option Explicit
Private mobjEvt1 As clsEvt1

Public Property Set ObjEvt1(p1 As clsEvt1)
    Set mobjEvt1 = p1
End Property

Public Sub OnEvtA()
    Debug.Print "clsFrom3.OnEvtA"
    Call mobjEvt1.OnEvtA(Me)
End Sub

Public Sub OnEvtB(p1 As Long)
    Debug.Print "clsFrom3.OnEvtB"
    Call mobjEvt1.OnEvtB(Me, p1)
End Sub

Public Sub OnEvtC(p1 As Long, p2 As Long)
    Debug.Print "clsFrom3.OnEvtC"
    Call mobjEvt1.OnEvtC(Me, p1, p2)
End Sub

'============================================================
'クラスモジュール：clsTo1
'============================================================
'イベント通知先クラス１
Option Explicit
Private WithEvents mobjEvt1 As clsEvt1
Private mobjFrom1 As clsFrom1
Private mobjFrom2 As clsFrom2
Private mobjFrom3 As clsFrom3

Public Sub Init1()
    'イベント中継クラスの同じインスタンス
    'を使って通知元と通知先をひもづける。
    Set mobjEvt1 = New clsEvt1
    Set mobjFrom1 = New clsFrom1
    Set mobjFrom1.ObjEvt1 = mobjEvt1
    Set mobjFrom2 = New clsFrom2
    Set mobjFrom2.ObjEvt1 = mobjEvt1
    Set mobjFrom3 = New clsFrom3
    Set mobjFrom3.ObjEvt1 = mobjEvt1
End Sub
'イベントEvtAの発生処理の実行
Public Sub OnEvtA()
    Debug.Print "clsTo1.onEvtA:>>>"
    Debug.Print "clsTo1.onEvtA:001"
    Call mobjFrom1.OnEvtA
    Debug.Print
    Debug.Print "clsTo1.onEvtA:002"
    Call mobjFrom2.OnEvtA
    Debug.Print
    Debug.Print "clsTo1.onEvtA:003"
    Call mobjFrom3.OnEvtA
    Debug.Print "clsTo1.onEvtA:<<<"
End Sub
'イベントEvtBの発生処理の実行
Public Sub OnEvtB()
    Debug.Print "clsTo1.OnEvtB:>>>"
    Debug.Print "clsTo1.OnEvtB:001"
    Call mobjFrom1.OnEvtB(1)
    Debug.Print
    Debug.Print "clsTo1.OnEvtB:002"
    Call mobjFrom2.OnEvtB(2)
    Debug.Print
    Debug.Print "clsTo1.OnEvtB:003"
    Call mobjFrom3.OnEvtB(3)
    Debug.Print "clsTo1.OnEvtB:<<<"
End Sub
'イベントEvtCの発生処理の実行
Public Sub OnEvtC()
    Debug.Print "clsTo1.OnEvtC:>>>"
    Debug.Print "clsTo1.OnEvtC:001"
    Call mobjFrom1.OnEvtC(1, 2)
    Debug.Print
    Debug.Print "clsTo1.OnEvtC:002"
    Call mobjFrom2.OnEvtC(2, 3)
    Debug.Print
    Debug.Print "clsTo1.OnEvtC:003"
    Call mobjFrom3.OnEvtC(3, 4)
    Debug.Print "clsTo1.OnEvtC:<<<"
End Sub
'mobjEvt1のイベントプロシージャ
Private Sub mobjEvt1_EvtA( _
pobjFrom As Object)
    Debug.Print "clsTo1.mobjEvt1_EvtA(" _
        & TypeName(pobjFrom) & ")"
End Sub
Private Sub mobjEvt1_EvtB( _
pobjFrom As Object, p1 As Long)
    Debug.Print "clsTo1.mobjEvt1_EvtB(" _
        & TypeName(pobjFrom) & "," _
        & Trim(p1) & ")"
End Sub
Private Sub mobjEvt1_EvtC( _
pobjFrom As Object, p1 As Long, p2 As Long)
    Debug.Print "clsTo1.mobjFrom3_EvtC(" _
        & TypeName(pobjFrom) & "," _
        & Trim(p1) & "," & Trim(p2) & ")"
End Sub

'============================================================
'標準モジュール：modMain
'============================================================
Option Explicit
'テスト実行処理
Sub Test1()
    Dim objTo1 As clsTo1
    Set objTo1 = New clsTo1
    Call objTo1.Init1
    Debug.Print "MOD1.001"
    Call objTo1.OnEvtA
    Debug.Print
    Debug.Print "MOD1.002"
    Call objTo1.OnEvtB
    Debug.Print
    Debug.Print "MOD1.003"
    Call objTo1.OnEvtC
End Sub

みなさん、こんばんは。
 
▼どんきちさん
・コンストラクタに引数を渡せないVBAの仕様に、不満がある方は沢山おられるのですね。
　（みなさん何かしらの工夫をされているんでしょうね？私は軽い防御でInitにflagを
　　立てているくらいです）
 
・イベント中継クラスですか。私が作るものはそんなに巨大になる事がまだありませんが
　是非覚えておきたいテクニックですね^^
 
やっと自分の方が落ち着いてきましたので、これから試させて頂きますね。
引き続きご参加お願い致します。
 
▼めんたんさん
 
無事に動いたみたいで安心しました。
初めてクラスを使う方には、多少見た目にインパクトがある方が興味をもって頂けるかなと？
あのクラスを選択しました。興味を持って頂けた様でよかったです^^
（裏方としては大活躍しているのだけど、表舞台には一切立たない地味ーなクラスなんかも
　あるのですけど、それでは面白みにかけるかと、、）
 
VB6.0ユーザー向けのクラスの解説なのですが、以下のサイトなどはどうでしょうか？
私はここで勉強させて頂きました。とても丁寧な解説で分り易いと思います。
http://homepage1.nifty.com/CavalierLab/lab/vb/clsmdl/index.html
 
序盤にこんな事が書いてありました。
以下はそのサイトからの引用です。
「一度クラスを知れば、次のプロジェクトからは「必須」になるでしょう。」
私はまさに「それ」でした。
 
「クラスの基本的な作り方はわかった。さーて実践に移ってみよう！」
「普段、この様な処理をメインに色々作ってきたのだが、どの部分にクラスをあてはめて
作成していけばいいのか？」
結局、自分で答えを見つけられずmougではありませんがその趣旨の質問スレッドを立てた事も
あります。YU-TANGさんやAbyssさんはそんな私の経緯をしっておられる方です^^
 
もし、「クラスをこれからやってみよう」「クラスを使い始めたばかり」という方で
「何をクラスにすべきか？」と悩んでいる方がおられましたら、普段はこんな処理を
よくやっています！と書かれますと適切なアドバイスが皆様より得られるのではないで
しょうか？
 
# クラスモジュールの話題がもっと「ポピュラー」にと切に願っております。^^

月 さんの引用:
clsContainers コンテナのコレクションクラス
↓
clsContainer　アイテムを収容するコンテナ
↓
clsMoveItems　アイテムのコレクションクラス
↓
clsMoveItem アイテム

おはようございます。YU-TANGさん早起きですね^^
 

YU-TANG さんの引用:

ちょっと思ったんですけれど、このアイテムって、コンテナのの外にも移動できますよね。
そうすると、どのコンテナにも属していないアイテムっていうのが発生することになるんですが、それはどのように管理するイメージになりますか？
 
#「どのコンテナにも属していないアイテム」用のダミーコンテナみたいなのに突っ込む？
 
# 引用元を指すレス番が欲しいな…。

YU-TANG さんの引用:
ちょっと思ったんですけれど、このアイテムって、コンテナの外にも移動できますよね。
そうすると、どのコンテナにも属していないアイテムっていうのが発生することになるんですが、それはどのように管理するイメージになりますか？

途中ですが、修正中のみそじのおじさんのクラスをアップします。
 
clsContainers コンテナのコレクションクラス
↓
clsContainer　アイテムを収容するコンテナ
↓
clsMoveItems　アイテムのコレクションクラス
↓
clsMoveItem アイテム
 
こういう階層にすると各クラスはどういうメンバを持つべきか、を考えて修正しました。
 
clsMoveItemsクラスにAddメソッドとAddItemメソッドがあり、Addメソッドに統一したかったのですが、まだできていません。
 
みそじのおじさんのクラス
https://gist.github.com/1970700/
 
以下、差分です。
 
clsContainer.cls
http://honda0510-y4q6xj6z.dotcloud.com/?old=https://gist.github.com/raw/1970700/40c0c1a59c774ac255d61fba8dfdefd085547515/clsContainer.cls&new=https://gist.github.com/raw/1970700/974cdc990fdf955b2d3fa80ec6b09e9d0714b8f1/clsContainer.cls
 
clsContainers.cls
http://honda0510-y4q6xj6z.dotcloud.com/?old=https://gist.github.com/raw/1970700/bceb515832289bec06827a06fb7102c63e743ea3/clsContainers.cls&new=https://gist.github.com/raw/1970700/501334d563ffc625b4084d66a604c25a5a01ec52/clsContainers.cls
 
clsMoveItem.cls
http://honda0510-y4q6xj6z.dotcloud.com/?old=https://gist.github.com/raw/1970700/34dd5583a9a5fb5d41a140cdb6f39de0682f5f9d/clsMoveItem.cls&new=https://gist.github.com/raw/1970700/8e882cab86a3b765373483f7f64c2bedcf4ffb9a/clsMoveItem.cls
 
clsMoveItems.cls
http://honda0510-y4q6xj6z.dotcloud.com/?old=https://gist.github.com/raw/1970700/8c032dc22c19a433a34872b0c6de7c583bfceb67/clsMoveItems.cls&new=https://gist.github.com/raw/1970700/ae86e5b7c0a23953d4433f5f0240c70ee8bf2675/clsMoveItems.cls
 
Module1.bas 変更なし
 
UserForm1.frm
http://honda0510-y4q6xj6z.dotcloud.com/?old=https://gist.github.com/raw/1970700/c64d0b4cece5c446491b882680ba92c4b7410ef0/UserForm1.frm&new=https://gist.github.com/raw/1970700/41369c202d4e90fe186c3db4d6c2ee095cf6d0ac/UserForm1.frm

月 さんの引用:
MaxItemCountOverイベントを定義するのはclsContainersじゃなくてclsContainerじゃないですかね。

みそじのおじさん さんの引用:
# 昨日、twitterの方でここの話題が書かれているのを見ました。
 （中略）
# 昨日一日でデジタル時計のクラスを書き上げましたが、コードが画面１つに収まり
# ません！（笑） 出直してきます^^

# なんとなく，考えたことを並べてみました。
 
# VBA の実装が実際にどうなっているのかは，わからないので，
# 解説ではなく，メモった程度という事柄です。
# というか，イベントにしたらどうだろう？というのを
# 単に私が持ち出したかったので(笑)，
# そういう流れになっています。
 
 
 
まだ変更途中のようですが，
月さんのコードの参照の関係を単純な形で見てみると...
 
　　UserForm
　　　　↓
　clsContainers
　　　　↓
　clsContainer　ref count : 2
　　↑　↓　← "強い" 参照の循環 ("strong" reference cycle)
　clsMoveItems
　　　　↓
　clsMoveItem
 
のようになっているので，
UserForm1 を閉じても，clsContainer の ref count が 1 にとどまるので，
clsContainer を含めて，それより下の階層のオブジェクトが破棄されません。
 
# UserForm1 を閉じる(Unload)時，常に Excel も閉じるのならば
# プロセスごと破棄されるので問題ないですが，
# そうでない場合は，
# 仮想メモリの Private Bytes の使用量がどんどん増えていきます。
 
なので，
clsMoveItems から clsContainer への参照は，
VBA には仕組みとして用意されていない
AddRef しない参照(non-counted reference / "weak" reference)
を用意する必要があります。
 
 
-----
オブジェクト参照の参照カウントに対する処理
AddRef/Release 呼び出しは，
VBA のコンパイラが自動的に挿入してくれます。
ただし，なぜか VBA では説明はありません。
また，
弱参照の仕組みは，コンパイラのサポートがありません。
 
ということで...
 
Apple の iOS5 向けの開発でも
コンパイラのサポートが入ったようで
 
[iOS5] ARC (Automatic Reference Counting) : Overview
ttp://blog.natsuapps.com/2011/11/ios5-arc-overview.html
 
[iOS5] ARC : 循環参照
ttp://blog.natsuapps.com/2011/11/ios5-arc-strong-reference-cycle.html
 
あたりを読むと，ちょっとだけ参考になります。
 
retain というのは COM の AddRef に相当します。
 
上記のリンク先の例では，
弱参照をコンパイラがサポートしている関係で，
オブジェクトが破棄された地点で，
弱参照は，nil つまり ポインタ が 0 になりますが，
VBA では，コンパイラのサポートではなく，
自作の仕組みで "弱い" 参照を組み入れる関係で，
弱参照が指すオブジェクトの寿命は，
自身の寿命より必ず長い必要があります。
 
上記のオブジェクト モデルだと，
clsMoveItems は，clsContainer 内にのみ存在するので，
clsContainer 側の方が寿命が必ず長いので
弱参照が使える場面になります。
 
# clsMoveItems クラスが，
# 単独で存在できる(orphaned) オブジェクト モデルの場合は，
# 弱参照は使えません。
 
 
 
ここから本題
-----
イベントの場合
 
 
例えば，親 が 子のイベント を利用する場合
 
　　　　　　　　　　　　　　　　　　　 親
　親へイベントを通知するための参照→ ↑　↓←子を所持するための参照
　　　　　　　　　　　　　　　　　　　 子
 
のような参照が循環している関係のように見えます。
 
この時，親が他のオブジェクトから参照されていると，
 
　　　　　他のオブジェクト
　　　　　　　↓
　　　　　　　親　ref count: 2
　　　　　　↑　↓
　　　　　　　子　ref count: 1
 
のような気がします。
 
その場合，
[他のオブジェクト] が破棄される時，
[親] に対して Release が呼ばれますが，
[親] の ref count は，2 -> 1 になるだけで，
 
　　　　　　　親　ref count: 1
　　　　　　↑　↓
　　　　　　　子　ref count: 1
 
[親] が破棄されないので，[子] への Release の呼び出しは無く，
結果，[子] も破棄されないので，[親] への Release の呼び出しは無く，
結果，両オブジェクトは，このまま残ることになります。
 
 
ですが，
実際は，これを避けるために，
親側がイベントに自身を登録する
(COM的には，Advise するといいます)時,
つまり，
VBA だと，WithEvents と付ける時，
シンク オブジェクト(sink object) と呼ばれている
親とは別のオブジェクトの参照を差し出します。
 
# sink は，キッチン シンク のシンクで，
# イベントを受け止めるオブジェクトというニュアンスで，
# sink object と呼ばれてるんでしょう。たぶん。
 
 
　　　　　　　　　　　　親
　　　　　　　　　　　　　　 │
　ref count: 1　sink object　│
　　　　　　　　　↑　　　　 │
　　　　　　　　　│　　　　 ↓
　　　　　　　　　　　　子　　　ref count: 1
 
参照の循環を避けるために，実装は，
[親] と [sink object] の間は，
参照カウントの無い間柄で，
[親] が破棄されれば，[sink object] も破棄される形に
なっていないといけません。
で，実際に，C++ で COM オブジェクトを作る時に使う
ATL と呼ばれいるライブラリ(クラス群)があるのですが，
その実装は，そうなってます。
 
 
また，
イベントの呼び出しは，
実行時バインディングになる関係で，
[sink object] は，IDispatch のメソッドを提供します。
 
そのため，
参照カウント用の
IUnknown::AddRef や IUnknown::Release メソッドを提供しますが，
実際はダミーで，上記の図の
[sink object] の ref count: 1 は，特に意味はありません。
 
 
VBA の実装が実際にどうなっているのかは，わかりません。
わからないのですが，動作を見ると，
巡りまわって参照が循環するようなことがない形の実装になってるようです。
 
 
ということで，
[親] が [他のオブジェクト] から参照されていても
sink object が挟まるおかげで，
 
　　　　　　　　　他のオブジェクト
　　　　　　　　　　　　↓
　　　　　　　　　　　　親　　　ref count: 1　※ 2 ではない
　　　　　　　　　　　　　　 │
　ref count: 1　sink object　│
　　　　　　　　　↑　　　　 │
　　　　　　　　　│　　　　 ↓
　　　　　　　　　　　　子　　　ref count: 1
 
のように，[親] 自体の参照カウントは，1 になります。
 
そして，
[他のオブジェクト] が破棄される時，
[親] に対して Release が呼ばれ，
[親] の ref count は，0 になります。
 
そして，
[親] は，自身のインスタンスが破棄される時，
[子] への参照を Release します。
 
そして，
[子] は，ref count が 0 になり，破棄される過程で，
[sink object] への参照(上図の ↑ )を Release します。
 
[sink object] の参照カウントが，
実際はダミーならば，この Release は特に意味はもちません。
 
 
のような感じで，
参照が循環しているように見えても，
大丈夫な仕組みになっています。
 
 
説明がややこしいので，
なんのことか，よくわからないかもしれませんが，
要するに，
イベントの場合は循環しているように見えても OK ということです。
前置きが長くて済みません。
 
 
なので，
 
　子がメソッド内で親を扱うようなメソッドの中身は，
　子が実装したイベントを通じて，親側のメソッド内で行うと
　参照の循環について気にしなくてもよくなる
 
ということになります。
 
# 但し，
# Collection や 配列で管理している要素の場合は，
# 仕組み的にイベントを受け取れないので困るんですが
 
 
今回の場合，
clsContainer は，子の clsMoveItems を
 

Private mMoveItems As clsMoveItems

みなさん、おはようございます。
近年まれにみる激務で返信が遅れています。申し訳ありません。
 
▼月さん
本当にありがとうございます。読み解くのに時間がかかっております^^;
 
▼マコさん
ご参加ありがとうございます。
このスレッドの目的は
・クラスを既に使っている方にはより深く！
・クラスを使った事がない・やり始めたばかりという方には「クラスを使う魅力」
　を体感してもらおう！
と思って立ち上げたスレッドですので、どんどん参加して下さいね。
 
# デジタル時計ですが、クラス内部に超危険なAPIのSettimer（へたをすればExcelごと落ちる）
　を仕込んでしまったのでみなさまに見てもらうのはどうかな？と思っております^^;
　YU-TANGさんに教えて頂いた事を復習しようと思って作った物ですので、、
 
▼yayadonさん
詳しい解説ありがとうございます。とても難しいです^^;
「強参照でクラスの関係を構築する」手法しか知らなかった私にとってとても有意義な
スレッドになっています。ありがとうございます。「親は子供を知っているのは当然だか
必ずしも子が親を知っている必要はない」これを念頭に置いてよく考えてみます。
 
引き続き皆様よろしくお願い致します。

yayadonさん、ご感想ありがとうございます。
 

みそじのおじさん さんの引用:
▼月さん
本当にありがとうございます。読み解くのに時間がかかっております^^;

話があっちこっちしてしまいますが。
 
クラスを作ると、どうやって再利用しようか考えますよね。クラス群専用のExcelファイルを作って参照設定するのが本筋なんですかね。その際、Instancingプロパティも合わせて考える必要がありますよね。というか、本当は順番が逆で、Instancingプロパティをどうするかを決めてクラスを作るのかなぁと。この辺詳しい方いましたらノウハウを教えてください。
 
Instancingプロパティ
http://s1-05.twitpicproxy.com/photos/full/536854026.png?key=260307
 
宣言された VBA プロジェクト外に(オブジェクトの)クラスを使用する方法
http://support.microsoft.com/kb/555159/ja

yayadon さんの引用:
まだ変更途中のようですが，
月さんのコードの参照の関係を単純な形で見てみると...
  
　　UserForm
　　　　↓
　clsContainers
　　　　↓
　clsContainer　ref count : 2
　　↑　↓　← "強い" 参照の循環 ("strong" reference cycle)
　clsMoveItems
　　　　↓
　clsMoveItem
  
のようになっているので，
UserForm1 を閉じても，clsContainer の ref count が 1 にとどまるので，
clsContainer を含めて，それより下の階層のオブジェクトが破棄されません。

yayadonさんの説明は、コードを書いた私にしか腹に落ちないかもしれませんね。
 
弱参照が何かわかっていませんが、メソッドをイベントに変えるといいというのは理解できました。なるほど、スゲー、というのが率直な感想です。すべてのクラスのTerminateイベントが呼ばれることを目標に、やってみたくなりました。時間取れたらやってみます。

引用:
超危険なAPIのSettimer（へたをすればExcelごと落ちる）
　を仕込んでしまったので...

# 本題ですが、みそじのおじさん さんご提示クラスですが、
　個人的な考えだと二つのクラスの構成でもいけると思っています。
　製作者の嗜好にもよる物ですし、まぁ、土台がUserformと言う特殊性も取り入れ、
　クラスはItemクラスと、それを子とする親クラス（Container）だけの構成。
 
# 同じ事を行っていますが、私のコードも提示します。
　一度、他人のコードを拝見したのでかなり影響を受けています（笑）
 
# コンテーナInの判断は、カーソルに位置基準に変更しています。
 
# Collectionへのメンバーの追加削除は意図的にclsItem側で行っています。
 
# 長いので、Userform実装コードは別追加します。
 
○ ICollection Interface

Public Function Item(Index)
Attribute Item.VB_UserMemId = 0
End Function
Public Function Add(Item)
End Function
Public Function Count&()
End Function
Public Sub Remove(Index)
End Sub
Public Function NewEnum() As IUnknown
Attribute NewEnum.VB_UserMemId = -4
End Function

Public Property Get pRect&()
End Property

Private Declare Sub MoveMemory Lib "Kernel32" Alias "RtlMoveMemory" _
    (pDest As Any, pSrc As Any, ByVal cbLen&)

Private bInit&
Private WithEvents mLb As MSForms.Label
Private aa!, bb!, fmWidth!, fmHeight!
Private mX!, mY!, mWidth!, mHeight!
Private mFm As [_UserForm]
Private mStr$, mPtr&
Event PosChange(ByVal n&, ByVal HmX&, ByVal HmY&)

Public Sub Attach(ByVal AttachTo As [_UserForm], ByVal Name$)
    If bInit Then Exit Sub
    Set mFm = AttachTo
    mStr = Name
    With mFm
        fmWidth = .InsideWidth
        fmHeight = .InsideHeight
        Set mLb = .Controls.Add("Forms.Label.1")
    End With
    
    With mLb
        .Height = 20
        .Width = 70
        mHeight = .Height
        mWidth = .Width
        .Name = ObjPtr(mLb)
        .Caption = mStr
        .BackColor = vbWhite
        .ForeColor = vbBlue
        .TextAlign = fmTextAlignCenter
        .SpecialEffect = fmSpecialEffectEtched
    End With
    bInit = 1
End Sub

Public Property Get Parent() As clsContainer
    Set Parent = ObjFromPtr(Val(mLb.Tag))
End Property

Public Property Set Parent(ByVal RHS As clsContainer)
    Dim buf&, tmp As clsContainer
    Dim IColl As ICollection
    If bInit = 0 Then Exit Property
    
    Set IColl = RHS
    buf = Val(mLb.Tag)
    If IColl Is Nothing Then
        If buf Then
            Set IColl = ObjFromPtr(buf)
            IColl.Remove Me
            mLb.Tag = vbNullString
            Set tmp = IColl
            If GetIDispatch(mFm).Visible Then tmp.Flush
        End If
        
    Else
        If ObjPtr(RHS) <> buf Then
            If IColl.Add(Me) Then
                mLb.Tag = ObjPtr(RHS)
                If buf Then
                    Set IColl = ObjFromPtr(buf)
                    IColl.Remove Me
                    Set tmp = IColl
                    tmp.Flush
                End If
            Else
                If buf Then
                    Set tmp = ObjFromPtr(buf)
                    tmp.Flush
                Else
                    SetPos mX, mY
                End If
            
            End If
        End If
        RHS.Flush
    End If
    
End Property

Public Property Get Name$()
    Name = mStr
End Property

Public Sub SetPos(ByVal X!, ByVal Y!)
    If bInit = 0 Then Exit Sub
    mLb.Move X, Y

End Sub

Public Property Get Height!()
    If bInit = 0 Then Exit Property
    Height = mLb.Height
End Property

Public Property Get Width!()
    If bInit = 0 Then Exit Property
    Width = mLb.Width
End Property

Private Sub Class_Terminate()
    If bInit = 0 Then Exit Sub
    mFm.Controls.Remove mLb.Name
    bInit = 0
End Sub

Private Sub mLb_MouseDown _
        (ByVal Button%, ByVal Shift%, ByVal X!, ByVal Y!)
        
    If Button <> 1 Then Exit Sub
    aa = X: bb = Y
    Set GetIDispatch(mFm).cls = Me
    With mLb
        If Val(.Tag) = 0 Then
            mX = .Left: mY = .Top
        End If
        .ZOrder 0
        .BackColor = vbYellow
        .SpecialEffect = fmSpecialEffectBump
    End With
End Sub

Private Sub mLb_MouseMove _
        (ByVal Button%, ByVal Shift%, ByVal X!, ByVal Y!)
    Dim ma!, mb!, e
    Dim tmp&, Ctnr As clsContainer
    If Button <> 1 Then Exit Sub
    With mLb
        ma = .Left + X - aa
        mb = .Top + Y - bb
        If ma < 0 Then ma = 0
        If mb < 0 Then mb = 0
        If ma + mWidth > fmWidth Then
            ma = fmWidth - mWidth
        End If
        If mb + mHeight > fmHeight Then
            mb = fmHeight - mHeight
        End If
        .Move ma, mb
        RaiseEvent PosChange(0, Hm(ma + X), Hm(mb + Y))
    
    End With
    
End Sub

Private Sub mLb_MouseUp _
        (ByVal Button%, ByVal Shift%, ByVal X!, ByVal Y!)
    Dim tmp&
    Dim ptr&, buf&
    If Button <> 1 Then Exit Sub
    With mLb
        .BackColor = vbWhite
        .SpecialEffect = fmSpecialEffectEtched
    End With
    With mLb
        RaiseEvent PosChange(1, Hm(.Left + X), Hm(.Top + Y))
    End With

End Sub

Private Function GetIDispatch(ByVal unk As IUnknown) As Object
    Set GetIDispatch = unk
End Function

Private Sub AddTo(ByVal Ctn As ICollection)
    If Ctn Is Nothing Then Exit Sub
    Ctn.Add Me
End Sub

Private Sub RemoveFrom(ByVal Ctn As ICollection)
    Ctn.Remove Me
End Sub

Private Function Hm&(ByVal m!)
    Hm = m * 2540! \ 72!
End Function

Private Function ObjFromPtr(ByVal ptr&) As clsContainer
    Dim tmp As clsContainer
    MoveMemory tmp, ptr, 4
    Set ObjFromPtr = tmp
    MoveMemory tmp, 0&, 4
End Function

Private mFm As [_UserForm]
Private bInit As Long, mName$
Private mLb As ILabelControl, mLbTtl As ILabelControl
Private mRect&(3), mMaxCnt&
Private mCol As Collection
Implements IRect
Implements ICollection
Event Alert(ByVal mCnt&)

Private Sub Class_Initialize()
    Set mCol = New Collection
End Sub

Private Sub Class_Terminate()
    Dim i&
    If bInit = 0 Then Exit Sub
    With mFm.Controls
        .Remove mLb.Name
        .Remove mLbTtl.Name
    End With
    For i = 1 To mCol.Count
        mCol.Remove 1
    Next
    Set mCol = Nothing
    
End Sub

Public Sub Attach(ByVal AttachTo As [_UserForm], ByVal Name$)
    Dim buf&
    If bInit Then Exit Sub
    Set mFm = AttachTo
    Set mLbTtl = mFm.Controls.Add("Forms.Label.1")
    With mLbTtl
        .Name = ObjPtr(mLbTtl)
        .Caption = Name
        .ForeColor = vbWhite
        .BackColor = &H800000
        .TextAlign = fmTextAlignCenter
        .SpecialEffect = fmSpecialEffectEtched
    End With
    
    Set mLb = mFm.Controls.Add("Forms.Label.1")
    With mLb
        .BackColor = vbWhite
        .Name = ObjPtr(mLb)
        .SpecialEffect = fmSpecialEffectEtched
    End With
    mName = Name
    bInit = 1
    GetRect mLb
End Sub

Public Sub SetPos(ByVal X!, ByVal Y!, Optional ByVal Width!, Optional ByVal Height!)
    If bInit = 0 Then Exit Sub
    mLb.Move X, Y, Width, Height
    mLbTtl.Move X, Y - mLbTtl.Height, Width
    GetRect mLb
End Sub

Public Property Let MaxCount(ByVal RHS&)
    If bInit = 0 Then Exit Property
    mMaxCnt = RHS
End Property

Public Property Get MaxCount&()
    If bInit = 0 Then Exit Property
    MaxCount = mMaxCnt
End Property

Public Sub Flush()
    Dim IColl As ICollection
    Dim e As clsItem, X!, Y!, mX!, mY!
    
    If bInit = 0 Then Exit Sub
    
    Set IColl = Me
    mX = mLb.Left: mY = mLb.Top
    X = mX: Y = mY
    For Each e In IColl
        If Y >= mY + mLb.Height Then
            Y = mY: X = mX + e.Width
        End If
        e.SetPos X, Y
        Y = Y + e.Height
    Next
End Sub

Public Sub HiLite(ByVal f As Long)
    If bInit = 0 Then Exit Sub
    With mLb
        If f Then
            If .BorderStyle = fmBorderStyleSingle Then Exit Sub
            .BorderStyle = fmBorderStyleSingle
            .BorderColor = vbBlue
        Else
            If .SpecialEffect = fmSpecialEffectEtched Then Exit Sub
            .SpecialEffect = fmSpecialEffectEtched
        End If
    End With
    
End Sub

Public Property Get Name$()
    Name = mName
End Property

Private Sub GetRect(ByVal ctl As IControl)
    Dim buf&
    If bInit = 0 Then Exit Sub
    With ctl
        .[_GetLeft] mRect(0)
        .[_GetTop] mRect(1)
        .[_GetWidth] mRect(2)
        .[_GetHeight] mRect(3)
    End With
    mRect(2) = mRect(2) + mRect(0)
    mRect(3) = mRect(3) + mRect(1)
    
End Sub

Private Function ICollection_Add(Item)
    Dim cls As clsItem
    If IsItemFull Then
        RaiseEvent Alert(mMaxCnt)
        Exit Function
    End If
    Set cls = Item
    mCol.Add cls, CStr(ObjPtr(cls))
    ICollection_Add = 1
End Function

Private Function ICollection_Count() As Long
    ICollection_Count = mCol.Count
End Function

Private Function IsItemFull() As Long
    If mMaxCnt = 0 Then Exit Function
    IsItemFull = mCol.Count = mMaxCnt
End Function

Private Function ICollection_Item(Index)
    ICollection_Item = mCol(Index)
End Function

Private Function ICollection_NewEnum() As IUnknown
    Set ICollection_NewEnum = mCol.[_NewEnum]
End Function

Private Sub ICollection_Remove(Index)
    Select Case VarType(Index)
        Case vbObject: mCol.Remove CStr(ObjPtr(Index))
        Case vbLong: mCol.Remove Index
    End Select

End Sub

Private Property Get IRect_pRect() As Long
    IRect_pRect = VarPtr(mRect(0))
End Property

Private Function GetIDispatch(ByVal unk As IUnknown) As Object
    Set GetIDispatch = unk
End Function

こちらが実際のUserformに乗せるコード。
同じく、部品なしのUserformだけ用意。（部品は、みそじのおじさん さんと同構成）
 
# 二日で出来上がったコードなので、バグありかも。。。（汗）
 

Private Declare Function PtInRect& Lib "User32" _
    (ByVal lprc&, ByVal X&, ByVal Y&)
    
Public WithEvents cls As clsItem
Private WithEvents Ctnr As clsContainer
Private WithEvents mCmd As MSForms.CommandButton
Private mText As MSForms.TextBox

Private colCtnr As Collection
Private colItem As Collection

Private Sub UserForm_Initialize()
    Dim i&, e
    Dim oItem As MSForms.Label
    Dim S As String * 12
    
    Set colCtnr = New Collection
    Set colItem = New Collection
    
    Width = 640!
    Height = 320!
    i = 20
    For Each e In Array("Moug", _
                        "ExcelVBA講座", _
                        "AccessVBA講座", _
                        "WordVBA講座")
        S = e
        Set Ctnr = New clsContainer
        Ctnr.Attach Me, S
        Ctnr.SetPos i, 30, 140, 100
        colCtnr.Add Ctnr, S
        i = i + 150
    Next
    
    colCtnr(2).MaxCount = 3 'ExcelVBA
    colCtnr(3).MaxCount = 4 'AccessVBA
    
    For Each e In Array("yayadonさん", _
                        "ろひさん", _
                        "simpleさん", _
                        "月さん", _
                        "ゴマさん", _
                        "kumattiさん", _
                        "YU-TANGさん", _
                        "Kanabunさん", _
                        "Abyssさん", _
                        "みそじのおじさん")
        Set cls = New clsItem
        cls.Attach Me, CStr(e)
        Set cls.Parent = colCtnr(1) ' Moug
        colItem.Add cls
    Next
    FlushAll
    
    Set mCmd = Me.Controls.Add("Forms.CommandButton.1")
    With mCmd
        .Move 20, 140, 50, 20
        .Caption = "決定"
    End With
    
    ''グループ分け結果の表示用テキストボックス作成
    Set mText = Controls.Add("Forms.TextBox.1")
    With mText
        .Move 80, 160, 150, 120
        .SpecialEffect = fmSpecialEffectEtched
        .MultiLine = True
    End With
    
    ''見出しのラベル作成
    Set oItem = Me.Controls.Add("Forms.Label.1")
    With oItem
        .Move 80, 140, 150, 20
        .SpecialEffect = fmSpecialEffectEtched
        .Caption = "グループ分け結果"
        .TextAlign = fmTextAlignCenter
        
    End With
    
End Sub

Private Sub UserForm_Terminate()
    Set cls = Nothing
    Set Ctnr = Nothing
    
    Set colCtnr = Nothing
    Set colItem = Nothing
End Sub

Private Sub cls_PosChange(ByVal n&, ByVal HmX&, ByVal HmY&)
    Dim e As clsContainer
    Dim IColl As ICollection
    Dim i&, j&, iOrder&, tmp&, flag&

    If colCtnr Is Nothing Then Exit Sub
    If colCtnr.Count = 0 Then Exit Sub
    
    If n Then   ' MouseUpイベント時
        For Each e In colCtnr
            e.HiLite 0
            If CheckInRect(e, HmX, HmY) Then
                Set Ctnr = e
                Set cls.Parent = e
                flag = 1
                Exit For
            End If
        Next
        If flag = 0 Then
            Set cls.Parent = Nothing
        End If
        Exit Sub
    End If
    
    ' MouseMoveイベント時
    For Each e In colCtnr
        e.HiLite CheckInRect(e, HmX, HmY)
    Next

End Sub

Private Sub Ctnr_Alert(ByVal mCnt As Long)
    MsgBox "限度Item数 = " & mCnt
    
End Sub

Private Function CheckInRect&(ByVal m As IRect, ByVal X&, ByVal Y&)
    CheckInRect = PtInRect(m.pRect, X, Y)
End Function

Private Sub FlushAll()
    Dim e As clsContainer
    For Each e In colCtnr
        e.Flush
    Next
End Sub

Private Sub mCmd_Click()
    Dim IColl As ICollection
    Dim e As clsContainer
    Dim m As clsItem
    Dim S() As String
    Dim i As Long
    
    ReDim S(1 To colItem.Count)
    
    For Each e In colCtnr
        Set IColl = e
        For Each m In IColl
            i = i + 1
            S(i) = e.Name & vbTab & m.Name
        Next
    Next
    For Each m In colItem
        If m.Parent Is Nothing Then
            i = i + 1
            S(i) = Space$(15) & vbTab & m.Name
        End If
    Next
    mText.Text = Join(S, vbCr)
            
End Sub

月 さんの引用:
クラスを作ると、どうやって再利用しようか考えますよね。クラス群専用のExcelファイルを作って参照設定するのが本筋なんですかね。その際、Instancingプロパティも合わせて考える必要がありますよね。というか、本当は順番が逆で、Instancingプロパティをどうするかを決めてクラスを作るのかなぁと。この辺詳しい方いましたらノウハウを教えてください。

▼月さん
お気使いありがとうございます。雰囲気は十分味わえております^^
 
▼Abyssさん
「すごい！」の一言です^^
これまでのスレッドの流れをすべて取り入れて頂いたかのような構成！じっくり研究させて頂きます。
・Attribute
・弱参照
・Implements
・クラス同士の関係
 
# Abyssさんのお名前で検索しwebを探索した事もありましたが、ここまで本気のコードを
　書かれているはかなり珍しいのではないのでしょうか？（笑）
 
▼どんきちさん
私も、みなさんの判断基準にかなり興味があります。
Instancingプロパティについての話題は質問板では皆無ですのでぜひ引き続きよろしく
お願い致します。
私自身は、社外への配布が主ですので「クラスを別Bookにする」に若干抵抗があります^^
みなさんはどうさているのでしょうか？

> Abyssさんのクラス
 
確かにラベル消失が、改善されてますね。
# 感想だけで失礼。

どんきち さんの引用:
クラスを別のプログラムを採用したいけれど、わざわざ別ブックに分ける必要がないのであれば、一つ一つのクラスの独立性をできるだけ高くしておいて、エクスポート機能でテキストファイルに出力したあとで、別ファイルでインポート機能で取り込めば済む話のような気もします。

補足
 

Abyss さんの引用:
○ ICollection Interface

Public Function Item(Index)
Attribute Item.VB_UserMemId = 0
End Function
Public Function Add(Item)
End Function
Public Function Count&()
End Function
Public Sub Remove(Index)
End Sub
Public Function NewEnum() As IUnknown
Attribute NewEnum.VB_UserMemId = -4
End Function

月さん、ありがとうございます。
 
# 今自分のコードを確認してたら、ゴミが数箇所に渡って残っていますね。
　当初、頭で描いていたのが実際には現れてないのがそのゴミです。
 
別話題にないますが、こちら
http://www.moug.net/faq/viewtopic.php?t=62502
のトピックも OSが用意している「DateTime Picker」、「Calendar Control」が
使えるようにクラスへの取入れるのもクラスの活用法ですね。
ややこしいWindows APIはクラスの内部に隠蔽して置き、必要な部分だけ
イベントなり、Publicメソッドにて公開しておくとか。
タイミングを図ってこれもコード化してみたいと思います。
とりあえずは、Calendar Controlかな。。。
 

こんばんは。今日は多少早く帰って来られました^^
 
APIのラッパー系だと過去にこんなのを作った事がありました。
別板で申し訳ありませんが、
 
FontDialogを呼び出すクラス
http://excelfactory.net/excelboard/excelvba/cfs.cgi?word=143081&andor=and&logs=23.txt
（クラス内のコードは示しませんでしたが、Abyssさんにもご参加頂きました^^）
 
これは現在でもExcelやAccessに頻繁にインポートして使っております。
UserにFontを選択してもらい適切な場所に選択情報を保存し、それ以降選択した
Fontの種類、サイズで文字を表示する（ExcelだとUserForm AccessではFormに適用）
というように利用しております。
 
作成する時は随分悩みましたが、出来てしまえばとても使い回しがよく重宝しております^^
 
 

参照関係が３階層のときのPublicなクラスの参照(1)
 
プロジェクト参照するときに、参照関係は一方通行で、循環参照や相互参照はできないなどなど、注意しないといけないことが結構あるのですが、そういったことはひとまずおいといて、プロジェクト参照をすると何ができて何ができないかを調べてみました。
 
A.xls、B.xls、C.xlsの３つのワークブックの参照関係が以下のようになっているとします。
A.xlsでB.xlsを参照し、B.xlsでC.xlsを参照しています。
クラスのinstancingプロパティは厳密には「Private」と「PublicNotCreatable」ですが、ここでは便宜上、PublicとPrivateと記述します。
 
コードはベタうちなのでタイプミスがあるかもしれません。
 
●ワークブック　A.xls
　VBAプロジェクト名 ProjA
　参照設定　B.xls
　'***** Publicなクラス clsA *****　
　Option Explicit
　'別ブックに定義してあるクラス
　Public ObjB As clsB
　Public StrA As String
 
　'***** 標準モジュール　modA *****　
  Option Explicit
　Public Function Init1() As clsA
      Dim objA as clsA
      Set objA = New clsA
　　　'別ブックに定義してあるクラス
　　　'のインスタンスの生成
　　　Set objA .ObjB = modB.Init1
      Set Init1 = objA
　End Function
 
●ワークブック　B.xls
　VBAプロジェクト名 ProjB
　参照設定　C.xls
　'***** Publicなクラス clsB *****　
  Option Explicit
　'別ブックに定義してあるクラス
　Public ObjC As clsC
　Public StrB As String
 
　'***** 標準モジュール　modB *****　
  Option Explicit
  '別ブックのクラスは直接Newできないため
　'対象クラスが存在するワークブック内の
  '標準モジュール経由でインスタンスを生成
　Public Function Init1() As clsB
      Dim objB As clsB
      Set objB = New clsB
　　　'別ブックに定義してあるクラス
　　　'のインスタンスの生成
      Set objB.ObjC = modC.Init1
      Set Init1 = objB
　End Function
 
●ワークブック　C.xls
　VBAプロジェクト名 ProjC
　'***** Publicなクラス clsC *****　
  Option Explicit
　Public StrC As String
 
　'***** 標準モジュール　modC *****　
  Option Explicit
  '別ブックのクラスは直接Newできないため
　'対象クラスが存在するワークブック内の
  '標準モジュール経由でインスタンスを生成
　Public Function Init1() As clsC
      Dim objC as clsC
      Set objC = New clsC
      Set Init1 = objC
　End Function
 
●調査結果
このときにA.xlsでclsAのインスタンスを生成してプロパティを利用するときに以下のような結果になります。
  '*** 以下の処理はコンパイルエラー ****
  'clsBはPublicなクラスであり
　'A.xlsではB.xlsを直接参照しているため、
  'clsBというクラス名を直接記述することができるが
　'インスタンスを生成することはできない
　Dim objB As clsB 'OK
　Set objB = New clsB 'NG
 
  '*** 以下の処理は正常終了 ****
　Dim objA As clsA
  Set objA = modA.Init1
  objA.StrA = "1" 'OK
  objA.ObjB.StrB = "XXX" 'OK
　'A.xlsではC.xlsを直接参照していないが
　'clsCはPublicなクラスであるため、
　'プロパティ経由で利用することは可能
  objA.ObjB.ObjC.StrC = "xxx" 'OK
 
  '*** 以下の処理は正常終了 ****
　Dim objA As clsA
　'A.xlsではB.xlsを直接参照しているため
  'clsBというクラス名を直接記述することが可能
　Dim objB As clsB 'OK
  Set objA = modA.Init1 'OK
  Set objB = objA.ObjB 'OK
　
  '*** 以下の処理はコンパイルエラー ****
　Dim objA As clsA
　'A.xlsではC.xlsを直接参照していないため
  'clsCというクラス名を直接記述するとコンパイルエラー
　Dim objC As clsC 'NG
 
  '*** 以下の処理は正常終了 ****
　'A.xlsではC.xlsを直接参照していないが
　'clsC自身はPublicであるため、
  'Object型の変数で利用することが可能。
  'Object型なのでプロパティ名やメソッド名を間違えてもコンパイルエラーにならないし
　'VBEのメンバ参照のクイックヒント機能も働かない。
　Dim objA As clsA
　Dim objO As Object
  Set objA = modA.Init1
  Set objO = objA.ObjB.ObjC 　
  objO.PrpC = "xxx"

参照関係が３階層のときのPublicなクラスの参照(2)
 
 
前回のA.xls、B.xls、C.xlsの３つのワークブックの参照関係を以下のように変えると結果が変わります。
A.xlsでB.xls、C.xlsを参照し、B.xlsでC.xlsを参照する。
 
コードはベタうちなのでタイプミスがあるかもしれません。
 
●ワークブック　A.xls
　VBAプロジェクト名 ProjA
　参照設定　B.xls , C.xls
　'***** Publicなクラス clsA *****　
　Option Explicit
　'別ブックに定義してあるクラス
　Public ObjB As clsB
　Public StrA As String
 
　'***** 標準モジュール　modA *****　
  Option Explicit
　Public Function Init1() As clsA
      Dim objA as clsA
      Set objA = New clsA
　　　'別ブックに定義してあるクラス
　　　'のインスタンスの生成
　　　Set objA .ObjB = modB.Init1
      Set Init1 = objA
　End Function
 
●ワークブック　B.xls
　VBAプロジェクト名 ProjB
　参照設定　C.xls
　'***** Publicなクラス clsB *****　
  Option Explicit
　'別ブックに定義してあるクラス
　Public ObjC As clsC
　Public StrB As String
 
　'***** 標準モジュール　modB *****　
  Option Explicit
  '別ブックのクラスは直接Newできないため
　'対象クラスが存在するワークブック内の
  '標準モジュール経由でインスタンスを生成
　Public Function Init1() As clsB
      Dim objB As clsB
      Set objB = New clsB
　　　'別ブックに定義してあるクラス
　　　'のインスタンスの生成
      Set objB.ObjC = modC.Init1
      Set Init1 = objB
　End Function
 
●ワークブック　C.xls
　VBAプロジェクト名 ProjC
　'***** Publicなクラス clsC *****　
  Option Explicit
　Public StrC As String
 
　'***** 標準モジュール　modC *****　
  Option Explicit
  '別ブックのクラスは直接Newできないため
　'対象クラスが存在するワークブック内の
  '標準モジュール経由でインスタンスを生成
　Public Function Init1() As clsC
      Dim objC as clsC
      Set objC = New clsC
      Set Init1 = objC
　End Function
 
●調査結果
A.xlsでclsAのインスタンスを生成してプロパティを利用したときの
結果は前回とほぼ同じですが、前回はできなかった以下の操作が可能になります。
　
  '*** 以下の処理はコンパイルエラー ****
　Dim objA As clsA
　'A.xlsではC.xlsを直接参照しているため
  'clsCというクラス名を直接記述することが可能
　Dim objC As clsC 'OK
  Set objA = modA.Init1 'OK
　Set objC = objA.ObjB.ObjC 'OK　
 

yayadon さんの引用:
そんな感じにすれば，
clsMoveItems 内の mParent は必要でなくなり,
弱参照のようなややこしい仕組みは必要なくなります。たぶん。

今のところの出来コードです。
 
# 部品として使う前提で、なるべく別モジュールは使わない方向で考えているが、
　どうしてもSubclassへの関数ポインタを正確に確保するため、Interfaceを
　使用しています。IUnknown(3関数）+ IDispath（4関数）の直後にWndProcを
　置きますので、IProc Interfaceの WndProc関数は、必ず最初に位置するのを
　前提とします。その上、AddressOfの為の標準モジュールを使っていませんので
　スタックフレームを直接見るためアセンブリコードを使っています。
　そのため、暗号のような部分が存在しますが、行っているのは単純なことです。
 
# SysMonthCal32 Windowとのメッセージのやり取りのため、Containerウィンドウは
　UserformのFrameコントロールにしています。
# FontはFrameコントロールのFont設定に従うようにしています。
# 取りあえず、日曜日を太字にしていますが、祭日などの太字も工夫次第。
# DateTime Pickerコントロールも同様の理屈で可能だと思います。
 
○ クラスモジュール(IProc) 骨組みのみ

Public Function WndProc&(ByVal Hwnd&, ByVal uMsg&, _
                            ByVal wParam&, ByVal lParam&)
End Function

Private Declare Function InitCommonControlsEx& Lib "Comctl32" _
    (ByVal lpInitCtrl&)
Private Declare Function CreateWindowExW& Lib "User32" _
    (ByVal dwExStyle&, _
     ByVal lpClassName&, _
     ByVal lpWindowName&, _
     ByVal dwStyle&, _
     ByVal x&, ByVal y&, _
     ByVal nWidth&, ByVal nHeight&, _
     ByVal hParent&, _
     ByVal hMenu&, _
     ByVal hInstance&, _
     ByVal lParam&)
Private Declare Function GetModuleHandleW& Lib "Kernel32" _
    (ByVal lpModName&)
Private Declare Function GetProcAddress& Lib "Kernel32" _
    (ByVal hMod&, _
     ByVal lpProcName&)
Private Declare Function VirtualAlloc& Lib "Kernel32" _
    (ByVal lpAddr&, _
     ByVal dwSize&, _
     ByVal fType&, _
     ByVal flProtect&)
Private Declare Function VirtualFree& Lib "Kernel32" _
    (ByVal lpAddr&, _
     ByVal dwSize&, _
     ByVal dwFreeType&)
Private Declare Function SetWindowLongW& Lib "User32" _
    (ByVal Hwnd&, _
     ByVal nIndex&, _
     ByVal dwNewLong&)
Private Declare Function GetWindowLongW& Lib "User32" _
    (ByVal Hwnd&, _
     ByVal nIndex&)
Private Declare Function CallWindowProcW& Lib "User32" _
    (ByVal lpPrevWndFunc&, _
     ByVal Hwnd&, _
     ByVal uMsg&, _
     ByVal wParam&, _
     ByVal lParam&)
Private Declare Function GetFocus& Lib "User32" ()
Private Declare Sub MoveMemory Lib "Kernel32" Alias "RtlMoveMemory" _
    (pDest As Any, _
     pSrc As Any, _
     ByVal cbLen&)
Private Declare Function SendMessageW& Lib "User32" _
    (ByVal Hwnd&, _
     ByVal uMsg&, _
     ByVal wParam&, _
     ByVal lParam&)
Private Declare Function MoveWindow& Lib "User32" _
    (ByVal Hwnd&, _
     ByVal x&, ByVal y&, _
     ByVal nWidth&, ByVal nHeight&, _
     ByVal bRepaint&)
Private Declare Function SetFocusVB& Lib "User32" Alias "SetFocus" _
    (ByVal Hwnd&)

Private Const GWL_WNDPROC = -4
Private Const MEM_RELEASE = &H8000&
Private Const MEM_COMMITRESERVE = &H3000&
Private Const PAGE_EXECUTE_READWRITE = &H40&
Private Const ICC_DATE_CLASSES = &H100&
Private Const WM_SETFOCUS = 7
Private Const WM_MOUSEACTIVATE = &H21
Private Const WM_SETFONT = &H30
Private Const WM_NOTIFY = &H4E
Private Const WM_NCDESTROY = &H82
Private Const WS_CHILD = &H40000000
Private Const WS_VISIBLE = &H10000000
Private Const MCS_DAYSTATE = 1
Private Const GMR_VISIBLE = 0
Private Const MCM_SETCOLOR = &H100A
Private Const MCM_GETMINREQRECT = &H1009
Private Const MCM_GETMAXTODAYWIDTH = &H1015
Private Const MCM_GETMONTHRANGE = &H1007
Private Const MCM_SETDAYSTATE = &H1008
Private Const MA_NOACTIVATE = 3
Private Const WS_CLIPSIBLINGS = &H4000000
Private Const WS_EX_CLIENTEDGE = &H200&

Private Type TT
    hParent As Long
    hChild As Long
    pp As Long
    dDate As Date
End Type

Private Type DD
    m(2) As Long
End Type

Private TT As TT, acc As IAccessible, flg&, pPrev&
Event DateChange(ByVal dDate As Date)
Implements IProc

Private Sub Class_Initialize()
    TT.dDate = Date
End Sub

Public Property Get GetDate() As Date
    GetDate = TT.dDate
End Property

Public Sub Connect(ByVal fr As IOptionFrame)
    Dim Cnt&
    Dim ii&(1), Asm@(7)
    Dim wd&, ht&, hMod&, hProc&, tmp$, ro#, rc&(3)
    Dim fnt As stdole.IFont
    Dim i&, buf&(3)
    Dim DD As DD, Impl As IProc
    
    Asm(0) = 3665925540493.8379@
    Asm(1) = 111355235910746.6612@
    Asm(2) = 585928097174388.7544@
    Asm(3) = 373826806618259.4744@
    Asm(4) = -394872433264837.8176@
    Asm(5) = -36870567463020.0143@
    Asm(6) = 3921298269300.3448@
    Asm(7) = 1842688795.0591@
    Cnt = (UBound(Asm) + 1) * 8
    
    TT.hParent = GetHwnd(fr)
    If TT.hParent = 0 Then Err.Raise 94
    
    Set acc = fr
    Set fnt = fr.Font
    acc.accLocation 0, 0, wd, 0
    ro = fr.Width / wd
    
    ii(0) = 8
    ii(1) = ICC_DATE_CLASSES
    InitCommonControlsEx VarPtr(ii(0))
    
    With TT
        .hChild = CreateWindowExW(WS_EX_CLIENTEDGE, _
                StrPtr("SysMonthCal32"), 0, _
                WS_CHILD Or WS_VISIBLE Or WS_CLIPSIBLINGS Or MCS_DAYSTATE, _
                0, 0, 0, 0, _
                .hParent, 0, 0, 0)
        ' 色変更
        SendMessageW .hChild, MCM_SETCOLOR, 4, &H99FFFF  ' MCSC_MONTHBK
        SendMessageW .hChild, MCM_SETCOLOR, 2, &H808000  ' MCSC_TITLEBK
        ' Font変更
        SendMessageW .hChild, WM_SETFONT, fnt.hFont, 0&
        SendMessageW .hChild, MCM_GETMINREQRECT, 0, VarPtr(rc(0))
        ' 日曜日を太字にする。
        flg = ToBold(.hChild)
        ' 下段の「今日の日付」Width取得
        i = SendMessageW(.hChild, MCM_GETMAXTODAYWIDTH, 0, 0)
        rc(3) = rc(3) + 2
        MoveWindow .hChild, 0, 0, i, rc(3), 0
    
    End With
    
    With fr
        .Width = i * ro
        .Height = rc(3) * ro
    End With
    
    i = VarPtr(Asm(0))
    
    MoveMemory ByVal i + 17, GetWindowLongW(TT.hChild, GWL_WNDPROC), 4
    
    hMod = GetModuleHandleW(StrPtr("User32"))
    tmp = StrConv("CallWindowProcW", vbFromUnicode)
    hProc = GetProcAddress(hMod, StrPtr(tmp))
    MoveMemory ByVal i + 25, hProc, 4
    
    Set Impl = Me
    MoveMemory ByVal i + 49, ObjPtr(Impl), 4

    i = VirtualAlloc(0, Cnt, MEM_COMMITRESERVE, PAGE_EXECUTE_READWRITE)
    MoveMemory ByVal i, Asm(0), Cnt
    With TT
        .pp = i
        SetWindowLongW .hChild, GWL_WNDPROC, .pp
        pPrev = SetWindowLongW(.hParent, GWL_WNDPROC, .pp + 31)
    End With

End Sub

Private Sub Class_Terminate()
    VirtualFree TT.pp, 0, MEM_RELEASE
End Sub

Private Function IProc_WndProc&(ByVal Hwnd&, ByVal uMsg&, _
                            ByVal wParam&, ByVal lParam&)
    Dim m%(7), Cd&
    
    ' Frame Window
    If Hwnd = TT.hParent Then
        Select Case uMsg
            Case WM_SETFOCUS
                SetFocusVB TT.hChild
                Exit Function
            
            Case WM_NOTIFY
                MoveMemory Cd, ByVal lParam + 8, 4
                If Cd = -749 Then  'MCN_SELCHANGE
                    MoveMemory m(0), ByVal lParam + 12, 8
                    MoveMemory Cd, m(0), 4
                    If Cd <> flg Then
                        flg = Cd
                        ToBold TT.hChild
                    End If
                    
                    With TT
                        .dDate = DateSerial(m(0), m(1), m(3))
                        RaiseEvent DateChange(.dDate)
                    End With
                    Exit Function
                End If
        End Select
        IProc_WndProc = CallWindowProcW(pPrev, Hwnd, uMsg, wParam, lParam)
        
    ' SysMonthCal32 Window
    Else
    
        Select Case uMsg
            Case WM_MOUSEACTIVATE
                If GetFocus() <> Hwnd Then
                    acc.accSelect 16&
                    acc.accSelect 1&
                    IProc_WndProc = MA_NOACTIVATE
                End If
            
        End Select
    
    End If
    
End Function

Private Function GetHwnd&(ByVal ctl As MSForms.IControl)
    GetHwnd = ctl.[_GethWnd]
End Function

Private Function ToBold&(ByVal Hwnd&)
    Dim m%(15), aa&(2)
    Dim p&, i&, buf&, mDay&, w&
    
    p = VarPtr(m(0))
    If SendMessageW(Hwnd, MCM_GETMONTHRANGE, GMR_VISIBLE, p) = 0 Then
        Exit Function
    End If
    
    MoveMemory ToBold, m(0), 4
    ' VBA曜日取得関数があるので手抜き...
    w = Weekday(DateSerial(m(0), m(1), m(3)), vbMonday)
    buf = (7 - w) Mod 7
    For i = 0 To 4
        mDay = buf + 7 * i
        If mDay < 31 Then
            aa(1) = aa(1) Or 2 ^ mDay
        End If
    Next
    SendMessageW Hwnd, MCM_SETDAYSTATE, 3, VarPtr(aa(0))

End Function

Private oo As UserForm1
Private WithEvents cls As clsMonthCal
Private WithEvents Btn As MSForms.CommandButton
Private mDt As Date

Private Sub Btn_Click()
    MsgBox mDt
End Sub

Private Sub UserForm_Initialize()
    Dim fr As IOptionFrame
    Set fr = Controls.Add("Forms.Frame.1")
    With fr.Font
        .Name = "MS PGothic"
        .Size = 10
    End With
    
    Set cls = New clsMonthCal
    cls.Connect fr
    
    Set Btn = Controls.Add("Forms.CommandButton.1")
    With fr
        .Move 5, 5
        Width = .Width + 10 + (Width - InsideWidth)
        Btn.Top = .Top + .Height + 4
        Btn.Width = .Width
        Btn.Left = .Left
    End With
    With Btn
        .Caption = "日付確認"
        Height = .Top + .Height + 5 + (Height - InsideHeight)
    End With
    mDt = cls.GetDate
    Caption = mDt
    ' 通常、モードレスFormの場合、Excelの最小化で
    ' Userformが見えなくなる不具合のおまじない。
    Set oo = Me
End Sub

Private Sub cls_DateChange(ByVal dDate As Date)
    mDt = dDate
    Caption = mDt
End Sub

モードレス時にも問題ないようにしています。
標準モジュールで
 
  With new userform1
      .show 0
  End with
 
# さすがに、疲れますね。（笑）

# イベントのところで
# VBA では，覚える必要の無い Advise/Unadvise というメソッドの説明を抜きに
# 参照の解放の手順をやったために，
# 説明が一部間違っていました(汗)。
 
 
 
イベントを利用する側とイベントを提供する側の関係は，
以下のようになります。
 
 
　　　　　　　　　イベントを利用する
　　　　　　　　　　オブジェクト
　　　　　　　　　　　：　 　│
　ref count: 1　sink object　│
　　　　　　　　　↑　　　　 │
　　　　　　　　 参照　　　 参照
　　　　　　　　　│　　　　 ↓
　　　　　　　　イベントを提供する
　　　　　　　　　オブジェクト　ref count: 1
 
 
この図だけ見ると，下へ向かう参照が無くなった時，
 
 
　　　　　　　　　イベントを利用する
　　　　　　　　　　オブジェクト
　　　　　　　　　　　：　
　ref count: 1　sink object
　　　　　　　　　↑　　　　
　　　　　　　　 参照　　　
　　　　　　　　　│　　　　
　　　　　　　　イベントを提供する
　　　　　　　　　オブジェクト　ref count: 0
 
 
[イベントを提供するオブジェクト] の ref count が 0 になったことにより，
sink object に対して Release を呼ぶように見えます。
 
今読み返すと，先にそのように説明してしまいました(汗)。
 
そのように，
先に [イベントを提供するオブジェクト] への参照を解放してしまうと，
[イベントを利用するオブジェクト] 側が
[イベントを提供するオブジェクト] の参照を持っていないために，
[イベントを提供するオブジェクト] の Unadvise メソッドが呼べなくなってしまいます。
 
なので，
このような実装はありえないですし，
念のため，先ほど，自作の COM オブジェクトを使って，
VBA の WithEvents での実装を確認してみましたが，
ちゃんと，先に Unadvise を呼んでいました。
 
 
なので，
VBA では覚える必要の無い Advise/Unadvise というメソッドの仕組みを簡単に説明します。
-----
イベントへの登録と解除は
 IConnectionPoint インターフェース と呼ばれているもののメソッド達を通じて行います。
 
[イベントを提供するオブジェクト] は，
IConnectionPoint インターフェースの
 Advise メソッドと Unadvise メソッドというものを公開しています。
 
[イベントを利用するオブジェクト] は，
利用開始時に Advise メソッドを呼び出し，
利用終了時に Unadvise メソッドを呼び出します。
 
Advise メソッドでは，
[イベントを利用するオブジェクト] は，
sink object の参照(IUnknown インターフェース)を渡して，
[イベントを提供するオブジェクト] から
 ある値 (番号札のようなもの/cookie) を受け取ります。
その値は，[イベントを提供するオブジェクト] が，
[イベントを利用するオブジェクト] を区別するために使う値です。
 
Unadvise メソッドでは，
[イベントを利用するオブジェクト] は，
利用開始時に Advise メソッドで受け取った その値 を引数に渡して呼び出します。
[イベントを提供するオブジェクト] は，
その値で，どのイベントの利用者が利用を終えたのか？がわかります。
握っていた sink object の参照を Release し，通知する対象から外します。
-----
 
 
VBA だと，よくあるパターンの以下のようにした場合
 

WithEvents m_obj As Class1
'-----
Private Sub Class_Initialize()
    Set m_obj = New Class1             ' A
End Sub

Private Sub Class_Terminate()
    Set m_obj = Nothing                ' B
End Sub

WithEvents m_objA As Class1
Dim m_objB As Class1

月 さんの引用:
mParentを使っている箇所をメソッドからイベントに変更したところ、すべてのクラスのTerminateイベントが発生しました。
明日追記します。

月 さんの引用:
あとで気がついたんですけど、メソッドをイベントに変更しなくても、親オブジェクトを取得するイベントを定義して使い回せばいいんじゃないか、と思い、やってみたら成功しました。あとでこの部分だけを実装したクラスをアップしてわかりやすく説明します。

Abyss さんの引用:
mCol.Add cls, CStr(ObjPtr(cls))

月 さんの引用:
親オブジェクトへの参照を保持せずに親オブジェクトへの参照を得る方法 ― Gist
https://gist.github.com/2041685

> clsMonthCal
loop命令は存在は知っていましたが、実際例はまだ、拝見したことがありませんでした。
勉強になります。

引用:
loop命令は存在は知っていましたが、...

こんにちは。
 

引用:
月 さんの引用:
親オブジェクトへの参照を保持せずに親オブジェクトへの参照を得る方法 ― Gist

　　Dim Parent1 As ParentA
　　Set Parent1 = New ParentA
　　Debug.Print Parent1.Child.Parent.Name
　　                   ^^^^^�@^^^^^^^

〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜
    [ParentA]
　　Private WithEvents m_ChildA As ChildA
　　　　　　　　　　　　　　　　　　　　　　　┌────────┐
┌→Private Sub m_ChildA_GetParent(ByRef argParent As ParentA)　│
│　　　Set argParent = Me　　　　^^^^^^　　↑　　　　　　　　　│
│　　　　　　└──────────────┘　　　　　　　　　│
│　End Sub 　　　　　　　　　　　　　　　　　　　　　　　　　　│
│　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　│
〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜
│　[ChildA]　　　　　　　　　　　　　　　　　　　　　　　　　　│
└────────┐　　　　　　　　　　　　　　　　　　　　　　│
┌→Public Event GetParent(ByRef argParent As ParentA)　　　　　│
│　　　　　　　　　　　　^^^^^^　　　　　　　　　　　　　　　　│
│�@Public Property Get Parent() As ParentA 　　　　　　　　　　│
│　　Dim Temp As ParentA　　　　　　　　　　　　　　　　　　　 │
└─  RaiseEvent GetParent(Temp)　　　　　　　　　　　　　　　　│
　　　Set Parent = Temp 　　↑ 　　　　　　　　　　　　　　　　 │
　　End Property　　　　　　└─────────────────┘


〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜

〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜
    [ParentA]
　　Private WithEvents m_ChildA As ChildA
　　Private Sub m_ChildA_GetParent(ByRef argParent As ParentA)

　　Public Sub xxx ・・・
　　Public Property Get yyy ・・・

〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜
　　[ChildA]
　　Public Event GetParent(ByRef argParent As ParentA)

　　Private Property Get Parent() As ParentA
　　End Property

　　'必要な時に、その都度、親オブジェクトの参照を一時的に取得し、即破棄する。
　　Me.Parent.xxx
　　Me.Parent.yyy
〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜

角田さん、ご質問ありがとうございます。
 

角田 さんの引用:
これは、下記の流れという理解で良いでしょうか？

Function test() As String
    test = "a"
End Function

Public Property Get Parent() As ParentA
    ' 親オブジェクトへの参照を得る
    RaiseEvent Parent(Parent)
End Property

Private Sub m_ChildA_Parent(Parent As ParentA)
    Set Parent = Me
End Sub

角田 さんの引用:
テストプロシジャーから呼ぶ都合で、Parent が Public になっていますが、
話題の内容からすると、実際の利用場面では Private にして ChildA 内での利用に限る
という理解で合っていますでしょうか？

角田 さんの引用:
WithEvents を使う為、この方法は親子が１：１の場合のみ可能で、
親子が１：ｎのケースでは、従来通りに「親オブジェクト参照をクラス内に持つ」
しかない、という理解で良いでしょうか。

会社で今見まして驚きました^^
取り急ぎですが、次のスレッドに進みたいとと思います。
 
ご参加頂いた方々、ROMをして頂いた方ありがとうございます。
 
引き続き、よろしくお願い致します。