Internal angular dimensions of a region (triangle)

[Anonymous]

Guys,

I'm trying to create something that sounds easy but I can't solve this problem by myself... here we go:

I do have a exploded GRID Volume surface done on Civil 3D that creates a lots of Regions objects wich the greater number type is a triangle with 3 vertex on the space (different elevations each vertex).

Now I need to identify wich object is a triangule and wich one is not: I think to select each object and calculate the sum of internal angles, if the internal angles sum is 180° then it is a triangle. But I have no idea how to get this internal angular dimension.

The main idea is to erase all the triangles generateds after explode the GRID Volume Surface...

Does anyone know how can I do something like that? Is it possible!

Thanks!

PS: I had attached a example... Edited by: carlos_krueger on Jan 15, 2010 4:36 PM

[Hallex]

Perhaps, easier yet to write selected region to temporary .SAT file
then read this file and calculate words "points#" if there are three in them
thus it is a triangle
Then delete .SAT file and go to next region

~'J'~

[Hallex]

This one is working on my end

{code}
Option Explicit
'' require reference to Microsoft Scripting Runtime

Sub TestRegions()
Dim oEnt As AcadEntity
Dim oReg As AcadRegion
Dim ftype(0) As Integer
Dim fdata(0) As Variant
Dim dxfCode, dxfValue
Dim name As String
Dim count As Integer

On Error GoTo Err_Control

Dim oSset As AcadSelectionSet
With ThisDrawing.SelectionSets
While .count > 0
.Item(0).Delete
Wend
Set oSset = .Add("$Regions$")
End With
ftype(0) = 0: fdata(0) = "REGION"
dxfCode = ftype: dxfValue = fdata
oSset.SelectOnScreen dxfCode, dxfValue
MsgBox oSset.count
ThisDrawing.SetVariable "EXPERT", 5
ThisDrawing.SetVariable "FILEDIA", 0
For Each oEnt In oSset
Set oReg = oEnt
name = Replace(ThisDrawing.name, ".dwg", ".sat")
ThisDrawing.SendCommand "_acisout " & "(handent " & Chr(34) & CStr(oReg.Handle) & Chr(34) & ") " & vbCr & name & vbCr & vbCr
count = CountPoints(name)
If count = 3 Then
MsgBox "Trianle"
Else
MsgBox "Another shape"
End If
Kill name
Next
ThisDrawing.SendCommand vbCr

Exit_Here:
ThisDrawing.SetVariable "FILEDIA", 1
ThisDrawing.SetVariable "EXPERT", 0
Exit Sub

Err_Control:
If Err.Number <> 0 Then
MsgBox Err.Description
Err.Clear
End If
Resume Exit_Here

End Sub

Public Function CountPoints(fname As String) As Integer
Dim fn, sr As String, fs, ForReading
Dim tmp(1) As String
ForReading = 1
Dim count As Integer

Set fs = CreateObject("Scripting.FileSystemObject")
Set fn = fs.OpenTextFile(fname, ForReading, False) ''<--full path

Do While Not fn.AtEndOfStream
sr = fn.Read(0)
sr = fn.ReadLine
If sr Like "point*" Then
count = count + 1
End If
Loop
fn.Close

Set fn = Nothing
Set fs = Nothing
CountPoints = count

End Function
{code}

~'J'~

[Anonymous]

Hi Carlos,

Here is another solution.

It's based on the premise, that you can create a copy of each region,
then explode the region to lines and count the number of lines generated
from the Explode.

If 3 lines are generated the copy of the region is deleted, otherwise
it's left in the drawing..

The new lines are deleted, then move on to the next region

Owing to the risk of there being existing lines in the drawing caught up
in the selection set of lines I've provided to allow for that
happening. For some reason which I don't understand, this segment of
the code doesn't work without doing regens and slowing the program down
enormously. You may care to see if you can refine it.

{code}
Option Explicit

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Call from:
' Calls:
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub Fred()
On Error GoTo ErrorHandler
Dim i As Integer
Dim iInitialLineCount As Integer
Dim ssInitialLines As AcadSelectionSet
Dim ssRegions As AcadSelectionSet
Dim l As Long
l = SelectObjectsByLayerAndObject(ssRegions, "Regions", "REGION", "*")
If l > 0 Then
iInitialLineCount = SelectObjectsByLayerAndObject(ssInitialLines,
"InitialLines", "LINE", "*")
If iInitialLineCount > 0 Then
HideLines ssInitialLines
ProcessWithInitialLines ssRegions, ssInitialLines
ShowLines ssInitialLines
Else
ProcessWithNoInitialLines ssRegions
End If
ThisDrawing.Regen acActiveViewport
ssRegions.Erase
Else
MsgBox "No Regions found in the drawing", vbInformation
End If
Exit Sub
ErrorHandler:
MsgBox "Unable to complete Sub 'Fred' due to" & vbCrLf & Err.Description
Err.Clear

