VBA - Measuring the area of a
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 WithExit SubNoRegion: Worksheets("Results").Cells(Col + 2, 2).Value = "ERROR"Resume NextEnd 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 Change line to this:
Worksheets("Results").Cells(Col + 2, 2).Value = ProfileRegion(0).Area Incidentally, some of the cross sections are not converting to Regions due to self-intersecting geometry. Now it works! Thank you very much:thumbsup:!
-> 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 !
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) 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!
页:
[1]