调用当前文件名，填写DWG 图形特性的自定义属性，可以做到吗？

阡陌客

有没有一个宏可以做到：读取当前文件的文件名，填写到如下菜单看到的 图形特性的“自定义属性”
文件 >> 图形特性 >>  自定义属性

比如：文件名为“TH15008-001 A 外壳.dwg” ，
执行宏或者LSP ，自动填写如下自定义属性



比如当前文件名为“TH15008-001 A 外壳.dwg”
自动获取文件名的前11个字符为图号，或者判断第一个空格之前的字符为图号。
第一个空格与第二个空格之间的字母为版本号A，
后面的字符为名称

因为3D软件 solidworks是可以用宏轻松实现，读取文件名，自动填写自定义属性，然后工程图调用属性值的。
不知道Acad能不能做到。已经搜了mjtd，没找到相关内容，恳请高手指点，谢谢！


附SW的宏

1. '从这里开始复制:
   
2. 
   
3. '定义solidwork
   
4. 
   
5. Dim swApp As Object
   
6. 
   
7. Dim Part As Object
   
8. 
   
9. Dim SelMgr As Object
   
10. 
    
11. Dim boolstatus As Boolean
    
12. 
    
13. Dim longstatus As Long, longwarnings As Long
    
14. 
    
15. Dim Feature As Object
    
16. 
    
17. Dim a As Integer
    
18. 
    
19. Dim b As String
    
20. 
    
21. Dim m As String
    
22. 
    
23. Dim e As String
    
24. 
    
25. Dim k As String
    
26. 
    
27. Dim t As String
    
28. 
    
29. Dim c As String
    
30. 
    
31. Dim j As Integer
    
32. 
    
33. Dim strmat As String
    
34. 
    
35. Dim tempvalue As String
    
36. 
    
37. '增加n个新变量
    
38. 
    
39. Dim cailiao As String
    
40. Dim banben As String
    
41. Dim mingcheng As String
    
42. 
    
43. Sub main()
    
44. 
    
45. 'link solidworks
    
46. 
    
47. Set swApp = Application.SldWorks
    
48. 
    
49. Set Part = swApp.ActiveDoc
    
50. 
    
51. Set SelMgr = Part.SelectionManager
    
52. 
    
53. swApp.ActiveDoc.ActiveView.FrameState = 1
    
54. 
    
55. '设定变量
    
56. 
    
57. c = swApp.ActiveDoc.GetTitle() '文件名
    
58. 
    
59. 'cailiao = swApp.ActiveDoc.GetMaterial()
    
60. 
    
61. strmat = Chr(34) + Trim("SW-Material" + "@") + c + Chr(34) '获取材料表达式
    
62. 
    
63. '定义各自定义属性
    
64. 
    
65. blnretval = Part.DeleteCustomInfo2("", "文件名")
    
66. 
    
67. blnretval = Part.DeleteCustomInfo2("", "代号")
    
68. 
    
69. blnretval = Part.DeleteCustomInfo2("", "版本")
    
70. 
    
71. blnretval = Part.DeleteCustomInfo2("", "名称")
    
72. 
    
73. blnretval = Part.DeleteCustomInfo2("", "设计")
    
74. 
    
75. blnretval = Part.DeleteCustomInfo2("", "审核")
    
76. 
    
77. blnretval = Part.DeleteCustomInfo2("", "工艺")
    
78. 
    
79. 'blnretval = Part.DeleteCustomInfo2("", "材料")
    
80. 
    
81. 'blnretval = Part.DeleteCustomInfo2("", "表面处理")
    
82. 
    
83. a = InStr(c, " ") - 1      '重点：分隔标识符，这里是一个空格
    
84. 
    
85. If a > 0 Then
    
86. 
    
87.     k = Left(c, a)
    
88. 
    
89.     t = Left(LTrim(e), 3)
    
90. 
    
91.     If t = "GBT" Then
    
92. 
    
93.         e = "GB/T" + Mid(k, 4)
    
94.     Else
    
95. 
    
96.         e = k
    
97. 
    
98.     End If '以上取图号完成
    
99.    
    
100.     b = Mid(c, a + 2) '得到（版本+名称+后缀名）
     
101. 
     
102.     t = Right(c, 7) '取后缀名，并进行判断
     
103. 
     
104.     If t = ".SLDPRT" Or t = ".SLDASM" Then
     
105. 
     
106.         j = Len(b) - 7
     
107. 
     
108.     Else
     
109. 
     
110.         j = Len(b)
     
111. 
     
112.     End If
     
113. 
     
114.     m = Left(b, j)
     
115.    
     
116.    
     
117.     banben = Left(m, 1)
     
118.     mingcheng = Mid(m, 3)
     
119. 
     
120. End If
     
121. 
     
122. 
     
123. blnretval = Part.AddCustomInfo3("", "文件名", swCustomInfoText, c)  '文件名
     
124. 
     
125. blnretval = Part.AddCustomInfo3("", "代号", swCustomInfoText, e)  '代号
     
