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

Hallo Robert,

möglich ist das sicher, allerdings eher aufwändig und nicht so einfach umzusetzen. Für eine Forenbeitrag sicher zu umfangreich, also eher etwas für eine Auftragsprogrammierung.




« Gruß Sepp »

 

Hallo Josef

Verstehe. Hast auch recht.
Hast du Lust so etwas im Auftrag zu machen?

Gruß,
Robert

 

Hallo Robert,

Excel/VBA ist mein Hobby nicht mein Beruf.




« Gruß Sepp »

 

Hallo Josef

Ich verstehe, dass meine Problemstellung im Umfang zu Komplex ist, um es in diesem Forum zu beantworten. Ich würde es aber dennoch gerne versuchen. *Smilie

Der Start der Zeichnung eines Freeform.Shapes über ein Button könnte doch so ähnlich funktionieren? oder? *rolleyes.gif*

Sub ShapeZeichnen()

Dim shp As Shape

'Set shp = wkbt_master.Sheets(wsSheet_master.Name).Shapes. _
AddShape(msomsoFreeform)

Set shp = Tabelle1.Shapes.AddShape
With shp
.Name = = UserForm1.ComboBox1.Text
End With

End Sub

Würde mich sehr freuen, wenn du mir noch bei dieser Sache helfen könntest.

LG,
Robert

 

Hallo Robert,

anbei deine angepasste Datei.




« Gruß Sepp »

 

Vielen Dank Josef für deinen Code.

Ist ja super, wie es funktioniert. *Smilie

Habe es soeben getestet. Mir ist aber aufgefallen, dass beim Einfügen eines "Freeforms" dieser nicht mehr verändert werden kann. D.h. es wird mir hier ein Rechteck mit abgerundeten Ecken eingefügt und keine "Freeform".

Wenn ich deinen Code ansehe ...

PHP:

         Private Sub CommandButton1_Click()
Dim objShp As Shape
Dim lngShapeType As Long

If ComboBox1.ListIndex > -1 Then
If OptionButton1 Then
lngShapeType = msoShapeRectangle
Else
lngShapeType = msoFreeform
End If
With ActiveSheet
Set objShp = .Shapes.AddShape(lngShapeType, .Range("F3").Left, .Range("F3").Top, 50, 50)
End With
With objShp
.Fill.ForeColor.RGB = Choose(ComboBox1.ListIndex + 1, 52377, 10079487, 52479, 12632256)
.Line.ForeColor.RGB = vbBlack
.Line.Weight = 0.25
.Name = ComboBox1.Text
.OnAction = "Tabelle1.calculateArea"
End With
Unload Me
Else
MsgBox "Keine Grundstücksart gewählt!", vbExclamation, "Hinweis"
End If
End Sub


 

Hallo Robert,

die Freihandform kannst du schon verändern (Rechtsklick > Punkte bearbeiten) du kannst auch Punkte hinzufügen/löschen.

Das was du willst, kann so nicht funktionieren.




« Gruß Sepp »

 

Hallo Josef

Mit Excel 2003 geht eine solche Einstellung leider nicht. *frown.gif*

Gibt es denn wirklich keine Möglichkeiten mehr?

Gruss,
Robert

 

Hallo Robert,

leider, keine weiteren Ideen.




« Gruß Sepp »

 

Hallo Josef

Habe im Netz noch einen Code gefunden, mit dem man angeblich die Punkte löschen und verändern kann. Leider verstehe ich diesen nicht wirklich.

PHP:

         Option Explicit
Sub Test()
Dim varArr As Variant
varArr = Tabelle1.Shapes(1).Nodes.Item(1).Points
Debug.Print varArr(1, 1)
Debug.Print varArr(1, 2)
Stop
Tabelle1.Shapes(1).Nodes.SetPosition 1, 200.5, 300.4
varArr = Tabelle1.Shapes(1).Nodes.Item(1).Points
Debug.Print varArr(1, 1)
Debug.Print varArr(1, 2)
Stop
End Sub
Sub Zeig()
Dim shpShape As Shape
For Each shpShape In ActiveSheet.Shapes
Stop
Next shpShape
End Sub


 

Hallo Josef

Ich muss mich korregieren. Es funktioniert auch in Excel 2003. Die Voraussetzung ist, dass es sich hier auch um eine Freihandform handelt.

