solidworks 批量执行宏

knight3732449

观摩一下

受伤的仙人球

有个使用场景，现在我使用的图号分离宏需要打开零件才能进行属性修改，每次在装配体里多修改几个零件名称或者新做零件就会忘了改属性，如果可以批量打开零件，然后中间插入执行图号分离宏的工具执行，就可以自动帮我一次性修改零件属性了（但是俺不会写，有没有大佬帮帮忙呜呜呜）

kbisi

Dim swApp As Object
Dim Part As Object
  f) X, w) w/ a; _, hDim sldPath As String

Dim boolstatus As Boolean
) y; |8 K6 ^* L4 E6 TDim longstatus As Long, longwarnings As Long
1 W; `" s, R% j$ c$ m+ @
( C6 G8 x+ ?1 ~


, F" `. K( y& y3 g+ D# @' cSub Test()
Set swApp = Application.SldWorks
9 u7 r* l  z/ a/ _- EsldPath = "C:\Users\kbisi\Desktop\实验\" '设定目录

3 _. q0 V6 x9 e# Z  Z( bswFileName = Dir(sldPath & "*.sld*")  '搜寻首个零件档案名称
If UCase(Right(swFileName, 3)) = "PRT" Then swFileTYpe = 1
If UCase(Right(swFileName, 3)) = "ASM" Then swFileTYpe = 2
1 G9 j8 u* T: V' x# r( \9 `
* L; S' y; @9 D( w" U# NDo While swFileName <> ""
- v& ~3 E! b* m( f+ x* j* [
( G) ~+ X6 |& |Set swApp = Application.SldWorks
# q0 W+ B+ I7 w) H  C( }' L7 V
'Set swDoc = swApp.OpenDoc(sldPath & swFileName, swFileTYpe) '开启零件

Set swModel = swApp.OpenDoc6(sldPath & swFileName, swFileTYpe, swOpenDocOptions_Silent, "", longstatus, longwarnings)
% K7 W( r* o0 `" r1 U" W) C5 s* p4 r. R


) [/ y( q* M) G$ I5 y
7 M% S. n: H/ {8 _
, I1 x1 `2 ~7 S+ @3 A# W; }Set Part = swApp.ActiveDoc

& P7 ]0 O- A) H' DCall plmain

: d% A; I* Z6 D" s  M
'
$ y% y1 B- z+ a
& j+ I4 c$ F9 ]

Part.Save '保存%
swApp.CloseDoc (swFileName) '关闭零件

If swFileName = "" Then Exit Do
% Y7 a2 Z# Z; x. a7 w. Z
, [6 \# ~6 H$ F% W- k9 P, Y
swFileName = Dir '搜寻下一个零件档案名称0
2 R. Q' V4 f. G# @6 V1 P3 f
Loop '循环搜寻
4 P2 }) N! R9 k  bEnd Sub
( U% H+ S5 L) d8 I+ k: E, l% @按F8一行看程序错误为什么老是跳过Then swFileTYpe = 2

kbisi

Dim swApp As Object
Dim Part As Object
Dim sldPath As String

Dim boolstatus As Boolean
7 k4 c6 D# P" s$ m) m& TDim longstatus As Long, longwarnings As Long
. ^( I) n! \- t6 {; X* z  z
. z. n7 `% a$ Y# h' y1 H: D( r


4 g) P' @9 X/ g. [# t* g# `Sub Test()
2 L/ N1 g4 P1 kSet swApp = Application.SldWorks
sldPath = "C:\Users\kbisi\Desktop\实验\" '设定目录
) _& M; K7 l* z7 T9 q
swFileName = Dir(sldPath & "*.sld*")  '搜寻首个零件档案名称
If UCase(Right(swFileName, 3)) = "PRT" Then swFileTYpe = 1
If UCase(Right(swFileName, 3)) = "ASM" Then swFileTYpe = 2

Do While swFileName <> ""

2 I8 y0 G$ R6 r) N- XSet swApp = Application.SldWorks

7 v( X& v7 {% @; K% c" ]'Set swDoc = swApp.OpenDoc(sldPath & swFileName, swFileTYpe) '开启零件

. q" f" N1 J3 d" o0 I5 O0 ^& LSet swModel = swApp.OpenDoc6(sldPath & swFileName, swFileTYpe, swOpenDocOptions_Silent, "", longstatus, longwarnings)
) A3 `5 y/ ]8 D; O$ T- V  ]+ i

( ]/ K6 ?9 f" S. Q8 j' G$ l
) e' ]- N8 d1 h! `0 S8 W0 k
* m9 v- T* ]1 j# M, e8 c
6 n! E6 Q5 V$ h$ [2 A5 nSet Part = swApp.ActiveDoc

3 c) D& z. e* V# K( mCall plmain
1 }# ~; C1 B& s, k% B  m( o/ f

