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

ryouss · 发表于 2018-6-16 09:24:58

经典图书

Piston Animation.rar (168.47 KB, 下载次数: 167, 售价: 40 金币) 含工程图(2012),swp及簡介

' ****************************************************************
' 2016/1/15 SC Liang
' [url=https://www.swbbsc.com/forum-57-1.html]宏[/url](巨集)變更工程圖的圖層顏色'
' 操作:1.打開 Piston Animation.SLDDRW 文件
' 2. 執行 main [url=https://www.swbbsc.com/forum-57-1.html]宏[/url]
'
' *****************************************************************
Dim swApp As Object
Dim Part As Object
Dim boolstatus As Boolean
Dim myDimension_1 As Object
Sub main()
Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
Set myModelView = Part.ActiveView
Set myDimension_1 = Part.Parameter("D3@草圖32") '角度尺寸控制活塞上下
Set myDimension_2 = Part.Parameter("D8@草圖32") '角度尺寸控制循環色盤
'~~~~~~~~~~ 常數 ~~~~~~~~~~
pi = Atn(1) * 4 '3.14159
R = 10 '弧長半徑
'~~~~~~~~~ 活塞驅動角度 ~~~~~~~~
For i = 0.01 To 720.01 Step 15 '單位:角度
Arc_L1 = i * pi / 180 * R / 1000 '活塞角度轉為弧長
Arc_L2 = Arc_L1 / 2 '色盤弧長
'Debug.Print "Arc_L1: " & i
myDimension_1.SystemValue = Arc_L1
myDimension_2.SystemValue = Arc_L2
boolstatus = Part.EditRebuild3()
'~~~ 控制工程圖圖層 ~~~
'~~~汽缸空間變色~~~
Dim swModel As SldWorks.ModelDoc2
Dim swLayerMgr As SldWorks.LayerMgr
Dim vLayerArr As Variant
Dim vLayer As Variant
Dim swLayer As SldWorks.Layer
Set swModel = swApp.ActiveDoc
Set swLayerMgr = swModel.GetLayerManager
vLayerArr = swLayerMgr.GetLayerList '取得圖層清單
For Each vLayer In vLayerArr '循環全部圖層清單
Set swLayer = swLayerMgr.GetLayer(vLayer)
If swLayer.Name = "Space" And i < 181 Then swLayer.Color = RGB(0, 255, 0) '進氣_綠色
If swLayer.Name = "Space" And (i > 180 And i < 373) Then swLayer.Color = RGB(255, 180, 220) '壓縮_粉紅色
If swLayer.Name = "Space" And (i > 372 And i < 381) Then swLayer.Color = RGB(255, 0, 0) '點火_紅色
If swLayer.Name = "Space" And (i > 380 And i < 541) Then swLayer.Color = RGB(80, 200, 255) '驅動_水藍色
If swLayer.Name = "Space" And (i > 540 And i < 721) Then swLayer.Color = RGB(190, 190, 190) '排氣_灰色
'Debug.Print " " & swLayer.Name
'Debug.Print " Color = " & swLayer.Color
Next
Next
End Sub

复制代码

hu001490 · 发表于 2018-6-17 10:04:26

很不错，顶一下！

qxzch · 发表于 2018-6-18 11:37:01

经典图书

真不错，顶！

xdliufh · 发表于 2018-6-28 08:01:46

很不错，顶一下！

hdgd501 · 发表于 2018-6-28 09:00:56

经典案例图书

很不错，顶一下！

fuwa505 · 发表于 2018-7-3 06:39:09

楼主很专业，写得很好！

zjx812 · 发表于 2018-7-4 20:24:52

经典案例图书

这个666，值得好好学习。

zjx_812 · 发表于 2018-7-8 22:00:40

不错，谢谢楼主分享！

杜丰林 · 发表于 2018-7-13 17:24:25

感谢楼主的分享

bingyu2018 · 发表于 2018-9-28 19:21:11

经典图书

非常棒代码都会

benjujieshu · 发表于 2018-11-21 15:57:01

好东西，努力学习学习！

hdgd501 · 发表于 2018-12-12 12:46:45

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

zjx839392 · 发表于 2018-12-14 16:57:20

谢谢分享

wwwerzhou · 发表于 2019-1-6 14:11:35

这个具体用在哪里!

jyzas001 · 发表于 2019-1-13 11:09:31

加入QQ群
参与讨论和学习

或扫描二维码加入

不错，谢谢分享

sheerart · 发表于 2019-3-9 17:57:07

经典案例图书

还不错的样子

wunvang · 发表于 2019-4-30 20:32:11

加入QQ群
参与讨论和学习

或扫描二维码加入

感谢楼主分享

dason8369307 · 发表于 2019-5-10 18:14:57

经典案例图书

很不错，顶一下！

yni621 · 发表于 2020-7-15 11:01:41

活到老学到老！

fouwen · 发表于 2020-9-9 15:25:29

值得好好学习

		自动登录	找回密码
密码			立即注册

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

本帖被以下淘专辑推荐:

浏览过的版块

最佳新人

活跃会员

热心会员

宣传达人

灌水之王

突出贡献