Get Linked Dimensions Example (VBA)
This example shows how to get the linked dimensions in a part document.
'---------------------------------------------
'
' Preconditions: Part is open, and, optionally, contains
linked dimensions.
'
' Postconditions: None
'
' NOTE: All dimensions in the part, including those that
are not linked,
' are
identified. These dimensions usually appear under the Annotations
' feature.
'
'---------------------------------------------
Option Explicit
Private Type DimLink
Name
As
String
DimName()
As
String
End Type
Private Sub ProcessDimLinkList _
( _
ThisDimLinkList()
As DimLink _
)
Dim
i As
Long
Dim
j As
Long
For
i = 0 To UBound(ThisDimLinkList)
Debug.Print
ThisDimLinkList(i).Name
For
j = 0 To UBound(ThisDimLinkList(i).DimName)
Debug.Print
" "
& ThisDimLinkList(i).DimName(j)
Next
j
Next
i
End Sub
Private Sub AddToDimLinkList _
( _
ThisDimLink
As DimLink, _
ThisDimLinkList()
As DimLink _
)
Debug.Assert
UBound(ThisDimLink.DimName) = 0
Dim
i As
Long
For
i = 0 To UBound(ThisDimLinkList)
If
ThisDimLinkList(i).Name = ThisDimLink.Name Then
ReDim
Preserve ThisDimLinkList(i).DimName(UBound(ThisDimLinkList(i).DimName)
+ 1)
ThisDimLinkList(i).DimName(UBound(ThisDimLinkList(i).DimName))
= ThisDimLink.DimName(0)
Exit
Sub
End
If
Next
i
If
0 = UBound(ThisDimLinkList) And "" = ThisDimLinkList(0).Name
Then
ThisDimLinkList(0).Name
= ThisDimLink.Name
ThisDimLinkList(0).DimName(UBound(ThisDimLinkList(0).DimName))
= ThisDimLink.DimName(0)
Exit
Sub
End
If
ReDim
Preserve ThisDimLinkList(UBound(ThisDimLinkList) + 1)
ReDim
Preserve ThisDimLinkList(UBound(ThisDimLinkList)).DimName(0)
ThisDimLinkList(UBound(ThisDimLinkList)).Name
= ThisDimLink.Name
ThisDimLinkList(UBound(ThisDimLinkList)).DimName(UBound(ThisDimLinkList(UBound(ThisDimLinkList)).DimName))
= ThisDimLink.DimName(0)
End Sub
Private Function IsInDimLinkList _
( _
ThisDimLink
As DimLink, _
ThisDimLinkList()
As DimLink _
) As Boolean
Dim
i As
Long
Dim
j As
Long
For
i = 0 To UBound(ThisDimLinkList)
If
ThisDimLinkList(i).Name = ThisDimLink.Name Then
For
j = 0 To UBound(ThisDimLinkList(i).DimName)
If
ThisDimLinkList(i).DimName(j) = ThisDimLink.DimName(0) Then
IsInDimLinkList
= True
Exit
Function
End
If
Next
j
End
If
Next
i
End Function
Sub main()
Dim
swApp As
SldWorks.SldWorks
Dim
swModel As
SldWorks.ModelDoc2
Dim
swFeat As
SldWorks.feature
Dim
swDimen As
SldWorks.Dimension
Dim
swDispDim As
SldWorks.DisplayDimension
Dim
swDispDimAnn As
SldWorks.Annotation
Dim
OneDimLink As
DimLink
Dim
DimLinkList() As
DimLink
Dim
bRet As
Boolean
ReDim
DimLinkList(0)
ReDim
DimLinkList(0).DimName(0)
ReDim
OneDimLink.DimName(0)
Set
swApp = Application.SldWorks
Set
swModel = swApp.ActiveDoc
Set
swFeat = swModel.FirstFeature
Debug.Print
"File = " & swModel.GetPathName
Do
While Not swFeat Is Nothing
Set
swDispDim = swFeat.GetFirstDisplayDimension
If
Not swDispDim Is Nothing Then
Debug.Print
" "
& swFeat.Name
End
If
Do
While Not swDispDim Is Nothing
Set
swDispDimAnn = swDispDim.GetAnnotation
Set
swDimen = swDispDim.GetDimension
If
swDispDim.IsLinked Then
OneDimLink.Name
= swDispDim.GetLinkedText
OneDimLink.DimName(0)
= swDimen.FullName
Debug.Print
" "
& swDispDimAnn.GetName & " [" & swDimen.FullName
& "] -- > " & swDispDim.GetLinkedText
If
Not IsInDimLinkList(OneDimLink, DimLinkList) Then
AddToDimLinkList
OneDimLink, DimLinkList
End
If
End
If
Set
swDispDim = swFeat.GetNextDisplayDimension(swDispDim)
Loop
Set
swFeat = swFeat.GetNextFeature
Loop
ProcessDimLinkList
DimLinkList
End Sub
'---------------------------------------------