main.cls

VB二次开发。用于solidworks结合。实现功能：新增工具栏、菜单栏

    typeLength = Sqr((vBox(0) - vBox(3)) * (vBox(0) - vBox(3)) + (vBox(1) - vBox(4)) * (vBox(1) - vBox(4)) + (vBox(2) - vBox(5)) * (vBox(2) - vBox(5)))
    
    '遍历装配体中的部件，如果部件的对角线长度大于选择的部件，则压缩
    Dim info As String '用于显示相关部件信息
    info = info + "被压缩的部件信息如下：" + vbCrLf
    Dim spCount As Long
    
    Dim compAll As Variant
    compAll = iAssemDoc.GetComponents(True)
    Dim compCount As Long
    compCount = iAssemDoc.GetComponentCount(True)
    Dim comp As Component2
    For j = 1 To compCount
        Set comp = compAll(j - 1)
        If comp Is Nothing Then
            MsgBox "不能得到装配体中的部件"
            Exit Function
        End If
        '得到该部件的包围盒对角线长度
        Dim compBox As Variant
        Dim compBoxLen As Double
        compBox = comp.GetBox(False, True)
        compBoxLen = Sqr((compBox(0) - compBox(3)) * (compBox(0) - compBox(3)) + (compBox(1) - compBox(4)) * (compBox(1) - compBox(4)) + (compBox(2) - compBox(5)) * (compBox(2) - compBox(5)))
        '判断如果该对角线长度大于选择标准的，记录
        If compBoxLen <= typeLength Then
            '计数增加1
            spCount = spCount + 1
            
            '得到部件的名称
            Dim compName As String
            compName = comp.Name
            info = info + "第" + Format(j) + "个被压缩部件的名称为: " + compName + vbCrLf
            
            '设置部件为压缩状态
            Dim ret As Long
            ret = comp.SetSuppression(swComponentSuppressed)
            If ret <> swSuppressionChangeOk Then
                MsgBox "压缩失败"
                Exit Function
            End If
        End If
    Next
    '输出被压缩部件信息
    info = info + "共计压缩 " + Format(spCount) + "部件" + vbCrLf
    MsgBox info
End Function
'遍历装配体中的所有装配关系
'弹出对话框显示装配关系及相关部件名称
Public Function OnTraverseMate()
    '定义一个字符串用于信息输出
    Dim info As String
    info = info + "当前装配体中配合关系信息如下：" + vbCrLf + vbCrLf
    '定义一个变量用于计数
    Count = 0
    
    '得到当前活动文档
    Dim iModelDoc As ModelDoc2
    Set iModelDoc = iSldWorks.ActiveDoc
    If iModelDoc Is Nothing Then
        MsgBox "不能得到当前活动文档"
        Exit Function
    End If
    
    '特征遍历，得到特征管理设计树中的“配合”
    Dim iFeat As Feature
    Dim mateFeat As Feature
    Set iFeat = iModelDoc.FirstFeature
    Do While Not iFeat Is Nothing
        '得到特征名称
        Dim featName As String
        featName = iFeat.GetTypeName
        '如果特征名称为 配合
        If featName = "MateGroup" Then
            Set mateFeat = iFeat
            Exit Do
        End If
        Set iFeat = iFeat.GetNextFeature
    Loop
    
    '如果没有找到配合特征，则退出程序并弹出对话框显示信息
    If mateFeat Is Nothing Then
        info = info + "文件中没有装配关系" + vbCrLf
        MsgBox info
        Exit Function
    End If
    
    '遍历配合下的所有子特征
    Dim subfeat As Feature
    Set subfeat = mateFeat.GetFirstSubFeature
    While Not subfeat Is Nothing
        Count = Count + 1
        Dim swMate As Mate2
        '得到配合特征
        Set swMate = subfeat.GetSpecificFeature2
        '得到装配实体
        If Not swMate Is Nothing Then
            '输出配合名称
            Dim mateName As String
            mateName = swMate.Name
            '输出配合名称信息
            info = info + "第" + Format(Count) + "个配合关系名称为：" + mateName + vbCrLf
            info = info + "该装配关系涉及的部件如下："
            '得到配合关系的实体数目
            entitycount = swMate.GetMateEntityCount
            '根据实体数目进入循环依次访问每个实体
            For i = 0 To entitycount - 1
                Dim iEntity As MateEntity2
                Set iEntity = swMate.MateEntity(i)
                '得到实体所在部件
                Dim iComp As Component2
                Set iComp = iEntity.ReferenceComponent
                '得到部件名称
                Dim compName As String
                compName = iComp.Name
                '输出部件名称
                info = info + compName + "， "
                          
            Next
            
        End If
        '下一个配合关系加入两个换行符
        info = info + vbCrLf + vbCrLf
        
        '得到下一个装配关系
        Set subfeat = subfeat.GetNextSubFeature
            
    Wend
        
    '输出信息
    MsgBox info
    
