Code tags should help with a Copy and Paste. I'm still trying to sort out all these posting details.
Code:
Option Explicit
Sub DrawDiagonal()
Dim intCode(8) As Integer
Dim varData(8) As Variant
Dim entLWPL As AcadLWPolyline
Dim entLine As AcadLine
Dim dblStPt(2) As Double
Dim dblNdPt(2) As Double
Dim varCoords As Variant
Dim varStPt As Variant
Dim varNdPt As Variant
Dim dblElev As Double
Dim varNormal As Variant
Dim i As Integer, j As Integer
With ThisDrawing
intCode(0) = 0: varData(0) = "LWPOLYLINE"
intCode(1) = -4: varData(1) = "&="
intCode(2) = 70: varData(2) = 1
intCode(3) = -4: varData(3) = "&"
intCode(4) = 70: varData(4) = 129
intCode(5) = 90: varData(5) = 4
intCode(6) = -4: varData(6) = "<Not"
intCode(7) = 67: varData(7) = 1
intCode(8) = -4: varData(8) = "Not>"
If SSAll(intCode, varData) <> 0 Then
For Each entLWPL In .SelectionSets("TempSSet")
dblElev = entLWPL.Elevation
varNormal = entLWPL.Normal
varCoords = entLWPL.Coordinates
For i = 0 To 1
For j = 0 To 1
dblStPt(j) = varCoords(j + (2 * i))
dblNdPt(j) = varCoords(j + 4 + (2 * i))
Next
dblStPt(2) = dblElev
dblNdPt(2) = dblElev
varStPt = dblStPt
varStPt = .Utility.TranslateCoordinates(varStPt, acOCS, acWorld, 0, varNormal)
varNdPt = dblNdPt
varNdPt = .Utility.TranslateCoordinates(varNdPt, acOCS, acWorld, 0, varNormal)
Set entLine = .ModelSpace.AddLine(varStPt, varNdPt)
Next
Next
End If
End With
End Sub
Function SSAll(Optional grpCode As Variant, Optional dataVal As Variant) As Integer
Dim TempObjSS As AcadSelectionSet
ClearSS
Set TempObjSS = ThisDrawing.SelectionSets.Add("TempSSet")
'get selection set
If IsMissing(grpCode) Then
TempObjSS.Select acSelectionSetAll
Else
TempObjSS.Select acSelectionSetAll, , , grpCode, dataVal
End If
SSAll = TempObjSS.Count
End Function
Private Sub ClearSS()
Dim SSS As AcadSelectionSets
'choose a selection set name for temporary storage and
'ensure that it does not currently exist
On Error Resume Next
Set SSS = ThisDrawing.SelectionSets
If SSS.Count > 0 Then
SSS.Item("TempSSet").Delete
End If
End Sub