12-05-2019
05:15 AM
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
12-05-2019
05:15 AM
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.
=====
Hideo Yamada