End Function
'轻化当前装配体文档中的零部件
Public Function OnLightWeight()
   '得到当前活动文档
    Dim iModelDoc As ModelDoc2
    Set iModelDoc = iSldWorks.ActiveDoc
    If iModelDoc Is Nothing Then
        MsgBox "不能得到当前活动文档"
        Exit Function
    End If
    
    '得到当前文件大小，如果文件不大则不需要进行轻化，文件大小可根据需要设置
    Dim filePath As String
    filePath = iModelDoc.GetPathName
    Dim fileLength As Long
    fileLength = FileLen(filePath)
    If fileLength <= 500000 Then
        MsgBox "零件数目不多，不需要对部件进行轻化"
        Exit Function
    End If
    
    '得到装配体文件指针
    Dim iAssemDoc  As AssemblyDoc
    Set iAssemDoc = iModelDoc
    If iAssemDoc Is Nothing Then
        MsgBox "不能得到指向装配体文档的指针"
        Exit Function
    End If
    
    '获取装配体文档中的所有部件，保存在compAll数组中
    Dim compAll As Variant
    compAll = iAssemDoc.GetComponents(True)
    '获取装配体中一级零部件总数
    Dim compCount As Long
    compCount = iAssemDoc.GetComponentCount(True)
    Dim comp As Component2
    For j = 1 To compCount
        Set comp = compAll(j - 1)
        If comp Is Nothing Then
            MsgBox "不能得到装配体中的部件"
            Exit Function
        End If
        
        '设置部件为选择状态
        comp.Select (True)
    Next
    
    '轻化选择的零部件
    iAssemDoc.MakeLightWeight
    
End Function
'遍历工程图中所有视图并弹出对话框显示视图名称、类型、比例、位置
Public Function OnTraverseView()
    '得到当前活动文档
    Dim iModelDoc As ModelDoc2
    Set iModelDoc = iSldWorks.ActiveDoc
    If iModelDoc Is Nothing Then
        MsgBox "不能得到当前活动文档"
        Exit Function
    End If
    
    '得到工程图文件指针
    Dim iDrawDoc  As DrawingDoc
    Set iDrawDoc = iModelDoc
    If iDrawDoc Is Nothing Then
        MsgBox "不能得到指向工程图文档的指针"
        Exit Function
    End If

    '得到第一个视图
    Dim iView As View
    Set iView = iDrawDoc.GetFirstView
    If iView Is Nothing Then
        MsgBox "当前工程图文件中没有视图"
        Exit Function
    End If
    
    '定义变量用于存储视图信息
    Dim info As String
    info = inof + "当前工程图文件中视图信息如下:" + vbCrLf + vbCrLf
    Count = 0
    '进入循环
    While Not iView Is Nothing
        '计数增加
        Count = Count + 1
        '写入信息
        info = info + "第" + Format(Count) + "个视图的信息如下：" + vbCrLf
        '得到视图的名称
        Dim viewName As String
        viewName = iView.Name
        info = info + "视图名称：" + viewName + vbCrLf
        
        '得到视图的类型
        Dim viewType As Long
        viewType = iView.Type
        '选择三个典型视图，更多的见程序说明
        info = info + "视图类型为："
        If viewType = swDrawingNamedView Then
            info = info + "命名视图" + vbCrLf
        Else
        If viewType = swDrawingAuxiliaryView Then
            info = info + "辅助视图" + vbCrLf
        Else
        If viewType = swDrawingProjectedView Then
            info = info + "投影视图" + vbCrLf
        Else
           info = info + Format(viewType) + vbCrLf
        End If
        End If
        End If
        
        '视图比例
        Dim viewScale As Variant
        viewScale = iView.ScaleRatio
        info = info + "视图比例：" + Format(viewScale(0)) + "：" + Format(viewScale(1)) + vbCrLf
        
        '得到视图所在位置
        Dim viewPos As Variant
        viewPos = iView.Position
        info = info + "视图位置：" + Format(viewPos(0)) + ", " + Format(viewPos(1)) + vbCrLf + vbCrLf
        
        
        '获取下一个视图
        Set iView = iView.GetNextView
                       
    Wend
    info = info + "共计" + Format(Count) + "个视图" + vbCrLf
    '输出视图信息
    MsgBox info
           
