Private Sub Form_Load()
Dim objApp As SolidEdgeFramework.Application
Dim objDoc As SolidEdgePart.PartDocument
Dim objBaseProfile(1 To 2) As SolidEdgePart.Profile
Dim objModel As SolidEdgePart.Model
Dim objBaseLines As SolidEdgeFrameworkSupport.Lines2d
Dim objBaseRelns As SolidEdgeFrameworkSupport.Relations2d
Dim objApplication As SolidEdgeFramework.Application
Dim objLoftCuts As SolidEdgePart.LoftedCutouts
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
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.05)
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 collection object
Set objLoftCuts = objModel.LoftedCutouts
' Get the Application property
Set objApplication = objLoftCuts.Application
' USER DISPLAY
' Release objects
Set objApp = Nothing
Set objDoc = Nothing
Set objBaseProfile(1) = Nothing
Set objBaseProfile(2) = Nothing
Set objModel = Nothing
Set objBaseLines = Nothing
Set objBaseRelns = Nothing
Set objApplication = Nothing
Set objLoftCuts = Nothing
End Sub