autocad vba problem - offset a circle continously towards the center?

[clarence_cad]

autocad vba problem - offset a circle continously towards the center (look like a target for archery)

anyone can help? thanks a lot!

[Tommy]

Hi clarence_cad,

The below sub will allow you to select a circle and it will offset to the center. The offset is 0.5 units. You will need to pick once per offset. I have no error checking but this should help Let me know if you need more help.

[VBA]
Sub OffsetCircle()
Dim mCrcle As AcadCircle, mCr As AcadCircle, mX() As Double
Dim mI As Long, mOffset As Double
Dim gpCode(0) As Integer
Dim dataValue(0) As Variant
Dim groupCode As Variant, dataCode As Variant
Dim ssetObj As AcadSelectionSet
Set ssetObj = Aset("GetACircle")
mOffset = 0.5 'this is the distance to offset
gpCode(0) = 0
dataValue(0) = "Circle"
groupCode = gpCode
dataCode = dataValue
ssetObj.SelectAtPoint ThisDrawing.Utility.GetPoint(, "Select a Circle: "), _
groupCode, dataCode
Set mCrcle = ssetObj(0)
Set mCrcle = ThisDrawing.ModelSpace.AddCircle(mCrcle.Center, _
(mCrcle.Diameter / 2) - mOffset)
ThisDrawing.Regen acActiveViewport
Set mCrcle = Nothing
Set mCrcle = Nothing
ssetObj.Delete
Set ssetObj = Nothing
End Sub
[/VBA]

[lucas]

This one does multiple offsets at one time. Couldn't get it to offset to inside of circle but it works outside. Maybe you could find where to change it to work inside. I will look at it when I have time.

[VBA]
'Begin Code Block
Option Explicit
Public Const VK_ESCAPE = &H1B
Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Function checkkey(lngKey As Long) As Boolean
If GetAsyncKeyState(lngKey) Then
checkkey = True
Else
checkkey = False
End If
End Function
Public Sub Moffset1()
Dim objPicked As Object
Dim BasePnt As AcadPoint
Dim returnDist As Double
Dim nuOffsets As Integer
Dim i As Integer
Dim accumDist As Double
Dim offsetObj As Variant
'declare variables
Start:
On Error GoTo errControl
'if there is an error
ThisDrawing.Utility.GetEntity objPicked, BasePnt, "Select A Line"
'select the object
returnDist = ThisDrawing.Utility.GetDistance(, "Enter distance: ")
'get the distance to offset
nuOffsets = ThisDrawing.Utility.GetInteger("Number of Offsets : ")
'get the number of offsets
offsetObj = objPicked.Offset(returnDist)
'offset the object
For i = 1 To nuOffsets
'set up the loop
accumDist = returnDist + accumDist
'calculate the new offset distance
offsetObj = objPicked.Offset(accumDist)
'multiple offset the object
Next i
'loop
Exit Sub
'exit the sub routine
errControl:
'define the error control
If Err.Description = "Method 'GetEntity' of object 'IAcadUtility' failed" Then
'if the error matches these..
If checkkey(VK_ESCAPE) = True Then
'if the escape key is selected
End
'end
Else
'or else
Resume
'repeat "Select Object"
End If
Else
MsgBox Err.Description
'it must be another type of error
End If
End Sub
[/VBA]

[Tommy]

Steve the changes below will make it work for a circle, if you enter to many offsets though it complains.
[VBA]
returnDist = -(ThisDrawing.Utility.GetDistance(, "Enter distance: ") ) '<-
'get the distance to offset
nuOffsets = ThisDrawing.Utility.GetInteger("Number of Offsets : ")
'get the number of offsets
offsetObj = objPicked.Offset(returnDist)
accumDist = returnDist '<-added
'offset the object
For i = 2 To nuOffsets '<-

[/VBA]