Office: Flächenberechnung des "Shapes" im Excel und Output in Zelle A1

Hallo Zusammen

Ich würde gerne im Excel ein "Shapes.BuildFreeform" zeichnen. Nachdem dieser gezeichnet ist (.ConvertToShape.Select) soll mir in der Zelle $A$1 seine Fläche z.B. in cm2 angegeben werden. Wird die Grösse bzw. die Form von diesem Shape im Nachgang noch manuell verändert, soll mir seine Fläche ebenfalls aktualisiert werden.
Die Idee ist, dass ich die Shapes hier im Excel wie Polygone für Flächenzeichnungen nutze.

Ist es überhaupt möglich Shapes-Flächen im Excel zu berechnen? *rolleyes.gif*
Hat hier jemand schon Erfahrung sammeln können? *rolleyes.gif*

Würde mich über jeden Denkansatz sehr freuen.

LG,
Robert

:)

 

Hallo Robert,

anbei ein Beispiel.




« Gruß Sepp »

 

Danke dir Josef für deinen Vorschlag. *Smilie
Du bist ja echt genial! *wink.gif* Ich wusste gar nicht dass so etwas im Excel überhaupt möglich währe.

Nach einigen Testen ist mir jedoch aufgefallen, dass wenn ich den Shape von seiner Ursprungsstelle auf dem Tabellenblatt verschiebe, das sich auch seine kalkulierte Fläche in $E$1 verändert wird, obwohl ich die eigentliche Shapefläche gar nicht verändere. Auch wird mir die Fläche oft im negativen angezeigt.

Wo könnte hier das Problem liegen? *rolleyes.gif*
Ich muss zugeben, dass ich deinen Code nicht so wirklich verstehe, um es selber beheben zu können.

Würde mich über einen weiteren Tipp sehr freuen.

LG,
Robert

PS: Kann man den Code auch für ".Type = msoShapeRectangle" verwenden. Habe es mit:

PHP:

         If .Type = msoShapeRectangle Then
For lngPoints = 1 To .Nodes.Count
Cells(lngPoints + 1, 1) = lngPoints
Cells(lngPoints + 1, 2) = .Nodes.Item(lngPoints).Points(1, 1) / dblFactor
Cells(lngPoints + 1, 3) = .Nodes.Item(lngPoints).Points(1, 2) / dblFactor
Next
Cells(1, 5).FormulaArray = "=SUM((C2:C" & lngPoints - 1 & "+C3:C" & lngPoints & ")*(B2:B" & lngPoints - 1 & "-B3:B" & lngPoints & ")/2)"
End If


 

Hallo Robert,

das mit der Änderung der Fläche beim Verschieben der Form kann ich beim besten willen nicht nachvollziehen.

Damit der Code auch bei einem Rechteck funktioniert muss man anders vorgehen.

' **********************************************************************
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Sub calculateArea()
Dim objShp As Shape
Dim lngPoints As Long
Dim dblFactor As Double

dblFactor = Application.CentimetersToPoints(1)

Set objShp = Me.Shapes(Application.Caller)

Range("A2:C100") = ""
Range("E1") = ""
With objShp
If .Type = msoFreeform Then
For lngPoints = 1 To .Nodes.Count
Cells(lngPoints + 1, 1) = lngPoints
Cells(lngPoints + 1, 2) = .Nodes.Item(lngPoints).Points(1, 1) / dblFactor
Cells(lngPoints + 1, 3) = .Nodes.Item(lngPoints).Points(1, 2) / dblFactor
Next
ElseIf .Type = msoShapeRectangle Then
Cells(2, 1) = 1: Cells(2, 2) = .Left / dblFactor: Cells(2, 3) = .Top / dblFactor
Cells(3, 1) = 2: Cells(3, 2) = (.Left + .Width) / dblFactor: Cells(3, 3) = .Top / dblFactor
Cells(4, 1) = 3: Cells(4, 2) = (.Left + .Width) / dblFactor: Cells(4, 3) = (.Top + .Height) / dblFactor
Cells(5, 1) = 4: Cells(5, 2) = .Left / dblFactor: Cells(5, 3) = (.Top + .Height) / dblFactor
Cells(6, 1) = 5: Cells(6, 2) = .Left / dblFactor: Cells(6, 3) = .Top / dblFactor
lngPoints = 6
End If
End With
If lngPoints > 0 Then Cells(1, 5).FormulaArray = "=SUM((C2:C" & lngPoints - 1 & "+C3:C" & lngPoints & ")*(B2:B" & lngPoints - 1 & "-B3:B" & lngPoints & ")/2)"
End Sub





