求闷大的用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()2 Y4 j; [& L2 @7 J
Set swApp = CreateObject("SldWorks.Application") '啟動SW' k- }% r' ]' o
SavedFilesCount = 0
# O$ J( q9 }6 x9 G4 @$ o) @
HeaderRow = 2
1 O! ^. Y$ {. {" |. i
RowNumber = 2
5 o) k9 `' r# D0 f @+ q
RowNumber = HeaderRow + 1
9 U2 M/ g5 b* M" X: j+ _
PathName = Cells(RowNumber, 1) '讀取第一個路徑的值) s0 C. n' R# |9 g+ w7 E
While Not (PathName = "" Or PathName = 0 Or IsEmpty(PathName)) '直到讀完路徑欄/ ?& J2 d6 @& m/ e4 y2 c
Filename = Cells(RowNumber, 2): V9 u. m! \. m9 {9 z4 V$ G6 _, }6 z
Set Drawing = Nothing; z0 V% I1 P# k4 F
If Dir(PathName & Filename) <> "" Then
! T/ C( Q# j# L B( D: J# d
Set Drawing = swApp.OpenDoc(PathName & Filename, 3) '開啟工程圖+ C% w! r2 @1 N" [5 C9 m& r
End If
) O/ h+ |) } J
If Not Drawing Is Nothing Then/ e/ M$ D5 Q! V9 Q1 s8 S4 a
ColumnNumber = 3( f* {& l$ m+ ]: k
PropName = Cells(HeaderRow, ColumnNumber)! h8 M w V8 [
While Not (PropName = "" Or PropName = 0 Or IsEmpty(PropName)) '直到讀完表頭3 \1 [: e/ B; u% P) m8 P r
PropValue = Cells(RowNumber, ColumnNumber)( R1 ^* z* b" m2 h
Drawing.DeleteCustomInfo2 "", PropName '刪除屬性0 W5 q- J4 h2 v' w
Drawing.AddCustomInfo3 "", PropName, 30, PropValue '新增屬性; D9 K/ f# J- `
ColumnNumber = ColumnNumber + 1 '下一欄2 t% `* A. {5 N# I. ~
PropName = Cells(HeaderRow, ColumnNumber)& g7 W8 e1 m( z6 @( R) K
Wend '回到>直到讀完表頭3 ?4 @; R! I. F$ k/ X
Dim lErrors As Long
" x2 ^* s& H0 R+ G
Dim lWarnings As Long6 Q4 s% ^8 f* u$ G
SaveOk = Drawing.Save3(1, lErrors, lWarnings)2 u( t' H5 f( d4 ~9 i, F `
swApp.CloseDoc PathName & Filename '關閉工程圖
3 N" N7 S9 t$ ~8 e/ H9 ~
If SaveOk Then Cells(RowNumber, 1).Interior.Color = RGB(255, 255, 127) 'SavedFilesCount = SavedFilesCount + 1
. `- V# d9 V6 l) k! a
End If
9 G% D; F3 e+ e: J) i! l
RowNumber = RowNumber + 1 '下一列
; f( J7 B$ k; {4 W% H6 @
PathName = Cells(RowNumber, 1)
+ x. p% h. t* f: \ N; w
Wend '回到>直到讀完路徑欄7 M& `$ K* N6 n4 l; x9 @% [9 F
'MsgBox "更新了 " & SavedFilesCount & " 個檔案"
4 i' B0 E e" }" w7 u
End Sub

复制代码

選擇檔案的程式碼

Sub BrowseDialog()# Z. Z( C( @- y; p) @ ?, U
Dim intChoice As Integer: F1 b: ?. A5 o' r0 D" s
Dim FilePathName As String
5 T% B! Q; _$ h6 U" H) _
Dim i As Integer
( C* l4 X+ A1 s' M R
RowNumber = 3+ D2 y, E( s% |% ]& ?
PathName = Cells(RowNumber, 1) '讀取第一個路徑的值
! r Z1 W b, Z) p/ {0 J
While Not (PathName = "" Or PathName = 0 Or IsEmpty(PathName)) '直到讀完路徑欄(尋找繼續填寫的位置)
, A+ m. Y7 ~7 ]$ _
RowNumber = RowNumber + 1 '下一列) R Y1 F, y" x1 D
PathName = Cells(RowNumber, 1)5 l; ] ^* f$ C* U1 t/ ?& m- H# v
Wend '回到>直到讀完路徑欄" @* @0 q# U, D) T, {3 o
Application.FileDialog(msoFileDialogFilePicker).AllowMultiSelect = True '設定為多選對話框" [, q3 B& i. X8 c6 i% C/ _ L) _) W1 M
Application.FileDialog(msoFileDialogFilePicker).Filters.Clear '清除既有類型+ p/ Y4 {" l: R
Application.FileDialog(msoFileDialogFilePicker).Filters.Add "騷窩宮程圖", "*.SLDDRW" '設定檔案類型. I6 h$ R2 ?/ i0 i
intChoice = Application.FileDialog(msoFileDialogFilePicker).Show '彈出對話框* u* `- W+ \/ q- Q
If intChoice <> 0 Then '判斷有否點選檔案0 I" S# t! e* }
For i = 1 To Application.FileDialog(msoFileDialogFilePicker).SelectedItems.Count '逐一讀取所選檔案$ {0 q0 _6 B* E& T" O6 @" \5 d
FilePathName = Application.FileDialog(msoFileDialogFilePicker).SelectedItems(i) '讀取完整檔案名稱' o+ q7 ?8 l- l; F9 L$ k
FilePath = Left(FilePathName, InStrRev(FilePathName, "")) '分解路徑- i9 r# V5 x5 |" H% ? O# s
Filename = Right(FilePathName, Len(FilePathName) - Len(FilePath)) '分解檔案名稱
8 ^$ R, Q, u8 I: q
Cells(i + RowNumber - 1, 1) = FilePath '填寫路徑( Z1 v! f+ x$ j6 ]; P
Cells(i + RowNumber - 1, 2) = Filename '填寫檔案名稱
$ ?9 M4 f8 } f9 w6 w, K
Next i
7 `/ V/ a2 B1 @/ u
End If
; m: v ]- D e2 n* O) ^- ~
End Sub

复制代码

讀取屬性的程式碼

* j% y) L: d5 d% Q m# U& M: Q
Sub ReadSlddrwPrp()( Y; o5 r8 x: \- Y% W
Set swApp = CreateObject("SldWorks.Application") '啟動SW
6 ~: l7 `2 W! P j# `. d1 [+ M
HeaderRow = 2# X# V: Y' l3 y2 F8 X
RowNumber = HeaderRow + 1- f; n; g K0 c1 n3 s
PathName = Cells(RowNumber, 1) '讀取第一個路徑的值, A# O; }# M6 h
While Not (PathName = "" Or PathName = 0 Or IsEmpty(PathName)) '直到讀完路徑欄$ c5 v. s# u1 A8 d) O0 c& u5 N
Filename = Cells(RowNumber, 2)
3 o- X8 r) J9 o t0 P8 G' q- p, S
Set Drawing = swApp.OpenDoc(PathName & Filename, 3) '開啟工程圖3 `2 V7 n, _ f6 a5 ^' ?8 Z
If Not Drawing Is Nothing Then0 _* R$ ~+ P: | P
ColumnNumber = 3
! d: R& \" q$ J* \3 N3 ]
PropName = Cells(HeaderRow, ColumnNumber)
+ m; r6 b k# @8 I# O
While Not (PropName = "" Or PropName = 0 Or IsEmpty(PropName)) '直到讀完表頭2 u! G" L2 ?6 P; `2 _
PropValue = Drawing.CustomInfo2("", PropName) 'GetCustomProperty(PropName, 30) '獲取屬性- X5 E. Q ^) W) e
Cells(RowNumber, ColumnNumber) = PropValue/ J# d# H. t8 [- ?7 U% v
ColumnNumber = ColumnNumber + 1 '下一欄
7 M- c+ x5 d4 }9 ~4 M4 L
PropName = Cells(HeaderRow, ColumnNumber)5 m# L2 O5 Z1 v1 B4 v. Y
Wend '回到>直到讀完表頭2 |- B; }) j D9 b/ N4 T0 _% w
swApp.CloseDoc PathName & Filename '關閉工程圖5 ?) U: I& g" n/ [* ]
Cells(RowNumber, 1).Interior.Color = RGB(200, 255, 200)
' E- n# m, e$ L5 y
End If* h: A7 [ C" q; p9 m. `- w
RowNumber = RowNumber + 1 '下一列" i2 B) x8 Q$ o5 N+ g0 ?
PathName = Cells(RowNumber, 1) G/ ?2 {. h3 W2 N4 }9 h4 I
Wend '回到>直到讀完路徑欄
% u8 |* R; r0 ~' U* \
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.gif2 Q! P( h4 ~( V
能否直接给个excel表格文件，这个txt打开很多乱码，感谢2楼美女

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

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

judyyai 发表于 2015-6-27 16:18 static/image/common/back.gif
2 h. c6 x# W' H3 ]) t8 a原始檔案就是這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:030 Y5 N/ C1 z, D8 @! O4 U
谢谢自己写剩余的部分

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

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

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

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

留着慢慢用，先收藏了。

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

通知

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

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

浏览过的版块