求闷大的用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()
5 B& P! O V: {
Set swApp = CreateObject("SldWorks.Application") '啟動SW( H1 g5 N* e1 H7 }' u
SavedFilesCount = 0
; D: T4 D( \" ?& E1 _
HeaderRow = 2* z8 d- g1 u2 E
RowNumber = 2
/ l1 H: ]/ [* J* Q2 G. C
RowNumber = HeaderRow + 1/ J9 m, v* e, {# B& \
PathName = Cells(RowNumber, 1) '讀取第一個路徑的值
% M& m* R3 K, A: D8 p4 R
While Not (PathName = "" Or PathName = 0 Or IsEmpty(PathName)) '直到讀完路徑欄
8 I" h! U& n$ b* W+ A
Filename = Cells(RowNumber, 2)
, U2 w; M' w% B: ~; T2 l% R
Set Drawing = Nothing
$ `5 R/ K; K. Y) S; c
If Dir(PathName & Filename) <> "" Then
" P/ A4 {# [; Q1 A5 E$ e
Set Drawing = swApp.OpenDoc(PathName & Filename, 3) '開啟工程圖( s! A8 e; t& B) Q8 |9 z; M
End If! Y: ~$ _; c# e! N s2 u( j& ^ f- a
If Not Drawing Is Nothing Then, n& e0 |, n7 P( L$ x9 Q) X
ColumnNumber = 30 a2 C; C6 ~5 }; s: c- d- A
PropName = Cells(HeaderRow, ColumnNumber)$ o2 E) b! @9 { `" `' e1 R! N
While Not (PropName = "" Or PropName = 0 Or IsEmpty(PropName)) '直到讀完表頭( r, m5 k! w+ o5 d p0 |7 A1 {) H
PropValue = Cells(RowNumber, ColumnNumber)
5 v" ~7 O& I2 M7 O$ c8 |
Drawing.DeleteCustomInfo2 "", PropName '刪除屬性
+ z( g# c0 H% {" g* d8 T2 g
Drawing.AddCustomInfo3 "", PropName, 30, PropValue '新增屬性
( o' T5 z. y8 v: B& j( }8 s
ColumnNumber = ColumnNumber + 1 '下一欄
7 I4 ~; S9 F6 o& \: H3 y8 u
PropName = Cells(HeaderRow, ColumnNumber)
% E$ h& B; f9 l2 H u. k
Wend '回到>直到讀完表頭: B H4 w" `9 l& w7 B
Dim lErrors As Long7 `0 u+ |6 i; r+ c( `+ ^
Dim lWarnings As Long0 ]( O( \: T# H7 e% q$ W
SaveOk = Drawing.Save3(1, lErrors, lWarnings)
0 L$ {; U5 e9 y1 Q
swApp.CloseDoc PathName & Filename '關閉工程圖
* k2 ]6 L w9 ~& G s8 `. g
If SaveOk Then Cells(RowNumber, 1).Interior.Color = RGB(255, 255, 127) 'SavedFilesCount = SavedFilesCount + 16 ~* F, U$ w N7 W
End If/ y5 i6 j* O4 i
RowNumber = RowNumber + 1 '下一列
6 b7 g7 K3 D2 u" t/ n7 V
PathName = Cells(RowNumber, 1)* t7 y! d. T: M+ m( b
Wend '回到>直到讀完路徑欄0 Y6 z! Z. Q4 y6 v: Q% p7 j
'MsgBox "更新了 " & SavedFilesCount & " 個檔案"
1 O, ^/ e/ ~0 s' @5 w7 V; d6 h' F
End Sub

复制代码

選擇檔案的程式碼

Sub BrowseDialog()
I: A& _; l2 x
Dim intChoice As Integer/ A: S2 j3 x9 k. C7 o6 i4 F
Dim FilePathName As String
9 f% X$ p# G4 Z& M
Dim i As Integer& u7 H+ n, V7 U" b; P9 ~6 b. o
RowNumber = 3 i3 V% [4 X' f
PathName = Cells(RowNumber, 1) '讀取第一個路徑的值
% V: b' U# m6 E" d* P s: D. M
While Not (PathName = "" Or PathName = 0 Or IsEmpty(PathName)) '直到讀完路徑欄(尋找繼續填寫的位置)
; M" b' H5 y* v. n9 E9 B. }
RowNumber = RowNumber + 1 '下一列$ M& \) e$ L' ^ [
PathName = Cells(RowNumber, 1) U, z8 [1 L: }2 l& Z
Wend '回到>直到讀完路徑欄4 r @; v$ J ]: y
Application.FileDialog(msoFileDialogFilePicker).AllowMultiSelect = True '設定為多選對話框
$ E8 O& N3 b5 I
Application.FileDialog(msoFileDialogFilePicker).Filters.Clear '清除既有類型
9 J8 l, z, p$ O% A: s6 O
Application.FileDialog(msoFileDialogFilePicker).Filters.Add "騷窩宮程圖", "*.SLDDRW" '設定檔案類型$ `: m% {9 A+ ?$ E# s6 R0 P0 H& q
intChoice = Application.FileDialog(msoFileDialogFilePicker).Show '彈出對話框
& W: c9 \* W4 P0 I( N5 |; |
If intChoice <> 0 Then '判斷有否點選檔案6 H2 r( O/ x, J5 a, `
For i = 1 To Application.FileDialog(msoFileDialogFilePicker).SelectedItems.Count '逐一讀取所選檔案
# _7 k, e& v- w. u( t [
FilePathName = Application.FileDialog(msoFileDialogFilePicker).SelectedItems(i) '讀取完整檔案名稱
9 N# h/ Y# f2 W' _8 R7 C
FilePath = Left(FilePathName, InStrRev(FilePathName, "")) '分解路徑& ]3 [- X0 K) @# O' ^1 p
Filename = Right(FilePathName, Len(FilePathName) - Len(FilePath)) '分解檔案名稱5 i: {; }4 Y, s( N
Cells(i + RowNumber - 1, 1) = FilePath '填寫路徑 `) K5 y$ w9 j% n' F
Cells(i + RowNumber - 1, 2) = Filename '填寫檔案名稱; @! A0 O* G: g i
Next i
: _) e; ]. k* r
End If
) f: E% A$ I( S# N
End Sub

复制代码

讀取屬性的程式碼

1 y1 i1 m: B) B# l1 T& n
Sub ReadSlddrwPrp()
/ f6 k l# \: l" J) X( c" O
Set swApp = CreateObject("SldWorks.Application") '啟動SW4 H' A8 v1 x" _$ r6 F5 G- X
HeaderRow = 2
]4 V& S, i* X& i
RowNumber = HeaderRow + 1 [; i1 u- [8 S" y! _ j
PathName = Cells(RowNumber, 1) '讀取第一個路徑的值8 m) G4 i1 ?$ G
While Not (PathName = "" Or PathName = 0 Or IsEmpty(PathName)) '直到讀完路徑欄! j& |% P( ~/ O' e8 L7 t: L
Filename = Cells(RowNumber, 2)
# Y- @, b1 J2 h6 ~$ U
Set Drawing = swApp.OpenDoc(PathName & Filename, 3) '開啟工程圖& T, p$ h6 V" A8 Q
If Not Drawing Is Nothing Then. C9 m3 Z4 W% E" f( d
ColumnNumber = 3
- [" y# X; k' o0 s s8 ?
PropName = Cells(HeaderRow, ColumnNumber)+ ~( w6 t* s' X$ w; V- P4 U% A
While Not (PropName = "" Or PropName = 0 Or IsEmpty(PropName)) '直到讀完表頭7 E8 H( b) S' r+ f% l
PropValue = Drawing.CustomInfo2("", PropName) 'GetCustomProperty(PropName, 30) '獲取屬性9 w. K# V) D. ~1 N7 W6 d
Cells(RowNumber, ColumnNumber) = PropValue
) ?- X* `" ^+ K' j, `! d0 ~# m
ColumnNumber = ColumnNumber + 1 '下一欄- b. O+ i& k4 M# C; F
PropName = Cells(HeaderRow, ColumnNumber)- {0 q" k' i% I
Wend '回到>直到讀完表頭
0 O% m' D' h" q) x1 J
swApp.CloseDoc PathName & Filename '關閉工程圖 k* @" A S+ t8 C9 D, e" p1 [
Cells(RowNumber, 1).Interior.Color = RGB(200, 255, 200)
/ n: e- _, V0 e! v$ E
End If
( U/ A1 S0 A9 M# h4 B: t+ x' {
RowNumber = RowNumber + 1 '下一列& L g6 p1 t" L5 k: K4 \
PathName = Cells(RowNumber, 1)
4 a% X* O) h+ }8 [3 O0 y$ |
Wend '回到>直到讀完路徑欄. m9 q" o3 y, V A1 I* 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.gif2 v2 @2 z8 K9 [; p
能否直接给个excel表格文件，这个txt打开很多乱码，感谢2楼美女

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

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

judyyai 发表于 2015-6-27 16:18 static/image/common/back.gif
4 _* k, G: @6 B" O' v原始檔案就是這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:031 S8 N- p: t( l
谢谢自己写剩余的部分

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

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

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

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

留着慢慢用，先收藏了。

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

通知

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

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

浏览过的版块