SOLIDWORKS 宏合并执行的问题

赵龙腾

   经典图书

[table][td]是这样的，想做一个宏，通过这个宏，会先后调用其它的宏，请问如何编写？非常感谢。
宏的名称分别是：
删除所有配置属性.swp
删除自定义属性.swp
partitionTM.swp

朱统帅

參考


Sub 删除所有配置属性()
   .
   .
   .
   Call 删除自定义属性 '呼叫 "删除自定义属性" 之宏
   .
   .
End Sub


Sub 删除自定义属性()
   .
   .
End Sub

狼懒钱空

   经典图书

非常感谢您的指点，根据我的浅薄理解，我的宏如下，但不起作用：
' ******************************************************************************
' C:UsersadminAppDataLocalTempswx10500Macro1.swb - macro recorded on 11/24/18 by arter
' ******************************************************************************
Dim swApp As Object

Dim Part As Object
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long
Sub 删除所有配置属性()



    Call 删除自定义属性


End Sub

Sub 删除自定义属性()



   Call partitionTM


End Sub

Sub partitionTM()


End Sub

能否帮我改下？非常感谢。

cl880302

不知道3个宏有没有问题，这三个宏单独执行的是没问题的。上面提到的，就是想把附件压缩包里的三个宏联合执行。

kingboysen

   经典案例图书

    [Run main() 試試!]

• ' ******************************************************************************
  
• ' C:UsersadminAppDataLocalTempswx8144Macro1.swb - macro recorded on 11/22/18 by mqlu
  
• ' ******************************************************************************
  
• Dim swApp As Object
  
• Dim Part As Object
  
• Dim boolstatus As Boolean
  
• Dim longstatus As Long, longwarnings As Long
  
• 
  
• Dim SelMgr As Object
  
• Dim Feature As Object
  
• Dim a As Integer
  
• Dim b As String
  
• Dim m As String
  
• Dim e As String
  
• Dim k As String
  
• Dim t As String
  
• Dim c As String
  
• Dim j As Integer
  
• Dim strmat As String
  
• Dim tempvalue As String
  
• 
  
• Sub main() '刉壺垀衄饜离扽俶(刪除所有配置屬性)
  
• Set swApp = Application.SldWorks
  
• Set Part = swApp.ActiveDoc
  
• CurCFGname = Part.GetConfigurationNames
  
• CurCFGnameCount = Part.GetConfigurationCount
  
• For i = 0 To CurCFGnameCount - 1
  
•     Set CusPropMgr = Part.Extension.CustomPropertyManager(CurCFGname(i))
  
•     Vnamearr = CusPropMgr.GetNames
  
•     If Not IsEmpty(Vnamearr) Then
  
•         For Each Vnamearr2 In Vnamearr
  
•             bRet = Part.DeleteCustomInfo2(CurCFGname(i), Vnamearr2)
  
•         Next
  
•     End If
  
• Next
  
• Call 刉壺赻隅砱扽俶 '(刪除自定義屬性)
  
• Call partitionTM
  
• 
  
• End Sub
  
• 
  
• '~~~ 刉壺赻隅砱扽俶 ~~~
  
• Sub 刉壺赻隅砱扽俶() '(刪除自定義屬性)
  
• 'Dim swApp As Object
  
• Dim swModel2 As SldWorks.ModelDoc2
  
• Dim vCustInfoNameArr2 As Variant
  
• 
  
• Set swApp = Application.SldWorks
  
• Set swModel2 = swApp.ActiveDoc
  
• vCustInfoNameArr2 = swModel2.GetCustomInfoNames
  
•   If Not IsEmpty(vCustInfoNameArr2) Then
  
•      For Each vCustInfoName2 In vCustInfoNameArr2
  
•          bRet = swModel2.DeleteCustomInfo(vCustInfoName2)
  
•       Next
  
•   End If
  
• End Sub
  
• 
  
• '~~~ partitionTM ~~~
  
• Sub partitionTM() 'partitionTM
  
• 
  
• 'link solidworks
  
• Set swApp = Application.SldWorks
  
• Set Part = swApp.ActiveDoc
  
• Set SelMgr = Part.SelectionManager
  
• swApp.ActiveDoc.ActiveView.FrameState = 1
  
• '扢隅曹講
  
• c = swApp.ActiveDoc.GetTitle() '錨璃靡
  
• strmat = Chr(34) + Trim("SW-Material" + "@") + c + Chr(34)
  
