关于批量修改零件属性的问题 - iCAx开思网

'
'Dim swDM As SwDMApplication
'Dim swDoc As SwDMDocument12
'Dim mOpenErrors As SwDmDocumentOpenError
'Dim swCfgMgr As SwDMConfigurationMgr
'Dim objClassfac As SwDMClassFactory
'Const SWDMLicenseKey = "C45DA6BCACBC9A3864AD7ACAB1C78A17EE34AFA74DDAFF6E"
Sub 打开文件()
Range("A3").Activate
'Set objClassfac = CreateObject("SwDocumentMgr.SwDMClassFactory")
'Set swDM = objClassfac.GetApplication(SWDMLicenseKey) '啟動SWDM
Set swApp = CreateObject("SldWorks.Application") '启动SW
Dim intChoice As Integer
Dim FilePathName As String
Dim i As Integer
HeaderRow = 2
RowNumber = 3
PathName = Cells(RowNumber, 1) '讀取第一個路徑的值
While Not (PathName = "" 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 "零件自定义属性", "*.SLDPRT" '設定檔案類型
Application.FileDialog(msoFileDialogFilePicker).Filters.Add "零件配置属性", "*.SLDPRT" '設定檔案類型
Application.FileDialog(msoFileDialogFilePicker).Filters.Add "装配体自定义属性", "*.SLDASM" '設定檔案類型
Application.FileDialog(msoFileDialogFilePicker).Filters.Add "装配体配置属性", "*.SLDASM" '設定檔案類型
Application.FileDialog(msoFileDialogFilePicker).Filters.Add "工程图属性", "*.SLDDRW" '設定檔案類型
If Cells(1, 1) = 1 Or Cells(1, 1) = 2 Or Cells(1, 1) = 3 Or Cells(1, 1) = 4 Or Cells(1, 1) = 5 Then
Application.FileDialog(msoFileDialogFilePicker).FilterIndex = Cells(1, 1)
End If
If Cells(1, 2) <> "" Then Application.FileDialog(msoFileDialogFilePicker).InitialFileName = Cells(1, 2)
intChoice = Application.FileDialog(msoFileDialogFilePicker).Show '彈出對話框
If intChoice <> 0 Then '判斷有否點選檔案
RowCount = 1
swFilterIndex = Application.FileDialog(msoFileDialogFilePicker).FilterIndex
For i = 1 To Application.FileDialog(msoFileDialogFilePicker).SelectedItems.Count '逐一讀取所選檔案
FilePathName = Application.FileDialog(msoFileDialogFilePicker).SelectedItems(i) '讀取完整檔案名稱
FilePath = Left(FilePathName, InStrRev(FilePathName, "")) '分解路徑
Filename = Right(FilePathName, Len(FilePathName) - Len(FilePath)) '分解檔案名稱
FileExtname = UCase(Right(FilePathName, 6)) '分解檔案類型
If swFilterIndex = 1 Or swFilterIndex = 3 Or swFilterIndex = 5 Then
Cells(RowCount + RowNumber - 1, 1) = FilePath '填寫路徑
Cells(RowCount + RowNumber - 1, 2) = Filename '填寫檔案名稱
RowCount = RowCount + 1
End If
If swFilterIndex = 2 Or swFilterIndex = 4 Then '過濾器是2或4
Set swDoc = swDM.GetDocument(PathName & Filename, swFileTYpe, False, mOpenErrors) '開啟檔案
If Not swDoc Is Nothing Then '排除無效檔案
Set swCfgMgr = swDoc.ConfigurationManager
swConfigNames = swCfgMgr.GetConfigurationNames
ConfigColor = 200
For Each swConfigName In swConfigNames
Cells(RowCount + RowNumber - 1, 1) = FilePath '填寫路徑
Cells(RowCount + RowNumber - 1, 2) = Filename '填寫檔案名稱
Cells(RowCount + RowNumber - 1, 3).NumberFormatLocal = "@" '设为“文本”格式
Cells(RowCount + RowNumber - 1, 3) = swConfigName '填寫模型組態名稱
Cells(RowCount + RowNumber - 1, 3).Errors.Item(xlNumberAsText).Ignore = True '去除三角错误
Cells(RowCount + RowNumber - 1, 3).Interior.Color = RGB(ConfigColor, ConfigColor, ConfigColor)
RowCount = RowCount + 1
Next
swDoc.CloseDoc '關閉檔案
End If '排除無效檔案<完>
End If ''過濾器是2或4<完>
Next i '逐一讀取所選檔案<完>
End If '判斷有否點選檔案<完>
End Sub

复制代码