End Sub ' Fred

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Call from:
' Calls:
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ProcessWithInitialLines(ssRegions As AcadSelectionSet,
ssInitialLines As AcadSelectionSet) As Boolean
On Error GoTo ErrorHandler
Dim iInitLineCount As Integer
Dim iFinalLineCount As Integer
Dim PtLL(0 To 2) As Double
Dim PtUR(0 To 2) As Double
Dim vPtLL As Variant
Dim vPtUR As Variant
Dim oEnt As AcadEntity
Dim oEnt2 As AcadEntity
Dim oReg As AcadRegion
Dim oReg2 As AcadRegion
Dim oRegCopy As AcadRegion
Dim i As Integer
Dim ssFinalLines As AcadSelectionSet
For Each oEnt In ssRegions
If TypeOf oEnt Is AcadRegion Then
Set oReg = oEnt
oReg.GetBoundingBox vPtLL, vPtUR
VariantToPoint vPtLL, PtLL
VariantToPoint vPtUR, PtUR
iInitLineCount = SelectObjectsOnLayerInBox(ssInitialLines,
"InitialLines", "LINE", "*", PtLL, PtUR)
Set oRegCopy = oReg.Copy
oReg.Explode
Set oReg = Nothing
ThisDrawing.Regen acActiveViewport ' This seems crazy, but unless
I regen, none of the new line objects are found.
iFinalLineCount = SelectObjectsOnLayerInBox(ssFinalLines,
"FinalLines", "LINE", "*", PtLL, PtUR)
If iFinalLineCount - iInitLineCount = 3 Then
oRegCopy.Delete
End If
If iInitLineCount = 0 Then
ssFinalLines.Erase
Else
For Each oEnt2 In ssFinalLines
If oEnt2.Visible = True Then
oEnt2.Delete
End If
Next
End If
End If
Next
ProcessWithInitialLines = True
Exit Function
ErrorHandler:
MsgBox "Unable to complete Function 'ProcessWithInitialLines' due to"
& vbCrLf & Err.Description
Err.Clear
ProcessWithInitialLines = False

End Function ' ProcessWithInitialLines
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Call from:
' Calls:
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ProcessWithNoInitialLines(ssRegions As AcadSelectionSet) As Boolean
On Error GoTo ErrorHandler
Dim Pt(0 To 2) As Double
Dim vPt As Variant
Dim iFinalLineCount As Long
Dim ptZero(0 To 2) As Double
Dim oEnt As AcadEntity
Dim oReg As AcadRegion
Dim oReg2 As AcadRegion
Dim oRegCopy As AcadRegion
Dim ssFinalLines As AcadSelectionSet
For Each oEnt In ssRegions
If TypeOf oEnt Is AcadRegion Then
Set oReg = oEnt
oReg.Highlight True
Set oRegCopy = oReg.Copy
oReg.Explode
Set oReg = Nothing
iFinalLineCount = SelectObjectsByLayerAndObject(ssFinalLines,
"FinalLines", "LINE", "*")
If iFinalLineCount = 3 Then
oRegCopy.Delete
End If
Set oEnt = Nothing
Set oRegCopy = Nothing
ssFinalLines.Erase
End If
Next

ProcessWithNoInitialLines = True
Exit Function
ErrorHandler:
MsgBox "Unable to complete Function 'ProcessWithNoInitialLines' due
to" & vbCrLf & Err.Description
Err.Clear
ProcessWithNoInitialLines = False

End Function ' ProcessWithNoInitialLines

Function VariantToPoint(v As Variant, Pt() As Double)
Dim i As Integer
For i = 0 To 2
Pt(i) = v(i)
Next i

