Private Sub Form_Load()
Dim objApp As SolidEdgeFramework.Application
Dim objDoc As SolidEdgePart.PartDocument
Dim objLines As SolidEdgeFrameworkSupport.Lines2d
Dim objProfArr(1 To 2) As SolidEdgePart.Profile
Dim objModel As SolidEdgePart.Model
Dim objExtProt As SolidEdgePart.ExtrudedProtrusion
Dim objRelns1 As SolidEdgeFrameworkSupport.Relations2d
Dim objTemp As Object
Dim objEdges(1 To 4) As Object
Dim objSideFace As Object
Dim objCapFace As Object
Dim objLips As SolidEdgePart.Lips
Dim objLip As SolidEdgePart.Lip
Dim lngStatus 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
On Error GoTo 0
' 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
Set objExtProt = objModel.ExtrudedProtrusions(1)
'*** Lip Creation
'Get the Lips collection from the Model object
Set objLips = objModel.Lips
'Get the edges on which lip is to be created in to an array
Set objTemp = objExtProt.BottomCap.Edges
For i = 1 To objTemp.Count - 1
Set objEdges(i) = objTemp(i)
Next i
'Get the face to be set as SideFace for the Lip
Set objSideFace = objExtProt.SideFaces.Item(1)
'Get the face to be set as CapFace for the Lip
Set objCapFace = objExtProt.BottomCap
'Create the Lip
Set objLip = objLips.Add(Numberofedges:=3, Edges:=objEdges, SideFace:=objSideFace, _
CapFace:=objCapFace, Width:=0.01, Height:=0.005)
' USER DISPLAY
' Release objects
Set objApp = Nothing
Set objDoc = Nothing
Set objLines = Nothing
Set objProfArr(1) = Nothing
Set objProfArr(2) = Nothing
Set objModel = Nothing
Set objExtProt = Nothing
Set objRelns1 = Nothing
Set objTemp = Nothing
Set objEdges(1) = Nothing
Set objEdges(2) = Nothing
Set objEdges(3) = Nothing
Set objEdges(4) = Nothing
Set objSideFace = Nothing
Set objCapFace = Nothing
Set objLips = Nothing
Set objLip = Nothing
End Sub