變更工程圖圖層顏色的應用例（变更工程图图层颜色的应用实例，VBA练习）

ryouss

Piston Animation.rar (168.47 KB, 下载次数: 167, 售价: 40 金币)

2018-6-16 09:21 上传

点击文件名下载附件
售价: 40 金币  [记录]
下载积分: 金币 -1

含工程图(2012),swp及簡介

1. ' ****************************************************************
   
2. ' 2016/1/15 SC Liang
   
3. ' [url=https://www.swbbsc.com/forum-57-1.html]宏[/url](巨集)變更工程圖的圖層顏色'
   
4. ' 操作:1.打開 Piston Animation.SLDDRW 文件
   
5. '      2. 執行 main [url=https://www.swbbsc.com/forum-57-1.html]宏[/url]
   
6. '
   
7. ' *****************************************************************
   
8. Dim swApp As Object
   
9. Dim Part As Object
   
10. Dim boolstatus As Boolean
    
11. Dim myDimension_1 As Object
    
12. 
    
13. Sub main()
    
14. Set swApp = Application.SldWorks
    
15. Set Part = swApp.ActiveDoc
    
16. Set myModelView = Part.ActiveView
    
17. Set myDimension_1 = Part.Parameter("D3@草圖32") '角度尺寸控制活塞上下
    
18. Set myDimension_2 = Part.Parameter("D8@草圖32") '角度尺寸控制循環色盤
    
19. '~~~~~~~~~~ 常數 ~~~~~~~~~~
    
20. pi = Atn(1) * 4 '3.14159
    
21. R = 10 '弧長半徑
    
22. '~~~~~~~~~ 活塞驅動角度 ~~~~~~~~
    
23. For i = 0.01 To 720.01 Step 15 '單位:角度
    
24. Arc_L1 = i * pi / 180 * R / 1000 '活塞角度轉為弧長
    
25. Arc_L2 = Arc_L1 / 2 '色盤弧長
    
26. 
    
27. 'Debug.Print "Arc_L1: " & i
    
28. myDimension_1.SystemValue = Arc_L1
    
29. myDimension_2.SystemValue = Arc_L2
    
30. boolstatus = Part.EditRebuild3()
    
31. 
    
32. '~~~ 控制工程圖圖層 ~~~
    
33. '~~~汽缸空間變色~~~
    
34. 
    
35.     Dim swModel                     As SldWorks.ModelDoc2
    
36.     Dim swLayerMgr                  As SldWorks.LayerMgr
    
37.     Dim vLayerArr                   As Variant
    
38.     Dim vLayer                      As Variant
    
39.     Dim swLayer                     As SldWorks.Layer
    
40.     Set swModel = swApp.ActiveDoc
    
41.     Set swLayerMgr = swModel.GetLayerManager
    
42.     vLayerArr = swLayerMgr.GetLayerList '取得圖層清單
    
43.     For Each vLayer In vLayerArr '循環全部圖層清單
    
44.         Set swLayer = swLayerMgr.GetLayer(vLayer)
    
45.         If swLayer.Name = "Space" And i < 181 Then swLayer.Color = RGB(0, 255, 0) '進氣_綠色
    
46.         If swLayer.Name = "Space" And (i > 180 And i < 373) Then swLayer.Color = RGB(255, 180, 220) '壓縮_粉紅色
    
47.         If swLayer.Name = "Space" And (i > 372 And i < 381) Then swLayer.Color = RGB(255, 0, 0) '點火_紅色
    
48.         If swLayer.Name = "Space" And (i > 380 And i < 541) Then swLayer.Color = RGB(80, 200, 255) '驅動_水藍色
    
49.         If swLayer.Name = "Space" And (i > 540 And i < 721) Then swLayer.Color = RGB(190, 190, 190) '排氣_灰色
    
50.                
    
51.         'Debug.Print "  " & swLayer.Name
    
52.         'Debug.Print "    Color          = " & swLayer.Color
    
53.      Next
    
54. Next
    
55. End Sub

复制代码

hu001490

很不错，顶一下！

qxzch

真不错，顶！

xdliufh

很不错，顶一下！

hdgd501

   经典案例图书

很不错，顶一下！

fuwa505

楼主很专业，写得很好！

zjx812

   经典案例图书

这个666，值得好好学习。

zjx_812

不错，谢谢楼主分享！

杜丰林

感谢楼主的分享

bingyu2018

非常棒   代码都会

benjujieshu

好东西，努力学习学习！

hdgd501

楼主太有才了，膜拜中……

zjx839392

谢谢分享

wwwerzhou

这个具体用在哪里!

jyzas001

加入QQ群
参与讨论和学习

或扫描二维码加入

不错，谢谢分享

sheerart

   经典案例图书

还不错的样子

wunvang

加入QQ群
参与讨论和学习

或扫描二维码加入

感谢楼主分享

dason8369307

   经典案例图书

很不错，顶一下！

yni621

活到老学到老！

fouwen

值得好好学习