126. 
     
127. blnretval = Part.AddCustomInfo3("", "版本", swCustomInfoText, banben)  '版本
     
128. 
     
129. blnretval = Part.AddCustomInfo3("", "名称", swCustomInfoText, mingcheng)  '名称
     
130. 
     
131. blnretval = Part.AddCustomInfo3("", "设计", swCustomInfoText, " ") '填写设计者名字
     
132. 
     
133. blnretval = Part.AddCustomInfo3("", "审核", swCustomInfoText, " ")  '填写审核人名字
     
134. 
     
135. blnretval = Part.AddCustomInfo3("", "工艺", swCustomInfoText, " ") '填写工艺人名字
     
136. 
     
137. 'blnretval = Part.AddCustomInfo3("", "材料", swCustomInfoText, strmat)
     
138. 
     
139. 'blnretval = Part.AddCustomInfo3("", "表面处理", swCustomInfoText, " ")
     
140. 
     
141. End Sub
     

'从这里开始复制:<br /> <br /> '定义solidwork<br /> <br /> Dim swApp As Object<br /> <br /> Dim Part As Object<br /> <br /> Dim SelMgr As Object<br /> <br /> Dim boolstatus As Boolean<br /> <br /> Dim longstatus As Long, longwarnings As Long<br /> <br /> Dim Feature As Object<br /> <br /> Dim a As Integer<br /> <br /> Dim b As String<br /> <br /> Dim m As String<br /> <br /> Dim e As String<br /> <br /> Dim k As String<br /> <br /> Dim t As String<br /> <br /> Dim c As String<br /> <br /> Dim j As Integer<br /> <br /> Dim strmat As String<br /> <br /> Dim tempvalue As String<br /> <br /> '增加n个新变量<br /> <br /> Dim cailiao As String<br /> Dim banben As String<br /> Dim mingcheng As String<br /> <br /> Sub main()<br /> <br /> 'link solidworks<br /> <br /> Set swApp = Application.SldWorks<br /> <br /> Set Part = swApp.ActiveDoc<br /> <br /> Set SelMgr = Part.SelectionManager<br /> <br /> swApp.ActiveDoc.ActiveView.FrameState = 1<br /> <br /> '设定变量<br /> <br /> c = swApp.ActiveDoc.GetTitle() '文件名<br /> <br /> 'cailiao = swApp.ActiveDoc.GetMaterial()<br /> <br /> strmat = Chr(34) + Trim("SW-Material" + "@") + c + Chr(34) '获取材料表达式<br /> <br /> '定义各自定义属性<br /> <br /> blnretval = Part.DeleteCustomInfo2("", "文件名")<br /> <br /> blnretval = Part.DeleteCustomInfo2("", "代号")<br /> <br /> blnretval = Part.DeleteCustomInfo2("", "版本")<br /> <br /> blnretval = Part.DeleteCustomInfo2("", "名称")<br /> <br /> blnretval = Part.DeleteCustomInfo2("", "设计")<br /> <br /> blnretval = Part.DeleteCustomInfo2("", "审核")<br /> <br /> blnretval = Part.DeleteCustomInfo2("", "工艺")<br /> <br /> 'blnretval = Part.DeleteCustomInfo2("", "材料")<br /> <br /> 'blnretval = Part.DeleteCustomInfo2("", "表面处理")<br /> <br /> a = InStr(c, " ") - 1      '重点：分隔标识符，这里是一个空格<br /> <br /> If a > 0 Then<br /> <br />     k = Left(c, a)<br /> <br />     t = Left(LTrim(e), 3)<br /> <br />     If t = "GBT" Then<br /> <br />         e = "GB/T" + Mid(k, 4)<br />     Else<br /> <br />         e = k<br /> <br />     End If '以上取图号完成<br />     <br />     b = Mid(c, a + 2) '得到（版本+名称+后缀名）<br /> <br />     t = Right(c, 7) '取后缀名，并进行判断<br /> <br />     If t = ".SLDPRT" Or t = ".SLDASM" Then<br /> <br />         j = Len(b) - 7<br /> <br />     Else<br /> <br />         j = Len(b)<br /> <br />     End If<br /> <br />     m = Left(b, j)<br />     <br />    <br />     banben = Left(m, 1)<br />     mingcheng = Mid(m, 3)<br /> <br /> End If<br /> <br /> <br /> blnretval = Part.AddCustomInfo3("", "文件名", swCustomInfoText, c)  '文件名<br /> <br /> blnretval = Part.AddCustomInfo3("", "代号", swCustomInfoText, e)  '代号<br /> <br /> blnretval = Part.AddCustomInfo3("", "版本", swCustomInfoText, banben)  '版本<br /> <br /> blnretval = Part.AddCustomInfo3("", "名称", swCustomInfoText, mingcheng)  '名称<br /> <br /> blnretval = Part.AddCustomInfo3("", "设计", swCustomInfoText, " ") '填写设计者名字<br /> <br /> blnretval = Part.AddCustomInfo3("", "审核", swCustomInfoText, " ")  '填写审核人名字<br /> <br /> blnretval = Part.AddCustomInfo3("", "工艺", swCustomInfoText, " ") '填写工艺人名字<br /> <br /> 'blnretval = Part.AddCustomInfo3("", "材料", swCustomInfoText, strmat)<br /> <br /> 'blnretval = Part.AddCustomInfo3("", "表面处理", swCustomInfoText, " ")<br /> <br /> End Sub<br />

