macro help needed
macro help needed
Hi all, I am new to this forum and have no programming experience. I have recorded a macro which takes a preselected flat face and offsets the perimeter by a set distance inwards. (I use it frequently for locating screw holes). It works perfectly every time. I then select that sketch, right click and change the colour to red. It would be great if I could integrate the colour change into the macro. I have tried recording it but the colour does not change. Can anybody help?
Code: Select all
Option Explicit
Dim swApp As SldWorks.SldWorks
Dim mDoc As ModelDoc2
Dim selMgr As SelectionMgr
Dim sketchMgr As SketchManager
Dim theSketch As Sketch
Dim theSketchFeature As Feature
Dim selCount As Long
Dim selType As swSelectType_e
Dim selFace As Face2
Dim i As Integer
Dim result As Boolean
Sub main()
Set swApp = Application.SldWorks
Set mDoc = swApp.ActiveDoc
Set selMgr = mDoc.SelectionManager
selCount = selMgr.GetSelectedObjectCount2(-1)
If selCount <> 1 Then 'Too many things selected, notify user and exit
swApp.SendMsgToUser2 "Please select a single planar face", swMessageBoxIcon_e.swMbStop, swMessageBoxBtn_e.swMbOk
Exit Sub
End If
selType = selMgr.GetSelectedObjectType3(1, -1)
If Not selType = swSelFACES Then 'Selection is not a face, notify user and exit
swApp.SendMsgToUser2 "Please select a single planar face", swMessageBoxIcon_e.swMbStop, swMessageBoxBtn_e.swMbOk
Exit Sub
End If
Set selFace = selMgr.GetSelectedObject6(1, -1)
Dim norm As Variant
norm = selFace.Normal
If norm(0) = 0 And norm(2) = 0 And norm(1) = 0 Then 'Face is not planar, notify user and exit
swApp.SendMsgToUser2 "Selected face is not planar", swMessageBoxIcon_e.swMbStop, swMessageBoxBtn_e.swMbOk
Exit Sub
End If
Set sketchMgr = mDoc.SketchManager
sketchMgr.InsertSketch False 'Start sketch on face
Set theSketch = sketchMgr.activeSketch
result = mDoc.SketchOffsetEntities2(-0.25 * 25.4 / 1000, False, False) 'Offset face 0.25" inward
sketchMgr.InsertSketch True 'Exit sketch
Set theSketchFeature = selMgr.GetSelectedObject6(1, -1) 'Get feature for the sketch which is selected
Dim props As Variant
props = theSketchFeature.GetMaterialPropertyValues2(1, Nothing) 'Get the current properties
props(0) = 1 'Set the RED value
props(1) = 0 'Set the GREEN value
props(2) = 0 'Set the BLUE value
theSketchFeature.SetMaterialPropertyValues2 props, 1, Nothing 'Set the properties
End Sub
-
- Posts: 26
- Joined: Wed Jul 21, 2021 3:20 pm
- x 6
- x 2
Re: macro help needed
I cannot find an accessor for the sketch colour in the sketch interface. Unless it is hidden somewhere obscure, I do not think that it can be changed using the API.
Storm
Storm
Re: macro help needed
-
I may not have gone where I intended to go, but I think I have ended up where I needed to be. -Douglas Adams
I may not have gone where I intended to go, but I think I have ended up where I needed to be. -Douglas Adams
Re: macro help needed
Code: Select all
Option Explicit
Dim swApp As SldWorks.SldWorks
Dim mDoc As ModelDoc2
Dim selMgr As SelectionMgr
Dim sketchMgr As SketchManager
Dim theSketch As Sketch
Dim theSketchFeature As Feature
Dim selCount As Long
Dim selType As swSelectType_e
Dim selFace As Face2
Dim i As Integer
Dim result As Boolean
Sub main()
Set swApp = Application.SldWorks
Set mDoc = swApp.ActiveDoc
Set selMgr = mDoc.SelectionManager
selCount = selMgr.GetSelectedObjectCount2(-1)
If selCount <> 1 Then 'Too many things selected, notify user and exit
swApp.SendMsgToUser2 "Please select a single planar face", swMessageBoxIcon_e.swMbStop, swMessageBoxBtn_e.swMbOk
Exit Sub
End If
selType = selMgr.GetSelectedObjectType3(1, -1)
If Not selType = swSelFACES Then 'Selection is not a face, notify user and exit
swApp.SendMsgToUser2 "Please select a single planar face", swMessageBoxIcon_e.swMbStop, swMessageBoxBtn_e.swMbOk
Exit Sub
End If
Set selFace = selMgr.GetSelectedObject6(1, -1)
Dim norm As Variant
norm = selFace.Normal
If norm(0) = 0 And norm(2) = 0 And norm(1) = 0 Then 'Face is not planar, notify user and exit
swApp.SendMsgToUser2 "Selected face is not planar", swMessageBoxIcon_e.swMbStop, swMessageBoxBtn_e.swMbOk
Exit Sub
End If
Set sketchMgr = mDoc.SketchManager
sketchMgr.InsertSketch False 'Start sketch on face
Set theSketch = sketchMgr.activeSketch
result = mDoc.SketchOffsetEntities2(-0.25 * 25.4 / 1000, False, False) 'Offset face 0.25" inward
sketchMgr.InsertSketch True 'Exit sketch
Set theSketchFeature = selMgr.GetSelectedObject6(1, -1) 'Get feature for the sketch which is selected
Dim props As Variant
props = theSketchFeature.GetMaterialPropertyValues2(1, Nothing) 'Get the current properties
props(0) = 1 'Set the RED value
props(1) = 0 'Set the GREEN value
props(2) = 0 'Set the BLUE value
theSketchFeature.SetMaterialPropertyValues2 props, 1, Nothing 'Set the properties
End Sub
Re: macro help needed
Thank you very much JSculley, That works perfectly!