Private Sub Form_Load()
Dim objApp As SolidEdgeFramework.Application
Dim objDoc As SolidEdgePart.PartDocument
Dim objProfArr(1 To 3) As SolidEdgePart.Profile
Dim objLines As SolidEdgeFrameworkSupport.Lines2d
Dim objRelns1 As SolidEdgeFrameworkSupport.Relations2d
Dim objModel As SolidEdgePart.Model
Dim objRefPln As SolidEdgePart.RefPlane
Dim objProf1 As SolidEdgePart.Profile
Dim objProf2 As SolidEdgePart.Profile
Dim objExtCut1 As SolidEdgePart.ExtrudedCutout
Dim objExtCut2 As SolidEdgePart.ExtrudedCutout
Dim objPatPln As SolidEdgePart.RefPlane
Dim objFtArr(1 To 3) As Object
Dim objMirr1 As SolidEdgePart.MirrorCopy
Dim objMirrCps As SolidEdgePart.MirrorCopies
Dim lngStatus As Long
Dim cType As FeatureTypeConstants
' 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 objProfArr(1) = objDoc.ProfileSets.Add.Profiles.Add(pRefPlaneDisp:=objDoc.RefPlanes(1))
Set objLines = objProfArr(1).Lines2d
Call objLines.AddBy2Points(x1:=0, y1:=0, x2:=0.06, y2:=0)
Call objLines.AddBy2Points(x1:=0.06, y1:=0, x2:=0.06, y2:=0.06)
Call objLines.AddBy2Points(x1:=0.06, y1:=0.06, x2:=0, y2:=0.06)
Call objLines.AddBy2Points(x1:=0, y1:=0.06, x2:=0, y2:=0)
' Relate the Lines to make the Profile closed
Set objRelns1 = objProfArr(1).Relations2d
Call objRelns1.AddKeypoint(Object1:=objLines(1), Index1:=igLineEnd, Object2:=objLines(2), Index2:=igLineStart)
Call objRelns1.AddKeypoint(Object1:=objLines(2), Index1:=igLineEnd, Object2:=objLines(3), Index2:=igLineStart)
Call objRelns1.AddKeypoint(Object1:=objLines(3), Index1:=igLineEnd, Object2:=objLines(4), Index2:=igLineStart)
Call objRelns1.AddKeypoint(Object1:=objLines(4), Index1:=igLineEnd, Object2:=objLines(1), Index2:=igLineStart)
' Check for the Profile Validity
lngStatus = objProfArr(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:=objProfArr, profileplaneSide:=igRight, _
ExtrusionDistance:=0.02)
objProfArr(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 2 Extruded Cutouts to act as Features for Mirroring
' Create a Circular Profile
Set objRefPln = objDoc.RefPlanes.AddParallelByDistance(ParentPlane:=objDoc.RefPlanes(1), _
Distance:=0, NormalSide:=igRight)
Set objProf1 = objDoc.ProfileSets.Add.Profiles.Add(pRefPlaneDisp:=objRefPln)
Call objProf1.Circles2d.AddByCenterRadius(x:=0.02, y:=0.02, Radius:=0.005)
' Check if the Profile is closed
lngStatus = objProf1.End(ValidationCriteria:=igProfileClosed)
If lngStatus <> 0 Then
MsgBox ("Profile not closed")
End If
'Create the ExtrudedCutout feature
Set objExtCut1 = objModel.ExtrudedCutouts.AddThroughAll(Profile:=objProf1, _
ProfileSide:=igLeft, profileplaneSide:= _
igRight)
objProf1.Visible = False
If objExtCut1.Status <> igFeatureOK Then
MsgBox ("Error in the Creation of ExtrudedCutout object")
End If
' Create a Circular Profile
Set objRefPln = objDoc.RefPlanes.AddParallelByDistance(ParentPlane:=objDoc.RefPlanes(1), _
Distance:=0, NormalSide:=igRight)
Set objProf2 = objDoc.ProfileSets.Add.Profiles.Add(pRefPlaneDisp:=objRefPln)
Call objProf2.Circles2d.AddByCenterRadius(x:=0.02, y:=0.04, Radius:=0.005)
' Check if the Profile is closed
lngStatus = objProf2.End(ValidationCriteria:=igProfileClosed)
If lngStatus <> 0 Then
MsgBox ("Profile not closed")
End If
'Create the ExtrudedCutout feature
Set objExtCut2 = objModel.ExtrudedCutouts.AddThroughAll(Profile:=objProf2, _
ProfileSide:=igLeft, profileplaneSide:= _
igRight)
objProf2.Visible = False
If objExtCut2.Status <> igFeatureOK Then
MsgBox ("Error in the creation of ExtrudedCutout object")
End If
' Create the PatternPlane for the Mirror object
Set objPatPln = objDoc.RefPlanes.AddParallelByDistance(ParentPlane:=objDoc.RefPlanes(2), _
Distance:=0.03, NormalSide:=igRight)
' Create a FeatureArray
Set objFtArr(1) = objExtCut1
Set objFtArr(2) = objExtCut2
' Create the Mirror
Set objMirrCps = objModel.MirrorCopies
Set objMirr1 = objMirrCps.Add(PatternPlane:=objPatPln, NumberOfFeatures:=2, FeatureArray:=objFtArr)
If objMirr1.Status <> igFeatureOK Then
MsgBox ("Add method of MirrorCopies object failed")
End If
' Get the Type Property
cType = objMirr1.Type
' USER DISPLAY
' Release objects
Set objApp = Nothing
Set objDoc = Nothing
Set objProfArr(1) = Nothing
Set objProfArr(2) = Nothing
Set objModel = Nothing
Set objLines = Nothing
Set objRelns1 = Nothing
Set objExtCut1 = Nothing
Set objExtCut2 = Nothing
Set objRefPln = Nothing
Set objProf2 = Nothing
Set objProf1 = Nothing
Set objMirr1 = Nothing
Set objMirrCps = Nothing
Set objPatPln = Nothing
Set objFtArr(1) = Nothing
Set objFtArr(2) = Nothing
End Sub