求闷大的用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 N! @4 o9 d. r& N. j
Set swApp = CreateObject("SldWorks.Application") '啟動SW M. q9 h3 Y c0 r( t# B' p, H/ u
SavedFilesCount = 07 P, P; F7 ]$ |: G6 z3 h
HeaderRow = 2
' V9 g- N7 h# p1 N* N4 {& _
RowNumber = 2+ R# c9 A) q2 I+ S- U. T) ?
RowNumber = HeaderRow + 1
4 L$ S' S2 u# |
PathName = Cells(RowNumber, 1) '讀取第一個路徑的值
8 e" z8 }1 ~0 N( e% n
While Not (PathName = "" Or PathName = 0 Or IsEmpty(PathName)) '直到讀完路徑欄! k* R7 A' ]1 t ]* B
Filename = Cells(RowNumber, 2)
( c) U+ ]8 n3 m! L' n& w
Set Drawing = Nothing
9 m0 r+ M! T* R) Z8 ^/ ^/ t
If Dir(PathName & Filename) <> "" Then4 b- e {9 I2 |7 u5 S! {7 w
Set Drawing = swApp.OpenDoc(PathName & Filename, 3) '開啟工程圖
: S* L0 Y7 ~: P7 x; I
End If
" _$ e7 ~5 t( _& h
If Not Drawing Is Nothing Then; [! f* O: d) L! c1 e
ColumnNumber = 3. {- `+ E3 }# U( D+ ~
PropName = Cells(HeaderRow, ColumnNumber)
6 H9 z$ M, x3 z1 o( h/ ~
While Not (PropName = "" Or PropName = 0 Or IsEmpty(PropName)) '直到讀完表頭
+ Q, |) I' n$ i9 L. z9 z" o
PropValue = Cells(RowNumber, ColumnNumber)
4 ?7 }! R% z& t5 W! d+ _
Drawing.DeleteCustomInfo2 "", PropName '刪除屬性/ k8 c: k; _0 x5 L
Drawing.AddCustomInfo3 "", PropName, 30, PropValue '新增屬性 I0 R8 @ ?0 N. H4 _8 ]3 t
ColumnNumber = ColumnNumber + 1 '下一欄7 W. p6 F7 W! q' y
PropName = Cells(HeaderRow, ColumnNumber)+ G" X/ n+ x7 l3 s5 J- v
Wend '回到>直到讀完表頭
, T j5 }* s3 @1 Y& x, X
Dim lErrors As Long
( Q# m$ d$ u" c2 Q/ ]1 K
Dim lWarnings As Long* J, o' F3 r( U |. L$ E6 J1 @
SaveOk = Drawing.Save3(1, lErrors, lWarnings)4 W" K- {$ E) o/ K$ R- A
swApp.CloseDoc PathName & Filename '關閉工程圖" l" o# A4 n" W C5 P4 O
If SaveOk Then Cells(RowNumber, 1).Interior.Color = RGB(255, 255, 127) 'SavedFilesCount = SavedFilesCount + 10 w3 }/ \3 ]- T, E! G: t
End If+ ^' b* a* D7 f9 v
RowNumber = RowNumber + 1 '下一列
9 R- p, ~! l* T3 b7 l- A' @
PathName = Cells(RowNumber, 1)
% p* D( I2 R( \. B
Wend '回到>直到讀完路徑欄0 _' I0 b3 S5 ^9 j% l# g$ M$ w
'MsgBox "更新了 " & SavedFilesCount & " 個檔案"
0 ?) s2 U1 K" M H; h4 A9 W8 N
End Sub

复制代码

選擇檔案的程式碼

Sub BrowseDialog()
! Z/ B% ^8 X' a/ y( r$ K
Dim intChoice As Integer
Dim FilePathName As String' s0 L6 T* Y9 l- y% l2 V
Dim i As Integer) H& f( q$ h* y) k& D- W$ B& \
RowNumber = 3
2 Z5 ^9 y- e# v! i! s
PathName = Cells(RowNumber, 1) '讀取第一個路徑的值. Z2 H+ |# r8 Z! V
While Not (PathName = "" Or PathName = 0 Or IsEmpty(PathName)) '直到讀完路徑欄(尋找繼續填寫的位置)6 A$ a7 e& ?- H6 f. o
RowNumber = RowNumber + 1 '下一列! G4 V) C6 Y/ I/ E" j8 V0 P# ?
PathName = Cells(RowNumber, 1)0 ^) \! l; j2 X* v3 E
Wend '回到>直到讀完路徑欄
' r, ^1 c$ V: ~
Application.FileDialog(msoFileDialogFilePicker).AllowMultiSelect = True '設定為多選對話框
7 d0 `: X# j& ?, S/ |3 H
Application.FileDialog(msoFileDialogFilePicker).Filters.Clear '清除既有類型% ^ _7 n6 ]% s2 @' {% N, T
Application.FileDialog(msoFileDialogFilePicker).Filters.Add "騷窩宮程圖", "*.SLDDRW" '設定檔案類型) w& Q5 ~, u7 `6 I+ d/ L1 g
intChoice = Application.FileDialog(msoFileDialogFilePicker).Show '彈出對話框2 ?' h+ a% `/ f' k7 F' L/ d
If intChoice <> 0 Then '判斷有否點選檔案
! n* J) n7 C6 a
For i = 1 To Application.FileDialog(msoFileDialogFilePicker).SelectedItems.Count '逐一讀取所選檔案
5 _! c0 \, u+ S4 i
FilePathName = Application.FileDialog(msoFileDialogFilePicker).SelectedItems(i) '讀取完整檔案名稱- k5 _: q& [1 H0 [, Y0 E- W$ E
FilePath = Left(FilePathName, InStrRev(FilePathName, "")) '分解路徑
: V. J3 i# f' R9 i
Filename = Right(FilePathName, Len(FilePathName) - Len(FilePath)) '分解檔案名稱- w/ q' N# v- k6 V3 z: y$ ~
Cells(i + RowNumber - 1, 1) = FilePath '填寫路徑2 i! u ]: n$ U- F" t1 D/ o/ }
Cells(i + RowNumber - 1, 2) = Filename '填寫檔案名稱+ e2 k! G8 W: N
Next i9 y! m/ j t' Y$ H7 a4 c4 W
End If" s' e2 w/ X, Q+ _% Y
End Sub

复制代码

讀取屬性的程式碼

- ]% L* m2 L9 I
Sub ReadSlddrwPrp()1 W8 F8 H0 d" D. o
Set swApp = CreateObject("SldWorks.Application") '啟動SW4 i9 O \& |: a: ^# |5 Q
HeaderRow = 2
) Z, r: P4 q( m+ X
RowNumber = HeaderRow + 1
6 `" [) _) p- s
PathName = Cells(RowNumber, 1) '讀取第一個路徑的值4 Y- ~$ C! G6 @1 Q
While Not (PathName = "" Or PathName = 0 Or IsEmpty(PathName)) '直到讀完路徑欄+ |3 _) I/ u1 Z& t
Filename = Cells(RowNumber, 2)" s0 Y" T e- K8 r: }8 e6 x
Set Drawing = swApp.OpenDoc(PathName & Filename, 3) '開啟工程圖
: N- I5 {' P, Z( p8 P
If Not Drawing Is Nothing Then$ S# m0 U8 P3 `$ Z; v, r
ColumnNumber = 3
/ `" e9 u0 O s& G
PropName = Cells(HeaderRow, ColumnNumber). C. ~& o$ x z+ {( S
While Not (PropName = "" Or PropName = 0 Or IsEmpty(PropName)) '直到讀完表頭4 `5 \1 S6 K+ V/ j- S. H
PropValue = Drawing.CustomInfo2("", PropName) 'GetCustomProperty(PropName, 30) '獲取屬性
7 ^: r$ [1 M5 s( Y. \
Cells(RowNumber, ColumnNumber) = PropValue) B z2 w2 ?0 S/ V+ I4 ?. Z
ColumnNumber = ColumnNumber + 1 '下一欄- [6 g4 {3 q! p6 E$ x- h% u, }) K
PropName = Cells(HeaderRow, ColumnNumber)4 m. R, {$ b9 E! i; U6 S
Wend '回到>直到讀完表頭; E4 h& \6 G4 d5 N2 g6 H. e
swApp.CloseDoc PathName & Filename '關閉工程圖
9 ?1 p2 N1 y- W9 ^+ P ^9 B2 ]
Cells(RowNumber, 1).Interior.Color = RGB(200, 255, 200)4 m' w1 O4 Y9 Y. |+ ^9 u1 m
End If' }- J, L4 n, C, L5 w
RowNumber = RowNumber + 1 '下一列7 k# z% z6 \' |- T; v' ]/ d
PathName = Cells(RowNumber, 1)( P# A3 v* n0 _( C7 q0 v
Wend '回到>直到讀完路徑欄
& s1 b# ]% e6 Q2 k1 t
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* x0 q. B. @% _2 j7 b5 g3 W( H. }7 z
能否直接给个excel表格文件，这个txt打开很多乱码，感谢2楼美女

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

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

judyyai 发表于 2015-6-27 16:18 static/image/common/back.gif6 B4 K5 y3 k8 S! s/ I3 G
原始檔案就是這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 t. t4 |5 x/ K! t' B谢谢自己写剩余的部分

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

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

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

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

留着慢慢用，先收藏了。

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

通知

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

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

浏览过的版块