Skip to content

@honda0510 /CParentAgent.cls
Created

Embed URL

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
みそじのおじさんのクラス 月修正版http://www.moug.net/faq/viewtopic.php?t=62306
Option Explicit
'***************************************************
'クラス名 clsContainer
'***************************************************
Public Event MaxItemCountOver()
Private WithEvents m_ParentAgent As CParentAgent ' 子から連絡を受ける自分の代理人
Private mMoveItems As clsMoveItems
Private mLabel As MSForms.Label
Private mTitleLabel As MSForms.Label
Public Value As Variant
Private Const cnsTitleHeight As Single = 18
Private Const cnsTitleForeColor As Long = vbWhite
Private Const cnsTitleBackColor As Long = &H800000
Private Const cnsContainerBackColor As Long = vbWhite
Private Sub Class_Initialize()
Dim itfLink As ILink
Set mMoveItems = New clsMoveItems
Set m_ParentAgent = New CParentAgent
' 子と親の代理人をリンクさせる
Set itfLink = mMoveItems
itfLink.Link m_ParentAgent
End Sub
Private Sub Class_Terminate()
Debug.Print "clsContainer_Terminate"
Set mMoveItems = Nothing
Set mLabel = Nothing
Set mTitleLabel = Nothing
Set m_ParentAgent = Nothing
End Sub
Public Sub Init(ByVal Label As MSForms.Label)
Set mLabel = Label
With mLabel
.BackColor = cnsContainerBackColor
.SpecialEffect = fmSpecialEffectEtched
End With
End Sub
Public Property Get MoveItems() As clsMoveItems
Set MoveItems = mMoveItems
End Property
Public Property Get Label() As MSForms.Label
Set Label = mLabel
End Property
Public Function CreateTitle(ByVal Title As String) As Boolean
Set mTitleLabel = _
mLabel.Parent.Controls.Add("Forms.Label.1", "Label" & Title, True)
With mTitleLabel
.Caption = Title
.Left = mLabel.Left
.Top = mLabel.Top - cnsTitleHeight
.Height = cnsTitleHeight
.Width = mLabel.Width
.SpecialEffect = fmSpecialEffectEtched
.ForeColor = cnsTitleForeColor
.BackColor = cnsTitleBackColor
.TextAlign = fmTextAlignCenter
.Font.Bold = True
End With
End Function
Public Property Get Parent() As Object
Set Parent = mLabel.Parent
End Property
Public Property Get Title() As String
Title = mTitleLabel.Caption
End Property
Public Property Let Title(ByVal Title As String)
mTitleLabel.Caption = Title
End Property
Property Get ContainerRect() As Rect
With mLabel
ContainerRect.Left = .Left
ContainerRect.Top = .Top
ContainerRect.Width = .Width
ContainerRect.Height = .Height
End With
End Property
Property Get Name() As Variant
Name = mLabel.Name
End Property
Public Property Get TitleForeColor() As Long
TitleForeColor = mTitleLabel.ForeColor
End Property
Public Property Let TitleForeColor(ByVal lngNewColor As Long)
mTitleLabel.ForeColor = lngNewColor
End Property
Public Property Get TitleBackColor() As Long
TitleBackColor = mTitleLabel.BackColor
End Property
Public Property Let TitleBackColor(ByVal lngNewColor As Long)
mTitleLabel.BackColor = lngNewColor
End Property
Public Sub OverLapEffect()
With mLabel
.BorderStyle = fmBorderStyleSingle
.BorderColor = vbBlue
End With
End Sub
Public Sub UndoOverLapEffect()
mLabel.SpecialEffect = fmSpecialEffectEtched
End Sub
Public Sub Alert()
RaiseEvent MaxItemCountOver
End Sub
' 子から連絡があったら、自分の代理人を通して子と連絡をとる
Private Sub m_ParentAgent_OnConnect(Parent As Object)
Set Parent = Me
End Sub
Option Explicit
'***************************************************
'クラス名 clsContainers
'***************************************************
Private mParent As Object
Private mContainers As Collection
Private Sub Class_Initialize()
Set mContainers = New Collection
End Sub
Private Sub Class_Terminate()
Debug.Print "clsContainers_Terminate"
Set mParent = Nothing
Set mContainers = Nothing
End Sub
Public Function Add( _
ByVal Name As String _
, ByVal Left As Single _
, ByVal Top As Single _
, ByVal Height As Single _
, ByVal Width As Single) As clsContainer
Dim Container As clsContainer
Dim Label As MSForms.Label
Set Container = New clsContainer
Set Label = mParent.Controls.Add("Forms.Label.1", Name, True)
Container.Init Label
With Label
.Left = Left
.Top = Top
.Height = Height
.Width = Width
.SpecialEffect = fmSpecialEffectEtched
End With
mContainers.Add Container, Name
Set Add = Container
End Function
Public Property Get Items() As Collection
Set Items = mContainers
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 = mContainers(CLng(Index) + 1&)
Case "String"
'フィールド名でアクセス
Set Item = mContainers(Index)
End Select
On Error GoTo 0
Err_Trap:
End Property
Public Sub OverLapEffect(ByVal TargetContainer As clsContainer)
Dim Container As clsContainer
For Each Container In mContainers
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 mContainers
Container.UndoOverLapEffect
Next
End Sub
Public Property Get Parent() As Object
Set Parent = mParent
End Property
Public Property Set Parent(Parent As Object)
Me.Parent = Parent
End Property
Public Property Let Parent(Parent As Object)
If mParent Is Nothing Then
Set mParent = Parent
End If
End Property
Option Explicit
'***************************************************
'クラス名 clsMoveItem
'***************************************************
Private WithEvents mLabel As MSForms.Label
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 Sub Init(ByVal Label As MSForms.Label)
Set mLabel = Label
With mLabel
.Height = 20
.Width = 70
.TextAlign = fmTextAlignCenter
.ForeColor = cnsItemForeColor
.BackColor = cnsItemBackColor
.SpecialEffect = fmSpecialEffectEtched
End With
End Sub
Private Sub Class_Terminate()
Debug.Print "clsMoveItem_Terminate"
Set mLabel = Nothing
End Sub
Private Sub mLabel_MouseDown(ByVal Button As Integer, _
ByVal Shift As Integer, _
ByVal x As Single, _
ByVal y As Single)
mCapture = True
With mLabel
.SpecialEffect = fmSpecialEffectBump
.BackColor = vbYellow
End With
o.x = x
o.y = y
OldPositionSet
End Sub
Private Sub mLabel_MouseMove(ByVal Button As Integer, _
ByVal Shift As Integer, _
ByVal x As Single, _
ByVal y As Single)
If Not mCapture Then
Exit Sub
End If
Static p As StructMovePoint
If p.x + mLabel.Width <= mLabel.Parent.InsideWidth Then
If p.x >= 0 Then
If p.y >= 0 Then
If p.y + mLabel.Height - o.y <= mLabel.Parent.InsideHeight Then
With mLabel
.Left = .Left + x - o.x
.Top = .Top + y - o.y
End With
Else
mLabel.Top = mLabel.Parent.InsideHeight - mLabel.Height
End If
Else
mLabel.Top = 0
End If
Else
mLabel.Left = 0
End If
Else
mLabel.Left = mLabel.Parent.InsideWidth - mLabel.Width
End If
p.x = mLabel.Left
p.y = mLabel.Top
mLabel.ZOrder 0
mLabel.Parent.Containers.OverLapEffect OverlapContainer()
End Sub
Private Sub mLabel_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
PositionCheck
End If
mCapture = False
With mLabel
.SpecialEffect = fmSpecialEffectEtched
.BackColor = cnsItemBackColor
End With
mLabel.Parent.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 = mLabel.Parent.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.MoveItems.AddItem(Me)
Select Case ret
Case MoveItemMaxCountOver
ItemRect = OldPositionRect()
Case Else
End Select
Else
Container.MoveItems.RemoveItem Me
End If
Next
Set ConItems = Nothing
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 = mLabel.Parent.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
Public Property Get OldPositionRect() As Rect
OldPositionRect = mOldPositionRect
End Property
Private Sub OldPositionSet()
With mLabel
mOldPositionRect.Left = .Left
mOldPositionRect.Top = .Top
mOldPositionRect.Width = .Width
mOldPositionRect.Height = .Height
End With
End Sub
Public Property Get ItemRect() As Rect
With mLabel
ItemRect.Left = .Left
ItemRect.Top = .Top
ItemRect.Width = .Width
ItemRect.Height = .Height
End With
End Property
Public Property Let ItemRect(NewRect As Rect)
With mLabel
.Left = NewRect.Left
.Top = NewRect.Top
.Width = NewRect.Width
.Height = NewRect.Height
End With
Call OldPositionSet
End Property
Public Property Get Name() As String
Name = mLabel.Name
End Property
Public Property Get Value() As Variant
Value = mLabel.Caption
End Property
Option Explicit
'***************************************************
'クラス名 clsMoveItems
'***************************************************
Implements ILink
Public Event Parent(Parent As clsContainer)
Private WithEvents mParent As clsContainer
Private m_ParentAgent As CParentAgent
Private mMoveItems As Collection
Private mItemPositions As Collection
Private mMaxItemCount As Long
Public MaxCountCheck As Boolean
Private Sub Class_Initialize()
Set mMoveItems = New Collection
Set mItemPositions = New Collection
MaxCountCheck = False
End Sub
Private Sub Class_Terminate()
Debug.Print "clsMoveItems_Terminate"
Set mMoveItems = Nothing
Set mItemPositions = Nothing
End Sub
Public 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
Public Function Add(ByVal Caption As String) As clsMoveItem
Dim MoveItem As clsMoveItem
Dim Label As MSForms.Label
Set MoveItem = New clsMoveItem
Set Label = Parent.Parent.Controls.Add("Forms.Label.1", "Label" & Caption, True)
Label.Caption = Caption
MoveItem.Init Label
ItemMove MoveItem
With MoveItem.ItemRect
mItemPositions.Add _
Array(.Left, .Top, .Width, .Height, MoveItem.Name), MoveItem.Name
End With
mMoveItems.Add MoveItem, MoveItem.Name
Set Add = MoveItem
End Function
Public Function AddItem(ByVal TargetMoveItem As clsMoveItem) As MoveItemAddResultEnum
Dim MoveItem As clsMoveItem
If IsInCollection(TargetMoveItem) Then
Set mItemPositions = New Collection
For Each MoveItem In mMoveItems
With MoveItem.OldPositionRect
mItemPositions.Add _
Array(.Left, .Top, .Width, .Height, MoveItem.Name), MoveItem.Name
End With
Next
ItemMoveAnchor TargetMoveItem, mItemPositions(TargetMoveItem.Name)
AddItem = MoveItemAlreadyAdd
ElseIf (mMaxItemCount >= mMoveItems.Count + 1) Or (Not MaxCountCheck) Then
ItemMove TargetMoveItem
mMoveItems.Add TargetMoveItem, TargetMoveItem.Name
With TargetMoveItem.ItemRect
mItemPositions.Add _
Array(.Left, .Top, .Width, .Height, TargetMoveItem.Name), TargetMoveItem.Name
End With
AddItem = MoveItemAddOk
Else
Set mParent = Parent
mParent.Alert
Set mParent = Nothing
AddItem = MoveItemMaxCountOver
End If
End Function
Property Get Items() As Collection
Set Items = mMoveItems
End Property
Public Sub RemoveItem(ByVal MoveItem As clsMoveItem)
If IsInCollection(MoveItem) Then
mMoveItems.Remove CStr(MoveItem.Name)
mItemPositions.Remove CStr(MoveItem.Name)
AllItemMove
End If
End Sub
Private Sub AllItemMove()
Dim MoveItem 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 MoveItem In mMoveItems
OldRect = MoveItem.ItemRect
Iw = MoveItem.ItemRect.Width
If MaxWidth < Iw Then
MaxWidth = Iw
End If
If t + OldRect.Height > Parent.Label.Height Then
t = 0
lw = lw + MaxWidth
MaxWidth = 0
End If
With NewRect
.Left = Parent.Label.Left + lw
.Top = Parent.Label.Top + t
.Width = OldRect.Width
.Height = OldRect.Height
End With
MoveItem.ItemRect = NewRect
t = t + OldRect.Height
Next
End Sub
Private Sub ItemMove(ByVal TargetMoveItem As clsMoveItem)
Dim MoveItem 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 = TargetMoveItem.ItemRect
For Each MoveItem In mMoveItems
Ih = MoveItem.ItemRect.Height
Iw = MoveItem.ItemRect.Width
t = t + Ih
If MaxWidth < Iw Then
MaxWidth = Iw
End If
If t + Ih > Parent.Label.Height Then
t = 0
lw = lw + MaxWidth
MaxWidth = 0
End If
Next
With NewRect
.Left = Parent.Label.Left + lw
.Top = Parent.Label.Top + t
.Width = OldRect.Width
.Height = OldRect.Height
End With
TargetMoveItem.ItemRect = NewRect
End Sub
Private Function IsInCollection(ByVal TargetMoveItem As clsMoveItem) As Boolean
Dim MoveItem As clsMoveItem
IsInCollection = False
For Each MoveItem In mMoveItems
If MoveItem Is TargetMoveItem Then
IsInCollection = True
Exit For
End If
Next
End Function
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
Property Get MaxItemCount() As Long
MaxItemCount = mMaxItemCount
End Property
Property Let MaxItemCount(ByVal MaxCount As Long)
If MaxCount < 0 Then
MsgBox "MaxItemCountniに設定できるのは0以上です。", vbCritical
Else
mMaxItemCount = MaxCount
MaxCountCheck = True
End If
End Property
Private Sub mParent_MaxItemCountOver()
MsgBox mParent.Title & "の最大定員は、" & mMaxItemCount & "名です。", vbExclamation
End Sub
Private Property Get Parent() As clsContainer
' 親が指定した代理人を通して親と連絡を取る
m_ParentAgent.Connect Parent
End Property
' 親が指定した代理人の連絡先を取得する
Private Sub ILink_Link(ParentAgent As CParentAgent)
Set m_ParentAgent = ParentAgent
End Sub
Option Explicit
' クラスモジュール: CParentAgent
Public Event OnConnect(Parent As Object)
Private Sub Class_Terminate()
Debug.Print TypeName(Me) & ": Class_Terminate."
End Sub
' 親と連絡を取る
Public Sub Connect(Parent As Object)
RaiseEvent OnConnect(Parent)
End Sub
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
Option Explicit
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 MougContainer As clsContainer
Dim Member
Dim Members
With Me
.Width = 640
.Height = 320
End With
Set mContainers = New clsContainers
Set mContainers.Parent = Me
''コンテナの作成
Set MougContainer = mContainers.Add("Moug", 20, cnsTop, 100, 140)
With MougContainer
.Value = "モーグ"
.CreateTitle "Moug"
End With
With mContainers.Add("Excel", 170, cnsTop, 100, 140)
.Value = "Excel"
.CreateTitle "ExcelVBA講座"
.MoveItems.MaxItemCount = 3
End With
With mContainers.Add("Access", 320, cnsTop, 100, 140)
.Value = "Access"
.CreateTitle "AccessVBA講座"
.MoveItems.MaxItemCount = 6
End With
With mContainers.Add("Word", 470, cnsTop, 100, 140)
.Value = "Word"
.CreateTitle "WordVBA講座"
.MoveItems.MaxItemCount = 3
End With
''アイテムの作成
Members = Array("yayadonさん", "ろひさん", "simpleさん", _
"月さん", "ゴマさん", "kumattiさん", "YU-TANGさん", _
"Kanabunさん", "Abyssさん", "みそじのおじさん")
For Each Member In Members
MougContainer.MoveItems.Add Member
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
''見出しのラベル作成
With Me.Controls.Add("Forms.Label.1", "lbl1", True)
.Left = 80
.Top = 140
.Height = 20
.SpecialEffect = fmSpecialEffectEtched
.Width = 140
.Caption = "グループ分け結果"
.TextAlign = fmTextAlignCenter
End With
End Sub
Private Sub UserForm_Terminate()
Debug.Print "UserForm_Terminate"
Set mContainers = Nothing
Set mCommandButton = Nothing
Set mTextBox = Nothing
End Sub
Private Sub mCommandButton_Click()
Dim Container As clsContainer
Dim MoveItem As clsMoveItem
Dim v() As String
Dim i As Long
For Each Container In mContainers.Items
For Each MoveItem In Container.MoveItems.Items
ReDim Preserve v(i)
v(i) = Container.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
Public Property Get Containers() As clsContainers
Set Containers = mContainers
End Property
@Follen

Is that a VB program

@honda0510
Owner

Is that a VB program

Yes, it is.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Something went wrong with that request. Please try again.