2 H( l2 ~9 B% `5 @6 n4 P9 O( D'
4 i5 D( K% b  \+ R

: x& w8 b8 ^5 w! X* H
Part.Save '保存%
swApp.CloseDoc (swFileName) '关闭零件

+ B& {1 a4 h3 G6 x, G* K9 a2 NIf swFileName = "" Then Exit Do


swFileName = Dir '搜寻下一个零件档案名称0

# t! e7 c9 G& W8 {" p3 k4 HLoop '循环搜寻
! _; O/ s% S2 v  Z% g5 sEnd Sub

kbisi

Dim swApp As Object
7 O) Q) j* W8 B) @  p0 M. \Dim Part As Object
Dim sldPath As String
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long
2 ^5 J+ _! k# P8 R) n* DSub Test()
" A+ p" W( I4 R6 _Set swApp = Application.SldWorks
# d! o5 o  a9 Z+ L7 ssldPath = "C:\Users\kbisi\Desktop\实验\" '设定目录
6 e! n  h9 e2 D* l- lswFileName = Dir(sldPath & "*.sld*")  '搜寻首个零件档案名称
If UCase(Right(swFileName, 3)) = "PRT" Then swFileTYpe = 1
+ t7 {! Z( A4 \1 t2 K# HIf UCase(Right(swFileName, 3)) = "ASM" Then swFileTYpe = 2
Do While swFileName <> ""
Set swApp = Application.SldWorks
'Set swDoc = swApp.OpenDoc(sldPath & swFileName, swFileTYpe) '开启零件
Set swModel = swApp.OpenDoc6(sldPath & swFileName, swFileTYpe, swOpenDocOptions_Silent, "", longstatus, longwarnings)
3 ?; d. D4 N  Y/ JSet Part = swApp.ActiveDoc
3 E1 e/ M# T  l- X/ [Call plmain
Part.Save '保存%
swApp.CloseDoc (swFileName) '关闭零件
9 u5 \% j; j/ V+ ?( RIf swFileName = "" Then Exit Do
swFileName = Dir '搜寻下一个零件档案名称0
; t. U, m: |8 M8 ]% n$ I$ aLoop '循环搜寻
0 ?1 I5 Y7 U- a3 q, MEnd Sub   老是被跳过

kbisi

kbisi 发表于 2021-11-28 10:05
Dim swApp As Object
Dim Part As Object
Dim sldPath As String

" Z) V+ [: i, T/ f) z希望可以得到解答
" b' M% i; |; Z% Y2 a. y% U

kbisi

kbisi 发表于 2021-11-28 10:05
3 M% o9 ~3 G% A& ADim swApp As Object
Dim Part As Object
Dim sldPath As String

和楼主一样打不开装配体
) o( p7 U" {1 j3 y

357755306b

多少积分可以分享

xinshiji666

kbisi 发表于 2021-11-28 13:44
8 r5 r$ t& f" X; B3 J+ ?" E, y希望可以得到解答

无法打开装配体文件，是因为你把文件类型判定的语句放在循环外了，挪到do...loop内即可，那个call语句调用了什么？用不上可以先屏蔽。
经过测试，下面的程序可正常打开零件和装配体
' L6 M; X8 ]( j  V6 _0 H* y# ~
5 E) P* k+ k3 z, j' ******************************************************************************
4 e. E  P# i, a$ L% N' 读取指定目录下的Prt/asm文件，关闭
' ******************************************************************************
Dim swApp As Object
" o2 R1 c5 ^4 b6 f6 m# p# w
- |. I) B/ C' o' [( F2 c* A( tDim Part As Object
Dim boolstatus As Boolean
% L; j; ~- G$ k+ T% s/ n3 A# W$ hDim longstatus As Long, longwarnings As Long
'Dim sldPath As String
Const sldPath As String = "E:\3Dtest\BOM1\"  '设定目录

, a+ i! z! @- zSub main()
( N6 O0 e; ?" U
% e$ m+ E2 m; ^: b) \    Set swApp = _
    Application.SldWorks
    Set Part = swApp.ActiveDoc
# g4 h( [) ~% Z& j0 o: ^        
8 J$ o- l9 r- [5 w- v    swFileName = Dir(sldPath & "*.sld*")
3 H1 B- y+ n5 G: b
    Do While swFileName <> ""
/ T/ Y" z: p3 O; Y9 {+ C        Set swApp = Application.SldWorks
        If UCase(Right(swFileName, 3)) = "PRT" Then swFileTYpe = 1
- i. j* V' z; \+ s4 ^' F: g* |        If UCase(Right(swFileName, 3)) = "ASM" Then swFileTYpe = 2
( i  R/ L( u6 K  L3 X+ _" U
        Set swModel = swApp.OpenDoc6(sldPath & swFileName, swFileTYpe, swOpenDocOptions_Silent, "", longstatus, longwarnings)
4 P, C8 Y+ u1 q6 L5 S! B( W, l        Set Part = swApp.ActiveDoc
- h9 G/ x+ x2 q* U# r% d4 {        'Call plmain
        'Part.Save '保存
        swApp.CloseDoc (swFileName) '关闭零件
        If swFileName = "" Then Exit Do:
, Z2 H, j6 z- G        swFileName = Dir '搜寻下一个零件档案名称
# f( l; m! V, T! G' S    Loop '循环搜寻

End Sub


0 E- @! H. B0 _1 a8 \, R5 [

Ali.

能提供你成功运行的一个代打为参考吗我的一直报错
1 k3 w: R2 H% |" e' V8 ~% ?' a