阡陌客

文件 >> 图形特性 >>  自定义属性

snddd2000

(setq doc (vla-get-activeDocument (vlax-get-acad-object)))
(setq info (vla-get-SummaryInfo doc))
(vla-AddCustomInfo info "比例" "1:16")
;支持的方法:
;   AddCustomInfo (2)
;   GetCustomByIndex (3)
;   GetCustomByKey (2)
;   NumCustomInfo ()
;   RemoveCustomByIndex (1)
;   RemoveCustomByKey (1)
;   SetCustomByIndex (3)
;   SetCustomByKey (2)

Gu_xl

1. (defun c:tt ()
   
2.   (setq        dwgname        (getvar 'dwgname)
   
3.         n        (VL-STRING-SEARCH "." dwgname)
   
4.         dwgname        (substr dwgname 1 n)
   
5.         n        (VL-STRING-SEARCH " " dwgname)
   
6.         th        (substr dwgname 1 n)
   
7.         n        (+ n 2)
   
8.         dwgname        (substr dwgname n)
   
9.         n        (VL-STRING-SEARCH " " dwgname)
   
10.         bb        (substr dwgname 1 n)
    
11.         mc        (substr dwgname (+ 2 n))
    
12.   )
    
13.   (setq        SummaryInfo
    
14.          (vla-get-SummaryInfo
    
15.            (vla-get-ActiveDocument (vlax-get-acad-object))
    
16.          )
    
17.   ) ;_ 获取SummaryInfo对象
    
18.   (mapcar
    
19.     '(lambda (key newVal)
    
20.        (if (VL-CATCH-ALL-ERROR-P
    
21.              (VL-CATCH-ALL-APPLY
    
22.                'vla-GetCustomByKey
    
23.                (list
    
24.                  SummaryInfo
    
25.                  key
    
26.                  'val
    
27.                )
    
28.              )
    
29.            )
    
30.          (VL-CATCH-ALL-APPLY
    
31.            'vla-AddCustomInfo
    
32.            (list
    
33.              SummaryInfo
    
34.              key
    
35.              newVal
    
36.            )
    
37.          )
    
38.          (VL-CATCH-ALL-APPLY
    
39.            'vla-SetCustomByKey
    
40.            (list
    
41.              SummaryInfo
    
42.              key
    
43.              newVal
    
44.            )
    
45.          )
    
46.        )
    
47.      )
    
48.     (list "图号" "版本" "名称")
    
49.     (list th bb mc)
    
50.   )
    
51.   (princ)
    
52. )

(defun c:tt ()<br />   (setq        dwgname        (getvar 'dwgname)<br />         n        (VL-STRING-SEARCH "." dwgname)<br />         dwgname        (substr dwgname 1 n)<br />         n        (VL-STRING-SEARCH " " dwgname)<br />         th        (substr dwgname 1 n)<br />         n        (+ n 2)<br />         dwgname        (substr dwgname n)<br />         n        (VL-STRING-SEARCH " " dwgname)<br />         bb        (substr dwgname 1 n)<br />         mc        (substr dwgname (+ 2 n))<br />   )<br />   (setq        SummaryInfo<br />          (vla-get-SummaryInfo<br />            (vla-get-ActiveDocument (vlax-get-acad-object))<br />          )<br />   ) ;_ 获取SummaryInfo对象<br />   (mapcar<br />     '(lambda (key newVal)<br />        (if (VL-CATCH-ALL-ERROR-P<br />              (VL-CATCH-ALL-APPLY<br />                'vla-GetCustomByKey<br />                (list<br />                  SummaryInfo<br />                  key<br />                  'val<br />                )<br />              )<br />            )<br />          (VL-CATCH-ALL-APPLY<br />            'vla-AddCustomInfo<br />            (list<br />              SummaryInfo<br />              key<br />              newVal<br />            )<br />          )<br />          (VL-CATCH-ALL-APPLY<br />            'vla-SetCustomByKey<br />            (list<br />              SummaryInfo<br />              key<br />              newVal<br />            )<br />          )<br />        )<br />      )<br />     (list "图号" "版本" "名称")<br />     (list th bb mc)<br />   )<br />   (princ)<br /> )

阡陌客

楼上的斑竹 太厉害了，请允许我膜拜一下

阡陌客

我没找到怎么把 [未解决]红字   改成[已解决]的绿字的办法，请斑竹帮忙操作一下，感谢！

zhangcan0515

谢谢老师分享

jiang__jin

的确是非常厉害啊

20060510412

第一次接触自定义属性这个概念。
主要用途是什么呢？