RE: Find Polygon Diagonals
I admit UCS is a VBA topic I don't entirely understand. But I think you're onto something here. I manually set the UCS to the polyline object. The results are below.
Code:
LWPOLYLINE Layer: "Diagrid"
Space: Model space
Handle = 2c
Closed
Constant width 0.000000
area 16936.199773
perimeter 520.695694
at point X= 0.000000 Y= 0.000000 Z= 0.000000
at point X= 0.000000 Y=133.182345 Z= 0.000000
at point X=127.165502 Y=133.182345 Z= 0.000000
at point X=127.165502 Y= 0.000000 Z= 0.000000
The z coords are now all zero, so 2D VBA polyline.coordinates will probably now work the way I want it to.
Trouble is, I can't find a VBA method that will set the UCS to an individual object. (at least a method I understand)
RE: Find Polygon Diagonals
Quote:
Originally Posted by MikeJarosz
...I can't find a VBA method
And here I was giving you LISP functions to run. Sorry about that, I didn't pay attention that this was the VBA group or that you were using VBA. I was just thinking about the problem....
1 Attachment(s)
RE: Find Polygon Diagonals
I solved it by avoiding the UCS/OCA issue. In a nutshell, I exploded the polyline, grabbed the startpoint xyz of each resultant line then restored the polyline with sendcommand "undo". The lines can then be drawn from V1 to V3 and V2 to v4.
An orbit view looks great!
1 Attachment(s)
RE: Find Polygon Diagonals
I would like to try solving the polygon diagonals problem without resorting to the explode method. The polygon is rotated in space and has all different z coordinates. After much searching, I still cannot find a way to isolate the actual xyz coordinates of the 4 vertices from VBA methods. The coordinates property returns only 8 items for a 4 sided poly; the z is ignored. Not only that, but the x and y are projections, not the actual xy values of the vertex.
What appears to be a likely solution is to change the coordinate system to be parallel to the face of the polygon. This forces the z values to be zero, and the xy coordinates found using the coordinates method. I then have the points I need to draw the diagonals. Mind you, I still don't have the true WCS coords of the vertices. I have to transform back to world and use the startpoints of the lines for that.
I can use the tools --> new UCS --> object menu in Acad to create a UCS parallel to the poly face. Trouble is I have 30,000 polylines. Doing each poly interactively is unreasonable. So I have to go into VBA. I can find no easy way to emulate the tools --> new UCS --> object technique.
This leads to the VBA translate coordinates method. VBA help gives the following example of setting the UCS:
Code:
' Create a UCS named "New_UCS" in current drawing
Dim ucsObj As AcadUCS
Dim origin(0 To 2) As Double
Dim xAxisPnt(0 To 2) As Double
Dim yAxisPnt(0 To 2) As Double
' Define the UCS
origin(0) = 2#: origin(1) = 2#: origin(2) = 2#
xAxisPnt(0) = 5#: xAxisPnt(1) = 2#: xAxisPnt(2) = 2#
yAxisPnt(0) = 2#: yAxisPnt(1) = 6#: yAxisPnt(2) = 2#
' Add the UCS to the UserCoordinatesSystems collection
Set ucsObj = ThisDrawing.UserCoordinateSystems.Add(origin, xAxisPnt, yAxisPnt, "New_UCS")
ThisDrawing.ActiveUCS = ucsObj
I don't seem to be able to get past this example. The x and y axis points appear to be the same as the origin point except for xpt(0) and ypt(1). How do I relate this to my polyline? What are the xaxispt =5# and the yaxispt = 6#? These numbers look arbitrary to me.
These are my polyline coords in WCS. Notice the z values:
Code:
LWPOLYLINE Layer: "Diagrid"
Space: Model space
Handle = 2d
Closed
Constant width 0.000000
Extrusion direction relative to UCS:
X=-0.345290 Y=-0.361628 Z= 0.866025
area 16936.199773
perimeter 520.695694
at point X=-6.925254 Y=323.783263 Z= 0.000000
at point X=117.747712 Y=314.871262 Z=45.986571
at point X=126.257091 Y=196.617761 Z= 0.000000
at point X= 1.584124 Y=205.529762 Z=-45.986571
If I could grab these numbers in VBA, I'd be done.
If I do tools --> new UCS --> object I get:
Code:
LWPOLYLINE Layer: "Diagrid"
Space: Model space
Handle = 2d
Closed
Constant width 0.000000
area 16936.199773
perimeter 520.695694
at point X= 0.000000 Y=127.165502 Z= 0.000000
at point X=133.182345 Y=127.165502 Z= 0.000000
at point X=133.182345 Y= 0.000000 Z= 0.000000
at point X= 0.000000 Y= 0.000000 Z= 0.000000
Both of these data sets give me the info I need to draw my lines, but they come from the list window, not VBA. Why can list do it, and VBA not?
I tried the ADN help line. The answer I got is that I should use the coordinates and translate coordinates methods. I knew that already. No help was offered on understanding how these methods work as applied to an actual object like a polyline.
I tried plugging different combinations of my numbers into their code. Nothing I did could create a UCS that was parallel to the poly face.
What am I missing? Can someone show me how to create a parallel UCS to the poly.dwg I have attached?
RE: Find Polygon Diagonals
I had to create a very similar routine a while back though I only had to deal with LWPoly's. 2DPoly's add a little more complexity, especially if there is a need to isolate those with only four sides.
In any event, the pertinent section of the code is below. It seems pretty stable but add whatever error checking deemed neccessary. Hope it helps.
I'm glad I previewed . . . . the smiley faces represent (eight)
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
RE: Find Polygon Diagonals
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
RE: Find Polygon Diagonals
Thanks Sean, it worked perfectly.
I'm working hard to figure it out. You might be able to guess from my posting that I don't quite get the translate coordinates method.
RE: Find Polygon Diagonals
Quote:
Originally Posted by seant61
Code tags should help with a Copy and Paste. I'm still trying to sort out all these posting details.
To get rid of the smilies, while in the advanced editor, check "Disable smilies in text".