求闷大的用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 w: T" B) n5 n
Set swApp = CreateObject("SldWorks.Application") '啟動SW
' w) V7 ^2 }% V4 r: \
SavedFilesCount = 0- s: P/ \; g5 H9 ?
HeaderRow = 2* L( R q0 \4 ?& t& l1 |
RowNumber = 27 `1 y4 T. X, d5 q, E3 ^
RowNumber = HeaderRow + 18 z0 V, ~- i! E( Z2 \0 j
PathName = Cells(RowNumber, 1) '讀取第一個路徑的值
* h" l& k- A& e6 o8 x: E( U
While Not (PathName = "" Or PathName = 0 Or IsEmpty(PathName)) '直到讀完路徑欄& {2 J/ K- s1 I
Filename = Cells(RowNumber, 2)
, K" v5 Z* G$ k3 Z4 q
Set Drawing = Nothing
5 C' b4 t( Z" X& q: o1 z6 y
If Dir(PathName & Filename) <> "" Then8 e+ X9 m+ @5 x: f& ]: e
Set Drawing = swApp.OpenDoc(PathName & Filename, 3) '開啟工程圖; b8 M. I# `5 Z
End If
4 k0 H4 M: D# K. f* W3 B
If Not Drawing Is Nothing Then
1 I- v9 T4 h9 P, q$ H, v+ Q$ Y
ColumnNumber = 38 z7 [3 {0 c$ `
PropName = Cells(HeaderRow, ColumnNumber)# _7 M+ D$ g: T2 {6 t+ W
While Not (PropName = "" Or PropName = 0 Or IsEmpty(PropName)) '直到讀完表頭$ K6 `- ~7 V, Y
PropValue = Cells(RowNumber, ColumnNumber)
0 L7 a& o! y' d) l5 k
Drawing.DeleteCustomInfo2 "", PropName '刪除屬性5 \. M% [+ ^; { I# F
Drawing.AddCustomInfo3 "", PropName, 30, PropValue '新增屬性
2 Q j" G$ g1 P
ColumnNumber = ColumnNumber + 1 '下一欄
; r& |+ N# A- B- `8 K! k0 v
PropName = Cells(HeaderRow, ColumnNumber)2 e4 Q( d( S5 j6 K2 ]2 k
Wend '回到>直到讀完表頭( F0 [; S0 S. f. |
Dim lErrors As Long
+ L" \' b) k* [- H
Dim lWarnings As Long7 |: ?1 D+ L) h. F
SaveOk = Drawing.Save3(1, lErrors, lWarnings)8 I7 |0 X; U3 |$ d) C
swApp.CloseDoc PathName & Filename '關閉工程圖1 G1 H4 T+ G+ H. C0 S% [6 c5 W0 m
If SaveOk Then Cells(RowNumber, 1).Interior.Color = RGB(255, 255, 127) 'SavedFilesCount = SavedFilesCount + 1
' m0 r, D, S8 k
End If
/ r+ D, H# H$ X8 A( }% c
RowNumber = RowNumber + 1 '下一列2 z0 w7 T2 x# N# k# J% H
PathName = Cells(RowNumber, 1)9 t) x& u* ~0 k& Z8 I; H7 Y7 w
Wend '回到>直到讀完路徑欄- i' j0 A( h. g0 D' y8 a0 B. `
'MsgBox "更新了 " & SavedFilesCount & " 個檔案"
) ~; V Y4 u" a: d& L
End Sub

复制代码

選擇檔案的程式碼

Sub BrowseDialog()* B& N) H+ @7 {$ c
Dim intChoice As Integer
% o; h! N$ j! M& l) D3 j
Dim FilePathName As String
0 X. F7 B9 R; i. ]% _$ g/ k L
Dim i As Integer, h6 R' S( L: ~# ~9 ]) }. W
RowNumber = 3
1 v" R4 f9 `! S1 m
PathName = Cells(RowNumber, 1) '讀取第一個路徑的值8 a' [4 m P1 l' ?; ~; [
While Not (PathName = "" Or PathName = 0 Or IsEmpty(PathName)) '直到讀完路徑欄(尋找繼續填寫的位置)! P& B# w- J; j$ j$ A3 S
RowNumber = RowNumber + 1 '下一列. ?8 \0 K1 S0 V2 v1 s2 f
PathName = Cells(RowNumber, 1)
; X& p" r m3 n$ h0 |+ I
Wend '回到>直到讀完路徑欄( T8 v8 [- R7 o* j0 g' N$ f4 @
Application.FileDialog(msoFileDialogFilePicker).AllowMultiSelect = True '設定為多選對話框) l0 P4 ?( @5 I7 {' U/ E; M' d
Application.FileDialog(msoFileDialogFilePicker).Filters.Clear '清除既有類型( V8 G2 l4 C- T
Application.FileDialog(msoFileDialogFilePicker).Filters.Add "騷窩宮程圖", "*.SLDDRW" '設定檔案類型9 ]4 w; W6 t' G1 D4 G( t) B, K
intChoice = Application.FileDialog(msoFileDialogFilePicker).Show '彈出對話框. p8 V G& J* y s3 W( j( q. V
If intChoice <> 0 Then '判斷有否點選檔案# t% B g" p0 s5 s( c# K/ R) C
For i = 1 To Application.FileDialog(msoFileDialogFilePicker).SelectedItems.Count '逐一讀取所選檔案
! c7 ?9 q4 Y7 p7 f6 [! ~2 i/ Z6 k
FilePathName = Application.FileDialog(msoFileDialogFilePicker).SelectedItems(i) '讀取完整檔案名稱0 M; k, ?# s6 v; W$ l
FilePath = Left(FilePathName, InStrRev(FilePathName, "")) '分解路徑
5 d& O0 Q# d9 A8 ?: p N+ |- n
Filename = Right(FilePathName, Len(FilePathName) - Len(FilePath)) '分解檔案名稱7 N! {3 m& y3 w& p
Cells(i + RowNumber - 1, 1) = FilePath '填寫路徑
6 S. P+ I0 z( k& S0 i5 Z' w+ ~3 L9 [
Cells(i + RowNumber - 1, 2) = Filename '填寫檔案名稱
a1 k0 D$ H2 L* c$ {8 `0 H* |, W
Next i
/ o! B+ l& x' ^2 E h7 B
End If
$ u2 W0 @1 s+ u6 ?* n. N
End Sub

复制代码

讀取屬性的程式碼

9 ]' [( g9 H& A+ ^8 r
Sub ReadSlddrwPrp()
B1 X2 H0 R# @3 F6 v+ {: T
Set swApp = CreateObject("SldWorks.Application") '啟動SW) V2 P$ Q6 f, n7 Q! h0 E: X. Q
HeaderRow = 2& o. V8 ~ c' U
RowNumber = HeaderRow + 1 }6 s4 L$ @5 j2 H1 N2 N
PathName = Cells(RowNumber, 1) '讀取第一個路徑的值0 ]3 Y3 Y: Y; ?8 v R. B
While Not (PathName = "" Or PathName = 0 Or IsEmpty(PathName)) '直到讀完路徑欄0 K) I% B( f/ W x
Filename = Cells(RowNumber, 2)" i' ~5 e: Q1 R5 {
Set Drawing = swApp.OpenDoc(PathName & Filename, 3) '開啟工程圖/ S) [! _6 k j, H
If Not Drawing Is Nothing Then" o# n. T, y N, P
ColumnNumber = 32 f1 J2 K. }! G$ e9 \) {
PropName = Cells(HeaderRow, ColumnNumber)% R4 W' P r7 q6 h7 o
While Not (PropName = "" Or PropName = 0 Or IsEmpty(PropName)) '直到讀完表頭$ F# l8 L8 i. X6 W
PropValue = Drawing.CustomInfo2("", PropName) 'GetCustomProperty(PropName, 30) '獲取屬性$ C! \1 V* ]# |; \9 J& @" s, m
Cells(RowNumber, ColumnNumber) = PropValue
, q. L2 E/ [3 e0 S8 h4 C7 D
ColumnNumber = ColumnNumber + 1 '下一欄
* C. x7 e9 u K1 |+ k }
PropName = Cells(HeaderRow, ColumnNumber), e6 o1 [. p- i, ?7 e2 B
Wend '回到>直到讀完表頭
7 n9 F( S* Z' W$ M
swApp.CloseDoc PathName & Filename '關閉工程圖5 ~0 C; I5 H1 F4 Y, e5 H
Cells(RowNumber, 1).Interior.Color = RGB(200, 255, 200)
7 z+ Q" | N4 h+ i8 m. r8 j
End If" X7 |; N: I9 [- p) L
RowNumber = RowNumber + 1 '下一列
% X0 y7 s: b* M9 _
PathName = Cells(RowNumber, 1)
% o7 c2 T: \* `
Wend '回到>直到讀完路徑欄9 S- i' E8 O$ H! \2 J: `6 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.gif
( }- S" K1 X% u. }能否直接给个excel表格文件，这个txt打开很多乱码，感谢2楼美女

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

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

judyyai 发表于 2015-6-27 16:18 static/image/common/back.gif
9 J/ S% @( v9 t0 |原始檔案就是這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 E3 a3 S% o n' r
谢谢自己写剩余的部分

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

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

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

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

留着慢慢用，先收藏了。

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

通知

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

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

浏览过的版块