excel VBA 批量更改solidworks 属性的问题 - iCAx开思网

Dim swDM As SwDMApplication
Dim swDoc As SwDMDocument12
Dim mOpenErrors As SwDmDocumentOpenError
Dim swCfgMgr As SwDMConfigurationMgr
Dim objClassfac As SwDMClassFactory
Dim vCustPropNameArr As Variant
Const SWDMLicenseKey = ""
Sub 打开文件()
Range("A3").Activate
Set objClassfac = CreateObject("SwDocumentMgr.SwDMClassFactory")
Set swDM = objClassfac.GetApplication(SWDMLicenseKey) '啟動SWDM
Dim vCfgNameArr As Object
Dim vCfgName As Object
Dim swCfg As SwDMConfiguration '14
Dim nPropType As Long
Dim PropList() As String
ReDim PropList(0)
PropList(0) = ""
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
For Each swConfigName In swConfigNames
Set swCfg = swCfgMgr.GetConfigurationByName(swConfigName)
vCustPropNameArr = swCfg.GetCustomPropertyNames
If TypeName(vCustPropNameArr) = "String()" Then
End If
Cells(RowCount + RowNumber - 1, 1) = FilePath '填寫路徑
Cells(RowCount + RowNumber - 1, 2) = FileName '填寫檔案名稱
Cells(RowCount + RowNumber - 1, 3) = swConfigName '填寫模型組態名稱
Cells(RowCount + RowNumber - 1, 3).Interior.Color = RGB(200, 200, 200)
RowCount = RowCount + 1
Next
swDoc.CloseDoc '關閉檔案
End If '排除無效檔案<完>
End If ''過濾器是2或4<完>
Next i '逐一讀取所選檔案<完>
End If '判斷有否點選檔案<完>
End Sub

复制代码