I am working on macro, where user will select hole from top plate in assembly file and then select the face in the bottom plate. this will transfer the matching hole in the bottom plate. top plate having iso 4762 M5 counterbore, bottom plate need M5 tap hole iso 4762
' Module2 bas
Option Explicit
Sub main()
' Initialize SolidWorks
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
' Check if assembly is open
If swModel Is Nothing Then
MsgBox "Please open an assembly document first.", vbExclamation
Exit Sub
End If
If swModel.GetType() <> swDocASSEMBLY Then
MsgBox "This macro only works with assembly documents.", vbExclamation
Exit Sub
End If
' Set swAssy = swModel
' Set swSelMgr = swModel.SelectionManager
'
' ' Initialize collection
' Set selectedHoles = New collection
' Show the dynamically created user form
HoleTransferForm1.Show vbModeless
End Sub
'ButtonEventHandler class
' Event handler class for dynamically created buttons
Public WithEvents btnControl As MSForms.CommandButton
Public ButtonName As String
Private Sub btnControl_Click()
' Route the click event based on button name
Select Case ButtonName
Case "btnSelectHoles"
HoleTransferForm1.HandleSelectHolesClick
Case "btnProceed"
HoleTransferForm1.HandleProceedClick
Case "btnCancel"
HoleTransferForm1.HandleCancelClick
End Select
End Sub
'HoleTransferForm1 frm file
Option Explicit
' SolidWorks Mating Hole Transfer Macro
' This macro transfers holes from top plate to bottom plate with appropriate hole types
' Counterbore holes in top plate create clearance holes in bottom plate
Public swApp As SldWorks.SldWorks
Public swModel As SldWorks.ModelDoc2
Public swAssy As SldWorks.AssemblyDoc
Public swSelMgr As SldWorks.SelectionMgr
Public swFeat As SldWorks.Feature
Public swHoleData As SldWorks.HoleSeriesFeatureData2
Public swComp As SldWorks.Component2
Public swMate As SldWorks.Mate2
' Collection to store selected holes
Public selectedHoles As collection
Public bottomFace As SldWorks.Face2
Public bottomComp As SldWorks.Component2
' Hole size conversion table (Counterbore to Clearance) - ISO 4762 Standard
' Close fit clearance holes for socket head cap screws
Const M3_CLEARANCE As Double = 0.0034 ' 3.4mm for M3
Const M4_CLEARANCE As Double = 0.0045 ' 4.5mm for M4
Const M5_CLEARANCE As Double = 0.0055 ' 5.5mm for M5
Const M6_CLEARANCE As Double = 0.0066 ' 6.6mm for M6
Const M8_CLEARANCE As Double = 0.009 ' 9.0mm for M8
Const M10_CLEARANCE As Double = 0.011 ' 11.0mm for M10
Const M12_CLEARANCE As Double = 0.0135 ' 13.5mm for M12
Const M16_CLEARANCE As Double = 0.0175 ' 17.5mm for M16
Const M20_CLEARANCE As Double = 0.022 ' 22.0mm for M20
' Dynamic controls
Private lblStep1 As MSForms.Label
Private lblStep1Desc As MSForms.Label
Private btnSelectHoles As MSForms.CommandButton
Private lblHolesSelected As MSForms.Label
Private lblStep2 As MSForms.Label
Private lblStep2Desc As MSForms.Label
Private btnProceed As MSForms.CommandButton
Private lblInfo As MSForms.Label
Private btnCancel As MSForms.CommandButton
Private lineH As MSForms.Label
' Event handlers
Private btnSelectHolesHandler As ButtonEventHandler
Private btnProceedHandler As ButtonEventHandler
Private btnCancelHandler As ButtonEventHandler
' SolidWorks Constants
Const swDocASSEMBLY As Long = 2
Const swSelBODYFEATURES As Long = 22
Const swSelFACES As Long = 2
Const swSelCOMPONENTS As Long = 20
Const swSurfaceCYLINDER As Long = 4
Const swSurfacePLANE As Long = 1
Const swSolidBody As Long = 0
Const swEndCondBlind As Long = 0
Const swEndCondThroughAll As Long = 1
Const swMateCOAXIAL As Long = 3
Const swMateAlignALIGNED As Long = 0
Const swAddMateError_ErrorUknown As Long = -1
Private Sub UserForm_Initialize()
Dim topPos As Long
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set swSelMgr = swModel.SelectionManager
' Set form properties
Me.Caption = "Hole Transfer Tool - ISO 4762"
Me.width = 500
Me.height = 420
Me.BackColor = RGB(240, 240, 240)
topPos = 20
' Step 1 Header
Set lblStep1 = Me.Controls.Add("Forms.Label.1", "lblStep1", True)
With lblStep1
.Left = 20
.Top = topPos
.width = 450
.height = 20
.Caption = "Step 1: Select Holes in Top Plate"
.Font.Size = 11
.Font.Bold = True
.ForeColor = RGB(0, 70, 130)
End With
topPos = topPos + 25
' Step 1 Description
Set lblStep1Desc = Me.Controls.Add("Forms.Label.1", "lblStep1Desc", True)
With lblStep1Desc
.Left = 20
.Top = topPos
.width = 450
.height = 40
.Caption = "Select one or more hole features (Hole Wizard, Cut, etc.) in the top plate component from the SolidWorks feature tree or graphics area."
.WordWrap = True
.Font.Size = 9
End With
topPos = topPos + 50
' Select Holes Button
Set btnSelectHoles = Me.Controls.Add("Forms.CommandButton.1", "btnSelectHoles", True)
With btnSelectHoles
.Left = 20
.Top = topPos
.width = 140
.height = 32
.Caption = "Select Holes"
.Font.Size = 10
.BackColor = RGB(70, 130, 180)
.ForeColor = RGB(255, 255, 255)
End With
' Holes Selected Label
Set lblHolesSelected = Me.Controls.Add("Forms.Label.1", "lblHolesSelected", True)
With lblHolesSelected
.Left = 170
.Top = topPos + 8
.width = 280
.height = 20
.Caption = "No holes selected"
.Font.Size = 9
.Font.Italic = True
.ForeColor = RGB(150, 150, 150)
End With
topPos = topPos + 50
' Horizontal line
Set lineH = Me.Controls.Add("Forms.Label.1", "lineH", True)
With lineH
.Left = 20
.Top = topPos
.width = 450
.height = 2
.BackColor = RGB(200, 200, 200)
End With
topPos = topPos + 15
' Step 2 Header
Set lblStep2 = Me.Controls.Add("Forms.Label.1", "lblStep2", True)
With lblStep2
.Left = 20
.Top = topPos
.width = 450
.height = 20
.Caption = "Step 2: Transfer to Bottom Plate"
.Font.Size = 11
.Font.Bold = True
.ForeColor = RGB(0, 70, 130)
End With
topPos = topPos + 25
' Step 2 Description
Set lblStep2Desc = Me.Controls.Add("Forms.Label.1", "lblStep2Desc", True)
With lblStep2Desc
.Left = 20
.Top = topPos
.width = 450
.height = 40
.Caption = "After selecting holes, click Proceed to select the bottom plate face where mating clearance holes will be created."
.WordWrap = True
.Font.Size = 9
End With
topPos = topPos + 50
' Proceed Button
Set btnProceed = Me.Controls.Add("Forms.CommandButton.1", "btnProceed", True)
With btnProceed
.Left = 20
.Top = topPos
.width = 140
.height = 32
.Caption = "Proceed"
.Font.Size = 10
.BackColor = RGB(34, 139, 34)
.ForeColor = RGB(255, 255, 255)
.Enabled = False
End With
' Cancel Button
Set btnCancel = Me.Controls.Add("Forms.CommandButton.1", "btnCancel", True)
With btnCancel
.Left = 170
.Top = topPos
.width = 100
.height = 32
.Caption = "Cancel"
.Font.Size = 10
.BackColor = RGB(220, 220, 220)
End With
topPos = topPos + 50
' Info Label
Set lblInfo = Me.Controls.Add("Forms.Label.1", "lblInfo", True)
With lblInfo
.Left = 20
.Top = topPos
.width = 450
.height = 30
.Caption = "Clearance holes will be created per ISO 4762 standard (close fit)" & vbCrLf & "Supports M3, M4, M5, M6, M8, M10, M12, M16, M20"
.Font.Size = 8
.ForeColor = RGB(0, 100, 0)
.WordWrap = True
End With
' Wire up button event handlers
Set btnSelectHolesHandler = New ButtonEventHandler
Set btnSelectHolesHandler.btnControl = btnSelectHoles
btnSelectHolesHandler.ButtonName = "btnSelectHoles"
Set btnProceedHandler = New ButtonEventHandler
Set btnProceedHandler.btnControl = btnProceed
btnProceedHandler.ButtonName = "btnProceed"
Set btnCancelHandler = New ButtonEventHandler
Set btnCancelHandler.btnControl = btnCancel
btnCancelHandler.ButtonName = "btnCancel"
End Sub
' Public methods to handle button clicks
Public Sub HandleSelectHolesClick()
' Hide form temporarily
Me.Hide
' Call the selection routine
SelectTopPlateHoles
' Update UI
If selectedHoles.Count > 0 Then
lblHolesSelected.Caption = selectedHoles.Count & " hole(s) selected ?"
lblHolesSelected.ForeColor = RGB(0, 150, 0)
lblHolesSelected.Font.Bold = True
btnProceed.Enabled = True
Else
lblHolesSelected.Caption = "No holes selected"
lblHolesSelected.ForeColor = RGB(200, 0, 0)
btnProceed.Enabled = False
End If
' Show form again
Me.Show
End Sub
Public Sub HandleProceedClick()
' Hide form
Me.Hide
' Call the transfer routine
ProceedWithTransfer
' Close form
Unload Me
End Sub
Public Sub HandleCancelClick()
' Close the form
Unload Me
End Sub
' Called when user clicks "Select Holes" button
Sub SelectTopPlateHoles()
Dim selCount As Long
Dim i As Long
Dim swFeat As SldWorks.Feature
Dim selType As Long
' Clear previous selections
Set selectedHoles = New collection
' Get current selections
selCount = swSelMgr.GetSelectedObjectCount2(-1)
If selCount = 0 Then
MsgBox "No holes selected. Operation cancelled.", vbExclamation
Exit Sub
End If
' Store selected holes
For i = 1 To selCount
selType = swSelMgr.GetSelectedObjectType3(i, -1)
If selType = swSelBODYFEATURES Then
Set swFeat = swSelMgr.GetSelectedObject6(i, -1)
' Check if it's a hole feature
If swFeat.GetTypeName2() = "HoleWzd" Or swFeat.GetTypeName2() = "HoleSeries" Or _
swFeat.GetTypeName2() = "Cut" Or swFeat.GetTypeName2() = "ICE" Then
selectedHoles.Add swFeat
End If
End If
Next i
If selectedHoles.Count = 0 Then
MsgBox "No valid hole features selected. Please select Hole Wizard features or cut features.", vbExclamation
End If
End Sub
' Called when user clicks "Proceed" button
Sub ProceedWithTransfer()
Dim selCount As Long
Dim selType As Long
Dim swFace As SldWorks.Face2
Dim swComp As SldWorks.Component2
If selectedHoles.Count = 0 Then
MsgBox "Please select holes in the top plate first.", vbExclamation
Exit Sub
End If
' Clear selection
swModel.ClearSelection2 True
' Wait for face selection - no timeout, let user select
Do While swSelMgr.GetSelectedObjectCount2(-1) = 0
DoEvents
Loop
selCount = swSelMgr.GetSelectedObjectCount2(-1)
If selCount > 0 Then
selType = swSelMgr.GetSelectedObjectType3(1, -1)
If selType = swSelFACES Then
Set bottomFace = swSelMgr.GetSelectedObject6(1, -1)
Set bottomComp = swSelMgr.GetSelectedObjectsComponent4(1, -1)
If Not bottomFace Is Nothing And Not bottomComp Is Nothing Then
' Process all holes
Call TransferAllHoles
Else
MsgBox "Could not identify bottom plate. Operation cancelled.", vbExclamation
End If
Else
MsgBox "Please select a face on the bottom plate.", vbExclamation
End If
End If
End Sub
Sub TransferAllHoles()
Dim i As Long
Dim swFeat As SldWorks.Feature
Dim successCount As Long
Dim failCount As Long
Dim errorMsg As String
successCount = 0
failCount = 0
errorMsg = ""
For i = 1 To selectedHoles.Count
Set swFeat = selectedHoles(i)
If TransferHole(swFeat) Then
successCount = successCount + 1
Else
failCount = failCount + 1
errorMsg = errorMsg & "Failed to transfer hole: " & swFeat.Name & vbCrLf
End If
Next i
' Show results
swModel.ForceRebuild3 False
swModel.ViewZoomtofit2
Dim resultMsg As String
resultMsg = "Transfer complete!" & vbCrLf & _
"Successfully created: " & successCount & " hole(s)" & vbCrLf & _
"Failed: " & failCount & " hole(s)"
If failCount > 0 And errorMsg <> "" Then
resultMsg = resultMsg & vbCrLf & vbCrLf & "Errors:" & vbCrLf & errorMsg
End If
MsgBox resultMsg, vbInformation, "Hole Transfer Complete"
' Clear selections
Set selectedHoles = New collection
Set bottomFace = Nothing
Set bottomComp = Nothing
End Sub
Function TransferHole(topHoleFeat As SldWorks.Feature) As Boolean
Dim holeType As Long
Dim holeDiameter As Double
Dim holeDepth As Double
Dim clearanceDia As Double
Dim topComp As SldWorks.Component2
Dim holePosition() As Double
Dim normalVector() As Double
Dim swFeatureData As Object
Dim bRet As Boolean
On Error GoTo ErrorHandler
TransferHole = False
' Get hole feature data
Set swFeatureData = topHoleFeat.GetDefinition()
If swFeatureData Is Nothing Then
MsgBox "Error: Could not get hole definition for " & topHoleFeat.Name, vbExclamation
Exit Function
End If
If TypeOf swFeatureData Is SldWorks.SimpleHoleFeatureData2 Then
Dim simpleHoleData As SldWorks.SimpleHoleFeatureData2
Set simpleHoleData = swFeatureData
holeDiameter = simpleHoleData.diameter
holeDepth = simpleHoleData.depth
holeType = simpleHoleData.Type
ElseIf TypeOf swFeatureData Is SldWorks.HoleSeriesFeatureData2 Then
Set swHoleData = swFeatureData
'holeType = swHoleData.Type
holeDiameter = swHoleData.holeDiameter
holeDepth = swHoleData.holeDepth
Else
' Try to get diameter from feature edges
holeDiameter = GetHoleDiameterFromFeature(topHoleFeat)
If holeDiameter = 0 Then
MsgBox "Error: Could not determine hole diameter for " & topHoleFeat.Name, vbExclamation
Exit Function
End If
holeType = 0 ' Assume simple hole
holeDepth = 0.025 ' Default 25mm depth
End If
' Determine hole size and clearance diameter
clearanceDia = GetClearanceDiameter(holeDiameter, holeType)
If clearanceDia = 0 Then
' Use default clearance if not standard size
clearanceDia = holeDiameter * 1.1 ' 10% clearance
End If
' Get the component containing the hole
Set topComp = GetComponentFromFeature(topHoleFeat)
' Get hole position and axis
Call GetHolePositionAndAxis(topHoleFeat, holePosition, normalVector)
If UBound(holePosition) < 2 Then
MsgBox "Error: Could not determine hole position for " & topHoleFeat.Name, vbExclamation
Exit Function
End If
' Debug info
Debug.Print "Transferring hole: " & topHoleFeat.Name
Debug.Print "Diameter: " & holeDiameter * 1000 & "mm, Clearance: " & clearanceDia * 1000 & "mm"
Debug.Print "Position: " & holePosition(0) & ", " & holePosition(1) & ", " & holePosition(2)
' Create clearance hole in bottom plate using the selected face
bRet = CreateClearanceHoleOnFace(bottomComp, bottomFace, holePosition, normalVector, clearanceDia, holeDepth)
If Not bRet Then
MsgBox "Error: Failed to create clearance hole for " & topHoleFeat.Name, vbExclamation
Exit Function
End If
' Try to create coaxial mate between holes
Call CreateCoaxialMate(topHoleFeat, topComp, bottomComp)
TransferHole = True
Exit Function
ErrorHandler:
MsgBox "Error in TransferHole: " & Err.Description & " (Error " & Err.Number & ")" & vbCrLf & _
"Hole: " & topHoleFeat.Name, vbCritical
TransferHole = False
End Function
Function GetHoleDiameterFromFeature(feat As SldWorks.Feature) As Double
' Try to extract hole diameter from feature edges
Dim swFace As SldWorks.Face2
Dim vFaces As Variant
Dim swEdge As SldWorks.Edge
Dim swCurve As SldWorks.Curve
Dim dRadius As Double
GetHoleDiameterFromFeature = 0
vFaces = feat.GetFaces()
If IsEmpty(vFaces) Then Exit Function
Set swFace = vFaces(0)
If swFace Is Nothing Then Exit Function
Dim vEdges As Variant
vEdges = swFace.GetEdges()
If IsEmpty(vEdges) Then Exit Function
Set swEdge = vEdges(0)
If swEdge Is Nothing Then Exit Function
Set swCurve = swEdge.GetCurve()
If swCurve Is Nothing Then Exit Function
If swCurve.IsCircle() Then
Dim vParams As Variant
vParams = swCurve.CircleParams()
dRadius = vParams(6)
GetHoleDiameterFromFeature = dRadius * 2
End If
End Function
Function GetClearanceDiameter(nominalDia As Double, holeType As Long) As Double
' Convert nominal diameter to clearance diameter based on hole type
' holeType: 0=Simple, 1=Counterbore, 2=Countersink
' Clearance holes per ISO 4762 standard (close fit)
Dim clearanceDia As Double
clearanceDia = 0
' Determine size based on diameter (in meters)
If Abs(nominalDia - 0.003) < 0.0001 Then ' M3
clearanceDia = M3_CLEARANCE
ElseIf Abs(nominalDia - 0.004) < 0.0001 Then ' M4
clearanceDia = M4_CLEARANCE
ElseIf Abs(nominalDia - 0.005) < 0.0001 Then ' M5
clearanceDia = M5_CLEARANCE
ElseIf Abs(nominalDia - 0.006) < 0.0001 Then ' M6
clearanceDia = M6_CLEARANCE
ElseIf Abs(nominalDia - 0.008) < 0.0001 Then ' M8
clearanceDia = M8_CLEARANCE
ElseIf Abs(nominalDia - 0.01) < 0.0001 Then ' M10
clearanceDia = M10_CLEARANCE
ElseIf Abs(nominalDia - 0.012) < 0.0001 Then ' M12
clearanceDia = M12_CLEARANCE
ElseIf Abs(nominalDia - 0.016) < 0.0001 Then ' M16
clearanceDia = M16_CLEARANCE
ElseIf Abs(nominalDia - 0.02) < 0.0001 Then ' M20
clearanceDia = M20_CLEARANCE
End If
GetClearanceDiameter = clearanceDia
End Function
Function GetComponentFromFeature(feat As SldWorks.Feature) As SldWorks.Component2
'Dim swSelMgr As SldWorks.SelectionMgr
Dim swSelData As SldWorks.SelectData
Dim swComp As SldWorks.Component2
Set swSelData = swSelMgr.CreateSelectData
' Get component from current selection
Set swComp = swSelMgr.GetSelectedObjectsComponent4(1, -1)
Set GetComponentFromFeature = swComp
End Function
Sub GetHolePositionAndAxis(holeFeat As SldWorks.Feature, ByRef position() As Double, ByRef axis() As Double)
' Extract hole position and axis direction from feature
Dim swSketchFeat As SldWorks.Feature
Dim swSketch As SldWorks.Sketch
Dim vSketchPt As Variant
Dim swFace As SldWorks.Face2
Dim swEdge As SldWorks.Edge
Dim swCurve As SldWorks.Curve
Dim vParams As Variant
Dim vCenter As Variant
ReDim position(2) As Double
ReDim axis(2) As Double
' Try to get position from sketch
Set swSketchFeat = holeFeat.GetFirstSubFeature()
If Not swSketchFeat Is Nothing Then
If swSketchFeat.GetTypeName2() = "ProfileFeature" Then
Set swSketch = swSketchFeat.GetSpecificFeature2
If Not swSketch Is Nothing Then
vSketchPt = swSketch.GetSketchPoints2()
If Not IsEmpty(vSketchPt) Then
Dim swSketchPt As SldWorks.SketchPoint
Set swSketchPt = vSketchPt(0)
' Get point coordinates
position(0) = swSketchPt.X
position(1) = swSketchPt.Y
position(2) = swSketchPt.Z
End If
End If
End If
End If
' If sketch method failed, try to get from face geometry
If position(0) = 0 And position(1) = 0 And position(2) = 0 Then
Dim vFaces As Variant
vFaces = holeFeat.GetFaces()
If Not IsEmpty(vFaces) Then
Set swFace = vFaces(0)
If Not swFace Is Nothing Then
If swFace.GetType() = swSurfaceCYLINDER Then
Dim vEdges As Variant
vEdges = swFace.GetEdges()
If Not IsEmpty(vEdges) Then
Set swEdge = vEdges(0)
Set swCurve = swEdge.GetCurve()
If swCurve.IsCircle() Then
vParams = swCurve.CircleParams()
' Center point
position(0) = vParams(0)
position(1) = vParams(1)
position(2) = vParams(2)
' Axis direction
axis(0) = vParams(3)
axis(1) = vParams(4)
axis(2) = vParams(5)
End If
End If
End If
End If
End If
End If
' Default axis direction if not found (normal to top face, pointing down)
If axis(0) = 0 And axis(1) = 0 And axis(2) = 0 Then
axis(0) = 0
axis(1) = 0
axis(2) = -1
End If
End Sub
Function SelectBottomPlate() As SldWorks.Component2
Dim swSelMgr As SldWorks.SelectionMgr
Dim swComp As SldWorks.Component2
Dim selType As Long
Set swSelMgr = swModel.SelectionManager
' Wait for user to select component
swModel.ClearSelection2 True
MsgBox "Click OK, then select the bottom plate component.", vbInformation
' Wait for selection (timeout after 60 seconds)
Dim startTime As Double
startTime = Timer
Do While swSelMgr.GetSelectedObjectCount2(-1) = 0
DoEvents
If Timer - startTime > 60 Then
Exit Do
End If
Loop
If swSelMgr.GetSelectedObjectCount2(-1) > 0 Then
selType = swSelMgr.GetSelectedObjectType3(1, -1)
If selType = swSelCOMPONENTS Then
Set swComp = swSelMgr.GetSelectedObject6(1, -1)
Else
Set swComp = swSelMgr.GetSelectedObjectsComponent4(1, -1)
End If
End If
Set SelectBottomPlate = swComp
End Function
Function CreateClearanceHoleOnFace(targetComp As SldWorks.Component2, targetFace As SldWorks.Face2, position() As Double, axis() As Double, diameter As Double, depth As Double) As Boolean
Dim swCompModel As SldWorks.ModelDoc2
Dim swPart As SldWorks.partDoc
Dim swSketchMgr As SldWorks.SketchManager
Dim swFeatMgr As SldWorks.FeatureManager
Dim swFeat As SldWorks.Feature
Dim swMathUtil As SldWorks.MathUtility
Dim swMathPt As SldWorks.MathPoint
Dim swMathVec As SldWorks.MathVector
Dim vProjPt As Variant
Dim dProjPt(2) As Double
Dim bRet As Boolean
Dim sketchName As String
Dim vFacesArray As Variant
Dim swBody As SldWorks.Body2
Dim vBodies As Variant
Dim swPartFace As SldWorks.Face2
Dim i As Integer
On Error GoTo ErrorHandler
CreateClearanceHoleOnFace = False
Debug.Print "Creating hole with diameter: " & diameter * 1000 & "mm, depth: " & depth * 1000 & "mm"
' Open component for editing
Set swCompModel = targetComp.GetModelDoc2()
If swCompModel Is Nothing Then
MsgBox "Error: Could not get component model", vbExclamation
Exit Function
End If
Set swPart = swCompModel
Set swSketchMgr = swCompModel.SketchManager
Set swFeatMgr = swCompModel.FeatureManager
Set swMathUtil = swApp.GetMathUtility
Set swAssy = swApp.ActiveDoc
' Edit component
targetComp.Select4 False, Nothing, False
swAssy.EditPart
Debug.Print "Editing component: " & targetComp.Name2
' Make sure we're not in sketch mode from a previous attempt
If Not swCompModel.SketchManager.ActiveSketch Is Nothing Then
Debug.Print "Warning: Already in sketch mode, exiting first"
swCompModel.SketchManager.InsertSketch True
swCompModel.ClearSelection2 True
DoEvents
End If
' Clear any selection
swCompModel.ClearSelection2 True
swAssy.ClearSelection2 True
' Important: In part edit mode, we need to select face differently
' Try to select the top face of the part (index 0 means first face)
Dim vFacesArray As Variant
Dim swBody As SldWorks.Body2
Dim vBodies As Variant
Dim swPartFace As SldWorks.Face2
' Get the first body in the part
vBodies = swPart.GetBodies2(swSolidBody, True)
If Not IsEmpty(vBodies) Then
Set swBody = vBodies(0)
vFacesArray = swBody.GetFaces()
If Not IsEmpty(vFacesArray) Then
' Find a planar face to sketch on (usually the top or front)
Dim i As Integer
For i = LBound(vFacesArray) To UBound(vFacesArray)
Set swPartFace = vFacesArray(i)
If swPartFace.GetType() = swSurfacePLANE Then
bRet = swPartFace.Select4(False, Nothing)
If bRet Then
Debug.Print "Selected planar face from part body"
Exit For
End If
End If
Next i
End If
End If
If Not bRet Then
MsgBox "Error: Could not select any face in part", vbExclamation
swAssy.EditAssembly
Exit Function
End If
Debug.Print "Face selected successfully"
' Create sketch on selected face
swSketchMgr.InsertSketch True
Debug.Print "Sketch inserted"
' Transform the 3D assembly point to 2D sketch coordinates
Dim swMathTransform As SldWorks.MathTransform
Dim swSketch As SldWorks.Sketch
Dim dPoint(2) As Double
Dim vPoint As Variant
Set swSketch = swSketchMgr.ActiveSketch
If swSketch Is Nothing Then
MsgBox "Error: Could not get active sketch", vbExclamation
swAssy.EditAssembly
Exit Function
End If
Set swMathTransform = swSketch.ModelToSketchTransform
If swMathTransform Is Nothing Then
MsgBox "Error: Could not get sketch transform", vbExclamation
swCompModel.SketchManager.InsertSketch True
swAssy.EditAssembly
Exit Function
End If
Set swMathTransform = swMathTransform.Inverse()
If swMathTransform Is Nothing Then
MsgBox "Error: Could not invert transform", vbExclamation
swCompModel.SketchManager.InsertSketch True
swAssy.EditAssembly
Exit Function
End If
' Create MathPoint from assembly coordinates
dPoint(0) = position(0)
dPoint(1) = position(1)
dPoint(2) = position(2)
Set swMathPt = swMathUtil.CreatePoint(dPoint)
If swMathPt Is Nothing Then
MsgBox "Error: Could not create math point", vbExclamation
swCompModel.SketchManager.InsertSketch True
swAssy.EditAssembly
Exit Function
End If
' Transform to sketch coordinates
Set swMathPt = swMathPt.MultiplyTransform(swMathTransform)
vPoint = swMathPt.ArrayData
Dim projX As Double, projY As Double
projX = vPoint(0)
projY = vPoint(1)
Debug.Print "Transformed to sketch coords: " & projX * 1000 & ", " & projY * 1000 & " mm"
Debug.Print "Creating circle at sketch position: " & projX * 1000 & ", " & projY * 1000 & " mm"
' Create circle at the projected 2D position in sketch coordinates
Dim swSketchSeg As SldWorks.SketchSegment
Set swSketchSeg = swSketchMgr.CreateCircleByRadius(projX, projY, 0, diameter / 2)
If swSketchSeg Is Nothing Then
MsgBox "Error: Could not create circle in sketch", vbExclamation
swCompModel.SketchManager.InsertSketch True
swAssy.EditAssembly
Exit Function
End If
Debug.Print "Circle created with radius: " & (diameter / 2) * 1000 & "mm"
' Get the sketch name while still in sketch mode
Dim sketchName As String
sketchName = swSketchMgr.ActiveSketch.Name
Debug.Print "Active sketch name: " & sketchName
' Exit sketch mode - use ClearSelection first
swCompModel.ClearSelection2 True
swCompModel.SketchManager.InsertSketch True
' Give it time to process
DoEvents
' Rebuild to commit the sketch
swCompModel.EditRebuild3
Debug.Print "Sketch closed and rebuilt"
' Select the sketch by name for the cut operation
swCompModel.ClearSelection2 True
bRet = swCompModel.Extension.SelectByID2(sketchName, "SKETCH", 0, 0, 0, False, 0, Nothing, 0)
If Not bRet Then
MsgBox "Error: Could not select sketch '" & sketchName & "' for cut", vbExclamation
swAssy.EditAssembly
Exit Function
End If
Debug.Print "Sketch '" & sketchName & "' selected, creating cut..."
' Create extruded cut with proper depth
If depth > 0 Then
Debug.Print "Creating blind cut with depth: " & depth * 1000 & "mm"
Set swFeat = swFeatMgr.FeatureCut4(True, False, False, swEndCondBlind, 0, depth, 0, _
False, False, False, False, 0, 0, False, False, _
False, False, False, True, True, True, True, False, 0, 0, False, False)
Else
Debug.Print "Creating blind cut with default depth: 50mm"
Set swFeat = swFeatMgr.FeatureCut4(True, False, False, swEndCondBlind, 0, 0.05, 0, _
False, False, False, False, 0, 0, False, False, _
False, False, False, True, True, True, True, False, 0, 0, False, False)
End If
Debug.Print "FeatureCut4 called, checking result..."
If swFeat Is Nothing Then
MsgBox "Error: FeatureCut4 returned Nothing - cut feature failed to create", vbExclamation
swAssy.EditAssembly
Exit Function
End If
Debug.Print "Cut feature created: " & swFeat.Name
' Exit edit mode
swAssy.EditAssembly
CreateClearanceHoleOnFace = True
Debug.Print "Hole creation completed successfully"
Exit Function
ErrorHandler:
MsgBox "Error in CreateClearanceHoleOnFace: " & Err.Description & " (Error " & Err.Number & ")", vbCritical
swAssy.EditAssembly
CreateClearanceHoleOnFace = False
End Function
Function CreateCoaxialMate(topHoleFeat As SldWorks.Feature, topComp As SldWorks.Component2, bottomComp As SldWorks.Component2) As Boolean
Dim swMateData As SldWorks.MateFeatureData
Dim vMateEntities(1) As Object
Dim swTopEdge As SldWorks.Edge
Dim swBottomEdge As SldWorks.Edge
Dim bRet As Boolean
' Get cylindrical edges from both holes
' This is simplified - in production, you'd need to properly identify the edges
' Select top hole edge
topHoleFeat.Select2 False, 0
' Create coaxial mate
Dim swMateFeat As SldWorks.Feature
Set swMateFeat = swAssy.AddMate5(swMateCOAXIAL, swMateAlignALIGNED, False, 0, 0, 0, 0, 0, 0, 0, 0, False, False, 0, swAddMateError_ErrorUknown)
CreateCoaxialMate = Not swMateFeat Is Nothing
End Function
