Tabulka ploch místností

Jedná se o užitečný nástroj při zpracování změn nebo variant ve stavebních půdorysech. Makro vygeneruje tabulku ploch a jejich popisů z obvodových křivek místností. Tabulka je seřazena dle čísel místností. Lze tak připravit tabulky s čísly a ručně vložit názvy místností. Při změnách či ve variantách půdorysů pak jen postačí smazat původní čísla a plochy a tabulku vygenerovat znova.



Předpokládány jsou hladiny:
a_plochy pro obvodové křivky
a_popis pro čísla místností (dtext)

Zda je text uvnitř uzavřené křivky je analyzováno dle bodu vložení textu.

Testovací půdorys ke stažení

---

Attribute VB_Name = "plochy"
Public Function pointInPolygon(polySides As Integer, x As Double, y As Double, polyX() As Double, polyY() As Double)

  Dim i As Integer
  Dim j As Integer
  Dim oddNodes As Integer
  
  oddNodes = 0
  j = polySides - 1

  For i = 0 To (polySides - 1)
    If (polyY(i) < y And polyY(j) >= y Or polyY(j) < y And polyY(i) >= y) Then
      If (polyX(i) + (y - polyY(i)) / (polyY(j) - polyY(i)) * (polyX(j) - polyX(i)) < x) Then
        If oddNodes = 0 Then
            oddNodes = 1
        ElseIf oddNodes = 1 Then
            oddNodes = 0
        End If
      End If
    End If
    j = i
  Next

  pointInPolygon = oddNodes

End Function

Sub BubbleSort(arr, idorder)
  
  Dim strTemp As String
  Dim i As Integer
  Dim j As Integer
  Dim lngMin As Integer
  Dim lngMax As Integer
  Dim idMin As Integer
  Dim idMax As Integer
  Dim idTemp As Integer
  
  lngMin = LBound(arr)
  lngMax = UBound(arr)
  idMin = lngMin
  idMax = lngMax
  For i = lngMin To lngMax - 1
    For j = i + 1 To lngMax
      If arr(i) > arr(j) Then
        strTemp = arr(i)
        arr(i) = arr(j)
        arr(j) = strTemp
        idTemp = idorder(i)
        idorder(i) = idorder(j)
        idorder(j) = idTemp
      End If
    Next j
  Next i
  
End Sub

Sub plochy()

            Dim icadDoc As IntelliCAD.Document
            Dim Poly As IntelliCAD.LWPolyline
            Dim text As IntelliCAD.text
            Dim mtextObj As IntelliCAD.text
            Dim Pt As IntelliCAD.Point
            Dim Pt1 As IntelliCAD.Point
            Dim Pt2 As IntelliCAD.Point
            Dim Pttable As IntelliCAD.Point
            Dim LL As IntelliCAD.Point
            Dim UR As IntelliCAD.Point
            Dim Pttext As IntelliCAD.Point
            Dim nvert As Integer
            Dim i As Integer
            Dim j As Integer
            Dim uvnitr As Integer
            Dim testx As Double
            Dim testy As Double
            Dim plocha As Double
            Dim ents As Object
            Dim ent As Object
            Dim ct As Integer
            Dim ct2 As Integer
            Dim ct3 As Integer
            Dim id As Integer
            Dim id2 As Integer
            Dim counter As Long
            Dim test As Integer
            Dim obvody() As Integer
            Dim plochy() As Double
            Dim popisy() As Integer
            Dim texty() As String
            Dim idordered() As Integer
            Dim txtStyle As String
            
            Set ents = IntelliCAD.Application.ActiveDocument.ModelSpace
            Set icadDoc = IntelliCAD.Application.ActiveDocument
            ct = ents.Count
            ct2 = 0
            ct3 = 0
            'For counter = 1 To ct
            For counter = 0 To (ct - 1)
                Set ent = ents.Item(counter)
                'If ent.Layer = "a_plochy" And ent.EntityType = 22 Then
                If ent.Layer = "a_plochy" Then
                    ReDim Preserve obvody(ct2)
                    ReDim Preserve plochy(ct2)
                    plochy(ct2) = Round(ent.Area / 10000) / 100
                    obvody(ct2) = counter
                    ct2 = ct2 + 1
                End If
                'If ent.Layer = "a_popis" And ent.EntityType = 33 Then
                If ent.Layer = "a_popis" Then
                    ReDim Preserve popisy(ct3)
                    ReDim Preserve texty(ct3)
                    texty(ct3) = ent.TextString
                    popisy(ct3) = counter
                    ct3 = ct3 + 1
                End If
             Next
            
            BubbleSort texty, popisy
                        
            Set Pttable = icadDoc.Utility.GetPoint(, "Zadejte umisteni tabulky: ")
            
            test = 0
            counter = 0
            txtStyle = icadDoc.ActiveTextStyle.Name
            For id = 0 To UBound(texty)
                'MsgBox "Popis" & id & ": " & texty(id)
                For id2 = 0 To UBound(obvody)
                    Dim vertx() As Double
                    Dim verty() As Double
                    nvert = ents.Item(obvody(id2)).Coordinates.Count
                    'MsgBox "Pocet vrcholu: " & nvert
                    For i = 0 To (nvert - 1)
                        ReDim Preserve vertx(i)
                        ReDim Preserve verty(i)
                        vertx(i) = ents.Item(obvody(id2)).Coordinates.Item(i).x
                        verty(i) = ents.Item(obvody(id2)).Coordinates.Item(i).y
                    Next
                    Set Pttext = ents.Item(popisy(id)).InsertionPoint
                    'ents.Item(popisy(id)).GetBoundingBox LL, UR
                    'testx = (Pttext.x + UR.x) / 2
                    'testy = (Pttext.y + UR.y) / 2
                    testx = Pttext.x
                    testy = Pttext.y
                    uvnitr = pointInPolygon(nvert, testx, testy, vertx, verty)
                    'MsgBox "Uvnitr: " & uvnitr
                    test = test + uvnitr
                    If uvnitr = 1 Then
                        'MsgBox "Popis" & id & ": " & texty(id)
                        'Set mtextObj = icadDoc.ModelSpace.AddText(texty(id), Library.CreatePoint(Pt1.x, Pt1.y - counter * 600, Pt1.z), 300)
                        Set Pt1 = Library.CreatePoint(Pttable.x + 200, Pttable.y - (700 * counter + 530), Pttable.z)
                        Set mtextObj = icadDoc.ModelSpace.AddText(texty(id), Pt1, 300)
                        mtextObj.StyleName = txtStyle
                        mtextObj.Layer = icadDoc.ActiveLayer.Name
                        Set Pt1 = Library.CreatePoint(Pttable.x + 9200, Pttable.y - (700 * counter + 530), Pttable.z)
                        Set mtextObj = icadDoc.ModelSpace.AddText(Format(plochy(id2), "0.00"), Pt1, 300)
                        mtextObj.StyleName = txtStyle
                        mtextObj.Layer = icadDoc.ActiveLayer.Name
                        'mtextObj.HorizontalAlignment = 2
                        mtextObj.TextAlignmentPoint = Pt1
                        counter = counter + 1
                    End If
                Next
            'Application.StatusBar = "Percent completed: " & 100 * (id / UBound(texty)) & " %"
            Next
            
            'MsgBox "Nalezeno uvnitr: " & test
            
            icadDoc.Regen
          
End Sub

---

Soubor ke stažení (zvolte "Uložit jako" pomocí pravého tlačítka myši)