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

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

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

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

x

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

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

Dim swDM As SwDMApplication
; f3 i. A9 c1 y4 g3 S. c! C. G
Dim swDoc As SwDMDocument123 u+ ?; a; ~2 i( d: a
Dim mOpenErrors As SwDmDocumentOpenError* p, v3 E, q; d! C7 ~5 `
Dim swCfgMgr As SwDMConfigurationMgr
3 A# S- t$ T7 t8 N$ \* w1 {
Dim objClassfac As SwDMClassFactory
( r0 f! ?* w- g# z( K+ i
Dim vCustPropNameArr As Variant
4 G, V ]5 J5 t0 _ F. M
Const SWDMLicenseKey = ""/ u' R, u$ I7 ^/ K( e7 C2 A
( S6 y; f E: ~: A2 C; f$ `' X, v
6 t, g5 p; Z0 q9 n3 G7 D$ J9 m1 h& Y
Sub 打开文件()! Q8 T$ x; `% J: a
Range("A3").Activate6 R% ~7 { j, x# ?
Set objClassfac = CreateObject("SwDocumentMgr.SwDMClassFactory")
r6 z0 w, I3 {. f* z7 Y9 B6 }
Set swDM = objClassfac.GetApplication(SWDMLicenseKey) '啟動SWDM
( A% D9 {1 R1 }
Dim vCfgNameArr As Object
3 }* k% l/ @! V
Dim vCfgName As Object
* r) \' a8 m3 l6 J* }" U) D
Dim swCfg As SwDMConfiguration '149 g. E1 x7 V. N& U* c
Dim nPropType As Long
2 V/ |! h8 g2 m- u
Dim PropList() As String% [. ]* l) I) U! q Z8 P8 c
ReDim PropList(0)7 Q# z- [ U* G$ K% k
PropList(0) = ""* b0 E: }; S9 w1 }+ k9 C7 j% g
Dim intChoice As Integer
; v4 \' ~& Q& {6 ?/ k) H% V) p
Dim FilePathName As String6 t1 N* K B+ G+ a. D4 `9 V1 F
Dim i As Integer
1 W% V7 ~2 c- R; ?+ j8 {
HeaderRow = 2
! C* b0 U; ?, t7 r, K0 D6 h1 j
RowNumber = 3
& g9 \! |6 k. Y! h( j7 [
PathName = Cells(RowNumber, 1) '讀取第一個路徑的值0 P+ |6 t! h( f$ `. h% t
While Not (PathName = "" Or PathName = 0 Or IsEmpty(PathName)) '直到讀完路徑欄(尋找繼續填寫的位置)
* W7 B& v$ ]$ Y1 j, F! C) U
RowNumber = RowNumber + 1 '下一列+ e. f: G5 n9 p3 j6 U
PathName = Cells(RowNumber, 1)
: p+ K+ o2 s/ ~; H, d/ \* o
Wend '回到>直到讀完路徑欄
3 o; m3 m0 @2 N( v" g+ q: e' c
Application.FileDialog(msoFileDialogFilePicker).AllowMultiSelect = True '設定為多選對話框; ^' y8 A& X. ?+ ^. {
Application.FileDialog(msoFileDialogFilePicker).Filters.Clear '清除既有類型
7 y: D" k" S" M
Application.FileDialog(msoFileDialogFilePicker).Filters.Add "零件自定义属性", "*.SLDPRT" '設定檔案類型7 w) R4 s& D! r+ Q+ J
Application.FileDialog(msoFileDialogFilePicker).Filters.Add "零件配置属性", "*.SLDPRT" '設定檔案類型
% F! T, l, t$ J4 q
Application.FileDialog(msoFileDialogFilePicker).Filters.Add "装配体自定义属性", "*.SLDASM" '設定檔案類型
0 C( @/ N/ O0 |) a
Application.FileDialog(msoFileDialogFilePicker).Filters.Add "装配体配置属性", "*.SLDASM" '設定檔案類型
& |: @9 ]1 P+ q: o o: B3 `4 P+ |
Application.FileDialog(msoFileDialogFilePicker).Filters.Add "工程图属性", "*.SLDDRW" '設定檔案類型 `& S: L4 B C
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 Then5 e0 v4 }3 L: X) B7 H9 I2 V$ i
Application.FileDialog(msoFileDialogFilePicker).FilterIndex = Cells(1, 1)6 [+ V: P$ F$ K. D/ T2 W, l9 o' q! S
End If& e0 W+ s) }! u; }! _+ f
If Cells(1, 2) <> "" Then Application.FileDialog(msoFileDialogFilePicker).InitialFileName = Cells(1, 2)
( P% D; J* p2 n$ F/ U' J) P8 Z0 x. u4 }
intChoice = Application.FileDialog(msoFileDialogFilePicker).Show '彈出對話框1 X6 q2 J& @. u; P
3 H2 p. u: |2 ?3 `
If intChoice <> 0 Then '判斷有否點選檔案* T$ T# u7 S/ M8 M& Z% b
RowCount = 1' m0 G7 T. X7 X
swFilterIndex = Application.FileDialog(msoFileDialogFilePicker).FilterIndex
; \9 H& k+ D) c
For i = 1 To Application.FileDialog(msoFileDialogFilePicker).SelectedItems.Count '逐一讀取所選檔案2 c" i7 W; I5 s; l
FilePathName = Application.FileDialog(msoFileDialogFilePicker).SelectedItems(i) '讀取完整檔案名稱
8 s; w( `3 t; ^6 e5 [: ?! e
FilePath = Left(FilePathName, InStrRev(FilePathName, "")) '分解路徑5 }4 \6 l5 w c" \
FileName = Right(FilePathName, Len(FilePathName) - Len(FilePath)) '分解檔案名稱# C$ I9 E1 p( x/ |' q* C8 Z
FileExtname = UCase(Right(FilePathName, 6)) '分解檔案類型/ C3 t2 R+ s$ ?. \2 p. m
If swFilterIndex = 1 Or swFilterIndex = 3 Or swFilterIndex = 5 Then- N# X- i; o8 x! K4 `7 P
Cells(RowCount + RowNumber - 1, 1) = FilePath '填寫路徑& e" K' l, f5 O* R: j; S
Cells(RowCount + RowNumber - 1, 2) = FileName '填寫檔案名稱- G: S! e) i9 ~" i0 p. l6 Y
RowCount = RowCount + 1
% s. S4 e; K4 P/ _# ?
End If. D8 l& s N" }5 j w3 X8 t: J
If swFilterIndex = 2 Or swFilterIndex = 4 Then '過濾器是2或4, t! Z; J3 V4 L! P' L. ^
Set swDoc = swDM.GetDocument(PathName & FileName, swFileTYpe, False, mOpenErrors) '開啟檔案 V9 v" h* [0 X j
If Not swDoc Is Nothing Then '排除無效檔案1 w% L4 t J7 M6 d) `+ w4 m7 l) Q5 ?
Set swCfgMgr = swDoc.ConfigurationManager
5 e+ F5 s+ b R' ^9 L2 r
swConfigNames = swCfgMgr.GetConfigurationNames
: n( [4 J, h% Y$ N H1 ?
4 M/ t2 S4 r4 X
For Each swConfigName In swConfigNames( f) o: m2 f8 R- D b' A: L
Set swCfg = swCfgMgr.GetConfigurationByName(swConfigName)
C$ s' a$ B* T# Q. h: ?, p
vCustPropNameArr = swCfg.GetCustomPropertyNames
6 e Q( Q( {; Q0 i4 |8 G8 k
If TypeName(vCustPropNameArr) = "String()" Then7 j( f! H' W) J2 }1 I# Z. X5 Q
3 f6 n5 ~0 m. p' R: E
# q2 ~. ?8 i3 v* C% ?
* @( `( C% C+ u2 X( C7 g
/ @3 D/ g$ \# U! f U2 [4 @
; z. A( P' `& j; q/ c- J4 O! H
' P( U4 v* N2 R2 O2 m, j5 r7 I* C
! M* B2 `7 q3 p- M0 O7 b' a
' [. _+ V+ C) T( R# f) N" b
$ v+ _- v" C- S
7 {; ^8 T- ^. ]
End If; z2 l. n7 H0 a, H
Cells(RowCount + RowNumber - 1, 1) = FilePath '填寫路徑
, V+ u, x C0 H4 u: W
Cells(RowCount + RowNumber - 1, 2) = FileName '填寫檔案名稱
. d/ R2 k3 R: o1 `* r
Cells(RowCount + RowNumber - 1, 3) = swConfigName '填寫模型組態名稱$ J( B+ {' U- M8 I8 t
Cells(RowCount + RowNumber - 1, 3).Interior.Color = RGB(200, 200, 200)9 i+ P: n' \* V7 Y2 @7 ^
0 I: X% c5 V3 D) _( |9 s
RowCount = RowCount + 1
, s; J8 q9 i* l2 X, `: m% M
Next
' F+ {5 J9 G1 t: s1 f
swDoc.CloseDoc '關閉檔案
# l T# r1 G* ^5 K
End If '排除無效檔案<完>! X8 p T1 n2 P$ c2 d, }0 O# K8 ?
End If ''過濾器是2或4<完>7 O9 T! G+ m, R4 U* d2 {" B* N
Next i '逐一讀取所選檔案<完>
5 ^7 P' F1 ]& n! o3 g# ]$ w' i
End If '判斷有否點選檔案<完>6 _- @! C9 J& {: g" K. c
End Sub) v; Y8 h: d' f1 g+ @

复制代码

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

全站		goto3d 说: 版主微信号：caivin811031；还未入三维微信群的小伙伴，速度加	2022-07-04
全站		goto3d 说: 此次SW竞赛获奖名单公布如下，抱歉晚了，版主最近太忙：一等奖：塔山817；二等奖：a9041、飞鱼；三等奖：wx_dfA5IKla、xwj960414、bzlgl、hklecon；请以上各位和版主联系，领取奖金！！！	2022-03-11

通知

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

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

点评

浏览过的版块