-
-
Notifications
You must be signed in to change notification settings - Fork 20
/
Util.vbs
1107 lines (1046 loc) · 34.5 KB
/
Util.vbs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
!INC Local Scripts.EAConstants-VBScript
'[path=\Framework\Utils]
'[group=Utils]
'
' Script Name: Util
' Author: Geert Bellekens
' Purpose: serves as library for other scripts
' Date: 28/09/2015
'
'definee the atrias Red color to be used by different scripts
dim atriasRed
atriasRed = RGB(153, 20, 37)
' Synchronises the names of the selected objects or BPMN Activities with their classifier/called activity ref.
' Will also set the composite diagram to that of the classifier/ActivityRef in order to facilitate click-through
function synchronizeElement (element)
'first check if this is an object or an action
if not element is Nothing then
if (element.Type = "Object" OR element.Type = "Action") _
AND element.ClassifierID > 0 then
dim classifier
set classifier = Repository.GetElementByID(element.ClassifierID)
if not classifier is nothing AND classifier.name <> element.name then
element.Name = classifier.Name
element.Stereotype = classifier.Stereotype
element.Update
Repository.AdviseElementChange(element.ElementID)
end if
'elements of type object should also point to the composite diagram of the classifier
if element.Type = "Object" then
dim compositeDiagram
set compositeDiagram = classifier.CompositeDiagram
if not compositeDiagram is nothing then
setCompositeDiagram element, compositeDiagram
end if
end if
elseif element.Type = "Activity" AND element.Stereotype = "Activity" then
'BPMN activities that call another BPMN activity need to get the same name and same composite diagram
dim calledActivityTV as EA.TaggedValue
set calledActivityTV = element.TaggedValues.GetByName("isACalledActivity")
dim referenceActivityTV as EA.TaggedValue
set referenceActivityTV = element.TaggedValues.GetByName("calledActivityRef")
if not calledActivityTV is nothing and not referenceActivityTV is nothing then
'only do something when the Activity is types a CalledActivity
'Session.Output "calledActivityTV.Value : " & calledActivityTV.Value
'Session.Output "referenceActivityTV.Value :" & referenceActivityTV.Value
if calledActivityTV.Value = "true" then
dim calledActivity as EA.Element
set calledActivity = Repository.GetElementByGuid(referenceActivityTV.Value)
if not calledActivity is nothing then
'set name to that of the called activity
element.Name = calledActivity.Name
element.Update
'Set composite diagram to that of the called activity
setCompositeDiagram element, calledActivity.CompositeDiagram
end if
end if
end if
end if
end if
end function
'set the given diagram as composite diagram for this element
function setCompositeDiagram (element, diagram)
if not diagram is nothing then
'Tell EA this element is composite
dim objectQuery
objectQuery = "update t_object set NType = 8 where Object_ID = " & element.ElementID
Repository.Execute objectQuery
if element.Type = "Object" then
'Tell EA which diagram is the composite diagram
dim xrefQuery
xrefquery = "insert into t_xref (XrefID, Name, Type, Visibility, Partition, Client, Supplier) values ('"&CreateGuid&"', 'DefaultDiagram', 'element property', 'Public', '0', '"& element.ElementGUID & "', '"& diagram.DiagramGUID &"')"
Repository.Execute xrefquery
elseif element.Type = "Activity" then
'for activities we need to update PDATA1 with the diagramID
dim updatequery
updatequery = "update t_object set PDATA1 = "& diagram.DiagramID & " where Object_ID = " & element.ElementID
Repository.Execute updatequery
end if
end if
end function
' Returns a unique Guid on every call. Removes any cruft.
Function CreateGuid()
CreateGuid = Left(CreateObject("Scriptlet.TypeLib").Guid,38)
End Function
'make an action into a calling activity
function makeCallingActivity(action, activity)
action.Type = "Activity"
action.ClassfierID = 0
action.Stereotype = "Activity"
action.Update
action.SynchTaggedValues "BPMN2.0","Activity"
action.TaggedValues.Refresh
'first copy the tagged values values
copyTaggedValuesValues activity, action
'set tagged values correctly
dim calledActivityTV as EA.TaggedValue
set calledActivityTV = action.TaggedValues.GetByName("isACalledActivity")
calledActivityTV.Value = "true"
calledActivityTV.Update
dim referenceActivityTV as EA.TaggedValue
set referenceActivityTV = action.TaggedValues.GetByName("calledActivityRef")
referenceActivityTV.Value = activity.ElementGUID
referenceActivityTV.Update
action.TaggedValues.Refresh()
end function
'copies values of the tagged values of the source to the values of the corresponding tagged values at the target
function copyTaggedValuesValues (source, target)
dim taggedValue as EA.TaggedValue
for each taggedValue in source.TaggedValues
dim targetTaggedValue as EA.TaggedValue
set targetTaggedValue = target.TaggedValues.GetByName(taggedValue.Name)
if not targetTaggedValue is nothing then
targetTaggedValue.Value = taggedValue.Value
targetTaggedValue.Update
end if
next
end function
'copies the tagged values from the source to the target
function copyTaggedValues(source, target)
dim sourceTag as EA.TaggedValue
dim targetTag as EA.TaggedValue
for each sourceTag in source.TaggedValues
set targetTag = nothing
'first try to find target tag
dim tag as EA.TaggedValue
for each tag in target.TaggedValues
if tag.Name = sourceTag.Name then
set targetTag = tag
exit for
end if
next
'if not found then create new
if targetTag is nothing then
set targetTag = target.TaggedValues.AddNew(sourceTag.Name,"TaggedValue")
end if
'set value
if not targetTag is nothing then
targetTag.Value = sourceTag.Value
targetTag.Notes = sourceTag.Notes
targetTag.Update
target.Update
end if
next
end function
'copies the tagged values from the source to the target
function copyAllTaggedValues(source, target)
dim sourceTag as EA.TaggedValue
dim targetTag as EA.TaggedValue
for each sourceTag in source.TaggedValues
set targetTag = nothing
'first try to find target tag, only use if empty
dim tag as EA.TaggedValue
for each tag in target.TaggedValues
if tag.Name = sourceTag.Name _
AND len(tag.Value) = 0 then
set targetTag = tag
exit for
end if
next
'if not found then create new
if targetTag is nothing then
set targetTag = target.TaggedValues.AddNew(sourceTag.Name,"TaggedValue")
end if
'set value
if not targetTag is nothing then
targetTag.Value = sourceTag.Value
targetTag.Notes = sourceTag.Notes
targetTag.Update
target.Update
end if
next
end function
function setFontOnDiagramObject(diagramObject, font, size )
dim styleParts
styleParts = Split (diagramObject.Style , ";")
dim i
dim stylepart
dim fontpart
fontpart = "font=" & font
dim fontSet
fontSet = false
dim sizePart
sizePart = "fontsz=" & size * 10
dim sizeSet
sizeSet = false
for i = 0 to Ubound(styleParts) -1
stylepart = styleParts(i)
if Instr(stylepart,"font=") > 0 then
styleParts(i) = fontpart
fontSet = true
elseif Instr(stylepart,"fontsz=") > 0 then
styleParts(i) = sizePart
sizeSet = true
end if
next
diagramObject.Style = join(styleParts,";")
if not fontSet then
diagramObject.Style = diagramObject.Style & fontpart & ";"
end if
if not sizeSet then
diagramObject.Style = diagramObject.Style & sizePart & ";"
end if
end function
'returns an ArrayList with the elements accordin tot he ObjectID's in the given query
function getElementsFromQuery(sqlQuery)
dim elements
set elements = Repository.GetElementSet(sqlQuery,2)
dim result
set result = CreateObject("System.Collections.ArrayList")
dim element
for each element in elements
result.Add Element
next
set getElementsFromQuery = result
end function
'returns a dictionary of all elements in the query with their name as key, and the element as value.
'for elements with the same name only one will be returned
function getElementDictionaryFromQuery(sqlQuery)
dim elements
set elements = Repository.GetElementSet(sqlQuery,2)
dim result
set result = CreateObject("Scripting.Dictionary")
dim element
for each element in elements
if not result.Exists(element.Name) then
result.Add element.Name, element
end if
next
set getElementDictionaryFromQuery = result
end function
'get the package id string of the currently selected package tree
function getCurrentPackageTreeIDString()
'initialize at "0"
getCurrentPackageTreeIDString = "0"
dim packageTree
dim currentPackage as EA.Package
'get selected package
set currentPackage = Repository.GetTreeSelectedPackage()
getCurrentPackageTreeIDString = getPackageTreeIDString(currentPackage)
end function
'get the package id string of the given package tree
function getPackageTreeIDString(package)
dim allPackageTreeIDs
set allPackageTreeIDs = CreateObject("System.Collections.ArrayList")
dim parentPackageIDs
set parentPackageIDs = CreateObject("System.Collections.ArrayList")
if not package is nothing then
parentPackageIDs.Add package.PackageID
end if
'get the actual package ids
getPackageTreeIDsFast allPackageTreeIDs, parentPackageIDs
'return
getPackageTreeIDString = Join(allPackageTreeIDs.ToArray,",")
end function
function getPackageTreeIDsFast(allPackageTreeIDs, parentPackageIDs)
if parentPackageIDs.Count = 0 then
if allPackageTreeIDs.Count = 0 then
'make sure there is at least a 0 in the allPackageTreeIDs
allPackageTreeIDs.Add "0"
end if
'then exit
exit function
end if
'add the parent package ids
allPackageTreeIDs.AddRange(parentPackageIDs)
'get the child package IDs
dim sqlGetPackageIDs
sqlGetPackageIDs = "select p.Package_ID from t_package p where p.Parent_ID in (" & Join(parentPackageIDs.ToArray, ",") & ")"
dim queryResult
set queryResult = getVerticalArrayListFromQuery(sqlGetPackageIDs)
if queryResult.Count > 0 then
dim childPackageIDs
set childPackageIDs = queryResult(0)
'call recursive function with child package id's
getPackageTreeIDsFast allPackageTreeIDs, childPackageIDs
end if
end function
'returns an ArrayList of the given package and all its subpackages recursively
function getPackageTree(package)
dim packageList
set packageList = CreateObject("System.Collections.ArrayList")
addPackagesToList package, packageList
set getPackageTree = packageList
end function
'add the given package and all subPackges to the list (recursively
function addPackagesToList(package, packageList)
dim subPackage as EA.Package
'add the package itself
packageList.Add package
'add subpackages
for each subPackage in package.Packages
addPackagesToList subPackage, packageList
next
end function
'make an id string out of the package ID of the given packages
function makePackageIDString(packages)
dim package as EA.Package
dim idString
idString = ""
dim addComma
addComma = false
for each package in packages
if addComma then
idString = idString & ","
else
addComma = true
end if
idString = idString & package.PackageID
next
'if there are no packages then we return "0"
if idString = "" then
idString = "0"
end if
'return idString
makePackageIDString = idString
end function
'make an id string out of the ID's of the given elements
function makeIDString(elements)
dim element as EA.Element
dim idString
idString = ""
dim addComma
addComma = false
for each element in elements
if addComma then
idString = idString & ","
else
addComma = true
end if
idString = idString & element.ElementID
next
'if there are no elements then we return "0"
if idString = "" then
idString = "0"
end if
'return idString
makeIDString = idString
end function
'returns the elements in an ArrayList of the given type from the given diagram
function getElementsFromDiagram(diagram, elementType)
dim selectedElements
set selectedElements = CreateObject("System.Collections.ArrayList")
dim diagramObject as EA.DiagramObject
dim element as EA.Element
for each diagramObject in diagram.DiagramObjects
set element = Repository.GetElementByID(diagramObject.ElementID)
if element.Type = elementType then
selectedElements.Add element
end if
next
'return selected Elements
set getElementsFromDiagram = selectedElements
end function
'returns the diagram objects in an ArrayList for elements of the given type from the given diagram
function getDiagramObjects(diagram, elementType)
dim selectedElements
set selectedElements = CreateObject("System.Collections.ArrayList")
dim diagramObject as EA.DiagramObject
dim element as EA.Element
for each diagramObject in diagram.DiagramObjects
set element = Repository.GetElementByID(diagramObject.ElementID)
if element.Type = elementType then
selectedElements.Add diagramObject
end if
next
'return selected Elements
set getDiagramObjects = selectedElements
end function
'returns the elements in an ArrayList of the given type from the given diagram
'the boundary element should be passed as a DiagramObject
function getElementsFromDiagramInBoundary(diagram, elementType,boundary)
'dim boundary as EA.DiagramObject
dim selectedElements
set selectedElements = CreateObject("System.Collections.ArrayList")
dim diagramObject as EA.DiagramObject
dim element as EA.Element
for each diagramObject in diagram.DiagramObjects
if (diagramObject.left >= boundary.left and _
diagramObject.left =< boundary.right and _
diagramObject.top =< boundary.top and _
diagramObject.top >= boundary.bottom) then
'get the element and check the type
set element = Repository.GetElementByID(diagramObject.ElementID)
if element.Type = elementType then
selectedElements.Add element
end if
end if
next
'return selected Elements
set getElementsFromDiagramInBoundary = selectedElements
end function
function getWC()
if Repository.RepositoryType = "JET" then
getWC = "*"
else
getWC = "%"
end if
end function
function addElementToDiagram(element, diagram, y, x)
dim diagramObject as EA.DiagramObject
dim positionString
'determine height and width
dim width
dim height
dim elementType
dim setVPartition
setVPartition = false
elementType = element.Type
select case elementType
case "Event"
width = 30
height = 30
case "Object"
width = 40
height = 25
case "Activity"
width = 110
height = 60
case "ActivityPartition"
width = 190
height = 60
setVPartition = true
case "Package"
width = 75
height = 90
case else
'default width and height
width = 75
height = 50
end select
'to make sure all elements are vertically aligned we subtract half of the width of the x
x = x - width/2
'set the position of the diagramObject
positionString = "l=" & x & ";r=" & x + width & ";t=" & y & ";b=" & y + height & ";"
Session.Output "positionString voor element "& element.Name & " : " & positionString
set diagramObject = diagram.DiagramObjects.AddNew( positionString, "" )
diagramObject.ElementID = element.ElementID
if setVPartition then
diagramObject.Style = "VPartition=1"
end if
diagramObject.Update
diagram.DiagramObjects.Refresh
set addElementToDiagram = diagramObject
end function
'gets the content of the linked document in the given format (TXT, RTF or EA)
function getLinkedDocumentContent(element, format)
dim linkedDocumentRTF
dim linkedDocumentEA
dim linkedDocumentPlainText
linkedDocumentRTF = element.GetLinkedDocument()
if format = "RTF" then
getLinkedDocumentContent = linkedDocumentRTF
else
linkedDocumentEA = Repository.GetFieldFromFormat("RTF",linkedDocumentRTF)
if format = "EA" then
getLinkedDocumentContent = linkedDocumentEA
else
linkedDocumentPlainText = Repository.GetFormatFromField("TXT",linkedDocumentEA)
getLinkedDocumentContent = linkedDocumentPlainText
end if
end if
end function
'returns the currently logged in user
'if security is not enabled then the logged in user is defaulted to me
function getUserLogin()
'get the currently logged in user
Dim userLogin
if Repository.IsSecurityEnabled then
userLogin = Repository.GetCurrentLoginUser(false)
else
userLogin = "SYSTEMAT-TCC\BellekensG"
end if
getUserLogin = userLogin
end function
function getArrayFromQuery(sqlQuery)
dim xmlResult
xmlResult = Repository.SQLQuery(sqlQuery)
getArrayFromQuery = convertQueryResultToArray(xmlResult)
end function
'converts the query results from Repository.SQLQuery from xml format to a two dimensional array of strings
Public Function convertQueryResultToArray(xmlQueryResult)
Dim arrayCreated
Dim i
i = 0
Dim j
j = 0
Dim result()
Dim xDoc
Set xDoc = CreateObject( "MSXML2.DOMDocument" )
'load the resultset in the xml document
If xDoc.LoadXML(xmlQueryResult) Then
'select the rows
Dim rowList
Set rowList = xDoc.SelectNodes("//Row")
Dim rowNode
Dim fieldNode
arrayCreated = False
'loop rows and find fields
For Each rowNode In rowList
j = 0
If (rowNode.HasChildNodes) Then
'redim array (only once)
If Not arrayCreated Then
ReDim result(rowList.Length, rowNode.ChildNodes.Length)
arrayCreated = True
End If
For Each fieldNode In rowNode.ChildNodes
'write f
result(i, j) = fieldNode.Text
j = j + 1
Next
End If
i = i + 1
Next
'make sure the array has a dimension even is we don't have any results
if not arrayCreated then
ReDim result(0, 0)
end if
end if
convertQueryResultToArray = result
End Function
function getArrayListFromQuery(sqlQuery)
dim xmlResult
xmlResult = Repository.SQLQuery(sqlQuery)
set getArrayListFromQuery = convertQueryResultToArrayList(xmlResult)
end function
Function convertQueryResultToArrayList(xmlQueryResult)
Dim result
set result = CreateObject("System.Collections.ArrayList")
Dim xDoc
Set xDoc = CreateObject( "MSXML2.DOMDocument" )
'load the resultset in the xml document
If xDoc.LoadXML(xmlQueryResult) Then
'select the rows
Dim rowList
Set rowList = xDoc.SelectNodes("//Row")
Dim rowNode
Dim fieldNode
'loop rows and find fields
For Each rowNode In rowList
dim rowArrayList
set rowArrayList = CreateObject("System.Collections.ArrayList")
'loop the field nodes
For Each fieldNode In rowNode.ChildNodes
'add the contents
rowArrayList.Add fieldNode.Text
Next
'add the row the the general list
result.Add rowArrayList
Next
end if
set convertQueryResultToArrayList = result
end function
function getVerticalArrayListFromQuery(sqlQuery)
dim xmlResult
xmlResult = Repository.SQLQuery(sqlQuery)
set getVerticalArrayListFromQuery = convertQueryResultToVerticalArrayList(xmlResult)
end function
Function convertQueryResultToVerticalArrayList(xmlQueryResult)
Dim result
set result = CreateObject("System.Collections.ArrayList")
Dim xDoc
Set xDoc = CreateObject( "MSXML2.DOMDocument" )
'load the resultset in the xml document
If xDoc.LoadXML(xmlQueryResult) Then
'select the rows
Dim rowList
Set rowList = xDoc.SelectNodes("//Row")
Dim rowNode
Dim fieldNode
dim firstRow
firstRow = true
'loop rows and find fields
For Each rowNode In rowList
if firstRow then
For Each fieldNode In rowNode.ChildNodes
'add an arraylist for each column
result.Add CreateObject("System.Collections.ArrayList")
next
end if
'loop the field nodes
dim i
i = 0
For Each fieldNode In rowNode.ChildNodes
'add the contents to the correct column arraylist
result(i).Add fieldNode.Text
i = i + 1
Next
Next
end if
set convertQueryResultToVerticalArrayList = result
end function
'let the user select a package
function selectPackage()
'start from the selected package in the project browser
dim constructpickerString
constructpickerString = "IncludedTypes=Package"
dim treeselectedPackage as EA.Package
set treeselectedPackage = Repository.GetTreeSelectedPackage()
if not treeselectedPackage is nothing then
constructpickerString = constructpickerString & ";Selection=" & treeselectedPackage.PackageGUID
end if
dim packageElementID
packageElementID = Repository.InvokeConstructPicker(constructpickerString)
if packageElementID > 0 then
dim packageElement as EA.Element
set packageElement = Repository.GetElementByID(packageElementID)
dim package as EA.Package
set package = Repository.GetPackageByGuid(packageElement.ElementGUID)
else
set package = nothing
end if
set selectPackage = package
end function
function getConnectorsFromQuery(sqlQuery)
dim xmlResult
xmlResult = Repository.SQLQuery(sqlQuery)
dim connectorIDs
connectorIDs = convertQueryResultToArray(xmlResult)
dim connectors
set connectors = CreateObject("System.Collections.ArrayList")
dim connectorID
dim connector as EA.Connector
for each connectorID in connectorIDs
if connectorID > 0 then
set connector = Repository.GetConnectorByID(connectorID)
if not connector is nothing then
connectors.Add(connector)
end if
end if
next
set getConnectorsFromQuery = connectors
end function
function getDiagramsFromQuery(sqlQuery)
dim xmlResult
xmlResult = Repository.SQLQuery(sqlQuery)
dim diagramIDs
diagramIDs = convertQueryResultToArray(xmlResult)
dim diagrams
set diagrams = CreateObject("System.Collections.ArrayList")
dim diagramID
dim diagram as EA.Diagram
for each diagramID in diagramIDs
if diagramID > 0 then
set diagram = Repository.GetdiagramByID(diagramID)
if not diagram is nothing then
diagrams.Add(diagram)
end if
end if
next
set getDiagramsFromQuery = diagrams
end function
function getAttributesFromQuery(sqlQuery)
dim xmlResult
xmlResult = Repository.SQLQuery(sqlQuery)
dim attributeIDs
attributeIDs = convertQueryResultToArray(xmlResult)
dim attributes
set attributes = CreateObject("System.Collections.ArrayList")
dim attributeID
dim attribute as EA.Attribute
for each attributeID in attributeIDs
if attributeID > 0 then
set attribute = Repository.GetAttributeByID(attributeID)
if not attribute is nothing then
attributes.Add(attribute)
end if
end if
next
set getattributesFromQuery = attributes
end function
function getPackagesFromQuery(sqlQuery)
dim xmlResult
xmlResult = Repository.SQLQuery(sqlQuery)
dim packageIDs
packageIDs = convertQueryResultToArray(xmlResult)
dim packages
set packages = CreateObject("System.Collections.ArrayList")
dim packageID
dim package as EA.Package
for each packageID in packageIDs
if packageID > 0 then
set package = Repository.GetPackageByID(packageID)
if not package is nothing then
packages.Add(package)
end if
end if
next
set getPackagesFromQuery = packages
end function
'get the description from the given notes
'that is the text between <NL> and </NL> or <FR> and </FR>
function getTagContent(notes, tag)
if tag = "" then
getTagContent = notes
else
getTagContent = ""
dim startTagPosition
dim endTagPosition
startTagPosition = InStr(notes,"<" & tag & ">")
endTagPosition = InStr(notes,"</" & tag & ">")
'Session.Output "notes: " & notes & " startTagPosition: " & startTagPosition & " endTagPosition: " &endTagPosition
if startTagPosition > 0 and endTagPosition > startTagPosition then
dim startContent
startContent = startTagPosition + len(tag) + 8
dim length
length = endTagPosition - startContent
getTagContent = mid(notes, startContent, length)
end if
end if
end function
'Returns the value of the tagged value with the given name (case insensitive)
'If there is no tagged value with the given name, an empty string is returned
'This function can be used with anything that can have tagged values
function getTaggedValueValue(owner, taggedValueName)
dim taggedValue as EA.TaggedValue
getTaggedValueValue = ""
for each taggedValue in owner.TaggedValues
if lcase(taggedValueName) = lcase(taggedValue.Name) then
if taggedValue.Value = "<memo>" then
'memo field, return the notes
getTaggedValueValue = taggedValue.Notes
else
'normal field
getTaggedValueValue = taggedValue.Value
end if
exit for
end if
next
end function
function getExistingOrNewTaggedValue(owner, tagname)
dim taggedValue as EA.TaggedValue
dim returnTag as EA.TaggedValue
set returnTag = nothing
'check if a tag with that name alrady exists
for each taggedValue in owner.TaggedValues
if taggedValue.Name = tagName then
set returnTag = taggedValue
exit for
end if
next
'create new one if not found
if returnTag is nothing then
set returnTag = owner.TaggedValues.AddNew(tagname,"")
end if
'return
set getExistingOrNewTaggedValue = returnTag
end function
function isRequireUserLockEnabled()
dim reqUserLockToEdit
'default is false
reqUserLockToEdit = false
'check if security is enabled
if Repository.IsSecurityEnabled then
dim getReqUserLockSQL
getReqUserLockSQL = "select sc.Value from t_secpolicies sc " & _
"where sc.Property = 'RequireLock' "
dim xmlQueryResult
xmlQueryResult = Repository.SQLQuery(getReqUserLockSQL)
dim reqUserLockResults
reqUserLockResults = convertQueryResultToArray(xmlQueryResult)
if Ubound(reqUserLockResults) > 0 then
if reqUserLockResults(0,0) = "1" then
reqUserLockToEdit = true
end if
end if
end if
isRequireUserLockEnabled = reqUserLockToEdit
end function
function copyDiagram(diagram, targetOwner)
dim copiedDiagram as EA.Diagram
'initialize at nothing
set copiedDiagram = nothing
'get the owner package
dim ownerPackage as EA.Package
set ownerPackage = Repository.GetPackageByID(diagram.PackageID)
'check if we need to lock the package to clone it
if isRequireUserLockEnabled() then
dim ownerOfOwnerPackage as EA.Package
if ownerPackage.ParentID > 0 then
set ownerOfOwnerPackage = Repository.GetPackageByID(ownerPackage.ParentID)
if not ownerOfOwnerPackage.ApplyUserLock() then
'tell the user we couldn't do it and then exit the function
msgbox "Could not lock package " & ownerPackage.Name & " in order to copy the diagram " & diagram.Name,vbError,"Could not lock Package"
exit function
end if
end if
end if
'then actually clone the owner package
dim clonedPackage as EA.Package
set clonedPackage = ownerPackage.Clone()
' if isRequireUserLockEnabled() then
' clonedPackage.ApplyUserLockRecursive true,true,true
' end if
'then get the diagram corresponding to the diagram to copy
set copiedDiagram = getCorrespondingDiagram(clonedPackage,diagram)
'set the owner of the copied diagram
if targetOwner.ObjectType = otElement then
copiedDiagram.ParentID = targetOwner.ElementID
else
copiedDiagram.PackageID = targetOwner.PackageID
end if
'save the update to the owner
copiedDiagram.Update
'delete the cloned package
deletePackage(clonedPackage)
'return the copied diagram
set copyDiagram = copiedDiagram
end function
function deletePackage(package)
if package.ParentID > 0 then
'get parent package
dim parentPackage as EA.Package
set parentPackage = Repository.GetPackageByID(package.ParentID )
dim i
'delete the pacakge
for i = parentPackage.Packages.Count -1 to 0 step -1
dim currentPackage as EA.Package
set currentPackage = parentPackage.Packages(i)
if currentPackage.PackageID = package.PackageID then
parentPackage.Packages.DeleteAt i,false
exit for
end if
next
end if
end function
function getCorrespondingDiagram(clonedPackage,diagram)
dim correspondingDiagram as EA.Diagram
dim candidateDiagrams
dim getCandidateDiagramsSQL
dim packageIDs
packageIDs = getPackageTreeIDString(clonedPackage)
getCandidateDiagramsSQL = "select d.Diagram_ID from t_diagram d " & _
" where d.name = '" & diagram.Name & "' " & _
" and d.Package_ID in (" & packageIDs& ") "
set candidateDiagrams = getDiagramsFromQuery(getCandidateDiagramsSQL)
'if there is only one candidate then that is the one we take
if candidateDiagrams.Count = 1 then
set correspondingDiagram = candidateDiagrams(0)
end if
'if there are multiple candidates then we have to filter them
'first create a dictionary with the diagrams and their owner
dim candidateDiagramsDictionary
set candidateDiagramsDictionary = CreateObject("Scripting.Dictionary")
dim currentDiagram
for each currentDiagram in candidateDiagrams
'add the diagram and its owner to the dictionary
candidateDiagramsDictionary.Add currentDiagram, getOwner(diagram)
next
dim currentowner
set currentOwner = nothing
'filter the diagrams until we have only one diagram left
set correspondingDiagram = filterDiagrams(candidateDiagramsDictionary,diagram, clonedPackage, currentOwner)
'return the diagram
set getCorrespondingDiagram = correspondingDiagram
end function
function filterDiagrams(candidateDiagramsDictionary,diagram, clonedPackage, currentOwner)
dim filteredDiagrams
dim filteredDiagram as EA.Diagram
'initialize at nothing
set filteredDiagram = nothing
set filteredDiagrams = CreateObject("Scripting.Dictionary")
if currentOwner is nothing then
set currentOwner = getOwner(diagram)
end if
'compare the diagrams and their owner with the current owner
dim candidateDiagram as EA.Diagram
dim candidateOwner
for each candidateDiagram in candidateDiagramsDictionary.Keys
set candidateOwner = candidateDiagramsDictionary(candidateDiagram)
if candidateOwner.Name = currentOwner.Name then
'add the diagram to the new list
filteredDiagrams.Add candidateDiagram, getOwner(candidateOwner)
end if
next
'check the number if we have reached he level of the cloned package, or if there is only one diagram left
if filteredDiagrams.Count = 1 _
OR currentOwner.ObjectType = otPackage AND currentOwner.ParentID = clonedPackage.PackageID then
'return the first one
set filteredDiagram = filteredDiagrams.Keys()(0)
else
'go one level deeper to filter the diagrams
set currentOwner = getOwner(currentOwner)
set filteredDiagram = filterDiagrams(filteredDiagrams,diagram, clonedPackage, currentOwner)
end if
'return filtered diagram
set filterDiagrams = filteredDiagram
end function
function getOwner(item)
dim owner
select case item.ObjectType
case otElement,otDiagram,otPackage
'if it has an element as owner then we return the element
if item.ParentID > 0 then
set owner = Repository.GetElementByID(item.ParentID)
else
if item.ObjectType <> otPackage then
'else we return the package (not for packages because then we have a root package that doesn't have an owner)
set owner = Repository.GetPackageByID(item.PackageID)
end if
end if
'TODO: add other cases such as attributes and operations
end select
'return owner
set getOwner = owner
end function
Function lpad(strInput, length, character)
lpad = Right(String(length, character) & strInput, length)
end function
function makeArrayFromArrayLists(arrayLists)
dim returnArray()
'get the dimensions
dim x
dim y
x = arrayLists.Count
dim row
y = 0
'get the largest row for y
for each row in arrayLists
if y < row.Count then
y = row.Count
end if
next
'redim the array to the correct dimensions
redim returnArray(x-1,y-1)
dim i,j
i = 0
dim field
for each row in arrayLists
'reset j
j = 0
for each field in row
if IsObject(field) then
set returnArray(i,j) = field
else
returnArray(i,j) = field
end if
j = j + 1
next
i = i + 1
next
'return the array
makeArrayFromArrayLists = returnArray
end function