Help with macro in Draw needed

English
#1

Having done a decent amount of VBA-scripting before I seem to utterly fail using LO macros. I have the simple goal of inserting a series of rectangles into a draw document whose width and length I calculate beforehand. Since there is no recording functionality in LO Draw I tried to make progress by recording in Calc. So I started recording and inserted a shape into a spreadsheet, added some text and change width and length. Now, if I re-run this macro I would expect it to insert another shape into the spreadsheet but it doesn’t. If I run the macro on a Draw document nothing happens as well. Also my Google skills let me down big time on this one.

This is the recording’s output to insert a rectangle

dim document   as object
dim dispatcher as object

document   = ThisComponent.CurrentController.Frame
dispatcher = createUnoService("com.sun.star.frame.DispatchHelper")

dim args1(0) as new com.sun.star.beans.PropertyValue
args1(0).Name = "BasicShapes"
args1(0).Value = "rectangle"

dispatcher.executeDispatch(document, ".uno:BasicShapes", "", 0, args1())

Can anyone point me in the right direction? Are macros inside Draw working at all?

#3

To solve this problem, you need to get the “drawing page” of your document and add new rectangles to it (just create them with createInstance)

Sub Sample
Dim oDrawPage As Variant
Dim i As Long
Dim oNewObj As Variant
Dim aSize As New com.sun.star.awt.Size
Dim aPosition As New com.sun.star.awt.Point
Rem Get Draw Page
	oDrawPage = ThisComponent.getDrawPages().getByIndex(0)
	For i = 1 to 5	
Rem Create new Rectangle
		oNewObj = ThisComponent.createInstance("com.sun.star.drawing.RectangleShape")
Rem Set size, position and color
		aSize.Width = 2000 * i
		aSize.Height = 1000 * i
		oNewObj.setSize(aSize)
		aPosition.X = 2000 * i
		aPosition.Y = 3000 * i
		oNewObj.setPosition(aPosition)
		Select Case i
			Case 1,3
				oNewObj.FillColor = 255 
			Case 2,4
				oNewObj.FillColor = 255 * 255
			Case 5
				oNewObj.FillColor = 255 * 255 * 255
		End Select
Rem Add this new Rectangle to the draw page
		oDrawPage.add(oNewObj)
	Next i
End Sub
#5

Thanks for your example, helped me a lot to understand!

#2

Test this (source: Andrew Pitonyak macro book)

Sub twoRectangles 'put 2 rectangles to the Draw page
        dim oDrawDoc,oPage,oRect1,oRect2,oShapes,oSelect
        oDrawDoc=thisComponent
        oPage=oDrawDoc.getDrawPages().getByIndex(0)

        rem put rectangle 1
        oRect1=oDrawDoc.createInstance("com.sun.star.drawing.RectangleShape")
        oRect1.setPosition(createPoint(1000, 1000))
        oRect1.setSize(createSize(4000, 3000))
        oPage.add(oRect1)

        rem put rectangle2
        oRect2=oDrawDoc.createInstance("com.sun.star.drawing.RectangleShape")
        oRect2.setPosition(createPoint(2000, 1500))
        oRect2.setSize(createSize(5000, 2000))
        oRect2.fillColor=RGB(123,34,78) 'other color
        oPage.add(oRect2)
End Sub

Function CreatePoint(ByVal x As Long,ByVal y As Long) As
com.sun.star.awt.Point
        Dim oPoint
        oPoint=createUnoStruct( "com.sun.star.awt.Point" )
        oPoint.X=x : oPoint.Y=y
        CreatePoint=oPoint
End Function

Function CreateSize(ByVal x As Long,ByVal y As Long) As
com.sun.star.awt.Size
        Dim oSize
        oSize=createUnoStruct( "com.sun.star.awt.Size" )
        oSize.Width=x : oSize.Height=y
        CreateSize=oSize
End Function
#4

Thanks for the swift reply and the mentioning of the macro book!

#6

I took the advice here and tried to take it one step further by drawing polygons. However, it ALWAYS throws a BASIC runtime error. Object variable not set. error on this line:

oShape.PolyPolygon = Array(ecken)

However, the shape is actually drawn but again I fail to understand what could be wrong. The full code:

REM  *****  BASIC  *****

Sub GloKuVielecke

Dim daten(11,2)

