Private Sub Form_Load()
Dim objApp As SolidEdgeFramework.Application
Dim objDoc As SolidEdgePart.PartDocument
Dim objBaseProfile(1 To 2) As SolidEdgePart.Profile
Dim objLine1 As SolidEdgeFrameworkSupport.Line2d
Dim objLine2 As SolidEdgeFrameworkSupport.Line2d
Dim objArc1 As SolidEdgeFrameworkSupport.Arc2d
Dim objArc2 As SolidEdgeFrameworkSupport.Arc2d
Dim objModel As SolidEdgePart.Model
Dim objExtProtrusion As SolidEdgePart.ExtrudedProtrusion
Dim objRelations As SolidEdgeFrameworkSupport.Relations2d
Dim objAttributeSet As Object
Dim objAttribute As Object
Dim lngStatus As Long
Dim strValue As String
Dim dateValue As Date
' 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
'Create an Extruded Protrusion as Base feature
Set objBaseProfile(1) = objDoc.ProfileSets.Add.Profiles.Add(pRefPlaneDisp:=objDoc.RefPlanes(1))
Set objLine1 = objBaseProfile(1).Lines2d.AddBy2Points(x1:=0.05, y1:=0, x2:=0.05, y2:=0.15)
Set objArc1 = objBaseProfile(1).Arcs2d.AddByCenterStartEnd(xCenter:=0.025, yCenter:=0.15, _
xStart:=0.05, yStart:=0.15, xEnd:=0, yEnd:=0.15)
Set objLine2 = objBaseProfile(1).Lines2d.AddBy2Points(x1:=0, y1:=0.15, x2:=0, y2:=0)
Set objArc2 = objBaseProfile(1).Arcs2d.AddByCenterStartEnd(xCenter:=0.025, yCenter:=0, _
xStart:=0, yStart:=0, xEnd:=0.05, yEnd:=0)
Set objRelations = objBaseProfile(1).Relations2d
objRelations.AddKeypoint Object1:=objLine1, Index1:=igLineEnd, Object2:=objArc1, Index2:=igArcStart
objRelations.AddKeypoint Object1:=objArc1, Index1:=igArcEnd, Object2:=objLine2, Index2:=igLineStart
objRelations.AddKeypoint Object1:=objLine2, Index1:=igLineEnd, Object2:=objArc2, Index2:=igArcStart
objRelations.AddKeypoint Object1:=objArc2, Index1:=igArcEnd, Object2:=objLine1, Index2:=igLineStart
lngStatus = objBaseProfile(1).End(ValidationCriteria:=igProfileClosed)
If lngStatus <> 0 Then
MsgBox ("Base feature profile is not closed")
End If
Set objModel = objDoc.Models.AddFiniteExtrudedProtrusion(NumberOfProfiles:=1, ProfileArray:=objBaseProfile, _
ProfilePlaneSide:=igRight, ExtrusionDistance:=0.05)
objBaseProfile(1).Visible = False
Set objExtProtrusion = objModel.ExtrudedProtrusions(1)
If objExtProtrusion.Status <> igFeatureOK Then
MsgBox "Base Feature is not created properly"
End If
'Create an AttributeSet with Add method
Set objAttributeSet = objExtProtrusion.AttributeSets.Add("MyAttrib Set")
'CASE 1 - a single attribute without subscript
'Add an Attribute to the set with Add method
Set objAttribute = objAttributeSet.Add("DateAttribute", seDate)
'Set today's date as value for this attribute
objAttribute.Value = Date
'Get the value of the Attribute
dateValue = objAttribute.Value
If dateValue <> Date Then
MsgBox "Error in setting the value for vbDate type attribute"
End If
'CASE 2 - a single attribute of String type
Set objAttribute = objAttributeSet.Add("StringAttribute", seStringANSI)
'Set the value for the attribute
objAttribute.Value = "Test Attribute"
'Get the Attribute value
strValue = objAttribute.Value
If StrComp(strValue, "Test Attribute", vbTextCompare) Then
MsgBox "Error in setting the value for vbString type attribute"
End If
' 'CASE 3 - attribute with Subscript
'
' Set objAttribute = objAttributeSet.Add("Attribute1", vbInteger, 5)
'
'
' If 1 Then
' MsgBox "Dimension property of Attribute should return 5 where as it returned "
' End If
' Release objects
Set objApp = Nothing
Set objDoc = Nothing
Set objBaseProfile(1) = Nothing
Set objBaseProfile(2) = Nothing
Set objLine1 = Nothing
Set objLine2 = Nothing
Set objArc1 = Nothing
Set objArc2 = Nothing
Set objModel = Nothing
Set objExtProtrusion = Nothing
Set objRelations = Nothing
Set objAttributeSet = Nothing
Set objAttribute = Nothing
End Sub