Hide Table of Contents

Cut Body in Half using Macro Feature Example (VBA)

This example shows how to cut a body in a part document in half using a macro feature.

'-----------------------------------------------------------------------------------------------
' Preconditions:
' 1. Create a VBA macro.
' 2. Click Tools > References > SolidWorks version exposed type libraries for
'    add-in use > OK.
' 3. Copy Macros to the main module and rename it Macros. (To rename the module, click
'    View > Properties Window and type Macros in (Name).)
' 4. Click Insert > Module and copy PropMgrConst to that module and name it PropMgrConst.
' 5. Click Insert > Class module and copy PropMgr to that class module and name it PropMgr.
' 6. Click Insert > Class module and copy PropMgrCmd to that class module and name it PropMgrCmd.
' 7. Click Insert > Class module and copy PropMgrHdlr to that class module and name it PropMgrHdlr.
' 8. Open public_documents\tutorial\api\plate.sldprt.
' Postconditions:
' 1. Click the part in the graphics area, which is then displayed in Surface on Mass Center in the 
'    PropertyManager page.
' 2. Click the green check mark in the PropertyManager page to insert the macro feature.
' 3. Cuts the body in half and adds the AngleSurf1 macro feature to the FeatureManager design tree.
' 4. Right-click AngleSurf1 and select Edit Feature on the context-sensitive menu.
' 5. Change 1 to 2 in Select the body to keep in the AngleSurf1 PropertyManager page.
' 6. Click the green check mark in the PropertyManager page.
' 7. Displays the opposite side of the body in the graphics area.
' 8. Examine the graphics area and FeatureManager design tree.
'
' NOTE: Because the part is used elsewhere, do not save changes.
'------------------------------------------------------------------------------------------------
'Macros
Option Explicit
' Macro feature rebuild function
Function swmMain(swAppIn, partIn, featureIn)
    Dim featData As SldWorks.MacroFeatureData
    Dim Config As SldWorks.Configuration
    Dim ConfigName As String
    Set featData = featureIn.GetDefinition
    ' Get name of configuration being rebuilt
    Set Config = featData.CurrentConfiguration
    ConfigName = Config.Name
    Dim sels, types, selmarks
    Dim body1 As SldWorks.Body2
    Call featData.GetSelections3(sels, types, selmarks, Nothing, Nothing)
    If IsEmpty(sels) Then
       swmMain = "Body has not been selected!"
       Exit Function
    End If
    If sels(0) Is Nothing Then
       swmMain = "Body has not been selected!"
       Exit Function
    End If
    Set body1 = sels(0)
    Dim modeler As SldWorks.modeler
    Set modeler = swAppIn.GetModeler
    Dim props As Variant
    props = body1.GetMassProperties(1)
    Dim p1(0 To 2) As Double
    Dim v1(0 To 2) As Double
    Dim v2(0 To 2) As Double
    p1(0) = props(0)
    p1(1) = props(1)
    p1(2) = props(2)
    v1(0) = 0
    v1(1) = 0
    v1(2) = 1
    v2(0) = 1
    v2(1) = 0
    v2(1) = 0
    Dim surf As SldWorks.Surface
    Set surf = modeler.CreatePlanarSurface2(p1, v1, v2)
    Dim box As Variant
    box = body1.GetBodyBox
    Dim uvLow, uvHigh As Variant
    uvLow = surf.GetClosestPointOn(box(0), box(1), box(2))
    uvHigh = surf.GetClosestPointOn(box(3), box(4), box(5))
    Dim midPt(0 To 2) As Double
    Dim i As Integer
    For i = 0 To 2
        midPt(i) = (uvLow(i) + uvHigh(i)) / 2
    Next i
    For i = 0 To 2
        uvLow(i) = (uvLow(i) - midPt(i)) * 1.1 + midPt(i)
        uvHigh(i) = (uvHigh(i) - midPt(i)) * 1.1 + midPt(i)
    Next i
    uvLow = surf.GetClosestPointOn(uvLow(0), uvLow(1), uvLow(2))
    uvHigh = surf.GetClosestPointOn(uvHigh(0), uvHigh(1), uvHigh(2))
    Dim sheet As SldWorks.Body2
    Dim uv(0 To 3) As Double
    uv(0) = uvLow(3)
    uv(1) = uvHigh(3)
    uv(2) = uvLow(4)
    uv(3) = uvHigh(4)
    Set sheet = modeler.CreateSheetFromSurface(surf, uv)
    ' Transform with angle
    Dim mathUtil As SldWorks.MathUtility
    Set mathUtil = swAppIn.GetMathUtility
    Dim aXform As SldWorks.MathTransform
    Dim basePt As SldWorks.MathPoint
    Dim RetVal As Boolean
    Set basePt = mathUtil.CreatePoint(midPt)
    Dim xAxis As MathVector
    Set xAxis = mathUtil.CreateVector(v2)
    Set aXform = mathUtil.CreateTransformRotateAxis(basePt, xAxis, 3.1416159 / 2)
    RetVal = sheet.ApplyTransform(aXform)
    ' Assign edge ID
    Dim edges As Variant
    Dim faces As Variant
    featData.GetEntitiesNeedUserId sheet, faces, edges
    edges = sheet.GetEdges
    For i = 0 To UBound(edges)
        featData.SetEdgeUserId edges(i), i, 0
        Dim id1 As Long
        Dim id2 As Long
        featData.GetEdgeUserId edges(i), id1, id2
    Next i
    Dim editBodies As Variant
    Dim editBdy As Body2
    Dim resBody As Body2
    editBodies = featData.editBodies
    Set editBdy = editBodies(0)
    Dim result As Variant
    Dim err As Long
    result = editBdy.Operations2(SWBODYCUT, sheet, err)
    Dim wb As Long
    featData.GetIntegerByName "WhichBody", wb
    Set resBody = result(wb - 1)
    Set swmMain = resBody
    resBody.Hide partIn
