It was a long long time ago I wrote this.. believe it or not my first solution involved saving as as iges and I had an excel spreadsheet that parsed it and outputted the code.
This was one of the first projects I did when learning the api and VBA. I daren't even look at the code but I remember it worked perfect.
Code: Select all
' Macro to create custom symbols from sketches
' v1.1 by 369
'
';; SolidWorks
';;
';; Geometric Tolerancing Symbols Library.
';;
';; Format:
';;
';; #<Name of library>,<Description of library>
';; *<Name of symbol>,<Description of symbol>
';; 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,<letter(s)>
';; 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 swSketchText As SldWorks.SketchText
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
Set swSketchText = vSketchSegment
Dim vCoordinates As Variant
vCoordinates = swSketchText.GetCoordinates()
sCode = sCode & "A,TEXT " & FormatNumber(CStr(vCoordinates(0) * 1000), 4) & ", " _
& FormatNumber(CStr(vCoordinates(1) * 1000), 4) & ", " _
& swSketchText.Text & vbCr
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
This post popping back to the top reminded me why I was trying to figure it out, but also makes it unneccessary for me to write the thing I was trying to figure it out for. 
I'm curious to check this out and see how you dunnit.