Announcements
Attention for Customers without Multi-Factor Authentication or Single Sign-On - OTP Verification rolls out April 2025. Read all about it here.

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

Capture.png

 

=====

Freeradical

 Hideo Yamada

=====
Freeradical
 Hideo Yamada
https://www.freeradical.jp