---

hallo zusammen,

ich möchte mir zwecks Flächenberechnung mit hilfe der polyline z.b. die raumbegrenzung abfahren.
und mit plineobj.area die fläche auslesen.

ich hab nun ein problem, ich krieg es nicht gebacken das folgende programm auf die polyline umzustellen, da ich mit der normalen line keine fläche erzeugen kann.

Sub Line1()
    Dim plineObj As AcadLine
    Dim einfuege1 As Variant
    Dim einfuege2 As Variant
    On Error Resume Next
    einfuege1 = ThisDrawing.Utility.GetPoint(, "Bitte den Startpunkt wählen")
    Do While Err = 0

    einfuege2 = ThisDrawing.Utility.GetPoint(, "bis Punkt")
    Set plineObj = ThisDrawing.ModelSpace.AddLine(einfuege1, einfuege2)
    einfuege1 = einfuege2
  Loop
'plineObj.Closed = True      ' Close Polyline
'FLAECHE1 = plineObj.area
End Sub

so in etwa

thx 4 help
Olli

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

vermute mal ganz stark, dein problem liegt in der dimensionierung. wenn du ne polylinie willst, mußt du sie auch so dimensionieren.

>>>>>>> Dim plineObj As AcadPolyline

Sub Line1()
    Dim plineObj As AcadPolyline '<<<<<<<<<<<<<<<
    Dim einfuege1 As Variant
    Dim einfuege2 As Variant
    On Error Resume Next
    einfuege1 = ThisDrawing.Utility.GetPoint(, "Bitte den Startpunkt wählen")
    Do While Err = 0

    einfuege2 = ThisDrawing.Utility.GetPoint(, "bis Punkt")
    Set plineObj = ThisDrawing.ModelSpace.AddLine(einfuege1, einfuege2)
    einfuege1 = einfuege2
  Loop
'plineObj.Closed = True      ' Close Polyline
'FLAECHE1 = plineObj.area
End Sub

aaaaaber...warum benutzt du nicht den befehl <zeichnen> <umgrenzung>
bzw. _boundary ?

------------------

Bernd

[Diese Nachricht wurde von BerndE am 15. September 2003 editiert.]

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo Oli,
schau dir das einmal an.
http://www.vbdesign.net/modules.php?s=&name=Code_Trout&cats=15&view=160
Ich denke, so etwas brauchst du. Kannst vielleicht nicht eins zu eins übernehmen, aber fast.

------------------
Roland

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Vielleicht folgendermaßen für eine 2D-Polylinie:

Public Sub Sample_AddPolyline()
Dim New2DP As AcadPolyline
Dim PtnMatrix(5) As Double, Prompt As String
Dim LastPnt(2) As Double, VarPoints, PlHeight As Double
On Local Error Resume Next
Prompt = "Geben Sie die Höhe der 2D-Polylinie an:"
PlHeight = ThisDrawing.Utility.GetReal(Prompt)
Prompt = "erster Punkt der 2D-Polylinie:"
x = 0
Do
  varPoint = Empty
  If x = 0 Then
      varPoint = ThisDrawing.Utility.GetPoint(, Prompt)
      If IsEmpty(varPoint) = True Then Exit Do
      PtnMatrix(0) = varPoint(0)
      PtnMatrix(1) = varPoint(1)
      PtnMatrix(2) = 0
      x = 3
      Prompt = "nächster Punkt der 2D-Polylinie:"
  ElseIf x = 3 Then
      varPoint = ThisDrawing.Utility.GetPoint(LastPnt, Prompt)
      If IsEmpty(varPoint) = True Then Exit Do
      PtnMatrix(3) = varPoint(0)
      PtnMatrix(4) = varPoint(1)
      PtnMatrix(5) = 0
      Set New2DP = ThisDrawing.ModelSpace.AddPolyline(PtnMatrix)
      New2DP.Elevation = PlHeight
      x = 6
  Else
      varPoint = ThisDrawing.Utility.GetPoint(LastPnt, Prompt)
      If IsEmpty(varPoint) = True Then Exit Do
      varPoint(2) = 0
      New2DP.AppendVertex varPoint
  End If
  LastPnt(0) = varPoint(0)
  LastPnt(1) = varPoint(1)
  LastPnt(2) = varPoint(2)
Loop
New2DP.Closed = True
MsgBox "Fläche: " & CStr(New2DP.Area)
End Sub

oder für eine optimierte Polylinie:

