What I need :
What I get : 
I made a macro that takes a list of dimensions for a belleville washer and makes a drawing of the specified part. An issue that I'm having is that whenever I adjust the dimensions, the callouts of the dimensions become distorted. Is there a way to adjust the callout of the dimensions with a vba macro?
Thank you for the reply, but unfortunately this is not working for me. When debugging, I noticed that swDispDim.OffsetText is always returned as a false value so it skips over that entire if statement that moves the leaders.
Are they not Offset text dimensions?
Could you post your model and drawing
I changed them to offset and it worked! Thank you!
Is there a way to adjust all dimensions? Even the ones that are not offset.
Try this:
Option Explicit
Sub main()
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swDraw As SldWorks.DrawingDoc
Dim swView As SldWorks.View
Dim swDispDim As SldWorks.DisplayDimension
Dim swAnn As SldWorks.Annotation
Dim vOutline As Variant
Dim DisplayData As SldWorks.DisplayData
Dim PtPos1 As Variant
Dim PtPos2 As Variant
Dim vPos As Variant
Dim distVX As Double
Dim distVY As Double
Dim distHX As Double
Dim distHYt As Double
Dim distHYb As Double
distVX = 0.03
distVY = 0.009
distHX = 0.019
distHYt = -0.009
distHYb = -0.004
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
If swModel.GetType <> swDocDRAWING Then
MsgBox "A drawing must be opened"
Exit Sub
End If
swModel.ClearSelection2 True
Set swDraw = swModel
Set swView = swDraw.GetFirstView
While Not swView Is Nothing
vOutline = swView.GetOutline
Set swDispDim = swView.GetFirstDisplayDimension5
While Not swDispDim Is Nothing
Set swAnn = swDispDim.GetAnnotation
Set DisplayData = swDispDim.GetDisplayData
If swDispDim.GetType = swDimensionType_e.swLinearDimension And DisplayData.GetArrowHeadCount = 2 Then
PtPos1 = DisplayData.GetLineAtIndex3(0)
PtPos2 = DisplayData.GetLineAtIndex3(1)
If swDispDim.OffsetText Then
' move dimension's leaders
swDispDim.OffsetText = False
vPos = swAnn.GetPosition
If PtPos1(4) < (vOutline(0) + vOutline(2)) / 2 Then
vPos(0) = vOutline(0)
Else
vPos(0) = vOutline(2)
End If
swAnn.SetPosition2 vPos(0), vPos(1), vPos(2)
swDispDim.OffsetText = True
End If
' move dimension's text
vPos = swAnn.GetPosition
If Abs(PtPos1(4) - PtPos2(4)) < Abs(PtPos1(5) - PtPos2(5)) Then
' vertical dimension
If vPos(0) < (vOutline(0) + vOutline(2)) / 2 Then
vPos(0) = vOutline(0) - distVX
Else
vPos(0) = vOutline(2) + distVX
End If
vPos(1) = vOutline(1) + distVY
Else
' horizontal dimension
If PtPos1(5) < (vOutline(1) + vOutline(3)) / 2 Then
vPos(1) = vOutline(1) - distHYb
Else
vPos(1) = vOutline(3) + distHYt
End If
If PtPos1(4) < PtPos2(4) Then
vPos(0) = PtPos2(4) - distHX
Else
vPos(0) = PtPos1(4) - distHX
End If
End If
swAnn.SetPosition2 vPos(0), vPos(1), vPos(2)
End If
Set swDispDim = swDispDim.GetNext5
Wend
Set swView = swView.GetNextView
Wend
End Sub
Thank you for the reply, unfortunately this did not fix the problem I was hoping to solve, but I may not be explaining this correctly.
Given the drawing, if the highlighted dimensions move away from the drawing view I would like the macro to adjust the dimensions back to the correct position.
Just adjust the values of distVX, distVY, distHX, distHYt and distHYb
Ok I understand now, but the macro always considers the left most vertical dimension as a horizontal dimension because it jumps over this if statement:
" If Abs(PtPos1(4) - PtPos2(4)) < Abs(PtPos1(5) - PtPos2(5)) Then "
Also I added this type of dimension and the macro takes no effect on it.
This is getting tedious.
You might as well place each dimension to its position based on its name.
Option Explicit
Sub main()
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swDraw As SldWorks.DrawingDoc
Dim swView As SldWorks.View
Dim swDispDim As SldWorks.DisplayDimension
Dim swAnn As SldWorks.Annotation
Dim vOutline As Variant
Dim DisplayData As SldWorks.DisplayData
Dim PtPos1 As Variant
Dim PtPos2 As Variant
Dim vPos As Variant
Dim xLeft As Double
Dim xRight As Double
Dim yTop As Double
Dim yBottom As Double
Dim xMiddle As Double
Dim yMiddle As DoubleSet swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
If swModel.GetType <> swDocDRAWING Then
MsgBox "A drawing must be opened"
Exit Sub
End If
swModel.ClearSelection2 True
Set swDraw = swModel
Set swView = swDraw.GetFirstView
While Not swView Is Nothing
vOutline = swView.GetOutline
xLeft = vOutline(0)
xRight = vOutline(2)
yBottom = vOutline(1)
yTop = vOutline(3)
xMiddle = (xRight + xLeft) / 2
yMiddle = (yTop + yBottom) / 2
Set swDispDim = swView.GetFirstDisplayDimension5
While Not swDispDim Is Nothing
Set swAnn = swDispDim.GetAnnotation
Select Case swDispDim.GetNameForSelection
Case "RD1@Drawing View1"
If swDispDim.OffsetText Then
swDispDim.OffsetText = False
vPos = swAnn.GetPosition
swAnn.SetPosition2 xLeft, yMiddle, 0
swDispDim.OffsetText = True
End If
vPos = swAnn.GetPosition
swAnn.SetPosition2 xLeft - 0.01, yBottom, 0
Case "RD2@Drawing View1"
vPos = swAnn.GetPosition
swAnn.SetPosition2 xRight + 0.01, yTop + 0.01, 0
Case "RD3@Drawing View1"
'...
End Select
Set swDispDim = swDispDim.GetNext5
Wend
Set swView = swView.GetNextView
Wend
End Sub
Thanks so much for the help! This is working perfectly.
Here is sample vba code from API help file that gets position and bounding box of drawing views on drawing. You should be able to use this code to find the position you want dimensions to be after the model changes in size. The values API uses are in meters and code converts to mm. The outline is outline of the geometry in the view and does not include the inserted model dimensions.
'---------------------------------------------------------
' Preconditions:
' 1. Verify that the drawing document to open exists.
' 2. Open the Immediate window.
'
' Postconditions:
' 1. Opens the specified drawing document.
' 2. Gets each drawing view's:
' * origin's x and y positions relative
' to the drawing sheet origin
' * bounding box
' * position lock status
' 3. Examine the Immediate window.
'
' NOTE: Because the drawing is used elsewhere, do not save
' changes.
'----------------------------------------------------------
Option Explicit
Sub main()
Dim swApp As SldWorks.SldWorks
Dim swDraw As SldWorks.DrawingDoc
Dim swView As SldWorks.View
Dim outline() As Double
Dim pos() As Double
Dim fileName As String
Dim errors As Long
Dim warnings As Long
Set swApp = CreateObject("SldWorks.Application")
Set swDraw = swApp.ActiveDoc
Set swView = swDraw.GetFirstView
Do While Not swView Is Nothing
outline = swView.GetOutline
pos = swView.Position
Debug.Print "View = " + swView.Name
Debug.Print " X and Y positions = (" & pos(0) * 1000# & ", " & pos(1) * 1000# & ") mm"
Debug.Print " X and Y bounding box minimums = (" & outline(0) * 1000# & ", " & outline(1) * 1000# & ") mm"
Debug.Print " X and Y bounding box maximums = (" & outline(2) * 1000# & ", " & outline(3) * 1000# & ") mm"
Debug.Print " Position locked? " & swView.PositionLocked
Set swView = swView.GetNextView
Loop
End Sub
Hello. Try this:
It will move the position of all "offset text" dimensions on the sides of the view. Adjust the spaces with distX and distY values.