Macro to add leader with text to selected CATPart/Product points in to a drawing view

[Wifirex]

Ref: thread560-349581

Here is the working version of what the previous thread managed to achieve. Still a long shot from what I am looking for but someone may find it useful.

' ==============================================================
' Purpose: Code to create a text file in Folder (MUST BE SPECIFIED BELOW) and write CATDrawing points coordinates inside from the currently active view 
' Usage:   1 - A CATDrawing document must be active and drawn points must be present (CATPart points don't work)
'               2 - Run macro 
' Author: modifed by ferdo, originator unknown (Disclaimer: You use this code at your own risk) 
' ===============================================================

Sub CATMain()

Dim Documents1 'As Documents
Dim DrawDocument1  'As DrawingDocument
Dim DrawSheets1 'As DrawingSheets
Dim DrawSheet1 'As DrawingSheet
Dim GeoEle 'As GeometricElements
Dim Pt2D 'As Point2D

On Error Resume Next

' Code to create and write in a file
' The resulting file its not so fine, I don't have time to make it look better....

Dim sPath 'As PathString
Dim sTime 'As TimeString
Dim sName 'As TimeString
Dim sFile 'As TimeString

documentname = CATIA.ActiveDocument.Name
position = InStr(documentname,".CATDrawing")
position = position -1
documentname = Left(documentname,position)
sPath = "C:\Users\XXXXXXXX" ' <<<<< SPECIFY PATH HERE
'~ sPath = CATIA.Application.SystemService.Environ("CATReport")            
sName = "\XYDrawing_" & documentname & ".TXT"       
sFile = sPath & sName

Set oFileOut = CATIA.FileSystem.CreateFile(sFile,TRUE)
Dim oStream 'As TextStream
Set oStream = oFileOut.OpenAsTextStream("ForWriting")

' Code for Points    

Set documents1 = CATIA.Documents
Set drawDocument1 = CATIA.ActiveDocument
Set DrawSheets1 = drawDocument1.Sheets
Set DrawSheet1 = DrawSheets1.ActiveSheet
Set DrawViews = DrawSheet1.Views
Set DrawView1 = DrawViews.ActiveView
Set GeoEle = DrawView1.GeometricElements

For i = 1 To GeoEle.Count
	Set Pt2d = GeoEle.Item(i)
	Dim coord(1)
	if Pt2d.GeometricType = 2 then		 ' GeometricElement 2 = CatGeotypePoint2D
		Pt2d.GetCoordinates coord
		 ' change value in inch if you want, just delete ' (the comment sign)
		coord(0) = coord(0)'/25.4
		coord(1)=coord(1)'/25.4
	
	end if

	Set Point(i) = GeoEle.Item(i).Value
   	oStream.Write (Pt2d.Name&" :"&coord(0)&" , "&coord(1))

Next

oStream.close
MsgBox "Check the file : " & sFile, vbInformation       ' information about where the file is

End Sub

I will clarify in my next post what exactly these guys were trying to do, and see if anyone can collaborate with me by picking up where these guys left off to get this macro working.

Schöne Grüße aus Berlin

 

[Wifirex]

Now, what I'm trying to find a solution for is a macro that can recognise the points in a Polyline in 3D ideally in an active drawing view, or in the 3D part tree (worst case), and either adding a Text with Leader directly to each of them if it's possible, or by generating a new set in 2D points that overlay the 3D points followed by adding Text with Leader to all, and lastly to offer a basic index text box to ask what the prefix should be (A-Z 0-9), what the suffix should be (same again) for the Text to Leader as it is written to each point, and put this information into the active view. The reason I need this Macro is that our department is working with lots of routings for pipes/hoses and our manufacturers use coordinate tables. Creating a coordinate table is easy, but labelling each point on the routing in a drawing is both time consuming...and as I see it...unnecessarily mind numbing. Ideally, we only need to reference one view completely and then these leaders can by copied to other views.

4 Milestones to cover.
- Recognise the generated 3D points within the drawing (semi finished but 2D only)
- Overwrite the points with 2D points if necessary
- Add a basic function to index the text before finally....
- Add the Text with Leader to these points

Can anyone help out with this? Pick a Milestone you know your way around and have at it.

Schöne Grüße aus Berlin,

Wifirex

 

[iscariot]

I am lost ... could you post a picture on what you try to achieve?

 

[Wifirex]

Picture 1: a Polyline drawn in 3D with 3D points. Picture 2: Leader with Text added to each point along the chain (Chain priority 1, X-Axis priority 2 and Y-Axis priority 3).

 

