On 12/27/00 15:53:56 you wrote:
>
>
> Hello everybody,
>
> Please, could anybody give me the key to include
> an already existing Generalization or Aggregation
> relationships in a class diagram.
>
> I only can do it if delete from the diagram the
> two related classes and put them again.
>
> I think that is caused because does not appear
> in browse info view (the Association relationships
> are showed in the left view)
>
> If somebody knows how to get it with Rose REI
> would be even better.
PRODUCT: 2000, 2000e
OS: Windows/WindowsNT
DEFECT #:
PATCH #:
REFERENCES:
CREATED: 12/27/00
REVISED:
QUESTION:
How do I add/remove selected class relations from a class diagram?
menubar:Filter Relations does this, but does not allow me to select individual
relations, only relation types.
ANSWER:
The following script will allow you to add/remove class relations from class
diagrams with finer control than Filter Relations:
Installation instructions:
This script must be run from the menubar:
1) Download to directory of your choice, e.g. c:\MyDirectory\SuperFilterRelations.ebs
2) Close Rose if you have it open.
3) Find and open Rose.mnu
4) Find the lines:
Menu Report
{
option "Show &Participants in UC..."
{
enable %selected_items:empty:false
RoseScript $SCRIPT_PATH\participants.ebx
}
option "&Documentation Report..."
{
RoseScript $SCRIPT_PATH\reportgen.ebx
}
}
Add a line to read as follows:
Menu Report
{
option "Show &Participants in UC..."
{
enable %selected_items:empty:false
RoseScript $SCRIPT_PATH\participants.ebx
}
option "&Documentation Report..."
{
RoseScript $SCRIPT_PATH\reportgen.ebx
}
option "SuperFilterRelationst"
{
Rosescript c:\MyDirectory\SuperFilterRelations.ebs
}
}
4) Save rose.mnu
5) Now when you open rose, you can run the script by
doing menubar:Report:SuperFilterRelations
'*****BEGIN SCRIPT
'************************************************************************
' Program: SuperFilterRelations.ebs
' Author: Tony Lew, Rational Techincal Support
' Date: December 27, 2000
'
' Purpose: To allow the addition/removal of class relations from
' a class diagram with finer control than Filter Relations
'
'************************************************************************
Option Explicit
Option Base 1
Dim c As Class
Dim cd As ClassDiagram
Dim addInvisibleClasses As Boolean
Dim boxtitle As String
'Dim boxtitle As String
Dim Leftarray() As String
Dim RightArray() As String
Dim Leftstuff As ItemCollection
Dim RightStuff As ItemCollection ' This collection's got the
' Right Stuff!
Begin Dialog MoveRelDlg ,,455,187,BoxTitle$,.MyDialogProc
OKButton 68,166,40,14
CancelButton 256,166,40,14
ListBox 12,22,177,136,LeftArray,.LeftBox
ListBox 254,22,188,136,RightArray,.RightBox
PushButton 206,62,32,14,">>>>",.AllRight
PushButton 206,21,32,14,">",.MoveRight
PushButton 207,40,31,14,"<",.MoveLeft
PushButton 206,80,32,14,"<<<<",.AllLeft
Text 12,8,32,8,"Visible",.Text1,,,ebBold
Text 208,8,32,8,"Invisible",.Text2
CheckBox 240,8,112,8,"Add Invisible Classes to Diagram",.AddInvisible
End Dialog
Function IsSameClass(c1 As class, c2 As class) As Boolean
Dim zot As Boolean
If c1.getUniqueID = c2.getUniqueID Then
IsSameClass = TRUE
Else
IsSameClass = FALSE
End If
End Function
Function Translate(zubu As RoseItem) As String
Dim a As Association
Dim cr As ClassRelation
Dim r As RealizeRelation
Dim inst As InstantiateRelation
Dim OtherClassName As String
Dim direction As String
Dim verb As String
Dim prep As String
Dim otherClass As class
If zubu.canTypecast(a) Then
Set a = zubu.typecast(a)
Set otherClass = a.getOtherRole(c).class
otherClassName = otherClass.name
If Not cd.exists(otherClass) Then
otherClassName = "(" + otherClassName + ")"
End If
Translate = "Association <" + a.name + "> with " _
+ OtherClassName
ElseIf zubu.canTypecast(r) Then
Set r = zubu.typecast(r)
If isSameClass(c,r.getSupplierClass) Then
Set otherClass = r.getContextClass
verb = "Realized"
prep = "by "
Else
Set otherClass = r.GetSupplierClass
verb = "Realizes"
prep = ""
End If
otherClassName = otherClass.name
If Not cd.exists(otherClass) Then
otherClassName = "(" + otherClassName + ")"
End If
Translate = verb + " <" + r.name + "> " + prep _
+ OtherClassName
ElseIf zubu.canTypeCast(cr) Then
Set cr = zubu.TypeCast(cr)
If isSameClass(c,cr.GetSupplierClass) Then
Set OtherClass = cr.GetContextClass
direction = " Client: "
verb = cr.getPropertyClassName
If verb = "Inherit" Then
verb = "Inherits"
prep = " from "
End If
If verb = "Uses" Then
verb = "Used"
prep = " by "
End If
If cr.canTypecast(inst) Then
verb = "Instantiated"
prep = "by"
End If
Else
Set OtherClass = cr.GetSupplierClass
direction = " Supplier: "
verb = cr.getPropertyClassName
If verb = "Inherit" Then
verb = "Inherited"
prep = " by "
End If
If cr.canTypecast(inst) Then
verb = "Instantiates"
End If
End If
otherClassName = otherClass.name
If Not cd.exists(OtherClass) Then
otherClassName = "(" + otherClassName + ")"
End If
Translate = _
verb + " <" + cr.name +"> " _
+ prep + direction + otherclassName
End If
End Function
Sub AddAt(c As ItemCollection, wot As RoseItem,indice As Integer)
Dim x As New ItemCollection
Dim i As Integer
If c.count = 0 Then
c.add wot
Exit Sub
End If
For i = 1 To c.count
x.add c.getat(i)
Next i
Set c = Nothing 'dispose it
Set c = New ItemCollection
For i = 1 To indice
c.add x.getat(i)
Next i
c.add wot
For i = indice + 1 To x.count
c.add x.getat(i)
Next i
End Sub
Sub zubu(x As MoveRelDlg)
msgbox x.AddInvisible
End Sub
Sub MakeArray(c As ItemCOllection, a() As String)
Dim i As Integer
If c.count = 0 Then
ReDim a(1)
a(1) = "<EMPTY>"
Exit Sub
End If
ReDim a(c.count)
For i = 1 To c.count
a(i) = Translate(c.getat(i))
Next i
End Sub
Sub FillErUp
MakeArray LeftStuff, LeftArray
MakeArray RightStuff, RightArray
End Sub
Function Movable(x As RoseItem) As Boolean
Dim cr As Classrelation
Dim a As association
Dim otherClass As class
If AddInvisibleClasses Then
Movable = TRUE
Exit Function
End If
If x.canTypeCast(cr) Then
Set cr = x.Typecast(cr)
If isSameClass(c,cr.getSupplierClass) Then
Set OtherClass = cr.getContextClass
Else
Set otherClass = cr.getSupplierClass
End If
Else
Set a = x.TypeCast(a)
Set otherClass = a.getOtherRole(c).class
End If
movable = cd.exists(otherClass)
End Function
Function MoveRight(indice As Integer, rightPlace As Integer) As Boolean
Dim x As RoseItem
If LeftStuff.count = 0 Then
Beep
MoveRight = FALSE
Exit Function
End If
Set x = LeftStuff.getat(indice)
Leftstuff.remove x
AddAt RightStuff, x, rightPlace
FillErUp
MoveRight = TRUE
End Function
Function MoveLeft(indice As Integer, leftPlace As Integer) As Boolean
Dim x As RoseItem
If RightStuff.count = 0 Then
Beep
MoveLeft = FALSE
Exit Function
End If
Set x = RightStuff.getat(indice)
If Not movable(x) Then
moveleft = FALSE
Exit Function
End If
Rightstuff.remove x
AddAt LeftStuff, x, leftPlace
FillErUp
MOveLeft = TRUE
End Function
Sub MoveAll(ex As ItemCollection, ad As ItemCollection)
Dim x As RoseItem
Dim i As Integer
For i = ex.count To 1 Step -1
Set x = ex.getat(i)
If ex Is RightStuff And Not movable(x) Then
GoTo skipIteration
End If
ex.remove x
Addat ad, x, 0
skipiteration:
Next i
FillerUp
End Sub
Const Allleft As String = "<<<<<"
Const AllRight As String = ">>>>>"
Const oneRight As String = ">"
Function myDialogProc(cntrl As String, _
action As Integer, suppval As Integer) As Integer
Dim Sourcebox As String
Dim destbox As String
Dim movato As Boolean
Dim i As Integer
Dim zot As RoseItem
Select Case action
Case 1
myDialogProc = 1
GoTo adjustStuff
Case 2
If cntrl = "AddInvisible" Then
myDialogProc = 1
AddInvisibleClasses = (dlgValue("AddInvisible") = 1)
If Not AddInvisibleClasses Then
For i = LeftStuff.count To 1 Step -1
Set zot = LeftStuff.getat(i)
If Not movable(zot) Then
LeftStuff.remove zot
RightStuff.add zot
End If
Next i
FillErUp
dlgListboxArray "RightBox", RightArray
dlgListBoxArray "LeftBox", LeftArray
GoTo AdjustStuff
End If
End If
If cntrl = "MoveRight" Then
myDialogProc = 1
movato = MoveRight( dlgValue("LeftBox") + 1 ,_
dlgValue("RightBox") +1 )
If Not movato Then
Exit Function
End If
' msgbox dlgValue("Rightbox")
dlgListboxArray "RightBox", RightArray
dlgListBoxArray "LeftBox", LeftArray
If Rightstuff.count > 1 Then
dlgValue "RightBox", dlgValue("RightBox") + 1
End If
GoTo AdjustStuff
End If
If cntrl = "MoveLeft" Then
myDialogProc = 1
movato = MoveLeft( dlgValue("RightBox") +1, _
dlgValue("LeftBox") + 1)
If Not movato Then
Exit Function
End If
dlgListboxArray "RightBox", RightArray
dlgListBoxArray "LeftBox", LeftArray
If Leftstuff.count > 1 Then
dlgValue "LeftBox", dlgValue("LeftBox") + 1
End If
GoTo AdjustSTuff
End If
If cntrl = "AllRight" Then
Moveall leftStuff, rightStuff
myDialogProc = 1
dlgListboxArray "RightBox", RightArray
dlgListBoxArray "LeftBox", LeftArray
GoTo AdjustStuff
End If
If cntrl = "AllLeft" Then ' Move to left
Moveall RightStuff, LeftStuff
DlgEnable "MoveLeft", FALSE
DlgEnable "MoveRight", TRUE
MyDialogProc = 1
dlgListboxArray "RightBox", RightArray
dlgListBoxArray "LeftBox", LeftArray
GoTo AdjustStuff
End If
Dim xxx As Integer
If (cntrl = "OK") And (DlgFocus$() = "LeftBox") Then
xxx = MyDialogProc("MoveRight",2,0)
myDialogProc = 1
End If
If (cntrl = "OK") And (dlgFocus$() = "RightBox") Then
xxx = MyDialogProc("MoveLeft",2,0)
myDialogProc = 1
End If
End Select
AdjustStuff:
DlgEnable "MoveLeft", RightStuff.count > 0
DlgEnable "AllLeft", RightStuff.count >0
DlgEnable "MoveRight", LeftStuff.count > 0
DlgEnable "AllRight", LeftStuff.count > 0
End Function
Sub AddItemCollections(x As ItemCollection, y As ItemCollection)
Dim i As Integer
If y Is Nothing Then
Exit Sub
End If
For i = 1 To y.count
x.add y.getat(i)
Next i
End Sub
Function GetAssociations (visible As Boolean) As AssociationCollection
Dim a As association
Dim aazot As New AssociationCollection
Dim aa As AssociationCollection
Dim j As Integer
Set aa = c.getassociations
For j = 1 To aa.count
Set a = aa.getat(j)
If cd.exists(a) = visible Then
If Not aazot.exists(a) Then
aazot.add a
End If
End If
Next j
Set GetAssociations = aazot
End Function
Function GetSupplierRels (visible As Boolean) As ItemCollection
Dim zot As New ItemCollection
Dim dep As ClassDependency
Dim deps As ClassDependencyCollection
Dim ir As InheritRelation
Dim irs As InheritRelationCollection
Dim r As realizeRelation
Dim rr As RealizeRelationCollection
Dim instColl As InstantiateRelationCollection
Dim inst As InstantiateRelation
Set deps = c.GetClassDependencies
Set irs = c.GetInheritRelations
Set rr = c.getRealizeRelations
Set instColl = c.getInstantiateRelations
'
' Dependencies
'
Dim i As Integer
For i = 1 To deps.count
Set dep = deps.getat(i)
If cd.exists(dep) = visible Then
zot.add dep
End If
Next i
'
' Inherits relations
'
For i = 1 To irs.count
Set ir = irs.getat(i)
If cd.exists(ir) = visible Then
zot.add ir
End If
Next i
'
' Realize relations
'
For i = 1 To rr.count
Set r = rr.getat(i)
If cd.exists(r) = visible Then
zot.add r
End If
Next i
'
' Instantiate relations
'
For i = 1 To instColl.count
Set inst = instColl.getat(i)
If cd.exists(inst) = visible Then
zot.add inst
End If
Next i
Set getSupplierRels = zot
End Function
Function getClientRels(visible As Boolean) As ItemCollection
Dim zot As New ItemCollection
Dim ir As InheritRelation
Dim dep As ClassDependency
Dim irs As InheritRelationCollection
Dim deps As ClassDependencycollection
Dim r As realizeRelation
Dim rr As RealizeRelationCollection
Dim instColl As InstantiateRelationCollection
Dim inst As InstantiateRelation
Dim c0 As class
Dim cc As classCollection
Dim i As Integer
Dim j As Integer
Set cc = RoseApp.currentmodel.getallclasses
For i = 1 To cc.count
Set c0 = cc.getat(i)
Set irs = c0.getInheritrelations
Set deps = c0.getClassDependencies
Set rr = c0.getRealizeRelations
Set instColl = c0.getInstantiateRelations
For j = 1 To irs.count
Set ir = irs.getat(j)
If cd.exists(ir) = visible And _
IsSameClass(c,ir.getSupplierClass) Then
zot.add ir
End If
Next j
For j = 1 To deps.count
Set dep = deps.getat(j)
If cd.exists(dep) = visible _
And IsSameClass(c,dep.getSupplierClass) Then
zot.add dep
End If
Next j
For j = 1 To rr.count
Set r = rr.getat(j)
If cd.exists(r) = visible _
And IsSameClass(c,r.getSupplierClass) Then
zot.add r
End If
Next j
For j = 1 To instColl.count
Set inst = instColl.getat(j)
If cd.exists(inst) = visible _
And IsSameClass(c,inst.getSupplierClass) Then
zot.add inst
End If
Next j
Next i
Set GetClientRels = zot
End Function
Function GetAllRels(visible As Boolean) As ItemCollection
Dim x As New ItemCollection
Dim i As Integer
AddItemCOllections x,GetSupplierRels(visible)
AddItemCollections x,GetClientRels(visible)
Dim aa As associationCollection
Set aa = GetAssociations(visible)
For i = 1 To aa.count
x.add aa.getat(i)
Next i
Set GetAllRels = x
End Function
Sub FillArray(col As ItemCollection,stuff() As String,visible As Boolean)
Dim zubu As roseItem
Dim a As association
Dim i As Integer
Set col = GetAllRels(visible)
If col.count > 0 Then
ReDim stuff(col.count)
Else
ReDim stuff(0 To 0)
stuff(0) = "<EMPTY>"
End If
For i = 1 To col.count
Set zubu = col.getat(i)
stuff(i) = Translate(zubu)
Next i
End Sub
Sub ModifyDiagram(col As ItemCollection,visible As Boolean)
Dim i As Integer
Dim zubu As roseItem
Dim a As Association
Dim cr As ClassRelation
Dim r As RealizeRelation
Dim isAdded As Boolean
Dim isRemoved As Boolean
Dim otherClass As class
Dim otherClassIsVisible As Boolean
For i = 1 To col.count
Set zubu = col.getat(i)
If zubu.canTypecast(cr) Then
Set cr = zubu.typecast(cr)
If visible Then
If isSameClass(c,cr.getSupplierClass) Then
Set otherClass = cr.getContextClass
Else
Set otherClass = cr.getSupplierClass
End If
otherClassIsVisible = cd.exists(otherClass)
If otherClassIsVisible Or AddInvisibleClasses Then
If Not cd.exists(cr) Then
If OtherClassIsVisible Then
isAdded = cd.addRelationView(cr)
Else
isAdded = cd.addClass(otherClass)
End If
End If
End If
ElseIf cd.exists(cr) Then
isRemoved = cd.removeItemView(cd.getViewFrom(cr))
End If
ElseIf zubu.canTypecast(a) Then
Set a = zubu.typecast(a)
If visible Then
otherClassIsVisible = cd.exists(a.getOtherRole(c).class)
If otherClassIsVisible Or AddInvisibleClasses Then
If Not cd.exists(a) Then
isAdded = cd.addAssociation(a)
End If
End If
ElseIf cd.exists(a) Then
isRemoved = cd.RemoveAssociation(a)
End If
ElseIf zubu.canTypecast(r) Then
Set r = zubu.typecast(r)
If visible Then
If isSameClass(c,r.getSupplierClass) Then
Set otherClass = r.getContextClass
Else
Set otherClass = r.getSupplierClass
End If
otherClassIsVisible = cd.exists(otherClass)
If otherClassIsVisible Or AddInvisibleClasses Then
If Not cd.exists(r) Then
isAdded = cd.addRelationView(r)
End If
End If
ElseIf cd.exists(r) Then
isRemoved = cd.RemoveItemView(cd.getViewFrom(r))
End If
End If
Next i
End Sub
Sub RunAddDlg()
Dim x As MoveRelDlg
'
' Initialize arrays and collections.
'
Set Leftstuff = New ItemCollection
Set Rightstuff = New ItemCOllection
Set LeftStuff = GetAllRels(TRUE)
Set RightStuff = GetAllRels(FALSE)
FillArray leftstuff,leftarray, TRUE
FillArray rightstuff, rightarray, FALSE
x.AddInvisible = 1
AddInvisibleClasses = TRUE
' x.text = "Relations for class " + c.name
'
' Run the dialog
'
Dim ret As Integer
ret = Dialog(x)
'
' Modify diagram
'
If ret = -1 Then 'OK!!!
ModifyDiagram LeftStuff,TRUE
ModifyDiagram RightStuff,FALSE
cd.update
End If
End Sub
Sub Main
Dim d As diagram
Dim cc As classCollection
Dim cat As category
Set d= RoseApp.currentmodel.getActiveDiagram
If d Is Nothing Then
msgbox "Error - no active diagram"
Exit Sub
End If
If Not d.canTypecast(cd) Then
msgbox "Error - diagram is not a class diagram"
Exit Sub
End If
Set cd = d.typecast(cd)
Set cc = cd.getSelectedClasses
If cc.count = 0 Then
msgbox "No class selected"
Exit Sub
End If
If cc.count > 1 Then
msgbox "Error - only one class can be selected"
End If
Set c = cc.getat(1)
BoxTitle = "Relations for Class " + c.name
RunAddDlg
End Sub
'*****END SCRIPT
>
> Best regards.
>
>Rafael Cabezas Zubimendi
>Telem�tica y Operaci�n
>TCP Sistemas e Ingenier�a
>L�pez de Hoyos, 327, 6� planta.
>Tel: +34 91 748 98 41 (directo)
>Tel: +34 91 748 99 20 (ext. 678) ;-)
>Fax: +34 91 748 98 76
>mailto:[EMAIL PROTECTED]
>http://www.tcpsi.es
>
>************************************************************************
>* Rose Forum is a public venue for ideas and discussions.
>* For technical support, visit http://www.rational.com/support
>*
>* Admin.Subscription Requests: [EMAIL PROTECTED]
>* Archive of messages:
>http://www.rational.com/products/rose/usergroups/rose_forum.jtmpl
>* Other Requests: [EMAIL PROTECTED]
>*
>* To unsubscribe from the list, please send email
>*
>* To: [EMAIL PROTECTED]
>* Subject:<BLANK>
>* Body: unsubscribe rose_forum
>*
>
************************************************************************
* Rose Forum is a public venue for ideas and discussions.
* For technical support, visit http://www.rational.com/support
*
* Admin.Subscription Requests: [EMAIL PROTECTED]
* Archive of messages:
http://www.rational.com/products/rose/usergroups/rose_forum.jtmpl
* Other Requests: [EMAIL PROTECTED]
*
* To unsubscribe from the list, please send email
*
* To: [EMAIL PROTECTED]
* Subject:<BLANK>
* Body: unsubscribe rose_forum
*
*************************************************************************