• 'tempvalue = Part.CustomInfo2("", "第蹋")
  
• blnretval = Part.DeleteCustomInfo2("", "測瘍")
  
• blnretval = Part.DeleteCustomInfo2("", "靡備")
  
• blnretval = Part.DeleteCustomInfo2("", "第蹋")
  
• a = InStr(c, " ") - 1
  
• If a > 0 Then
  
•     k = Left(c, a)
  
•     t = Left(LTrim(e), 3)
  
•     If t = "GBT" Then
  
•         e = "GB/T" + Mid(k, 4)
  
•     Else
  
•         e = k
  
•     End If
  
•     b = Mid(c, a + 2)
  
•     t = Right(c, 7)
  
•     If t = ".SLDPRT" Or t = ".SLDASM" Then
  
•         j = Len(b) - 7
  
•     Else
  
•         j = Len(b)
  
•     End If
  
•     m = Left(b, j)
  
• End If
  
• blnretval = Part.AddCustomInfo3("", "測瘍", swCustomInfoText, e)
  
• blnretval = Part.AddCustomInfo3("", "靡備", swCustomInfoText, m)
  
• blnretval = Part.AddCustomInfo3("", "第蹋", swCustomInfoText, strmat)
  
• blnretval = Part.AddCustomInfo3("", "等笭", swCustomInfoText, " ")
  
• blnretval = Part.AddCustomInfo3("", "掘蛁", swCustomInfoText, " ")
  
• 
  
• End Sub
  

复制代码

蔡J

能否把您改后的swp文件上传上来？
非常感谢您的指点，上面的内容从网页上复制、黏贴到写字板或宏文件里后，都是乱码，执行不了，非常感谢您，让您费心了。

莱杰

   经典案例图书

w4896110

在原来的基础上改会方便一些。

fx910827

以下是我改过的宏，不知道哪里出了问题？附件压缩包是写字板格式的。
' ******************************************************************************
' C:UsersadminAppDataLocalTempswx8144Macro1.swb - macro recorded on 11/22/18 by mqlu
' ******************************************************************************
Dim swApp As Object
Dim Part As Object
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long

Dim SelMgr As Object
Dim Feature As Object
Dim a As Integer
Dim b As String
Dim m As String
Dim e As String
Dim k As String
Dim t As String
Dim c As String
Dim j As Integer
Dim strmat As String
Dim tempvalue As String

Sub main() '刪除所有配置屬性
Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
CurCFGname = Part.GetConfigurationNames)
CurCFGnameCount = Part.GetConfigurationCount
For i = 0 To CurCFGnameCount - 1
    Set CusPropMgr = Part.Extension.CustomPropertyManager(CurCFGname(i))
    Vnamearr = CusPropMgr.GetNames
    If Not IsEmpty(Vnamearr) Then
        For Each Vnamearr2 In Vnamearr
            bRet = Part.DeleteCustomInfo2(CurCFGname(i), Vnamearr2)
        Next
    End If
Next
Call 刪除自定義屬性
Call partitionTM

End Sub

'~~~ 刪除自定義屬性 ~~~
Sub  '刪除自定義屬性
'Dim swApp As Object
Dim swModel2 As SldWorks.ModelDoc2
Dim vCustInfoNameArr2 As Variant

Set swApp = Application.SldWorks
Set swModel2 = swApp.ActiveDoc
vCustInfoNameArr2 = swModel2.GetCustomInfoNames
  If Not IsEmpty(vCustInfoNameArr2) Then
     For Each vCustInfoName2 In vCustInfoNameArr2
         bRet = swModel2.DeleteCustomInfo(vCustInfoName2)
      Next
  End If
End Sub

'~~~ partitionTM ~~~
Sub partitionTM() 'partitionTM

'link solidworks
Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
Set SelMgr = Part.SelectionManager
swApp.ActiveDoc.ActiveView.FrameState = 1
'扢隅曹講
c = swApp.ActiveDoc.GetTitle() '錨璃靡
strmat = Chr(34) + Trim("SW-Material" + "@") + c + Chr(34)
'tempvalue = Part.CustomInfo2("", "第蹋")
blnretval = Part.DeleteCustomInfo2("", "測瘍")
blnretval = Part.DeleteCustomInfo2("", "靡備")
blnretval = Part.DeleteCustomInfo2("", "第蹋")
a = InStr(c, " ") - 1
If a > 0 Then
    k = Left(c, a)
    t = Left(LTrim(e), 3)
    If t = "GBT" Then
        e = "GB/T" + Mid(k, 4)
    Else
        e = k
    End If'
    b = Mid(c, a + 2)
    t = Right(c, 7)
    If t = ".SLDPRT" Or t = ".SLDASM" Then
        j = Len(b) - 7
    Else
        j = Len(b)
    End If
    m = Left(b, j)
