Sub 打开文件()
Range("A3").Activate
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
swConfigNames = swApp.GetConfigurationNames(FilePathName)
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
End If '排除無效檔案<完>
Next i '逐一讀取所選檔案<完>
End If '判斷有否點選檔案<完>
End Sub
Sub 读取配置特性属性值()
Dim HeaderRow As Integer
Dim RowNumber As Integer
Dim FileName As String
Dim swExtName As String
Dim swFileTYpe As Integer
Dim swConfigName As String
Dim vCustPropName
Dim PropValue As String
HeaderRow = 2
RowNumber = HeaderRow + 1
PathName = Cells(RowNumber, 1) '讀取第一個路徑的值
While Not (PathName = "" Or PathName = 0 Or IsEmpty(PathName)) '直到讀完路徑欄
FileName = Trim(Cells(RowNumber, 2))
FileExtname = UCase(Right(Cells(RowNumber, 2), 6))
If "SLDPRT" = FileExtname Then swFileTYpe = 1
If "SLDASM" = FileExtname Then swFileTYpe = 2
If "SLDDRW" = FileExtname Then swFileTYpe = 3
' Set swDoc = swDM.GetDocument(PathName & FileName, swFileTYpe, False, mOpenErrors) '開啟
If Not swDoc Is Nothing Then
If swFileTYpe = 1 Or swFileTYpe = 2 Then
If Not (Cells(RowNumber, 3) = "" Or Cells(RowNumber, 3) = 0) Then
Set swCfgMgr = swDoc.ConfigurationManager
swConfigName = Cells(RowNumber, 3)
Set swCfg = swCfgMgr.GetConfigurationByName(swConfigName)
End If
End If
ColumnNumber = 4
PropName = Cells(HeaderRow, ColumnNumber)
While Not (PropName = "" Or PropName = 0) 'Or IsEmpty(PropName)) '直到讀完表頭
PropName = PropName & ""
If PropName = "$Author$" Then '作者
Cells(RowNumber, ColumnNumber) = swDoc.Author
ElseIf PropName = "$Keywords$" Then '標記
Cells(RowNumber, ColumnNumber) = swDoc.Keywords
ElseIf PropName = "$Comments$" Then '註解
Cells(RowNumber, ColumnNumber) = swDoc.Comments
ElseIf PropName = "$Subject$" Then '主題
Cells(RowNumber, ColumnNumber) = swDoc.Subject
ElseIf PropName = "$Title$" Then '標題
Cells(RowNumber, ColumnNumber) = swDoc.Title
Else
If Cells(RowNumber, 3) = "" Or Cells(RowNumber, 3) = 0 Then '模型組態欄位是否空值
vCustPropNameArr = swDoc.GetCustomPropertyNames '是
If TypeName(vCustPropNameArr) = "String()" Then
For Each vCustPropName In vCustPropNameArr
If PropName = vCustPropName Then
PropValue = swDoc.GetCustomProperty(PropName, swDmCustomInfoText) '獲取屬性
Cells(RowNumber, ColumnNumber) = PropValue
End If
Next
End If
Else '否
vCustPropNameArr = swCfg.GetCustomPropertyNames
If TypeName(vCustPropNameArr) = "String()" Then
For Each vCustPropName In vCustPropNameArr
If PropName = vCustPropName Then
PropValue = swCfg.GetCustomProperty(PropName, swDmCustomInfoText) '獲取屬性
Cells(RowNumber, ColumnNumber) = PropValue
End If
Next
End If
End If
End If
ColumnNumber = ColumnNumber + 1 '下一欄
PropName = Cells(HeaderRow, ColumnNumber)
Wend '回到>直到讀完表頭
swDoc.CloseDoc
Cells(RowNumber, 1).Interior.Color = RGB(200, 255, 200)
Else
Cells(RowNumber, 1).Interior.Pattern = xlNoneColor
End If
RowNumber = RowNumber + 1 '下一列
PathName = Cells(RowNumber, 1)
Wend '回到>直到讀完路徑欄
End Sub
Sub 写入配置特性属性值()
Dim HeaderRow As Integer
Dim RowNumber As Integer
Dim FileName As String
Dim swExtName As String
Dim swFileTYpe As Integer
Dim swConfigName As String
Dim vCustPropName
Dim PropValue As String
HeaderRow = 2
RowNumber = HeaderRow + 1
PathName = Cells(RowNumber, 1) '讀取第一個路徑的值
While Not (PathName = "" Or PathName = 0 Or IsEmpty(PathName)) '直到讀完路徑欄
FileName = Trim(Cells(RowNumber, 2))
FileExtname = UCase(Right(Cells(RowNumber, 2), 6))
If "SLDPRT" = FileExtname Then swFileTYpe = 1
If "SLDASM" = FileExtname Then swFileTYpe = 2
If "SLDDRW" = FileExtname Then swFileTYpe = 3
' Set swDoc = swDM.GetDocument(PathName & FileName, swFileTYpe, False, mOpenErrors) '開啟
If Not swDoc Is Nothing Then
If swFileTYpe = 1 Or swFileTYpe = 2 Then
If Not (Cells(RowNumber, 3) = "" Or Cells(RowNumber, 3) = 0) Then
Set swCfgMgr = swDoc.ConfigurationManager
swConfigName = Cells(RowNumber, 3)
Set swCfg = swCfgMgr.GetConfigurationByName(swConfigName)
End If
End If
ColumnNumber = 4
PropName = Cells(HeaderRow, ColumnNumber)
While Not (PropName = "" Or PropName = 0) 'Or IsEmpty(PropName)) '直到讀完表頭
PropName = PropName & ""
If PropName = "$Author$" Then '作者
' If Cells(RowNumber, ColumnNumber) <> "" Then
swDoc.Author = Cells(RowNumber, ColumnNumber)
ElseIf PropName = "$Keywords$" Then '標記
' If Cells(RowNumber, ColumnNumber) <> "" Then
swDoc.Keywords = Cells(RowNumber, ColumnNumber)
ElseIf PropName = "$Comments$" Then '註解
' If Cells(RowNumber, ColumnNumber) <> "" Then
swDoc.Comments = Cells(RowNumber, ColumnNumber)
ElseIf PropName = "$Subject$" Then '主題
' If Cells(RowNumber, ColumnNumber) <> "" Then
swDoc.Subject = Cells(RowNumber, ColumnNumber)
ElseIf PropName = "$Title$" Then '標題
' If Cells(RowNumber, ColumnNumber) <> "" Then
swDoc.Title = Cells(RowNumber, ColumnNumber)
Else
If Cells(RowNumber, 3) = "" Or Cells(RowNumber, 3) = 0 Then '模型組態欄位是否空值
PropValue = Cells(RowNumber, ColumnNumber)
swDoc.DeleteCustomProperty PropName '刪除屬性
swDoc.AddCustomProperty PropName, 30, PropValue '新增屬性
Else '否
vCustPropNameArr = swCfg.GetCustomPropertyNames
PropValue = Cells(RowNumber, ColumnNumber)
swCfg.DeleteCustomProperty PropName '刪除屬性
swCfg.AddCustomProperty PropName, 30, PropValue '新增屬性
End If
End If
ColumnNumber = ColumnNumber + 1 '下一欄
PropName = Cells(HeaderRow, ColumnNumber)
Wend '回到>直到讀完表頭
swDoc.Save
swDoc.CloseDoc
Cells(RowNumber, 1).Interior.Color = RGB(255, 255, 200)
Else
Cells(RowNumber, 1).Interior.Pattern = xlNoneColor
End If
RowNumber = RowNumber + 1 '下一列
PathName = Cells(RowNumber, 1)
Wend '回到>直到讀完路徑欄
End Sub
Sub 删除配置特性属性()
YN = MsgBox("作者提醒你，一旦删除不能恢复，是否继续?", vbYesNo)
If YN <> 6 Then Exit Sub
Dim HeaderRow As Integer
Dim RowNumber As Integer
Dim FileName As String
Dim swExtName As String
Dim swFileTYpe As Integer
Dim swConfigName As String
Dim vCustPropName
Dim PropValue As String
HeaderRow = 2
RowNumber = HeaderRow + 1
PathName = Cells(RowNumber, 1) '讀取第一個路徑的值
While Not (PathName = "" Or PathName = 0 Or IsEmpty(PathName)) '直到讀完路徑欄
FileName = Trim(Cells(RowNumber, 2))
FileExtname = UCase(Right(Cells(RowNumber, 2), 6))
If "SLDPRT" = FileExtname Then swFileTYpe = 1
If "SLDASM" = FileExtname Then swFileTYpe = 2
If "SLDDRW" = FileExtname Then swFileTYpe = 3
' Set swDoc = swDM.GetDocument(PathName & FileName, swFileTYpe, False, mOpenErrors) '開啟
If Not swDoc Is Nothing Then
If swFileTYpe = 1 Or swFileTYpe = 2 Then
If Not (Cells(RowNumber, 3) = "" Or Cells(RowNumber, 3) = 0) Then
Set swCfgMgr = swDoc.ConfigurationManager
swConfigName = Cells(RowNumber, 3)
Set swCfg = swCfgMgr.GetConfigurationByName(swConfigName)
End If
End If
ColumnNumber = 4
PropName = Cells(HeaderRow, ColumnNumber)
While Not (PropName = "" Or PropName = 0) 'Or IsEmpty(PropName)) '直到讀完表頭
PropName = PropName & ""
If PropName = "$Author$" Then '作者
ElseIf PropName = "$Keywords$" Then '標記
ElseIf PropName = "$Comments$" Then '註解
ElseIf PropName = "$Subject$" Then '主題
ElseIf PropName = "$Title$" Then '標題
Else
If Cells(RowNumber, 3) = "" Or Cells(RowNumber, 3) = 0 Then '模型組態欄位是否空值
PropValue = Cells(RowNumber, ColumnNumber)
swDoc.DeleteCustomProperty PropName '刪除屬性
Else '否
vCustPropNameArr = swCfg.GetCustomPropertyNames
PropValue = Cells(RowNumber, ColumnNumber)
swCfg.DeleteCustomProperty PropName '刪除屬性
End If
End If
ColumnNumber = ColumnNumber + 1 '下一欄
PropName = Cells(HeaderRow, ColumnNumber)
Wend '回到>直到讀完表頭
swDoc.Save
swDoc.CloseDoc
Cells(RowNumber, 1).Interior.Color = RGB(255, 50, 50)
Else
Cells(RowNumber, 1).Interior.Pattern = xlNoneColor
End If
RowNumber = RowNumber + 1 '下一列
PathName = Cells(RowNumber, 1)
Wend '回到>直到讀完路徑欄
HeaderRow = 2
RowNumber = HeaderRow + 1
i = HeaderRow
While (Cells(i, 1) <> "")
i = i + 1
Wend
j = 4
While (Cells(HeaderRow, j) <> "")
j = j + 1
Wend
Range(Cells(HeaderRow + 1, RowNumber + 1), Cells(i, j)).ClearContents
End Sub
Sub 读取配置特性属性名称()
Set swApp = CreateObject("SldWorks.Application") '啟動SW
Dim vCfgNameArr As Object
Dim vCfgName As Object
Dim swCfg As Object
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) '讀取第一個路徑的值
PropColumn = 4
PropName = Cells(HeaderRow, PropColumn)
While Not (PropName = "" Or PropName = 0 Or IsEmpty(PropName)) '直到讀完路徑欄
ReDim Preserve PropList(PropColumn - 3)
PropList(PropColumn - 3) = PropName
PropColumn = PropColumn + 1 '下一列
PropName = Cells(HeaderRow, PropColumn)
Wend
While Not (PathName = "" Or PathName = 0 Or IsEmpty(PathName)) '直到讀完路徑欄
FileName = Trim(Cells(RowNumber, 2))
FileExtname = UCase(Right(Cells(RowNumber, 2), 6))
If "SLDPRT" = FileExtname Then swFileTYpe = 1
If "SLDASM" = FileExtname Then swFileTYpe = 2
If "SLDDRW" = FileExtname Then swFileTYpe = 3
' Set swDoc = swApp.OpenDoc(PathName & FileName, swFileTYpe) '開啟檔案
If Not swDoc Is Nothing Then '排除無效檔案
swConfigName = Cells(RowNumber, 3)
If swConfigName = "" Or swConfigName = 0 Then
vCustPropNameArr = swDoc.GetCustomPropertyNames
If TypeName(vCustPropNameArr) = "String()" Then
For Each vCustPropName In vCustPropNameArr
InList = False
For Each PropItem In PropList
If vCustPropName = PropItem Then InList = True
Next
If Not InList Then
ReDim Preserve PropList(UBound(PropList) + 1)
PropList(UBound(PropList)) = vCustPropName
End If
Next
End If
Else
Set swCfgMgr = swDoc.ConfigurationManager
swConfigNames = swCfgMgr.GetConfigurationNames
For Each swConfigName In swConfigNames
Set swCfg = swDoc.GetConfigurationByName(swConfigName)
vCustPropNameArr = swCfg.GetCustomPropertyNames
If TypeName(vCustPropNameArr) = "String()" Then
For Each vCustPropName In vCustPropNameArr
InList = False
For Each PropItem In PropList
If vCustPropName = PropItem Then InList = True
Next
If Not InList Then
ReDim Preserve PropList(UBound(PropList) + 1)
PropList(UBound(PropList)) = vCustPropName
End If
Next
End If
Next
End If 'If swConfigName = "" Or swConfigName = 0
swDoc.CloseDoc '關閉檔案
Cells(RowNumber, 1).Interior.Color = RGB(200, 200, 255)
End If ''If Not swDoc Is Nothing
RowNumber = RowNumber + 1 '下一列
PathName = Cells(RowNumber, 1)
Wend '回到>直到讀完路徑欄
PropHeading = 4
For i = 1 To UBound(PropList) '- 1
Cells(HeaderRow, PropHeading) = PropList(i)
Cells(HeaderRow, PropHeading).Font.Bold = True
PropHeading = PropHeading + 1
Next
End Sub
