-> ThisDrawing

Option Explicit
Public mystatusmodi As Boolean
Public my1 As AcadObject
Public myid As String
Public myCommand As String
Public myFlaecheneu As Single
Public pt1 As Variant

'---------------------------------------------
Private Sub AcadDocument_BeginCommand(ByVal CommandName As String)
myCommand = CommandName
End Sub
'---------------------------------------------
Private Sub AcadDocument_ObjectModified(ByVal Object As Object)

On Error Resume Next

If myCommand = "GRIP_STRETCH" Or myCommand = "SCALE" Or myCommand = "FILLET" Or myCommand = "CHAMFER" Or myCommand = "STRETCH" Then
'**********************************

'plintype muss auf 1 stehen !!!

'**********************************
Dim myobname As String

Set my1 = Object
myobname = my1.ObjectName

myCommand = ""

If ((myobname = "AcDbPolyline" Or myobname = "AcDb2dPolyline") And my1.Area > 0) Then
mystatusmodi = True
myid = my1.ObjectName
myid = my1.ObjectID
'MsgBox "" & my1.Area
myFlaecheneu = my1.Area
Set my1 = Nothing
Call myUpdate
'Set my1 = Nothing
End If

End If

End Sub

'---------------------------------------------
Private Sub AcadDocument_EndCommand(ByVal CommandName As String)
'Später........ mach was am Ende

If mystatusmodi Then

End If

End Sub

'---------------------------------------------
'ÄnderungsCode##################################

Private Sub myUpdate()
On Error GoTo error:
      Dim ssetObj As AcadSelectionSet
start:
    Set ssetObj = ThisDrawing.SelectionSets.Add("TEST_SSET1")

    ssetObj.SelectOnScreen
      
  
    '######### Text ändern##########
    
    Dim textObj As AcadText
    Dim count2 As Integer
    count2 = ssetObj.Count
    Dim test4
    
    If count2 > 1 Then
    Dim k As Integer
    'Text im SS suchen
    For k = 0 To count2 - 1
    test4 = ssetObj.Item(k).ObjectName
    If ssetObj.Item(k).ObjectName = "AcDbText" Then
    Set textObj = ssetObj.Item(k)
   
    With textObj
    '.height = 0.15
    '.LinetypeScale = 1
    '.width = 1.7
    '.Layer = "Flaeche_Text"
    .TextString = Format(myFlaecheneu, "##,##0.00") & " m2"
    
    .Update
    
    End With
    
    Set textObj = Nothing
    Exit For
   End If
   Next k
   End If
   GoTo ende:
error:

    'wenn SelectionSet vorhanden...
    If Err.Number = "-2145320851" Then
        Set ssetObj = ThisDrawing.SelectionSets.Item(0)
       'dann löschen..
       ssetObj.Delete
       'und Zurück
    GoTo start:
    
   Else
   GoTo ende
   End If
   

ende:
    'SelectionSet löschen
    ssetObj.Delete
    Set ssetObj = Nothing
  
End Sub

'---------------------------------------------
Public Property Get CurrentSpace() As AcadBlock
    If Me.ActiveSpace = acModelSpace Then
        Set CurrentSpace = Me.ModelSpace
    Else
        If Me.MSpace Then
            Set CurrentSpace = Me.ModelSpace
        Else
            Set CurrentSpace = Me.ActiveLayout.Block
        End If
    End If
