Code:
Option ExplicitPrivate Sub SelectUnposed()
Dim oDrawDoc As DrawingDocument
Set oDrawDoc = ThisApplication.ActiveDocument
Dim oSheet As Sheet
Set oSheet = oDrawDoc.ActiveSheet
If Not oSheet.DrawingViews(1).ReferencedDocumentDescriptor.ReferencedDocumentType = kAssemblyDocumentObject Then
Exit Sub
End If
Dim oAssDoc As AssemblyDocument
Set oAssDoc = oSheet.DrawingViews(1).ReferencedDocumentDescriptor.ReferencedDocument
Dim oBOM As DrawingBOM
Set oBOM = oDrawDoc.DrawingBOMs.Item(1)
Dim oCompDef As ComponentDefinition
Dim oBOMDoc As Document
Dim oBOMRow As DrawingBOMRow
Dim oDrawCurves As DrawingCurvesEnumerator
Dim oView As DrawingView
Dim oDrawCurve As DrawingCurve
Dim oDrawCurveSeg As DrawingCurveSegment
Dim oOcc As ComponentOccurrence
Dim oOccs As ComponentOccurrencesEnumerator
Dim oHLSet As HighlightSet
Set oHLSet = oDrawDoc.CreateHighlightSet
oHLSet.color = ThisApplication.TransientObjects.CreateColor(255, 128, 255)
For Each oBOMRow In oBOM.DrawingBOMRows
If oBOMRow.Ballooned = False Then
For Each oCompDef In oBOMRow.BOMRow.ComponentDefinitions
Set oBOMDoc = oCompDef.Document
Set oOccs = oAssDoc.ComponentDefinition.Occurrences.AllReferencedOccurrences(oBOMDoc)
For Each oView In oSheet.DrawingViews
For Each oOcc In oOccs
Set oDrawCurves = oView.DrawingCurves(oOcc)
If oDrawCurves.Count > 0 Then
For Each oDrawCurve In oDrawCurves
For Each oDrawCurveSeg In oDrawCurve.Segments
If oDrawCurveSeg.HiddenLine = False Then
Call oHLSet.AddItem(oDrawCurveSeg)
End If
Next
Next
End If
Set oDrawCurves = Nothing
Next
Next
Next
Dim oTargetCurveSeg As DrawingCurveSegment
Set oTargetCurveSeg = ThisApplication.CommandManager.Pick(kDrawingCurveSegmentFilter, "Wählen Sie eine Kante für die Bemaßung aus...")
If Not oTargetCurveSeg Is Nothing Then
Call CreateBalloon(oDrawDoc, oSheet, oTargetCurveSeg)
End If
Call oHLSet.Clear
End If
Next
End Sub
Private Sub CreateBalloon(ByVal oDrawDoc As DrawingDocument, ByVal oActiveSheet As Sheet, ByVal oDrawingCurveSegment As DrawingCurveSegment)
' Set a reference to the drawing curve.
Dim oDrawingCurve As DrawingCurve
Set oDrawingCurve = oDrawingCurveSegment.Parent
' Get the mid point of the selected curve
' assuming that the selection curve is linear
Dim oMidPoint As Point2d
Set oMidPoint = oDrawingCurve.MidPoint
' Set a reference to the TransientGeometry object.
Dim oTG As TransientGeometry
Set oTG = ThisApplication.TransientGeometry
Dim oLeaderPoints As ObjectCollection
Set oLeaderPoints = ThisApplication.TransientObjects.CreateObjectCollection
' Create a leader point.
Call oLeaderPoints.Add(oTG.CreatePoint2d(oMidPoint.X + 1, oMidPoint.y - 1))
' Add the GeometryIntent to the leader points collection.
' This is the geometry that the balloon will attach to.
Dim oGeometryIntent As GeometryIntent
Set oGeometryIntent = oActiveSheet.CreateGeometryIntent(oDrawingCurve, oMidPoint)
Call oLeaderPoints.Add(oGeometryIntent)
Dim oBalloon As Balloon
Set oBalloon = oDrawDoc.ActiveSheet.Balloons.Add(oLeaderPoints)
End Sub
Foren auf CAD.de (alle Foren)
| 
