Private Sub Form_Load()
Dim objApp As SolidEdgeFramework.Application
Dim objDoc As SolidEdgePart.PartDocument
Dim objRefPlane As SolidEdgePart.RefPlane
Dim objProfiles(1 To 3) As SolidEdgePart.Profile
Dim objLines As SolidEdgeFrameworkSupport.Lines2d
Dim objRelations As SolidEdgeFrameworkSupport.Relations2d
Dim objLine(1 To 4) As SolidEdgeFrameworkSupport.Line2d
Dim objBaseLines As SolidEdgeFrameworkSupport.Lines2d
Dim objBaseProfile(1 To 2) As SolidEdgePart.Profile
Dim objBaseRelns As SolidEdgeFrameworkSupport.Relations2d
Dim objModel As SolidEdgePart.Model
Dim objLoftCuts As SolidEdgePart.LoftedCutouts
Dim objLoftCut1 As SolidEdgePart.LoftedCutout
Dim objLoftCut2 As SolidEdgePart.LoftedCutout
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 lngCnt 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
' Draw the Base Profile
Set objBaseProfile(1) = objDoc.ProfileSets.Add.Profiles.Add(pRefPlaneDisp:= _
objDoc.RefPlanes(1))
Set objBaseLines = objBaseProfile(1).Lines2d
Call objBaseLines.AddBy2Points(x1:=0, y1:=0, x2:=0.1, y2:=0)
Call objBaseLines.AddBy2Points(x1:=0.1, y1:=0, x2:=0.1, y2:=0.1)
Call objBaseLines.AddBy2Points(x1:=0.1, y1:=0.1, x2:=0, y2:=0.1)
Call objBaseLines.AddBy2Points(x1:=0, y1:=0.1, x2:=0, y2:=0)
' Define Relations among the Line objects to make the Profile closed
Set objBaseRelns = objBaseProfile(1).Relations2d
Call objBaseRelns.AddKeypoint(Object1:=objBaseLines(1), Index1:=igLineEnd, Object2:= _
objBaseLines(2), Index2:=igLineStart)
Call objBaseRelns.AddKeypoint(Object1:=objBaseLines(2), Index1:=igLineEnd, Object2:= _
objBaseLines(3), Index2:=igLineStart)
Call objBaseRelns.AddKeypoint(Object1:=objBaseLines(3), Index1:=igLineEnd, Object2:= _
objBaseLines(4), Index2:=igLineStart)
Call objBaseRelns.AddKeypoint(Object1:=objBaseLines(4), Index1:=igLineEnd, Object2:= _
objBaseLines(1), Index2:=igLineStart)
' Check for the Profile Validity
lngStatus = objBaseProfile(1).End(ValidationCriteria:=igProfileClosed)
If lngStatus <> 0 Then
MsgBox ("Profile not closed")
End If
'Create the Base Extruded Protrusion Feature
Set objModel = objDoc.Models.AddFiniteExtrudedProtrusion(NumberOfProfiles:=1, _
ProfileArray:=objBaseProfile, _
ProfilePlaneSide:=igRight, _
ExtrusionDistance:=0.1)
objBaseProfile(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 Lofted Cutout object
' Create a new reference plane.
Set objRefPlane = objDoc.RefPlanes.AddParallelByDistance( _
ParentPlane:=objDoc.RefPlanes(2), Distance:=0.1, _
NormalSide:=igRight, Local:=True)
' Create a new profile set and profile to use for the first section.
Set objProfiles(1) = objDoc.ProfileSets.Add.Profiles.Add(pRefPlaneDisp:= _
objRefPlane)
' Get the model space origin relative to profile space.
Call objProfiles(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) = 0.03
Origin(2) = 0.03
OriginArray(1) = Origin
' Set a reference to the Lines2d and Relations2d collections on the profile.
Set objLines = objProfiles(1).Lines2d
Set objRelations = objProfiles(1).Relations2d
' Draw 4 lines for the Rectangular profile graphics.
Set objLine(1) = objLines.AddBy2Points(x1:=0.03, y1:=0.03, x2:=0.07, _
y2:=0.03)
Set objLine(2) = objLines.AddBy2Points(x1:=0.07, y1:=0.03, _
x2:=0.07, y2:=0.07)
Set objLine(3) = objLines.AddBy2Points(x1:=0.07, y1:=0.07, _
x2:=0.03, y2:=0.07)
Set objLine(4) = objLines.AddBy2Points(x1:=0.03, y1:=0.07, _
x2:=0.03, y2:=0.03)
' Connect the lines with relationships
Call objRelations.AddKeypoint(Object1:=objLine(1), Index1:=igLineEnd, Object2:= _
objLine(2), Index2:=igLineStart)
Call objRelations.AddKeypoint(Object1:=objLine(2), Index1:=igLineEnd, Object2:= _
objLine(3), Index2:=igLineStart)
Call objRelations.AddKeypoint(Object1:=objLine(3), Index1:=igLineEnd, Object2:= _
objLine(4), Index2:=igLineStart)
Call objRelations.AddKeypoint(Object1:=objLine(4), Index1:=igLineEnd, Object2:= _
objLine(1), Index2:=igLineStart)
' End and validate the profile.
lngStatus = objProfiles(1).End(ValidationCriteria:=igProfileClosed)
If lngStatus <> 0 Then
MsgBox (" Invalid Profile")
End If
' Turn off the display of the profile.
objProfiles(1).Visible = False
' Create a new reference plane.
Set objRefPlane = objDoc.RefPlanes.AddParallelByDistance( _
ParentPlane:=objDoc.RefPlanes(2), Distance:=0.05, _
NormalSide:=igRight, Local:=True)
' Create a new profile set and profile to use for the first section.
Set objProfiles(2) = objDoc.ProfileSets.Add.Profiles.Add(pRefPlaneDisp:=objRefPlane)
' Get the model space origin relative to profile space.
Call objProfiles(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
' Draw a circle.
Call objProfiles(2).Circles2d.AddByCenterRadius(x:=0.05, y:= _
0.05, Radius:=0.015)
' End and validate the profile.
lngStatus = objProfiles(2).End(ValidationCriteria:=igProfileClosed)
If lngStatus <> 0 Then
MsgBox ("Invalid Profile")
End If
' Turn off the display of the profile.
objProfiles(2).Visible = False
' Create a new reference plane.
Set objRefPlane = objDoc.RefPlanes.AddParallelByDistance( _
ParentPlane:=objDoc.RefPlanes(2), Distance:=0, _
NormalSide:=igRight, Local:=True)
' Create a new profile set and profile to use for the first section.
Set objProfiles(3) = objDoc.ProfileSets.Add.Profiles.Add(pRefPlaneDisp:= _
objRefPlane)
' Get the model space origin relative to profile space.
Call objProfiles(3).Convert3DCoordinate(x3d:=0, y3d:=0, z3d:=0, _
x2d:=xOrigin, y2d:=yOrigin)
' Save the coordinates to define the start point for this profile.
Origin(1) = 0.03
Origin(2) = 0.03
OriginArray(3) = Origin
' Set a reference to the Lines2d and Relations2d collections on the profile.
Set objLines = objProfiles(3).Lines2d
Set objRelations = objProfiles(3).Relations2d
' Draw 4 lines for the Rectangular profile graphics.
Set objLine(1) = objLines.AddBy2Points(x1:=0.03, y1:=0.03, x2:=0.07, _
y2:=0.03)
Set objLine(2) = objLines.AddBy2Points(x1:=0.07, y1:=0.03, _
x2:=0.07, y2:=0.07)
Set objLine(3) = objLines.AddBy2Points(x1:=0.07, y1:=0.07, _
x2:=0.03, y2:=0.07)
Set objLine(4) = objLines.AddBy2Points(x1:=0.03, y1:=0.07, _
x2:=0.03, y2:=0.03)
' Connect the lines with relationships
Call objRelations.AddKeypoint(Object1:=objLine(1), Index1:=igLineEnd, Object2:= _
objLine(2), Index2:=igLineStart)
Call objRelations.AddKeypoint(Object1:=objLine(2), Index1:=igLineEnd, Object2:= _
objLine(3), Index2:=igLineStart)
Call objRelations.AddKeypoint(Object1:=objLine(3), Index1:=igLineEnd, Object2:= _
objLine(4), Index2:=igLineStart)
Call objRelations.AddKeypoint(Object1:=objLine(4), Index1:=igLineEnd, Object2:= _
objLine(1), Index2:=igLineStart)
' End and validate the profile.
lngStatus = objProfiles(3).End(ValidationCriteria:=igProfileClosed)
If lngStatus <> 0 Then
MsgBox ("Invalid Profile")
End If
' Turn off the display of the profile.
objProfiles(3).Visible = False
For i = 1 To 3
SectionTypes(i) = igProfileBasedCrossSection
Next
' Build up an array of the origin positions.
Set objLoftCut1 = objDoc.Models(1).LoftedCutouts.AddSimple(NumSections:=3, CrossSections:=objProfiles, _
CrossSectionTypes:=SectionTypes, Origins:=OriginArray, _
MaterialSide:=igLeft, StartTangentType:=igNone, _
EndTangentType:=igNone)
' Check the Status of the Feature
If objLoftCut1.Status <> igFeatureOK Then
MsgBox ("AddSimple method of LoftedCutouts object failed")
End If
' Create LoftedCutouts collection object
Set objLoftCuts = objDoc.Models(1).LoftedCutouts
' Assign the LoftedCutout to another object
Set objLoftCut2 = objLoftCuts.Item(1)
' USER DISPLAY
' Release objects
Set objApp = Nothing
Set objDoc = Nothing
Set objRefPlane = Nothing
Set objProfiles(1) = Nothing
Set objProfiles(2) = Nothing
Set objProfiles(3) = Nothing
Set objLine(1) = Nothing
Set objLine(2) = Nothing
Set objLine(3) = Nothing
Set objLine(4) = Nothing
Set objRelations = Nothing
Set objLines = Nothing
Set objBaseProfile(1) = Nothing
Set objBaseLines = Nothing
Set objBaseRelns = Nothing
Set objModel = Nothing
Set objLoftCuts = Nothing
Set objLoftCut1 = Nothing
Set objLoftCut2 = Nothing
End Sub