End Function
' Macro feature edit definition function
Sub swmPM(swAppIn, partIn, featureIn)
    Dim swPage As New PropMgr
    swPage.Init swAppIn, partIn, featureIn, swCmdEdit, swAppIn.GetCurrentMacroPathName
    swPage.Show
End Sub
'Inserts macro feature with customized PropertyManager page
Public Sub swmInsertCustomizedMacroFeature()
    Dim swAppIn, partIn, featureIn
    Set swAppIn = Application.SldWorks
    Set partIn = swAppIn.ActiveDoc
    If partIn.GetType() <> swDocPART Then
        MsgBox ("Available only from part document!")
        Exit Sub
    End If
    Dim swPage As New PropMgr
    swPage.Init swAppIn, partIn, featureIn, swCmdCreate, swAppIn.GetCurrentMacroPathName
    swPage.Show
End Sub

Back to top

'PropMgrConst

Public Enum swPageCmdState
    swCmdCreate = 1
    swCmdEdit = 2
End Enum
Public Const ID_GROUP = 1
Public Const ID_SELECTION = 2
Public Const ID_NUMBER = 3

Back to top

 

'PropMgr

Option Explicit
Private m_swApp As SldWorks.SldWorks
Private m_Part As SldWorks.ModelDoc2
Private m_feature As SldWorks.feature
Private m_Page As PropertyManagerPage2
Private m_Group As PropertyManagerPageGroup
Private m_Selection As PropertyManagerPageSelectionbox
Private m_NumberBox As PropertyManagerPageNumberbox
Private m_Text As PropertyManagerPageTextbox
Private m_swPageCmd As New PropMgrCmd
Private m_cmdState As swPageCmdState
Private m_pageHdlr As New PropMgrHdlr
Private Sub Layout()
    Dim swControl As PropertyManagerPageControl
    Dim title As String
    Dim buttonTypes As Long
    Dim Message As String
    Dim Id As Long
    Dim controlType As Integer
    Dim caption As String
    Dim alignment As Integer
    Dim options As Long
    Dim tip As String
    Dim filterArray(0 To 1) As Long
    
    m_pageHdlr.Init Me
    If m_cmdState = swCmdCreate Then
        title = "Cut body macro feature"
    Else
        title = m_feature.Name
    End If
    buttonTypes = swPropertyManagerOptions_OkayButton + swPropertyManagerOptions_CancelButton + swPropertyManagerOptions_LockedPage
    Dim errorh As Long
    Set m_Page = m_swApp.CreatePropertyManagerPage(title, buttonTypes, m_pageHdlr, errorh)
    If Not m_Page Is Nothing Then
        'Initial set up of the message in the PropertyManager page
        Message = "Select body to cut, then select the side of the body to keep."
        m_Page.SetMessage Message, swImportantMessageBox
        'Begin adding the required controls to the PropertyManager
        'Group box
        Id = ID_GROUP
        caption = "Surface on Mass Center"
        options = swGroupBoxOptions_Visible + swGroupBoxOptions_Expanded '+ swGroupBoxOptions_Checked
        Set m_Group = m_Page.AddGroupBox(Id, caption, options)
        If Not m_Group Is Nothing Then
            'Selection box
            Id = ID_SELECTION
            controlType = swControlType_Selectionbox
            caption = "Selection box"
            alignment = swControlAlign_Indent
            options = swControlOptions_Visible + swControlOptions_Enabled
            tip = "Select body"
            Set swControl = m_Group.AddControl2(Id, controlType, caption, alignment, options, tip)
            If Not swControl Is Nothing Then
                Set m_Selection = swControl
                filterArray(0) = swSelSOLIDBODIES
                filterArray(1) = swSelSURFACEBODIES
                m_Selection.SingleEntityOnly = True
                m_Selection.Height = 50
                m_Selection.SingleEntityOnly = True
                m_Selection.SetSelectionFilters (filterArray)
                m_Selection.SetStandardPictureLabel swBitmapLabel_SelectFaceSurface
            End If
            'Selection box
            Id = ID_SELECTION
            controlType = swControlType_Numberbox
            caption = "Number box"
            alignment = swControlAlign_Indent
            options = swControlOptions_Visible + swControlOptions_Enabled
            tip = "Select the body to keep"
            Set swControl = m_Group.AddControl2(Id, controlType, caption, alignment, options, tip)
            If Not swControl Is Nothing Then
                Set m_NumberBox = swControl
                m_NumberBox.SetRange swNumberBox_UnitlessInteger, 1, 2, 1, True
                m_NumberBox.Value = GetCmd().GetNumberValue()
            End If
        End If
    End If
