Private Sub Form_Load()
Dim objApp As SolidEdgeFrameWork.Application
Dim objDoc As SolidEdgepart.PartDocument
Dim objProf As SolidEdgepart.Profile
Dim objProfile(1 To 2) As SolidEdgepart.Profile
Dim objExtProt As SolidEdgepart.ExtrudedProtrusion
Dim objModel As SolidEdgepart.Model
Dim objLines As SolidEdgeFrameworkSupport.Lines2d
Dim objRelns As SolidEdgeFrameworkSupport.Relations2d
Dim objRefPln As SolidEdgepart.RefPlane
Dim objMProfile As SolidEdgepart.Profile
Dim objL1 As SolidEdgeFrameworkSupport.Line2d
Dim objL2 As SolidEdgeFrameworkSupport.Line2d
Dim objL3 As SolidEdgeFrameworkSupport.Line2d
Dim objL4 As SolidEdgeFrameworkSupport.Line2d
Dim objRelations As SolidEdgeFrameworkSupport.Relations2d
Dim objProfCollection As SolidEdgepart.Profiles
Dim objMExtprot As SolidEdgepart.ExtrudedProtrusion
Dim objProfArray(1 To 2) As SolidEdgepart.Profile
Dim i As Integer
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
'Draw the Base Profile
Set objProfile(1) = objDoc.ProfileSets.Add.Profiles.Add(pRefPlaneDisp:=objDoc.RefPlanes(3))
Set objLines = objProfile(1).Lines2d
Call objLines.AddBy2Points(x1:=0, y1:=0, x2:=0.08, y2:=0)
Call objLines.AddBy2Points(x1:=0.08, y1:=0, x2:=0.08, y2:=0.06)
Call objLines.AddBy2Points(x1:=0.08, y1:=0.06, x2:=0.064, y2:=0.06)
Call objLines.AddBy2Points(x1:=0.064, y1:=0.06, x2:=0.064, y2:=0.02)
Call objLines.AddBy2Points(x1:=0.064, y1:=0.02, x2:=0.048, y2:=0.02)
Call objLines.AddBy2Points(x1:=0.048, y1:=0.02, x2:=0.048, y2:=0.06)
Call objLines.AddBy2Points(x1:=0.048, y1:=0.06, x2:=0.032, y2:=0.06)
Call objLines.AddBy2Points(x1:=0.032, y1:=0.06, x2:=0.032, y2:=0.02)
Call objLines.AddBy2Points(x1:=0.032, y1:=0.02, x2:=0.016, y2:=0.02)
Call objLines.AddBy2Points(x1:=0.016, y1:=0.02, x2:=0.016, y2:=0.06)
Call objLines.AddBy2Points(x1:=0.016, y1:=0.06, x2:=0, y2:=0.06)
Call objLines.AddBy2Points(x1:=0, y1:=0.06, x2:=0, y2:=0)
' Define Relations among the Line objects to make the Profile closed
Set objRelns = objProfile(1).Relations2d
Call objRelns.AddKeypoint(Object1:=objLines(1), Index1:=igLineEnd, Object2:=objLines(2), Index2:=igLineStart)
Call objRelns.AddKeypoint(Object1:=objLines(2), Index1:=igLineEnd, Object2:=objLines(3), Index2:=igLineStart)
Call objRelns.AddKeypoint(Object1:=objLines(3), Index1:=igLineEnd, Object2:=objLines(4), Index2:=igLineStart)
Call objRelns.AddKeypoint(Object1:=objLines(4), Index1:=igLineEnd, Object2:=objLines(5), Index2:=igLineStart)
Call objRelns.AddKeypoint(Object1:=objLines(5), Index1:=igLineEnd, Object2:=objLines(6), Index2:=igLineStart)
Call objRelns.AddKeypoint(Object1:=objLines(6), Index1:=igLineEnd, Object2:=objLines(7), Index2:=igLineStart)
Call objRelns.AddKeypoint(Object1:=objLines(7), Index1:=igLineEnd, Object2:=objLines(8), Index2:=igLineStart)
Call objRelns.AddKeypoint(Object1:=objLines(8), Index1:=igLineEnd, Object2:=objLines(9), Index2:=igLineStart)
Call objRelns.AddKeypoint(Object1:=objLines(9), Index1:=igLineEnd, Object2:=objLines(10), Index2:=igLineStart)
Call objRelns.AddKeypoint(Object1:=objLines(10), Index1:=igLineEnd, Object2:=objLines(11), Index2:=igLineStart)
Call objRelns.AddKeypoint(Object1:=objLines(11), Index1:=igLineEnd, Object2:=objLines(12), Index2:=igLineStart)
Call objRelns.AddKeypoint(Object1:=objLines(12), Index1:=igLineEnd, Object2:=objLines(1), Index2:=igLineStart)
' Check for the Profile Validity
lngStatus = objProfile(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:=objProfile, profileplaneSide:= _
igRight, ExtrusionDistance:=0.05)
objProfile(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 an ExtrudedProtrusion with multiple profiles with ProfilePlaneSide as igRight
Set objRefPln = objDoc.RefPlanes.AddParallelByDistance(ParentPlane:=objDoc.RefPlanes(2), _
Distance:=0.04, NormalSide:=igRight)
Set objMProfile = objDoc.ProfileSets.Add.Profiles.Add(pRefPlaneDisp:=objRefPln)
'Draw two closed profiles and validate the same
Call objMProfile.Circles2d.AddByCenterRadius(x:=-0.04, y:=0.05, Radius:=0.005)
Set objL1 = objMProfile.Lines2d.AddBy2Points(x1:=-0.015, y1:=0.025, x2:=-0.015, y2:=0.035)
Set objL2 = objMProfile.Lines2d.AddBy2Points(x1:=-0.015, y1:=0.035, x2:=-0.04, y2:=0.035)
Set objL3 = objMProfile.Lines2d.AddBy2Points(x1:=-0.04, y1:=0.035, x2:=-0.04, y2:=0.025)
Set objL4 = objMProfile.Lines2d.AddBy2Points(x1:=-0.04, y1:=0.025, x2:=-0.015, y2:=0.025)
Set objRelations = objMProfile.Relations2d
Call objRelations.AddKeypoint(Object1:=objL1, Index1:=igLineEnd, Object2:=objL2, Index2:=igLineStart)
Call objRelations.AddKeypoint(Object1:=objL2, Index1:=igLineEnd, Object2:=objL3, Index2:=igLineStart)
Call objRelations.AddKeypoint(Object1:=objL3, Index1:=igLineEnd, Object2:=objL4, Index2:=igLineStart)
Call objRelations.AddKeypoint(Object1:=objL4, Index1:=igLineEnd, Object2:=objL1, Index2:=igLineStart)
lngStatus = objMProfile.End(ValidationCriteria:=igProfileClosed)
If lngStatus <> 0 Then
MsgBox ("Profile not colsed")
End If
Set objProfCollection = objMProfile.Parent.Profiles
For i = 1 To objProfCollection.Count
Set objProfArray(i) = objProfCollection(i)
objProfArray(i).Visible = False
Next i
Set objMExtprot = objModel.ExtrudedProtrusions.AddThroughAllMulti(NumberOfProfiles:=2, _
profileArray:=objProfArray, profileplaneSide:=igRight)
' USER DISPLAY
' Release objects
Set objApp = Nothing
Set objDoc = Nothing
Set objProf = Nothing
Set objProfile(1) = Nothing
Set objProfile(2) = Nothing
Set objModel = Nothing
Set objExtProt = Nothing
Set objLines = Nothing
Set objRelns = Nothing
Set objRefPln = Nothing
Set objMProfile = Nothing
Set objL1 = Nothing
Set objL2 = Nothing
Set objL3 = Nothing
Set objL4 = Nothing
Set objRelations = Nothing
Set objProfCollection = Nothing
Set objMExtprot = Nothing
Set objProfArray(1) = Nothing
Set objProfArray(2) = Nothing
End Sub