End Property
'---------------------------------------------
'- Pline zeichnen ----
Sub Line3()
    Dim objTemp As AcadLWPolyline
    Dim varPnt As Variant
    Dim dblTemp(1) As Double
    Dim dblVerts() As Double
    Dim strPrmt As String
    Dim Intcnt As Integer
    Dim pt1 As Variant
    Dim Pt2 As Variant
    Dim PtTemp As Variant
    checklayer ("MyFlaeche")
    On Error GoTo Err_Control
    
    pt1 = ThisDrawing.Utility.GetPoint(, vbCrLf & "Bitte den Startpunkt wählen: ")
    'Pt2 = ThisDrawing.Utility.GetPoint(, vbCrLf & "bis Punkt: ")
    Pt2 = pt1
        ReDim dblVerts(3)
        dblVerts(0) = pt1(0)
        dblVerts(1) = pt1(1)
        dblVerts(2) = Pt2(0)
        dblVerts(3) = Pt2(1)
        
        Set objTemp = ThisDrawing.CurrentSpace.AddLightWeightPolyline(dblVerts)
      Intcnt = 1
    PtTemp = Pt2
    objTemp.Layer = "MyFlaeche"
    On Error GoTo Flaeche
Do
    Intcnt = Intcnt + 1
    varPnt = ThisDrawing.Utility.GetPoint _
                (ThisDrawing.Utility.TranslateCoordinates(PtTemp, acWorld, acUCS, False), _
                vbCrLf & "bis Punkt: ")
    dblTemp(0) = varPnt(0)
    dblTemp(1) = varPnt(1)
    objTemp.AddVertex Intcnt, dblTemp
     
    
    objTemp.color = acYellow
    objTemp.Update
    PtTemp = varPnt
    
Loop
    
Flaeche:
    If Intcnt < 3 Then GoTo Err_Control
    objTemp.Closed = True
    
    objTemp.color = acYellow
    objTemp.Update
    
    Dim Flaeche1 As Double
    
    Flaeche1 = objTemp.Area
    ' nur zwei Kommastellen
    'Flaeche1 = Format(Flaeche1, "0." & String(ThisDrawing.GetVariable("LUPREC"), "0"))
    
    
        
        Flaeche1 = Format(Flaeche1, "##,##0.00")
        
        
         
        objTemp.color = acGreen
        objTemp.Update
        
        MsgBox "Fläche: " & Flaeche1 & " m²", , "GetEntity Example"
 
    Dim textObj As AcadText
    Dim height As Double
    Dim einfuege As Variant
 
    
    
    height = 0.25
     einfuege = ThisDrawing.Utility.GetPoint(, "Bitte den Einfügepunkt wählen")

    Set textObj = ThisDrawing.CurrentSpace.AddText(Flaeche1 & " m2", einfuege, height)
    

    
    
        textObj.color = acGreen
        textObj.Layer = "MyFlaeche"
        textObj.Update
        Err.Clear
        
      '#---------------------------
    
    'Hier Block und Text zu Gruppe zusammenfassen
    
    Dim groupColl As AcadGroups
    Set groupColl = ThisDrawing.Groups
    Dim myGroup As AcadGroup
    Set myGroup = groupColl.Add("Area" & objTemp.ObjectID)
    ReDim appendObjs(0 To 1) As AcadEntity
    'da nur zwei objekte
    
        Set appendObjs(0) = objTemp
        Set appendObjs(1) = textObj
    
    
    myGroup.AppendItems appendObjs
    
    
    
    '#---------------------------
    
    
   
Exit_Here:
Set objTemp = Nothing
Set textObj = Nothing

    Exit Sub
Err_Control:
    ThisDrawing.Utility.Prompt vbCrLf & "Zu wenig Punkte für Flächenberechnung!" & vbCrLf
    Resume Exit_Here
    
End Sub

' ist der richtige layer vorhanden?

Sub checklayer(layername As String)

Dim templayer As String
Dim layerObj As AcadLayer
Dim layervorhanden As Boolean
Dim i As Integer
For i = 0 To ThisDrawing.Layers.Count - 1
templayer = ThisDrawing.Layers.Item(i).Name
If templayer = layername Then
layervorhanden = True
End If
Next i

If layervorhanden = False Then
Set layerObj = ThisDrawing.Layers.Add(layername)
Dim color As AcadAcCmColor
layerObj.color = acGreen
End If

End Sub