Dear API Experts,
I hope this message finds you well.
I am seeking your guidance regarding an issue I am facing. Currently, I manually add dimensions to folded views in my daily work, and I am attempting to automate this process using the macro outlined below.
The macro successfully adds the dimensions (highlighted in red), but my requirement is for it to include the overall dimensions, including the arc (highlighted in green).
Could any expert kindly assist me in resolving this issue? Your support would be greatly appreciated.
Thank you in advance for your time and help.
Option Explicit
' --- constants (from SOLIDWORKS API)
Public Const LINE_TYPE As Integer = 3001
Public Const CIRCLE_TYPE As Integer = 3002
Public Const BCURVE_TYPE As Integer = 3005
' Helper to unpack two ints packed into a double (used by GetCurveParams2)
Type DoubleRec
dValue As Double
End Type
Type Long2Rec
iLower As Long
iUpper As Long
End Type
Sub ExtractFields(ByVal dValue As Double, ByRef iLower As Long, ByRef iUpper As Long)
Dim dr As DoubleRec
Dim i2r As Long2Rec
dr.dValue = dValue
LSet i2r = dr
iLower = i2r.iLower
iUpper = i2r.iUpper
End Sub
Function GetDrawingViewByName(swDrawing As SldWorks.DrawingDoc, viewName As String) As SldWorks.View
Dim swView As SldWorks.View
Set swView = swDrawing.GetFirstView
Do While Not swView Is Nothing
If swView.Name = viewName Then
Set GetDrawingViewByName = swView
Exit Function
End If
Set swView = swView.GetNextView
Loop
Set GetDrawingViewByName = Nothing
End Function
' --- Check if a line is part of the convex hull (outer edge)
Function IsEdgeOnHull(x1 As Double, y1 As Double, x2 As Double, y2 As Double, hullPts As Collection) As Boolean
Dim i As Long
Dim pt1 As Variant, pt2 As Variant
For i = 1 To hullPts.Count - 1
pt1 = hullPts(i)
pt2 = hullPts(i + 1)
If (Abs(x1 - pt1(0)) < 0.0001 And Abs(y1 - pt1(1)) < 0.0001 And _
Abs(x2 - pt2(0)) < 0.0001 And Abs(y2 - pt2(1)) < 0.0001) Or _
(Abs(x2 - pt1(0)) < 0.0001 And Abs(y2 - pt1(1)) < 0.0001 And _
Abs(x1 - pt2(0)) < 0.0001 And Abs(y1 - pt2(1)) < 0.0001) Then
IsEdgeOnHull = True
Exit Function
End If
Next i
IsEdgeOnHull = False
End Function
Sub AutoDimensionViewEdges()
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swDrawing As SldWorks.DrawingDoc
Dim swView As SldWorks.View
Dim vComps As Variant, comp As SldWorks.Component2
Dim vEdges As Variant, ent As SldWorks.Entity
Dim vCurveParam As Variant
Dim swMathUtil As SldWorks.MathUtility
Dim swModelStartPt As SldWorks.MathPoint
Dim swModelEndPt As SldWorks.MathPoint
Dim swViewStartPt As SldWorks.MathPoint
Dim swViewEndPt As SldWorks.MathPoint
Dim swViewXform As SldWorks.MathTransform
Dim vOutline As Variant
Dim swDispDim As SldWorks.DisplayDimension
Dim i As Long, j As Long
Dim nIdentity As Long, nDummy As Long
Dim nXoffset As Double, nYoffset As Double, nTolerance As Double
Dim nXpos As Double, nYpos As Double
Dim viewName As String
' dictionary for duplicate filtering
Dim edgeDict As Object
Set edgeDict = CreateObject("Scripting.Dictionary")
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
If swModel Is Nothing Or swModel.GetType <> swDocDRAWING Then
MsgBox "Please open a drawing document and run the macro there.", vbExclamation
Exit Sub
End If
Set swDrawing = swModel
' Ask user for the view name (Default: Drawing View2)
viewName = InputBox("Enter drawing view name to auto-dimension (exact):", "Choose view", "Drawing View2")
If viewName = "" Then Exit Sub
Set swView = GetDrawingViewByName(swDrawing, viewName)
If swView Is Nothing Then
MsgBox "View '" & viewName & "' not found. Make sure you typed it exactly.", vbExclamation
Exit Sub
End If
' Tolerances and offsets (meters)
nTolerance = 0.00000001
nXoffset = 0.005 ' 5 mm
nYoffset = 0.005 ' 5 mm
Set swMathUtil = swApp.GetMathUtility
Set swViewXform = swView.ModelToViewTransform
vOutline = swView.GetOutline
' --- Collect all edge points in view coordinates ---
Dim allPts As Collection
Set allPts = New Collection
vComps = swView.GetVisibleComponents
If IsEmpty(vComps) Then
MsgBox "No visible components found in view.", vbInformation
Exit Sub
End If
For i = LBound(vComps) To UBound(vComps)
Set comp = vComps(i)
vEdges = swView.GetVisibleEntities2(comp, 1) ' edges
If Not IsEmpty(vEdges) Then
For j = LBound(vEdges) To UBound(vEdges)
On Error GoTo SkipEdge
Set ent = vEdges(j)
vCurveParam = ent.GetCurveParams2
ExtractFields vCurveParam(8), nDummy, nIdentity
If nIdentity = LINE_TYPE Then
Dim coords(2) As Double
coords(0) = vCurveParam(0): coords(1) = vCurveParam(1): coords(2) = vCurveParam(2)
Set swModelStartPt = swMathUtil.CreatePoint(coords)
coords(0) = vCurveParam(3): coords(1) = vCurveParam(4): coords(2) = vCurveParam(5)
Set swModelEndPt = swMathUtil.CreatePoint(coords)
Set swViewStartPt = swModelStartPt.MultiplyTransform(swViewXform)
Set swViewEndPt = swModelEndPt.MultiplyTransform(swViewXform)
Dim pt1(1) As Double, pt2(1) As Double
pt1(0) = swViewStartPt.ArrayData(0): pt1(1) = swViewStartPt.ArrayData(1)
pt2(0) = swViewEndPt.ArrayData(0): pt2(1) = swViewEndPt.ArrayData(1)
allPts.Add pt1
allPts.Add pt2
End If
SkipEdge:
Err.Clear
Next j
End If
Next i
' --- Compute outer hull (convex hull) of points ---
Dim hullPts As Collection
Set hullPts = ConvexHull2D(allPts)
' --- Dimension only edges on the convex hull ---
For i = LBound(vComps) To UBound(vComps)
Set comp = vComps(i)
vEdges = swView.GetVisibleEntities2(comp, 1)
If Not IsEmpty(vEdges) Then
For j = LBound(vEdges) To UBound(vEdges)
On Error GoTo SkipEdge2
Set ent = vEdges(j)
vCurveParam = ent.GetCurveParams2
ExtractFields vCurveParam(8), nDummy, nIdentity
If nIdentity = LINE_TYPE Then
' Dim coords(2) As Double
coords(0) = vCurveParam(0): coords(1) = vCurveParam(1): coords(2) = vCurveParam(2)
Set swModelStartPt = swMathUtil.CreatePoint(coords)
coords(0) = vCurveParam(3): coords(1) = vCurveParam(4): coords(2) = vCurveParam(5)
Set swModelEndPt = swMathUtil.CreatePoint(coords)
Set swViewStartPt = swModelStartPt.MultiplyTransform(swViewXform)
Set swViewEndPt = swModelEndPt.MultiplyTransform(swViewXform)
Dim x1 As Double, y1 As Double, x2 As Double, y2 As Double
x1 = Round(swViewStartPt.ArrayData(0), 4)
y1 = Round(swViewStartPt.ArrayData(1), 4)
x2 = Round(swViewEndPt.ArrayData(0), 4)
y2 = Round(swViewEndPt.ArrayData(1), 4)
' Only consider edges on convex hull
If Not IsEdgeOnHull(x1, y1, x2, y2, hullPts) Then GoTo SkipEdge2
' --- Duplicate filter ---
Dim key As String
If x1 < x2 Or (x1 = x2 And y1 < y2) Then
key = CStr(x1) & "_" & CStr(y1) & "_" & CStr(x2) & "_" & CStr(y2)
Else
key = CStr(x2) & "_" & CStr(y2) & "_" & CStr(x1) & "_" & CStr(y1)
End If
If edgeDict.Exists(key) Then GoTo SkipEdge2 Else edgeDict.Add key, True
' ------------------------
' Select and dimension
swModel.ClearSelection2 True
swView.SelectEntity ent, False
If Abs(x1 - x2) < nTolerance Then
nXpos = vOutline(0) - nXoffset * 0.01
nYpos = Abs((y1 + y2) / 2#)
Set swDispDim = swModel.AddVerticalDimension2(nXpos, nYpos, 0#)
ElseIf Abs(y1 - y2) < nTolerance Then
nXpos = Abs((x1 + x2) / 2#)
nYpos = vOutline(3) + nYoffset
Set swDispDim = swModel.AddHorizontalDimension2(nXpos, nYpos, 0#)
Else
nXpos = Abs((x1 + x2) / 2#) + nXoffset
nYpos = Abs((y1 + y2) / 2#) + nYoffset
Set swDispDim = swModel.AddDimension2(nXpos, nYpos, 0#)
End If
swModel.ClearSelection2 True
End If
SkipEdge2:
Err.Clear
Next j
End If
Next i
swModel.GraphicsRedraw2
MsgBox "Auto-dimensioning completed for outer edges of view: " & viewName, vbInformation
End Sub
' --- Simple 2D convex hull using Graham scan
Function ConvexHull2D(allPts As Collection) As Collection
Dim sortedPts() As Variant
Dim i As Long
ReDim sortedPts(1 To allPts.Count)
For i = 1 To allPts.Count
sortedPts(i) = allPts(i)
Next i
' Sort by X (then Y)
Dim swapped As Boolean, temp As Variant
Do
swapped = False
For i = 1 To UBound(sortedPts) - 1
If sortedPts(i)(0) > sortedPts(i + 1)(0) Or _
(sortedPts(i)(0) = sortedPts(i + 1)(0) And sortedPts(i)(1) > sortedPts(i + 1)(1)) Then
temp = sortedPts(i)
sortedPts(i) = sortedPts(i + 1)
sortedPts(i + 1) = temp
swapped = True
End If
Next i
Loop While swapped
' Graham scan
Dim hull As New Collection
Dim pt As Variant
For i = 1 To UBound(sortedPts)
pt = sortedPts(i)
Do While hull.Count >= 2
Dim pt2 As Variant, pt1 As Variant
pt1 = hull(hull.Count - 1)
pt2 = hull(hull.Count)
If (pt2(0) - pt1(0)) * (pt(1) - pt1(1)) - (pt2(1) - pt1(1)) * (pt(0) - pt1(0)) <= 0 Then
hull.Remove hull.Count
Else
Exit Do
End If
Loop
hull.Add pt
Next i
Set ConvexHull2D = hull
End Function
