求闷大的用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()% }. r5 B# d* ~- u( O
Set swApp = CreateObject("SldWorks.Application") '啟動SW$ X5 k$ L8 u* C# ?
SavedFilesCount = 0
o( b( E/ z7 C1 z1 ]1 K
HeaderRow = 2
+ L$ ^& g, k: B. k
RowNumber = 2* `1 g$ ~5 _. g; ]+ O
RowNumber = HeaderRow + 1
) _- k9 z6 ~- ?1 @) n" W1 B2 ]
PathName = Cells(RowNumber, 1) '讀取第一個路徑的值
6 S" o7 Q9 s( n. U% v+ X
While Not (PathName = "" Or PathName = 0 Or IsEmpty(PathName)) '直到讀完路徑欄4 |0 y. T: s( i/ b9 M
Filename = Cells(RowNumber, 2)
2 t7 x+ }& e8 _- ?9 A9 h
Set Drawing = Nothing
T* d$ }' G- ~' |5 G
If Dir(PathName & Filename) <> "" Then% N! p6 s) q+ s2 F. w! r, a
Set Drawing = swApp.OpenDoc(PathName & Filename, 3) '開啟工程圖# f7 s0 _" @1 ~
End If0 N. R. J+ o; o- H5 t7 t7 r
If Not Drawing Is Nothing Then# h8 O; [! q; c0 z D
ColumnNumber = 33 b9 k7 z. ]+ x: F
PropName = Cells(HeaderRow, ColumnNumber)
; A( Q H! m: d Q* j9 E% p
While Not (PropName = "" Or PropName = 0 Or IsEmpty(PropName)) '直到讀完表頭6 O d V& |$ x1 n
PropValue = Cells(RowNumber, ColumnNumber)
, O0 o2 G$ M: ~( V4 J5 ?
Drawing.DeleteCustomInfo2 "", PropName '刪除屬性
9 R- m" `% h# v! A
Drawing.AddCustomInfo3 "", PropName, 30, PropValue '新增屬性
7 @, ] }/ A1 }
ColumnNumber = ColumnNumber + 1 '下一欄6 w6 X: N8 f& }/ g4 x( C
PropName = Cells(HeaderRow, ColumnNumber)
2 O8 X6 r# E" v. B5 A" s# t9 x
Wend '回到>直到讀完表頭
7 g6 G& ^$ Q! {9 ]- R) |* j r
Dim lErrors As Long- F- e1 q- ]+ M4 P- z$ } n. D
Dim lWarnings As Long }0 a1 _' r& ^9 @$ Y3 K5 ?: |3 j5 C
SaveOk = Drawing.Save3(1, lErrors, lWarnings)' @; @' f6 O$ o; b: D6 q
swApp.CloseDoc PathName & Filename '關閉工程圖8 s# D# V7 e8 p8 N; B p, I4 L8 R
If SaveOk Then Cells(RowNumber, 1).Interior.Color = RGB(255, 255, 127) 'SavedFilesCount = SavedFilesCount + 1) N, x G. g5 z; b4 O) P
End If; F: H% D7 ^8 N
RowNumber = RowNumber + 1 '下一列
1 F8 S$ d0 t4 Q
PathName = Cells(RowNumber, 1)
0 r+ N$ V) `7 c3 |$ o" C( {5 u/ r
Wend '回到>直到讀完路徑欄* c0 m. q* @- E' L, F3 d
'MsgBox "更新了 " & SavedFilesCount & " 個檔案"
: o$ _0 r! O( r5 L" s' @; f8 i7 Y
End Sub

复制代码

選擇檔案的程式碼

Sub BrowseDialog()
5 [ U! i- m. Z2 m' m
Dim intChoice As Integer3 c+ \- p( ]# ~4 Q8 d. ~
Dim FilePathName As String
4 V1 a- k% o! \, d8 f( l2 _
Dim i As Integer% k1 H5 n9 W7 W$ N2 N
RowNumber = 3
7 P/ [2 H2 W4 h* l
PathName = Cells(RowNumber, 1) '讀取第一個路徑的值* P3 l- s' Y( P" ~! x+ `! k4 z& {
While Not (PathName = "" Or PathName = 0 Or IsEmpty(PathName)) '直到讀完路徑欄(尋找繼續填寫的位置)
% i0 l8 f! B3 o5 \
RowNumber = RowNumber + 1 '下一列! a, h# U# x4 A) B
PathName = Cells(RowNumber, 1)5 O6 j3 k( k6 ^6 b5 b" [) P3 l
Wend '回到>直到讀完路徑欄
+ g# {1 M! e5 A6 R9 d9 D
Application.FileDialog(msoFileDialogFilePicker).AllowMultiSelect = True '設定為多選對話框
% O. e( F: W5 R
Application.FileDialog(msoFileDialogFilePicker).Filters.Clear '清除既有類型; P6 ?# B7 f. h( J* m, s6 d
Application.FileDialog(msoFileDialogFilePicker).Filters.Add "騷窩宮程圖", "*.SLDDRW" '設定檔案類型3 P+ Q' s4 {! B# t
intChoice = Application.FileDialog(msoFileDialogFilePicker).Show '彈出對話框
( J2 E; r# @3 d2 }6 s1 U
If intChoice <> 0 Then '判斷有否點選檔案2 R7 B; U y! y. f* B
For i = 1 To Application.FileDialog(msoFileDialogFilePicker).SelectedItems.Count '逐一讀取所選檔案- Q6 v! [ e$ A; w I
FilePathName = Application.FileDialog(msoFileDialogFilePicker).SelectedItems(i) '讀取完整檔案名稱
: o! n: s& I0 x) l4 k8 G
FilePath = Left(FilePathName, InStrRev(FilePathName, "")) '分解路徑
2 S7 L$ E2 ~. i0 k% F
Filename = Right(FilePathName, Len(FilePathName) - Len(FilePath)) '分解檔案名稱
0 ~# {1 E2 x. q# ?
Cells(i + RowNumber - 1, 1) = FilePath '填寫路徑# l& m" W3 y1 [# c" [+ c; d G
Cells(i + RowNumber - 1, 2) = Filename '填寫檔案名稱
# k5 e& e: R ]/ ?& G
Next i
% u, Q1 m9 `( I7 g
End If
- _( G3 _* ~8 |4 c! J
End Sub

复制代码

讀取屬性的程式碼

$ J/ t" A; ~; A* G) L
Sub ReadSlddrwPrp()- a3 v! X$ X' X, V+ O
Set swApp = CreateObject("SldWorks.Application") '啟動SW1 ^4 D W1 n/ {4 r
HeaderRow = 23 A! v, ^( s2 d+ k
RowNumber = HeaderRow + 1) i5 q; ?, n$ d2 L
PathName = Cells(RowNumber, 1) '讀取第一個路徑的值: j7 B* A5 ]2 L4 L0 {$ b
While Not (PathName = "" Or PathName = 0 Or IsEmpty(PathName)) '直到讀完路徑欄
3 S" _1 R4 S5 W) F+ @
Filename = Cells(RowNumber, 2)% R# R* g% c+ v. n `
Set Drawing = swApp.OpenDoc(PathName & Filename, 3) '開啟工程圖% J e# t' m$ T+ D# u y7 R3 G4 `
If Not Drawing Is Nothing Then6 u7 u7 H& i& X
ColumnNumber = 3 p5 H3 x- d9 ^; C, m4 N0 h
PropName = Cells(HeaderRow, ColumnNumber)
% \: h! Q# a+ \: W
While Not (PropName = "" Or PropName = 0 Or IsEmpty(PropName)) '直到讀完表頭- L% \! [' p" b$ Z
PropValue = Drawing.CustomInfo2("", PropName) 'GetCustomProperty(PropName, 30) '獲取屬性/ m5 u7 s# o* r5 i/ z
Cells(RowNumber, ColumnNumber) = PropValue H3 ~! H& O' L$ b! k0 k
ColumnNumber = ColumnNumber + 1 '下一欄$ c9 \- j9 E3 R8 M2 {5 @
PropName = Cells(HeaderRow, ColumnNumber)) ]# B) {( {$ F* ]
Wend '回到>直到讀完表頭
+ s8 Z, w* i, ]2 k, S, C {
swApp.CloseDoc PathName & Filename '關閉工程圖/ l) a. g' q- E. I: v
Cells(RowNumber, 1).Interior.Color = RGB(200, 255, 200)
6 |5 P( h: k( _; P
End If( R; F+ [' N; j% T5 z* [2 Z
RowNumber = RowNumber + 1 '下一列6 E1 M' B" k( O G+ M
PathName = Cells(RowNumber, 1)
$ p, `1 x7 p4 F. t- z5 }
Wend '回到>直到讀完路徑欄
# i; F& @+ e& Z4 e
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.gif9 B& T3 H+ V0 O) S. g" k9 `
能否直接给个excel表格文件，这个txt打开很多乱码，感谢2楼美女

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

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

judyyai 发表于 2015-6-27 16:18 static/image/common/back.gif' x1 G# H. c# T) X2 e. t* E4 X
原始檔案就是這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
- N; X8 I. u) l! a, Q7 z谢谢自己写剩余的部分

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

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

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

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

留着慢慢用，先收藏了。

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

通知

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

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

浏览过的版块