Muliple Offset.
This application will offset an entity multiple times. Just select the
entity, enter an offset distance, (enter a negative number if you want to
offset the other way), and then enter the number of times you would like
to offset it.
Enter this coding into a new module :
Option Explicit
Public Sub Moffset()
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
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
End Sub
Now run the macro 'Moffset'. Works fine Hey!. Now run it again but this
time select an empty space on the screen when prompted to select an
object.
Oh, Crikey, an error??? Re-run it once more but this time select an
object.
Now press the Escape key. Oh No, another error!!!
I think this application is screaming out for some error control.
Start a new application and enter this coding. I've colour coded the
coding that
has been added :
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
Now load and run Macro 'Moffset1'. Much better, Hey?
Thanks to Randall Raath for the error checking in this application.
If you would like to download the source code for this Application/s, Then
click Here |
