Lots of years have passed...
I had no email message about this request.
In case someone has the same problem...
I am far from being proud about this coding. But at least it shows how to get the points. I no longer use Structures and ArrayLists. I needed a solution on the fly and i was based on some very old coding of mine.
The TKV and Civil3D objects are custom objects of mine, ignore them.
Area calculation is not that easy i though it would be. There might be multiple areas and the code must detect them so it does. Most probably the area calculation has more value than the Civil 3D material points extraction itself.
For the selected SampleLineGroup, for each sample line, for each material of each material list it gets their points calculates the areas and export them to a text file using the appropriate headers to distinguish.
Dim SelectedSLG As ACDBS.SampleLineGroup
Private Sub btnKMS_Click(sender As Object, e As EventArgs) Handles btnKMS.Click
Try
'used for transaction to get each SL object
Dim MDIactiveDoc As Autodesk.AutoCAD.ApplicationServices.Document = Autodesk.AutoCAD.ApplicationServices.Application.DocumentManager.MdiActiveDocument
Dim DirectorySelection As String = TKVCL.TKV_SelectPathFile.SelectOnlyDirectory(, True)
If DirectorySelection = String.Empty Then Exit Sub
' ...for the current SampleLineGroup
Dim LofSLobjects As List(Of Autodesk.Civil.DatabaseServices.SampleLine) = Civil3D.NET.SLGs.SLs(Me.SelectedSLG)
If LofSLobjects Is Nothing Then
MsgBox("Operation failed", MsgBoxStyle.Critical)
Exit Sub
End If
Dim FileName As String = DirectorySelection + "\" + Me.SelectedAlignmentName + "." + Me.SelectedSLG.Name + ".txt"
Using OutputFile As New System.IO.StreamWriter(FileName)
'...write headers
For Each MaterialList As Autodesk.Civil.DatabaseServices.QTOMaterialList In Me.SelectedSLG.MaterialLists
For Each Material As Autodesk.Civil.DatabaseServices.QTOMaterial In MaterialList
Dim MaterialSectionID As Autodesk.AutoCAD.DatabaseServices.ObjectId = LofSLobjects.Item(0).GetMaterialSectionId(MaterialList.Guid, Material.Guid)
Dim MaterialSectionObject As Autodesk.Civil.DatabaseServices.MaterialSection
Try
Using TRNSCTN As Autodesk.AutoCAD.DatabaseServices.Transaction = MDIactiveDoc.Database.TransactionManager.StartTransaction
MaterialSectionObject = CType(TRNSCTN.GetObject(MaterialSectionID, Autodesk.AutoCAD.DatabaseServices.OpenMode.ForRead), Autodesk.Civil.DatabaseServices.MaterialSection)
End Using
OutputFile.Write(vbTab + MaterialList.Name + "." + Material.Name)
Catch ex As Exception
MsgBox("While exporting names..." + ex.Message, MsgBoxStyle.Critical, "Error")
End Try
Next
Next
OutputFile.WriteLine()
' ...for each sample line
For Each SLobject As Autodesk.Civil.DatabaseServices.SampleLine In LofSLobjects
OutputFile.Write(SLobject.Station.ToString("0.000"))
' run through each QTOmaterialList for the current SLG
For Each MaterialList As Autodesk.Civil.DatabaseServices.QTOMaterialList In Me.SelectedSLG.MaterialLists
'run through each QTOmaterial for the current QTOmaterialList
For Each Material As Autodesk.Civil.DatabaseServices.QTOMaterial In MaterialList
Dim MaterialSectionID As Autodesk.AutoCAD.DatabaseServices.ObjectId = SLobject.GetMaterialSectionId(MaterialList.Guid, Material.Guid)
Dim MaterialSectionObject As Autodesk.Civil.DatabaseServices.MaterialSection
Try
Using TRNSCTN As Autodesk.AutoCAD.DatabaseServices.Transaction = MDIactiveDoc.Database.TransactionManager.StartTransaction
MaterialSectionObject = CType(TRNSCTN.GetObject(MaterialSectionID, Autodesk.AutoCAD.DatabaseServices.OpenMode.ForRead), Autodesk.Civil.DatabaseServices.MaterialSection)
End Using
'MsgBox("Station=" + SLobject.Station.ToString("0+000.00") + CalculateArea(MaterialSectionObject.SectionPoints).ToString(" area is=0.000") + MaterialSectionObject.Area.ToString(" C3D area is 0.00"))
OutputFile.Write(vbTab + CalculateArea(MaterialSectionObject.SectionPoints).ToString("0.000"))
Catch ex As Exception
MsgBox("While exporting areas..." + ex.Message, MsgBoxStyle.Critical, "Error")
End Try
Next 'QTOmaterial
Next 'QTOmaterialList
OutputFile.WriteLine()
Next 'SampleLine
End Using
Catch ex As Exception
MsgBox("Failed to export values" + vbNewLine + Err.Description, MsgBoxStyle.Information)
End Try
End Sub
Public Module TKV_StructuresOfDoubles
Public Structure TwoDoubles 'eg Station and Offset or Station and LeftSlope or RightSlope
Dim DoubleValue1 As Double
Dim DoubleValue2 As Double
End Structure
'includes search for multiple closed areas!!!
Public Function ListOfTwoDoublesArea(ByVal AoTD As ArrayList, Optional ByVal WarnForNonClosedAreas As Boolean = True, Optional ByVal SearchForMultipleAreas As Boolean = True) As Double
Try
ListOfTwoDoublesArea = 0 'return value-contains final area-may be the sum of all areas if SearchForMultipleAreas is set to default value TRUE
Dim AreaRunning As Double 'holds area while calculating
Dim StartPoint As New TKV_StructuresOfDoubles.TwoDoubles 'contains start point to check for possible sub area closing
Dim ListOfAreas As New List(Of Double) 'contains sub areas
Dim StartNewArea As Boolean = True
Dim i As Integer = 0, P1 As TwoDoubles, P2 As TwoDoubles
For i = 0 To AoTD.Count - 2
If StartNewArea Then
StartNewArea = False
StartPoint = CType(AoTD(i), TwoDoubles)
AreaRunning = 0
End If
P1 = CType(AoTD(i), TwoDoubles) : P2 = CType(AoTD(i + 1), TwoDoubles)
AreaRunning += (P1.DoubleValue1 - P2.DoubleValue1) * ((P1.DoubleValue2 + P2.DoubleValue2) / 2)
If TKV_StructuresOfDoubles.IsEqual(StartPoint, P2) Then
ListOfAreas.Add(AreaRunning)
StartNewArea = True
i += 1
End If
Next
'if list of points reached the end but current area startpoint is not equal to current end point then inform user if optional warn value is left to optional TRUE
If StartNewArea = False Then
If WarnForNonClosedAreas Then MsgBox("Open area detected !" + vbNewLine + "Start point coordinates" + vbNewLine + "X=" + StartPoint.DoubleValue1.ToString("0.000") + vbNewLine + "Y=" + StartPoint.DoubleValue2.ToString("0.000"))
End If
'sum all sub areas
For Each x As Double In ListOfAreas
ListOfTwoDoublesArea += x
Next
Return Math.Abs(ListOfTwoDoublesArea)
Catch ex As Exception
Return Double.NaN
End Try
End Function
Public Function IsEqual(ByVal A As TwoDoubles, ByVal B As TwoDoubles,
Optional ByVal UseValue1tolerance As Boolean = False, Optional ByVal UseValue2tolerance As Boolean = False,
Optional ByVal Value1tolerance As Double = 0.0001, Optional ByVal Value2tolerance As Double = 0.0001,
Optional ByVal ShowErrorMessage As Boolean = True) As Boolean
Try
Dim EqualityOfValue1 As Boolean = False
If UseValue1tolerance Then
If Math.Abs(A.DoubleValue1 - B.DoubleValue1) <= Value1tolerance Then EqualityOfValue1 = True Else EqualityOfValue1 = False
Else
If A.DoubleValue1 = B.DoubleValue1 Then EqualityOfValue1 = True Else EqualityOfValue1 = False
End If
Dim EqualityOfValue2 As Boolean = False
If UseValue2tolerance Then
If Math.Abs(A.DoubleValue2 - B.DoubleValue2) <= Value1tolerance Then EqualityOfValue2 = True Else EqualityOfValue2 = False
Else
If A.DoubleValue2 = B.DoubleValue2 Then EqualityOfValue2 = True Else EqualityOfValue2 = False
End If
If EqualityOfValue1 And EqualityOfValue2 Then Return True Else Return False
Catch ex As Exception
If ShowErrorMessage Then MsgBox("Failed to compare TwoDoubles. Development error.", CType(MsgBoxStyle.Critical + MsgBoxStyle.ApplicationModal, MsgBoxStyle))
Return False
End Try
End Function
End Module
Public Function SLs(ByVal SLG As Autodesk.Civil.DatabaseServices.SampleLineGroup) As List(Of Autodesk.Civil.DatabaseServices.SampleLine)
Try
'get ID for each sample line for the entered SLG
Dim LofSLids As Autodesk.AutoCAD.DatabaseServices.ObjectIdCollection = SLG.GetSampleLineIds
'used for transaction to get each SL object
Dim MDIactiveDoc As Autodesk.AutoCAD.ApplicationServices.Document = Autodesk.AutoCAD.ApplicationServices.Application.DocumentManager.MdiActiveDocument
Dim LofSLobjects As New List(Of Autodesk.Civil.DatabaseServices.SampleLine)
For Each SLid As Autodesk.AutoCAD.DatabaseServices.ObjectId In LofSLids
Try
Using TRNSCTN As Autodesk.AutoCAD.DatabaseServices.Transaction = MDIactiveDoc.Database.TransactionManager.StartTransaction
Dim SLobject As Autodesk.Civil.DatabaseServices.SampleLine = CType(TRNSCTN.GetObject(SLid, Autodesk.AutoCAD.DatabaseServices.OpenMode.ForRead), Autodesk.Civil.DatabaseServices.SampleLine)
LofSLobjects.Add(SLobject)
End Using
Catch ex As Exception
MsgBox(ex.Message, MsgBoxStyle.Critical, "Error")
End Try
Next
Return LofSLobjects
Catch ex As Exception
MsgBox("Failed to get SL objects " + Err.Description, MsgBoxStyle.Information)
Return Nothing
End Try
End Function
End Module
