软件平台：SolidWorks2016+Excel2013
1. 在SolidWorks中建立好草图点，然后选择工具->宏->新建
2. 将Macrol 1中代码删除，复制如下代码放进去，运行可以在E盘得到保存坐标点的Excel文件
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'
' 草图点导出到Excel中
'
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Option Explicit
Dim swApp As Object
Dim modelDoc As Object
Dim sketch As Object
Dim objExcel As Object
Dim objWorkBook As Object
Dim objWorkSheet As Object
'Dim objWorkBook As Excel.Workbook
'Dim objWorkSheet As Excel.Worksheet
Const FILE_NAME = "E:\Coordinates.xls"
Sub main()
Set swApp = Application.SldWorks
Set modelDoc = swApp.ActiveDoc
If modelDoc Is Nothing Then
MsgBox "No active document!"
Exit Sub
End If
'// get active sketch
'
Set sketch = modelDoc.SketchManager.ActiveSketch
If sketch Is Nothing Then
MsgBox "No active Sketch!"
Exit Sub
End If
'// Check Excel
Set objExcel = CreateObject("Excel.Application")
If objExcel Is Nothing Then
MsgBox "Cannot open Excel!"
Exit Sub
End If
Set objWorkBook = objExcel.Workbooks.Add
If objWorkBook Is Nothing Then
MsgBox "Cannot open Excel Workbook!"
Exit Sub
End If
Set objWorkSheet = objWorkBook.Worksheets(1)
If objWorkSheet Is Nothing Then
MsgBox "Cannot open Excel WorkSheet!"
Exit Sub
End If
'Extract Sketch Points
'
Dim i As Integer
Dim sketchPoints As Variant
sketchPoints = sketch.GetSketchPoints2()
'Write X, Y, Z title to Excel worksheet
objWorkSheet.Cells(1, 1) = "X"
objWorkSheet.Cells(1, 2) = "Y"
objWorkSheet.Cells(1, 3) = "Z"
'Write coordinates to Excel worksheet
'
For i = 0 To UBound(sketchPoints)
objWorkSheet.Cells(i + 2, 1) = Round(sketchPoints(i).X * 1000, 2)
objWorkSheet.Cells(i + 2, 2) = Round(sketchPoints(i).Y * 1000, 2)
objWorkSheet.Cells(i + 2, 3) = Round(sketchPoints(i).Z * 1000, 2)
Next i
objWorkBook.SaveAs FILE_NAME
'Close Excel
'
objWorkBook.Close
objExcel.Quit
Set objWorkSheet = Nothing
Set objWorkBook = Nothing
Set objExcel = Nothing
MsgBox "坐标存储于:" & vbCrLf & FILE_NAME
End Sub
参考文献