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
【SolidWorks宏】VBA操作SolidWorks程序对象
最新推荐文章于 2024-07-15 10:02:58 发布