« Gruß Sepp »

 

Danke für den Code. *Smilie
Werde es gleich mal ausprobieren.

Frage zu der Flächenveränderung:

Könntest du mir deinen Code erklären? Ich verstehe es leider nicht.
Theoretisch müsste doch die Flächenberechnung im Koordinatensystem (was meiner Meinung das Tabellenblatt im Excel auch darstellt) nach Gaußschen Trapezformel erfolgen.

Im Anhang habe ich eine Excel-Datei zur berechnung der Gaußschen Trapezformel angehängt. Kann man diese Formel in den Code einbauen? *rolleyes.gif*

Würde mich über deine Hilfe sehr freuen.

LG,
Robert

 

... noch eine kleine Anmerkung.

Bei der Verschiebung des Rechtecks, wird die Fläche nicht verändert.*Smilie
Es müsste folglich an der Formel von "Shapes.BuildFreeform" liegen, oder???*rolleyes.gif*

LG,
Robert

 

Hallo Robert,

genau die Formel aus deiner Datei wird auch in meiner Datei in E1 verwendet, allerdings als Matrixformel.

Was du mit "Es müsste folglich an der Formel von "Shapes.BuildFreeform" liegen" meinst, erschließt sch mir nicht.

Anbei noch einmal meine Datei mit verschiedenen Shapes, alle außer dem Rechteck sind FreeForms!
Egal wohin ich die einzelnen Formen verschiebe, die Fläche bleibt immer gleich.


« Gruß Sepp »

 

Hallo Josef

Habe schon einiges selbst probiert, jedoch ohne Erfolg.*frown.gif*

Frage: Kann es daran liegen, dass die Formel für "Freeform" den Anfangspunkt nicht mitberücksichtigt.

Bsp.: Wenn ich ein Rechteck erstelle, werden mir 5 x-y-Punkte gezeigt. Wenn ich aber ein "Freeform" von 7 Punkten erstelle, werden mir nur 7 x-y-Punkte gezeigt. D.h. der erste (beginnende) Punkt wird hier nicht mit berücksichtigt.

Könnte es daran liegen?

Gruss,
Robert

 

Hallo Robert,

wahrscheinlich sind bei deiner Form der erste und der letzte Punkt nicht verbunden. Aber warum lädst du eine rar-Datei mit einem Bild hoch anstatt gleich die Tabelle mit der Form? Dann könnte ich halt gleich am Original schauen, wo das problem liegt.




« Gruß Sepp »

 

... Sorry Josef, habe deine Lösung betr. der Flächenänderung übersehen.

In meiner letzten Anmerkung, ging ich auf die Flächenberechnung ein. Mich wundert es, dass sich die Fläche bei Eingabe derselben x-y-Koordinaten zwischen meiner und deiner Lösung unterscheiden.

Gruss,
Robert

 

... hier die Excel-Dateien mit derselben Fläche.

Gruss,
Robert

 

Hallo Robert,

ich verstehe dein Problem nicht! In deiner Datei habe ich nichts gemacht, außer einmal die Form angeklickt. In E1 erscheint die richtige Fläche.




« Gruß Sepp »

 

Hallo Josef

