求闷大的用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()' ~5 y, B; c& `% n- I
Set swApp = CreateObject("SldWorks.Application") '啟動SW9 b5 Y2 X! p, L/ L3 S
SavedFilesCount = 0' k( g: w& K% @6 h& P5 L8 ^( z
HeaderRow = 2
1 G7 g6 q2 b& n2 z1 A7 @( E
RowNumber = 27 N) `! j) l8 K$ R
RowNumber = HeaderRow + 18 q1 b1 R" ]% O. h' B
PathName = Cells(RowNumber, 1) '讀取第一個路徑的值
* h. \3 H2 S; U% Z) D* L* ^; @! ~
While Not (PathName = "" Or PathName = 0 Or IsEmpty(PathName)) '直到讀完路徑欄, ?7 N5 r8 r! B% T P, ~
Filename = Cells(RowNumber, 2)
0 R/ D0 `* t* q
Set Drawing = Nothing
/ a+ F6 V$ M s! c* d
If Dir(PathName & Filename) <> "" Then
* ~( R9 \, L6 b
Set Drawing = swApp.OpenDoc(PathName & Filename, 3) '開啟工程圖 p }6 O9 N+ E. {1 H8 h' |
End If
+ p, Q7 H: r' F$ _5 r- E# ?9 g
If Not Drawing Is Nothing Then0 i; g5 U9 o a/ ~! W: y
ColumnNumber = 3
+ R( |7 \3 F. A' e
PropName = Cells(HeaderRow, ColumnNumber)
) {* C, \) C! e4 @
While Not (PropName = "" Or PropName = 0 Or IsEmpty(PropName)) '直到讀完表頭+ P4 `* p" u% i2 q0 e
PropValue = Cells(RowNumber, ColumnNumber)
& Q6 w; Q6 [& B" @" t" Y) g( x9 d
Drawing.DeleteCustomInfo2 "", PropName '刪除屬性0 j+ p! n, n2 j* l' K
Drawing.AddCustomInfo3 "", PropName, 30, PropValue '新增屬性" _# t% L; V- [3 [! X
ColumnNumber = ColumnNumber + 1 '下一欄
' C# z A5 z7 X, }$ M; b
PropName = Cells(HeaderRow, ColumnNumber)
0 I" X7 ^( J& c% x
Wend '回到>直到讀完表頭
2 Z* j+ q7 C2 ?5 L6 x1 [( R/ _
Dim lErrors As Long
$ t& e/ Y1 ~- i+ P: s1 v
Dim lWarnings As Long* `3 c- R& L% q* G
SaveOk = Drawing.Save3(1, lErrors, lWarnings)
7 r Q/ D( u0 E8 L6 A5 K
swApp.CloseDoc PathName & Filename '關閉工程圖
* u- Z8 z6 a5 [* p' y- N, }6 o
If SaveOk Then Cells(RowNumber, 1).Interior.Color = RGB(255, 255, 127) 'SavedFilesCount = SavedFilesCount + 1
" q; a+ D B- u, \
End If' C$ v. |: Z6 h6 {
RowNumber = RowNumber + 1 '下一列: E, K8 ^% e: D* u# o. I* w+ R
PathName = Cells(RowNumber, 1)
0 [. g9 n* ]0 t* g; U# \
Wend '回到>直到讀完路徑欄) r" t& E5 W8 I& X q$ E3 I
'MsgBox "更新了 " & SavedFilesCount & " 個檔案"0 `! U: a2 N: Z8 o3 r: p4 j
End Sub

复制代码

選擇檔案的程式碼

Sub BrowseDialog()4 F c" @ q/ z, f& [7 x/ p8 n& E
Dim intChoice As Integer; b! @, {4 a# o* J9 Q, u/ F
Dim FilePathName As String
% W% y1 O7 [3 @& A! m
Dim i As Integer
/ e; y$ l, g$ t; ]9 P& L$ K
RowNumber = 3( u5 x$ L" D" ?3 `* M- o; Z
PathName = Cells(RowNumber, 1) '讀取第一個路徑的值5 F+ y3 W6 y+ U$ J' J1 L' T/ K% C1 J6 j3 w
While Not (PathName = "" Or PathName = 0 Or IsEmpty(PathName)) '直到讀完路徑欄(尋找繼續填寫的位置)
7 k) X2 e2 H4 p
RowNumber = RowNumber + 1 '下一列8 C. M z. |8 t, l" b& }0 L
PathName = Cells(RowNumber, 1)- g+ i) }) K# A0 C
Wend '回到>直到讀完路徑欄; e4 g, c9 t' d- S- Z3 T3 j* k- P1 [
Application.FileDialog(msoFileDialogFilePicker).AllowMultiSelect = True '設定為多選對話框9 f6 G0 V, T& ^3 r; ^: ~ j: d
Application.FileDialog(msoFileDialogFilePicker).Filters.Clear '清除既有類型" S. ?6 B" | e
Application.FileDialog(msoFileDialogFilePicker).Filters.Add "騷窩宮程圖", "*.SLDDRW" '設定檔案類型
8 k9 L' p- [6 P' N. w2 \/ v
intChoice = Application.FileDialog(msoFileDialogFilePicker).Show '彈出對話框
8 Q J, j1 n* S
If intChoice <> 0 Then '判斷有否點選檔案" w0 {; L) n- s1 m7 H# m
For i = 1 To Application.FileDialog(msoFileDialogFilePicker).SelectedItems.Count '逐一讀取所選檔案+ i& ?" j, s d% {+ j1 Z! ], T
FilePathName = Application.FileDialog(msoFileDialogFilePicker).SelectedItems(i) '讀取完整檔案名稱4 f% d( n) u+ E/ j
FilePath = Left(FilePathName, InStrRev(FilePathName, "")) '分解路徑
! A; ~ i. n7 V7 X' B/ h
Filename = Right(FilePathName, Len(FilePathName) - Len(FilePath)) '分解檔案名稱
4 a2 ^5 J/ u- E* K2 n( W
Cells(i + RowNumber - 1, 1) = FilePath '填寫路徑/ b. |. ~: | q
Cells(i + RowNumber - 1, 2) = Filename '填寫檔案名稱) P0 l8 C8 ?6 y2 L2 B
Next i
/ L H6 L. h# ~5 Q( P0 z' @
End If
1 Q/ t% x1 S% P. |7 ~
End Sub

复制代码

讀取屬性的程式碼

" H1 E1 X3 r+ G& j% r# H( i% e
Sub ReadSlddrwPrp()( [. a$ K1 Z: H& f! S6 i6 X
Set swApp = CreateObject("SldWorks.Application") '啟動SW& g/ `( U+ F) H8 J
HeaderRow = 23 J' J! q* q9 j8 f+ Y
RowNumber = HeaderRow + 10 {' Q; i, u1 J: c. ?
PathName = Cells(RowNumber, 1) '讀取第一個路徑的值. a) M7 o9 H2 a8 D1 [0 K
While Not (PathName = "" Or PathName = 0 Or IsEmpty(PathName)) '直到讀完路徑欄
: K; X9 P3 Y, U# E4 ~# I
Filename = Cells(RowNumber, 2)
$ l! ?9 ]% r; z j% `* u6 r
Set Drawing = swApp.OpenDoc(PathName & Filename, 3) '開啟工程圖
' D7 m( C* a: x1 w3 t. D8 s
If Not Drawing Is Nothing Then
; n3 c; d2 B! o# z/ Q9 e6 z: `! P
ColumnNumber = 3
( f( f# a0 C6 X; s* Z
PropName = Cells(HeaderRow, ColumnNumber)3 C- `. ?' v) w( l. X6 t3 o- \
While Not (PropName = "" Or PropName = 0 Or IsEmpty(PropName)) '直到讀完表頭 ?$ L: G/ u' t+ S
PropValue = Drawing.CustomInfo2("", PropName) 'GetCustomProperty(PropName, 30) '獲取屬性! l3 ]6 \% }4 ]: X' Z
Cells(RowNumber, ColumnNumber) = PropValue
/ V' `0 k3 O0 i& X- [
ColumnNumber = ColumnNumber + 1 '下一欄
$ y4 H8 X# l3 ]! Y1 h
PropName = Cells(HeaderRow, ColumnNumber)
) V- B; z; ?2 R7 ^7 S& M- [, \4 N7 W
Wend '回到>直到讀完表頭5 I0 Y) d& ?% s9 T: B+ u$ D
swApp.CloseDoc PathName & Filename '關閉工程圖
; r J7 n. v. Q2 L ~( [
Cells(RowNumber, 1).Interior.Color = RGB(200, 255, 200)6 p: A) I5 ^( r9 k! y: o# X
End If
n. y6 h3 f$ S: N
RowNumber = RowNumber + 1 '下一列& ]! U% L" V( G" {' O0 j
PathName = Cells(RowNumber, 1)' f5 I/ c4 ~0 V; |* G* W
Wend '回到>直到讀完路徑欄
* Q. W0 @6 W) d1 `- Y, [5 m
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" e1 w2 R% K1 l: U" ]7 I& R
能否直接给个excel表格文件，这个txt打开很多乱码，感谢2楼美女

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

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

judyyai 发表于 2015-6-27 16:18 static/image/common/back.gif/ ]9 i7 W+ Y1 e$ P
原始檔案就是這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
; O* O- _$ ?- j* T- y2 Y1 N" j谢谢自己写剩余的部分

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

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

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

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

留着慢慢用，先收藏了。

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

通知

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

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

浏览过的版块