求闷大的用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()
/ F2 D* c' }7 n; \3 T. X+ I& M
Set swApp = CreateObject("SldWorks.Application") '啟動SW
Q' M0 O% t# n) j
SavedFilesCount = 0) V: Z0 C2 o/ L7 z# \
HeaderRow = 2
9 q, f9 ^4 r/ m4 I2 D
RowNumber = 2) x9 a: S7 R# J, Z
RowNumber = HeaderRow + 1
, s: B j% c% R2 `5 k
PathName = Cells(RowNumber, 1) '讀取第一個路徑的值# _0 x3 }1 l! f5 ~& L! g$ U
While Not (PathName = "" Or PathName = 0 Or IsEmpty(PathName)) '直到讀完路徑欄) f" r6 G$ `8 v. T* c7 z! v1 N
Filename = Cells(RowNumber, 2)
# w+ [6 q$ {0 _, v8 I
Set Drawing = Nothing
6 u+ A) k2 D& R3 x
If Dir(PathName & Filename) <> "" Then+ K% @5 D2 ~, [) j+ h
Set Drawing = swApp.OpenDoc(PathName & Filename, 3) '開啟工程圖
: O3 K' I" k* t" Z1 n9 p0 o
End If0 J$ ?9 I2 {* T7 |" F
If Not Drawing Is Nothing Then0 I1 y, t& f" S/ I+ V
ColumnNumber = 3
X) W; e+ y' }9 p
PropName = Cells(HeaderRow, ColumnNumber)
7 C3 L7 c; A- P4 {
While Not (PropName = "" Or PropName = 0 Or IsEmpty(PropName)) '直到讀完表頭
$ `9 m6 j7 q z1 }- j9 K
PropValue = Cells(RowNumber, ColumnNumber)6 ?) }& `( [' X8 W, U# X4 o
Drawing.DeleteCustomInfo2 "", PropName '刪除屬性! b6 S- H/ m- J' |0 D _
Drawing.AddCustomInfo3 "", PropName, 30, PropValue '新增屬性+ _* T+ O3 y/ x* ]
ColumnNumber = ColumnNumber + 1 '下一欄
! ?8 c* i% I# y, k, |3 K
PropName = Cells(HeaderRow, ColumnNumber)
& _9 y7 J- d2 P0 r2 A% w
Wend '回到>直到讀完表頭7 k4 S- | B0 {% k2 R
Dim lErrors As Long
, ?( @3 v% H n* x7 P& {2 ?; N
Dim lWarnings As Long
, Y2 B3 J! C* W% ~0 A4 U
SaveOk = Drawing.Save3(1, lErrors, lWarnings)
swApp.CloseDoc PathName & Filename '關閉工程圖( R. `! x) y# s$ P/ k
If SaveOk Then Cells(RowNumber, 1).Interior.Color = RGB(255, 255, 127) 'SavedFilesCount = SavedFilesCount + 1& j7 H4 w# j3 D5 `5 r% {/ d
End If
+ N$ e6 ?4 s3 m% a( D7 t5 x' ?
RowNumber = RowNumber + 1 '下一列! r( O# I6 S4 ^9 M5 T1 [
PathName = Cells(RowNumber, 1)' y% I$ r/ I/ n1 _0 _1 p0 A. z
Wend '回到>直到讀完路徑欄- P, c6 }- _( _' p3 ^+ A
'MsgBox "更新了 " & SavedFilesCount & " 個檔案"
9 ~, k. m; O2 V, [
End Sub

复制代码

選擇檔案的程式碼

Sub BrowseDialog()
: M8 R+ f3 h& V7 p2 ?& S1 z
Dim intChoice As Integer
Dim FilePathName As String$ @( w; {0 _ _/ K. f }0 [
Dim i As Integer) U: b4 H% K" y" s4 R5 F4 a
RowNumber = 3
; |' h2 _8 {/ w' c2 j3 T3 C
PathName = Cells(RowNumber, 1) '讀取第一個路徑的值
& M( o' \# @2 p$ a5 C
While Not (PathName = "" Or PathName = 0 Or IsEmpty(PathName)) '直到讀完路徑欄(尋找繼續填寫的位置)
/ x, b7 u5 `% |
RowNumber = RowNumber + 1 '下一列1 N0 N7 W8 |4 b# V' p3 n$ y7 W- F
PathName = Cells(RowNumber, 1)
1 O/ S+ |" ~" h9 l+ I
Wend '回到>直到讀完路徑欄+ R( c7 s5 y2 }& o* X
Application.FileDialog(msoFileDialogFilePicker).AllowMultiSelect = True '設定為多選對話框/ b$ [! `9 F" `* E$ d) ~* L
Application.FileDialog(msoFileDialogFilePicker).Filters.Clear '清除既有類型
- u2 Y5 P9 _" y% \+ a1 i: A
Application.FileDialog(msoFileDialogFilePicker).Filters.Add "騷窩宮程圖", "*.SLDDRW" '設定檔案類型
& n3 Y. S! K g, a, a6 g8 `5 ?$ {
intChoice = Application.FileDialog(msoFileDialogFilePicker).Show '彈出對話框0 ^* a' @) R+ U T4 e' c) d' i2 H" I
If intChoice <> 0 Then '判斷有否點選檔案
/ o. j0 ?* f1 L& \0 J% {; `) c
For i = 1 To Application.FileDialog(msoFileDialogFilePicker).SelectedItems.Count '逐一讀取所選檔案
, Q* j: p$ s) b) P: X. C
FilePathName = Application.FileDialog(msoFileDialogFilePicker).SelectedItems(i) '讀取完整檔案名稱
. q6 ~2 F* x) o% k& N
FilePath = Left(FilePathName, InStrRev(FilePathName, "")) '分解路徑+ j2 h5 G' l. F/ d
Filename = Right(FilePathName, Len(FilePathName) - Len(FilePath)) '分解檔案名稱
1 {) u0 |$ l8 |# M* H
Cells(i + RowNumber - 1, 1) = FilePath '填寫路徑
$ `6 V( {4 R! D5 S) s7 A
Cells(i + RowNumber - 1, 2) = Filename '填寫檔案名稱
$ \1 ]# ` C1 x6 F$ M
Next i
# y! J6 s% X" A- b9 E
End If
5 c' D5 j" t& {5 _
End Sub

复制代码

讀取屬性的程式碼

o1 Q% E- W1 }' e) Y+ D
Sub ReadSlddrwPrp()
t7 L& F# y0 ^/ C4 R8 c0 |
Set swApp = CreateObject("SldWorks.Application") '啟動SW
; g( G$ V: S& u9 \6 U
HeaderRow = 2
% l! T) P$ C! q% o! i
RowNumber = HeaderRow + 1
: R/ z; W' f) Q$ s( x* T
PathName = Cells(RowNumber, 1) '讀取第一個路徑的值5 T1 `6 ?; N8 W, O* ~; Z( o
While Not (PathName = "" Or PathName = 0 Or IsEmpty(PathName)) '直到讀完路徑欄
/ a1 V* B j" t1 c I
Filename = Cells(RowNumber, 2)
0 ^7 y8 s% Z" z) A6 U) g6 k" v2 t
Set Drawing = swApp.OpenDoc(PathName & Filename, 3) '開啟工程圖
; O% g8 z/ r& R; v$ V7 v( ]/ c! G- z
If Not Drawing Is Nothing Then8 p( u+ _* m" L
ColumnNumber = 3
2 a1 u7 D+ _, y* {9 V. ~
PropName = Cells(HeaderRow, ColumnNumber)2 M! f( Z7 e! T. x* Q% P
While Not (PropName = "" Or PropName = 0 Or IsEmpty(PropName)) '直到讀完表頭& E8 u2 y+ p) _* Q) |
PropValue = Drawing.CustomInfo2("", PropName) 'GetCustomProperty(PropName, 30) '獲取屬性
5 t" G4 i4 ]+ [4 C4 S; |0 B7 l
Cells(RowNumber, ColumnNumber) = PropValue
7 s2 [7 F; o8 z) r, Q$ l6 \
ColumnNumber = ColumnNumber + 1 '下一欄2 Q8 D9 I) V% d" \3 r
PropName = Cells(HeaderRow, ColumnNumber)- b: |" `- Q* [- o3 b& d$ {, b$ Y
Wend '回到>直到讀完表頭
4 W" U: f& B( J- ~4 `1 A* M
swApp.CloseDoc PathName & Filename '關閉工程圖2 R6 b# b8 L! L% q x1 h/ [6 z- W1 @+ E
Cells(RowNumber, 1).Interior.Color = RGB(200, 255, 200)
+ s) g1 |5 h a! b; Z6 p
End If* e4 X6 Z* Z! z! \4 K
RowNumber = RowNumber + 1 '下一列' h4 C3 b! ^2 q" f( i
PathName = Cells(RowNumber, 1)6 C/ }1 \1 c' Z$ U7 ?; l
Wend '回到>直到讀完路徑欄
1 E8 a4 x' q6 m6 c7 i
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
* R: }4 @4 \% ~7 `能否直接给个excel表格文件，这个txt打开很多乱码，感谢2楼美女

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

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

judyyai 发表于 2015-6-27 16:18 static/image/common/back.gif- F; d4 d+ b. T4 f5 Y
原始檔案就是這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+ W% a, _" H, e6 `6 g. J
谢谢自己写剩余的部分

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

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

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

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

留着慢慢用，先收藏了。

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

通知

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

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

浏览过的版块