I need some help on this. I have a grid of lines/arcs that I need to be able to select and run the VBA and have it place a data point at the all the intersections of the selected elements. I have done some reading online, but I dont know enough about VBA in Microstation to get started. I have attached a screen shot of the grid I am working with. Actually I am trying to locate these points and using the tracking tool in InRoads I need to find surface elevations at all the intersection points. I think I can select the lines and then activate the tracking tool in InRoads and then run the VBA to place a data point at all the intersections. Any help will be greatly appreciated.
Jon,
Sorry I mistyped before. I am using Matrix3dIdentity.
Sub LabelIntersectionsofLines()
Dim ScanCriteria As New ElementScanCriteria
Dim ScanEnumerator As ElementEnumerator
Dim ScanEnumerator2 As ElementEnumerator
Dim MyElement As Element
Dim MyElement2 As Element
Dim t As Integer
Dim i As Integer
Dim points() As Point3d
Dim point As Point3d
i = -1
ScanCriteria.ExcludeAllLevels
ScanCriteria.IncludeLevel ActiveDesignFile.Levels("1Left_Coping")
Set ScanEnumerator = ActiveModelReference.Scan(ScanCriteria)
Set ScanEnumerator2 = ActiveModelReference.GetSelectedElements
Do While ScanEnumerator.MoveNext
Set MyElement = ScanEnumerator.Current
Do While ScanEnumerator2.MoveNext
Set MyElement2 = ScanEnumerator2.Current
If MyElement.IsIntersectableElement Then
points = MyElement.AsIntersectableElement.GetIntersectionPoints(MyElement2, Matrix3dIdentity)
End If
For t = 0 To UBound(points)
MsgBox ("x:" & points(t).X & " " & "y:" & points(t).Y & " " & "z:" & points(t).Z)
CadInputQueue.SendDataPoint points(t), 1
Next
Loop
End Sub
Stefan. I cant figure out where this goes in my code. Can you look at the code I pasted above and show me how this would work in my code
Stefan,
I changed it to compare the current selection as both ElementEnumerators so it is effectively comparing against itself so I don't have to worry about the levels. I can have the user select all the elements and then it will give them all the intersection points.
I have figured out when it gives me the duplicate intersection points. When a line has been extended to intersection of the other element then it will give me two intersection points but if I extend the line to where they are crossing each other not one element extended to the intersection then it will only give me one intersection point. I don't know what is causing this but this is when the issues occurs. Thanks for all your help.
Comment out your Line and put mine instead:
'ScanCriteria.IncludeLevel ActiveDesignFile.Levels("1Left_Coping")
AddVisibleLevelsToScanCriteria ScanCriteria, 0
And you have to paste my function into your module of course.
Regards, Stefan.
OK guys. I am still having issues with this VBA. Here is the current code. Now the problem I am having is when a level has more than 1 element on it then it will only process the first element. Now I am comparing my selection set vs. the active level and it works fine as long as the active level has only one element. If the active level has 2 or more elements then it will only find the intersection of my selection set vs the first element on the level. PLEASE HELP!!! THANKS!
Sub LabelIntersections()
ScanCriteria.IncludeLevel ActiveSettings.Level
'MsgBox ("x:" & points(t).X & " " & "y:" & points(t).Y & " " & "z:" & points(t).Z)
CadInputQueue.SendCommand "MDL SILENTLOAD CLEANUP"
lngTemp = Not 15
lngTemp = GetCExpressionValue("sdG.duplicatesAction", "CLEANUP") And lngTemp
SetCExpressionValue "sdG.duplicatesAction", lngTemp Or 2, "CLEANUP"
CadInputQueue.SendCommand "CLEANUP DO"
CadInputQueue.SendCommand "DMSG UPDATEDIALOG -400"
CadInputQueue.SendCommand "MDL UNLOAD CLEANUP"
Set ScanEnumerator = Nothing
Set ScanEnumerator2 = Nothing
Phillip:
You should not process points if MyElement.IsIntersectableElement returns False.
It should be like this:
If MyElement.IsIntersectableElement Then points = MyElement.AsIntersectableElement.GetIntersectionPoints(MyElement2, Matrix3dIdentity)
For t = 0 To UBound(points) CadInputQueue.SendDataPoint points(t), 1 Next End If
Calls:
Set ScanEnumerator = NothingSet ScanEnumerator2 = Nothing
are in your case redundant.
You've mixing program code with queued commands, which is not a good idea. Use either key-ins or program code, but not both.
In this case, you queue a command to send a data point in the middle of your loop. A queued command won't bubble to the top of MicroStation's input queue until nothing else is going on. But there is something going on: the code in your loop.
Write a procedure to add a marker at each data point. I've provided PlaceMarker, but you can call it what you want.
' --------------------------------------------------------------------- Sub PlaceMarker(ByRef point As Point3d) Dim oCircle As EllipseElement Set oCircle = CreateEllipseElement2(Nothing, point, 1#, 1#, Matrix3dIdentity) ActiveModelReference.AddElement oCircle End Sub ' --------------------------------------------------------------------- Sub LabelIntersections() Dim oScanCriteria As New ElementScanCriteria Dim oScannedLines As ElementEnumerator Dim oSelectedLines As ElementEnumerator Dim oScannedElement As Element Dim oSelectedElement As Element Dim points() As Point3d oScanCriteria.ExcludeAllLevels oScanCriteria.IncludeLevel ActiveSettings.Level Set oScannedLines = ActiveModelReference.Scan(oScanCriteria) Set oSelectedLines = ActiveModelReference.GetSelectedElements Do While oScannedLines.MoveNext Set oScannedElement = oScannedLines.Current Do While oSelectedLines.MoveNext Set oSelectedElement = oSelectedLines.Current ' Make sure that we're not comparing an element with itself If 0 <> DLongComp(oScannedElement.ID, oSelectedElement.ID) Then If oScannedElement.IsIntersectableElement Then points = oScannedElement.AsIntersectableElement.GetIntersectionPoints(oSelectedElement, Matrix3dIdentity) End If Dim t As Integer For t = 0 To UBound(points) 'MsgBox ("x:" & points(t).X & " " & "y:" & points(t).Y & " " & "z:" & points(t).Z) Debug.Print "x:" & points(t).X & " " & "y:" & points(t).Y & " " & "z:" & points(t).Z 'CadInputQueue.SendDataPoint points(t), 1 PlaceMarker points(t) Next End If Loop Loop CadInputQueue.SendCommand "MDL SILENTLOAD CLEANUP" Dim lngTemp As Long lngTemp = Not 15 lngTemp = GetCExpressionValue("sdG.duplicatesAction", "CLEANUP") And lngTemp SetCExpressionValue "sdG.duplicatesAction", lngTemp Or 2, "CLEANUP" CadInputQueue.SendCommand "CLEANUP DO" CadInputQueue.SendCommand "DMSG UPDATEDIALOG -400" CadInputQueue.SendCommand "MDL UNLOAD CLEANUP" Set oScannedLines = Nothing Set oSelectedLines = Nothing End Sub
Those lines after the loop look fishy. That's write-only code. I have no idea what it does, and neither will you in six months time. Wrap it in a procedure and give it a meaningful name 8-)
Regards, Jon Summers LA Solutions
+1 Jon.
Maybe we want to pretty up the nested loops...?
The "fishy" code at the bottom looks like a check for duplicate lineworks or elements.
You could implement such checks in your code to. Simply create a collection of points a check against that list before placing the mark.
' ---------------------------------------------------------------------
Sub PlaceMarker(ByRef point As Point3d)
Dim oCircle As EllipseElement
Set oCircle = CreateEllipseElement2(Nothing, point, 1#, 1#, Matrix3dIdentity)
ActiveModelReference.AddElement oCircle
Sub LabelIntersections_HandleOneElement(oSelectedElement as Element)
Dim oScanCriteria As New ElementScanCriteria
Dim oScannedLines As ElementEnumerator
Dim oScannedElement As Element
oScanCriteria.ExcludeAllLevels
oScanCriteria.IncludeLevel ActiveSettings.Level
Set oScannedLines = ActiveModelReference.Scan(oScanCriteria)
Do While oScannedLines .MoveNext
Set oScannedElement = oScannedLines .Current
If oScannedElement.IsIntersectableElement Then
points = oScannedElement.AsIntersectableElement.GetIntersectionPoints(oSelectedElement, Matrix3dIdentity)
PlaceMarker points(t)
Dim oSelectedLines As ElementEnumerator
Dim oSelectedElement As Element
Set oSelectedLines = ActiveModelReference.GetSelectedElements
Do While oSelectedLines.MoveNext
Set oSelectedElement = oSelectedLines.Current
LabelIntersections_HandleOneElement oSelectedElement
....