求闷大的用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()6 U1 _3 c7 P- v5 |) V* ^8 G$ P6 n* y
Set swApp = CreateObject("SldWorks.Application") '啟動SW# G* Y1 e$ Z3 O9 j
SavedFilesCount = 0& [8 e0 k) e: O9 J/ I! f
HeaderRow = 2
/ F& P, h! `; n: U S
RowNumber = 2
3 Q+ M+ U4 O5 t. d- Y
RowNumber = HeaderRow + 1
7 q; d' X) G1 e. [ f
PathName = Cells(RowNumber, 1) '讀取第一個路徑的值 |! b: H$ r8 g* V }
While Not (PathName = "" Or PathName = 0 Or IsEmpty(PathName)) '直到讀完路徑欄
( E% B. V' C$ K: I) E
Filename = Cells(RowNumber, 2)
. V# J) i) L/ G5 K9 A0 [
Set Drawing = Nothing! ~3 Y5 _+ h S* Z% D0 {
If Dir(PathName & Filename) <> "" Then" T: L8 K6 }4 M6 J6 ]' T
Set Drawing = swApp.OpenDoc(PathName & Filename, 3) '開啟工程圖! L2 Q3 R9 w, u# s
End If
5 D. C; `" n3 Z
If Not Drawing Is Nothing Then
7 K2 }9 ?# A! M- @3 x9 t
ColumnNumber = 3+ g+ b/ O+ Z5 U. R4 C4 a; _
PropName = Cells(HeaderRow, ColumnNumber)( r' K- M- u* ~# F
While Not (PropName = "" Or PropName = 0 Or IsEmpty(PropName)) '直到讀完表頭/ S0 y! w- e+ P A, w( v
PropValue = Cells(RowNumber, ColumnNumber)
+ c/ [+ K6 Q- `
Drawing.DeleteCustomInfo2 "", PropName '刪除屬性( ]. U0 M0 T/ _5 z9 `
Drawing.AddCustomInfo3 "", PropName, 30, PropValue '新增屬性3 I7 _+ s' U' X5 {0 x
ColumnNumber = ColumnNumber + 1 '下一欄
) k9 ~9 d r% g; X# W: n* |
PropName = Cells(HeaderRow, ColumnNumber)% e, Q2 n7 x2 K& E/ q# ?
Wend '回到>直到讀完表頭
* R9 [( J2 V [# R- p/ C g
Dim lErrors As Long1 G& l8 B5 o; U7 U7 ~6 E' p, h
Dim lWarnings As Long1 i, B: X$ J, b/ q+ ^
SaveOk = Drawing.Save3(1, lErrors, lWarnings), V9 _& |: H! o: A$ l d( f2 P- y' ^
swApp.CloseDoc PathName & Filename '關閉工程圖) m8 B# |, `( _5 d3 @) J! b
If SaveOk Then Cells(RowNumber, 1).Interior.Color = RGB(255, 255, 127) 'SavedFilesCount = SavedFilesCount + 1
2 b& z% m5 x! T8 I
End If
( Y- Y1 F7 X/ _4 _: P a- W" I
RowNumber = RowNumber + 1 '下一列
( S* f& U; [% u2 t; P9 {
PathName = Cells(RowNumber, 1)
; y, U7 G: ^$ e: r3 [
Wend '回到>直到讀完路徑欄
# _ _0 |# |/ ~' @9 v- g$ b
'MsgBox "更新了 " & SavedFilesCount & " 個檔案"
3 P0 Z: Q' z( |( I9 ^' f
End Sub

复制代码

選擇檔案的程式碼

Sub BrowseDialog()) F# Q7 ^( ?& K
Dim intChoice As Integer" O* _: ]1 Z; w: p# I; j
Dim FilePathName As String; Y4 z) Y" P# i) l0 W
Dim i As Integer* Y8 w' O8 N0 u7 F, f: s4 h" e/ _
RowNumber = 37 q1 j7 ^) g0 m! ^8 i
PathName = Cells(RowNumber, 1) '讀取第一個路徑的值4 k) a1 N6 q) ?0 D, G* _
While Not (PathName = "" Or PathName = 0 Or IsEmpty(PathName)) '直到讀完路徑欄(尋找繼續填寫的位置)
0 a5 V$ T P0 d. B
RowNumber = RowNumber + 1 '下一列
: y( ?, H' G( c- E, g
PathName = Cells(RowNumber, 1)
0 v4 l0 k' @7 n g( r3 h% v
Wend '回到>直到讀完路徑欄
* [- z% ~6 o( T. m5 _! V% g
Application.FileDialog(msoFileDialogFilePicker).AllowMultiSelect = True '設定為多選對話框
?1 r8 `+ V" J7 A; W" Y/ l( u% g: y
Application.FileDialog(msoFileDialogFilePicker).Filters.Clear '清除既有類型9 |% u# P$ E1 ?9 U, F$ o* h9 q& g
Application.FileDialog(msoFileDialogFilePicker).Filters.Add "騷窩宮程圖", "*.SLDDRW" '設定檔案類型
1 b, V# [ ?% e
intChoice = Application.FileDialog(msoFileDialogFilePicker).Show '彈出對話框
) \$ e* o; s7 x" R8 n( q f8 `" F. C
If intChoice <> 0 Then '判斷有否點選檔案
+ k! {9 b* e) q# j$ Y- ]9 U
For i = 1 To Application.FileDialog(msoFileDialogFilePicker).SelectedItems.Count '逐一讀取所選檔案, L h5 _/ `* j) w0 n) M, f
FilePathName = Application.FileDialog(msoFileDialogFilePicker).SelectedItems(i) '讀取完整檔案名稱 x7 y( `0 a$ F) G
FilePath = Left(FilePathName, InStrRev(FilePathName, "")) '分解路徑. H! n* R9 z! `
Filename = Right(FilePathName, Len(FilePathName) - Len(FilePath)) '分解檔案名稱( u1 C3 y6 L7 R7 b
Cells(i + RowNumber - 1, 1) = FilePath '填寫路徑
9 P( Z+ E- I- P3 o$ t1 g- f
Cells(i + RowNumber - 1, 2) = Filename '填寫檔案名稱0 X5 t- j, L. T. Y4 J" A
Next i H& |% ~- e2 d* o
End If7 N' a8 ?2 r0 y3 v& ]
End Sub

复制代码

讀取屬性的程式碼

5 _+ e. K) e* G2 j. m) ~- U
Sub ReadSlddrwPrp()
+ r2 Y: Y& T/ a( S& D
Set swApp = CreateObject("SldWorks.Application") '啟動SW
* j% v, `7 g7 j- Y! p
HeaderRow = 2
7 J- J$ a' ?) C7 ~0 R) ]4 w
RowNumber = HeaderRow + 1
( E6 X7 A0 I! o* X
PathName = Cells(RowNumber, 1) '讀取第一個路徑的值
: v& ~) c, o" G: j
While Not (PathName = "" Or PathName = 0 Or IsEmpty(PathName)) '直到讀完路徑欄5 v& ?+ G1 G9 v. ~# Q O, \
Filename = Cells(RowNumber, 2)
0 A, e. |, j- ^( p7 ^# ~
Set Drawing = swApp.OpenDoc(PathName & Filename, 3) '開啟工程圖! S8 P$ A* t' r, Y" x3 M
If Not Drawing Is Nothing Then
+ R) W& l- B$ B2 U8 c# c
ColumnNumber = 35 u4 O1 e3 l6 S V- p1 x
PropName = Cells(HeaderRow, ColumnNumber)
7 s* c+ t( e' v( p) p& E
While Not (PropName = "" Or PropName = 0 Or IsEmpty(PropName)) '直到讀完表頭
1 s: O7 c( j$ k) P8 o2 B; b5 M! i
PropValue = Drawing.CustomInfo2("", PropName) 'GetCustomProperty(PropName, 30) '獲取屬性, b/ _: Z- ^. E& Q+ w
Cells(RowNumber, ColumnNumber) = PropValue+ q9 A$ g1 x. ?4 f
ColumnNumber = ColumnNumber + 1 '下一欄
# y/ K) ], Z# o) R( D
PropName = Cells(HeaderRow, ColumnNumber)
3 a* r, _+ t( O; n- F5 J O4 p1 O
Wend '回到>直到讀完表頭$ Q/ U/ _4 O {5 g" L* [" w
swApp.CloseDoc PathName & Filename '關閉工程圖* J" [5 Y V! ?& B7 N
Cells(RowNumber, 1).Interior.Color = RGB(200, 255, 200). A% t, F8 V9 L/ q4 K9 R
End If2 h; g1 A* [& E( E k! |" {! d
RowNumber = RowNumber + 1 '下一列6 T$ T* ]1 i. h8 T. z) Q9 @, P# A, f
PathName = Cells(RowNumber, 1)0 }3 ?7 L/ s& u( D
Wend '回到>直到讀完路徑欄5 b; H0 L8 H- 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
" M1 k7 a" L6 `. z* ^( {* I; R8 ^能否直接给个excel表格文件，这个txt打开很多乱码，感谢2楼美女

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

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

judyyai 发表于 2015-6-27 16:18 static/image/common/back.gif5 d) {5 ~9 y6 M
原始檔案就是這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
) R) W% z- M/ ^! l; z谢谢自己写剩余的部分

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

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

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

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

留着慢慢用，先收藏了。

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

通知

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

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

浏览过的版块