Rob Edwards

Create Custom Symbols Macro

Discussion created by Rob Edwards on Jan 11, 2019
Latest reply on Jan 14, 2019 by Jerome De San Nicolás

This project was inspired by this passage from Matt Lombard 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:
';;
';; #<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 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

Outcomes