End If
blnretval = Part.AddCustomInfo3("", "測瘍", swCustomInfoText, e)
blnretval = Part.AddCustomInfo3("", "靡備", swCustomInfoText, m)
blnretval = Part.AddCustomInfo3("", "第蹋", swCustomInfoText, strmat)
blnretval = Part.AddCustomInfo3("", "等笭", swCustomInfoText, " ")
blnretval = Part.AddCustomInfo3("", "掘蛁", swCustomInfoText, " ")

End Sub

ntnol

   经典图书

family科技之家

就是如下的繁体字改為簡体字就是

• ' ******************************************************************************
  
• ' C:UsersadminAppDataLocalTempswx8144Macro1.swb - macro recorded on 11/22/18 by mqlu
  
• ' ******************************************************************************
  
• Dim swApp As Object
  
• Dim Part As Object
  
• Dim boolstatus As Boolean
  
• Dim longstatus As Long, longwarnings As Long
  
• 
  
• Dim SelMgr As Object
  
• Dim Feature As Object
  
• Dim a As Integer
  
• Dim b As String
  
• Dim m As String
  
• Dim e As String
  
• Dim k As String
  
• Dim t As String
  
• Dim c As String
  
• Dim j As Integer
  
• Dim strmat As String
  
• Dim tempvalue As String
  
• 
  
• Sub main() '刪除所有配置屬性
  
• Set swApp = Application.SldWorks
  
• Set Part = swApp.ActiveDoc
  
• CurCFGname = Part.GetConfigurationNames
  
• CurCFGnameCount = Part.GetConfigurationCount
  
• For i = 0 To CurCFGnameCount - 1
  
•     Set CusPropMgr = Part.Extension.CustomPropertyManager(CurCFGname(i))
  
•     Vnamearr = CusPropMgr.GetNames
  
•     If Not IsEmpty(Vnamearr) Then
  
•         For Each Vnamearr2 In Vnamearr
  
•             bRet = Part.DeleteCustomInfo2(CurCFGname(i), Vnamearr2)
  
•         Next
  
•     End If
  
• Next
  
• Call 刪除自定義屬性
  
• Call partitionTM
  
• 
  
• End Sub
  
• 
  
• '~~~ 刪除自定義屬性 ~~~
  
• Sub 刪除自定義屬性()
  
• 'Dim swApp As Object
  
• Dim swModel2 As SldWorks.ModelDoc2
  
• Dim vCustInfoNameArr2 As Variant
  
• 
  
• Set swApp = Application.SldWorks
  
• Set swModel2 = swApp.ActiveDoc
  
• vCustInfoNameArr2 = swModel2.GetCustomInfoNames
  
•   If Not IsEmpty(vCustInfoNameArr2) Then
  
•      For Each vCustInfoName2 In vCustInfoNameArr2
  
•          bRet = swModel2.DeleteCustomInfo(vCustInfoName2)
  
•       Next
  
•   End If
  
• End Sub
  
• 
  
• '~~~ partitionTM ~~~
  
• Sub partitionTM() 'partitionTM
  
• 
  
• 'link solidworks
  
• Set swApp = Application.SldWorks
  
• Set Part = swApp.ActiveDoc
  
• Set SelMgr = Part.SelectionManager
  
• swApp.ActiveDoc.ActiveView.FrameState = 1
  
• '設定變量
  
• c = swApp.ActiveDoc.GetTitle() '零件名
  
• strmat = Chr(34) + Trim("SW-Material" + "@") + c + Chr(34)
  
• 'tempvalue = Part.CustomInfo2("", "材料")
  
• blnretval = Part.DeleteCustomInfo2("", "代號")
  
• blnretval = Part.DeleteCustomInfo2("", "名稱")
  
• blnretval = Part.DeleteCustomInfo2("", "材料")
  
• a = InStr(c, " ") - 1
  
• If a > 0 Then
  
•     k = Left(c, a)
  
•     t = Left(LTrim(e), 3)
  
