LibreOffice-Forum

Code: Alles auswählen

Sub DrawTouchingCircleSegments()
    ' Zugriff auf die erste Zeichnungsseite
    Dim oDrawPage As Object
    oDrawPage = ThisComponent.DrawPages(0)

    ' Erstellen der ersten Ellipse (erstes Segment)
    Dim oSegment1 As Object
    oSegment1 = oDrawPage.createInstance("com.sun.star.drawing.EllipseShape")
	'oSegment1 = oDrawPage.createInstance("com.sun.star.drawing.Ellipse")

    ' Position und Größe des ersten Segments
    Dim oPosition1 As Object
    oPosition1 = CreateUnoObject("com.sun.star.awt.Point")
    oPosition1.X = 1000   ' X-Position des ersten Kreissegments
    oPosition1.Y = 1000   ' Y-Position des ersten Kreissegments
    oSegment1.Position = oPosition1

    ' Radius des ersten Kreissegments
    oSegment1.Width = 2000   ' Breite des ersten Kreises
    oSegment1.Height = 2000  ' Höhe des ersten Kreises (gleich für einen Kreis)

    ' Optional: Linie und Füllung
    oSegment1.LineColor = RGB(0, 0, 0)  ' Schwarze Linie
    oSegment1.LineWidth = 200            ' Linienstärke
    oSegment1.FillColor = RGB(255, 255, 0)  ' Gelbe Füllung

    ' Das erste Segment zur Zeichnungsseite hinzufügen
    oDrawPage.add(oSegment1)

    ' Erstellen der zweiten Ellipse (zweites Segment)
    Dim oSegment2 As Object
    oSegment2 = oDrawPage.createInstance("com.sun.star.drawing.EllipseShape")

    ' Position und Größe des zweiten Segments
    Dim oPosition2 As Object
    oPosition2 = CreateUnoObject("com.sun.star.awt.Point")
    oPosition2.X = 3000   ' X-Position des zweiten Kreissegments (am Berührungspunkt)
    oPosition2.Y = 1000   ' Y-Position des zweiten Kreissegments
    oSegment2.Position = oPosition2

    ' Radius des zweiten Kreissegments
    oSegment2.Width = 2000   ' Breite des zweiten Kreises
    oSegment2.Height = 2000  ' Höhe des zweiten Kreises (gleich für einen Kreis)

    ' Optional: Linie und Füllung für das zweite Segment
    oSegment2.LineColor = RGB(0, 0, 0)  ' Schwarze Linie
    oSegment2.LineWidth = 200            ' Linienstärke
    oSegment2.FillColor = RGB(0, 255, 0)  ' Grüne Füllung

    ' Das zweite Segment zur Zeichnungsseite hinzufügen
    oDrawPage.add(oSegment2)

    ' Optional: Position des Berührungspunkts anzeigen
    Dim oPoint As Object
    oPoint = CreateUnoObject("com.sun.star.awt.Point")
    oPoint.X = 2000  ' Berührungspunkt X
    oPoint.Y = 1000  ' Berührungspunkt Y
    MsgBox "Die Kreissegmente berühren sich bei: " & oPoint.X & ", " & oPoint.Y
End Sub

Code: Alles auswählen

Sub Zeichne_Kreisboegen
'################################################################
' die Lösung mit der europäischen Alternative LUMO zu Chatgpt
' erstellt.
' von alleine wäre ich nicht so weit gekommen
'################################################################
 
Dim oDoc As Object 
Dim oPage As Object 
Dim nRad As Long
Dim oPos As New com.sun.star.awt.Point
Dim oSize As New com.sun.star.awt.Size 

 oDoc = ThisComponent 
 oPage = oDoc.DrawPages.getByIndex(0) 
 nRad = 3000 
 oSize.Width = nRad * 2 
 oSize.Height = nRad * 2 
 oPos.X = 5000 
 oPos.Y = 5000 
 ErstelleBogen oPage, oPos, oSize, 0, 12000, RGB(0,0,255), 100 
 ErstelleBogen oPage, oPos, oSize, 12000, 24000, RGB(255,0,0), 100 
 End Sub

Private Sub ErstelleBogen(ByRef oPage As Object, ByVal oPos As com.sun.star.awt.Point, ByVal oSize As com.sun.star.awt.Size, ByVal nStart As Long, ByVal nEnd As Long, ByVal nColor As Long, ByVal nWidth As Long) 
Dim oArc As Object 
oArc = ThisComponent.createInstance("com.sun.star.drawing.EllipseShape") 
oArc.Position = oPos 
oArc.Size = oSize 
oArc.CircleKind = com.sun.star.drawing.CircleKind.ARC 
oArc.CircleStartAngle = nStart 
oArc.CircleEndAngle = nEnd 
oArc.LineColor = nColor 
oArc.LineWidth = nWidth 
oPage.add(oArc) 
End Sub