Now that all our buildings are made of closed PLines we needed to determine the height of each building. As mentioned earlier, each building, with a few minor exceptions, had a number inside it indicating the number of storeys that building is.
If the buildings were all neat rectangles and had walls running NSEW it would have been possible to make a standard selection box the shape of the building and find the number inside. However, with irregularly shaped buildings this isn’t always possible. In the diagram below we can see that using the top-left to bottom-right boundary for the blue building could result in us choosing either the 6 or the 12.
Selecting the height number using the building's NSEW limits would not work in some cases.
Fortunately there is a way to select items using an irregular shape boundary in AutoCAD VBA (Incidentally, this is very easy to do in the AutoCAD front end by typing CP+Enter when AutoCAD prompts you to select items. See here for a demonstration). Using this technique we loop through all PLines on the layer NewPLine and search for a textbox bounded by the PLine. If there is more than one textbox, we don’t care – just use the first one we find – then move the PLine to a layer called Level_[#] where # is the value of the texbox.
Just to keep us on our toes, some of the text boxes had non numeric values in them, so we had to trap that error.
The trickiest part of this module for me was the SelectByPolygon method, which uses the coordinates of the PLine to create a boundary.
Module05_BuildingHeights
Option Explicit
Sub FindTextInPLine()
Dim ptZero(0 To 2) As Double
Dim stPolyLines As String: stPolyLines = "PolyLineFilter"
Dim FilterType(0) As Integer
Dim FilterData(0) As Variant
Dim ssPlines As AcadSelectionSet
Dim ssText As AcadSelectionSet
Dim arrPLineBoundary() As Double
Dim pLine As AcadLWPolyline
FilterType(0) = 8
FilterData(0) = "NewPLine"
Dim lMoveCount As Long
On Error Resume Next
ThisDrawing.SelectionSets(stPolyLines).Delete
On Error GoTo 0
Set ssPlines = ThisDrawing.SelectionSets.Add(stPolyLines)
Dim txt As AcadMText
Dim iPline As Long, lOriginalMaxPoints As Long, iPoint As Integer
Dim arrCoordsXY() As Double, arrCoordsXYZ() As Double
Dim iLevels As Integer, stLevels As String
ssPlines.Select acSelectionSetAll, ptZero, ptZero, FilterType(), FilterData()
For iPline = 0 To ssPlines.Count – 1
If ssPlines.Item(iPline).ObjectName = "LWPolyLine" Or _
ssPlines.Item(iPline).ObjectName = "AcDbPolyline" Then
Set pLine = ssPlines.Item(iPline)
Set txt = Nothing
arrCoordsXY() = pLine.Coordinates
If UBound(arrCoordsXY) > 3 Then
arrCoordsXYZ() = ConvertXYtoXYZ(arrCoordsXY())
Set txt = GetTextObjectWithBoundary(arrCoordsXYZ())
End If
If Not txt Is Nothing Then
stLevels = txt.TextString
'The textboxes have these invisible braces – don’t show on the screen,
'but suddenly appear when you get the TextString property.
stLevels = Replace(stLevels, "{", "")
stLevels = Replace(stLevels, "}", "")
'Non-numerics will be put on layer 999
iLevels = 999
If IsNumeric(stLevels) Then iLevels = CInt(stLevels)
lMoveCount = lMoveCount + 1
Debug.Print "Moved: " & lMoveCount
Call MoveToLayer(pLine, iLevels)
End If
End If
Next iPline
End Sub
Sub MoveToLayer(pLine As AcadEntity, iLevel As Integer)
'Given an autocad object (pLine) and a number (iLevel)
'it will move that object to a layer called e.g. Level_6
Dim stLayer As String
stLayer = "Level_" & iLevel
On Error Resume Next
Call ThisDrawing.Layers.Add(stLayer)
On Error GoTo 0
pLine.Layer = stLayer
End Sub
Function ConvertXYtoXYZ(xy() As Double) As Double()
'Some of the objects seem to use only xy coords, rather than xyz.
'When we need xyz coords, we use this, which adds an additional (z) coord
'after each xy pair.
Dim xyz() As Double
Dim iXY As Integer, iZ As Integer
ReDim xyz((UBound(xy) + 1) * (3 / 2) – 1)
For iXY = 0 To UBound(xy)
iZ = (iXY \ 2) * 3
iZ = iZ + iXY Mod 2
xyz(iZ) = xy(iXY)
Next iXY
ConvertXYtoXYZ = xyz()
End Function
Function GetTextObjectWithBoundary(Coords() As Double) As AcadMText
'Given a set of coords representing the boundary of a pline,
'we create a selection set representing that boundary and return
'the first text object we find inside that boundary.
Dim ssText As AcadSelectionSet
Dim stText As String: stText = "TextSelection"
On Error Resume Next
ThisDrawing.SelectionSets(stText).Delete
On Error GoTo 0
Dim ptZero(0 To 2) As Double
Dim FilterType(0) As Integer
Dim FilterData(0) As Variant
FilterType(0) = 8
FilterData(0) = "text"
Set ssText = ThisDrawing.SelectionSets.Add(stText)
ssText.Clear
ssText.SelectByPolygon acSelectionSetCrossingPolygon, Coords(), FilterType(), FilterData()
If ssText.Count > 0 Then
Set GetTextObjectWithBoundary = ssText.Item(0)
End If
End Function