End Function
'获取用户选择工程图视图的部件，弹出对话框显示
Public Function OnGetViewComponent()
    '定义字符串用于信息输出
    Dim info As String
    info = info + "当前工程图中的部件信息如下：" + vbCrLf
    '得到当前活动文档
    Dim iModelDoc As ModelDoc2
    Set iModelDoc = iSldWorks.ActiveDoc
    If iModelDoc Is Nothing Then
        MsgBox "不能得到当前活动文档"
        Exit Function
    End If
    '得到选择管理器
    Dim iSelManager As SelectionMgr
    Set iSelManager = iModelDoc.SelectionManager
    If iSelManager Is Nothing Then
        MsgBox "不能获取选择管理器"
        Exit Function
    End If
    '得到选择的个数，确保为1
    Dim selCount As Long
    selCount = iSelManager.GetSelectedObjectCount
    If selCount <> 1 Then
        MsgBox "请选择一个视图"
        Exit Function
    End If
    '得到选择的类型，确保为工程图视图
    Dim selType As Long
    selType = iSelManager.GetSelectedObjectType(1)
    If selType <> swSelDRAWINGVIEWS Then
        MsgBox "请选择一个视图"
        Exit Function
    End If
    '得到选择的部件
    Dim selView As View
    Set selView = iSelManager.GetSelectedObject(1)
    If selView Is Nothing Then
        MsgBox "不能获取视图指针"
        Exit Function
    End If
    '得到选择视图的部件
    Dim drawComp As DrawingComponent
    Set drawComp = selView.RootDrawingComponent
    If drawComp Is Nothing Then
        MsgBox "不能获取DrawingComponent对象"
        Exit Function
    End If
    
    Dim comp As Component2
    Set comp = drawComp.Component
    If comp Is Nothing Then
        MsgBox "不能获取部件"
        Exit Function
    End If
    '获取部件信息
    '获取部件名称
    Dim compName As String
    compName = comp.Name2
    info = info + "视图的部件名称为：" + compName + vbCrLf
    '获取部件文件路径
    Dim compPath As String
    Dim compModel As ModelDoc2
    Set compModel = comp.GetModelDoc
    compPath = compModel.GetPathName
    info = info + "部件文件路径为：" + compPath + vbCrLf
    
    '输出信息
    MsgBox info

End Function
'添加视图右键菜单项，条件为当前没有用户选择的对象
'因为弹出的右键菜单与用户的选择相关，具体见代码
Public Function AddPopMenuItem()
    '调用添加函数
    ret = iSldWorks.AddMenuPopupItem2(swDocPART, iCookie, swSelNOTHING, "得到当前文件路径", "OnGetFilePath", "", "得到文件路径", "")
    '判断是否添加成功
    If ret Then
    Else
        MsgBox "添加右键菜单失败"
    End If
End Function
'右键菜单响应函数，得到文件路径
Public Function OnGetFilePath()
    info = info + "当前工程图中的部件信息如下：" + vbCrLf
    '得到当前活动文档
    Dim iModelDoc As ModelDoc2
    Set iModelDoc = iSldWorks.ActiveDoc
    If iModelDoc Is Nothing Then
        MsgBox "不能得到当前活动文档"
        Exit Function
    End If
    '得到文件路径
    Dim path As String
    path = iModelDoc.GetPathName
    MsgBox path

End Function