I am not a math because of you need to check all
extensively
Change small radius
Hth
'~~~~~~~~~~~~~~~~~~~~~'
Option Explicit
Sub holes()
Dim s As Double, b As Double, st As Double
Dim mx1 As Double, mx2 As Double
Dim n As Integer, c As Integer
Dim oEnt As AcadEntity, rEnt As AcadEntity
Dim cent(2) As Double, npt(2) As Double
Dim upt(2) As Double, spt(2) As Double
Dim varpt As Variant, xpt As Variant, hpt As Variant
Dim bc As AcadCircle, sc As AcadCircle
Dim retObj1 As Variant, retObj2 As Variant
Dim ans As String
Dim pi As Double
pi = Atn(1) * 4
s = 20#
ans = InputBox("Enter arrange mode" & _
vbNewLine & "Rectangular or Polar" & _
vbNewLine & "case-nonsensitive (R or P) :", "Arrange mode", "R")
varpt = ThisDrawing.Utility.GetPoint(, "Pick center")
cent(0) = CDbl(varpt(0))
cent(1) = CDbl(varpt(1))
cent(2) = CDbl(varpt(2))
If UCase(ans) = "R" Then
b = 480#
st = 70#
c = (Fix(b / st) + 1) * 2
mx1 = c * st
npt(0) = cent(0) - mx1 / 2
npt(1) = cent(1) - mx1 / 2
npt(2) = cent(2)
upt(0) = cent(0) + mx1 / 2
upt(1) = cent(1) + mx1 / 2
upt(2) = cent(2)
ZoomWindow npt, upt
Set bc = ThisDrawing.ModelSpace.AddCircle(cent, b)
Set sc = ThisDrawing.ModelSpace.AddCircle(npt, s)
retObj1 = sc.ArrayRectangular(c, c, 1, st, st, 0)
For n = 0 To UBound(retObj1)
Set oEnt = retObj1(n)
xpt = oEnt.Center
If Distance(xpt, varpt) >= b - s Then
oEnt.Delete
End If
Next
sc.Delete
ElseIf UCase(ans) = "P" Then
b = 450#
st = 76#
Dim xi As Double, yi As Double
Dim c1 As Integer, c2 As Integer
xi = Sqr(st ^ 2 - (st / 2) ^ 2)
yi = st / 2
c1 = (Fix(b / xi * 2) + 1) * 2
mx1 = c1 * xi * 2
c2 = (Fix((b - yi) / st) + 1) * 2
mx2 = c2 * st - st
npt(0) = cent(0) - mx1 / 2
npt(1) = cent(1) - mx2 / 2
npt(2) = cent(2)
upt(0) = cent(0) + mx1 / 2
upt(1) = cent(1) + mx2 / 2
upt(2) = cent(2)
ZoomWindow npt, upt
Set bc = ThisDrawing.ModelSpace.AddCircle(cent, b)
Set sc = ThisDrawing.ModelSpace.AddCircle(npt, s)
retObj1 = sc.ArrayRectangular(c2, c1, 1, st, xi * 2, 0)
For n = 0 To UBound(retObj1)
Set oEnt = retObj1(n)
xpt = oEnt.Center
If Distance(xpt, varpt) >= b - s Then
oEnt.Delete
End If
Next
sc.Delete
spt(0) = npt(0) + xi
spt(1) = npt(1) + st / 2
spt(2) = npt(2)
Set sc = ThisDrawing.ModelSpace.AddCircle(spt, s)
retObj2 = sc.ArrayRectangular(c2, c1, 1, st, xi * 2, 0)
For n = 0 To UBound(retObj2)
Set oEnt = retObj2(n)
xpt = oEnt.Center
If Distance(xpt, varpt) >= b - s Then
oEnt.Delete
End If
Next
sc.Delete
Else
MsgBox "Wrong input"
Exit Sub
End If
ZoomAll
ThisDrawing.Regen acActiveViewport
End Sub
Public Function Distance(fPoint As Variant, sPoint As Variant) As Double
Dim x1, x2 As Double
Dim y1, y2 As Double
Dim z1, z2 As Double
Dim cDist As Double
x1 = fPoint(0): y1 = fPoint(1): z1 = fPoint(2)
x2 = sPoint(0): y2 = sPoint(1): z2 = sPoint(2)
cDist = Sqr(((x2 - x1) ^ 2) + ((y2 - y1) ^ 2) + ((z2 - z1) ^ 2))
Distance = cDist
End Function
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
Fatty
~'J'~
Message was edited by: Fatty
