is there a way to draw something and measure:
a) length
b) area
c) angle
thank you very much!
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
Users browsing this forum: No registered users and 2 guests