Public Sub Sample_AddLWPolyline()
Dim NewLWP As AcadLWPolyline, NewPoint(1) As Double
Dim PtnMatrix(3) As Double, Prompt As String
Dim LastPnt(2) As Double, VarPoints, PlHeight As Double
On Local Error Resume Next
Prompt = "Geben Sie die Höhe der LW-Polylinie an:"
PlHeight = ThisDrawing.Utility.GetReal(Prompt)
Prompt = "erster Punkt der LW-Polylinie:"
x = 0
Do
  varPoint = Empty
  If x = 0 Then
      varPoint = ThisDrawing.Utility.GetPoint(, Prompt)
      If IsEmpty(varPoint) = True Then Exit Do
      PtnMatrix(0) = varPoint(0)
      PtnMatrix(1) = varPoint(1)
      x = 2
      Prompt = "nächster Punkt der 2D-Polylinie:"
  ElseIf x = 2 Then
      varPoint = ThisDrawing.Utility.GetPoint(LastPnt, Prompt)
      If IsEmpty(varPoint) = True Then Exit Do
      PtnMatrix(2) = varPoint(0)
      PtnMatrix(3) = varPoint(1)
      Set NewLWP = ThisDrawing.ModelSpace. _
        AddLightWeightPolyline(PtnMatrix)
      NewLWP.Elevation = PlHeight
      x = 4
  Else
      varPoint = ThisDrawing.Utility.GetPoint(LastPnt, Prompt)
      If IsEmpty(varPoint) = True Then Exit Do
      NewPoint(0) = varPoint(0)
      NewPoint(1) = varPoint(1)
      NewLWP.AddVertex (UBound(NewLWP.Coordinates) + 1) / 2, _
        NewPoint
  End If
  LastPnt(0) = varPoint(0)
  LastPnt(1) = varPoint(1)
  LastPnt(2) = varPoint(2)
Loop
NewLWP.Closed = True
MsgBox "Fläche: " & CStr(NewLWP.Area)
End Sub

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Danke für die Antworten, haben mir sehr geholfen.

Für die, die es interessiert :

Sub Line2()
    Dim objTemp As AcadLWPolyline
    'Dim objTemp As AcadPolyline
    Dim varPnt As Variant
    Dim dblTemp(1) As Double
    Dim dblVerts() As Double
    Dim strPrmt As String
    Dim Intcnt As Integer

    On Error Resume Next
    pt1 = ThisDrawing.Utility.GetPoint(, "Bitte den Startpunkt wählen")
    pt2 = ThisDrawing.Utility.GetPoint(, "bis Punkt")
        ReDim dblVerts(3)
        dblVerts(0) = pt1(0)
        dblVerts(1) = pt1(1)
        dblVerts(2) = pt2(0)
        dblVerts(3) = pt2(1)
       
        Set objTemp = ThisDrawing.ModelSpace.AddLightWeightPolyline(dblVerts)
      Intcnt = 1
Do While Err = 0
    Intcnt = Intcnt + 1
    varPnt = ThisDrawing.Utility.GetPoint(, "bis Punkt")
    dblTemp(0) = varPnt(0)
    dblTemp(1) = varPnt(1)
    objTemp.AddVertex Intcnt, dblTemp
    objTemp.Update
 
Loop

    objTemp.Closed = True
    objTemp.Update

End Sub

tschau Olli

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

oh, jetzt hab ich doch glatt die Fläche vergessen:

        Dim Flaeche1 As Double
       
        Flaeche1 = objTemp.Area
        ' nur zwei Kommastellen
        Flaeche1 = Round(Flaeche1, 2)

so jetzt ;-)

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo Olli,
ich hab es ein wenig geändert.

Code:

---

Sub Line2()
    Dim objTemp As AcadLWPolyline
    'Dim objTemp As AcadPolyline
    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

    On Error GoTo Err_Control
    Pt1 = ThisDrawing.Utility.GetPoint(, vbCrLf & "Bitte den Startpunkt wählen: ")
    Pt2 = ThisDrawing.Utility.GetPoint(, vbCrLf & "bis Punkt: ")
        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
    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.Update
    PtTemp = varPnt
   
Loop
   
Flaeche:
    If Intcnt < 3 Then GoTo Err_Control
    objTemp.Closed = True
    objTemp.Update
   
    Dim Flaeche1 As Double
   
    Flaeche1 = objTemp.Area
    ' nur zwei Kommastellen
    Flaeche1 = Format(Flaeche1, "0." & String(ThisDrawing.GetVariable("LUPREC"), "0"))
   
    ThisDrawing.Utility.Prompt vbCrLf & "Fläche: " & Flaeche1 & vbCrLf
Exit_Here:
    Exit Sub
Err_Control:
    ThisDrawing.Utility.Prompt vbCrLf & "Zu wenig Punkte für Flächenberechnung!" & vbCrLf
    Resume Exit_Here
   
End Sub

---

Weiters brauchst du folgende Funktion unter ThisDrawing

Code:

---

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

---

------------------
Roland

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Das ist genau das Richtige, Danke

Habs aber noch ein bisschen abgeändert, man kann jetzt vom startpunkt aus die Polyline ziehen und am ende nen text mit der fläche setzen:
--------
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
---------
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
    On Error GoTo Err_Control
    Pt1 = ThisDrawing.Utility.GetPoint(, vbCrLf & "Bitte den Startpunkt wählen: ")
    '-->
    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
    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.Update
    PtTemp = varPnt
   
Loop
   
Flaeche:
    If Intcnt < 3 Then GoTo Err_Control
    objTemp.Closed = True
    objTemp.Update
   
    Dim Flaeche1 As Double
   
    Flaeche1 = objTemp.Area
    Flaeche1 = Format(Flaeche1, "##,##0.00")
 
        objTemp.Color = acYellow
        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)
   
       
        objTemp.Color = acByLayer
        objTemp.Update
        Err.Clear
Exit_Here:
    Exit Sub
Err_Control:
    ThisDrawing.Utility.Prompt vbCrLf & "Zu wenig Punkte für Flächenberechnung!" & vbCrLf
    Resume Exit_Here
End Sub

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP