excel VBA 批量更改solidworks 属性的问题

xiaoxifeng · 发表于 2017-3-30 15:18:45

马上注册，结识高手，享用更多资源，轻松玩转三维网社区。

您需要登录才可以下载或查看，没有帐号？注册

x

本帖最后由 xiaoxifeng 于 2017-3-30 15:19 编辑

现在的问题是：在下面的代码的空白处加什么代码。可以达到图片的效果。就是在打开装配体的时候，自动遍历装配下的零件和数量并自动缩进

Dim swDM As SwDMApplication
7 Q. ?* h/ z4 L. N/ x7 b
Dim swDoc As SwDMDocument12
4 p# Y" ^5 A L( r! e! u
Dim mOpenErrors As SwDmDocumentOpenError
w; y- ?. J) U& Z4 F/ @
Dim swCfgMgr As SwDMConfigurationMgr; ` H4 a# Q4 Y8 [+ E
Dim objClassfac As SwDMClassFactory/ v- S6 D" @; z! X: Z- G# e0 q
Dim vCustPropNameArr As Variant
7 b3 _' P" t4 w
Const SWDMLicenseKey = ""/ Y' f" A! `% ]$ F' I& V
0 X4 d5 X" O9 E% X( Q+ E) b
, I* a# ~8 u: M, S
Sub 打开文件()
# Q6 R, m6 k. g5 L% `1 O/ M# c
Range("A3").Activate/ ~/ x' J. [: w7 x. L! \8 f
Set objClassfac = CreateObject("SwDocumentMgr.SwDMClassFactory")" d# O( z7 P; A3 U) U
Set swDM = objClassfac.GetApplication(SWDMLicenseKey) '啟動SWDM2 ^' ~% z0 [8 J
Dim vCfgNameArr As Object- G0 \$ q. H3 k s3 q8 u% a
Dim vCfgName As Object
2 D; c( ^8 V. w" g& g" T
Dim swCfg As SwDMConfiguration '14& _ O0 Y/ ~3 U. t9 L$ R) l% |
Dim nPropType As Long
( F( ], c6 a1 U* }' {8 m" J# r
Dim PropList() As String
0 a: ^4 }# ~# J
ReDim PropList(0)
* U1 N' h; f. ~8 M0 Q
PropList(0) = ""* [7 }# p5 M+ F6 P) l
Dim intChoice As Integer% O: Y6 E: S+ r8 k
Dim FilePathName As String
: D' N+ q/ l W6 H& j7 V/ a
Dim i As Integer" U( N- L, F9 t8 X# ~! I: K. R9 o0 k2 |
HeaderRow = 22 P" D' h8 Z& W8 `% f1 L9 @7 h
RowNumber = 3
6 M. p) C7 x1 c& C |) o, e6 B
PathName = Cells(RowNumber, 1) '讀取第一個路徑的值
$ D; Y3 R$ R2 x% N/ N" x$ J+ b/ H t
While Not (PathName = "" Or PathName = 0 Or IsEmpty(PathName)) '直到讀完路徑欄(尋找繼續填寫的位置)$ ?6 @( G, q9 J1 l9 f$ f4 ?& v; g: ^
RowNumber = RowNumber + 1 '下一列4 H' _7 T' |: a& m; u! ?
PathName = Cells(RowNumber, 1)
' M8 p) w; Z5 A0 R/ \! w
Wend '回到>直到讀完路徑欄
& q1 _$ H" z( Q) c0 x/ [
Application.FileDialog(msoFileDialogFilePicker).AllowMultiSelect = True '設定為多選對話框
; a6 r0 J& D9 Y& u/ {) _
Application.FileDialog(msoFileDialogFilePicker).Filters.Clear '清除既有類型
0 K% }9 @$ T2 a# ?5 p. w
Application.FileDialog(msoFileDialogFilePicker).Filters.Add "零件自定义属性", "*.SLDPRT" '設定檔案類型
9 K, L. i0 Z( i: p* a7 J8 N% r
Application.FileDialog(msoFileDialogFilePicker).Filters.Add "零件配置属性", "*.SLDPRT" '設定檔案類型; d" E7 d6 g, N# `0 z
Application.FileDialog(msoFileDialogFilePicker).Filters.Add "装配体自定义属性", "*.SLDASM" '設定檔案類型 ]( j9 p" u2 B4 y
Application.FileDialog(msoFileDialogFilePicker).Filters.Add "装配体配置属性", "*.SLDASM" '設定檔案類型
2 U% \, B. g' E: ^
Application.FileDialog(msoFileDialogFilePicker).Filters.Add "工程图属性", "*.SLDDRW" '設定檔案類型
2 ~& J/ B1 d* {; i, |- V, J) @3 B
If Cells(1, 1) = 1 Or Cells(1, 1) = 2 Or Cells(1, 1) = 3 Or Cells(1, 1) = 4 Or Cells(1, 1) = 5 Then; }0 w# e* @: Q, U# `
Application.FileDialog(msoFileDialogFilePicker).FilterIndex = Cells(1, 1); @" }8 d" ^9 O0 K3 C- z
End If
# D9 B+ I( _5 |2 e, |( K3 J& p
If Cells(1, 2) <> "" Then Application.FileDialog(msoFileDialogFilePicker).InitialFileName = Cells(1, 2)+ P0 p( j, P: f# P
intChoice = Application.FileDialog(msoFileDialogFilePicker).Show '彈出對話框( \& J/ Z2 f6 v3 z! B- W; {$ o
* D0 s6 s" P* s! k) w
If intChoice <> 0 Then '判斷有否點選檔案
+ V' b* L+ H: S7 Q- ~: _
RowCount = 1
+ q# O1 Q6 T- x! B
swFilterIndex = Application.FileDialog(msoFileDialogFilePicker).FilterIndex
1 Z/ n1 I% F) u3 J
For i = 1 To Application.FileDialog(msoFileDialogFilePicker).SelectedItems.Count '逐一讀取所選檔案
( \/ ~$ l |6 F7 m5 g, M) }
FilePathName = Application.FileDialog(msoFileDialogFilePicker).SelectedItems(i) '讀取完整檔案名稱. O8 z# f/ P/ X8 r
FilePath = Left(FilePathName, InStrRev(FilePathName, "")) '分解路徑& }) q/ A f2 N% j' `' G
FileName = Right(FilePathName, Len(FilePathName) - Len(FilePath)) '分解檔案名稱7 w k/ U2 q4 T, Y' r& h4 J
FileExtname = UCase(Right(FilePathName, 6)) '分解檔案類型
7 d8 t8 P: N: D
If swFilterIndex = 1 Or swFilterIndex = 3 Or swFilterIndex = 5 Then( o8 B# h. t7 ?
Cells(RowCount + RowNumber - 1, 1) = FilePath '填寫路徑& b+ d5 l, _6 L% j! H+ L/ ]% R( \
Cells(RowCount + RowNumber - 1, 2) = FileName '填寫檔案名稱. L2 b( a! U9 ]
RowCount = RowCount + 1
C. M( T6 Y" S8 Q
End If9 ^3 @4 m1 E& c9 u5 X& H$ f
If swFilterIndex = 2 Or swFilterIndex = 4 Then '過濾器是2或4' e% Q7 o" f0 L
Set swDoc = swDM.GetDocument(PathName & FileName, swFileTYpe, False, mOpenErrors) '開啟檔案( U C; ], F6 W% i
If Not swDoc Is Nothing Then '排除無效檔案
2 r% d: r9 |' u( ~$ C- B
Set swCfgMgr = swDoc.ConfigurationManager' {& L) ]; h6 g5 o" A" _% C' T
swConfigNames = swCfgMgr.GetConfigurationNames0 e+ s0 l( e( m6 E+ `
. z7 L/ `; T- Q* G4 g
For Each swConfigName In swConfigNames
" C! y' m: u2 N: Y2 r
Set swCfg = swCfgMgr.GetConfigurationByName(swConfigName)- {0 H: j% R% @1 Z' Z* I: w5 Q' z
vCustPropNameArr = swCfg.GetCustomPropertyNames7 p9 f5 F! J- Q% ?) F/ A0 ~
If TypeName(vCustPropNameArr) = "String()" Then" `. v! Q7 C$ t: r
" m9 Q7 u9 |! _, ~
3 t% B4 v' F! Y+ H, d
9 E# S0 c" q6 N6 h2 q# {0 J
! Z' H% _- @8 R. g/ ]) I- {
0 s8 F5 G: H' q3 m8 \ S+ }( ?
+ ~( Q, B& c' e( T7 }+ _/ I" l, [
: h% S/ P, [' D1 D( }
) D% v: T0 T4 K# O; t
" G- s( V+ O/ \8 S- Y6 f7 F
' ?* E T) F. m R. ]6 g; c6 c
End If8 f, A6 O v0 a: c) p
Cells(RowCount + RowNumber - 1, 1) = FilePath '填寫路徑
s, p$ R+ @* r7 X" T3 V1 o
Cells(RowCount + RowNumber - 1, 2) = FileName '填寫檔案名稱
* r7 \2 Z( v4 e
Cells(RowCount + RowNumber - 1, 3) = swConfigName '填寫模型組態名稱
/ n& K4 E8 V- s5 c
Cells(RowCount + RowNumber - 1, 3).Interior.Color = RGB(200, 200, 200)+ g1 x/ @% {* r* ~3 @; c+ }
$ S* R7 l' Z; L' `
RowCount = RowCount + 1
. B% `5 |5 A/ w: ~% t
Next
4 I/ X! u, ~7 @- s. d3 ^
swDoc.CloseDoc '關閉檔案
: m) G- ]2 J! A/ E1 p
End If '排除無效檔案<完> A0 ]8 E' g' n1 R: g6 I
End If ''過濾器是2或4<完>
, ~7 y3 q5 f) C0 H( r' v
Next i '逐一讀取所選檔案<完>* P& k# h5 i# C: {% T/ A7 d
End If '判斷有否點選檔案<完>
' b7 s4 M# G5 H! T
End Sub& I" w( K0 ^1 J/ e

复制代码

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

通知

[讨论] excel VBA 批量更改solidworks 属性的问题

马上注册，结识高手，享用更多资源，轻松玩转三维网社区。

点评