End Sub
Public Sub Show()
    m_Page.Show
End Sub
Sub Init(swApp, part, feature, cmdState As swPageCmdState, macroPath As String)
    Set m_swApp = swApp
    Set m_Part = part
    
    If Not IsEmpty(feature) Then
        Set m_feature = feature
    End If
    m_cmdState = cmdState
    m_Part.ClearSelection2 True
    m_swPageCmd.Init swApp, part, feature, cmdState, macroPath
    Layout
End Sub
Public Function GetCmd() As PropMgrCmd
    Set GetCmd = m_swPageCmd
End Function

 

 

Back to top

 

'PropMgrCmd

Option Explicit
Private m_swApp As SldWorks.SldWorks
Private m_Part As SldWorks.ModelDoc2
Private m_feature As SldWorks.feature
Private m_bodySel As Object
Private m_whichBody As Long
Private m_featData As SldWorks.MacroFeatureData
Private m_modelComp As SldWorks.Component2
Private m_cmdState As swPageCmdState
Private m_macroPath As String
Public Sub Init(swApp, part, feature, cmdState As swPageCmdState, macroPath As String)
    Set m_swApp = swApp
    Set m_Part = part
    m_macroPath = macroPath
    m_whichBody = 1
    If Not IsEmpty(feature) Then
        Set m_feature = feature
    End If
    If cmdState = swCmdEdit Then ' On Edit Definition
   
        Dim ret As Boolean
        Set m_featData = m_feature.GetDefinition
        Set m_modelComp = m_feature.GetComponent
        m_cmdState = cmdState
        ret = m_featData.AccessSelections(m_Part, m_modelComp)
        Dim sels, types, selmarks
       
        Call m_featData.GetSelections3(sels, types, selmarks, Nothing, Nothing)
               
        If Not IsEmpty(sels) And Not sels(0) Is Nothing Then
            Set m_bodySel = sels(0)
            Call m_bodySel.Select(True, selmarks(0))
        End If
        m_featData.GetIntegerByName "WhichBody", m_whichBody
    End If
