Private Sub Form_Load()
Dim objApp As SolidEdgeFramework.Application
Dim objDoc As SolidEdgePart.PartDocument
Dim objRefAxis As SolidEdgePart.RefAxis
Dim objModel As SolidEdgePart.Model
Dim objProfile As SolidEdgePart.Profile
Dim objProfileArray(1 To 2) As SolidEdgePart.Profile
Dim objCutProfArray(1 To 3) As SolidEdgePart.Profile
Dim objLines As SolidEdgeFrameworkSupport.Lines2d
Dim objRelns1 As SolidEdgeFrameworkSupport.Relations2d
Dim objRelns As SolidEdgeFrameworkSupport.Relations2d
Dim objCutLines1 As SolidEdgeFrameworkSupport.Lines2d
Dim objRelns2 As SolidEdgeFrameworkSupport.Relations2d
Dim objCutLines2 As SolidEdgeFrameworkSupport.Lines2d
Dim objRevCutout As SolidEdgePart.RevolvedCutout
Dim objRefPln As SolidEdgePart.RefPlane
Dim objLine As SolidEdgeFrameworkSupport.Line2d
Dim objRCProfCollection As SolidEdgePart.Profiles
Dim objGetProfile(1 To 2) As SolidEdgePart.Profile
Dim lngStatus As Long
Dim lngNumProfiles As Long
Dim i As Integer
' 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 Profile
Set objProfileArray(1) = objDoc.ProfileSets.Add.Profiles.Add(pRefPlaneDisp:=objDoc.RefPlanes(1))
Set objLines = objProfileArray(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.08)
Call objLines.AddBy2Points(x1:=0.08, y1:=0.08, x2:=0, y2:=0.08)
Call objLines.AddBy2Points(x1:=0, y1:=0.08, x2:=0, y2:=0)
' Relate the Lines to make the Profile closed
Set objRelns = objProfileArray(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(1), Index2:=igLineStart)
' Check for the Profile Validity
lngStatus = objProfileArray(1).End(ValidationCriteria:=igProfileClosed)
If lngStatus <> 0 Then
MsgBox ("Profile not closed")
End If
' Create the Base Protrusion Object
Set objModel = objDoc.Models.AddFiniteExtrudedProtrusion(NumberOfProfiles:=1, _
ProfileArray:=objProfileArray, ProfilePlaneSide:=igRight, _
ExtrusionDistance:=0.08)
objProfileArray(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 the Revolved Cutout Profile
Set objRefPln = objDoc.RefPlanes.AddParallelByDistance(ParentPlane:=objDoc.RefPlanes(1), Distance:=0.04, NormalSide:=igRight)
Set objProfile = objDoc.ProfileSets.Add.Profiles.Add(pRefPlaneDisp:=objRefPln)
Set objCutLines1 = objProfile.Lines2d
Call objCutLines1.AddBy2Points(x1:=-0.02, y1:=0, x2:=0.02, y2:=0)
Call objCutLines1.AddBy2Points(x1:=0.02, y1:=0, x2:=0.02, y2:=0.02)
Call objCutLines1.AddBy2Points(x1:=0.02, y1:=0.02, x2:=-0.02, y2:=0.02)
Call objCutLines1.AddBy2Points(x1:=-0.02, y1:=0.02, x2:=-0.02, y2:=0)
' Relate the Lines to make the Profile closed
Set objRelns1 = objProfile.Relations2d
Call objRelns1.AddKeypoint(Object1:=objCutLines1(1), Index1:=igLineEnd, Object2:=objCutLines1(2), Index2:=igLineStart)
Call objRelns1.AddKeypoint(Object1:=objCutLines1(2), Index1:=igLineEnd, Object2:=objCutLines1(3), Index2:=igLineStart)
Call objRelns1.AddKeypoint(Object1:=objCutLines1(3), Index1:=igLineEnd, Object2:=objCutLines1(4), Index2:=igLineStart)
Call objRelns1.AddKeypoint(Object1:=objCutLines1(4), Index1:=igLineEnd, Object2:=objCutLines1(1), Index2:=igLineStart)
' Create another Revolved Cutout Profile
Call objCutLines1.AddBy2Points(x1:=-0.02, y1:=0.06, x2:=0.02, y2:=0.06)
Call objCutLines1.AddBy2Points(x1:=0.02, y1:=0.06, x2:=0.02, y2:=0.08)
Call objCutLines1.AddBy2Points(x1:=0.02, y1:=0.08, x2:=-0.02, y2:=0.08)
Call objCutLines1.AddBy2Points(x1:=-0.02, y1:=0.08, x2:=-0.02, y2:=0.06)
' Relate the Lines to make the Profile closed
Call objRelns1.AddKeypoint(Object1:=objCutLines1(5), Index1:=igLineEnd, Object2:=objCutLines1(6), Index2:=igLineStart)
Call objRelns1.AddKeypoint(Object1:=objCutLines1(6), Index1:=igLineEnd, Object2:=objCutLines1(7), Index2:=igLineStart)
Call objRelns1.AddKeypoint(Object1:=objCutLines1(7), Index1:=igLineEnd, Object2:=objCutLines1(8), Index2:=igLineStart)
Call objRelns1.AddKeypoint(Object1:=objCutLines1(8), Index1:=igLineEnd, Object2:=objCutLines1(5), Index2:=igLineStart)
' Check for the Profile Validity
lngStatus = objProfile.End(ValidationCriteria:=igProfileClosed)
If lngStatus <> 0 Then
MsgBox ("Profile not closed")
End If
'Get the Profile Array
Set objRCProfCollection = objProfile.Parent.Profiles
For i = 1 To objRCProfCollection.Count
Set objCutProfArray(i) = objRCProfCollection(i)
Next i
' Create the Revolution Axis
Set objLine = objDoc.ProfileSets(1).Profiles.Add(pRefPlaneDisp:=objRefPln). _
Lines2d.AddBy2Points(x1:=0.04, y1:=0.04, x2:=0.04, y2:=0)
Set objRefAxis = objDoc.ProfileSets(1).Profiles(2).SetAxisOfRevolution(LineForAxis:=objLine)
' Create the Revolved Cutout with no optional arguments and Profileside set to igLeft
Set objRevCutout = objModel.RevolvedCutouts.AddFiniteMulti( _
NumberOfProfiles:=2, ProfileArray:=objCutProfArray, _
RefAxis:=objRefAxis)
objCutProfArray(1).Visible = False
objCutProfArray(2).Visible = False
If (objRevCutout.Status <> igFeatureOK) Then
MsgBox ("AddFiniteMulti method of the RevolvedCutouts fails")
End If
' Get the Profiles used for creating the Revolved Cutout
Call objRevCutout.GetProfiles(NumProfiles:=lngNumProfiles, Profiles:=objGetProfile)
' USER DISPLAY
' Release objects
Set objApp = Nothing
Set objDoc = Nothing
Set objRefAxis = Nothing
Set objModel = Nothing
Set objProfile = Nothing
Set objProfileArray(1) = Nothing
Set objLines = Nothing
Set objProfileArray(2) = Nothing
Set objRelns1 = Nothing
Set objRelns2 = Nothing
Set objRelns = Nothing
Set objCutProfArray(1) = Nothing
Set objCutProfArray(2) = Nothing
Set objCutProfArray(3) = Nothing
Set objCutLines1 = Nothing
Set objRefPln = Nothing
Set objCutLines2 = Nothing
Set objRevCutout = Nothing
Set objLine = Nothing
Set objRCProfCollection = Nothing
Set objGetProfile(1) = Nothing
Set objGetProfile(2) = Nothing
End Sub