Private Sub Form_Load()
Dim objApp As SolidEdgeFramework.Application
Dim objDoc As SolidEdgePart.PartDocument
Dim objModel As SolidEdgePart.Model
Dim objPatternPlane As SolidEdgePart.RefPlane
Dim objFeatArray(1 To 2) As Object
Dim objProfile As SolidEdgePart.Profile
Dim objRPatterns As SolidEdgeFrameworkSupport.RectangularPatterns2d
Dim objRPattern As SolidEdgeFrameworkSupport.RectangularPattern2d
Dim objPattern As SolidEdgePart.Pattern
Dim strName As String
' 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 base model for patterning
If CreateModel(objDoc) <> "" Then
MsgBox "Error in creating the base model"
Exit Sub
End If
Set objModel = objDoc.Models(1)
'***** Create a Rectangular Pattern of SmartPattern Type
' Create a new Profile object
Set objPatternPlane = objDoc.RefPlanes.AddParallelByDistance(ParentPlane:=objDoc.RefPlanes(1), _
Distance:=0.025, normalside:=igRight, local:=True)
Set objProfile = objDoc.ProfileSets.Add.Profiles.Add(objPatternPlane)
' Get the RectangularPatterns2d object on the Profile
Set objRPatterns = objProfile.RectangularPatterns2d
' Add an item to the RectangularPatterns2d collection
Set objRPattern = objRPatterns.Add(OriginX:=-0.035, OriginY:=-0.035, _
Width:=0.1, Height:=0.075, Angle:=0, OffsetType:=sePatternFillOffset, _
XCount:=1, YCount:=1, XSpace:=0.025, YSpace:=0.025)
Set objFeatArray(1) = objModel.ExtrudedProtrusions(2)
Set objPattern = objModel.Patterns.Add(NumberOfFeatures:=1, FeatureArray:=objFeatArray, _
Profile:=objProfile, PatternType:=seSmartPattern)
If objPattern.Status <> igFeatureOK Then
MsgBox "Problem in creating rectangular pattern of SmartPattern type"
End If
' Get the name associated with the Pattern
strName = objPattern.Name
' USER DISPLAY
' Release objects
Set objApp = Nothing
Set objDoc = Nothing
Set objModel = Nothing
Set objPatternPlane = Nothing
Set objFeatArray(1) = Nothing
Set objFeatArray(2) = Nothing
Set objProfile = Nothing
Set objRPatterns = Nothing
Set objRPattern = Nothing
Set objPattern = Nothing
End Sub