End Sub
Public Sub OnOk()
    If m_cmdState = swCmdEdit Then ' On Edit Definition
   
        Dim sels, types, selmarks
             
        Call m_featData.GetSelections3(sels, types, selmarks, Nothing, Nothing)
                       
        Dim newSels(0 To 0) As Body2
        Dim newSelMarks(0 To 0) As Long
        
        Set newSels(0) = m_bodySel
        newSelMarks(0) = 0
        sels = newSels
        selmarks = newSelMarks
        
        Dim DrViews(0 To 0) As View
        Set DrViews(0) = Nothing
               
        Call m_featData.SetSelections2(sels, selmarks, DrViews)
        m_featData.SetIntegerByName "WhichBody", m_whichBody
        Call m_feature.ModifyDefinition(m_featData, m_Part, m_modelComp)
    Else ' On Insert feature
        Dim paramNames, paramTypes, paramValues
        Dim pNames(0 To 0) As String
        Dim pTypes(0 To 0) As Long
        Dim pValues(0 To 0) As String
        Dim methods(0 To 8) As String
        methods(0) = m_macroPath
        methods(1) = "Macros"
        methods(2) = "swmMain"
        methods(3) = m_macroPath
        methods(4) = "Macros"
        methods(5) = "swmPM"
        methods(6) = ""
        methods(7) = ""
        methods(8) = ""
        Dim feat As Object
        pNames(0) = "WhichBody"
        pTypes(0) = swMacroFeatureParamTypeInteger
        pValues(0) = m_whichBody
        paramNames = pNames
        paramTypes = pTypes
        paramValues = pValues
        Dim selBodies(0 To 0) As Body2
        Set selBodies(0) = m_bodySel
        Set feat = m_Part.FeatureManager.InsertMacroFeature3("AngleSurf", "", methods, (paramNames), (paramTypes), (paramValues), Nothing, Nothing, selBodies, Nothing, swMacroFeatureByDefault)
    End If
End Sub
 
Public Sub OnCancel()
    If m_cmdState = swCmdEdit Then
        m_featData.ReleaseSelectionAccess
    End If
End Sub
 
Public Sub OnBodySelect()
    Dim selM
    Set selM = m_Part.SelectionManager
    Set m_bodySel = Nothing
    Set m_bodySel = selM.GetSelectedObject6(1, -1)
End Sub
Public Sub OnNumberChanged(Value As Long)
    m_whichBody = Value
End Sub
Public Function GetNumberValue()
    GetNumberValue = m_whichBody
End Function

 

Back to top

'PropMgrHdlr

Option Explicit
Implements PropertyManagerPage2Handler8
 
Dim m_pageObj As PropMgr
Public Sub Init(pageObj As PropMgr)
    Set m_pageObj = pageObj
End Sub
Private Sub PropertyManagerPage2Handler8_OnListboxRMBUp(ByVal Id As Long, ByVal PosX As Long, ByVal PosY As Long)
End Sub
Private Function PropertyManagerPage2Handler8_OnWindowFromHandleControlCreated(ByVal Id As Long, ByVal Status As Boolean) As Long
End Function
 
Private Sub PropertyManagerPage2Handler8_OnLostFocus(ByVal Id As Long)
End Sub
Private Sub PropertyManagerPage2Handler8_OnGainedFocus(ByVal Id As Long)
End Sub
Private Sub PropertyManagerPage2Handler8_OnPopupMenuItemUpdate(ByVal Id As Long, ByRef RetVal As Long)
End Sub
Private Sub PropertyManagerPage2Handler8_OnPopupMenuItem(ByVal Id As Long)
End Sub
Private Function PropertyManagerPage2Handler8_OnKeystroke(ByVal Wparam As Long, ByVal Message As Long, ByVal Lparam As Long, ByVal Id As Long) As Boolean
End Function
 
Private Sub PropertyManagerPage2Handler8_OnSliderTrackingCompleted(ByVal Id As Long, ByVal Value As Double)
End Sub
Private Sub PropertyManagerPage2Handler8_OnSliderPositionChanged(ByVal Id As Long, ByVal Value As Double)
End Sub
 
Private Function PropertyManagerPage2Handler8_OnActiveXControlCreated(ByVal Id As Long, ByVal Status As Boolean) As Long
End Function
Private Function PropertyManagerPage2Handler8_OnSubmitSelection(ByVal Id As Long, ByVal Selection As Object, ByVal SelType As Long, ByRef ItemText As String) As Boolean
    PropertyManagerPage2Handler8_OnSubmitSelection = True
End Function
 
