求闷大的用Excel批量修改工程图属性

jaychou315 · 发表于 2015-6-27 12:27:15

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

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

x

本帖最后由 jaychou315 于 2015-6-27 12:51 编辑

这个是台湾的几何网闷大做的，但是下载不了，请问这个坛子里有吗？求链接。
还有我想实现
将零件的自定义属性中的“图号”和“零件名”提取出来自动将“图号”+“零件名”命名为新文件名，因为工程图出完肯定就是这种格式的命名，现在这样做就把零件和工程图的名字搞成一样了。
我知道这需要二次开发，现在我准备学习这个，早日实现自己想要的功能，加油！

judyyai · 发表于 2015-6-27 13:03:32

本帖最后由 judyyai 于 2015-6-27 16:17 编辑

那裏的4#有原始碼~

轉過來了~原始檔案就是附檔 (若亂碼請看以下代碼,中文請自行翻譯你們需要的文字語言

code.rar (2.22 KB, 下载次数: 145)

2015-6-27 13:16 上传

点击文件名下载附件

寫入屬性的程式碼

Sub WriteSlddrwPrp()7 v; ^+ @; C7 V2 N: E7 a
Set swApp = CreateObject("SldWorks.Application") '啟動SW
6 k, ]3 P# i' C7 h3 i; D5 L
SavedFilesCount = 0+ H0 @* h. I' x' T+ x% Z* x
HeaderRow = 2
+ R: e T' C, q# Z" N* u; @
RowNumber = 2
! F T- I& c* W( x) @4 p
RowNumber = HeaderRow + 1
PathName = Cells(RowNumber, 1) '讀取第一個路徑的值; E* a9 t6 |: U+ t- D" }# c& q
While Not (PathName = "" Or PathName = 0 Or IsEmpty(PathName)) '直到讀完路徑欄
. O/ D Q& B- n8 @6 E8 Q
Filename = Cells(RowNumber, 2)# P4 x9 z0 m- d( H: h' ]
Set Drawing = Nothing$ v( g2 n7 a) P' H: B
If Dir(PathName & Filename) <> "" Then9 K+ A! B" b0 ^; t3 _ f: R2 K" J ]
Set Drawing = swApp.OpenDoc(PathName & Filename, 3) '開啟工程圖: w; w b, @' ?
End If
( L% `& l2 K# K s3 P0 M" G+ r
If Not Drawing Is Nothing Then6 |( d' D: a3 c% d! m- y' x
ColumnNumber = 3
1 Z0 }6 I7 z" t/ [) c2 i% X
PropName = Cells(HeaderRow, ColumnNumber)( i4 Y; @3 |8 R: y6 J, t
While Not (PropName = "" Or PropName = 0 Or IsEmpty(PropName)) '直到讀完表頭3 X5 [1 C) K! N% @
PropValue = Cells(RowNumber, ColumnNumber)
8 @" e% l7 Z; y2 N
Drawing.DeleteCustomInfo2 "", PropName '刪除屬性! \# `$ W+ W- K; v6 L
Drawing.AddCustomInfo3 "", PropName, 30, PropValue '新增屬性
& ~/ m- h. K! x: e* j2 _
ColumnNumber = ColumnNumber + 1 '下一欄
' |# _+ T+ u/ n' D4 H+ z
PropName = Cells(HeaderRow, ColumnNumber)$ e) [5 j7 e3 k$ `9 c$ {
Wend '回到>直到讀完表頭
- v' Y( `- P6 {2 s* r- A
Dim lErrors As Long
1 B# H5 Z+ Q- D! V9 y6 D O, f& F
Dim lWarnings As Long
; {9 n$ D- C) a$ z
SaveOk = Drawing.Save3(1, lErrors, lWarnings)
6 E4 X" @! Y, b1 i
swApp.CloseDoc PathName & Filename '關閉工程圖
2 h z" z$ z2 k8 m" i3 V) A
If SaveOk Then Cells(RowNumber, 1).Interior.Color = RGB(255, 255, 127) 'SavedFilesCount = SavedFilesCount + 15 M8 ^2 o: g/ K* M- s" J* x
End If+ f5 b6 [4 P/ `$ p6 F# n9 }7 X
RowNumber = RowNumber + 1 '下一列
$ d0 h$ T. J6 f* Y" j% m# n6 L
PathName = Cells(RowNumber, 1)
) ]) G' m, a! A
Wend '回到>直到讀完路徑欄+ e2 ]2 D- z3 [' X
'MsgBox "更新了 " & SavedFilesCount & " 個檔案"
2 t% F, P" {! d. Z2 Z" Q
End Sub

复制代码

選擇檔案的程式碼

Sub BrowseDialog()
8 B1 r) ]/ S; L
Dim intChoice As Integer6 s6 @$ L3 V' h3 n7 Y
Dim FilePathName As String% B; j7 A# _! R& N8 C5 ^( f& I3 b3 a
Dim i As Integer' W R4 `* D$ h4 _6 ?
RowNumber = 3% u! O: ~& Y }
PathName = Cells(RowNumber, 1) '讀取第一個路徑的值; O; x2 ^" w0 ^2 t+ y" l
While Not (PathName = "" Or PathName = 0 Or IsEmpty(PathName)) '直到讀完路徑欄(尋找繼續填寫的位置)1 z; S, X" c. Z, _+ J
RowNumber = RowNumber + 1 '下一列
% \6 P- v H& H$ I/ M5 i6 m
PathName = Cells(RowNumber, 1)
8 T. Z$ V4 D! H' n
Wend '回到>直到讀完路徑欄! ^; J6 \% S6 ]) l p/ P$ J9 f- q
Application.FileDialog(msoFileDialogFilePicker).AllowMultiSelect = True '設定為多選對話框; Q/ f5 H4 r, i+ @
Application.FileDialog(msoFileDialogFilePicker).Filters.Clear '清除既有類型1 B( B7 {/ y* ^
Application.FileDialog(msoFileDialogFilePicker).Filters.Add "騷窩宮程圖", "*.SLDDRW" '設定檔案類型$ D1 `- Y1 X Z9 f+ o" N) ?* `! R% Q8 ?
intChoice = Application.FileDialog(msoFileDialogFilePicker).Show '彈出對話框
# j' ~3 ^& U; ?9 t7 @
If intChoice <> 0 Then '判斷有否點選檔案
+ A3 n3 M0 q y, e$ F( f; f
For i = 1 To Application.FileDialog(msoFileDialogFilePicker).SelectedItems.Count '逐一讀取所選檔案
/ @2 J' B% G2 v8 F. N
FilePathName = Application.FileDialog(msoFileDialogFilePicker).SelectedItems(i) '讀取完整檔案名稱
0 I+ K: g' g/ w% x8 W2 b
FilePath = Left(FilePathName, InStrRev(FilePathName, "")) '分解路徑
9 T+ Y) M$ k3 r. ^6 \% b% j
Filename = Right(FilePathName, Len(FilePathName) - Len(FilePath)) '分解檔案名稱
2 B: e9 a1 I! \: k
Cells(i + RowNumber - 1, 1) = FilePath '填寫路徑
. g& H9 i7 ^1 P) B g- Z
Cells(i + RowNumber - 1, 2) = Filename '填寫檔案名稱1 G! @2 l, u; O# o6 |
Next i
1 d( _1 {' K/ |3 c. `
End If9 `; J; }8 [* a$ V
End Sub

复制代码

讀取屬性的程式碼

, I% g) T* ~, w
Sub ReadSlddrwPrp()
3 Y$ t' _) ]" y9 i1 h9 A8 V
Set swApp = CreateObject("SldWorks.Application") '啟動SW
8 O1 L( m" i% h% W+ \ ~5 Y) L9 G
HeaderRow = 2
! b2 j2 L9 f0 n& o' ^
RowNumber = HeaderRow + 1+ Z& c4 @$ U; r3 N# X
PathName = Cells(RowNumber, 1) '讀取第一個路徑的值
2 {: {2 o4 N3 N$ N7 G, l( S
While Not (PathName = "" Or PathName = 0 Or IsEmpty(PathName)) '直到讀完路徑欄
4 U/ o+ n+ j% T/ [. M2 `
Filename = Cells(RowNumber, 2)
, `; H' [; I: J8 S
Set Drawing = swApp.OpenDoc(PathName & Filename, 3) '開啟工程圖
v1 T9 }# i' a
If Not Drawing Is Nothing Then
% o& h: Q8 `1 \; g
ColumnNumber = 3% E1 \) W7 {, p, d0 X3 h' m. _$ T% p
PropName = Cells(HeaderRow, ColumnNumber)
6 a% S T2 \2 K f c1 ]1 H* b
While Not (PropName = "" Or PropName = 0 Or IsEmpty(PropName)) '直到讀完表頭
$ Z9 M# N7 c0 }* _1 ^ @
PropValue = Drawing.CustomInfo2("", PropName) 'GetCustomProperty(PropName, 30) '獲取屬性) [: @0 x1 ?/ W: Y9 J$ O
Cells(RowNumber, ColumnNumber) = PropValue
6 H6 H, i4 c- D/ w( v
ColumnNumber = ColumnNumber + 1 '下一欄7 @; k) D( q9 q5 J9 B, N; _
PropName = Cells(HeaderRow, ColumnNumber)- j4 e# X& ?3 |4 \, u% u
Wend '回到>直到讀完表頭; u% a D; Z v$ P/ @6 n
swApp.CloseDoc PathName & Filename '關閉工程圖
3 W, i# w$ e4 T) J" K/ q. S
Cells(RowNumber, 1).Interior.Color = RGB(200, 255, 200)5 v6 k8 j' N# f3 M: X
End If
% i& n9 c; i8 d- d% I5 I( s9 _ \) Y
RowNumber = RowNumber + 1 '下一列
1 v9 I. D1 ~& {' j9 E
PathName = Cells(RowNumber, 1)
) S- O# i6 Q+ x# z
Wend '回到>直到讀完路徑欄
2 R/ p+ m6 k# t& x; }6 h9 ^
End Sub

复制代码

eric.bo · 发表于 2015-6-27 16:01:35

能否直接给个excel表格文件，这个txt打开很多乱码，感谢2楼美女

judyyai · 发表于 2015-6-27 16:18:08

whoeric 发表于 2015-6-27 16:01 static/image/common/back.gif
& t6 S$ c/ U' X, B9 }. T能否直接给个excel表格文件，这个txt打开很多乱码，感谢2楼美女

原始檔案就是這3個代碼~我已經用代碼方式丟出來了~

jaychou315 · 发表于 2015-6-27 16:24:32

judyyai 发表于 2015-6-27 16:18 static/image/common/back.gif3 R/ u! H7 Z( e! E
原始檔案就是這3個代碼~我已經用代碼方式丟出來了~

，厉害，看来我也要加油学习了！！

apple_058 · 发表于 2015-6-27 19:46:28

:):):):):)good

zthorn · 发表于 2016-10-30 22:24:49

我也很想要

weifneg1213 · 发表于 2016-11-25 14:19:26

这个有人弄出来了么

weifneg1213 · 发表于 2016-11-25 14:20:11

为什么我做的读取的属性不会显示啊

Foxzxm · 发表于 2016-11-25 14:36:15

没流量下载不了流量也兑换不了

tjhongtian · 发表于 2017-6-6 00:48:35

是什么下载

igmq · 发表于 2017-6-6 06:37:56

支持！楼主辛苦了！

ruoying_2233 · 发表于 2018-5-11 16:03:45

谢谢自己写剩余的部分

念天悠 · 发表于 2018-5-28 18:00:36

ruoying_2233 发表于 2018-5-11 16:03
3 f5 {$ i- \9 e7 o. e谢谢自己写剩余的部分

不知道如何入手，excel和宏怎么链接呢

magicnie · 发表于 2018-6-3 17:35:03

真心感谢，SW还有很多知识需要学习

hdgd501 · 发表于 2018-12-13 21:47:58

留着慢慢用，先收藏了。

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

通知

[求助] 求闷大的用Excel批量修改工程图属性

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

浏览过的版块