怎么才能用SW－API

xiaoxifeng

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

莱虫

莱虫

qiminger

xiaoxifeng

xiaoxifeng

海饼干

xiaoxifeng

愛玩家

xiaoxifeng