This project was inspired by this passage from ​ in his excellent 2013 Bible

It will analyse sketches and copy the code to the clipboard.

It will ignore a sketch called Bounding Box Sketch which is a 1x1 Rectangle with bottom left at origin.

For example this will give the following code

A few points to note

You can name your sketches to name your symbols

For the special case of a Solid Arc you can use construction geometry

Remember to backup your Gtol.sym file before changing anything

I'd like to add text support to this and also make it possible to select sketches individually.

I'll get round to it one day... or maybe you'd like to do that

Macro and 2016 bounding box part attached

' Macro to create custom symbols from sketches
' v1.1 by 369
'
';; SolidWorks
';;
';; Geometric Tolerancing Symbols Library.
';;
';; Format:
';;
';; #,
';; *,
';; A,LINE xStart,yStart,xEnd,yEnd
';; A,CIRCLE xCenter,yCenter,radius
';; A,ARC xCenter,yCenter,radius,startAngle,endAngle
';; A,SARC xCenter,yCenter,radius,startAngle,endAngle
';; A,TEXT xLowerLeft,yLowerLeft,
';; A,POLY x1,y1,x2,y2,x3,y3
';;
';; Units:
';;
';; All x, y, and radius values are in the symbols grid space (0.0 to 1.0),
';; where 0,0 is the lower left corner and 1,1 is the upper right corner.
';; The grid space is considered to be the height of a character squared.
';; All angle values are in degrees.
';;
'
'
'
'
'
'
'
'
'
'
Option Explicit
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swFeatFolder As SldWorks.FeatureFolder
Dim swFeature As SldWorks.Feature
Dim swSketchMgr As SldWorks.SketchManager
Dim swSketch As Sketch
Dim vSketchSegments As Variant
Dim vSketchSegment As Variant
Dim swSketchSegment As SldWorks.SketchSegment
Dim swSketchLine As SldWorks.SketchLine
Dim swSketchArc As SldWorks.SketchArc
Dim swStartSketchPoint As SldWorks.SketchPoint
Dim swEndSketchPoint As SldWorks.SketchPoint
Dim swCenterSketchPoint As SldWorks.SketchPoint
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long
Function get_angle(x As Double, y As Double) As Double
Rem Returns the angle in degrees of the x,y point from the origin, with zero degrees at 3 O'Clock going Clockwise
Dim Angle As Double
Dim PI As Double
PI = 4 * Atn(1)
If x = 0 Then
Angle = PI / 2
Else
Angle = Atn(Abs(y) / Abs(x))
End If
If x < 0 Then
If y < 0 Then
Angle = PI + Angle
Else
Angle = PI - Angle
End If
Else
If y < 0 Then
Angle = 2 * PI - Angle
Else
'Angle = Angle
End If
End If
get_angle = (Angle * 180) / PI
End Function
Sub main()
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set swSketchMgr = swModel.SketchManager
swModel.ClearSelection2 True
Dim sCode As String
sCode = ""
Dim sName As String
Dim sFeatType As String
Dim xStart, xEnd, xCenter As Double
Dim yStart, yEnd, yCenter As Double
Dim startAngle, endAngle As Double
sCode = sCode & ";;" & vbCr
sCode = sCode & ";; ---------------------------------------------------------------------------" & vbCr
sCode = sCode & ";;" & vbCr
sCode = sCode & ";; Custom Symbols" & vbCr
sCode = sCode & ";;" & vbCr
Set swFeature = swModel.FirstFeature
While Not swFeature Is Nothing 'we have a feature
If swFeature.GetTypeName2 = "FtrFolder" Then
If InStr(1, swFeature.Name, "EndTag", vbTextCompare) Then
sCode = sCode & ";;" & vbCr
Else
sCode = sCode & "#" & swFeature.Name & "," & swFeature.Description & " description" & vbCr
End If
End If
If swFeature.GetTypeName2 = "ProfileFeature" Then
Set swSketch = swFeature.GetSpecificFeature2
If swSketch.Name = "Bounding Box Sketch" Then
'ignore
Else
sCode = sCode & "*" & swSketch.Name & "," & swSketch.Description & vbCr 'Symbol Name
vSketchSegments = swSketch.GetSketchSegments
If (Not IsEmpty(vSketchSegments)) Then
For Each vSketchSegment In vSketchSegments
Set swSketchSegment = vSketchSegment
Select Case (swSketchSegment.GetType)
'Case swSketchSegments_e.swSketchTEXT
Case swSketchSegments_e.swSketchLine
If swSketchSegment.ConstructionGeometry Then 'do nothing
Else
Set swSketchLine = swSketchSegment
Set swStartSketchPoint = swSketchLine.GetStartPoint2
Set swEndSketchPoint = swSketchLine.GetEndPoint2
xStart = swStartSketchPoint.x * 1000
yStart = swStartSketchPoint.y * 1000
xEnd = swEndSketchPoint.x * 1000
yEnd = swEndSketchPoint.y * 1000
sCode = sCode & "A,LINE " & FormatNumber(CStr(xStart), 4) & "," & FormatNumber(CStr(yStart), 4) & "," & FormatNumber(CStr(xEnd), 4) & "," & FormatNumber(CStr(yEnd), 4) & vbCr
End If
Case swSketchSegments_e.swSketchELLIPSE
sCode = sCode & ";; Ellipse Ignored" & vbCr
Case swSketchSegments_e.swSketchArc
Set swSketchArc = swSketchSegment
Set swCenterSketchPoint = swSketchArc.GetCenterPoint2
xCenter = swCenterSketchPoint.x * 1000
yCenter = swCenterSketchPoint.y * 1000
Dim dRadius As Double
dRadius = swSketchArc.GetRadius * 1000
If swSketchArc.IsCircle Then
If swSketchSegment.ConstructionGeometry Then
sCode = sCode & "A,SARC " & FormatNumber(CStr(xCenter), 4) & "," & FormatNumber(CStr(yCenter), 4) & "," & FormatNumber(CStr(dRadius), 4) & "," & FormatNumber(CStr(0), 4) & "," & FormatNumber(CStr(180), 4) & vbCr
sCode = sCode & "A,SARC " & FormatNumber(CStr(xCenter), 4) & "," & FormatNumber(CStr(yCenter), 4) & "," & FormatNumber(CStr(dRadius), 4) & "," & FormatNumber(CStr(179), 4) & "," & FormatNumber(CStr(1), 4) & vbCr
Else
sCode = sCode & "A,CIRCLE " & FormatNumber(CStr(xCenter), 4) & "," & FormatNumber(CStr(yCenter), 4) & "," & FormatNumber(CStr(dRadius), 4) & vbCr
End If
Else 'partial arc
If swSketchArc.GetRotationDir = 1 Then 'Anti-Clockwise
Set swStartSketchPoint = swSketchArc.GetStartPoint2
Set swEndSketchPoint = swSketchArc.GetEndPoint2
Else 'Clockwise - engage reverse gear!
Set swStartSketchPoint = swSketchArc.GetEndPoint2
Set swEndSketchPoint = swSketchArc.GetStartPoint2
End If
xStart = swStartSketchPoint.x * 1000 - xCenter
yStart = swStartSketchPoint.y * 1000 - yCenter
xEnd = swEndSketchPoint.x * 1000 - xCenter
yEnd = swEndSketchPoint.y * 1000 - yCenter
startAngle = get_angle((xStart), (yStart))
endAngle = get_angle((xEnd), (yEnd))
If swSketchSegment.ConstructionGeometry Then
sCode = sCode & "A,SARC " & FormatNumber(CStr(xCenter), 4) & "," & FormatNumber(CStr(yCenter), 4) & "," & FormatNumber(CStr(dRadius), 4) & "," & FormatNumber(CStr(startAngle), 4) & "," & FormatNumber(CStr(endAngle), 4) & vbCr
Else
sCode = sCode & "A,ARC " & FormatNumber(CStr(xCenter), 4) & "," & FormatNumber(CStr(yCenter), 4) & "," & FormatNumber(CStr(dRadius), 4) & "," & FormatNumber(CStr(startAngle), 4) & "," & FormatNumber(CStr(endAngle), 4) & vbCr
End If
End If
'Case swSketchSegments_e.swSketchPARABOLA
'Case swSketchSegments_e.swSketchSPLINE
'Case Else
End Select
Next vSketchSegment
End If
End If
End If
Set swFeature = swFeature.GetNextFeature()
Wend
Dim DataObj As New MSForms.DataObject
'Put a string in the clipboard
DataObj.SetText sCode
DataObj.PutInClipboard
MsgBox "Code Copied To Clipboard"
End Sub