Który na przykład może podać to na załączniku:
Option Explicit
Dim swApp As SldWorks.SldWorks
Dim swModel As ModelDoc2
Dim swPart As PartDoc
Dim swBody As SldWorks.Body2
Dim vBodies As Variant
Dim theFeature As SldWorks.Feature
Dim swFeature As SldWorks.Feature
Dim myFeature As SldWorks.Feature
Dim skSegment As SldWorks.SketchSegment
Dim myRefPlane As SldWorks.RefPlane
Dim swEnt As SldWorks.Face2
Dim swFace As SldWorks.Face2
Dim swSelData As SldWorks.SelectData
Dim status As Boolean
Dim faceName As String
Dim BodyName As String
Dim AxeName As String
Dim PlanName As String
Dim currentFaceName As String
Dim featCount As Long
Dim featName As String
Dim i As Long
Sub main()
On Error GoTo Handler
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
swModel.ClearSelection2 True
Set swEnt = swModel.SelectionManager.GetSelectedObject6(1, -1)
Do While swEnt Is Nothing
DoEvents
Set swEnt = swModel.SelectionManager.GetSelectedObject6(1, -1)
Loop
status = swModel.InsertAxis2(True)
If status = False Then
MsgBox "Il n'est pas possible de créer un axe sur cette sélection."
swModel.ClearSelection2 True
Exit Sub
End If
swModel.GraphicsRedraw2
swModel.ClearSelection2 True
featCount = swModel.GetFeatureCount
Set theFeature = swModel.FeatureByPositionReverse(0)
If Not theFeature Is Nothing Then
featName = theFeature.Name
End If
AxeName = "MonAxe"
status = swModel.Extension.SelectByID2(featName, "AXIS", 0, 0, 0, False, 0, Nothing, 0)
status = swModel.SelectedFeatureProperties(0, 0, 0, 0, 0, 0, 0, True, False, AxeName)
i = 0
Do While status = False
i = i + 1
AxeName = "MonAxe" & i
status = swModel.SelectedFeatureProperties(0, 0, 0, 0, 0, 0, 0, True, False, AxeName)
Loop
swModel.GraphicsRedraw2
swModel.ClearSelection2 True
'************************************************************
'Ajout d'un usinage pour test
'************************************************************
status = swModel.Extension.SelectByID2("Plan de droite", "PLANE", 0, 0, 0, False, 0, Nothing, 0)
swModel.SketchManager.InsertSketch True
Set skSegment = swModel.SketchManager.CreateCircle(-0.04, 0#, 0#, -0.03, 0.01, 0#)
swModel.ViewOrientationUndo
Set myFeature = swModel.FeatureManager.FeatureCut4(False, False, False, 9, 1, 0.001, 0.001, False, False, False, False, 0, 0, False, False, False, False, False, True, True, True, True, False, 0, 0, False, False)
swModel.SelectionManager.EnableContourSelection = False
swModel.GraphicsRedraw2
swModel.ClearSelection2 True
If myFeature Is Nothing Then
MsgBox "Usinage impossible : la géométrie ne croise pas le modèle."
swModel.EditUndo2 2
End If
'************************************************************
'Plan coincident 1 axe et perpendiculaire 1 plan de référence
'************************************************************
status = swModel.Extension.SelectByID2(AxeName, "AXIS", 0, 0, 0, True, 0, Nothing, 0)
status = swModel.Extension.SelectByID2("Plan de dessus", "PLANE", 0, 0, 0, True, 1, Nothing, 0)
Set myRefPlane = swModel.FeatureManager.InsertRefPlane(4, 0, 2, 0, 0, 0)
swModel.GraphicsRedraw2
swModel.ClearSelection2 True
featCount = swModel.GetFeatureCount
Set theFeature = swModel.FeatureByPositionReverse(0)
If Not theFeature Is Nothing Then
featName = theFeature.Name
End If
PlanName = "MonPlan"
status = swModel.Extension.SelectByID2(featName, "PLANE", 0, 0, 0, False, 0, Nothing, 0)
status = swModel.SelectedFeatureProperties(0, 0, 0, 0, 0, 0, 0, True, False, PlanName)
i = 0
Do While status = False
i = i + 1
PlanName = "MonPlan" & i
status = swModel.SelectedFeatureProperties(0, 0, 0, 0, 0, 0, 0, True, False, PlanName)
Loop
swModel.GraphicsRedraw2
swModel.ClearSelection2 True
'****************************************************
'Plan tangent à ma face et perpenticulaire à mon plan
'****************************************************
Set swSelData = swModel.SelectionManager.CreateSelectData
Set swPart = swModel
vBodies = swPart.GetBodies2(swAllBodies, True)
Set swBody = vBodies(0)
Set swFace = swBody.GetFirstFace
Do While Not swFace Is Nothing
status = swFace.IsSame(swEnt)
If status Then
swFace.Select4 True, swSelData
Exit Do
End If
Set swFace = swFace.GetNextFace
Loop
status = swModel.Extension.SelectByID2(PlanName, "PLANE", 0, 0, 0, True, 1, Nothing, 0)
Set myRefPlane = swModel.FeatureManager.InsertRefPlane(32, 0, 2, 0, 0, 0)
swModel.GraphicsRedraw2
swModel.ClearSelection2 True
featCount = swModel.GetFeatureCount
Set theFeature = swModel.FeatureByPositionReverse(0)
If Not theFeature Is Nothing Then
featName = theFeature.Name
End If
status = swModel.Extension.SelectByID2(featName, "PLANE", 0, 0, 0, False, 0, Nothing, 0)
status = swModel.SelectedFeatureProperties(0, 0, 0, 0, 0, 0, 0, True, False, PlanName)
i = 0
Do While status = False
i = i + 1
PlanName = "MonPlan" & i
status = swModel.SelectedFeatureProperties(0, 0, 0, 0, 0, 0, 0, True, False, PlanName)
Loop
swModel.ForceRebuild3 True
swModel.ClearSelection2 True
MsgBox "Traitement terminé."
Exit Sub
Handler:
MsgBox "Traitement terminé sur erreur."
swModel.ClearSelection2 True
Exit Sub
End Sub
macroselectface.sldprt