•     If t = "GBT" Then
  
•         e = "GB/T" + Mid(k, 4)
  
•     Else
  
•         e = k
  
•     End If
  
•     b = Mid(c, a + 2)
  
•     t = Right(c, 7)
  
•     If t = ".SLDPRT" Or t = ".SLDASM" Then
  
•         j = Len(b) - 7
  
•     Else
  
•         j = Len(b)
  
•     End If
  
•     m = Left(b, j)
  
• End If
  
• blnretval = Part.AddCustomInfo3("", "代號", swCustomInfoText, e)
  
• blnretval = Part.AddCustomInfo3("", "名稱", swCustomInfoText, m)
  
• blnretval = Part.AddCustomInfo3("", "材料", swCustomInfoText, strmat)
  
• blnretval = Part.AddCustomInfo3("", "單重", swCustomInfoText, " ")
  
• blnretval = Part.AddCustomInfo3("", "備註", swCustomInfoText, " ")
  
• End Sub
  

复制代码

nmgfxd

执行后无反应，属性都没改，不知道问题出在哪里？让您费心了。

' ******************************************************************************
' C:UsersadminAppDataLocalTempswx8144Macro1.swb - macro recorded on 11/22/18 by mqlu
' ******************************************************************************
Dim swApp As Object
Dim Part As Object
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long

Dim SelMgr As Object
Dim Feature As Object
Dim a As Integer
Dim b As String
Dim m As String
Dim e As String
Dim k As String
Dim t As String
Dim c As String
Dim j As Integer
Dim strmat As String
Dim tempvalue As String

Sub main() '刪除所有配置属性
Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
CurCFGname = Part.GetConfigurationNames
CurCFGnameCount = Part.GetConfigurationCount
For i = 0 To CurCFGnameCount - 1
    Set CusPropMgr = Part.Extension.CustomPropertyManager(CurCFGname(i))
    Vnamearr = CusPropMgr.GetNames
    If Not IsEmpty(Vnamearr) Then
        For Each Vnamearr2 In Vnamearr
            bRet = Part.DeleteCustomInfo2(CurCFGname(i), Vnamearr2)
        Next
    End If
Next
Call 刪除自定义属性
Call partitionTM

End Sub

'~~~ 刪除自定义属性 ~~~
Sub 刪除自定义属性()
'Dim swApp As Object
Dim swModel2 As SldWorks.ModelDoc2
Dim vCustInfoNameArr2 As Variant

Set swApp = Application.SldWorks
Set swModel2 = swApp.ActiveDoc
vCustInfoNameArr2 = swModel2.GetCustomInfoNames
  If Not IsEmpty(vCustInfoNameArr2) Then
     For Each vCustInfoName2 In vCustInfoNameArr2
         bRet = swModel2.DeleteCustomInfo(vCustInfoName2)
      Next
  End If
End Sub

'~~~ partitionTM ~~~
Sub partitionTM() 'partitionTM

'link solidworks
Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
Set SelMgr = Part.SelectionManager
swApp.ActiveDoc.ActiveView.FrameState = 1
'设定变量
c = swApp.ActiveDoc.GetTitle() '零件名
strmat = Chr(34) + Trim("SW-Material" + "@") + c + Chr(34)
'tempvalue = Part.CustomInfo2("", "材料")
blnretval = Part.DeleteCustomInfo2("", "代号")
blnretval = Part.DeleteCustomInfo2("", "名称")
blnretval = Part.DeleteCustomInfo2("", "材料")
a = InStr(c, " ") - 1
If a > 0 Then
    k = Left(c, a)
    t = Left(LTrim(e), 3)
    If t = "GBT" Then
        e = "GB/T" + Mid(k, 4)
    Else
        e = k
    End If
    b = Mid(c, a + 2)
    t = Right(c, 7)
    If t = ".SLDPRT" Or t = ".SLDASM" Then
        j = Len(b) - 7
    Else
        j = Len(b)
    End If
    m = Left(b, j)
End If
blnretval = Part.AddCustomInfo3("", "代号", swCustomInfoText, e)
blnretval = Part.AddCustomInfo3("", "名称", swCustomInfoText, m)
blnretval = Part.AddCustomInfo3("", "材料", swCustomInfoText, strmat)
blnretval = Part.AddCustomInfo3("", "单重", swCustomInfoText, " ")
blnretval = Part.AddCustomInfo3("", "备注", swCustomInfoText, " ")

