求闷大的用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()
7 [8 S3 f/ i" V& \* A, U' X
Set swApp = CreateObject("SldWorks.Application") '啟動SW( A4 F6 [; ?- ^6 |. ~& U! o
SavedFilesCount = 0( l3 _$ \( N# V; ]" Q% f% Z6 ?8 s( s1 ]
HeaderRow = 2# E6 o" W$ F, W$ g9 w1 u& W
RowNumber = 22 p8 n& }; S* M
RowNumber = HeaderRow + 1; P" X$ f$ S2 [1 D
PathName = Cells(RowNumber, 1) '讀取第一個路徑的值& I# d" g A) s8 L. U( x3 w
While Not (PathName = "" Or PathName = 0 Or IsEmpty(PathName)) '直到讀完路徑欄9 n6 U1 D$ c8 `/ T
Filename = Cells(RowNumber, 2)' J3 C( e% @+ g. s
Set Drawing = Nothing
' }( @0 }1 z$ T# m; d
If Dir(PathName & Filename) <> "" Then
% \! I- V" o6 B
Set Drawing = swApp.OpenDoc(PathName & Filename, 3) '開啟工程圖* M) J3 V6 f8 {3 S
End If
. d6 G' B2 ~" a
If Not Drawing Is Nothing Then5 A; @$ i, Q, F
ColumnNumber = 31 x. Z# m( j" B" Z4 Y4 O7 M
PropName = Cells(HeaderRow, ColumnNumber)1 n; |( D. g# v; I
While Not (PropName = "" Or PropName = 0 Or IsEmpty(PropName)) '直到讀完表頭
# b/ e% `9 C2 y1 p
PropValue = Cells(RowNumber, ColumnNumber)
0 F; E9 F' h- `
Drawing.DeleteCustomInfo2 "", PropName '刪除屬性
2 z$ u$ X2 v- X. V
Drawing.AddCustomInfo3 "", PropName, 30, PropValue '新增屬性
. b- ]0 x; K. F. V* u2 Z! u
ColumnNumber = ColumnNumber + 1 '下一欄8 ?% d' D- `& o0 q) A' t) w2 ]
PropName = Cells(HeaderRow, ColumnNumber)/ c0 b- H8 A7 W8 P6 T* I
Wend '回到>直到讀完表頭
: F$ f; D, r; ?- X8 ^! b
Dim lErrors As Long- o4 \/ a$ T% g* t0 j, \
Dim lWarnings As Long
( S* p H2 H3 ~
SaveOk = Drawing.Save3(1, lErrors, lWarnings)3 z4 ^9 c9 N; C8 K. X+ I: m
swApp.CloseDoc PathName & Filename '關閉工程圖
6 u$ F. R4 k' l3 b# p5 i
If SaveOk Then Cells(RowNumber, 1).Interior.Color = RGB(255, 255, 127) 'SavedFilesCount = SavedFilesCount + 1
, ~! |% H, O9 v
End If
* t$ h: E% M5 ]) P- A! P6 V! v1 D
RowNumber = RowNumber + 1 '下一列: v1 z+ E: `' c! } g; V
PathName = Cells(RowNumber, 1)
, D- r: Q0 A% h- X* o' g, m
Wend '回到>直到讀完路徑欄
- t1 Q& s- I9 t
'MsgBox "更新了 " & SavedFilesCount & " 個檔案"; x+ ~3 c6 D5 p+ m! e5 L* q& j( O; T+ h
End Sub

复制代码

選擇檔案的程式碼

Sub BrowseDialog()
8 t# Y4 ?% A$ D3 R' x1 b# X$ U
Dim intChoice As Integer+ \% `* |2 [: Z$ Z
Dim FilePathName As String
: }8 F: A! L! Y0 w3 |/ h
Dim i As Integer
' V ^6 B; Q: A; b+ _9 d+ M' a; h: e
RowNumber = 3
& M8 ^' j8 j) U
PathName = Cells(RowNumber, 1) '讀取第一個路徑的值
- U3 w( ~8 M; E2 W/ W) t
While Not (PathName = "" Or PathName = 0 Or IsEmpty(PathName)) '直到讀完路徑欄(尋找繼續填寫的位置)
! | Z7 K. \$ @! H( g. {" |: P4 o
RowNumber = RowNumber + 1 '下一列
+ T0 ?+ [* ]& d& N" {* ?
PathName = Cells(RowNumber, 1)) i* q/ ^/ H) n. q( n' p; U5 G
Wend '回到>直到讀完路徑欄+ O# c, n! E2 d$ _" O
Application.FileDialog(msoFileDialogFilePicker).AllowMultiSelect = True '設定為多選對話框
% I, E) [) R, S% B# Y, s
Application.FileDialog(msoFileDialogFilePicker).Filters.Clear '清除既有類型
- P8 I% ^! c6 a E5 ?' p& P
Application.FileDialog(msoFileDialogFilePicker).Filters.Add "騷窩宮程圖", "*.SLDDRW" '設定檔案類型 y! n1 r X$ E
intChoice = Application.FileDialog(msoFileDialogFilePicker).Show '彈出對話框! N3 v6 ]- }$ N1 C. w
If intChoice <> 0 Then '判斷有否點選檔案/ ]* ]1 h' _) H' e, o' `
For i = 1 To Application.FileDialog(msoFileDialogFilePicker).SelectedItems.Count '逐一讀取所選檔案
- [# W5 C2 _- ^9 K6 ~) Y
FilePathName = Application.FileDialog(msoFileDialogFilePicker).SelectedItems(i) '讀取完整檔案名稱
) W ?( j. [1 i% d6 f
FilePath = Left(FilePathName, InStrRev(FilePathName, "")) '分解路徑/ L5 g- y+ A b1 H$ p
Filename = Right(FilePathName, Len(FilePathName) - Len(FilePath)) '分解檔案名稱7 p5 w0 C5 I- k& L% j
Cells(i + RowNumber - 1, 1) = FilePath '填寫路徑+ r5 q) u2 [+ r5 X
Cells(i + RowNumber - 1, 2) = Filename '填寫檔案名稱 m& q" Y) ^. q; t( i
Next i
G h3 I5 |# s' i( p3 _. D
End If! a4 b% Z: g! }1 X
End Sub

复制代码

讀取屬性的程式碼

" @! o) z7 v, X P& e
Sub ReadSlddrwPrp()
0 ~4 c. W5 \2 Z6 h2 `6 s5 r
Set swApp = CreateObject("SldWorks.Application") '啟動SW
0 Y7 V, {( Z+ ?1 l2 @7 `( \0 {8 ]% Z
HeaderRow = 2
. W- |% z. l) |
RowNumber = HeaderRow + 11 u# b+ P7 p8 v% G8 u- U# t
PathName = Cells(RowNumber, 1) '讀取第一個路徑的值# {7 v. G, I7 m% P$ x
While Not (PathName = "" Or PathName = 0 Or IsEmpty(PathName)) '直到讀完路徑欄' n. h- {: R( F& b* o" e/ W
Filename = Cells(RowNumber, 2)
% @: J& r7 b. {8 J3 d+ ]
Set Drawing = swApp.OpenDoc(PathName & Filename, 3) '開啟工程圖, H9 Y- V1 v7 w4 X
If Not Drawing Is Nothing Then/ A9 _6 w: T3 F% }, e4 u
ColumnNumber = 3, ]; r7 |# p, U, d& n
PropName = Cells(HeaderRow, ColumnNumber)/ I. X \; P5 v: C
While Not (PropName = "" Or PropName = 0 Or IsEmpty(PropName)) '直到讀完表頭) x. o. v6 S" a# v5 r
PropValue = Drawing.CustomInfo2("", PropName) 'GetCustomProperty(PropName, 30) '獲取屬性
# M0 l( y: u1 d: j/ v
Cells(RowNumber, ColumnNumber) = PropValue
0 I4 _7 V& ?/ y* _% a
ColumnNumber = ColumnNumber + 1 '下一欄6 H3 E! B4 }" i
PropName = Cells(HeaderRow, ColumnNumber)7 Z- s5 j% ]- g3 B* f) F" e# I
Wend '回到>直到讀完表頭
5 q# e' ^3 n% q- I2 U
swApp.CloseDoc PathName & Filename '關閉工程圖" R! f$ |. E$ [5 t" f! u
Cells(RowNumber, 1).Interior.Color = RGB(200, 255, 200); b6 m8 G4 D: J& J, C" f
End If
; `! s$ ?, d% w7 C+ w9 g, y
RowNumber = RowNumber + 1 '下一列 Z; G7 d. f/ K' g
PathName = Cells(RowNumber, 1)$ r ]1 k. n& I' a
Wend '回到>直到讀完路徑欄
7 y6 n4 `$ F* ?
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
9 p5 ]' T3 s9 |; Y7 S4 a能否直接给个excel表格文件，这个txt打开很多乱码，感谢2楼美女

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

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

judyyai 发表于 2015-6-27 16:18 static/image/common/back.gif
' o9 T# {5 l4 g+ v% M3 C! k原始檔案就是這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
# E' _* J/ d* B# H4 b7 l谢谢自己写剩余的部分

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

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

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

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

留着慢慢用，先收藏了。

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

通知

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

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

浏览过的版块