AreaCalc

[commakozzi]

The HVAC guys here at my office asked me to come up with an area calculation for them to use to do their loads. The following was something quick I came up with for them to use right away, but I'd like for them to be able to window a whole mess of rectangle or polyline areas and have the text automatically inserted into the center of those areas:

Public Sub AreaCalc()

Dim objEnt As AcadLWPolyline
Dim varPick As Variant
Dim sngArea As Single
Dim strArea As String
Dim objText As AcadText
Dim varInsert As Variant
Dim varScale As Variant
Dim dblHeight As Double
Dim strLayerName As String
Dim objLayer As AcadLayer

On Error Resume Next

With ThisDrawing.Utility
.GetEntity objEnt, varPick, vbCr & "Select area/s to calculate: "
If Err Then
MsgBox ("You did not select a polyline!")
Exit Sub
Else
sngArea = objEnt.Area
varInsert = .GetPoint(, vbCr & "Select insert point for area text: ")
End If
End With

varScale = ThisDrawing.GetVariable("dimscale")

Select Case varScale
Case "24"
dblHeight = 2
Case "48"
dblHeight = 4.5
Case "96"
dblHeight = 9
Case "128"
dblHeight = 12
Case "192"
dblHeight = 18
End Select

strArea = CInt(sngArea / 144)

If ThisDrawing.ActiveSpace = acModelSpace Then
Set objText = ThisDrawing.ModelSpace.AddText((strArea) & " SF", varInsert, dblHeight)
End If

strLayerName = "M-AREA"

If Not strLayerName Then
objLayer = ThisDrawing.Layers.Add(strLayerName)
objLayer.Linetype = "continuous"
objLayer.color = acWhite
End If

objText.Layer = "m-area"
objText.Update

End Sub


So how would you guys improve on this and make it so that the text is input in the center of each area automatically. Oh yeah, and also how would you change it to do multiple areas at once?

Thanks,

commakozzi

[Anonymous]

Hi commakozzi,

You can use the formula to find the x and y values (and deduce z) for the centroids at http://local.wasp.uwa.edu.au/~pbourke/geometry/polyarea/ .

below is an example of transversing through a polyline (reversing a polylines direction) to

{code}
Sub RevPline()
'this code was found somewhere, is for example only and should not be trusted for production, in particular bulges
Dim objPline As Object
Dim varBasePt As Variant
Dim varCoords As Variant
Dim intLastCoord As Integer
Dim i As Integer, o As Integer
Dim varNewPoints As Variant
Dim j As Integer
AppActivate ThisDrawing.Application.Caption
ThisDrawing.Utility.GetEntity objPline, varBasePt, vbCr & "Select polyline:"

varCoords = objPline.Coordinates
ReDim varNewPoints(0 To (UBound(varCoords) + 1) / 2 * 3 - 1) As Double
'MsgBox UBound(varNewPoints)
'assign x's
On Error Resume Next
For j = 0 To UBound(varNewPoints) + 4 Step 3
i = 1
varNewPoints(j) = varCoords(UBound(varCoords) - i)
i = i + 2
Next j

'assign y's
For j = 1 To UBound(varNewPoints) + 4 Step 3
i = 0
varNewPoints(j) = varCoords(UBound(varCoords) - i)
i = i + 2
Next j

'assign z's
For j = 2 To UBound(varNewPoints) + 4 Step 3
varNewPoints(j) = 0#
Next j
objPline.color = acYellow
ThisDrawing.ModelSpace.AddPolyline varNewPoints

End Sub
{code}

below is an example of using a selectionset to collect many polylines and their areas

{code}
Sub copyareaft()
'i think microsoft scripting may need to be referenced for clipboard use
'select objects with area properties before running
'(have it set up in right click menu)
Dim objClip As New DataObject
Dim SSET As AcadSelectionSet
On Error Resume Next
SSET.Clear
Set SSET = ThisDrawing.ActiveSelectionSet
On Error GoTo 0
Dim areaFt As Double
For X = 0 To SSET.count
On Error Resume Next
areaFt = SSET(X).area + areaFt
On Error GoTo 0
Next X
ThisDrawing.SetVariable "MODEMACRO", SSET.count & " : " & Format(areaFt, "###,###,##0.00" & " Sq.Ft.")
objClip.SetText Format(areaFt, "###,###,##0.000")
objClip.PutInClipboard
Set SSET = Nothing
End Sub
{code}

to be more precise and only select polylines a filter should be applied reference SelectOnScreen

hope is useful
cadger

[commakozzi]

Very interesting thank you!!!

I'll let you know how it goes.

commakozzi