End Sub

ilff99

sw2017 測試OK
有否顯示什麼錯誤提示?

天涯@远意

我的是Solidworks 2018，看来可能是版本的问题了

aa755936266

加入QQ群
参与讨论和学习

或扫描二维码加入

2018 沒版本能試

浪漫笔记

   经典案例图书

非常感谢您，让您费心了。

a81004

加入QQ群
参与讨论和学习

或扫描二维码加入

能否把您的SWP文件发上来，我刚才用solidworks 2014也试了一下，发现也不行，但是别的宏都可以。
我从网页上复制下来的都变成下面这个样子了，所以要删掉很多多出来的东西，我怀疑是不是这个原因导致的，但是校对很费时间，也难发现。

' ******************************************************************************3 3 X) J3 n, I6 @4 |0 x
' C:UsersadminAppDataLocalTempswx8144Macro1.swb - macro recorded on 11/22/18 by mqlu' a$ M. 3 S6 C, S! A1 C
' ******************************************************************************
: n% ( F) I, C+ j: _& m6 bDim swApp As Object
' e* i- B# F; m% [6 c9 t+  }Dim Part As Object! t9 ?1 q2 c' K2 l9 ^4 X" G
Dim boolstatus As Boolean- I8 s/ Y$ i' W. N0 _
Dim longstatus As Long, longwarnings As Long
1 W8 u' q( 3 d4 Y/ K1 v" N; D
3 J( R9 8 _3 m& ) d/ Dim SelMgr As Object
: S& D4 E8 I: d4 K4 q9 f0 e& f5 HDim Feature As Object
7 s$ z: N6 b! v  l! SDim a As Integer
& P" q% F6 [5 U$ N  F7 l5 _1 iDim b As String/ a) E' o9 v7 y0 L) H; T4 a/ J& Z% M
Dim m As String+ ?/ w( `) D: S9 x
Dim e As String" t" l1 k  K7 K8 U: @# s; `
Dim k As String* ?4 t9 u7 n+ _
Dim t As String
% R* ?6 C5 B( @3 D& DDim c As String
! K3 d. @4 X+ d/ Q. _. p: yDim j As Integer3 N( z+ v  K2 q* v6 D
Dim strmat As String
" F! d7 t6 p- DDim tempvalue As String
& E& r" D5 F  G0 |% Q: b, Y
- o) ?$ `2 a( G& L5 x7 Q- B3 Z( ISub main() '刪除所有配置屬性
; c8 H3 l/ z* n* R9 KSet swApp = Application.SldWorks9 g. p. p7 K6 u7 ?4 x4 W6 n
Set Part = swApp.ActiveDoc$ q6 |& ^2 b7 ~/ ]( ^0 R
CurCFGname = Part.GetConfigurationNames
- [5 v: x. U8 U( V* kCurCFGnameCount = Part.GetConfigurationCount
" c- O# J: c, c5 w7 Y0 T. i = 0 To CurCFGnameCount - 1& {$ V* E/ x+ ~. V
    Set CusPropMgr = Part.Extension.CustomPropertyManager(CurCFGname(i))
. G( J! L$ ?  c% B6 }    Vnamearr = CusPropMgr.GetNames4 B$ N4 Q* X) q- [; f8 r0 ^5 {
    If Not IsEmpty(Vnamearr) Then' t" n; u" h( T
        For Each Vnamearr2 In Vnamearr
- n8 t& |, B: B/ V9 S4 d, F7 Z            bRet = Part.DeleteCustomInfo2(CurCFGname(i), Vnamearr2)+ h. {$ P6 Q5 M: i
        Next- P& E; Z$ s7 V+ a( t' E% T
    End If
$ A3 @6 S" n' d2 eNext
  k" k4 f; K$ vCall 刪除自定義屬性
( A- x) f" C" d8 G6 }) {# {' iCall partitionTM4 }2 o$ e' E7 t

2 @8 q. ~" b  {% q" `4 h6 {End Sub
% e; G6 r) ]# @' p
" D7 r# [' m2 U5 Z7 k9 B. O: ?'~~~ 刪除自定義屬性 ~~~
: Q6 `! G2 u. ]" |4 i. ?Sub 刪除自定義屬性()
  B# r$ |5 d2 b. o4 x5 W" n+ J'Dim swApp As Object2 Q# s7 O1 ~+ I" }
Dim swModel2 As SldWorks.ModelDoc2
! f' g# o6 S, e, W4 z+ EDim vCustInfoNameArr2 As Variant7 J* i  U% A! t0  D! h, V

- K" x+ X- v- E% b! h6 i* p! ], |9 USet swApp = Application.SldWorks
4 S  i4 [' W6 ]0 I* U0 V' O' B+ NSet swModel2 = swApp.ActiveDoc3 u) Z+ D2 D4 z; M# d4 {
vCustInfoNameArr2 = swModel2.GetCustomInfoNames- N/ C9 m0 n2 t* k9 u
  If Not IsEmpty(vCustInfoNameArr2) Then
! V# Z5 s; g8 P9 J( v  m% Z     For Each vCustInfoName2 In vCustInfoNameArr2- % O7 w% [: r; T3 |5 M
         bRet = swModel2.DeleteCustomInfo(vCustInfoName2)
. ?" R/ r# I! y' x7 _' X      Next9 U+ R% V2 G# P
  End If
& V, L( M& Q4 l& b0 TEnd Sub
6 M- K7 `: z' w) T+ c$ V; G
/ j9 |  ?( U5 a+ K'~~~ partitionTM ~~~7 O3 t. l4 R1 [+ ]3 K  G+ M
Sub partitionTM() 'partitionTM( j# ]! b. Q, G0 M9 E4 f8 B2 J
% l; E) x# ~4 [& t0 {8 [
'link solidworks( C, c- [# N+ Z* [
Set swApp = Application.SldWorks+ w1 D3 {4 b7 ^# i5 p4 ~2 p
Set Part = swApp.ActiveDoc
) k" c8 Y, z+ b# A0 `9 OSet SelMgr = Part.SelectionManager% m# Z: n! Q: I/ M* d( j' c
swApp.ActiveDoc.ActiveView.FrameState = 1& ?6 I  _. Y+ 4 m7 P" c% W/ h
'設定變量& }. N& d* J$ W) S
c = swApp.ActiveDoc.GetTitle() '零件名
. {8 L5 ~" z0 y# g! I" Estrmat = Chr(34) + Trim("SW-Material" + "@") + c + Chr(34). w+ f3 v( W- `* D! G! v. z
'tempvalue = Part.CustomInfo2("", "材料")
& U; y& P! d9 n  V  X0 H+ J1 Yblnretval = Part.DeleteCustomInfo2("", "代號")3 w1 A4 Q. Z1 , x1 N/ e; R
blnretval = Part.DeleteCustomInfo2("", "名稱"). }" r" K0 E! E
blnretval = Part.DeleteCustomInfo2("", "材料")
+ U) d- F; R- ]4 V0 e- k2 J; Sa = InStr(c, " ") - 1
" v0 S% D. r) K$ `' iIf a > 0 Then
0 D& _% k+ M" K3 ~    k = Left(c, a)0 D( T  G4 u* @' Z: h# g5 h) k
    t = Left(LTrim(e), 3)0 |: d+ H% K1 I5 d; ^& r
    If t = "GBT" Then0 a: k4 H  }1 j) y
        e = "GB/T" + Mid(k, 4)0 C& x4 F4 D' ], i* s8 T
    Else
! W2 i7 C- b( f1 H* X4 B; P        e = k& O7 M7 ]$ E: v$ n5 ]  ?0 p$ z
    End If! C- h9 R! k; n% D6 G+ S; P
    b = Mid(c, a + 2)
