【SolidWorks宏】VBA操作SolidWorks程序对象

Rem 获取SolidWorks的标题并解析
Private Sub SldWorks_GetTitle()
    Dim SwApp As Object
    Dim TitleStr As String
    Dim PartStr() As String
    Dim Part1 As String
    Dim Part2 As String
    Dim currentDoc As SldWorks.modelDoc
    
    '获取SolidWorks应用程序对象
    Set SwApp = CreateObject("sldworks.application")
    '获取打开的当前文档
    Set currentDoc = SwApp.ActiveDoc
    If currentDoc Is Nothing Then
        MsgBox "请打开一个部件"
    Else
        '获取标题
        TitleStr = currentDoc.GetTitle
    
        '将标题用 下划线(_)分解成两部分 PartStr(0) 图号  PartStr(1) 部件
        If InStr(TitleStr, Chr(95)) > 0 Then
            PartStr = Split(TitleStr, Chr(95))
            Part1 = PartStr(0)
            Part2 = PartStr(1)
        Else
            Part1 = TitleStr
            Part2 = "命名不符合标准"
        End If
    End If
End Sub

Rem 设置当前文档的自定义信息
Private Sub SldWorks_SetCustomInformation(customStr As String, FieldName As String)
    Dim SwApp As Object
    Dim TitleStr As String
    Dim PartStr() As String
    Dim Part1 As String
    Dim Part2 As String
    Dim currentDoc As SldWorks.modelDoc
    Dim retval As Boolean
    '获取SolidWorks应用程序对象
    Set SwApp = CreateObject("sldworks.application")
    '获取打开的当前文档

    Set currentDoc = SwApp.ActiveDoc
    
    '设置对应字段的值
    If currentDoc Is Nothing Then
        MsgBox "请打开一个部件"
    Else
        'AddCustomInfo3(Configration as String,FieldName As String,FieldType as Long,fieldvalue as String ) as Boolean
        retval = currentDoc.AddCustomInfo3("", FieldName, swCustomInfoText, "")
        'CustomInfo2(Configration as String,FiedlName as String) as String
        currentDoc.CustomInfo2("", FieldName) = customStr
    End If
End Sub

Rem 获取当前文档的自定义信息
Private Function SldWorks_GetCustomInformation(FieldName As String) As String
    Dim SwApp As Object
    Dim TitleStr As String
    Dim PartStr() As String
    Dim Part1 As String
    Dim Part2 As String
    Dim currentDoc As SldWorks.modelDoc
    
    '获取SolidWorks应用程序对象
    Set SwApp = CreateObject("sldworks.application")
    Set currentDoc = SwApp.ActiveDoc
    '获取打开的当前文档
    If currentDoc Is Nothing Then
        MsgBox "请打开一个部件"
    Else
        '设置对应字段的值
        'CustomInfo2(Configration as String,FiedlName as String) as String
        SldWorks_GetCustomInformation = currentDoc.CustomInfo2("", FieldName)
    End If
End Function

Rem 获取部件质量
Private Function SldWorks_GetPartMass(densityStr As String) As String
    '声名
    Dim volumeStr As String
    Dim massProperties As Variant
    Dim currentDoc As Object
    Dim volume As Double
    Dim density As Double
    '执行过程
    Set SwApp = CreateObject("SldWorks.Application")
    Set currentDoc = SwApp.ActiveDoc
    
    '获取当前文档的质量属性
    If currentDoc Is Nothing Then
        MsgBox "请打开一个部件"
    Else
        massProperties = currentDoc.GetMassProperties
        '从质量属性中提取出体积
        volumeStr = str(massProperties(3) * (10 ^ 9))
        volume = Val(volumeStr)
        density = Val(densityStr)
        SldWorks_GetPartMass = Format(volume * density / (10 ^ 9), "##0.###")
    End If
End Function

Rem 打开部件查看部件特征 然后关闭
Private Sub SldWorks_OpenPart(filePath As String)
    
    Dim SwApp As SldWorks.SldWorks
    Dim PartDoc As SldWorks.PartDoc
    Dim modelDoc As SldWorks.ModelDoc2
    Dim ParameterDoc As SldWorks.Parameter
    
    Dim Myfeature As SldWorks.Feature
    
    Set SwApp = CreateObject("SldWorks.Application")
    
    'SwApp.OpenDoc(Name as String ,Type as Long ) as Object
    
    Set PartDoc = SwApp.OpenDoc(filePath, 1)
    'PartDoc.FeatureByName(name as String ) as Object

    Set Myfeature = PartDoc.FeatureByName("草图1")
    'Myfeature.Parameter(name as String ) as Object
    Set ParameterDoc = Myfeature.Parameter("upR1")
    'ParameterDoc.GetStringValue
    MsgBox (Myfeature.Parameter("upR1").Value)
    SwApp.Quit (filePath)
    Set SwApp = Nothing
End Sub