main.cls

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

            iModelDoc.CreateLine2 boxSketchPt(5).X, boxSketchPt(5).Y, boxSketchPt(5).Z, boxSketchPt(6).X, boxSketchPt(6).Y, boxSketchPt(6).Z
            iModelDoc.CreateLine2 boxSketchPt(6).X, boxSketchPt(6).Y, boxSketchPt(6).Z, boxSketchPt(7).X, boxSketchPt(7).Y, boxSketchPt(7).Z
            iModelDoc.CreateLine2 boxSketchPt(7).X, boxSketchPt(7).Y, boxSketchPt(7).Z, boxSketchPt(4).X, boxSketchPt(4).Y, boxSketchPt(4).Z

            '退出3D草图绘制模式
            iModelDoc.Insert3DSketch2 False
        End If
        
        '完成该特征的包围盒获取与绘制，进入下一个特征
        Dim featTemp As Feature
        Set featTemp = iFeature.GetNextFeature
        Set iFeature = featTemp
        
    Next
    
End Function
'得到选择的物体及属性，以弹出对话框的形式显示
Public Function OnGetSelectedObj()

    '得到当前活动文档
    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
        
    '得到用户选择的数目
    Dim selCount As Long
    selCount = iSelManager.GetSelectedObjectCount
    If selCount < 1 Then
        MsgBox "没有选择对象"
        Exit Function
    End If
    
    '统计变量
    vertexCount = 0 '被选择点的数目
    edgecount = 0  '被选择边的数目
    facecount = 0  '被选择面的数目

        
    '通过循环依次访问每一个选择对象
    For i = 1 To selCount
        
        '得到第I个选择对象的类型
        Dim selType As Long
        selType = iSelManager.GetSelectedObjectType(i)
        '判断选择类型
        If selType = swSelVERTICES Then
            vertexCount = vertexCount + 1
        Else
        If selType = swSelEDGES Then
            edgecount = edgecount + 1
        Else
        If selType = swSelFACES Then
            facecount = facecount + 1
        End If
        End If
        End If
        
    Next
    '弹出对话框显示
    Dim selMsg As String
    selMsg = selMsg + "选择的信息如下：" + vbCrLf
    selMsg = selMsg + "共计" + Format(selCount) + "个对象。" + vbCrLf
    selMsg = selMsg + "其中包含" + Format(facecount) + "个面， " + Format(edgecount) + "条边，" + Format(vertexCount) + "个顶点"
    MsgBox selMsg
       

End Function
'获取当前视图信息，包括视图坐标系和比例缩放
Public Function OnGetViewInfo()
    
     '得到当前活动文档
    Dim iModelDoc As ModelDoc2
    Set iModelDoc = iSldWorks.ActiveDoc
    If iModelDoc Is Nothing Then
        MsgBox "不能得到当前活动文档"
        Exit Function
    End If
    
    '得到当前视图对象
    Dim iView As ModelView
    Set iView = iModelDoc.ActiveView
    If iView Is Nothing Then
        MsgBox "不能获取视图"
        Exit Function
    End If
    
    '定义一个字符串记录数据
    Dim vwData As String
    vwData = "模型视图信息如下：" + vbCrLf
    Dim viewNum As Integer
    viewNum = 0
    
    '遍历所有的模型视图
    While Not iView Is Nothing
                
        viewNum = viewNum + 1
        vwData = vwData + "视图" + Format(viewNum) + "的显示模式为："
        '得到当前视图的显示模式
        Dim vwDMode As Long
        vwDMode = iView.DisplayMode
        If vwDMode = swViewDisplayMode_Wireframe Then
            vwData = vwData + "线框模式" + vbCrLf
        Else
        If vwDMode = swViewDisplayMode_HiddenLinesRemoved Then
            vwData = vwData + "隐藏线消除模式" + vbCrLf
        Else
        If vwDMode = swViewDisplayMode_HiddenLinesGrayed Then
            vwData = vwData + "隐藏线可见模式" + vbCrLf
        Else
        If vwDMode = swViewDisplayMode_Shaded Then
            vwData = vwData + "上色模式" + vbCrLf
        Else
        If vwDMode = swViewDisplayMode_ShadedWithEdges Then
            vwData = vwData + "带边线上色模式" + vbCrLf
        End If
        End If
        End If
        End If
        End If
        
        '得到当前视图的缩放比例
        Dim vwScale As Long
        vwScale = iView.Scale2
        vwData = vwData + "视图的缩放比例为：" + vbCrLf
        vwData = vwData + "    " + Format(vwScale) + vbCrLf
        
        '得到视图旋转矩阵
        Dim vwOrie As MathTransform
        Set vwOrie = iView.Orientation3
        Dim vwRotate As Variant
        vwRotate = vwOrie.ArrayData
        vwData = vwData + "视图的旋转矩阵为: " + vbCrLf
        For j = 0 To 2
            vwData = vwData + "    " + Format(vwRotate(j * 3 + 0)) + ", " + Format(vwRotate(j * 3 + 1)) + ", " + Format(vwRotate(j * 3 + 2)) + vbCrLf
        Next
        
        '得到视图的位移数据
        Dim vwTran As MathVector
        Set vwTran = iView.Translation3
        Dim vwTData As Variant
        vwTData = vwTran.ArrayData
        vwData = vwData + "视图的位移数据为: " + vbCrLf
            vwData = vwData + "    " + Format(vwTData(0)) + ", " + Format(vwTData(1)) + ", " + Format(vwTData(2)) + vbCrLf + vbCrLf
        
        Dim tempView As ModelView
        Set tempView = iView.GetNext
        Set iView = tempView
        
        
    Wend
    
    '弹出对话框显示视图信息
    MsgBox vwData
    