Mit deinem Code wird mir aber nicht die Freihandform erzeugt, sondern ein Rechteck mit abgerundeten Ecken bei dem auch die Eigenschaft "Punkte bearbeiten" fehlt.

Wenn ich manuell eine Freihandform erstelle, kann ich die Punkte wohl bearbeiten und neue hinzufügen.

Frage: kann man in deinem Code als Vorlage vorgeben, dass bei der Auswahl der Freihandform mir eine mit 5 Punkten erzeugt wird, die ich dann auch verändern kann?

Gruss,
Robert

 

Habe es soeben selber hinbekommen.

PHP:

         Option Explicit

Private Sub CommandButton1_Click()
Dim objShp As Shape
Dim lngShapeType As Long

If ComboBox1.ListIndex > -1 Then
If OptionButton1 Then
lngShapeType = msoShapeRectangle

With ActiveSheet
Set objShp = .Shapes.AddShape(lngShapeType, .Range("F3").Left, .Range("F3").Top, 50, 50)
End With

Else
lngShapeType = msoFreeform

With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, 427.5, 424.5)
.AddNodes msoSegmentLine, msoEditingAuto, 540.75, 468.75
.AddNodes msoSegmentLine, msoEditingAuto, 441.75, 528.75
.AddNodes msoSegmentLine, msoEditingAuto, 417.75, 468#
.AddNodes msoSegmentLine, msoEditingAuto, 427.5, 424.5
.ConvertToShape.Select
End With

End If
With objShp
.Fill.ForeColor.RGB = Choose(ComboBox1.ListIndex + 1, 52377, 10079487, 52479, 12632256)
.Line.ForeColor.RGB = vbBlack
.Line.Weight = 0.25
.Name = ComboBox1.Text
.OnAction = "Tabelle1.calculateArea"
End With

Unload Me
Else
MsgBox "Keine Grundstücksart gewählt!", vbExclamation, "Hinweis"
End If
End Sub


 

Hallo Robert,

ersetze den Code von CommandButton1_Click durch folgenden.

Private Sub CommandButton1_Click()
Dim objShp As Object


If ComboBox1.ListIndex > -1 Then
If OptionButton1 Then
Set objShp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, Range("F3").Left, Range("F3").Top, 50, 50)
Else
Set objShp = ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, Range("F3").Left, Range("F3").Top)
With objShp
.AddNodes msoSegmentLine, msoEditingAuto, Range("F3").Left + 50, Range("F3").Top
.AddNodes msoSegmentLine, msoEditingAuto, Range("F3").Left + 75, Range("F3").Top + 35
.AddNodes msoSegmentLine, msoEditingAuto, Range("F3").Left + 50, Range("F3").Top + 70
.AddNodes msoSegmentLine, msoEditingAuto, Range("F3").Left, Range("F3").Top + 35
.AddNodes msoSegmentLine, msoEditingAuto, Range("F3").Left, Range("F3").Top
Set objShp = .ConvertToShape
End With
End If

With objShp
.Fill.ForeColor.RGB = Choose(ComboBox1.ListIndex + 1, 52377, 10079487, 52479, 12632256)
.Line.ForeColor.RGB = vbBlack
.Line.Weight = 0.25
.Name = ComboBox1.Text
.OnAction = "Tabelle1.calculateArea"
End With
Unload Me
Else
MsgBox "Keine Grundstücksart gewählt!", vbExclamation, "Hinweis"
End If
End Sub





« Gruß Sepp »

 

Danke, Danke, Danke. Jetzt funktioniert es. *Smilie

Alleine währe ich nie drauf gekommen.

Noch eine letzte Frage, dann ist es wirklich Schluss. *rolleyes.gif*

Kann man die Flächenberechnung den 4 Flächenarten zuordnen, so dass mir die Flächen je Art in den Zellen $O$3, $O$5, $O$7, $O$9 angezeigt werden?

Momentan wird mir die selektierte Fläche in der Zelle $O$3 angezeigt und je nach Auswahl der Fläche wieder überschrieben.

Gruss,
Robert

 

Hallo Robert,

kein Problem, habe es so gelöst, dass alle Flächen berechnet werden und von gleichen Flächen gleich die Summe gebildet wird.




« Gruß Sepp »