Private Sub Form_Load()
Dim objApp As SolidEdgeFramework.Application
Dim objDoc As SolidEdgePart.PartDocument
Dim objBaseProf(1 To 2) As SolidEdgePart.Profile
Dim objCirc1 As SolidEdgeFrameworkSupport.Circle2d
Dim objModel As SolidEdgePart.Model
Dim objLoftProf(1 To 3) As SolidEdgePart.Profile
Dim objRefPln As SolidEdgePart.RefPlane
Dim objLoftProt As SolidEdgePart.LoftedProtrusion
Dim lngStatus As Long
Dim xOrigin As Double, yOrigin As Double
Dim OriginArray(1 To 3) As Variant
Dim Origin(1 To 2) As Double
Dim SectionTypes(1 To 3) As Long
Dim i As Integer
Dim cStatus As FeatureStatusConstants
' 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 the Base Protrusion Feature
' Create the Base Profile
Set objBaseProf(1) = objDoc.ProfileSets.Add.Profiles.Add(pRefPlaneDisp:=objDoc.RefPlanes(1))
Set objCirc1 = objBaseProf(1).Circles2d.AddByCenterRadius(x:=0, y:=0, Radius:=0.02)
' Check for the Profile Validity
lngStatus = objBaseProf(1).End(ValidationCriteria:=igProfileClosed)
If lngStatus <> 0 Then
MsgBox ("Profile not closed")
End If
' Create the Protrusion
Set objModel = objDoc.Models.AddFiniteExtrudedProtrusion(NumberOfProfiles:= _
1, ProfileArray:=objBaseProf, _
ProfilePlaneSide:=igRight, _
ExtrusionDistance:=0.05)
objBaseProf(1).Visible = False
' Check the status of Base Feature
If objModel.ExtrudedProtrusions(1).Status <> igFeatureOK Then
MsgBox ("Error in the Creation of Base Protrusion Feature object")
End If
' Create a new Profile to use as the First Section
Set objRefPln = objDoc.RefPlanes.AddParallelByDistance(ParentPlane:= _
objDoc.RefPlanes(1), Distance:=0.05, NormalSide:=igRight)
Set objLoftProf(1) = objDoc.ProfileSets.Add.Profiles.Add(pRefPlaneDisp:=objRefPln)
Set objCirc1 = objLoftProf(1).Circles2d.AddByCenterRadius(x:=0, y:=0, Radius:=0.02)
' Get the model space origin relative to profile space.
Call objLoftProf(1).Convert3DCoordinate(x3d:=0, y3d:=0, z3d:=0, _
x2d:=xOrigin, y2d:=yOrigin)
' Save the coordinates to define the start point for this profile.
Origin(1) = xOrigin
Origin(2) = yOrigin
OriginArray(1) = Origin
' End and validate the profile.
lngStatus = objLoftProf(1).End(ValidationCriteria:=igProfileClosed)
If lngStatus <> 0 Then
MsgBox ("Invalid Profile")
End If
' Turn off the display of the profile.
objLoftProf(1).Visible = False
' Create a new reference plane.
Set objRefPln = objDoc.RefPlanes.AddParallelByDistance( _
ParentPlane:=objDoc.RefPlanes(1), Distance:=0.1, _
NormalSide:=igRight)
' Create a new profile set and profile to use for the 2nd section.
Set objLoftProf(2) = objDoc.ProfileSets.Add.Profiles.Add(pRefPlaneDisp:=objRefPln)
' Get the model space origin relative to profile space.
Call objLoftProf(2).Convert3DCoordinate(x3d:=0, y3d:=0, z3d:=0, _
x2d:=xOrigin, y2d:=yOrigin)
' Save the coordinates to define the start point for this profile.
Origin(1) = xOrigin
Origin(2) = yOrigin
OriginArray(2) = Origin
' Set a reference to the Circle2d
Set objCirc1 = objLoftProf(2).Circles2d.AddByCenterRadius(x:=0, y:=0, Radius:=0.035)
' End and validate the profile.
lngStatus = objLoftProf(2).End(ValidationCriteria:=igProfileClosed)
If lngStatus <> 0 Then
MsgBox ("Invalid Profile")
End If
' Turn off the display of the profile.
objLoftProf(2).Visible = False
For i = 1 To 2
SectionTypes(i) = igProfileBasedCrossSection
Next
' Build up an array of the origin positions.
Set objLoftProt = objModel.LoftedProtrusions.AddSimple( _
NumSections:=2, CrossSections:=objLoftProf, _
CrossSectionTypes:=SectionTypes, Origins:=OriginArray, _
MaterialSide:=igLeft, StartTangentType:=igNone, _
EndTangentType:=igNone)
' Check the Status of the Feature
If objLoftProt.Status <> igFeatureOK Then
MsgBox ("AddSimple method of LoftedCutouts object failed")
End If
' Get the Status property
cStatus = objLoftProt.Status
' USER DISPLAY
' Release objects
Set objApp = Nothing
Set objDoc = Nothing
Set objBaseProf(1) = Nothing
Set objBaseProf(2) = Nothing
Set objCirc1 = Nothing
Set objModel = Nothing
Set objLoftProf(1) = Nothing
Set objLoftProf(2) = Nothing
Set objLoftProf(3) = Nothing
Set objLoftProt = Nothing
Set objRefPln = Nothing
End Sub