03-20-2022
01:22 AM
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
03-20-2022
01:22 AM
This is the Code to add a balloon using VBA with the Attribute helper.
Sub AddBalloon(SheetNo As Double, viewName As String, AttributeName As String _
, xPosition As Double, yPosition As Double, intent As Double)
' 1- Reference the drwing file A8-003 that must be open specifically
If ThisApplication.ActiveDocument.DocumentType <> _
DocumentTypeEnum.kDrawingDocumentObject Then
Call MsgBox("The drawing document is Not active." _
& " Please Activate it first", vbOKOnly, "Document Type")
BCheck = False
Exit Sub
Else
Dim oDrawDoc As DrawingDocument
Set oDrawDoc = ThisApplication.ActiveDocument
End If
' 2- Reference the active Sheet
If oDrawDoc.DisplayName <> "1Fxxx-A8-0x.dwg" Then
Call MsgBox(" You need to open A8-003 Drawing", vbCritical, "Drawing file")
BCheck = False
Exit Sub
Else
Dim oSheet As Sheet
Set oSheet = oDrawDoc.Sheets.Item(SheetNo)
End If
' 3- Reference the needed drwing View
Dim oView As DrawingView
For i = 1 To oSheet.DrawingViews.Count
If oSheet.DrawingViews.Item(i).Name = viewName Then
Set oView = oSheet.DrawingViews.Item(i)
End If
Next
'Verify that the selected drawing view exist, and not suppressed.
If oView Is Nothing Then
Call MsgBox("View named (" & viewName & ") was not found. Exiting.", vbCritical, "Drawing View")
BCheck = False
Exit Sub
ElseIf oView.Suppressed = True Then
oView.Suppressed = False
BCheck = False
Exit Sub
End If
' 4- Reference the Model on that Sheet
Dim oAssemblyDoc As Document
Set oAssemblyDoc = oView.ReferencedDocumentDescriptor.ReferencedDocument
'Verify that the selected drawing view is of an assembly.
If oAssemblyDoc.DocumentType <> kAssemblyDocumentObject Then
Call MsgBox("The selected View must be of an assembly", vbInformation, "Document Type")
BCheck = False
Exit Sub
End If
' 5- Find the assigned Attribute of an Object
Dim sAttributeSetName As String
Dim sAttributeName As String
sAttributeSetName = "Balloon"
sAttributeName = AttributeName
Dim oObjs As ObjectCollection
Set oObjs = oAssemblyDoc.AttributeManager _
.FindObjects(sAttributeSetName, sAttributeName)
' Verify the existance of the assigned attribute
If oObjs.Count = 0 Then
Call MsgBox("attribute name " & sAttributeName & _
" was not found. Exiting.", vbCritical, "Attribute object")
BCheck = False
Exit Sub
End If
' 6- get the needed face of the object
Dim oTypeName As String
oTypeName = TypeName(oObjs.Item(1))
Dim oFace As Face
Dim oFaceProxy As FaceProxy
Dim oOccName As String
If oTypeName = "Face" Then
Set oFace = oObjs.Item(1)
oOccName = oFace.ContainingOccurrence.Name
ElseIf oTypeName = "FaceProxy" Then
Set oFaceProxy = oObjs.Item(1)
oOccName = oFaceProxy.ContainingOccurrence.Name
Else
Call MsgBox("the assigned object's Face was Not found. Exiting", vbCritical, "Face")
BCheck = False
Exit Sub
End If
GOccName = oOccName
' 7- get the occurrence of the detected object's face
Dim Oocc As ComponentOccurrence
Set Oocc = OccSearch(oAssemblyDoc)
' Verify the existance of the assigned occurrence
If Oocc Is Nothing Then
Call MsgBox("the Occurrence of the detected object is Not found. Exiting", vbCritical, "Occurrence")
BCheck = False
Exit Sub
End If
Dim oParentOcc As ComponentOccurrence
Set oParentOcc = Oocc.ParentOccurrence
If oTypeName = "Face" Then
Call Oocc.CreateGeometryProxy(oFace, oFaceProxy)
If Not oParentOcc Is Nothing Then
Call oParentOcc.CreateGeometryProxy(oFace, oFaceProxy)
End If
End If
' 8- Promote to an DrawingCurve on the View
Dim oViewAllCurves As DrawingCurvesEnumerator
Dim oViewCurves As DrawingCurvesEnumerator
Dim ocurve As DrawingCurve
Set oViewAllCurves = oView.DrawingCurves
For i = 1 To oViewAllCurves.Count
If oViewAllCurves.Item(i).StartPoint Is Nothing Or _
oViewAllCurves.Item(i).Evaluator3D Is Nothing Or _
oViewAllCurves.Item(i).ModelGeometry Is Nothing Then
i = i + 1
Else
If oViewAllCurves.Item(i).ModelGeometry.ContainingOccurrence.Name = oOccName Then
Set oViewCurves = oView.DrawingCurves(oFaceProxy)
If oViewCurves.Count <> 0 Then
Set ocurve = oViewCurves.Item(1)
Exit For
Else
Set ocurve = oViewAllCurves.Item(i)
Exit For
End If
End If
End If
Next
' Verify the existance of the assigned Curve
If ocurve Is Nothing Then
Call MsgBox("Occurrence does not belong to the view. Exiting", vbExclamation, "View Refrence Documents")
BCheck = False
Exit Sub
End If
If oViewAllCurves.Count = 0 Then
Call MsgBox("No curves found in view. Exiting", vbExclamation, "Drawing Curves")
BCheck = False
Exit Sub
End If
' 9- locate a position for the text point of the Balloon
' this will be relative to the assigned curve
Dim oMidPoint As Point2d
Set oMidPoint = ocurve.MidPoint
Dim oTG As TransientGeometry
Set oTG = ThisApplication.TransientGeometry
Dim Xpos As Double
Dim Ypos As Double
Xpos = oMidPoint.x + xPosition
Ypos = oMidPoint.y + yPosition
Set oPoint = oTG.CreatePoint2d(Xpos, Ypos)
' Attach Balloon to the text point
Dim oLeaderPoint As ObjectCollection
Set oLeaderPoint = ThisApplication.TransientObjects _
.CreateObjectCollection
Call oLeaderPoint.Add(oPoint)
' 10- locate a leader point for the Balloon
Dim GI As GeometryIntent
Set GI = oSheet.CreateGeometryIntent(ocurve, intent)
Call oLeaderPoint.Add(GI)
' Deleting the dublicated Balloon if any
Dim K As Integer
K = oSheet.Balloons.Count ' Number of Balloons
Dim counter As Integer
counter = 0 ' Number of similar balloons
For i = 1 To K
While i < K
If oSheet.Balloons.Item(i).ParentView.Name = sViewName Then
If oSheet.Balloons.Item(i).Position.x = Xpos And _
oSheet.Balloons.Item(i).Position.y = Ypos Then
oSheet.Balloons.Item(i).Delete
K = K - 1
End If
End If
i = i + 1
Wend
Next
' Adding the Balloon
Dim oBalloon As Balloon
Set oBalloon = oSheet.Balloons.Add(oLeaderPoint)
' Deleting previously exsited balloon if any
Dim oBalloonItemNumber As String
oBalloonItemNumber = oBalloon.BalloonValueSets _
.Item(1).ItemNumber
K = oSheet.Balloons.Count ' Updated Number of Balloons
For i = 1 To K
While i < K
If oSheet.Balloons.Item(i).ParentView.Name = sViewName _
And oSheet.Balloons.Item(i).BalloonValueSets _
.Item(1).ItemNumber = oBalloonItemNumber _
And oSheet.Balloons.Item(i).Position.x <> Xpos And _
oSheet.Balloons.Item(i).Position.y <> Ypos Then
counter = counter + 1
If counter >= 1 Then
oSheet.Balloons.Item(i).Delete
K = K - 1
i = i - 1
End If
End If
i = i + 1
Wend
Next
BCheck = True
End Sub
Function OccSearch(AssemblyDoc As AssemblyDocument) As ComponentOccurrence
Dim CompName As String
For Each SubCompOcc In AssemblyDoc.ComponentDefinition.Occurrences
CompName = SubCompOcc.Name
If CompName = GOccName Then
Set OccSearch = SubCompOcc
Exit Function
End If
If SubCompOcc.Visible = True And _
SubCompOcc.Suppressed = False And _
SubCompOcc.BOMStructure = kNormalBOMStructure And _
SubCompOcc.DefinitionDocumentType = kAssemblyDocumentObject Then
Set OccSearch = OccSearch(SubCompOcc.Definition.Document)
If Not OccSearch Is Nothing Then
Exit Function
End If
End If
Next
Set OccSearch = Nothing
End FunctionI hope everyone finds it useful.
Thanks