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

Hi,

 

I changed your code and this code tries to add the dimension to the part which part number is same to the name specified in "targetPartName".

 

Option Explicit

Const targetPartName = "Part1"

Sub CreatAssemblyDim()
    ' refer to the file
    Dim oDrawDoc As DrawingDocument
    Set oDrawDoc = ThisApplication.ActiveDocument
    
    'refer to the active sheet
    Dim oSheet As Sheet
    Set oSheet = oDrawDoc.ActiveSheet
    
    'refer to the view
    Dim oView As DrawingView
    Set oView = oSheet.DrawingViews.Item(1)
    
    'refer to the assembly on the view
    Dim oAssembly As AssemblyDocument
    Set oAssembly = oView.ReferencedDocumentDescriptor.ReferencedDocument
    
    'find the model referenced  in the assembly
    Dim oTargetOcc As ComponentOccurrence ': Set oTargetOcc = Nothing
    Dim oOcc As ComponentOccurrence
    For Each oOcc In oAssembly.ComponentDefinition.Occurrences
        If TypeOf oOcc.Definition Is PartComponentDefinition Then
            If oOcc.Definition.Document.PropertySets("Design Tracking Properties")("Part Number").Value = targetPartName Then
                Set oTargetOcc = oOcc
                Exit For
            End If
        End If
    Next oOcc
    
    If oTargetOcc Is Nothing Then
        MsgBox "The occurrence named """ & targetPartName & """ is not exist."
        Exit Sub
    End If
    
    'Dim i As Integer
    'For i = 1 To oAssembly.ReferencedDocuments.Count
    Dim oModelDoc As Document
    Set oModelDoc = oTargetOcc.Definition.Document
    ' refer to the edge
    Dim Edge1 As Edge
    'MsgBox (oModelDoc.DisplayName)
    Set Edge1 = oModelDoc.AttributeManager.FindObjects("*", "*", "Left").Item(1)
    
    Dim Edge2 As Edge
    Set Edge2 = oModelDoc.AttributeManager.FindObjects("*", "*", "Right").Item(1)
    
    'Next
    ' refere to occurrence in the assembly
    Dim oCompOcc As ComponentOccurrence
    Set oCompOcc = oTargetOcc
    
    
    ' promote the model edge to the assembly using poroxy
    Dim oOccEdge1Proxy As EdgeProxy
    Dim oOccEdge2Proxy As EdgeProxy
    
    Call oCompOcc.CreateGeometryProxy(Edge1, oOccEdge1Proxy)
    Call oCompOcc.CreateGeometryProxy(Edge2, oOccEdge2Proxy)
    
    'promote to an a DrawingCurve on the view
    Dim oDrawingCurves1 As DrawingCurve
    Set oDrawingCurves1 = oView.DrawingCurves(oOccEdge1Proxy).Item(1)
    
    Dim oDrawingCurves2 As DrawingCurve
    Set oDrawingCurves2 = oView.DrawingCurves(oOccEdge2Proxy).Item(1)
    
    'promote to a geometryIntent on the sheet
    Dim GI1 As GeometryIntent
    Set GI1 = oSheet.CreateGeometryIntent(oDrawingCurves1)
    
    Dim GI2 As GeometryIntent
    Set GI2 = oSheet.CreateGeometryIntent(oDrawingCurves2)
    
    '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

 

I cannot understand exactly what you are needing, but I am grad if this code will help you to solve your problem.

 

=====

Freeradical

 Hideo Yamada

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