Private Sub Form_Load()
Dim objApp As solidEdgeFramework.Application
Dim objDoc As solidEdgePart.PartDocument
Dim objBaseProfile As solidEdgePart.Profile
Dim objBaseProfileArray(1 To 2) As solidEdgePart.Profile
Dim objBaseModel As solidEdgePart.Model
Dim objEPPlane As solidEdgePart.RefPlane
Dim objEPProfile As solidEdgePart.Profile
Dim objExtProt As solidEdgePart.ExtrudedProtrusion
Dim objRPProfile As solidEdgePart.Profile
Dim objLine As solidEdgeFrameworkSupport.Line2d
Dim objRefAxis As solidEdgePart.RefAxis
Dim objRevProt As solidEdgePart.RevolvedProtrusion
Dim lngType As Long
Dim lngStatus As Long
' Report errors
Const PI = 3.14159265358979
' Create/get the application with specific settings
On Error Resume Next
Set objApp = GetObject(, "SolidEdge.Application")
If Err Then
Err.Clear
Set objApp = CreateObject("SolidEdge.Application")
Set objDoc = objApp.Documents.Add("SolidEdge.PartDocument")
objApp.Visible = True
Else
Set objDoc = objApp.ActiveDocument
End If
' *** creating the base feature
' creating the profile for the base feature and validating it
Set objBaseProfile = objDoc.ProfileSets.Add.Profiles.Add(pRefPlaneDisp:=objDoc.RefPlanes(1))
Call objBaseProfile.Circles2d.AddByCenterRadius(x:=0, y:=0, Radius:=0.01)
lngStatus = objBaseProfile.End(ValidationCriteria:=igProfileClosed)
If lngStatus <> 0 Then
MsgBox "Profile for the base feature is not closed"
End If
' creating the base extruded protrusion feature and validating it
Set objBaseProfileArray(1) = objBaseProfile
Set objBaseModel = objDoc.Models.AddFiniteExtrudedProtrusion(NumberOfProfiles:=1, _
ProfileArray:=objBaseProfileArray, ProfilePlaneSide:=igSymmetric, ExtrusionDistance:=0.1)
If (objBaseModel.ExtrudedProtrusions(1).Status <> igFeatureOK) Then
MsgBox "AddFiniteExtrudedProtrusion of Models object fails"
End If
objBaseProfile.Visible = False
' *** creating a extruded protrusion on the base feature
' creating the profile and validating it
Set objEPPlane = objDoc.RefPlanes.AddParallelByDistance(ParentPlane:=objDoc.RefPlanes(1), _
Distance:=0.05, NormalSide:=igRight)
Set objEPProfile = objDoc.ProfileSets.Add.Profiles.Add(pRefPlaneDisp:=objEPPlane)
Call objEPProfile.Circles2d.AddByCenterRadius(x:=0, y:=0, Radius:=0.0075)
lngStatus = objEPProfile.End(ValidationCriteria:=igProfileClosed)
If lngStatus <> 0 Then
MsgBox "Profile for the extruded protrusion feature is not closed"
End If
' creating the extruded protrusion feature and validating it
Set objExtProt = objBaseModel.ExtrudedProtrusions.AddFinite(Profile:=objEPProfile, _
profileSide:=igLeft, ProfilePlaneSide:=igRight, Depth:=0.05)
If (objExtProt.Status <> igFeatureOK) Then
MsgBox "AddFinite method of the ExtrudedProtrusions object fails"
End If
objEPProfile.Visible = False
' *** creating a revolved protrusion feature
' creating the ref axis & profile and validating it
Set objRPProfile = objDoc.ProfileSets.Add.Profiles.Add(pRefPlaneDisp:=objDoc.RefPlanes(2))
Call objRPProfile.Circles2d.AddByCenterRadius(x:=0.05, y:=0, Radius:=0.025)
lngStatus = objRPProfile.End(ValidationCriteria:=igProfileClosed)
If (lngStatus <> 0) Then
MsgBox "Profile for the revolved protrusion feature is not closed"
End If
Set objLine = objRPProfile.Lines2d.AddBy2Points(x1:=0, y1:=-0.05, x2:=0, y2:=0.05)
Set objRefAxis = objRPProfile.SetAxisOfRevolution(lineforaxis:=objLine)
' creating the revolved protrusion and validating it
Set objRevProt = objBaseModel.RevolvedProtrusions.AddFinite(Profile:=objRPProfile, RefAxis:=objRefAxis, _
profileSide:=igLeft, ProfilePlaneSide:=igSymmetric, AngleOfRevolution:=(2 * PI / 3))
objRPProfile.Visible = False
If (objRevProt.Status <> igFeatureOK) Then
MsgBox "AddFiniteRevolvedProtrusion method of the Models object fails"
End If
' reordering the revolved protrusion to place it below the extruded protrusion
Call objRevProt.Reorder(TargetFeature:=objBaseModel.Features(1), InsertBefore:=False)
' checking whether the revolved protrusion has been reordered or not
If Not (objBaseModel.Features.Item(2) Is objRevProt) Then
MsgBox "Reorder method of the RevolvedProtrusion object fails"
End If
' USER DISPLAY
' Release objects
Set objApp = Nothing
Set objDoc = Nothing
Set objBaseProfile = Nothing
Set objBaseProfileArray(1) = Nothing
Set objBaseModel = Nothing
Set objRPProfile = Nothing
Set objLine = Nothing
Set objRefAxis = Nothing
Set objRevProt = Nothing
End Sub