Wie kann es denn sein. Habe deinen letzten Anhang geöffnet. Dort steht der richtige Flächenwert von 19,4661069.

Wenn ich aber auf die Form klicke wird mir der Wert von 21,9064582 angezeigt.*frown.gif*

Liegt es an irgendeiner Einstellung bei mir oder hängt es mit meinem Excel 2003 zusammen? *rolleyes.gif*

Gruss,
Robert

 

Hallo Robert,

leider habe ich xl2003 nicht mehr, deshalb kann ich es nicht testen, ob es an deiner Version liegt. Probier mal folgenden Code.

' **********************************************************************
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Sub calculateArea()
Dim objShp As Shape
Dim lngPoints As Long
Dim dblFactor As Double

dblFactor = Application.CentimetersToPoints(1)

Set objShp = Me.Shapes(Application.Caller)

Range("A2:C100") = ""
Range("E1") = ""
With objShp
If .Type = msoFreeform Then
For lngPoints = 1 To .Nodes.Count
Cells(lngPoints + 1, 1) = lngPoints
Cells(lngPoints + 1, 2) = .Nodes.Item(lngPoints).Points(1, 1) / dblFactor
Cells(lngPoints + 1, 3) = .Nodes.Item(lngPoints).Points(1, 2) / dblFactor
Next
If Cells(lngPoints, 2) <> Cells(2, 2) And Cells(lngPoints, 3) <> Cells(2, 3) Then
lngPoints = lngPoints + 1
Cells(lngPoints, 1) = lngPoints - 1
Cells(lngPoints, 2) = Cells(2, 2)
Cells(lngPoints, 3) = Cells(2, 3)
End If
ElseIf .Type = msoShapeRectangle Then
Cells(2, 1) = 1: Cells(2, 2) = .Left / dblFactor: Cells(2, 3) = .Top / dblFactor
Cells(3, 1) = 2: Cells(3, 2) = (.Left + .Width) / dblFactor: Cells(3, 3) = .Top / dblFactor
Cells(4, 1) = 3: Cells(4, 2) = (.Left + .Width) / dblFactor: Cells(4, 3) = (.Top + .Height) / dblFactor
Cells(5, 1) = 4: Cells(5, 2) = .Left / dblFactor: Cells(5, 3) = (.Top + .Height) / dblFactor
Cells(6, 1) = 5: Cells(6, 2) = .Left / dblFactor: Cells(6, 3) = .Top / dblFactor
lngPoints = 6
End If
End With
If lngPoints > 0 Then Cells(1, 5).FormulaArray = "=SUM((C2:C" & lngPoints - 1 & "+C3:C" & lngPoints & ")*(B2:B" & lngPoints - 1 & "-B3:B" & lngPoints & ")/2)"
End Sub





« Gruß Sepp »

 

Vielen, vielen Dank jetzt funktioniert es.
Du bis ja echt genial. *Smilie *Smilie *Smilie

Ich würde gerne diesen Code zur Flächenberechnung von Grundstücken verwenden. Dazu gibt es bei mir 4 Flächenarten, die sowohl mit "Freeform" als auch mit "Rectangle" gezeichnet werden sollten.

Ich habe mir überlegt, ob es evtl. möglich währe, mit Klick auf den Button "Neuen Shape" zuerst eine Userform zu öffnen und in der Combobox meine Flächenart, die ich zeichnen möchte zu bestimmen (die dann als Name der Fläche gilt) und anschliessend die Zeichnung meiner Form auszuführen (ohne auf das Menü "Autoformen/Linien/Freihandform" gehen zu müssen) . Nach der Zeichnung soll mir der Fläche der Form in der dafür vorgesehene Zelle automatisch übernommen werden.

Habe meinen Gedankengang in der anbei liegenden Excel-Datei skizziert.
Meinst du es könnte so klappen? *rolleyes.gif*

LG,
Robert