[ferdo]

Some sample files (not your real files, but 3D and 2D) would help users to test if they have some solutions(and for sure they are existing).

Regards
Fernando

https://picasaweb.google.com/102257836106335725208

- Romania

https://picasaweb.google.com/103462806772634246699/

- EU

 

[Wifirex]

Hello Ferdo!

I have seen several of your posts and I am pleased to see you posting on this topic

I just read this morning that generated items are not exposed to the VBA API and will be hard to attach features to them (e.g a leader with text). This is why I was suggesting an overlay of drawn 2D points that can be referenced to the generated 3D points within the drawing (and so that they don't lose their relationship if the model is changed).

Uploading basic polyline with drawing right now.

 

[Wifirex]

And here's the drawing

 

[Wifirex]

Update: I'm currently modifying this script to see if I can call on the generated points and draw a line to them (originally designed to draw a line to traverse the center point of holes and place a point in their centers).

If anyone wants to have a crack at it also - here it is:

Sub CATMain()

' Choose one of two ways to generate vectors.
' Comment out unused method with " ' " sign

'Call CreateHoleVectorsWithoutEdges ' this will generate vectors and points without linking them to hole geometry
Call CreateHoleVectorsWithEdges ' this generates vectors, linked to geometry of hole's "end" faces

End Sub


'======================================================================================================
' Sets layer for choosen geometrical feature with respect to Hole Diameter.
'======================================================================================================
Private Sub SetHoleGeometryLayer(ByVal objHoleGeometry As HybridShape, ByVal dblHoleDiameter As Double)

' quickly check inputs
If (objHoleGeometry Is Nothing) Then
Exit Sub
End If

' get selection object
Dim objSelection As Selection
Set objSelection = CATIA.ActiveDocument.Selection

' get access to graphic properties of object
Dim objVisProp As VisPropertySet

Call objSelection.Clear
Call objSelection.Add(objHoleGeometry)
Set objVisProp = objSelection.VisProperties


' choose proper layer for geometry using hole diameter as a criteria
Dim iLayer As Integer

Select Case dblHoleDiameter

' ENLIST ALL POSSIBLE DIAMETERS AND CORRESPONDING LAYER NUMBERS HERE
Case 10: iLayer = 1
Case 20: iLayer = 2
Case 30: iLayer = 3
Case 40: iLayer = 4

' if no suitable diameter was found, geometry will be sent to "None" layer
Case Else: iLayer = -1
End Select

If (iLayer < 0) Then
Call objVisProp.SetLayer(catVisLayerNone, 0)
Else
Call objVisProp.SetLayer(catVisLayerBasic, iLayer)
End If


' clear selection
Call objSelection.Clear

End Sub


'========================================================================================================
' Translates reference string (retrieved with DisplayName) of Edge, Face or Vertex object, making it usable in construction
'========================================================================================================
Private Function TranslateReferenceStr(ByVal strReference As String) As String

' set default value
TranslateReferenceStr = strReference

' quickly check inputs
If (TranslateReferenceStr = "") Then
Exit Function
End If

' analyze string
Dim posSelection As Integer
Dim posCf As Integer

' check if it is string from reference retrieved from selection
posSelection = InStr(1, strReference, "Selection_")
If (posSelection = 0) Then
Exit Function
End If

' remove "Selection" from string
strReference = Right(strReference, Len(strReference) - Len("Selection_"))

' cut bad ending
posCf = InStrRev(strReference, "Cf11));")
strReference = Left(strReference, posCf + Len("Cf11));") - 1)

' insert new ending
strReference = strReference & "WithPermanentBody;WithoutBuildError;WithSelectingFeatureSupport;MFBRepVersion_CXR15)"


' return translated string
TranslateReferenceStr = strReference

End Function

'========================================================================================================
' Creates vectors and points on hole ends basing solely on their coordinates
'========================================================================================================
Private Sub CreateHoleVectorsWithoutEdges()

' part infrastructure
Dim RootPart As Part
Set RootPart = CATIA.ActiveDocument.Part

Dim PartBody As Body
Set PartBody = RootPart.MainBody

Dim SPAWbench As SPAWorkbench
Set SPAWbench = CATIA.ActiveDocument.GetWorkbench("SPAWorkbench")



' find and create (if necessary) "Points and Vectors" geometrical set
Dim PnVGeoSet As HybridBody
On Error Resume Next
Set PnVGeoSet = RootPart.HybridBodies.Item("Points and Vectors")
If (Err.Number 0) Then
' geometrical set not found, create new one
Set PnVGeoSet = RootPart.HybridBodies.Add()
PnVGeoSet.name = "Points and Vectors"

Call Err.Clear
End If
On Error GoTo 0

' find all Holes inside PartBody and form collection of them
Dim objSelection As Selection
Set objSelection = CATIA.ActiveDocument.Selection

Call objSelection.Clear
Call objSelection.Add(PartBody)
objSelection.Search "'Part Design'.Hole,sel" '.Search "'Part Design'.Hole,sel"

Dim colHoles As Collection
Set colHoles = New Collection

Dim iHole As Integer
For iHole = 1 To objSelection.Count2
Call colHoles.Add(objSelection.Item2(iHole).Value)
Next

Call objSelection.Clear



' for each hole create "axis" lines and points
Dim objHSF As HybridShapeFactory
Set objHSF = RootPart.HybridShapeFactory

Dim hlHole As Hole
Dim objHole As AnyObject
Dim refHole As Reference

Dim iHoleType As CatHoleType
Dim lntDepth As Length
Dim lmtDepth As Limit
Dim dblDepth As Double
Dim dblDiameter As Double

Dim ArrOriginPoint(2) As Variant
Dim ArrDirection(2) As Variant

Dim objOriginPoint As HybridShapePointCoord
Dim refOriginPoint As Reference
Dim objEndPoint As HybridShape
Dim refEndPoint As Reference
Dim objHoleDirection As HybridShapeDirection
Dim refHoleDirection As Reference

Dim blOrientation As Boolean

Dim objHoleAxis As HybridShape
Dim refHoleAxis As Reference

For iHole = 1 To colHoles.Count

' get hole object
Set hlHole = colHoles(iHole)
Set objHole = hlHole
Set refHole = RootPart.CreateReferenceFromObject(objHole)

'----------------
' BASIC HOLE INFO
'----------------
' retrieve hole type
iHoleType = hlHole.Type

' determine depth of the hole
If (iHoleType = catSimpleHole) Or (iHoleType = catTaperedHole) Then
Set lmtDepth = hlHole.BottomLimit
Set lntDepth = lmtDepth.Dimension
Else
Set lntDepth = hlHole.HeadDepth
End If

dblDepth = lntDepth.Value

' !!!!! IMPORTANT!!!!!!
' Determine hole direction orientation
' Seems like hole is always created opposingly to it's direction vector (retrieved below)
blOrientation = False


' get hole diameter
dblDiameter = hlHole.Diameter.Value

'---------------------------
' POINTS AND VECTOR CREATION
'---------------------------
' retrieve hole origin and direction
Call objHole.GetOrigin(ArrOriginPoint)
Call objHole.GetDirection(ArrDirection)

' create explicit origin point and compute it's geometry
Set objOriginPoint = objHSF.AddNewPointCoord(ArrOriginPoint(0), ArrOriginPoint(1), ArrOriginPoint(2))
Set refOriginPoint = RootPart.CreateReferenceFromObject(objOriginPoint)
Call objOriginPoint.Compute

' place origin point in "Points and Vectors" geometrical set
Call PnVGeoSet.AppendHybridShape(objOriginPoint)

' create explicit direction
Set objHoleDirection = objHSF.AddNewDirectionByCoord(ArrDirection(0), ArrDirection(1), ArrDirection(2))
' Set refHoleDirection = RootPart.CreateReferenceFromObject(objHoleDirection)
Call objHoleDirection.Compute



' create axis line along hole direction
Set objHoleAxis = objHSF.AddNewLinePtDir(refOriginPoint, objHoleDirection, 0, dblDepth, blOrientation)
Set refHoleAxis = RootPart.CreateReferenceFromObject(objHoleAxis)
Call objHoleAxis.Compute

' place line in "Points and Vectors" geometrical set
Call PnVGeoSet.AppendHybridShape(objHoleAxis)




' create point at the end of axis line
Set objEndPoint = objHSF.AddNewPointOnCurveFromPercent(refHoleAxis, 1, blOrientation)
Set refEndPoint = RootPart.CreateReferenceFromObject(objEndPoint)
Call objEndPoint.Compute

' place end point in "Points and Vectors" geometrical set
Call PnVGeoSet.AppendHybridShape(objEndPoint)


'--------------------------------------------
' ASSIGNING PROPER LAYER TO POINTS AND VECTOR
'--------------------------------------------

Call SetHoleGeometryLayer(objOriginPoint, dblDiameter)
Call SetHoleGeometryLayer(objEndPoint, dblDiameter)
Call SetHoleGeometryLayer(objHoleAxis, dblDiameter)

Next

' update geometrical set
Call RootPart.UpdateObject(PnVGeoSet)

End Sub

'========================================================================================================
' Creates required vectors and points by retrieving edges from holes
' This allows vectors to be linked with their corresponding holes
' and (theoretically) be properly updated when hole geometry changes
'========================================================================================================
Private Sub CreateHoleVectorsWithEdges()

' part infrastructure
Dim RootPart As Part
Set RootPart = CATIA.ActiveDocument.Part

Dim PartBody As Body
Set PartBody = RootPart.MainBody

Dim SPAWbench As SPAWorkbench
Set SPAWbench = CATIA.ActiveDocument.GetWorkbench("SPAWorkbench")



' find and create (if necessary) "Points and Vectors" geometrical set
Dim PnVGeoSet As HybridBody
On Error Resume Next
Set PnVGeoSet = RootPart.HybridBodies.Item("Points and Vectors")
If (Err.Number 0) Then
' geometrical set not found, create new one
Set PnVGeoSet = RootPart.HybridBodies.Add()
PnVGeoSet.name = "Points and Vectors"

Call Err.Clear
End If
On Error GoTo 0


' find all Holes inside PartBody and form collection of them
Dim objSelection As Selection
Set objSelection = CATIA.ActiveDocument.Selection

Call objSelection.Clear
Call objSelection.Add(PartBody)
Call objSelection.Search("'Part Design'.Hole,sel")

Dim colHoles As Collection
Set colHoles = New Collection

Dim iHole As Integer
For iHole = 1 To objSelection.Count2
Call colHoles.Add(objSelection.Item2(iHole).Value)
Next

Call objSelection.Clear



' for each hole create "axis" lines and points
Dim objHSF As HybridShapeFactory
Set objHSF = RootPart.HybridShapeFactory

Dim hlHole As Hole
Dim objHole As AnyObject
Dim refHole As Reference

Dim iHoleType As CatHoleType
Dim lntDepth As Length
Dim lmtDepth As Limit
Dim dblDepth As Double
Dim dblDiameter As Double

Dim ArrOriginPoint(2) As Variant
Dim ArrDirection(2) As Variant

Dim objOriginPoint As Point
Dim refOriginPoint As Reference
Dim objEndPoint As Point
Dim refEndPoint As Reference

Dim blOrientation As Boolean

Dim objHoleAxis As HybridShape
Dim refHoleAxis As Reference

Dim ArrEdges() 'As Collection
ReDim ArrEdges(colHoles.Count) 'As Collection

Dim colEdges As Collection

Dim iEdge As Integer
Dim refEdge As Reference
Dim strEdge As String

Dim colCenterPoints As Collection
Set colCenterPoints = New Collection


Dim iCenterPoint As Integer
Dim objCenterPoint As HybridShapePointCenter
Dim varCenterPoint As AnyObject
Dim refCenterPoint As Reference
Dim ArrCenterPoint(2) As Variant

Dim objMeas As Measurable
Dim dblDistance As Double



For iHole = 1 To colHoles.Count

' get hole object
Set hlHole = colHoles(iHole)
Set objHole = hlHole
Set refHole = RootPart.CreateReferenceFromObject(objHole)

'---------------------------------
' ENLIST ALL EDGES OF CURRENT HOLE
'---------------------------------
Call objSelection.Clear
Call objSelection.Add(hlHole)
Call objSelection.Search("Topology.Edge,sel")

Set colEdges = New Collection
For iEdge = 1 To objSelection.Count
strEdge = TranslateReferenceStr(objSelection.Item(iEdge).Value.DisplayName)
Set refEdge = RootPart.CreateReferenceFromBRepName(strEdge, objSelection.Item(iEdge).Value.Parent)

Call colEdges.Add(refEdge)
Next

Call objSelection.Clear


'--------------------------------------------
' CREATE CENTERS OF ALL EDGES OF CURRENT HOLE
'--------------------------------------------
Set objOriginPoint = Nothing
Set objEndPoint = Nothing


' retrieve hole origin and direction
Call objHole.GetOrigin(ArrOriginPoint)
Call objHole.GetDirection(ArrDirection)


For iEdge = 1 To colEdges.Count
' retrieve edge
Set refEdge = colEdges.Item(iEdge)

' try to create center point of it
On Error Resume Next
Set objCenterPoint = objHSF.AddNewPointCenter(refEdge)
If (Err.Number = 0) Then
On Error Resume Next
Call objCenterPoint.Compute
If (Err.Number 0) Then
Set objCenterPoint = Nothing
End If
Else
Set objCenterPoint = Nothing
End If

If Not (objCenterPoint Is Nothing) Then

' sucessfully created point in the center of edge
Set refCenterPoint = RootPart.CreateReferenceFromObject(objCenterPoint)

' add it to center points collection
Call colCenterPoints.Add(objCenterPoint)

' check if it is the same point as hole origin point
Set varCenterPoint = objCenterPoint
Call varCenterPoint.GetCoordinates(ArrCenterPoint)

If ((ArrCenterPoint(0) = ArrOriginPoint(0)) And _
(ArrCenterPoint(1) = ArrOriginPoint(1)) And _
(ArrCenterPoint(2) = ArrOriginPoint(2))) Then

Set objOriginPoint = objCenterPoint
Set refOriginPoint = refCenterPoint
End If

End If
Next

' if we've found origin point of hole we look for another center point lying on other edge at the distance equal to hole depth
If Not (objOriginPoint Is Nothing) Then
' determine depth of the hole
iHoleType = hlHole.Type

If (iHoleType = catSimpleHole) Or (iHoleType = catTaperedHole) Then
Set lmtDepth = hlHole.BottomLimit
Set lntDepth = lmtDepth.Dimension
Else
Set lntDepth = hlHole.HeadDepth
End If

dblDepth = lntDepth.Value

' get Measurable object on retrieved origin point
Set objMeas = SPAWbench.GetMeasurable(refOriginPoint)

For iCenterPoint = 1 To colCenterPoints.Count

' retrieve another center point
Set objCenterPoint = colCenterPoints.Item(iCenterPoint)
Set refCenterPoint = RootPart.CreateReferenceFromObject(objCenterPoint)

' calculate distance between origin and center points
dblDistance = objMeas.GetMinimumDistance(refCenterPoint)

' check if it equals to hole depth
If (dblDistance = dblDepth) Then
Set objEndPoint = objCenterPoint
Set refEndPoint = refCenterPoint
Exit For
End If
Next
End If


' get hole diameter
dblDiameter = hlHole.Diameter.Value


'---------------------------
' POINTS AND VECTOR CREATION
'---------------------------
If (Not (objOriginPoint Is Nothing) And Not (objCenterPoint Is Nothing)) Then

' create line between origin and end points
Set objHoleAxis = objHSF.AddNewLinePtPt(refOriginPoint, refEndPoint)
Call objHoleAxis.Compute

' add both points and created line to "Points and Vectors" geometrical set
Call PnVGeoSet.AppendHybridShape(objOriginPoint)
Call PnVGeoSet.AppendHybridShape(objEndPoint)
Call PnVGeoSet.AppendHybridShape(objHoleAxis)

End If


'--------------------------------------------
' ASSIGNING PROPER LAYER TO POINTS AND VECTOR
'--------------------------------------------

Call SetHoleGeometryLayer(objOriginPoint, dblDiameter)
Call SetHoleGeometryLayer(objEndPoint, dblDiameter)
Call SetHoleGeometryLayer(objHoleAxis, dblDiameter)

Next

' update geometrical set
Call RootPart.UpdateObject(PnVGeoSet)

End Sub

 

[Wifirex]

I've changed to a new script for the basis for this tool. I will ask the team tomorrow if I can share it here or if it is protected under our company asset laws.

 

[Wifirex]

Bad news sorry. The code I've been given to strip and rebuild is company property. I will only be able to share what I manage to cover by myself, but if I run into any problems I will post them here. Thank you to those who showed interest in this topic!

 

[Wifirex]

I have found a bit of code from the Catia portable script center (Note insertion V2) that I am trying to use but it keeps throwing an error.

ReDim objSelFilterType1(0)

objSelFilterType1(0) = "AnyObject"

sStatus1 = Selection1.IndicateOrSelectElement2D("Select Leader Head Point", objSelFilterType1, False, False, False, objSelected1, PointLocation1)

Do you know why it isn't working Ferdo? When I leave in the REM Option Explicit section up until the CATMAin() I get more errors. As I'm going through the API I can't find references like CatiaApp for example. Has the API changed the references since you used them?

Regards,

Wifirex