求版大的用Excel批量修改工程图属性

昨天的今天

这个是台湾的几何网大侠做的，但是下载不了，请问这个坛子里有吗？求链接。
还有我想实现
将零件的自定义属性 中的“图号”和“零件名”提取出来自动将“图号”+“零件名”命名为新文件名，因为工程图出完肯定就是这种格式的命名，现在这样做就把零件和工程图的名字搞成一样了。
我知道这需要二次开发，现在我准备学习这个，早日实现自己想要的功能，加油！

x1990625

那裏的4#有原始碼~
轉過來了~原始檔案就是附檔 (若亂碼 請看以下代碼,中文請自行翻譯你們需要的文字語言
code.rar (2.22 KB, 下载次数: 76)

2015-12-31 19:06 上传

点击文件名下载附件
下载积分: 金币 -1

寫入屬性的程式碼

Sub WriteSlddrwPrp()
Set swApp = CreateObject("SldWorks.Application") '啟動SW
SavedFilesCount = 0
HeaderRow = 2
RowNumber = 2
RowNumber = HeaderRow + 1
PathName = Cells(RowNumber, 1) '讀取第一個路徑的值
While Not (PathName = "" Or PathName = 0 Or IsEmpty(PathName)) '直到讀完路徑欄
    Filename = Cells(RowNumber, 2)
    Set Drawing = Nothing
    If Dir(PathName & Filename) <> &quot;&quot; Then
        Set Drawing = swApp.OpenDoc(PathName & Filename, 3) '開啟工程圖
    End If
    If Not Drawing Is Nothing Then
        ColumnNumber = 3
        PropName = Cells(HeaderRow, ColumnNumber)
        While Not (PropName = &quot;&quot; Or PropName = 0 Or IsEmpty(PropName)) '直到讀完表頭
            PropValue = Cells(RowNumber, ColumnNumber)
            Drawing.DeleteCustomInfo2 &quot;&quot;, PropName '刪除屬性
            Drawing.AddCustomInfo3 &quot;&quot;, PropName, 30, PropValue '新增屬性
            ColumnNumber = ColumnNumber + 1 '下一欄
            PropName = Cells(HeaderRow, ColumnNumber)
        Wend '回到>直到讀完表頭
        Dim lErrors             As Long
        Dim lWarnings           As Long
        SaveOk = Drawing.Save3(1, lErrors, lWarnings)
        swApp.CloseDoc PathName & Filename '關閉工程圖
        If SaveOk Then Cells(RowNumber, 1).Interior.Color = RGB(255, 255, 127) 'SavedFilesCount = SavedFilesCount + 1
    End If
    RowNumber = RowNumber + 1 '下一列
    PathName = Cells(RowNumber, 1)
Wend '回到>直到讀完路徑欄
'MsgBox &quot;更新了 &quot; & SavedFilesCount & &quot; 個檔案&quot;
End Sub

复制代码
選擇檔案的程式碼

Sub BrowseDialog()
Dim intChoice As Integer
Dim FilePathName As String
Dim i As Integer
RowNumber = 3
PathName = Cells(RowNumber, 1) '讀取第一個路徑的值
While Not (PathName = &quot;&quot; Or PathName = 0 Or IsEmpty(PathName)) '直到讀完路徑欄(尋找繼續填寫的位置)
    RowNumber = RowNumber + 1 '下一列
    PathName = Cells(RowNumber, 1)
Wend '回到>直到讀完路徑欄
Application.FileDialog(msoFileDialogFilePicker).AllowMultiSelect = True '設定為多選對話框
Application.FileDialog(msoFileDialogFilePicker).Filters.Clear '清除既有類型
Application.FileDialog(msoFileDialogFilePicker).Filters.Add &quot;騷窩宮程圖&quot;, &quot;*.SLDDRW&quot; '設定檔案類型
intChoice = Application.FileDialog(msoFileDialogFilePicker).Show '彈出對話框
If intChoice <> 0 Then '判斷有否點選檔案
    For i = 1 To Application.FileDialog(msoFileDialogFilePicker).SelectedItems.Count '逐一讀取所選檔案
        FilePathName = Application.FileDialog(msoFileDialogFilePicker).SelectedItems(i) '讀取完整檔案名稱
        FilePath = Left(FilePathName, InStrRev(FilePathName, &quot;&quot;)) '分解路徑
        Filename = Right(FilePathName, Len(FilePathName) - Len(FilePath)) '分解檔案名稱
        Cells(i + RowNumber - 1, 1) = FilePath '填寫路徑
        Cells(i + RowNumber - 1, 2) = Filename '填寫檔案名稱
    Next i
End If
End Sub

复制代码
讀取屬性的程式碼

Sub ReadSlddrwPrp()
Set swApp = CreateObject(&quot;SldWorks.Application&quot;) '啟動SW
HeaderRow = 2
RowNumber = HeaderRow + 1
PathName = Cells(RowNumber, 1) '讀取第一個路徑的值
While Not (PathName = &quot;&quot; Or PathName = 0 Or IsEmpty(PathName)) '直到讀完路徑欄
    Filename = Cells(RowNumber, 2)
    Set Drawing = swApp.OpenDoc(PathName & Filename, 3) '開啟工程圖
    If Not Drawing Is Nothing Then
        ColumnNumber = 3
        PropName = Cells(HeaderRow, ColumnNumber)
        While Not (PropName = &quot;&quot; Or PropName = 0 Or IsEmpty(PropName)) '直到讀完表頭
            PropValue = Drawing.CustomInfo2(&quot;&quot;, PropName) 'GetCustomProperty(PropName, 30) '獲取屬性
            Cells(RowNumber, ColumnNumber) = PropValue
            ColumnNumber = ColumnNumber + 1 '下一欄
            PropName = Cells(HeaderRow, ColumnNumber)
        Wend '回到>直到讀完表頭
        swApp.CloseDoc PathName & Filename '關閉工程圖
        Cells(RowNumber, 1).Interior.Color = RGB(200, 255, 200)
    End If
    RowNumber = RowNumber + 1 '下一列
    PathName = Cells(RowNumber, 1)
Wend '回到>直到讀完路徑欄
End Sub

复制代码

顺~科恩凯达

能否直接给个excel表格文件，这个txt打开很多乱码，感谢2楼美女

葭苍海

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

chl88889

   经典案例图书

，厉害，看来我也要加油学习了！！

hdp

good

lanhai

   经典案例图书

厉害，看来我也要加油学习了！！

litao036

tk3681167

这个太复杂了，用凯元工具中的BOM工具读取所有的属性到一个表中，然后修改就可以了，代码自己弄不了

litao036

好东西，努力学习学习！

qq1633014799

收藏一下，以后下载有用

叶落满空山

好好学习，天天向上！

windy117

学习一下，二次开发

tzliang888126

说的什么意思，看到最后都被搞糊涂了

烦心天使

加入QQ群
参与讨论和学习

或扫描二维码加入

x1990625 发表于 2015-6-27 12:32
那裏的4#有原始碼~
轉過來了~原始檔案就是附檔 (若亂碼 請看以下代碼,中文請自行翻譯你們需要的文字語言

能否直接给个excel表格文件，这个txt打开很多乱码，感谢美女

Ayinyue

   经典案例图书

活到老学到老！

XBCYANP

加入QQ群
参与讨论和学习

或扫描二维码加入

活到老学到老！

沉默的人

   经典案例图书

好好学习，天天向上！