Area measurement
Posted: Tue Feb 09, 2010 4:28 am
is there a way to draw something and measure:
a) length
b) area
c) angle
thank you very much!
a) length
b) area
c) angle
thank you very much!
User community support forum for Apache OpenOffice, LibreOffice and all the OpenOffice.org derivatives
https://forum.openoffice.org/en/forum/
Code: Select all
Option Explicit
' Copyleft 2019 Lubos Raus
' Procedure is based on https://forum.openoffice.org/en/forum/viewtopic.php?f=11&t=86532
Sub PolygonArea
Dim oDoc As Object, PolyPolygonShape As Object
Dim StartPoint As New com.sun.star.awt.Point
Dim Value as Long, PointsNumber as integer, i as Integer, InputStr as String
oDoc = ThisComponent
If IsNull(oDoc) Then
Exit Sub
EndIf
PolyPolygonShape = MyGetCurrentlySelectedSingleShape(oDoc, False)
If IsNull(PolyPolygonShape) then
exit sub
End if
If PolyPolygonShape.getShapeType() <> "com.sun.star.drawing.PolyPolygonShape" Then
MsgBox "Selected shape is not PolyPolygonShape", 48, "Info"
exit sub
End if
PointsNumber = UBound(PolyPolygonShape.PolyPolygon(0))
Dim Points(PointsNumber) As New com.sun.star.awt.Point
Dim Coordinates(0 to PointsNumber, 0 to 1) as Long
Array(Points()) = PolyPolygonShape.PolyPolygon
For i= 0 to PointsNumber
Coordinates(i,0) = PolyPolygonShape.PolyPolygon(0)(i).x
Coordinates(i,1) = PolyPolygonShape.PolyPolygon(0)(i).y
next i
Dim x(PointsNumber) as Double, y(PointsNumber) as Double, Area as Double
Area = 0
For i= 0 to PointsNumber
x(i) = Coordinates(i,0)/1000
y(i) = Coordinates(i,1)/1000
next i
For i= 0 to PointsNumber-1 ' algortimus based on mathworld.wolfram.com/PolygonArea.html
Area = Area + x(i)*y(i+1)-x(i+1)*y(i) ' (CRC Standard Mathematical Tables and Formulas 33E (2018).pdf pg. 212)
next i
Area = Area/2
MsgBox "Polygon Area is: " & Area & " cm².",0 , "Polygon Area"
End sub
'___________________________________________________________________________________________________________________
'**************************************************************************************
' Next functions based on Danny B's macro collection downloaded from the old oooForum.
' a version of the original code is available from this topic of the AOO forum:
' https://forum.openoffice.org/en/forum/viewtopic.php?f=7&t=15217&start=0
' and on this place:
' http://nab.pcug.org.au/20090204_bas_source/dannyb.bas
'**************************************************************************************
Function MyDrawingGetSelection(ByVal oDrawDocCtrl as object) as object
Dim oSelectedShapes as object
Dim oDrawDocCtrl2 as object
If Not HasUnoInterfaces( oDrawDocCtrl, "com.sun.star.frame.XController" ) Then
'xray oDrawDocCtrl
oDrawDocCtrl2 = MyGetDocumentController( oDrawDocCtrl )
else
oDrawDocCtrl2 = oDrawDocCtrl
EndIf
If IsEmpty( oDrawDocCtrl2.getSelection() ) Then
oSelectedShapes = createUnoService( "com.sun.star.drawing.ShapeCollection" )
else
oSelectedShapes = oDrawDocCtrl2.getSelection()
EndIf
MyDrawingGetSelection() = oSelectedShapes
End Function
'___________________________________________________________________________________________________________________
Function MyGetCurrentlySelectedSingleShape(ByVal oDrawDoc, Optional bSilent ) As Object
Dim oSelectedShapes as object
Dim oSingleSelectedShape as object
If IsMissing( bSilent ) Then
bSilent = False
EndIf
oSelectedShapes = MyDrawingGetSelection(oDrawDoc)
If oSelectedShapes.getCount() <= 0 Then
If Not bSilent Then
MsgBox "There is not object selected", 48, "Info"
Exit Function
EndIf
ElseIf oSelectedShapes.getCount() > 1 Then
If Not bSilent Then
MsgBox "Please select one shape only", 48, "Info"
Exit Function
EndIf
Else
oSingleSelectedShape = oSelectedShapes.getByIndex(0)
myGetCurrentlySelectedSingleShape() = oSingleSelectedShape
EndIf
End Function
'___________________________________________________________________________________________________________________
Function MyGetDocumentController( oDoc As Object ) As Object
Dim oCtrl As Object
If oDoc.supportsService( "com.sun.star.document.OfficeDocument" ) Then
oCtrl = oDoc.getCurrentController()
ElseIf HasUnoInterfaces( oDoc, "com.sun.star.frame.XController" ) Then
oCtrl = oDoc
ElseIf HasUnoInterfaces( oDoc, "com.sun.star.frame.XFrame" ) Then
oFrame = oDoc
oCtrl = oFrame.getController()
Else
MsgBox( "GetDocController called with incorrect parameter." )
EndIf
MyGetDocumentController() = oCtrl
End Function