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 objSweptProtrusion As SolidEdgePart.SweptProtrusion
Dim objSweptApplication As SolidEdgeFramework.Application
Dim lngStatus As Long
Dim lngTraceCurveTypes(1 To 2) As Long
Dim lngCrossSectionTypes(1 To 2) 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
On Error GoTo 0
'Create an Extruded Protrusion as Base feature
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)
Set objRelations = objBaseProfile(1).Relations2d
objRelations.AddKeypoint Object1:=objLine1, Index1:=igLineEnd, Object2:=objArc1, Index2:=igArcStart
objRelations.AddKeypoint Object1:=objArc1, Index1:=igArcEnd, Object2:=objLine2, Index2:=igLineStart
objRelations.AddKeypoint Object1:=objLine2, Index1:=igLineEnd, Object2:=objArc2, Index2:=igArcStart
objRelations.AddKeypoint Object1:=objArc2, Index1:=igArcEnd, Object2:=objLine1, Index2:=igLineStart
lngStatus = objBaseProfile(1).End(ValidationCriteria:=igProfileClosed)
If lngStatus <> 0 Then
MsgBox ("Base feature profile is not closed")
End If
Set objModel = objDoc.Models.AddFiniteExtrudedProtrusion(NumberOfProfiles:=1, ProfileArray:=objBaseProfile, _
ProfilePlaneSide:=igRight, ExtrusionDistance:=0.05)
objBaseProfile(1).Visible = False
Set objExtProtrusion = objModel.ExtrudedProtrusions(1)
If objExtProtrusion.Status <> igFeatureOK Then
MsgBox "Base Feature is not created properly"
End If
'Create SweptProtrusion with Add method
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)
Set objRelations = objTraceprofile(1).Relations2d
objRelations.AddKeypoint Object1:=objLine1, Index1:=igLineEnd, Object2:=objArc1, Index2:=igArcStart
objRelations.AddKeypoint Object1:=objArc1, Index1:=igArcEnd, Object2:=objLine2, Index2:=igLineStart
objRelations.AddKeypoint Object1:=objLine2, Index1:=igLineEnd, Object2:=objArc2, Index2:=igArcStart
objRelations.AddKeypoint Object1:=objArc2, Index1:=igArcEnd, Object2:=objLine1, Index2:=igLineStart
lngStatus = objTraceprofile(1).End(ValidationCriteria:=igProfileClosed)
If lngStatus <> 0 Then
MsgBox ("Trace profile is not closed")
End If
Set objCSRefPlane = objDoc.RefPlanes.AddNormalToCurve( _
Curve:=objLine1, _
PlanePoint:=igCurveStart, _
OrientationPlaneOrPivot:=objDoc.RefPlanes(1), _
PivotOrigin:=igPivotEnd, _
Local:=True, _
ParentCurve:=objTraceprofile(1))
Set objCSProfile(1) = objDoc.ProfileSets.Add.Profiles.Add(pRefPlaneDisp:=objCSRefPlane)
Call objCSProfile(1).Circles2d.AddByCenterRadius(x:=0, y:=0, Radius:=0.01)
lngStatus = objCSProfile(1).End(ValidationCriteria:=igProfileClosed)
If lngStatus <> 0 Then
MsgBox ("Cross-section profile is not closed")
End If
lngTraceCurveTypes(1) = igProfileBasedCrossSection
lngCrossSectionTypes(1) = igProfileBasedCrossSection
vOriginArray(1) = 0
Set objSweptProtrusion = objModel.SweptProtrusions.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
If objSweptProtrusion.Status <> igFeatureOK Then
MsgBox "SweptProtrusion Feature Failed"
End If
'Get the Application from the objSweptProtrusion object
Set objSweptApplication = objModel.SweptProtrusions.Application
' 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 objSweptProtrusion = Nothing
Set objSweptApplication = Nothing
End Sub