12-10-2019
06:09 PM
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
12-10-2019
06:09 PM
Hi,
This code will help you.
Option Explicit
Private oDrawDoc As DrawingDocument
Private oSheet As Sheet
Private oView As DrawingView
Private oAssembly As AssemblyDocument
Public Sub CreatAssemblyDim()
If Not InitializeCondition Then
MsgBox "Failed : InitializeCondition"
Exit Sub
End If
Dim oOccCover As ComponentOccurrence
Dim oOccPlate As ComponentOccurrence
Set oOccCover = GetOccurrenceByOccurrenceName(oAssembly, "Hopper_InspectionDoor_Cover:1")
Set oOccPlate = GetOccurrenceByOccurrenceName(oAssembly, "Hopper_InspectionDoor_Plate:1")
If oOccCover Is Nothing Or oOccPlate Is Nothing Then
MsgBox "The occurrence is not found."
Exit Sub
End If
'promote to a geometryIntent on the sheet
Dim GI1 As GeometryIntent
Set GI1 = CreateGeometryIntent(oView, oOccCover, "Left")
Dim GI2 As GeometryIntent
Set GI2 = CreateGeometryIntent(oView, oOccPlate, "Right")
'Create a general Dimension on that shett
Dim oGeneralDims As GeneralDimensions
Set oGeneralDims = oSheet.DrawingDimensions.GeneralDimensions
' Create point for the text
Dim TextPoint As Point2d
Dim Xpo As Double
Dim Ypo As Double
Xpo = oView.Left + (oView.Width / 4)
Ypo = oView.Top + 3
Set TextPoint = ThisApplication.TransientGeometry.CreatePoint2d(Xpo, Ypo)
' Create the Dimemsion
Dim oDim1 As GeneralDimension
Set oDim1 = oGeneralDims.AddLinear(TextPoint, GI1, GI2)
For Each oDim1 In oGeneralDims
If oDim1.Attached = False Then
Call oDim1.Delete
End If
Next
End Sub
Private Function InitializeCondition() As Boolean
InitializeCondition = False
If TypeOf ThisApplication.ActiveDocument Is DrawingDocument Then
Set oDrawDoc = ThisApplication.ActiveDocument
Else
Exit Function
End If
Set oSheet = oDrawDoc.ActiveSheet
If oSheet Is Nothing Then
Exit Function
End If
If oSheet.DrawingViews.Count > 0 Then
Set oView = oSheet.DrawingViews(1)
Else
Exit Function
End If
Set oAssembly = oView.ReferencedDocumentDescriptor.ReferencedDocument
InitializeCondition = True
End Function
Private Function GetOccurrenceByOccurrenceName(adoc As AssemblyDocument, occName As String) As ComponentOccurrence
Dim occ As ComponentOccurrence
For Each occ In adoc.ComponentDefinition.Occurrences
If occ.name = occName Then
Set GetOccurrenceByOccurrenceName = occ
Exit For
End If
Next occ
End Function
Private Function GetOccurrenceByPartNumber(adoc As AssemblyDocument, partNumberString As String) As ComponentOccurrence
Dim occ As ComponentOccurrence
For Each occ In adoc.ComponentDefinition.Occurrences
If TypeOf occ.Definition Is PartComponentDefinition Then
If occ.Definition.Document.PropertySets("Design Tracking Properties")("Part Number").Value = partNumberString Then
Set GetOccurrenceByPartNumber = occ
Exit For
End If
End If
Next occ
End Function
Private Function CreateGeometryIntent(oDrawingView As DrawingView, occ As ComponentOccurrence, labelName As String) As GeometryIntent
Dim doc As Document
Set doc = occ.Definition.Document
Dim obj As Object
Set obj = doc.AttributeManager.FindObjects(, , labelName).Item(1)
Dim proxy As Object
Call occ.CreateGeometryProxy(obj, proxy)
Dim oDrawingCurve As DrawingCurve
Set oDrawingCurve = oDrawingView.DrawingCurves(proxy).Item(1)
Set CreateGeometryIntent = oView.Parent.CreateGeometryIntent(oDrawingCurve)
End Function
=====
Hideo Yamada