依據Excel的XYZ座標數據在SW作圖

ryouss

參考

dongxl

有意思，楼主是怎么实现的呢？

haoha7087933

顶一下，楼主大神分享一下吧！

yj9295

很不错，希望能共享模型，谢谢！

ryouss

   经典案例图书

謝謝樓上支持!
再支持到10#分享資料.

志哥就是帅

支持楼主
紫薯布丁

design100

   经典案例图书

还行吧，这个我也会做！

hwwgh

楼主分享一下吧

peng188

有意思，楼主是怎么实现的呢？

LYCZJS

感谢楼主分享，很不错！

qianjs90924

这么麻烦！！！直接用方程式曲线更快

ryouss

peng188 发表于 2018-5-11 10:02
有意思，楼主是怎么实现的呢？

參考:附 .XLS 及 .SWP 檔   Excel批點坐標作點線或曲線.rar (112.18 KB, 下载次数: 30)

2018-6-11 22:18 上传

点击文件名下载附件
下载积分: 金币 -1

2018-6-11 22:20重傳

1. ' ******************************************************************************
   
2. ' macro recorded on 01/25/14 by scliang
   
3. ' 連結 excel作點,連成不規則曲線(放樣曲線)或直線
   
4. ' 版本 V140125-2-170916
   
5. ' 操作:
   
6. ' 1. 開 Excel座標檔,副檔名為 .XLS
   
7. ' 2. 開 SW 新零件
   
8. ' 3. 執行 [url=https://www.swbbsc.com/forum-57-1.html]宏[/url] main()
   
9. '
   
10. ' ******************************************************************************
    
11. Dim swApp As Object
    
12. Dim Part As Object
    
13. Dim boolstatus As Boolean
    
14. Sub Draw() '作圖
    
15. Set swApp = Application.SldWorks
    
16. Set Part = swApp.ActiveDoc
    
17. On Error Resume Next
    
18. If Part Is Nothing Then
    
19.     MsgBox "請先打開或者新建SolidWorks Part"
    
20. Exit Sub
    
21. End If
    
22. 
    
23. With UserForm1
    
24. If .OptionButton1.Value = True Then item = 1
    
25. If .OptionButton2.Value = True Then item = 2
    
26. If .OptionButton3.Value = True Then item = 3
    
27. End With
    
28. Dim skSegment  As Object
    
29. Dim pointArray As Variant
    
30. Dim points() As Double
    
31. Set xl = GetObject(, "Excel.Application") '連結Excel
    
32. '*** Get active sheet in Exce
    
33. Set xls = xl.ActiveSheet
    
34. '*** Get value in Excel cell value
    
35. rgs = InputBox("鍵入Excel儲存格(單元格)範圍", , "C11:E203") 'L11:N15
    
36. Set wb = xl.Activeworkbook
    
37. If wb Is Nothing Then
    
38.     MsgBox "請先打開 Excel 點座標檔"
    
39. Exit Sub
    
40. End If
    
41. Part.SketchManager.Insert3DSketch True '插入3D草圖
    
42. Start_Row = xls.range(rgs).ROW
    
43. u = Right(rgs, Len(rgs) - InStr(rgs, ":")) '取 : 之後的單元格
    
44. End_Row = xls.range(u).ROW
    
45. Set rags = xls.range(rgs) 'Excel數據範圍
    
46. ct = (End_Row - Start_Row + 1) * 3 '數據總筆數數
    
47. ReDim points(1 To ct) As Double
    
48. n = 0
    
49. For Each rag In rags 'Excel單元格數據
    
50.     If rag = "" Then Exit For
    
51.         n = n + 1
    
52.         points(n) = rag / 1000 '數據存至陣列
    
53. Next
    
54. Select Case item
    
55. Case 1 '作點
    
56.     For i = 1 To n Step 3
    
57.         Set skSegment = Part.SketchManager.CreatePoint(points(i), points(i + 1), points(i + 2))
    
58.         myModelView.RotateAboutCenter 0, 0
    
59.     Next
    
60.    
    
61. Case 2 '不規則曲線連點
    
62.     pointArray = points
    
63.     Set skSegment = Part.SketchManager.CreateSpline((pointArray))
    
64.     myModelView.RotateAboutCenter 0, 0
    
65. Case 3 '直線連點
    
66.     m = n - 5
    
67.     For i = 1 To m Step 3
    
68.         Set skSegment = Part.SketchManager.CreateLine(points(i), points(i + 1), points(i + 2), points(i + 3), points(i + 4), points(i + 5))
    
69.         myModelView.RotateAboutCenter 0, 0
    
70.     Next
    
71. End Select
    
72. 
    
73. End Sub
    
74. 
    
75. Sub main() '主程式
    
76.     UserForm1.Show 0
    
77. End Sub
    

复制代码

LYCZJS

SW机械工程师论坛，找到组织了！

lcj2018

ryouss 发表于 2018-5-17 11:30
參考:附 .XLS 及 .SWP 檔

支持一下，谢谢分享！

lcj2018

加入QQ群
参与讨论和学习

或扫描二维码加入

ryouss 发表于 2018-5-17 11:30
參考:附 .XLS 及 .SWP 檔

我靠，怎么是个空文件夹？太不厚道了吧！

ryouss

   经典案例图书

lcj2018 发表于 2018-6-11 19:25
我靠，怎么是个空文件夹？太不厚道了吧！

可能是上傳操作失誤,已補傳了.

造成不便請諒解!

lcj2018

加入QQ群
参与讨论和学习

或扫描二维码加入

ryouss 发表于 2018-6-11 22:17
可能是上傳操作失誤,已補傳了.

造成不便請諒解!

支持一下，谢谢分享！

gfzms2590

   经典案例图书

这么麻烦！！！直接用方程式曲线更快

ryouss

gfzms2590 发表于 2018-6-12 13:46
这么麻烦！！！直接用方程式曲线更快

這是概念問題,

當手上取得EXCEL大量座標資料,哪曉得是什麼方程式時,
就可以用SW作圖看看.