Private Sub Form_Load()
Dim objApp As solidEdgeFramework.Application
Dim objDoc As solidEdgePart.PartDocument
Dim objBaseProfile As solidEdgePart.Profile
Dim objBaseProfileArray(1 To 2) As solidEdgePart.Profile
Dim objBaseModel As solidEdgePart.Model
Dim objRPProfile As solidEdgePart.Profile
Dim objRPProfCollection As solidEdgePart.Profiles
Dim objSetProfCollection As solidEdgePart.Profiles
Dim objLine As solidEdgeFrameworkSupport.Line2d
Dim objRefAxis As solidEdgePart.RefAxis
Dim objRevProt As solidEdgePart.RevolvedProtrusion
Dim objProfileArray(1 To 2) As solidEdgePart.Profile
Dim objProfileArrayASet(1 To 4) As solidEdgePart.Profile
Dim objMultFinRevProt As solidEdgePart.RevolvedProtrusion
Dim objLines As solidEdgeFrameworkSupport.Lines2d
Dim objRelns As solidEdgeFrameworkSupport.Relations2d
Dim lngStatus As Long
Dim i As Single
Dim lngNoOfProfiles 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
' *** Creating the base feature
' Creating the profile for the base feature and validating it
Set objBaseProfile = objDoc.ProfileSets.Add.Profiles.Add(pRefPlaneDisp:=objDoc.RefPlanes(1))
Call objBaseProfile.Circles2d.AddByCenterRadius(x:=0, y:=0, Radius:=0.025)
lngStatus = objBaseProfile.End(ValidationCriteria:=igProfileClosed)
If (lngStatus <> 0) Then
MsgBox "Profile for the base feature is not closed"
Exit Sub
End If
' Creating the base extruded protrusion and validating it
Set objBaseProfileArray(1) = objBaseProfile
Set objBaseModel = objDoc.Models.AddFiniteExtrudedProtrusion(NumberOfProfiles:=1, _
ProfileArray:=objBaseProfileArray, ProfilePlaneSide:=igSymmetric, ExtrusionDistance:=0.1)
If (objBaseModel.ExtrudedProtrusions(1).Status <> igFeatureOK) Then
MsgBox "AddFiniteExtrudedProtrusion method of the Models object fails"
End If
objBaseProfile.Visible = False
' *** Creating a Revolved Protrusion on the base feature towards the left side
' Creating the profile for the revolved protrusion feature
Set objRPProfile = objDoc.ProfileSets.Add.Profiles.Add(pRefPlaneDisp:=objDoc.RefPlanes(3))
Call objRPProfile.Circles2d.AddByCenterRadius(x:=0.05, y:=-0.035, Radius:=0.015)
Call objRPProfile.Circles2d.AddByCenterRadius(x:=0.05, y:=0.035, Radius:=0.015)
Set objLine = objRPProfile.Lines2d.AddBy2Points(x1:=0, y1:=-0.05, x2:=0, y2:=0.05)
Set objRefAxis = objRPProfile.SetAxisOfRevolution(lineforaxis:=objLine)
lngStatus = objRPProfile.End(ValidationCriteria:=igProfileClosed)
If (lngStatus <> 0) Then
MsgBox "Profile for the revolved protrusion feature is not closed"
Exit Sub
End If
'Get the Profile Array
Set objRPProfCollection = objRPProfile.Parent.Profiles
For i = 1 To objRPProfCollection.Count
Set objProfileArray(i) = objRPProfCollection(i)
objProfileArray(i).Visible = False
Next i
' Creating the revolved protrusion feature with multiple profiles
Set objMultFinRevProt = objBaseModel.RevolvedProtrusions.AddFiniteMulti(NumberOfProfiles:=2, ProfileArray:=objProfileArray, _
RefAxis:=objRefAxis, ProfilePlaneSide:=igLeft, _
AngleOfRevolution:=PI)
'Change the profile
Set objRPProfile = objDoc.ProfileSets.Add.Profiles.Add(pRefPlaneDisp:=objDoc.RefPlanes(3))
Call objRPProfile.Circles2d.AddByCenterRadius(x:=0.05, y:=-0.035, Radius:=0.01)
Call objRPProfile.Circles2d.AddByCenterRadius(x:=0.075, y:=0, Radius:=0.01)
Call objRPProfile.Circles2d.AddByCenterRadius(x:=0.05, y:=0.035, Radius:=0.01)
Call objRPProfile.Circles2d.AddByCenterRadius(x:=0.025, y:=0, Radius:=0.01)
If objRPProfile.End(igProfileClosed) Then
MsgBox "Profiles must be closed"
End If
Set objSetProfCollection = objRPProfile.Parent.Profiles
For i = 1 To objSetProfCollection.Count
Set objProfileArrayASet(i) = objSetProfCollection(i)
objProfileArrayASet(i).Visible = False
Next i
Call objMultFinRevProt.SetProfiles(NumProfiles:=objSetProfCollection.Count, Profiles:=objProfileArrayASet)
' USER DISPLAY
' Release objects
Set objApp = Nothing
Set objDoc = Nothing
Set objBaseProfile = Nothing
Set objBaseProfileArray(1) = Nothing
Set objBaseModel = Nothing
Set objRPProfile = Nothing
Set objRPProfCollection = Nothing
Set objLine = Nothing
Set objRefAxis = Nothing
Set objRevProt = Nothing
Set objProfileArray(1) = Nothing
Set objProfileArrayASet(1) = Nothing
Set objMultFinRevProt = Nothing
Set objLines = Nothing
Set objRelns = Nothing
End Sub