Private Sub Form_Load()
Dim objApp As SolidEdgeFramework.Application
Dim objDoc As SolidEdgePart.PartDocument
Dim objBaseProfile(1 To 2) As SolidEdgePart.Profile
Dim objLine1 As SolidEdgeFrameworkSupport.Line2d
Dim objLine2 As SolidEdgeFrameworkSupport.Line2d
Dim objArc1 As SolidEdgeFrameworkSupport.Arc2d
Dim objArc2 As SolidEdgeFrameworkSupport.Arc2d
Dim objModel As SolidEdgePart.Model
Dim objExtProtrusion As SolidEdgePart.ExtrudedProtrusion
Dim objRelations As SolidEdgeFrameworkSupport.Relations2d
Dim objTraceRefPlane As SolidEdgePart.RefPlane
Dim objTraceprofile(1 To 2) As SolidEdgePart.Profile
Dim objCSRefPlane As SolidEdgePart.RefPlane
Dim objCSProfile(1 To 2) As SolidEdgePart.Profile
Dim vOriginArray(2) As Variant
Dim objSweptCutout As SolidEdgePart.SweptCutout
Dim lngStatus As Long
Dim lngTraceCurveTypes(1 To 2) As Long
Dim lngCrossSectionTypes(1 To 2) As Long
Dim strSwCutName As String
' 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
On Error GoTo 0
'Create an Extruded Protrusion as Base feature
'Draw the base Profile
Set objBaseProfile(1) = objDoc.ProfileSets.Add.Profiles.Add(pRefPlaneDisp:=objDoc.RefPlanes(1))
Set objLine1 = objBaseProfile(1).Lines2d.AddBy2Points(x1:=0.05, y1:=0, x2:=0.05, y2:=0.15)
Set objArc1 = objBaseProfile(1).Arcs2d.AddByCenterStartEnd(xCenter:=0.025, yCenter:=0.15, _
xStart:=0.05, yStart:=0.15, xEnd:=0, yEnd:=0.15)
Set objLine2 = objBaseProfile(1).Lines2d.AddBy2Points(x1:=0, y1:=0.15, x2:=0, y2:=0)
Set objArc2 = objBaseProfile(1).Arcs2d.AddByCenterStartEnd(xCenter:=0.025, yCenter:=0, _
xStart:=0, yStart:=0, xEnd:=0.05, yEnd:=0)
' Define Relations among the Line and Arc objects to make the Profile closed
Set objRelations = objBaseProfile(1).Relations2d
Call objRelations.AddKeypoint(Object1:=objLine1, Index1:=igLineEnd, _
Object2:=objArc1, Index2:=igArcStart)
Call objRelations.AddKeypoint(Object1:=objArc1, Index1:=igArcEnd, _
Object2:=objLine2, Index2:=igLineStart)
Call objRelations.AddKeypoint(Object1:=objLine2, Index1:=igLineEnd, _
Object2:=objArc2, Index2:=igArcStart)
Call objRelations.AddKeypoint(Object1:=objArc2, Index1:=igArcEnd, _
Object2:=objLine1, Index2:=igLineStart)
' Check for the Profile Validity
lngStatus = objBaseProfile(1).End(ValidationCriteria:=igProfileClosed)
If lngStatus <> 0 Then
MsgBox ("Base feature profile is not closed")
End If
'Create the Base Extruded Protrusion Feature
Set objModel = objDoc.Models.AddFiniteExtrudedProtrusion(NumberOfProfiles:=1, ProfileArray:=objBaseProfile, _
ProfilePlaneSide:=igRight, ExtrusionDistance:=0.05)
objBaseProfile(1).Visible = False
Set objExtProtrusion = objModel.ExtrudedProtrusions(1)
' Check the status of Base Feature
If objExtProtrusion.Status <> igFeatureOK Then
MsgBox "Base Feature is not created properly"
End If
'Create SweptCutout with Add method
'Draw the Trace profile
Set objTraceRefPlane = objDoc.RefPlanes.AddParallelByDistance(ParentPlane:=objDoc.RefPlanes(1), _
Distance:=0.05, NormalSide:=igRight, Local:=True)
Set objTraceprofile(1) = objDoc.ProfileSets.Add.Profiles.Add(pRefPlaneDisp:=objTraceRefPlane)
Set objLine1 = objTraceprofile(1).Lines2d.AddBy2Points(x1:=0.05, y1:=0, x2:=0.05, y2:=0.15)
Set objArc1 = objTraceprofile(1).Arcs2d.AddByCenterStartEnd(xCenter:=0.025, yCenter:=0.15, _
xStart:=0.05, yStart:=0.15, xEnd:=0, yEnd:=0.15)
Set objLine2 = objTraceprofile(1).Lines2d.AddBy2Points(x1:=0, y1:=0.15, x2:=0, y2:=0)
Set objArc2 = objTraceprofile(1).Arcs2d.AddByCenterStartEnd(xCenter:=0.025, yCenter:=0, _
xStart:=0, yStart:=0, xEnd:=0.05, yEnd:=0)
' Define Relations among the Line and Arc objects to make the Trace Profile closed
Set objRelations = objTraceprofile(1).Relations2d
Call objRelations.AddKeypoint(Object1:=objLine1, Index1:=igLineEnd, _
Object2:=objArc1, Index2:=igArcStart)
Call objRelations.AddKeypoint(Object1:=objArc1, Index1:=igArcEnd, _
Object2:=objLine2, Index2:=igLineStart)
Call objRelations.AddKeypoint(Object1:=objLine2, Index1:=igLineEnd, _
Object2:=objArc2, Index2:=igArcStart)
Call objRelations.AddKeypoint(Object1:=objArc2, Index1:=igArcEnd, _
Object2:=objLine1, Index2:=igLineStart)
' Check for the Trace Profile Validity
lngStatus = objTraceprofile(1).End(ValidationCriteria:=igProfileClosed)
If lngStatus <> 0 Then
MsgBox ("Trace profile is not closed")
End If
' Create a reference plane for Cross section profile
Set objCSRefPlane = objDoc.RefPlanes.AddNormalToCurve( _
Curve:=objLine1, _
PlanePoint:=igCurveStart, _
OrientationPlaneOrPivot:=objDoc.RefPlanes(1), _
PivotOrigin:=igPivotEnd, _
Local:=True, _
ParentCurve:=objTraceprofile(1))
' Draw the Cross Section profile
Set objCSProfile(1) = objDoc.ProfileSets.Add.Profiles.Add(pRefPlaneDisp:=objCSRefPlane)
Call objCSProfile(1).Circles2d.AddByCenterRadius(x:=0, y:=0, Radius:=0.01)
' Check for the Cross section Profile Validity
lngStatus = objCSProfile(1).End(ValidationCriteria:=igProfileClosed)
If lngStatus <> 0 Then
MsgBox ("Cross-section profile is not closed")
End If
'Create SweptCutout Feature
lngTraceCurveTypes(1) = igProfileBasedCrossSection
lngCrossSectionTypes(1) = igProfileBasedCrossSection
vOriginArray(1) = 0
Set objSweptCutout = objModel.SweptCutouts.Add(NumCurves:=1, _
TraceCurves:=objTraceprofile, TraceCurveTypes:=lngTraceCurveTypes, NumSections:=1, _
CrossSections:=objCSProfile, CrossSectionTypes:=lngCrossSectionTypes, _
Origins:=vOriginArray, SegmentMaps:=0, MaterialSide:=igLeft, StartExtentType:=igNone, _
StartExtentDistance:=0, StartSurfaceOrRefPlane:=Nothing, EndExtentType:=igNone, _
EndExtentDistance:=0, EndSurfaceOrRefPlane:=Nothing)
objTraceprofile(1).Visible = False
objCSProfile(1).Visible = False
' Check the status of SweptCutout Feature
If objSweptCutout.Status <> igFeatureOK Then
MsgBox "Add method of the SweptCutouts object Failed"
End If
'Get the Name of SweptCutout feature
strSwCutName = objSweptCutout.Name
' USER DISPLAY
' Release objects
Set objApp = Nothing
Set objDoc = Nothing
Set objBaseProfile(1) = Nothing
Set objBaseProfile(2) = Nothing
Set objLine1 = Nothing
Set objLine2 = Nothing
Set objArc1 = Nothing
Set objArc2 = Nothing
Set objModel = Nothing
Set objExtProtrusion = Nothing
Set objRelations = Nothing
Set objTraceRefPlane = Nothing
Set objTraceprofile(1) = Nothing
Set objTraceprofile(2) = Nothing
Set objCSRefPlane = Nothing
Set objCSProfile(1) = Nothing
Set objCSProfile(2) = Nothing
Set vOriginArray(1) = Nothing
Set vOriginArray(2) = Nothing
Set objSweptCutout = Nothing
End Sub