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程序对象
猜你喜欢
转载自blog.csdn.net/chenlu5201314/article/details/80287936
今日推荐
周排行