1 a, _" o% b/ ^0 j8 S  T    t = Right(c, 7)
( H6 S2 ?' U+ d5 X" f: a    If t = ".SLDPRT" Or t = ".SLDASM" Then
( m# n+ r. ]5 p& Q/ I! e        j = Len(b) - 7: f; _- _+ L% W8 E) q2 `; Z9 B'
    Else& f9 y# D- W/ Y! i& w- H
        j = Len(b); J( ?# E, |  ?
    End If8 @/ x5 s, N; . _& V# V
    m = Left(b, j)
. P: e' A' P) l4 b& End If( o3 u- a' n" g; c4 t2 s& ]
blnretval = Part.AddCustomInfo3("", "代號", swCustomInfoText, e)
: F  K  N' M% L5 C4 Hblnretval = Part.AddCustomInfo3("", "名稱", swCustomInfoText, m)7 a/ m( J8 q$ B) ^& B( M# Q' V
blnretval = Part.AddCustomInfo3("", "材料", swCustomInfoText, strmat)
9 Z0 O2 e0 Q6 cblnretval = Part.AddCustomInfo3("", "單重", swCustomInfoText, " ")
  V; G2 e# V. L; H; {2 wblnretval = Part.AddCustomInfo3("", "備註", swCustomInfoText, " ")
: i2 D6 }7 z- @1 t: i# Q, P, {! f% c" J- {6 u; t
End Sub

bms2008

   经典案例图书

附swp繁体版   

scysa

試試把   CurCFGname = swApp.GetConfigurationNames

改為      CurCFGname = swApp.GetConfigurationNames(swApp.ActiveDoc.GetPathName) '補加零件文件的路徑及名稱

在沒補加 (swApp.ActiveDoc.GetPathName) 時在2012及2015版是會有提示錯誤的(如附图)
另VBA編程在   " '  " 符號后的文字是會跳過不執行的.

1197806538

我试过了，改之前，改之后一个样，而且执行中没有任何错误提示。
' ******************************************************************************
' C:UsersadminAppDataLocalTempswx8144Macro1.swb - macro recorded on 11/22/18 by mqlu
' ******************************************************************************
Dim swApp As Object
Dim Part As Object
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long

Dim SelMgr As Object
Dim Feature As Object
Dim a As Integer
Dim b As String
Dim m As String
Dim e As String
Dim k As String
Dim t As String
Dim c As String
Dim j As Integer
Dim strmat As String
Dim tempvalue As String

Sub main() '刪除所有配置属性
Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
CurCFGname = swApp.GetConfigurationNames(swApp.ActiveDoc.GetPathName) '补加零件文件的路径及名称
CurCFGnameCount = Part.GetConfigurationCount
For i = 0 To CurCFGnameCount - 1
    Set CusPropMgr = Part.Extension.CustomPropertyManager(CurCFGname(i))
    Vnamearr = CusPropMgr.GetNames
    If Not IsEmpty(Vnamearr) Then
        For Each Vnamearr2 In Vnamearr
            bRet = Part.DeleteCustomInfo2(CurCFGname(i), Vnamearr2)
        Next
    End If
Next
Call 刪除自定义属性
Call partitionTM

End Sub

'~~~ 刪除自定义属性 ~~~
Sub 刪除自定义属性()
'Dim swApp As Object
Dim swModel2 As SldWorks.ModelDoc2
Dim vCustInfoNameArr2 As Variant

Set swApp = Application.SldWorks
Set swModel2 = swApp.ActiveDoc
vCustInfoNameArr2 = swModel2.GetCustomInfoNames
  If Not IsEmpty(vCustInfoNameArr2) Then
     For Each vCustInfoName2 In vCustInfoNameArr2
         bRet = swModel2.DeleteCustomInfo(vCustInfoName2)
      Next
  End If
End Sub

'~~~ partitionTM ~~~
Sub partitionTM() 'partitionTM

'link solidworks
Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
Set SelMgr = Part.SelectionManager
swApp.ActiveDoc.ActiveView.FrameState = 1
'设定变量
c = swApp.ActiveDoc.GetTitle() '零件名
strmat = Chr(34) + Trim("SW-Material" + "@") + c + Chr(34)
'tempvalue = Part.CustomInfo2("", "材料")
blnretval = Part.DeleteCustomInfo2("", "代号")
blnretval = Part.DeleteCustomInfo2("", "名称")
blnretval = Part.DeleteCustomInfo2("", "材料")


a = InStr(c, " ") - 1
If a > 0 Then
    k = Left(c, a)
    t = Left(LTrim(e), 3)

    If t = "GBT" Then
        e = "GB/T" + Mid(k, 4)
    Else
        e = k
    End If

    b = Mid(c, a + 2)
    t = Right(c, 7)
    If t = ".SLDPRT" Or t = ".SLDASM" Then
        j = Len(b) - 7
    Else
        j = Len(b)
    End If
    m = Left(b, j)
End If

blnretval = Part.AddCustomInfo3("", "代号", swCustomInfoText, e)
blnretval = Part.AddCustomInfo3("", "名称", swCustomInfoText, m)
blnretval = Part.AddCustomInfo3("", "材料", swCustomInfoText, strmat)
blnretval = Part.AddCustomInfo3("", "单重", swCustomInfoText, " ")
blnretval = Part.AddCustomInfo3("", "备注", swCustomInfoText, " ")

End Sub