End Function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Call from:
' Calls:
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function HideLines(ssInitialLines As AcadSelectionSet) As Boolean
On Error GoTo ErrorHandler
Dim oLine As AcadLine
Dim oEnt As AcadEntity
For Each oEnt In ssInitialLines
If TypeOf oEnt Is AcadLine Then
Set oLine = oEnt
oLine.Visible = False
End If
Next
HideLines = True
Exit Function
ErrorHandler:
MsgBox "Unable to complete Function 'HideLines' due to" & vbCrLf &
Err.Description
Err.Clear
HideLines = False

End Function ' HideLines

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Call from:
' Calls:
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ShowLines(ssInitialLines As AcadSelectionSet) As Boolean
On Error GoTo ErrorHandler
Dim oLine As AcadLine
Dim oEnt As AcadEntity
For Each oEnt In ssInitialLines
If TypeOf oEnt Is AcadLine Then
Set oLine = oEnt
oLine.Visible = True
End If
Next
ShowLines = True
Exit Function
ErrorHandler:
MsgBox "Unable to complete Function 'ShowLines' due to" & vbCrLf &
Err.Description
Err.Clear
ShowLines = False

End Function ' ShowLines
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Auto Select objects of a nominated type on nominated layers
' and inside a nominated rectangle
' Status: Fully tested
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Function SelectObjectsOnLayerInBox(ssObs As AcadSelectionSet,
sSSName As String, sObjName As String, sLayName As String, Pt1() As
Double, Pt2() As Double) As Long
On Error Resume Next
Dim saType(0 To 1) As Integer
Dim saData(0 To 1) As Variant
saType(0) = 0: saData(0) = sObjName
saType(1) = 8: saData(1) = sLayName
ThisDrawing.SelectionSets.Item(sSSName).Delete
If Err <> 0 Then
Err.Clear
End If
On Error GoTo SOLErrorHandler
Set ssObs = ThisDrawing.SelectionSets.Add(sSSName)
ssObs.Select acSelectionSetWindow, Pt1, Pt2, saType, saData
SelectObjectsOnLayerInBox = ssObs.Count
If ssObs.Count > 0 Then
Exit Function
Else
' MsgBox "No " & sObjName & " objects found on layer " & sLayName,
vbInformation
End If
Exit Function
SOLErrorHandler:
MsgBox "Error '" & Err.Description & "' in SelectObjectsOnLayerInBox",
vbCritical
Err.Clear
SelectObjectsOnLayerInBox = 0

End Function 'SelectObjectsOnLayerInBox()

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Auto Select objects of a nominated type on nominated layers
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Function SelectObjectsByLayerAndObject(ssObs As AcadSelectionSet,
sSSName As String, spObjectType As String, spLayer As String) As Long
On Error Resume Next
Dim FilterType(0 To 1) As Integer
Dim FilterData(0 To 1) As Variant
Dim sNumber As String
FilterType(0) = 0: FilterData(0) = spObjectType
FilterType(1) = 8: FilterData(1) = spLayer
ThisDrawing.SelectionSets.Item(sSSName).Delete
If Err > 0 Then Err.Clear
On Error GoTo ErrorHandler
Set ssObs = ThisDrawing.SelectionSets.Add(sSSName)
ssObs.Select acSelectionSetAll, , , FilterType, FilterData
SelectObjectsByLayerAndObject = ssObs.Count
Exit Function

ErrorHandler:
MsgBox "Error selecting objects with 'SelectObjectsByLayerAndObject'
due to:-" & vbCrLf And Err.Description
Err.Clear
SelectObjectsByLayerAndObject = 0
End Function ' SelectObjectsByLayerAndObject()

{code}


Regards,


Laurie Comerford



carlos_krueger wrote:
> Guys,
>
> I'm trying to create something that sounds easy but I can't solve this problem by myself... here we go:
>
> I do have a exploded GRID Volume surface done on Civil 3D that creates a lots of Regions objects wich the greater number type is a triangle with 3 vertex on the space (different elevations each vertex).
>
> Now I need to identify wich object is a triangule and wich one is not: I think to select each object and calculate the sum of internal angles, if the internal angles sum is 180° then it is a triangle. But I have no idea how to get this internal angular dimension.
>
> The main idea is to erase all the triangles generateds after explode the GRID Volume Surface...
>
> Does anyone know how can I do something like that? Is it possible!
>
> Thanks!
>
> PS: I had attached a example...
>
> Edited by: carlos_krueger on Jan 15, 2010 4:36 PM
>

[Anonymous]

Thank you guys... I will test it for my ends and will reply my results soon!
Best regards!