Копирование 3D-объектов в DRAW

[vla.dik]

Добрый день!
Такой вопрос: можно ли программно не при помощи буфера обмена копировать 3-D объекты в DRAW?
У меня получилось копировать только с помощью DispatchHelper командами ".uno:Copy" и ".uno:Paste".
Но они работают достаточно медленно.

Вот код:

Код Выделить Развернуть


Sub Main
Dim Point As New com.sun.star.awt.Point
Dim MaxY

Ticks = GetSystemTicks()

Doc = ThisComponent

Point.x = 500
Point.y = 500
MaxY = 500

dispatcher = createUnoService("com.sun.star.frame.DispatchHelper")

NewDoc = StarDesktop.loadComponentFromURL("private:factory/sdraw" ,"_blank", 0, Array())
NewDoc.CurrentController.CurrentPage.BorderLeft = 500
NewDoc.CurrentController.CurrentPage.BorderRight = 500
NewDoc.CurrentController.CurrentPage.BorderTop = 500
NewDoc.CurrentController.CurrentPage.BorderBottom = 500

for p = 0 to ThisComponent.DrawPages.Count - 1
Page = Doc.DrawPages(p)
for e = 0 to Page.Count - 1
Elem = Page(e)
if Elem.UINamePlural = "Трёхмерные сцены" then
for b = 0 to Elem.Count - 1
Shape = Elem(b)
Doc.CurrentController.Select(Shape)
If Point.x > 500 Then
If Point.x + Shape.Size.Width + 500 > NewDoc.CurrentController.CurrentPage.Width Then
Point.x = 500
If MaxY + Shape.Size.Height > NewDoc.CurrentController.CurrentPage.Height Then
NewPage = NewDoc.DrawPages.insertNewByIndex(NewDoc.DrawPages.Count)
NewDoc.CurrentController.setCurrentPage(NewPage)
Point.y = 500
MaxY = 500
Else
Point.y = MaxY
End If
End If
End If
Wait 100 ' Без паузы LibreOffice зависает
dispatcher.executeDispatch(Doc.CurrentController.Frame, ".uno:Copy", "", 0, Array())
dispatcher.executeDispatch(NewDoc.CurrentController.Frame, ".uno:Paste", "", 0, Array())
NewShape = NewDoc.CurrentController.GetSelection(0).GetByIndex(0)
NewShape.Position = Point
Point.x = Point.x + Shape.Size.Width + 500
NewPosY = Point.y + Shape.Size.Height + 500
If NewPosY > MaxY Then
MaxY = NewPosY
End If
next b
end if
next e
next p

MsgBox("Закончили: " & (GetSystemTicks() - Ticks) / 1000)

End Sub


Файл примера во вложении.
Спасибо.

[vla.dik]

Добрый день!
Я почему спрашиваю насчет копирования объектов не через буфер обмена - в DRAW есть пункт меню "Правка" - "Размножить" ("Edit" - "Duplicate") - вызывается комбинацией <Shift+F3>.
Вот эта команда быстро работает - пробовал делать 100 копий, очень быстро сделались.
Есть ли возможность вызвать эту команду программно из LibreOffice Basic?
Никто не знает?
Заранее спасибо.

[bigor]

Подниму вопрос.

Можно ли с помощью макроса копировать объекты Draw в другой документ.
(без DispatchHelper)?

Вдруг за 3 года чего изменилось

[Kadet]

Сам искал ответ. В инете не нашёл.
Пришлось искать эмпирическим методом, т.е. проб и ошибок.
Получилось нечто подобное. На 3D-моделях пока не экспериментировал.
Макросы тестовые и заточены под конкретные задачи теста.

Код Выделить Развернуть

Sub Main
Dim oDoc as Object, oSheet as Object, oDrawPage as Object, oGroup as Object, oElem as Object, CopyElem as Object
Dim i%, Xpoz&, Ypoz&, Xsm&, Ysm&, arName(0) as String
Dim aPosition As New com.sun.star.awt.Point
Dim TheSize As New com.sun.star.awt.Size
'*****************************************
oDoc = ThisComponent
oSheet = oDoc.sheets(0)
oDrawPage = oDoc.DrawPages(0)
'*****************************************
arName(0) = "Группа"
CleanDrow(oDrawPage, arName)
oGroup = funDrawGroup(oDoc, "Группа")
'*****************************************
For i=0 To oDrawPage.Count-1
oElem = oDrawPage.getByIndex(i)
If oElem.ShapeType="com.sun.star.drawing.CustomShape" OR oElem.ShapeType="com.sun.star.drawing.LineShape" Then
CopyElem = CopyElement(oDoc, oElem)
oGroup.add(CopyElem)
TheSize.width = oElem.Size.width
TheSize.height = oElem.Size.height
CopyElem.setSize(TheSize)
aPosition.X = oElem.Position.X-8500
aPosition.Y = oElem.Position.Y
CopyElem.setPosition(aPosition)
End If
Next
'*****************************************
Xpoz = oGroup.Position.X
Ypoz = oGroup.Position.Y
CopyElem = CopyElement(oDoc, oGroup)
'*****************************************
aPosition.X = Xpoz
aPosition.Y = Ypoz+8500
CopyElem.setPosition(aPosition)
'*****************************************
End Sub



'***********************************************************************************************
Function CopyElement(xDoc, xElem) as Object
Dim CElem as Object, CopyElem as Object, oSheet as Object, oDrawPage as Object
'*****************************************
oSheet = xDoc.sheets(0)
oDrawPage = xDoc.DrawPages(0)
'*****************************************
Deselected(xDoc)
'*****************************************
xDoc.CurrentController.select(xElem)
CElem = xDoc.CurrentController.getTransferable()
'*****************************************
' oRange = oSheet.getCellRangeByName("B10")
' xDoc.CurrentController.select(oRange)
xDoc.CurrentController.insertTransferable(CElem)
'*****************************************
CopyElem = oDrawPage.getByIndex(oDrawPage.Count-1)
'*****************************************
CopyElement = CopyElem
'*****************************************
End Function

Некоторые используемые процедуры и функции есть во вложенном документе.

В общем, может кому полезно будет. Пригодится.

Тут набор макросов которые копируют (клонируют) DRAW-объекты. Объединяют их в группы (функция "сгруппировать").
Кстати, сами группы можно так же копировать (клонировать).
Копировать (клонировать) можно и в этот самый документ и любой другой, в том числе Draw и Write.