|
樓主 |
發表於 2014/10/31 22:09:28
|
顯示全部樓層
程式碼如下:
- Const SWDMLicenseKey = "許可號碼"
- Dim swDM As SwDMApplication
- Dim swDoc As SwDMDocument12
- Dim mOpenErrors As SwDmDocumentOpenError
- Dim swCfgMgr As SwDMConfigurationMgr
- Dim objClassfac As SwDMClassFactory
- Dim vCustPropNameArr As Variant
- Sub BrowseFiles()
- 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 "SW Part", "*.SLDPRT" '設定檔案類型
- Application.FileDialog(msoFileDialogFilePicker).Filters.Add "SW Part with Configs", "*.SLDPRT" '設定檔案類型
- Application.FileDialog(msoFileDialogFilePicker).Filters.Add "SW Asm", "*.SLDASM" '設定檔案類型
- Application.FileDialog(msoFileDialogFilePicker).Filters.Add "SW Asm with Configs", "*.SLDASM" '設定檔案類型
- Application.FileDialog(msoFileDialogFilePicker).Filters.Add "SW Drawing", "*.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
- Set swCfg = swCfgMgr.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
- 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(ConfigColor, ConfigColor, ConfigColor)
- ConfigColor = ConfigColor - 10
- RowCount = RowCount + 1
- Next
- swDoc.CloseDoc '關閉檔案
- End If '排除無效檔案<完>
- End If ''過濾器是2或4<完>
- Next i '逐一讀取所選檔案<完>
- End If '判斷有否點選檔案<完>
- End Sub
- Sub ReadProps()
- Dim swCfg As SwDMConfiguration '14
- 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
- Set objClassfac = CreateObject("SwDocumentMgr.SwDMClassFactory")
- Set swDM = objClassfac.GetApplication(SWDMLicenseKey) '啟動SWDM
- HeaderRow = 2
- RowNumber = HeaderRow + 1
- PathName = Cells(RowNumber, 1) '讀取第一個路徑的值
- While Not (PathName = "" Or PathName = 0 Or IsEmpty(PathName)) '直到讀完路徑欄
- FileName = 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 WriteProps()
- Dim swCfg As SwDMConfiguration '14
- 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
- Set objClassfac = CreateObject("SwDocumentMgr.SwDMClassFactory")
- Set swDM = objClassfac.GetApplication(SWDMLicenseKey) '啟動SWDM
- HeaderRow = 2
- RowNumber = HeaderRow + 1
- PathName = Cells(RowNumber, 1) '讀取第一個路徑的值
- While Not (PathName = "" Or PathName = 0 Or IsEmpty(PathName)) '直到讀完路徑欄
- FileName = 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 '作者
- swDoc.Author = Cells(RowNumber, ColumnNumber)
- ElseIf PropName = "$Keywords$" Then '標記
- swDoc.Keywords = Cells(RowNumber, ColumnNumber)
- ElseIf PropName = "$Comments$" Then '註解
- swDoc.Comments = Cells(RowNumber, ColumnNumber)
- ElseIf PropName = "$Subject$" Then '主題
- swDoc.Subject = Cells(RowNumber, ColumnNumber)
- ElseIf PropName = "$Title$" 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 DeleteProps()
- YN = MsgBox("Once Deleted, those cannot be restored. Continue?", vbYesNo)
- If YN <> 6 Then Exit Sub
- Dim swCfg As SwDMConfiguration '14
- 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
- Set objClassfac = CreateObject("SwDocumentMgr.SwDMClassFactory")
- Set swDM = objClassfac.GetApplication(SWDMLicenseKey) '啟動SWDM
- HeaderRow = 2
- RowNumber = HeaderRow + 1
- PathName = Cells(RowNumber, 1) '讀取第一個路徑的值
- While Not (PathName = "" Or PathName = 0 Or IsEmpty(PathName)) '直到讀完路徑欄
- FileName = 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 '回到>直到讀完路徑欄
- End Sub
- Sub GetPropNames()
- 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) '讀取第一個路徑的值
- 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 = 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 '排除無效檔案
- 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 = swCfgMgr.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
複製代碼 |
|