End Function

'获取组成零件的三角面片数据，然后调用3D草图绘制命令显示
Public Function OnTessPart()
    
    '得到当前活动文档
    Dim iModelDoc As ModelDoc2
    Set iModelDoc = iSldWorks.ActiveDoc
    If iModelDoc Is Nothing Then
        MsgBox "不能得到当前活动文档"
        Exit Function
    End If
    
    '得到零件指针
    Dim iPartDoc As PartDoc
    Set iPartDoc = iModelDoc
        
    '定义一个Variant变量用于保存得到的三角面片数据
    Dim tessData As Variant
    '定义一个long型变量用于记录组成零件的三角面片个数
    Dim triCount As Long
    
    '得到组成零件的三角面片数目
    triCount = iPartDoc.GetTessTriangleCount
    '判断是否为空
    If triCount <= 0 Then
        MsgBox "该零件无三角面片数据"
        Exit Function
    End If
    
    '得到三角面片数据
    tessData = iPartDoc.GetTessTriangles(True)
    
    '绘制三角面片
    '进入3D草图绘制
    iModelDoc.Insert3DSketch2 True
    iModelDoc.SetAddToDB True
    
    '定义三个顶点
    Dim triSketchPt(3)    As SketchPoint
    
    '根据三角面片总数(点的个数应乘3)进行循环，每一次绘制一个三角形
    For i = 0 To triCount * 3 - 1 Step 3
             
        '绘制三角形顶点
        Set triSketchPt(0) = iModelDoc.CreatePoint2(tessData(i * 3 + 0), tessData(i * 3 + 1), tessData(i * 3 + 2))
        Set triSketchPt(1) = iModelDoc.CreatePoint2(tessData(i * 3 + 3), tessData(i * 3 + 4), tessData(i * 3 + 5))
        Set triSketchPt(2) = iModelDoc.CreatePoint2(tessData(i * 3 + 6), tessData(i * 3 + 7), tessData(i * 3 + 8))
        
        '绘制三角形边线
        iModelDoc.CreateLine2 triSketchPt(0).X, triSketchPt(0).Y, triSketchPt(0).Z, triSketchPt(1).X, triSketchPt(1).Y, triSketchPt(1).Z
        iModelDoc.CreateLine2 triSketchPt(1).X, triSketchPt(1).Y, triSketchPt(1).Z, triSketchPt(2).X, triSketchPt(2).Y, triSketchPt(2).Z
        iModelDoc.CreateLine2 triSketchPt(2).X, triSketchPt(2).Y, triSketchPt(2).Z, triSketchPt(0).X, triSketchPt(0).Y, triSketchPt(0).Z

    '进入下一个循环
    Next
    
    '退出3D草图绘制模式
    iModelDoc.Insert3DSketch2 False

End Function
'修改用户选择的面的贴图
Public Function OnChangeTexture()
    
    '得到当前活动文档
    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
        
    '判断是否选择物体
    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 <> swSelFACES Then
        MsgBox "选择类型必须是面，请重新选择"
        Exit Function
    End If
    
    '定义贴图
    Dim iDocExt As ModelDocExtension
    Set iDocExt = iModelDoc.Extension
    Dim iTex As Texture
    Dim bmpPath As String
    bmpPath = "<SystemTexture>\images\textures\floor\floorbd2.jpg"
    Set iTex = iDocExt.CreateTexture(bmpPath, 5, 45, False)
    If iTex Is Nothing Then
        MsgBox "无法创建贴图"
        Exit Function
    End If
        
    '根据面的总数进入循环
    For i = 1 To selCount
    
        '获取选择的面
        Dim iFace As Face2
        Set iFace = iSelManager.GetSelectedObject(i)
        If iFace Is Nothing Then
            Exit Function
        End If
       
    
        '将贴图贴到指定的面上
        Dim retval As Boolean
        retval = iFace.SetTexture("默认", iTex)
        If Not retval Then
            MsgBox "贴图到指定面失败"
            Exit Function
        End If
    
    '下一个面
    Next
    '弹出对话框提示贴图成功
    MsgBox "贴图成功"
    
End Function
'打开用户选择的装配体文件
Public Function OnOpenAssembly()
    '弹出文件选择对话眶
    
    

End Function
'压缩装配体的部件，首先用户选择一个部件
'程序判断当前装配体中包围盒大于该部件的都压缩
Public Function OnSuppressComponent()
    '得到当前活动文档
    Dim iModelDoc As ModelDoc2
    Set iModelDoc = iSldWorks.ActiveDoc
    If iModelDoc Is Nothing Then
        MsgBox "不能得到当前活动文档"
        Exit Function
    End If
    
    '得到装配体文件指针
    Dim iAssemDoc  As AssemblyDoc
    Set iAssemDoc = iModelDoc
    If iAssemDoc 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 <> swSelCOMPONENTS Then
        MsgBox "请选择一个部件"
        Exit Function
    End If
    
    '得到选择的部件
    Dim selComp As Component2
    Set selComp = iSelManager.GetSelectedObject(1)
    If selComp Is Nothing Then
        MsgBox "不能获取部件指针"
        Exit Function
    End If
    
    '得到选择部件的包围盒
    Dim vBox As Variant
    vBox = selComp.GetBox(False, True)
    
    '计算包围盒对角线长度，以此作为判断参数
    Dim typeLength As Double