quick way to do offsets

[rwbaker]

found this on another site

Option Explicit
Public Property Get Pi()
Pi = 3.14159265358979
End Property




Private Sub AcadDocument_BeginDoubleClick(ByVal PickPoint As Variant)
On Error GoTo Err_Control



Dim selectionSetObject As AcadSelectionSet
Dim objEnt As AcadEntity

Set selectionSetObject = ThisDrawing.PickfirstSelectionSet
If selectionSetObject.Count = 0 Then Exit Sub
Set objEnt = selectionSetObject.Item(0)



With ThisDrawing.Utility
Select Case objEnt.ObjectName
Case "AcDbLine"
Dim dblAng As Double
Dim PolarPt1, polarPt2
Dim dblOffset As Double
Dim varStart As Variant
Dim varEnd As Variant
Dim VarPick As Variant
Dim objXline As AcadXline
Dim intSide As Integer
Dim dblOffsetdata As Double

dblOffsetdata = ThisDrawing.GetVariable("offsetdist")
varStart = objEnt.StartPoint
varEnd = objEnt.EndPoint
dblOffset = .GetDistance(, vbCrLf & "<" & dblOffsetdata & ">" & "Offset distance: ")
If dblOffset = 0 Then
dblOffset = dblOffsetdata
End If

VarPick = .GetPoint(, "Specify point on side to offset: ")
intSide = SideOfLine(varStart, varEnd, VarPick)
If intSide = -1 Then dblOffset = -dblOffset
dblAng = ThisDrawing.Utility.AngleFromXAxis(varStart, varEnd) + 0.5 * Pi
PolarPt1 = .PolarPoint(varStart, dblAng, dblOffset)
polarPt2 = .PolarPoint(varEnd, dblAng, dblOffset)
Set objXline = ThisDrawing.ModelSpace.AddXline(PolarPt1, polarPt2)
ThisDrawing.SetVariable "offsetdist", Abs(dblOffset)


Case "AcDbPolyline"
Dim oLWP As AcadLWPolyline
Dim dblangComp As Double
Dim i As Integer, j As Integer
Dim Coordinates As Variant
Dim Coord As Variant
Dim retAngle As Double
Dim Point(2) As Double
Dim CoordsCol As New Collection 'collections are arrays starting at 1 not 0
Dim retAngles As New Collection
Dim PrevV, NexV, LastVertex, Ptlist
Dim dblAngle As Double

objEnt.Highlight True
Set oLWP = objEnt

For i = 0 To (UBound(oLWP.Coordinates) - 1) / 2
Coord = oLWP.Coordinate(i)
ReDim Preserve Coord(2): Coord(2) = 0
CoordsCol.Add Coord
Next
If oLWP.Closed = True Then
CoordsCol.Add CoordsCol(1)
End If
For i = 1 To CoordsCol.Count - 1
dblAngle = .AngleFromXAxis(CoordsCol(i), PickPoint) - .AngleFromXAxis(PickPoint, CoordsCol(i + 1))
If dblAngle > Pi Then
dblAngle = dblAngle - (2 * Pi) '180+->-180+
ElseIf dblAngle < -Pi Then
dblAngle = dblAngle + (2 * Pi) '-180+ ->180+
End If
If i = 1 Then
dblangComp = dblAngle
j = 1
Else
If Abs(dblAngle) < Abs(dblangComp) Then
dblangComp = dblAngle
j = i
End If
End If
Next
dblOffsetdata = ThisDrawing.GetVariable("offsetdist")
varStart = CoordsCol(j): varEnd = CoordsCol(j + 1)
On Error Resume Next
dblOffset = .GetDistance(, vbCrLf & "<" & dblOffsetdata & ">" & "Offset distance: ")
If dblOffset = 0 Then
dblOffset = dblOffsetdata 'dblOffsetdata is the current offset in setvar
End If
On Error GoTo Err_Control

