I am using VBS to move an element found in a diagram to the parent package of where the diagram lives. Per Enterprise Architect resources, I obtain an element ID from a diagram object. It seemsthat the diagramObject elementID is not equivalent to an element's elementID since attempting to retrieve the parentpackage of using the elementID gives me an undefined value.
Is there a way I can get to the element's parent package from the diagram object?
EDIT: Added code that I am using
Specific Portion ():
dim diagObject
set diagObject = package.Diagrams.GetAt(i).DiagramObjects.GetAt(j)
'add element to list and track its origin
dim elementID
elementID = diagobject.ElementID
dim element
set element = Repository.GetElementByID(elementID)
Session.Prompt elementID, promptOK
Session.Prompt "Test: " & element.PackageID, promptOK
Whole Function:
Function prepare(package)
'define parent package id
dim parentID
parentID = package.PackageID
'iterate through diagrams
Dim i
For i = 0 to Package.Diagrams.Count-1
'iterate through diagram objects
Session.Prompt "iterate through diagram objects", promptOK
Dim j
For j = 0 to package.Diagrams.GetAt(i).DiagramObjects.Count-1
'Check if the object is a element
Session.Prompt package.Diagrams.GetAt(i).DiagramObjects.GetAt(j).ObjectType, promptOK
If (19 = package.Diagrams.GetAt(i).DiagramObjects.GetAt(j).ObjectType) Then
Session.Prompt "IS A element", promptOK
dim diagObject
set diagObject = package.Diagrams.GetAt(i).DiagramObjects.GetAt(j)
'add element to list and track its origin
dim elementID
elementID = diagobject.ElementID
dim element
set element = Repository.GetElementByID(elementID)
Session.Prompt elementID, promptOK
Session.Prompt "Test: " & element.PackageID, promptOK
originList.Add elementID, element.PackageID
Session.Prompt PackageID, promptOK
'move element to currently selected package
element.PackageID = parentID
Session.Prompt "Moved", promptOK
End If
Next
Next
You are never updating element after altering its PackageID. Once you do that, everything should be fine.
Here is a link to the Object Model Reference
You must get the element from the DiagramObject first, as the DiagramObject is not the element
element=Repository.GetElementByID(yourDiagramObject.ElementID)
packageID=element.PackageID
Related
As I can't solve my problem I'd like to ask someone more experienced.I created simple dialog (4 fields) to let the user enter few data. After clicking "Submit" button those data should be inserted into textboxes put ON THE SHEET (not on any dialog). How to refer to those sheet texboxes in code to insert those data? Other thing is deleting those data after clicking other button "Clear". Suppose it will be similar to inserting but how this piece of code should look like?
Thanks in advance.
The trick is to create a com.sun.star.drawing.TextShape object and add it to the Draw Page of the target sheet. The following works for me. You should be able to assign it to the appropriate button on your dialog.
Sub InsertTextBox()
Dim oDocument As Object
oDocument = ThisComponent
If oDocument.SupportsService("com.sun.star.sheet.SpreadsheetDocument") Then
Dim sText As String
sText = "Blah,blah, blah!"
Dim oPosition As New com.sun.star.awt.Point
oPosition.X = 1000
oPosition.Y = 1000
Dim oSize As New com.sun.star.awt.Size
oSize.Width = 10000
oSize.Height = 5000
Dim oTextShape As Object
oTextShape = oDocument.createInstance("com.sun.star.drawing.TextShape")
oTextShape.setPosition(oPosition)
oTextShape.setSize(oSize)
oTextShape.setPropertyValue("FillStyle", "SOLID")
oTextShape.Visible = 1
' Give it a name so you can find it again when you want to delete it
oTextShape.setPropertyValue("Name", "Thingy")
Dim oDrawPage As Object
oDrawPage = oDocument.getSheets().getByIndex(0).getDrawPage()
oDrawPage.add(oTextShape)
' Set the string of the text shape AFTER adding it to the
' draw page, otherwise the text will not be set.
oTextShape.setString(sText)
End If
End Sub
In the above routine the TextShape object was given the name "Thingy". You can obviously give it any name you like, but it should be unique. To delete it, you need to loop through all the objects in the draw page, find the one that is a TextShape and has the name you gave it (in this case "Thingy") and remove it. This can be done as follows:
Sub DeleteTextBox()
Dim oDocument As Object
oDocument = ThisComponent
If oDocument.SupportsService("com.sun.star.sheet.SpreadsheetDocument") Then
Dim oDrawPage As Object
oDrawPage = oDocument.getSheets().getByIndex(0).getDrawPage()
Dim oShape As Object
Dim i As Long
For i = (oDrawPage.getCount() - 1) To 0 Step -1
oShape = oDrawPage.getByIndex(i)
If oShape.SupportsService("com.sun.star.drawing.TextShape") Then
If StrComp(oShape.getPropertyValue("Name"), "Thingy") = 0 Then
oDrawPage.remove(oShape)
End If
End If
Next i
End If
End Sub
This will delete all objects of type TextShape and named "Thingy"
I am trying to create two tables which mirror changes made to any of them to one another automatically.
To that end, I added event listeners which are triggered when the cells of these tables are edited by the user.
Unfortunately, editing one of the tables causes LibreOffice to crash, even though the changes are indeed reflected correctly, as seen upon reopening the file.
I thought the crash might be due to a never-ending circular reference, but it still crashes after it has been made non-circular (by commenting out the relevant parts of the code so that changes are reflected only one way rather than both ways).
I noticed the code worked fine when writing to a cell that didn't have an event listener set to it.
How can I write to one of the cells with event listeners set to them without causing LibreOffice to crash?
You may want to download the following file. Please run Main and then try editing the cell C3 of the Planning sheet. The arbitrary string "C" should be written in the cell C4 of the Services sheet.
Here is a simplified version of the code :
REM ***** BASIC *****
const SERVICESSHEET_NUMBER = 2
const SERVICESSHEET_SERVICES_COLUMN = 2
Type cellStruct
columnNumber As Integer
rowNumber As Integer
End Type
Sub UpdateServicesSheet(editedCell As cellStruct, newValue As String)
Dim oSheets
Dim servicesSheet
oSheets = ThisComponent.getSheets()
servicesSheet = oSheets.getByIndex(SERVICESSHEET_NUMBER)
servicesSheet.getCellByPosition(SERVICESSHEET_SERVICES_COLUMN, 3).setString(newValue)
End Sub
Private oListener, cellRange as Object
Sub AddListener
Dim sheet, cell as Object
sheet = ThisComponent.Sheets.getByIndex(0) 'get leftmost sheet
servicesSheet = ThisComponent.Sheets.getByIndex(2)
cellRange = sheet.getCellrangeByName("C3")
oListener = createUnoListener("Modify_","com.sun.star.util.XModifyListener") 'create a listener
cellRange.addModifyListener(oListener) 'register the listener
cellRange = servicesSheet.getCellrangeByName("C4")
oListener = createUnoListener("Modify_","com.sun.star.util.XModifyListener") 'create a listener
cellRange.addModifyListener(oListener) 'register the listener
End Sub
global CircularReferenceAllowed As boolean
Sub Modify_modified(oEv)
Dim editedCell As cellStruct
Dim newValue As String
editedCell.columnNumber = 2
editedCell.rowNumber = 2
If CircularReferenceAllowed Then
CircularReferenceAllowed = false
UpdateServicesSheet(editedCell, "C")
End If
End Sub
Sub Modify_disposing(oEv)
End Sub
Sub RmvListener
cellRange.removeModifyListener(oListener)
End Sub
Sub Main
CircularReferenceAllowed = true
AddListener
End Sub
Crossposted to :
OpenOffice forums
LibreOffice discourse platform
It seems like the event trigger is within another event's function is causing the crash. In any case, the solution is to remove the listener, then add it back after modifying the other cell.
You do need to global the Listener and the Cell objects to make this work.
This code is simplified to work on C3 and C15 on the first sheet. It would also output some information on C14, which isn't really necessary for your purpose, but I use it to see what's happening. You need to adopt the according to what you need.
global goListener as Object
global goListener2 as Object
global goCellR as Object
global goCellR2 as Object
global goSheet as Object
global giRun as integer
global giUpd as Integer
Sub Modify_modified(oEv)
Dim sCurStr$
Dim sNewStr As String
'xRay oEv
giRun = giRun + 1
sCurStr = oEv.source.string
oCell = goSheet.getCellByPosition(2, 14)
If (oCell.getString() <> sCurStr) Then
' only update if it's different.
giUpd = giUpd + 1
goCellR2.removeModifyListener(goListener2)
oCell.setString(sCurStr)
goCellR2.addModifyListener(goListener2)
End If
sNewStr =sCurStr & " M1 Run=" & giRun & " Upd=" & giUpd
goSheet.getCellByPosition(2, 13).setString(sNewStr)
End Sub
Sub Modify2_modified(oEv)
Dim sCurStr$
Dim sNewStr As String
Dim oCell as Object
'xRay oEv
giRun = giRun + 1
sCurStr = oEv.source.string
oCell = goSheet.getCellByPosition(2, 2)
If (oCell.getString() <> sCurStr) Then
' only update if it's different.
giUpd = giUpd + 1
goCellR.removeModifyListener(goListener)
oCell.setString(sCurStr)
goCellR.addModifyListener(goListener)
End If
sNewStr =sCurStr & " M2 Run=" & giRun & " Upd=" & giUpd
goSheet.getCellByPosition(2, 13).setString(sNewStr)
End Sub
Sub Modify_disposing(oEv)
MsgBox "In Modify_disposing"
End Sub
Sub Modify2_disposing(oEv)
MsgBox "In Modify2_disposing"
End Sub
Sub RmvListener
MsgBox "In RmvListener"
goCellR.removeModifyListener(goListener)
goCellR2.removeModifyListener(goListener2)
End Sub
Sub AddListener
goSheet = ThisComponent.Sheets.getByIndex(0) 'get leftmost goSheet
'servicesSheet = ThisComponent.Sheets.getByIndex(2)
goCellR = goSheet.getCellrangeByName("C3")
goListener = createUnoListener("Modify_","com.sun.star.util.XModifyListener") 'create a listener
goCellR.addModifyListener(goListener) 'register the listener
goCellR2 = goSheet.getCellrangeByName("C15")
goListener2 = createUnoListener("Modify2_","com.sun.star.util.XModifyListener") 'create a listener
goCellR2.addModifyListener(goListener2) 'register the listener
End Sub
Sub Main
giRun = 0
giUpd = 0
AddListener
End Sub
I have many use case diagrams defined in a model in Enterprise Architect. The diagrams are at different levels in the hierarchy. Irrespective of where the diagram is located, is there any way to access all the use case diagrams (any diagram for that matter) present in the model using Enterprise Architect Java API?
The Java API is nothing more then a layer around the regular API, so I'm answering in general.
You can of course traverse the whole model in code to get diagrams, but that will take ages in any non-trivial model.
So what you want to do is
query the model to get all diagram guid's using EA.Repository.SQLQuery()
loop the diagram guid's and get each diagram using EA.Repository.GetDiagramByGUID()
The SQL Query
The SQL Query you need to get all use case diagram guid's is the following
select d.ea_guid from t_diagram d
where d.Diagram_Type = 'Use Case'
Getting a list of values from the query
EA.Repository.SQLQuery() returns an XML string, so you need to parse that to get a list of values. This example is an operation in VBScript that does exactly that:
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
Getting the diagram based on the guid's
Loop the resulting query and use Repository.GetDiagramByGUID()
In VBScript that would be something like this (supposing the results of the query are stored in the variable guidResults)
dim diagram as EA.Diagram
dim diagrams
set diagrams = CreateObject("System.Collections.Arraylist")
dim guid
for each guid in guidResults
set diagram = Repository.GetDiagramByGuid(guid)
diagrams.Add diagram
next
I'm trying to create a form which contains two entries:
-folder number
-list of toms which are in folders
This is for archiving purpose. Form is divided on 4 section which will be printed on labels for archive boxes.
Folders are numbered from 1 to 1500, some of them contain 1 tom of documents, some of them up to 10. For now I'm doing this manualy by just copying from the table which looks like this:
table
Only thing I need in form is TOM NUMBER from this table
form
I was trying to use VLOOKUP but it only returns first row which has searched folder number.
So bascially I want a function which will take folder number from label form and find all toms which are assigned to and write it below. first 3 digits in folder number aren't important, only last 4 digits are considered most important variable
Unfortunately vlookup will not work, you are going to have to use an array folder. I am making an assumption that you will have a table that is called [Folders]
and I am going to create a form form with some vba on how to do this.
1. Create a Table by selecting the folder dataset and push ctl+T.
Alt + F11 to enter Visual basic editor
At the top choose insert ==> UserForm
Push F4 and in the properties window name your form FileFinder
Your toolbox maynot appear if it doesn't choose view => toolbox to open
drag 2 labels, 2 listboxes, and 2 buttons, you can format it however you like.
7.Create a new Module same as adding userform only choose module
Copy paste this code
Public Function CreateWorksheet(Optional name As String = "") As Worksheet
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets.Add
If name <> "" Then ws.name = name
Set Create = ws
End Function
Public Function LastRow() As Integer 'gets last row from column A
LastRow = ActiveSheet.Cells(Rows.count, 1).End(xlUp).Row
End Function
Public Function DistintFolders() As String()
Dim list() As String
Dim counter As Integer
For Each cell In ActiveSheet.Range("E2:E" & LastRow)
If Not IsInList(list, cell.Value, counter) Then
counter = counter + 1
ReDim Preserve list(1 To counter)
list(counter) = cell.Value
End If
Next cell
DistintFolders = list
End Function
Public Function TomNumberByFolder(folderName As Variant) As String()
Dim list() As String
Dim counter As Integer
Dim rowNumber As Integer
For Each cell In ActiveSheet.Range("B2:B" & LastRow)
rowNumber = rowNumber + 1
If IsCorrectFolder(folderName, rowNumber) Then
counter = counter + 1
ReDim Preserve list(1 To counter)
list(counter) = cell.Value
End If
Next cell
TomNumberByFolder = list
End Function
Public Function IsInList(ByRef list() As String, compare As String, count As Integer) As Boolean
Dim l As Variant
If compare = "" Then
IsInList = True
Exit Function
End If
If count = 0 Then
IsInList = False
Exit Function
End If
For Each l In list
If l = compare Then
IsInList = True
Exit Function
End If
Next l
IsInList = False
End Function
Public Function IsCorrectFolder(folderName As Variant, rowNumber As Integer) As Boolean
IsCorrectFolder = (ActiveSheet.Range("E" & rowNumber).Value = folderName)
End Function
double click your form and paste this code
`
Private Sub btnCancel_Click()
Unload Me
End Sub
Private Sub btnCreate_Click()
Dim ws As Worksheet
If lstTom.ListCount = 0 Then
MessageBox "Please select a folder"
End If
Set ws = ThisWorkbook.Sheets.Add
ws.Cells(1, 1).Value = "Tom Number"
ws.Cells(2, 1).Resize(Me.lstTom.ListCount, 1) = Me.lstTom.list
End Sub
Private Sub lstFolder_Click()
Dim folder As String
If ActiveSheet.name <> "Data" Then ThisWorkbook.Sheets("Data").Activate 'please name this whatever your datasheet is called
For i = 0 To lstFolder.ListCount - 1
If lstFolder.Selected(i) Then
Me.lstTom.Clear
For Each s In TomNumberByFolder(lstFolder.list(i))
With lstTom
.AddItem s
End With
Next s
End If
Next i
End Sub
Private Sub UserForm_Initialize()
For Each s In DistintFolders
With lstFolder
.AddItem s
End With
Next s
End Sub
`
please note that you may have to change sheet names if you would like I will send you this.
Download Here
I am writing code which is supposed to read in data from an Excel worksheet, save it as strings into variables contained in an object of a class which I have defined and then add this object to an object tree of a class which I have also defined.
Dim ProdTreeMain As New CProdTree
Dim nR As Range
Dim nnR As Range
Set nR = oXS.Range("A1")
Set nnR = oXS.Range("A1")
dim r as integer
r = 1
Do While Not (nR.Text = "" And nnR.Text = "")
If CONDITION IS TRUE:
Dim currProd As New CProduct
ProdTreeMain.addProduct (currProd) '<-- error 438 "Object doesn't support property or method
End If
r = r + 1
Set nR = oXS.Range("A" & CStr(r + 1))
Set nR = oXS.Range("A" & CStr(r + 2))
Loop
The class CProdTree contains a sub "addProduct" which takes an input object of class CProduct by reference.
Public Sub addProduct(ByRef Prod As CProduct)
What the hell is going on? The class is defined, the sub correct, the variable type being passed to the sub is of the correct class and yet I get this error ... :/
You need to drop the parentheses around the argument. My favorite explanation is this Daily Dose of Excel post.
This line:
ProdTreeMain.addProduct (currProd)
becomes:
ProdTreeMain.addProduct currProd