Consulting

Results 1 to 4 of 4

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

  1. #1

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

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

    anyone can help? thanks a lot!

  2. #2
    VBAX Master Tommy's Avatar
    Joined
    May 2004
    Location
    Houston, TX
    Posts
    1,168
    Location
    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]

  3. #3
    VBAX Wizard lucas's Avatar
    Joined
    Jun 2004
    Location
    Tulsa, Oklahoma
    Posts
    7,323
    Location
    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]
    Steve
    "Nearly all men can stand adversity, but if you want to test a man's character, give him power."
    -Abraham Lincoln

  4. #4
    VBAX Master Tommy's Avatar
    Joined
    May 2004
    Location
    Houston, TX
    Posts
    1,168
    Location
    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]

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •