VBA - Measuring the area of a region

[TotoKad]

Hello everybody!

 

I use VBA with Excel for some years but I have been asked to create a VBA macro for AutoCAD. I have to draw the shape of a storage pile from the table of the measurement in Excel. Then I have to measure the area of each profile. My macro runs well for the drawing, but I can't read the area of the region I created.

 

I have used the same codes as the help examples (I think ^^) but I have this message: "Object doesn't support this property or method". But when I use the 'Watch' tool, the region have an area... .

 

Here is an extract of the code. The total Excel worksheet is attached:

 

 
Sub Calculation()
   
   Dim ThisDrawing As AutoCAD.AcadDocument
   Set ThisDrawing = AutoCAD.ActiveDocument
   
   Dim Measurement As Variant
   Dim NbStep As Integer
   Dim NbProfile As Integer
   Dim DimStep As Single
   Dim DimProfile As Single
   Dim Elev As Single
   Dim Density As Single
   Dim Col As Integer
   Dim Row As Integer
   Dim SCol As Integer
   Dim SRow As Integer
   Dim Line As Integer
   Dim Value As Single
       
   Dim CommandSent As String
   
   Dim zStart As Single
   Dim zEnd As Single
   
   Dim ProfileEntity(0 To 3) As AcadEntity
   Dim ProfileRegion As Variant
   
   
   Line = 1
   
   'save the informations
   DimStep = 3
   DimProfile = 9.75
   Elev = 20.12
   Density = 1500
   
   
With Application
   .Calculation = xlCalculationManual
   
'---------------------------------------------------------
'---(deleted - see the attached file)-----------------------
'---------------------------------------------------------
   
   'create the command for AutoCAD. First it creates the top spline and then the lines to close the profile.
   'after each profile, the y value is increased to separate the profiles.
   For Col = 0 To NbProfile - 1
   
       'creates the spline
       Dim Points() As Double
       Dim i As Integer
       Dim SplineTangent(0 To 2) As Double
       
       ReDim Points(1 To (NbStep + 1) * 3)
       
       SplineTangent(0) = 0: SplineTangent(1) = 0: SplineTangent(2) = 0
       
       zStart = Format(Elev - Worksheets("Measurement Table").Cells(SRow, Col + SCol).Value, "#0.000")
       
       'enters the points for the spline
       For Row = 0 To NbStep
           zEnd = Format(Elev - Worksheets("Measurement Table").Cells(Row + SRow, Col + SCol).Value, "#0.000")
                       
           Points((Row * 3) + 1) = Format(Row * DimStep, "#0.000")
           Points((Row * 3) + 2) = Format(Col * DimProfile, "#0.000")
           Points((Row + 1) * 3) = zEnd
           
       Next Row
       
       'sends the command
       Set ProfileEntity(0) = ThisDrawing.ModelSpace.AddSpline(Points, SplineTangent, SplineTangent)
       
       
       'closes the profile
       Dim LinePoint0(0 To 2) As Double
       Dim LinePoint1(0 To 2) As Double
       Dim LinePoint2(0 To 2) As Double
       Dim LinePoint3(0 To 2) As Double
       
       LinePoint0(0) = Format(NbStep * DimStep, "#0.000"): LinePoint0(1) = Format(Col * DimProfile, "#0.000"): LinePoint0(2) = zEnd
       LinePoint1(0) = Format(NbStep * DimStep, "#0.000"): LinePoint1(1) = Format(Col * DimProfile, "#0.000"): LinePoint1(2) = 0
       LinePoint2(0) = 0: LinePoint2(1) = Format(Col * DimProfile, "#0.000"): LinePoint2(2) = 0
       LinePoint3(0) = 0: LinePoint3(1) = Format(Col * DimProfile, "#0.000"): LinePoint3(2) = zStart
       
       
       'sends the command
       Set ProfileEntity(1) = ThisDrawing.ModelSpace.AddLine(LinePoint0, LinePoint1)
       Set ProfileEntity(2) = ThisDrawing.ModelSpace.AddLine(LinePoint1, LinePoint2)
       Set ProfileEntity(3) = ThisDrawing.ModelSpace.AddLine(LinePoint2, LinePoint3)
               
       
       'measures the area
       'On Local Error GoTo NoRegion -> will be enabled when the error is corrected
       ProfileRegion = ThisDrawing.ModelSpace.AddRegion(ProfileEntity)
       
       ThisDrawing.Regen acAllViewports
               
       Worksheets("Results").Cells(Col + 2, 2).Value = ThisDrawing.ModelSpace.ProfileRegion.Area '-> Here is the error
   Next Col

'---------------------------------------------------------
'---(deleted - see the attached file)-----------------------
'---------------------------------------------------------

   'changes the viewpoint
   ThisDrawing.SendCommand "vpoint" & vbCr & "1,-1,1" & vbCr
   
   .Calculation = xlCalculationAutomatic
   

End With
Exit Sub
NoRegion:
   Worksheets("Results").Cells(Col + 2, 2).Value = "ERROR"
Resume Next
End Sub

 

The code is not optimized at all: I adapted it from an old procedure, so it can seem quite strange...!

 

If somebody could help me finding a solution... I'm stuck on it for hours!

Thanks.

Drawing sheet.zip

[SEANT]

Change line to this:

 

Worksheets("Results").Cells(Col + 2, 2).Value = ProfileRegion(0).Area

[SEANT]

Incidentally, some of the cross sections are not converting to Regions due to self-intersecting geometry.

[TotoKad]

Now it works! Thank you very much:thumbsup:!

 

Incidentally, some of the cross sections are not converting to Regions due to self-intersecting geometry.

-> I know this, that is why I prepared the "On Error GoTo NoRegion"

 

After that, it could be manually corrected: I use the 'Break at point' command and I create 2 different regions (Z > 0, I delete the little other one)... If you have another solution, I'm interested !

[SEANT]

 

 

-> I know this, that is why I prepared the "On Error GoTo NoRegion"

 

Ah, yes. I overlooked that.

 

I suppose one automated solution could be to extend the lines for each region a sensible distance below Z = 0. The area could then be derived mathematically by area of region – (region width * sensible distance)

[TotoKad]

Thank you for this idea!

Just one comment: The area is not exactly the same as expected. You also substract the area which is over the spline and under Z=0. So you have a little difference. But as the difference is limited, I think I will use this method .

 

Have a nice day!