Files
Code
Module: mMain
Dim pm As clsPMP 'Needs to be outside of module
Public swApp As SldWorks.SldWorks
Public swModel As SldWorks.ModelDoc2
Public swBody As SldWorks.Body2
Public Const GROUP_SKETCH_ID = 0
Public Const GROUP_CYL_ID = 1
Public Const GROUP_CONE_ID = 2
Public Const REVERSE_ID = 3
Public Const SKETCH_ID = 4
Public Const CYL_RAD_ID = 5
Public Const CYL_DEPTH_ID = 6
Public Const CONE_RAD_ID = 7
Public Const CONE_DEPTH_ID = 8
Public dblCylRad As Double
Public dblCylDepth As Double
Public dblConeRad As Double
Public dblConeDepth As Double
Public dblCylLoc(2) As Double
Public dblConeLoc(2) As Double
Public dblVect(2) As Double
Public dblRelVect(2) As Double
Sub main()
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
'Make sure a part is open
If swModel.GetType <> swDocPART Then
MsgBox "Run in part only."
End
End If
'Create the PMP
Set pm = New clsPMP
pm.CreateLayout swApp
End SubModule: mSpikeCreator
Sub CreateSpike()
Dim swModeler As SldWorks.Modeler
Set swModeler = swApp.GetModeler
'Create cylinder
Dim swCylBody As SldWorks.Body2
Dim dblCylData(7) As Double
dblCylData(0) = dblCylLoc(0) 'center of face (x coord)
dblCylData(1) = dblCylLoc(1) 'center of face (y coord)
dblCylData(2) = dblCylLoc(2) 'center of face (z coord)
dblCylData(3) = dblRelVect(0) 'axis vector (x component)
dblCylData(4) = dblRelVect(1) 'axis vector (y component)
dblCylData(5) = dblRelVect(2) 'axis vector (z component)
dblCylData(6) = dblCylRad 'radius
dblCylData(7) = dblCylDepth 'extrude length
Set swCylBody = swModeler.CreateBodyFromCyl(dblCylData)
swCylBody.Display3 swModel, 255, 0
'Create cone
Call GetFaceCenter
Dim swConeBody As SldWorks.Body2
Dim dblConeData(8) As Double
dblConeData(0) = dblConeLoc(0) 'center of face (x coord)
dblConeData(1) = dblConeLoc(1) 'center of face (y coord)
dblConeData(2) = dblConeLoc(2) 'center of face (z coord)
dblConeData(3) = dblRelVect(0) 'axis vector (x component)
dblConeData(4) = dblRelVect(1) 'axis vector (y component)
dblConeData(5) = dblRelVect(2) 'axis vector (z component)
dblConeData(6) = dblConeRad 'base radius
dblConeData(7) = 0 'top radius
dblConeData(8) = dblConeDepth 'extrude length
Set swConeBody = swModeler.CreateBodyFromCone(dblConeData)
swConeBody.Display3 swModel, 255, 0
'Add bodies
Dim vBodies As Variant
Dim lngErrors As Long
vBodies = swConeBody.Operations2(SWBODYADD, swCylBody, lngErrors)
If lngErrors <> 0 Then
swApp.SendMsgToUser "Boolean operation error: " & lngErrors
Exit Sub
End If
Set swBody = vBodies(0)
End SubModule: mTransform
Dim swMathUtil As SldWorks.MathUtility
Dim swTransform As SldWorks.MathTransform
Dim swMathPt As SldWorks.MathPoint
Dim swMathVect As SldWorks.MathVector
Dim vPts As Variant
Sub SketchTransform(swSketch As SldWorks.Sketch)
Set swMathUtil = swApp.GetMathUtility
'Create the new math pt from sketch data
Set swMathPt = swMathUtil.CreatePoint(dblCylLoc)
'Get the model-to-sketch transform of the sketch
Set swTransform = swSketch.ModelToSketchTransform
'Get the sketch-to-model transform
Set swTransform = swTransform.Inverse
'Get math pt relative to model space
Set swMathPt = swMathPt.MultiplyTransform(swTransform)
'Extract pt data
vPts = swMathPt.ArrayData
dblCylLoc(0) = vPts(0)
dblCylLoc(1) = vPts(1)
dblCylLoc(2) = vPts(2)
End Sub
Sub NormalTransform(swSketch As SldWorks.Sketch)
'By default, the sketch is normal to the Z axis. Create Z-axis vector to transform _
to model space
dblVect(0) = 0
dblVect(1) = 0
Set swMathVect = swMathUtil.CreateVector(dblVect)
Set swMathVect = swMathVect.MultiplyTransform(swTransform)
vPts = swMathVect.ArrayData
dblRelVect(0) = vPts(0)
dblRelVect(1) = vPts(1)
dblRelVect(2) = vPts(2)
End Sub
Sub GetFaceCenter()
Set swMathVect = swMathVect.Normalise
vPts = swMathVect.ArrayData
dblConeLoc(0) = dblCylLoc(0) + vPts(0) * dblCylDepth
dblConeLoc(1) = dblCylLoc(1) + vPts(1) * dblCylDepth
dblConeLoc(2) = dblCylLoc(2) + vPts(2) * dblCylDepth
End SubClass: clsPMP
Dim pmHandler As clsPMPHandler
Dim pmPage As SldWorks.PropertyManagerPage2
Dim pmGroupSketch As SldWorks.PropertyManagerPageGroup
Dim pmGroupCyl As SldWorks.PropertyManagerPageGroup
Dim pmGroupCone As SldWorks.PropertyManagerPageGroup
Public pmCheckboxReverse As SldWorks.PropertyManagerPageCheckbox
Public pmSelBoxSketch As SldWorks.PropertyManagerPageSelectionbox
Public pmNumBoxCylRad As SldWorks.PropertyManagerPageNumberbox
Public pmNumBoxCylDepth As SldWorks.PropertyManagerPageNumberbox
Public pmNumBoxConeRad As SldWorks.PropertyManagerPageNumberbox
Public pmNumBoxConeDepth As SldWorks.PropertyManagerPageNumberbox
Dim lngErrors As Long
Sub CreateLayout(swApp As SldWorks.SldWorks)
Set pmHandler = New clsPMPHandler
Set pmPage = swApp.CreatePropertyManagerPage("Create spike", _
swPropertyManagerOptions_OkayButton + swPropertyManagerOptions_CancelButton + _
swPropertyManagerOptions_LockedPage, pmHandler, lngErrors)
If lngErrors = 0 Then
'Set message
pmPage.SetMessage3 "Select a 2D sketch containing a sketch point. Spike is created normal to the sketch plane.", swImportantMessageBox, _
swMessageBoxMaintainExpandState, Empty
'Group box - sketch selection
Set pmGroupSketch = pmPage.AddGroupBox(GROUP_SKETCH_ID, "Sketch", _
swGroupBoxOptions_Expanded + swGroupBoxOptions_Visible)
'Selection box - selection box
Set pmSelBoxSketch = pmGroupSketch.AddControl(SKETCH_ID, _
swControlType_Selectionbox, Empty, swControlAlign_Indent, _
swControlOptions_Visible + swControlOptions_Enabled, "Select sketch")
pmSelBoxSketch.SetSelectionFilters swSelSKETCHES
pmSelBoxSketch.SetStandardPictureLabel swBitmapLabel_SelectProfile
pmSelBoxSketch.SingleEntityOnly = True
pmSelBoxSketch.Height = 13
'Checkbox - reverse direction
Set pmCheckboxReverse = pmGroupSketch.AddControl(REVERSE_ID, _
swControlType_Checkbox, "Reverse direction", swControlAlign_Indent, _
swControlOptions_Visible + swControlOptions_Enabled, "Reverse direction")
'Group box - cylinder
Set pmGroupCyl = pmPage.AddGroupBox(GROUP_CYL_ID, "Cylinder", _
swGroupBoxOptions_Expanded + swGroupBoxOptions_Visible)
'Number box - cylinder radius
Set pmNumBoxCylRad = pmGroupCyl.AddControl(CYL_RAD_ID, _
swControlType_Numberbox, Empty, swControlAlign_Indent, _
swControlOptions_Visible + swControlOptions_Enabled, "Radius")
pmNumBoxCylRad.Value = 0.005
pmNumBoxCylRad.SetRange2 swNumberBox_Length, 0, 1, True, 0.005, 0.005, 0.005
pmNumBoxCylRad.SetStandardPictureLabel swBitmapLabel_Radius
'Number box - cylinder depth
Set pmNumBoxCylDepth = pmGroupCyl.AddControl(CYL_DEPTH_ID, _
swControlType_Numberbox, Empty, swControlAlign_Indent, _
swControlOptions_Visible + swControlOptions_Enabled, "Depth")
pmNumBoxCylDepth.Value = 0.01
pmNumBoxCylDepth.SetRange2 swNumberBox_Length, 0, 1, True, 0.005, 0.005, 0.005
pmNumBoxCylDepth.SetStandardPictureLabel swBitmapLabel_LinearDistance
'Group box - cone
Set pmGroupCone = pmPage.AddGroupBox(GROUP_CONE_ID, "Cone", _
swGroupBoxOptions_Expanded + swGroupBoxOptions_Visible)
'Number box - cone radius
Set pmNumBoxConeRad = pmGroupCone.AddControl(CONE_RAD_ID, _
swControlType_Numberbox, Empty, swControlAlign_Indent, _
swControlOptions_Visible + swControlOptions_Enabled, "Radius")
pmNumBoxConeRad.Value = 0.005
pmNumBoxConeRad.SetRange2 swNumberBox_Length, 0, 1, True, 0.005, 0.005, 0.005
pmNumBoxConeRad.SetStandardPictureLabel swBitmapLabel_Radius
'Number box - cone depth
Set pmNumBoxConeDepth = pmGroupCone.AddControl(CONE_DEPTH_ID, _
swControlType_Numberbox, Empty, swControlAlign_Indent, _
swControlOptions_Visible + swControlOptions_Enabled, "Depth")
pmNumBoxConeDepth.Value = 0.01
pmNumBoxConeDepth.SetRange2 swNumberBox_Length, 0, 1, True, 0.005, 0.005, 0.005
pmNumBoxConeDepth.SetStandardPictureLabel swBitmapLabel_LinearDistance
'Display the PMP
pmPage.Show2 0
Else
Debug.Print "Error creating PropertyManager page."
End If
End SubClass: clsPMPHandler
Implements PropertyManagerPage2Handler8
Dim swFeat As SldWorks.Feature
Dim swSketchMgr As SldWorks.SketchManager
Dim swSketch As SldWorks.Sketch
Dim swSketchPt As SldWorks.SketchPoint
Dim vSketchPts As Variant
Private Sub PropertyManagerPage2Handler8_AfterActivation()
dblCylRad = 0.005
dblCylDepth = 0.01
dblConeRad = 0.005
dblConeDepth = 0.01
dblVect(2) = 1
End Sub
Private Sub PropertyManagerPage2Handler8_AfterClose()
End Sub
Private Function PropertyManagerPage2Handler8_OnActiveXControlCreated(ByVal Id As Long, ByVal Status As Boolean) As Long
End Function
Private Sub PropertyManagerPage2Handler8_OnButtonPress(ByVal Id As Long)
End Sub
Private Sub PropertyManagerPage2Handler8_OnCheckboxCheck(ByVal Id As Long, ByVal Checked As Boolean)
dblVect(2) = dblVect(2) * -1
Call NormalTransform(swSketch)
Call CreateSpike
End Sub
Private Sub PropertyManagerPage2Handler8_OnClose(ByVal Reason As Long)
If Reason = swPropertyManagerPageClose_Okay Then
'Turn temporary body into feature
Dim swPart As SldWorks.PartDoc
Set swPart = swModel
swPart.CreateFeatureFromBody3 swBody, False, 0
End If
Set swBody = Nothing
End Sub
Private Sub PropertyManagerPage2Handler8_OnComboboxEditChanged(ByVal Id As Long, ByVal Text As String)
End Sub
Private Sub PropertyManagerPage2Handler8_OnComboboxSelectionChanged(ByVal Id As Long, ByVal Item As Long)
End Sub
Private Sub PropertyManagerPage2Handler8_OnGainedFocus(ByVal Id 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 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_OnListboxRMBUp(ByVal Id As Long, ByVal PosX As Long, ByVal PosY As Long)
End Sub
Private Sub PropertyManagerPage2Handler8_OnListboxSelectionChanged(ByVal Id As Long, ByVal Item As Long)
End Sub
Private Sub PropertyManagerPage2Handler8_OnLostFocus(ByVal Id As Long)
End Sub
Private Function PropertyManagerPage2Handler8_OnNextPage() As Boolean
End Function
Private Sub PropertyManagerPage2Handler8_OnNumberboxChanged(ByVal Id As Long, ByVal Value As Double)
If Id = CYL_RAD_ID Then dblCylRad = Value
If Id = CYL_DEPTH_ID Then dblCylDepth = Value
If Id = CONE_RAD_ID Then dblConeRad = Value
If Id = CONE_DEPTH_ID Then dblConeDepth = Value
Call CreateSpike
End Sub
Private Sub PropertyManagerPage2Handler8_OnOptionCheck(ByVal Id As Long)
End Sub
Private Sub PropertyManagerPage2Handler8_OnPopupMenuItem(ByVal Id As Long)
End Sub
Private Sub PropertyManagerPage2Handler8_OnPopupMenuItemUpdate(ByVal Id As Long, retval As Long)
End Sub
Private Function PropertyManagerPage2Handler8_OnPreview() As Boolean
End Function
Private Function PropertyManagerPage2Handler8_OnPreviousPage() As Boolean
End Function
Private Sub PropertyManagerPage2Handler8_OnRedo()
End Sub
Private Sub PropertyManagerPage2Handler8_OnSelectionboxCalloutCreated(ByVal Id As Long)
End Sub
Private Sub PropertyManagerPage2Handler8_OnSelectionboxCalloutDestroyed(ByVal Id As Long)
End Sub
Private Sub PropertyManagerPage2Handler8_OnSelectionboxFocusChanged(ByVal Id As Long)
End Sub
Private Sub PropertyManagerPage2Handler8_OnSelectionboxListChanged(ByVal Id As Long, ByVal Count As Long)
If Count = 0 Then Set swBody = Nothing
End Sub
Private Sub PropertyManagerPage2Handler8_OnSliderPositionChanged(ByVal Id As Long, ByVal Value As Double)
End Sub
Private Sub PropertyManagerPage2Handler8_OnSliderTrackingCompleted(ByVal Id As Long, ByVal Value As Double)
End Sub
Private Function PropertyManagerPage2Handler8_OnSubmitSelection(ByVal Id As Long, ByVal Selection As Object, ByVal SelType As Long, ItemText As String) As Boolean
PropertyManagerPage2Handler8_OnSubmitSelection = True
'Get sketch pt coordinates
Set swFeat = Selection 'even though SelItem says sketch, its actually a feature
Set swSketch = swFeat.GetSpecificFeature2
vSketchPts = swSketch.GetSketchPoints2
Set swSketchPt = vSketchPts(0)
dblCylLoc(0) = swSketchPt.X
dblCylLoc(1) = swSketchPt.Y
dblCylLoc(2) = swSketchPt.Z
Call SketchTransform(swSketch)
'Get axis vector
Call NormalTransform(swSketch)
'Create temporary body for preview
Call CreateSpike
swModel.ViewZoomtofit2
End Function
Private Function PropertyManagerPage2Handler8_OnTabClicked(ByVal Id As Long) As Boolean
End Function
Private Sub PropertyManagerPage2Handler8_OnTextboxChanged(ByVal Id As Long, ByVal Text As String)
End Sub
Private Sub PropertyManagerPage2Handler8_OnUndo()
End Sub
Private Sub PropertyManagerPage2Handler8_OnWhatsNew()
End Sub
Private Function PropertyManagerPage2Handler8_OnWindowFromHandleControlCreated(ByVal Id As Long, ByVal Status As Boolean) As Long
End Function