求闷大的用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()8 P+ F" c5 m6 B; H& N
Set swApp = CreateObject("SldWorks.Application") '啟動SW
7 G. J+ R2 l6 `$ r. J2 J
SavedFilesCount = 0( J. D7 G* _* A8 q) v1 L, A0 g2 I( a
HeaderRow = 2) l. p- k" ~1 ^2 Q. u1 j; R, {
RowNumber = 2
. @. w; q7 M: J' n9 M9 Y* T+ c
RowNumber = HeaderRow + 1! b, ?9 g r& V
PathName = Cells(RowNumber, 1) '讀取第一個路徑的值
) G( w8 q/ P2 b
While Not (PathName = "" Or PathName = 0 Or IsEmpty(PathName)) '直到讀完路徑欄7 {, F0 c. t! C0 V" i$ j4 g
Filename = Cells(RowNumber, 2)
4 a4 F0 F9 a3 w" x6 U( K0 D
Set Drawing = Nothing+ R. ~) x. t3 P+ v s2 f {
If Dir(PathName & Filename) <> "" Then* M' ]: ~, u$ U. L% M: d1 s9 R! O
Set Drawing = swApp.OpenDoc(PathName & Filename, 3) '開啟工程圖
6 w( \ L- E! [' ]* B
End If1 {( |+ C. C$ r1 r/ g/ I: R
If Not Drawing Is Nothing Then% ?$ _$ l: W, I7 c N
ColumnNumber = 3
) _9 p7 X! Q4 |6 a
PropName = Cells(HeaderRow, ColumnNumber)6 u" E5 Y% D+ }' c! W" E: K, q$ H
While Not (PropName = "" Or PropName = 0 Or IsEmpty(PropName)) '直到讀完表頭0 y# x3 q, x5 p+ g& p, `) R
PropValue = Cells(RowNumber, ColumnNumber)
# p, s- E- l0 ?& B1 d
Drawing.DeleteCustomInfo2 "", PropName '刪除屬性# v& d# f% L ~) f0 [' g) m
Drawing.AddCustomInfo3 "", PropName, 30, PropValue '新增屬性: ?9 N9 Z, @5 @3 X
ColumnNumber = ColumnNumber + 1 '下一欄+ t( M5 q+ H: O% \6 Q; A4 z
PropName = Cells(HeaderRow, ColumnNumber)
2 b s2 n3 j9 ~3 L5 [% y
Wend '回到>直到讀完表頭
! g) N3 [1 s/ g$ \, p3 T* ^
Dim lErrors As Long/ p' S E: l7 p- @( Z
Dim lWarnings As Long" x1 i+ E/ w! ` Q( q: a
SaveOk = Drawing.Save3(1, lErrors, lWarnings)1 W% K1 w1 v' g* Y' A% n7 j" M- d
swApp.CloseDoc PathName & Filename '關閉工程圖/ u& k; s' t6 Z' R
If SaveOk Then Cells(RowNumber, 1).Interior.Color = RGB(255, 255, 127) 'SavedFilesCount = SavedFilesCount + 1
) }0 E1 C- {' A Z8 ^
End If
# a' R, F4 l2 J
RowNumber = RowNumber + 1 '下一列3 t& D# g: I. U0 @
PathName = Cells(RowNumber, 1)* J' G/ ]8 x3 e) W0 B* f
Wend '回到>直到讀完路徑欄2 W# \, n$ B& q+ O# ]
'MsgBox "更新了 " & SavedFilesCount & " 個檔案"
6 a8 ?/ V0 H% a, Y1 X4 X- q. Q
End Sub

复制代码

選擇檔案的程式碼

Sub BrowseDialog()0 K3 G* y" X+ ^! e
Dim intChoice As Integer! ]8 G+ @7 x& J. u# y; K- e* Z
Dim FilePathName As String
- M. R( `/ L- O# [. S0 Z
Dim i As Integer7 K) C2 K6 V, h$ e
RowNumber = 3
" {: ^( T' H. W& c0 A% N
PathName = Cells(RowNumber, 1) '讀取第一個路徑的值' `6 C! Y" q! |+ m2 d7 {5 U
While Not (PathName = "" Or PathName = 0 Or IsEmpty(PathName)) '直到讀完路徑欄(尋找繼續填寫的位置)
" K# H6 L) Z( ^) a! k d5 ?
RowNumber = RowNumber + 1 '下一列
& {0 E! b! w4 D; G3 q$ ~
PathName = Cells(RowNumber, 1)
+ {1 @" m6 X) S+ E& I# g3 y9 U
Wend '回到>直到讀完路徑欄
' ~1 \' J* S& h& @5 O! H
Application.FileDialog(msoFileDialogFilePicker).AllowMultiSelect = True '設定為多選對話框9 @$ r+ a9 ?5 V+ I: ~; k& ~% L
Application.FileDialog(msoFileDialogFilePicker).Filters.Clear '清除既有類型
: B" p8 r) I6 U8 x5 O
Application.FileDialog(msoFileDialogFilePicker).Filters.Add "騷窩宮程圖", "*.SLDDRW" '設定檔案類型# a/ k2 p* m3 n% v3 O. p3 Q% ^
intChoice = Application.FileDialog(msoFileDialogFilePicker).Show '彈出對話框% v; D" N1 u) p. y: v* e, L
If intChoice <> 0 Then '判斷有否點選檔案
% U% P- a: R7 n
For i = 1 To Application.FileDialog(msoFileDialogFilePicker).SelectedItems.Count '逐一讀取所選檔案& J* r. w. c+ A2 J
FilePathName = Application.FileDialog(msoFileDialogFilePicker).SelectedItems(i) '讀取完整檔案名稱/ b' }' d/ b" l: \& k
FilePath = Left(FilePathName, InStrRev(FilePathName, "")) '分解路徑 S& i- V% k+ ^) r m
Filename = Right(FilePathName, Len(FilePathName) - Len(FilePath)) '分解檔案名稱* w* T6 P8 K. Q7 X( ?2 U) Q
Cells(i + RowNumber - 1, 1) = FilePath '填寫路徑" Y# Q! O' P# p+ o- \$ g
Cells(i + RowNumber - 1, 2) = Filename '填寫檔案名稱 O6 l# p+ H# k8 S! \7 }# }0 D+ a/ d
Next i: f2 a' b+ `; a/ l* q
End If" o8 n, X' g2 U$ N8 f$ ~! Z
End Sub

复制代码

讀取屬性的程式碼

. k$ j& o& ]2 B% X3 R O3 h% ?
Sub ReadSlddrwPrp(), l2 o5 f2 l9 y$ R
Set swApp = CreateObject("SldWorks.Application") '啟動SW
' m: e7 N" F8 I# }
HeaderRow = 2' s: i- J8 b$ I
RowNumber = HeaderRow + 12 T' j+ I, U8 M* _9 S8 ?$ R. X
PathName = Cells(RowNumber, 1) '讀取第一個路徑的值; i2 m; ^( {9 J4 n4 y
While Not (PathName = "" Or PathName = 0 Or IsEmpty(PathName)) '直到讀完路徑欄6 I9 k% W6 j' `5 D
Filename = Cells(RowNumber, 2)7 P5 V, ]# _1 u! M+ X" b
Set Drawing = swApp.OpenDoc(PathName & Filename, 3) '開啟工程圖
& p, _' e7 Q& v* H2 c- |5 E
If Not Drawing Is Nothing Then
9 p; R/ \& u7 ?3 \! U8 l- V
ColumnNumber = 3
j, ?* r/ v5 K. w4 h
PropName = Cells(HeaderRow, ColumnNumber)
' M" ^8 T- d$ n9 l% {
While Not (PropName = "" Or PropName = 0 Or IsEmpty(PropName)) '直到讀完表頭8 n) e0 V5 B$ X2 @, }) {" t
PropValue = Drawing.CustomInfo2("", PropName) 'GetCustomProperty(PropName, 30) '獲取屬性' q8 u. v# N9 g! y7 P4 I, s: w: X. ]
Cells(RowNumber, ColumnNumber) = PropValue
: m! F) W& W3 O8 l/ s( M9 |/ M- g
ColumnNumber = ColumnNumber + 1 '下一欄
' H3 n9 a( `( B ?( c9 E% u
PropName = Cells(HeaderRow, ColumnNumber)' c1 O. e0 z2 g, V- g4 ~
Wend '回到>直到讀完表頭8 p* V% q5 {$ s. @9 h
swApp.CloseDoc PathName & Filename '關閉工程圖- \9 l# W, Z7 ~; w$ J& }4 N
Cells(RowNumber, 1).Interior.Color = RGB(200, 255, 200), N1 w/ l: m8 P" f# G4 P
End If
" e% `, ]9 b2 b, Q7 W
RowNumber = RowNumber + 1 '下一列8 ?* R, t; [& }" h
PathName = Cells(RowNumber, 1)6 K5 _! A/ r! I1 `6 f' X
Wend '回到>直到讀完路徑欄
1 R9 B4 c# u1 D5 D+ P
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
4 H' {5 s5 e+ e' \能否直接给个excel表格文件，这个txt打开很多乱码，感谢2楼美女

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

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

judyyai 发表于 2015-6-27 16:18 static/image/common/back.gif
3 \7 |! j+ K3 {9 r原始檔案就是這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:031 U( {8 @: T( f$ Y2 o$ |
谢谢自己写剩余的部分

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

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

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

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

留着慢慢用，先收藏了。

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

通知

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

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

浏览过的版块