找回密码 注册 QQ登录
开思网工业级高精度在线3D打印服务

iCAx开思网

CAD/CAM/CAE/设计/模具 高清视频【积分说明】如何快速获得积分?快速3D打印 手板模型CNC加工服务在线3D打印服务,上传模型,自动报价
查看: 5770|回复: 10
打印 上一主题 下一主题

[求助] 怎么才能用SW-API

[复制链接]
跳转到指定楼层
1
发表于 2016-12-15 17:03:22 | 只看该作者 回帖奖励 |倒序浏览 |阅读模式

马上注册,结交更多同行朋友,交流,分享,学习。

您需要 登录 才可以下载或查看,没有帐号?注册

x

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



分享到:  QQ好友和群QQ好友和群 QQ空间QQ空间 腾讯微博腾讯微博 腾讯朋友腾讯朋友
收藏收藏1 分享淘帖 赞一下!赞一下!
2
发表于 2016-12-15 17:17:20 | 只看该作者

马上注册,结交更多同行朋友,交流,分享,学习。

您需要 登录 才可以下载或查看,没有帐号?注册

x
3
发表于 2016-12-15 17:20:36 | 只看该作者

马上注册,结交更多同行朋友,交流,分享,学习。

您需要 登录 才可以下载或查看,没有帐号?注册

x
4
发表于 2016-12-15 20:32:52 | 只看该作者

马上注册,结交更多同行朋友,交流,分享,学习。

您需要 登录 才可以下载或查看,没有帐号?注册

x
5
 楼主| 发表于 2016-12-16 07:50:54 | 只看该作者

马上注册,结交更多同行朋友,交流,分享,学习。

您需要 登录 才可以下载或查看,没有帐号?注册

x
6
 楼主| 发表于 2016-12-16 09:28:29 | 只看该作者

马上注册,结交更多同行朋友,交流,分享,学习。

您需要 登录 才可以下载或查看,没有帐号?注册

x
7
发表于 2016-12-16 13:04:35 | 只看该作者

马上注册,结交更多同行朋友,交流,分享,学习。

您需要 登录 才可以下载或查看,没有帐号?注册

x
8
 楼主| 发表于 2016-12-16 16:59:35 | 只看该作者

马上注册,结交更多同行朋友,交流,分享,学习。

您需要 登录 才可以下载或查看,没有帐号?注册

x
9
发表于 2016-12-16 22:55:15 | 只看该作者

马上注册,结交更多同行朋友,交流,分享,学习。

您需要 登录 才可以下载或查看,没有帐号?注册

x
10
 楼主| 发表于 2016-12-17 08:16:03 | 只看该作者

马上注册,结交更多同行朋友,交流,分享,学习。

您需要 登录 才可以下载或查看,没有帐号?注册

x
您需要登录后才可以回帖 登录 | 注册

本版积分规则

3D打印手板模型快速制作服务,在线报价下单!

QQ 咨询|手机版|联系我们|iCAx开思网  

GMT+8, 2024-11-15 04:51 , Processed in 0.043201 second(s), 10 queries , Gzip On, Redis On.

Powered by Discuz! X3.3

© 2002-2024 www.iCAx.org

快速回复 返回顶部 返回列表