Right. I've struck lucky and got it working. I can't take full credit (if any) for this as most of it is cut and paste from various help sources on the net.
I've posted the full code below in case it is of some use to somebody. It's not tidied up at all yet, or even structured to fit in my existing program, but it should prove sufficient for the purposes of the subject of this topic.
Cheers
----------------------------
Public Const pi As Double = 3.14159265358979
Sub test()
Dim ss As AcadSelectionSet
Dim oldCircle As AcadCircle, newCircle As AcadCircle
Dim oldPt(0 To 2) As Double, newPt(0 To 2) As Double
Dim inter As Variant
Dim sp(0 To 2) As Double, ep(0 To 2) As Double
Dim OuterLoop(0 To 0) As AcadEntity
Dim hatchObj As AcadHatch
Call HatchBorder(hatchObj)
oldPt(0) = 0: oldPt(1) = 0: oldPt(2) = 0
newPt(0) = 2: newPt(1) = -2: newPt(2) = 0
For Each ss In ThisDrawing.SelectionSets
If StrComp(ss.Name, "ss", vbTextCompare) = 0 Then
ss.Delete
Exit For
End If
Next
Set ss = ThisDrawing.SelectionSets.Add("ss")
ss.SelectOnScreen
Set oldCircle = ss.Item(0)
Set newCircle = oldCircle.Copy
newCircle.Move oldPt, newPt
inter = oldCircle.IntersectWith(newCircle, acExtendNone)
Update
sp(0) = inter(0)
sp(1) = inter(1)
ep(0) = inter(3)
ep(1) = inter(4)
Call Border(inter, oldPt, newPt, OuterLoop)
Call ModifyHatch(hatchObj, OuterLoop)
End Sub
Public Sub Border(ByRef inter As Variant, oldPt() As Double, newPt() As Double, ByRef OuterLoop() As AcadEntity)
Dim coords(0 To 3) As Double
Dim i As Integer
Dim Angle As Double
Dim Bulge As Double
Dim arc1 As AcadArc
Dim arc2 As AcadArc
Dim PL As AcadLWPolyline
'set arc1 = thisdrawing.ModelSpace.addarc(oltpt, 20
coords(0) = inter(0)
coords(1) = inter(1)
coords(2) = inter(3)
coords(3) = inter(4)
'Set PL = ThisDrawing.ModelSpace.AddLightWeightPolyline(coords)
'PL.Closed = True
Set OuterLoop(0) = ThisDrawing.ModelSpace.AddLightWeightPolyline(coords)
OuterLoop(0).Closed = True
'Update
Angle = GetAngle(coords(0), coords(1), newPt(0), newPt(1), coords(2), coords(3))
Bulge = Tan((Angle * -1) / 4)
OuterLoop(0).SetBulge 0, Bulge
'PL.SetBulge 0, Bulge
'Update
Angle = (2 * pi) - Angle
Bulge = Tan(Angle / 4)
OuterLoop(0).SetBulge 1, Bulge
'PL.SetBulge 1, Bulge
Update
End Sub
Public Sub HatchBorder(hatchObj As AcadHatch)
Dim patternName As String
Dim PatternType As Long
Dim bAssociativity As Boolean
' Define the hatch
patternName = "SOLID"
PatternType = acHatchPatternTypePreDefined '0
bAssociativity = True
' Create the associative Hatch object in model space
Set hatchObj = ThisDrawing.ModelSpace.AddHatch(PatternType, patternName, bAssociativity)
End Sub
Public Sub ModifyHatch(hatchObj As AcadHatch, ByRef OuterLoop() As AcadEntity)
' Append the outerboundary to the hatch object, and display the hatch
hatchObj.AppendOuterLoop OuterLoop
hatchObj.Evaluate
ThisDrawing.Regen True
End Sub
Public Function GetAngle(ByVal Ax As Double, ByVal Ay As Double, ByVal Bx As Double, ByVal By As Double, ByVal _
Cx As Double, ByVal Cy As Double) As Double
Dim side_a As Double
Dim side_b As Double
Dim side_c As Double
' Get the lengths of the triangle's sides.
side_a = Sqr((Bx - Cx) ^ 2 + (By - Cy) ^ 2)
side_b = Sqr((Ax - Cx) ^ 2 + (Ay - Cy) ^ 2)
side_c = Sqr((Ax - Bx) ^ 2 + (Ay - By) ^ 2)
' Calculate angle B between sides ab and bc.
GetAngle = Acos((side_b ^ 2 - side_a ^ 2 - side_c ^ 2) _
/ (-2 * side_a * side_c))
End Function
' Return the arccosine of X.
Function Acos(ByVal X As Double) As Double
Acos = Atn(-X / Sqr(-X * X + 1)) + 2 * Atn(1)
End Function
