Hello there. I have a problem to make macro for getting X&Y coordinates of all points from sketch (see a picture), but on new coordinate system. Can anyone help me?
Thanks in advance
Danijel
Hi Danijel
You can try something like tihs
....
Set swApp = Application.SldWorks
Dim oPart As ModelDoc2
Set oPart = swApp.ActiveDoc
Dim oSketch As Sketch
Set oSketch = oPart.SketchManager.ActiveSketch 'Get Active skecth
Dim sketchPointArray As Variant
' Each item of this array will give you a sketch point in the active skech
sketchPointArray = oSketch.GetSketchPoints2
Dim i As Integer
For i = LBound(sketchPointArray) To UBound(sketchPointArray)
'MsgBox sketchPointArray(i).X & " " & sketchPointArray(i).Y & " " & sketchPointArray(i).Z
Next
...
Regards,
Manish
Manish
I tried the code and getting this error
Am I doing something wrong?
Thanks,
JOHN
Hi John,
As I mentioned in my comment in code, this will return active sketch, so make sure ur sketch is open. Otherwise change code to get sketch by selection.
Danijel,
You might want to ask this in the API forum. The people who can answer you best will be more likely to see it there.
Jerry S.
Hello my friends, I tried to ask this question on API section of the forum but I don't have a permission, maybe because I am new member on this forum.
It is most likely because you do not have the sketch open or in edit mode. This is when that method is available.
Try editing the sketch and running the macro again.
I have attached a little more elaborate macro.
Dear Jeff,
This doesn't works for me. I am getting an error. Can anyone help me to make macro which takes (X,Y) coordinates of all points in sketch for NEW CREATED COORDINATED SYSTEM.
Thanks in advance.
D.R.
I found an macro which doing what I want, but Default coordinate system named (origin). How to modify macro to works on diferent coordinate system (in my case "Coordinate System1")?
'----------------------------------------------------
' Option Explicit
Public Enum swSketchSegments_e
swSketchLine = 0
swSketchArc = 1
swSketchEllipse = 2
swSketchSpline = 3
swSketchTEXT = 4
swSketchParabola = 5
End Enum
Sub main()
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swSelMgr As SldWorks.SelectionMgr
Dim swFeat As SldWorks.feature
Dim swSketch As SldWorks.sketch
Dim i As Long
Dim bRet As Boolean
Dim vSketchSeg As Variant
Dim swSketchSeg As SldWorks.SketchPoint
Dim nLength As Double
Dim xValue() As Double
Dim yValue() As Double
Dim zValue() As Double
Dim point_count As Integer
On Error GoTo error:
Set swApp = CreateObject("SldWorks.Application")
Set swModel = swApp.ActiveDoc
If swModel.GetSaveFlag Then
MsgBox "Part/Assembly must be saved", vbCritical
Exit Sub
End If
If swModel Is Nothing Then Exit Sub
Set swSelMgr = swModel.SelectionManager
Set swFeat = swSelMgr.GetSelectedObject5(1)
If swFeat Is Nothing Then
Set swSketch = swModel.GetActiveSketch2
If swSketch Is Nothing Then
MsgBox ("you must select the sketch from feature manager tree or at least be in a sketch")
Exit Sub
End If
Else
Set swSketch = swFeat.GetSpecificFeature2
End If
vSketchSeg = swSketch.GetSketchPoints
point_count = UBound(vSketchSeg)
ReDim xValue(point_count)
ReDim yValue(point_count)
ReDim zValue(point_count)
For i = 0 To point_count
Set swSketchSeg = vSketchSeg(i)
xValue(i) = swSketchSeg.x * 1000
yValue(i) = swSketchSeg.y * 1000
zValue(i) = swSketchSeg.z * 1000
Next i
tFilename = swModel.GetPathName
sFilename = Left(tFilename, Len(tFilename) - 7)
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.CreateTextFile(sFilename & ".txt", True)
For i = 0 To point_count
f.writeline Format(xValue(i)) & "," & _
Format(yValue(i)) & "," & _
Format(zValue(i))
Next i
f.Close
MsgBox Left(swModel.GetTitle, Len(swModel.GetTitle) - 7) & ".txt file created under working directory"
Exit Sub
error: MsgBox " please make sure that:" & vbCrLf & _
"1. Only one SolidWorks session is opened" & vbCrLf & _
"2. An Assembly or a part is the active document" & vbCrLf & _
"3. A Sketch feature is selected or active with nothing selected" & vbCrLf & _
"4. you are allowed to write to working directory.", vbInformation
Exit Sub
End Sub
'----------------------------------------------------
Option Explicit
Public Enum swSketchSegments_e
swSketchLINE = 0
swSketchARC = 1
swSketchELLIPSE = 2
swSketchSPLINE = 3
swSketchTEXT = 4
swSketchPARABOLA = 5
End Enum
Sub main()
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swSelMgr As SldWorks.SelectionMgr
Dim swFeat1 As SldWorks.Feature
Dim swFeat2 As SldWorks.Feature
Dim swSketch As SldWorks.Sketch
Dim cSysData As SldWorks.CoordinateSystemFeatureData
Dim i As Long
Dim vSketchSeg As Variant
Dim swSketchSeg As SldWorks.SketchPoint
Dim xValue() As Double
Dim yValue() As Double
Dim zValue() As Double
Dim point_count As Integer
Dim sFilename As String
Dim fs As Object
Dim f As Object
On Error GoTo error:
Set swApp = CreateObject("SldWorks.Application")
Set swModel = swApp.ActiveDoc
If swModel.GetSaveFlag Then
MsgBox "Part/Assembly must be saved", vbCritical
Exit Sub
End If
If swModel Is Nothing Then Exit Sub
Set swSelMgr = swModel.SelectionManager
Select Case swSelMgr.GetSelectedObjectCount2(-1)
Case 1
Set swFeat1 = swSelMgr.GetSelectedObject6(1, -1)
If swFeat1.GetTypeName2 = "CoordSys" Then
Set cSysData = swFeat1.GetSpecificFeature2
Else
MsgBox ("you must select coordinate system and the sketch from feature manager tree or at least be in a sketch")
Exit Sub
End If
Set swSketch = swModel.GetActiveSketch2
If swSketch Is Nothing Then
MsgBox ("you must select coordinate system and the sketch from feature manager tree or at least be in a sketch")
Exit Sub
End If
Case 2
Set swFeat1 = swSelMgr.GetSelectedObject6(1, -1)
Set swFeat2 = swSelMgr.GetSelectedObject6(2, -1)
If swFeat1.GetTypeName2 = "CoordSys" Then
Set cSysData = swFeat1.GetDefinition
ElseIf swFeat2.GetTypeName2 = "CoordSys" Then
Set cSysData = swFeat2.GetDefinition
Else
MsgBox ("you must select coordinate system and the sketch from feature manager tree or at least be in a sketch")
Exit Sub
End If
If swFeat1.GetTypeName2 = "ProfileFeature" Then
Set swSketch = swFeat1.GetSpecificFeature2
ElseIf swFeat2.GetTypeName2 = "ProfileFeature" Then
Set swSketch = swFeat2.GetSpecificFeature2
Else
MsgBox ("you must select coordinate system and the sketch from feature manager tree or at least be in a sketch")
Exit Sub
End If
End Select
Dim mu As SldWorks.MathUtility
Set mu = swApp.GetMathUtility
Dim swSkXform As SldWorks.MathTransform
Set swSkXform = swSketch.ModelToSketchTransform
Set swSkXform = swSkXform.Inverse
Dim PointCoords(2) As Double
Dim vPt As Variant
Dim mt As SldWorks.MathTransform
Dim mp As SldWorks.MathPoint
Set mt = cSysData.Transform
Set mt = mt.Inverse
vSketchSeg = swSketch.GetSketchPoints
point_count = UBound(vSketchSeg)
ReDim xValue(point_count)
ReDim yValue(point_count)
ReDim zValue(point_count)
For i = 0 To point_count
Set swSketchSeg = vSketchSeg(i)
PointCoords(0) = swSketchSeg.X
PointCoords(1) = swSketchSeg.Y
PointCoords(2) = swSketchSeg.Z
vPt = PointCoords
Set mp = mu.CreatePoint(vPt)
Set mp = mp.MultiplyTransform(swSkXform)
Set mp = mp.MultiplyTransform(mt)
xValue(i) = mp.ArrayData(0) * 1000
yValue(i) = mp.ArrayData(1) * 1000
zValue(i) = mp.ArrayData(2) * 1000
Next i
sFilename = swModel.GetPathName
sFilename = Left(sFilename, Len(sFilename) - 7)
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.CreateTextFile(sFilename & ".txt", True)
For i = 0 To point_count
f.writeline Format(xValue(i)) & "," & _
Format(yValue(i)) & "," & _
Format(zValue(i))
Next i
f.Close
MsgBox Left(swModel.GetTitle, Len(swModel.GetTitle) - 7) & ".txt file created under working directory"
Exit Sub
error: MsgBox " please make sure that:" & vbCrLf & _
"1. Only one SolidWorks session is opened" & vbCrLf & _
"2. An Assembly or a part is the active document" & vbCrLf & _
"3. A Sketch feature is selected or active with nothing selected" & vbCrLf & _
"4. you are allowed to write to working directory.", vbInformation
Exit Sub
End Sub
Hello Ivana, thank you for the reply but it doesn't works for me, or maybe I don't know how to use macro.
Warm Regards,
Danijel
Danijel,
It's because of the extra line break between the two lines
I corrected the maco
Please use this one
Hello John, I respect you are trying to help me but I get new error again. Maybe SW verison is a problem. I have 2010. 
then create new macro and copy and paste text from this one to new one. Or delete empty lines from macro which I posted this morning. Each line ending with _ should not be followed by empty row
Thank you very much Ivana . Finally it works perfect. Thanks a lot to John and everyone which tried to help me. You are simple the best my friends.
Thanks again
D.R.
Hi John , I know is is from a long time ago but I have tried your macro and it tells me ," you must select coordinate system and sketch fro mfeature manager tree or be in a sketch"
I have tried using the macro while in the sketch, and creating a new coordinate system , and selecting it and the sketch at the same time , but I still get the message. Could you help me with this Please?