Private Sub PropertyManagerPage2Handler8_OnSelectionboxCalloutDestroyed(ByVal Id As Long)
End Sub
Private Sub PropertyManagerPage2Handler8_OnSelectionboxCalloutCreated(ByVal Id As Long)
End Sub
Private Sub PropertyManagerPage2Handler8_OnComboboxEditChanged(ByVal Id As Long, ByVal Text As String)
End Sub
Private Function PropertyManagerPage2Handler8_OnTabClicked(ByVal Id As Long) As Boolean
End Function
Private Sub PropertyManagerPage2Handler8_OnRedo()
End Sub
Private Sub PropertyManagerPage2Handler8_OnUndo()
End Sub
Private Sub PropertyManagerPage2Handler8_OnWhatsNew()
End Sub
Private Function PropertyManagerPage2Handler8_OnPreview() As Boolean
End Function
 
Private Function PropertyManagerPage2Handler8_OnNextPage() As Boolean
End Function
 
Private Function PropertyManagerPage2Handler8_OnPreviousPage() As Boolean
End Function
 
Private Sub PropertyManagerPage2Handler8_AfterActivation()
End Sub
 
Private Function PropertyManagerPage2Handler8_ConnectToSW(ByVal ThisSW As Object, ByVal Cookie As Long) As Boolean
 
End Function
 
Private Sub PropertyManagerPage2Handler8_OnButtonPress(ByVal Id As Long)
End Sub
 
Private Sub PropertyManagerPage2Handler8_OnClose(ByVal reason As Long)
    If reason = swPropertyManagerPageClose_Okay Then
        m_pageObj.GetCmd().OnOk
    ElseIf reason = swPropertyManagerPageClose_Cancel Then
        m_pageObj.GetCmd().OnCancel
    End If
End Sub
 
Private Sub PropertyManagerPage2Handler8_OnCheckboxCheck(ByVal Id As Long, ByVal Checked As Boolean)
End Sub
 
Private Sub PropertyManagerPage2Handler8_OnComboboxSelectionChanged(ByVal Id As Long, ByVal Item As Long)
End Sub
 
Private Sub PropertyManagerPage2Handler8_OnGroupCheck(ByVal Id As Long, ByVal Checked As Boolean)
End Sub
 
Private Sub PropertyManagerPage2Handler8_OnGroupExpand(ByVal Id As Long, ByVal Expanded As Boolean)
End Sub
 
Private Function PropertyManagerPage2Handler8_OnHelp() As Boolean
End Function
 
Private Sub PropertyManagerPage2Handler8_OnListboxSelectionChanged(ByVal Id As Long, ByVal Item As Long)
End Sub
 
Private Sub PropertyManagerPage2Handler8_OnNumberboxChanged(ByVal Id As Long, ByVal Value As Double)
    m_pageObj.GetCmd().OnNumberChanged Int(Value)
End Sub
 
Private Sub PropertyManagerPage2Handler8_AfterClose()
    Set m_pageObj = Nothing
End Sub
 
Private Sub PropertyManagerPage2Handler8_OnOptionCheck(ByVal Id As Long)
End Sub
 
Private Sub PropertyManagerPage2Handler8_OnSelectionboxFocusChanged(ByVal Id As Long)
End Sub
 
Private Sub PropertyManagerPage2Handler8_OnTextboxChanged(ByVal Id As Long, ByVal Text As String)
 
End Sub
 
Private Sub PropertyManagerPage2Handler8_OnSelectionBoxListChanged(ByVal Id As Long, ByVal Text As Long)
    m_pageObj.GetCmd().OnBodySelect
End Sub

Back to top



Provide feedback on this topic

SOLIDWORKS welcomes your feedback concerning the presentation, accuracy, and thoroughness of the documentation. Use the form below to send your comments and suggestions about this topic directly to our documentation team. The documentation team cannot answer technical support questions. Click here for information about technical support.

* Required

 
*Email:  
Subject:   Feedback on Help Topics
Page:   Cut Body in Half using Macro Feature Example (VBA)
*Comment:  
*   I acknowledge I have read and I hereby accept the privacy policy under which my Personal Data will be used by Dassault Systèmes

Print Topic

Select the scope of content to print:



x

We have detected you are using a browser version older than Internet Explorer 7. For optimized display, we suggest upgrading your browser to Internet Explorer 7 or newer.

 Never show this message again
x

Web Help Content Version: API Help (English only) 2017 SP05

To disable Web help from within SOLIDWORKS and use local help instead, click Help > Use SOLIDWORKS Web Help.

To report problems encountered with the Web help interface and search, contact your local support representative. To provide feedback on individual help topics, use the “Feedback on this topic” link on the individual topic page.