daten(0, 0) = "E-Fahrrad" : daten(0, 1) = 1
daten(1, 0) = "Moped" : daten(1, 1) = 4
daten(2, 0) = "Motorrad" : daten(2, 1) = 6
daten(3, 0) = "Kleines E-Auto" : daten(3, 1) = 14
daten(4, 0) = "Kleinwagen" : daten(4, 1) = 12
daten(5, 0) = "Mittelklasse" : daten(5, 1) = 17
daten(6, 0) = "Großer Van, SUV oder großes E-Auto" : daten(6, 1) = 21
daten(7, 0) = "Luxuswagen oder Wohnmobil" : daten(7, 1) = 26
daten(8, 0) = "Wohnwagen oder Motorboot <6m" : daten(8, 1) = 15
daten(9, 0) = "Yacht" : daten(9, 1) = 17
daten(10, 0) = "Privatjet" : daten(10, 1) = 341

Dim oPage     'Page on which to draw
Dim oDrawDoc  'Temporary draw document.
Dim oShape
  
'oDrawDoc = LoadEmptyDocument("sdraw")
'oPage = createDrawPage(oDrawDoc, "GloKu", True)
oPage = ThisComponent.getDrawPages().getByIndex(0)

Dim ecken()

' Anzahl twips pro Zentimeter
einheit% = 1000

For i = LBound(daten()) To UBound(daten())

	' Anzahl Ecken bestimmen
	ecken = Array()
	If daten(i, 1) MOD 10 = 0 OR daten(i, 1) <= 10 Then
		ReDim ecken(4)
	Else
		ReDim ecken(6)
	End If
	
	' 1. Ecke
    ecken(0)=CreatePoint(0, 0)
    
    ' 2. Ecke
    If daten(i, 1) < 10 Then
    	ecken(1)=CreatePoint(daten(i, 1) * einheit%, 0)
    Else
    	ecken(1)=CreatePoint(10 * einheit%, 0)
    End If
    
    ' 3. Ecke
    If daten(i, 1) <= 10 Then
    	ecken(2)=CreatePoint(daten(i, 1) * einheit%, einheit%)
    Else
    	ecken(2)=CreatePoint(10 * einheit%, einheit% * daten(i, 1) \ 10)
    End If
    
    ' 4. Ecke
    If daten(i, 1) <= 10 Then
    	ecken(3)=CreatePoint(0, einheit%)
    Else
    	ecken(3)=CreatePoint(daten(i, 1) MOD 10 * einheit%, einheit% * daten(i, 1) \ 10)
    End If
    
    ' 5. & 6. Ecke
    If daten(i, 1) MOD 10 <> 0 AND daten(i, 1) > 10 Then
    	ecken(4)=CreatePoint(daten(i, 1) MOD 10 * einheit%, einheit% * daten(i, 1) \ 10 + einheit%)
    	ecken(5)=CreatePoint(0, einheit% * daten(i, 1) \ 10 + einheit%)
    End If
    
    oShape = ThisComponent.createInstance("com.sun.star.drawing.PolyPolygonShape")
    oPage.add(oShape)
    oShape.PolyPolygon = Array(ecken)
    oShape.Text = daten(i, 0)
    oShape.LineWidth = 10
    
    ' Position versetzen
	If i MOD 2 = 0 Then
    	oShape.setPosition(CreatePoint(einheit%, i * einheit%))
    Else
    	oShape.setPosition(CreatePoint(einheit% * 11.5, i * einheit%))
    End If
    
Next i

End Sub

Function CreatePoint(ByVal x As Long, ByVal y As Long) As com.sun.star.awt.Point
	Dim oPoint
	oPoint=createUnoStruct( "com.sun.star.awt.Point" )
	oPoint.X=x : oPoint.Y=y
	CreatePoint=oPoint
End Function

I run LibreOffice 7.1.5 on macOS 11.5.1 Big Sur

#7

Solved it myself, the array definition bit me.

#8

This code:

    Dim oPoint
    oPoint=createUnoStruct( "com.sun.star.awt.Point" )

may be simplified to

    Dim oPoint As New com.sun.star.awt.Point

Impressum (Legal Info) | Datenschutzerklärung (Privacy Policy)   Content on this site is licensed under a Creative Commons Attribution Share Alike 3.0 license.