I have this macro for slicing objects that the excellent @AlexB made for me. It does exactly what I need, and responds well to changes in construction history. It has just one small inconvenience, in that it can't tell the direction of the selected object.
- image.png (7.17 KiB) Viewed 262 times
Does anyone here have a good idea how to read the right direction?
Something like detecting the normal of the selected face, or maybe working double sided?
Option Explicit
Function BuildMacroFeature(swApp As SldWorks.SldWorks, swModel As ModelDoc2, swFeature As Feature) As Variant
Dim swModeler As Modeler
Dim swMacroFeatData As SldWorks.MacroFeatureData
Dim selObjects As Variant
Dim selTypes As Variant
Dim selMarks As Variant
Dim paramCount As Integer
Dim paramNames As Variant
Dim paramTypes As Variant
Dim paramValues As Variant
Dim sliceHeight As Double
Dim flipNormal As Integer
Dim totalHeight As Double
Dim i As Integer
Dim firstID As Long
firstID = 1
Dim resultBodies As Collection
Set resultBodies = New Collection
Set swModeler = swApp.GetModeler
Set swMacroFeatData = swFeature.GetDefinition
swMacroFeatData.AccessSelections swModel, Nothing
swMacroFeatData.GetSelections3 selObjects, selTypes, selMarks, Nothing, Nothing
paramCount = swMacroFeatData.GetParameterCount
If paramCount > 0 Then
swMacroFeatData.GetParameters paramNames, paramTypes, paramValues
For i = 0 To paramCount - 1
If paramNames(i) = "Slice_Height" Then
sliceHeight = CDbl(paramValues(i))
End If
If paramNames(i) = "Flip_Normal" Then
flipNormal = CInt(paramValues(i))
If flipNormal = 0 Then flipNormal = 1
End If
Next i
End If
If Not IsEmpty(selObjects) Then
If selTypes(0) = swConst.swSelectType_e.swSelFACES Then
Dim swFace As Face2
Dim swSurface As Surface
Set swFace = selObjects(0)
Set swSurface = swFace.GetSurface
Dim swBody As Body2
Set swBody = swFace.GetBody
Dim swBox As Variant
swBox = swBody.GetBodyBox
'Debug.Print swBox(0) & ", " & swBox(1) & ", " & swBox(2)
'Debug.Print swBox(3) & ", " & swBox(4) & ", " & swBox(5)
Dim boxDims(8) As Double
boxDims(0) = swBox(0) + ((swBox(3) - swBox(0)) / 2)
boxDims(1) = swBox(1) + ((swBox(4) - swBox(1)) / 2)
boxDims(2) = swBox(2)
boxDims(3) = 0
boxDims(4) = 0
boxDims(5) = 1
boxDims(6) = swBox(3) - swBox(0)
boxDims(7) = swBox(4) - swBox(1)
boxDims(8) = swBox(5) - swBox(2)
'Debug.Print "MID: " & boxDims(0) & ", " & boxDims(1) & ", " & boxDims(2)
Dim swBoxBody As Body2
Set swBoxBody = swModeler.CreateBodyFromBox3(boxDims)
Dim swCopyBody As Body2
'Set swCopyBody = swBody.Copy2(False)
Set swCopyBody = swBody
Dim maxPoint(2) As Double
Dim minPoint(2) As Double
Dim normal As Variant
normal = swFace.normal
swCopyBody.GetExtremePoint normal(0), normal(1), normal(2), minPoint(0), minPoint(1), minPoint(2)
swCopyBody.GetExtremePoint -normal(0), -normal(1), -normal(2), maxPoint(0), maxPoint(1), maxPoint(2)
resultBodies.Add swCopyBody ', swCopyBody.Name
totalHeight = Math.Sqr(((maxPoint(0) - minPoint(0)) ^ 2) + ((maxPoint(1) - minPoint(1)) ^ 2) + ((maxPoint(2) - minPoint(2)) ^ 2))
Dim largestHalfDim As Double
'largestHalfDim = maxPoint(0) - minPoint(0)
'If maxPoint(1) - minPoint(1) > largestHalfDim Then largestHalfDim = maxPoint(1) - minPoint(1)
'If maxPoint(2) - minPoint(2) > largestHalfDim Then largestHalfDim = maxPoint(2) - minPoint(2)
largestHalfDim = 10
Dim numSlices As Integer
numSlices = totalHeight / sliceHeight
For i = 1 To numSlices
Dim tempSurface As Surface
Set tempSurface = swModeler.CreateOffsetSurface(swSurface, sliceHeight * i * flipNormal)
Dim uvLow As Variant
Dim uvHigh As Variant
uvLow = tempSurface.GetClosestPointOn(swBox(0), swBox(1), swBox(2))
uvHigh = tempSurface.GetClosestPointOn(swBox(3), swBox(4), swBox(5))
'Debug.Print "UVLOW: " & uvLow(0) & ", " & uvLow(1) & ", " & uvLow(2) & ", " & uvLow(3) & ", " & uvLow(4)
'Debug.Print "UVHI : " & uvHigh(0) & ", " & uvHigh(1) & ", " & uvHigh(2) & ", " & uvHigh(3) & ", " & uvHigh(4)
Dim uv(3) As Double
uv(0) = uvLow(3) - largestHalfDim
uv(1) = uvHigh(3) + largestHalfDim
Dim tempUV As Double
If uv(0) > uv(1) Then
tempUV = uv(0)
uv(0) = uv(1)
uv(1) = tempUV
End If
uv(2) = uvLow(4) - largestHalfDim
uv(3) = uvHigh(4) + largestHalfDim
If uv(2) > uv(3) Then
tempUV = uv(2)
uv(2) = uv(3)
uv(3) = tempUV
End If
Dim uvBounds As Variant
uvBounds = swFace.GetUVBounds
'Debug.Print "UVBOUNDS: " & uvBounds(0) & ", " & uvBounds(1) & ", " & uvBounds(2) & ", " & uvBounds(3)
'Debug.Print "UV: " & uv(0) & ", " & uv(1) & ", " & uv(2) & ", " & uv(3)
Dim tempSheet As Body2
Set tempSheet = swModeler.CreateSheetFromSurface(tempSurface, uv)
'swBoxBody.Display3 swModel, 124, swTempBodySelectOptions_e.swTempBodySelectOptionNone
'swCopyBody.Display3 swModel, 124, swTempBodySelectOptions_e.swTempBodySelectOptionNone
'tempSheet.Display3 swModel, 255, swTempBodySelectOptions_e.swTempBodySelectOptionNone
'DoEvents
'Debug.Print "Num resultBodies: " & resultBodies.Count
Dim k As Integer
Dim newResultBodies As Collection
Set newResultBodies = New Collection
For k = 1 To resultBodies.count
Dim tempBody As Body2
Set tempBody = resultBodies(k)
Dim vNewBodies As Variant
Dim errorCode As Long
Dim intersectionCount As Long
intersectionCount = tempBody.IGetIntersectionEdgeCount(tempSheet)
If intersectionCount > 0 Then
vNewBodies = tempBody.Operations2(swConst.swBodyOperationType_e.SWBODYCUT, tempSheet, errorCode)
Dim n As Integer
If Not IsEmpty(vNewBodies) Then
For n = 0 To UBound(vNewBodies)
Dim newBody As Body2
Set newBody = vNewBodies(n)
newResultBodies.Add newBody ', newBody.Name
Next n
End If
Else
newResultBodies.Add tempBody
End If
Next k
Set resultBodies = newResultBodies
Next i
For i = 1 To resultBodies.count
''''
Dim tempNewBody As Body2
Set tempNewBody = resultBodies(i)
Dim vFaces As Variant
Dim vEdges As Variant
vFaces = tempNewBody.GetFaces
vEdges = tempNewBody.GetEdges
Dim j As Integer
For j = 0 To UBound(vEdges)
swMacroFeatData.SetEdgeUserId vEdges(j), j, 0
Next j
For j = 0 To UBound(vFaces)
swMacroFeatData.SetFaceUserId vFaces(j), j, 0
Next j
'''''
Next i
Dim resultBodyArray() As Body2
If resultBodies.count <> 0 Then
ReDim resultBodyArray(resultBodies.count - 1)
For i = 0 To UBound(resultBodyArray)
Set resultBodyArray(i) = resultBodies(i + 1)
Next i
End If
BuildMacroFeature = resultBodyArray
End If
End If
swMacroFeatData.ReleaseSelectionAccess
'Debug.Print "Build"
End Function
