Macro to add horizontal and vertical ordinate dimensions for holes in SOLIDWORKS drawings view
This SOLIDWORKS VBA macro automates adding the horizontal ordinate dimensions for all the holes in the selected drawing view.
- Macro will find the ordinate dimension origin by finding the bottom left vertex in the view
- Macro will find all holes of the view (only internal holes are included, fillets will not be considered)
- Macro will add horizontal and vertical dimensions for the holes
- Dimensions wil be positioned relative to the drawing view
Dim swApp As SldWorks.SldWorks
Dim swMathUtils As SldWorks.MathUtility
Sub main()
Set swApp = Application.SldWorks
Set swMathUtils = swApp.GetMathUtility
Dim swModel As SldWorks.ModelDoc2
Set swModel = swApp.ActiveDoc
Dim swView As SldWorks.view
Set swView = swModel.SelectionManager.GetSelectedObject6(1, -1)
If swView Is Nothing Then
Err.Raise vbError, "", "Please select view"
End If
Dim swOrigVertex As SldWorks.vertex
Set swOrigVertex = FindOriginVertex(swView)
Dim vHoles As Variant
vHoles = FindHoles(swView)
If IsEmpty(vHoles) Then
Err.Raise vbError, "", "No holes found"
End If
Dim vOutline As Variant
vOutline = swView.GetOutline
Dim offset As Double
offset = (vOutline(2) - vOutline(1)) * 0.1
AddOrdinateDimensions swModel, swOrigVertex, vHoles, swAddOrdinateDims_e.swHorizontalOrdinate, 0, vOutline(1) - offset
AddOrdinateDimensions swModel, swOrigVertex, vHoles, swAddOrdinateDims_e.swVerticalOrdinate, vOutline(0) - offset, 0
End Sub
Sub AddOrdinateDimensions(model As SldWorks.ModelDoc2, origVertex As SldWorks.vertex, holes As Variant, dimType As swAddOrdinateDims_e, x As Double, y As Double)
Dim swSels() As SldWorks.Entity
ReDim swSels(1 + UBound(holes))
Set swSels(0) = origVertex
Dim i As Integer
For i = 0 To UBound(holes)
Set swSels(i + 1) = holes(i)
Next
If model.Extension.MultiSelect2(swSels, False, Nothing) = UBound(swSels) + 1 Then
Dim res As Long
res = model.Extension.AddOrdinateDimension(dimType, x, y, 0)
model.SetPickMode
If res <> swCreateOrdDimError_e.swCreateOrdDimErr_Success Then
Err.Raise vbError, "", "Failed to add ordinate dimension"
End If
Else
Err.Raise vbError, "", "Failed to select entities"
End If
End Sub
Function FindOriginVertex(view As SldWorks.view) As SldWorks.vertex
Dim vComps As Variant
vComps = view.GetVisibleComponents
Dim swViewTransform As SldWorks.MathTransform
Set swViewTransform = view.ModelToViewTransform
Dim swOriginVertex As SldWorks.vertex
If Not IsEmpty(vComps) Then
Dim i As Integer
For i = 0 To UBound(vComps)
Dim swComp As SldWorks.Component2
Set swComp = vComps(i)
Dim vVisEnts As Variant
vVisEnts = view.GetVisibleEntities2(swComp, swViewEntityType_e.swViewEntityType_Vertex)
Dim j As Integer
For j = 0 To UBound(vVisEnts)
Dim swVertex As SldWorks.vertex
Set swVertex = vVisEnts(j)
If swOriginVertex Is Nothing Then
Set swOriginVertex = swVertex
Else
Dim vCurOrigCoord As Variant
vCurOrigCoord = GetVertexCoordinate(swOriginVertex, swViewTransform)
Dim vCoord As Variant
vCoord = GetVertexCoordinate(swVertex, swViewTransform)
If vCoord(0) < vCurOrigCoord(0) And vCoord(1) < vCurOrigCoord(1) Then
Set swOriginVertex = swVertex
End If
End If
Next
Next
End If
If swOriginVertex Is Nothing Then
Err.Raise vbError, "", "Failed to find origin vertex"
End If
Set FindOriginVertex = swOriginVertex
End Function
Function GetVertexCoordinate(vertex As SldWorks.vertex, transform As SldWorks.MathTransform) As Variant
Dim vCoordPt As Variant
vCoordPt = vertex.GetPoint()
Dim swMathPt As SldWorks.MathPoint
Set swMathPt = swMathUtils.CreatePoint(vCoordPt)
Set swMathPt = swMathPt.MultiplyTransform(transform)
GetVertexCoordinate = swMathPt.ArrayData
End Function
Function FindHoles(view As SldWorks.view) As Variant
Dim vComps As Variant
vComps = view.GetVisibleComponents
Dim swHoles() As SldWorks.Edge
If Not IsEmpty(vComps) Then
Dim i As Integer
For i = 0 To UBound(vComps)
Dim swComp As SldWorks.Component2
Set swComp = vComps(i)
Dim vVisEnts As Variant
vVisEnts = view.GetVisibleEntities2(swComp, swViewEntityType_e.swViewEntityType_Edge)
Dim j As Integer
For j = 0 To UBound(vVisEnts)
Dim swEdge As SldWorks.Edge
Set swEdge = vVisEnts(j)
Dim swCurve As SldWorks.Curve
Set swCurve = swEdge.GetCurve
If False <> swCurve.IsCircle() Then
Dim isClosed As Boolean
swCurve.GetEndParams -1, -1, isClosed, -1
If False <> isClosed Then
If (Not swHoles) = -1 Then
ReDim swHoles(0)
Else
ReDim Preserve swHoles(UBound(swHoles) + 1)
End If
Set swHoles(UBound(swHoles)) = swEdge
End If
End If
Next
Next
End If
If (Not swHoles) = -1 Then
FindHoles = Empty
Else
FindHoles = swHoles
End If
End Function