VarPick = .GetPoint(, "Specify point on side to offset: ")
intSide = SideOfLine(varStart, varEnd, VarPick)
If intSide = -1 Then dblOffset = -dblOffset
dblAngle = ThisDrawing.Utility.AngleFromXAxis(varStart, varEnd) + 0.5 * Pi
PolarPt1 = .PolarPoint(varStart, dblAngle, dblOffset)
polarPt2 = .PolarPoint(varEnd, dblAngle, dblOffset)
Set objXline = ThisDrawing.ModelSpace.AddXline(PolarPt1, polarPt2)
ThisDrawing.SetVariable "offsetdist", Abs(dblOffset)

objEnt.Highlight False



End Select



selectionSetObject.Highlight False
selectionSetObject.Delete

End With

Exit_Here:
Exit Sub
Err_Control:
Select Case Err.Number
Case "-2145320928"
Resume Next
'Case "13", "-2147467259", -2147352567 ', -2145320949 'Method 'Item' of object 'IAcadSelectionSet' failed
'Dim varcancel
'varcancel = ThisDrawing.GetVariable("LASTPROMPT")
'If InStr(1, varcancel, "*Cancel*") <> 0 Then

'If GetAsyncKeyState(VK_ESCAPE) And 8000 > 0 Then
'Err.Clear
'Resume Exit_Here
'ElseIf GetAsyncKeyState(VK_LBUTTON) > 0 Then
'Err.Clear
'Resume
'End If
'End If


Case Else

MsgBox Err.Description
Err.Clear
Resume Exit_Here
End Select

End Sub

'SomeCallMeDave
'

http://www.vbdesign.net/expresso/showthread.php?postid=57552#post57552

Public Function SideOfLine(LineStart As Variant, LineEnd As Variant, Pnt As Variant) As Integer
'returns -1 if Pnt is to left, +1 if Pnt is to right, 0 if all points are collinear
'return of 0 sometimes is inaccurate, due I think to rounding
On Error GoTo errcontrol
Dim a1 As Double
Dim a2 As Double
Dim a3 As Double
Dim a4 As Double

a1 = LineStart(0) * LineEnd(1) - LineStart(0) * Pnt(1)
a2 = -LineStart(1) * LineEnd(0) + LineStart(1) * Pnt(0)
a3 = LineEnd(0) * Pnt(1) - LineEnd(1) * Pnt(0)

a4 = a1 + a2 + a3

If a4 = 0 Then SideOfLine = 0
If a4 < 0 Then SideOfLine = -1
If a4 > 0 Then SideOfLine = 1
Exit Function
errcontrol: MsgBox Err.Description
End Function

 

[SRO]

I'm not really fluent with lisp, so pardon my stupidity, but why is this so special? Why not just hit "O", enter a distance, then select the object?

 

[rwbaker]

we are new to autocad
so without knowing all the key commands
i thought it would be eaiser to just be able
to do a double click on a line and have it
preform the command

we use alot of construction lines for layout work
and this was one things the users asked about

 

[SRO]

DO YOURSELF A FAVOR. GO TO THE HELP, IN THE INDEX SEARCH BOX TYPE "aliases, for commands, table listing of" IF YOU'RE AMBITIOUS AND HAVE A COUPLE OF SECONDS YOU CAN CUT AND PASTE THIS TABLE INTO EXCEL AND IT WILL FIT NICELY ON TWO SHEETS. IF YOU WANT GIVE MY YOUR FAX # AND I'LL FAX IT (CAN'T E-MAIL IT, CAUSE I DIDN'T FEEL THE NEED TO SAVE IT). PIN IT UP NEAR YOUR WORK STATION. THEN LEARN IT, LIVE IT, LOVE IT. THE ICONS WILL CHANGE WITH EACH AUTO CAD VERSION, OR POTENTIALLY FORM STATION TO STATION, BUT KEYBOARD SHORT CUTS USUALLY ARE CONSISTENT.