Макрос для экспорта всех слайдов презентации как JPG рисунки. РЕШЕНИЕ

Автор serhiy.k, 5 мая 2011, 10:01

0 Пользователи и 1 гость просматривают эту тему.

serhiy.k

Не нашел подходящего макроса, поэтому решил собрать из найденных в интернете примеров.
Тестировал только на windows 7 LibreOffice 3.3.2.
Если у вас не будет замечаний, сделаю расширение.


REM  *****  BASIC  *****
REM This macro was written on a base of examples from OOo forums
REM and Andrew Pitonyak http://www.pitonyak.org/book/
REM  *****  BASIC  *****
Option Explicit

dim doc
dim exportPath
dim exportName
dim slideNum
dim docPath
dim docName
dim ocontrol
dim oFolderPickerDlg
dim cPickedFolder
dim lastPageNumber
dim formatString
dim decimalRep
dim oPropertyValue

Sub ExportAsImage
  SplitSlides
Msgbox "Images exported!"
End Sub

'Splits the current document into one (soon svg) file for each slide
sub SplitSlides
dim i
dim slide


  doc=thiscomponent
  ocontrol=doc.getcurrentcontroller()
'   exportPath = InputBox("Path to export to?")
'   exportPath = SlashTerminateString(exportPath)

DocumentFileNames 'returns current path and the current file name

  exportPath =  PickFolderSpecific ( docPath )
  exportPath = SlashTerminateString(exportPath)
 
'Это удаляет все экземпляры подстроки bad$ из исходной строки s$
'Это изменяет исходную строку s$
'Sub RemoveFromString(s$, bad$)
 Dim n%
 dim bad
 bad = "%20"
 n = InStr(docName, bad)
 Do While n > 0
   Mid(docName, n, Len(bad), " ")
   n = InStr(n, docName, bad)
 Loop
'End Sub

  exportName = InputBox("Пожалуйста, подтвердите или измените основу имени экспортируемых изображений. Числа будут добавлены автоматически:", "Base Name For Exported Images", docName)
 
  lastPageNumber = doc.getdrawpages().count - 1
  formatString = Zeroes(numDigitsIn(lastPageNumber+1)) 'Format string for zero-padding
  for i = 0 to lastPageNumber
     slideNum = Format(i+1, formatString) 'Zero pad slide number
     slide=doc.drawpages(i)
     ocontrol.setCurrentPage(slide)
     'Save it as an SVG.
    ' doc.storeToUrl( ConvertToURL( exportPath + exportName +slideNum+ ".svg" ), _
     '  Array( MakePropertyValue( "FilterName", "impress_svg_Export" ) ) )
     'Save to jpg
     doc.storeToUrl( ConvertToURL( exportPath + exportName + " - " + slideNum + ".jpg" ), _
        Array( MakePropertyValue("FilterName", "impress_jpg_Export") ) )', _
      '  MakePropertyValue( "FilterData", Array(MakePropertyValue( "PageRange", i ))))
  next i
end sub

Function PickFolderSpecific( docPath ) as string
'   oFolderPickerDlg = createUnoService( "com.sun.star.ui.dialogs.OfficeFolderPicker" )
'   oFolderPickerDlg = createUnoService( "com.sun.star.ui.dialogs.FolderPicker" )
  oFolderPickerDlg = createUnoService( "com.sun.star.ui.dialogs.SystemFolderPicker" )
  If Len( docPath ) > 0 Then
     oFolderPickerDlg.setDisplayDirectory( ConvertToURL( docPath ) )  Rem... Broken. Does not work with system folder picker.
  End If

  oFolderPickerDlg.execute()
   
  cPickedFolder = oFolderPickerDlg.getDirectory()
   
     PickFolderSpecific = ConvertFromURL( cPickedFolder )

End Function

Function MakePropertyValue( Optional cName As String, Optional uValue ) As com.sun.star.beans.PropertyValue
  oPropertyValue = createUnoStruct( "com.sun.star.beans.PropertyValue" )
  If Not IsMissing( cName ) Then
     oPropertyValue.Name = cName
  EndIf
  If Not IsMissing( uValue ) Then
     oPropertyValue.Value = uValue
  EndIf
  MakePropertyValue() = oPropertyValue
End Function

'If the original does not end in a forward or backward slash, returns a copy of the
'string that ends in a forward slash.
'Otherwise returns a copy of the string
function SlashTerminateString(orig as String) as String
  dim lastChar as String
  lastChar = Right(orig, 1)
  if lastChar = "/" OR lastChar = "\" then
     SlashTerminateString = orig
  else
     SlashTerminateString = orig & "/"
  end if
end function    

'Returns the minimum number of decimal digits required to represent a given integer
function NumDigitsIn(num as Integer) as Integer
  decimalRep = cstr(num)
  NumDigitsIn = Len(decimalRep)
end function

'Returns the a string consisting of the given number of zeros
function Zeroes(num as Integer) as String
  dim result as String
  dim i as Integer
  result = ""
  for i = 1 to num
     result = result & "0"
  next i
  Zeroes = result
end function

REM Author: Andrew Pitonyak
Sub DocumentFileNames
' Dim Doc
 Dim sDocURL
 Doc = ThisComponent
 If (Not GlobalScope.BasicLibraries.isLibraryLoaded("Tools")) Then
   GlobalScope.BasicLibraries.LoadLibrary("Tools")
 End If
 If (Doc.hasLocation()) Then
   sDocURL = Doc.getURL()
'   Print "Document Directory = " & DirectoryNameoutofPath(sDocURL, "/")
'    Print "Document File Name = " & FileNameoutofPath(sDocURL, "/")
docPath = DirectoryNameoutofPath(sDocURL, "/")
'docName = FileNameoutofPath(sDocURL, "/")
docName = GetFileNameWithoutExtension(sDocUrl, "/")
 End If
End Sub

Рыбка Рио

На Linux этот вариант не работает. Вот такой вроде должен работать и на Windows и на линукс.
REM ***** BASIC *****
REM This macro was written on a base of examples from OOo forums
REM and Andrew Pitonyak http://www.pitonyak.org/book/
REM ***** BASIC *****
Option Explicit

dim doc
dim exportPath
dim exportName
dim slideNum
dim docDir
dim docName
dim ocontrol
dim oFolderPickerDlg
dim cPickedFolder
dim lastPageNumber
dim formatString
dim decimalRep
dim oPropertyValue

Sub ExportAsImage
SplitSlides
End Sub

'Splits the current document into one (soon svg) file for each slide
sub SplitSlides
dim i
dim slide


doc=thiscomponent
ocontrol=doc.getcurrentcontroller()
' exportPath = InputBox("Path to export to?")
' exportPath = SlashTerminateString(exportPath)

DocumentFileNames 'returns current path and the current file name

exportPath = PickFolderSpecific ( docDir )
if exportPath="" then Exit Sub
exportPath = SlashTerminateString(exportPath)

exportName = InputBox("Пожалуйста, подтвердите или измените основу имени экспортируемых изображений. Числа будут добавлены автоматически:", "Base Name For Exported Images", docName)

lastPageNumber = doc.getdrawpages().count - 1
formatString = Zeroes(numDigitsIn(lastPageNumber+1)) 'Format string for zero-padding
for i = 0 to lastPageNumber
slideNum = Format(i+1, formatString) 'Zero pad slide number
slide=doc.drawpages(i)
ocontrol.setCurrentPage(slide)
'Save it as an SVG.
' doc.storeToUrl( ConvertToURL( exportPath + exportName +slideNum+ ".svg" ), _
' Array( MakePropertyValue( "FilterName", "impress_svg_Export" ) ) )
'Save to jpg
doc.storeToUrl( ConvertToURL( exportPath + exportName + " - " + slideNum + ".jpg" ), _
Array( MakePropertyValue("FilterName", "impress_jpg_Export") ) )', _
' MakePropertyValue( "FilterData", Array(MakePropertyValue( "PageRange", i ))))
next i
Msgbox "Images exported!", 64 ,"Info"
end sub

Function PickFolderSpecific( docDir ) as string
oFolderPickerDlg = createUnoService( "com.sun.star.ui.dialogs.OfficeFolderPicker" )
' oFolderPickerDlg = createUnoService( "com.sun.star.ui.dialogs.FolderPicker" )
'oFolderPickerDlg = createUnoService( "com.sun.star.ui.dialogs.SystemFolderPicker" )
If docDir<>"" Then
oFolderPickerDlg.setDisplayDirectory( ConvertToURL(docDir) ) Rem... Broken. Does not work with system folder picker.
End If

oFolderPickerDlg.execute()

cPickedFolder = oFolderPickerDlg.getDirectory()

PickFolderSpecific = ConvertFromURL( cPickedFolder )

End Function

Function MakePropertyValue( Optional cName As String, Optional uValue ) As com.sun.star.beans.PropertyValue
oPropertyValue = createUnoStruct( "com.sun.star.beans.PropertyValue" )
If Not IsMissing( cName ) Then
oPropertyValue.Name = cName
EndIf
If Not IsMissing( uValue ) Then
oPropertyValue.Value = uValue
EndIf
MakePropertyValue() = oPropertyValue
End Function

'If the original does not end in a forward or backward slash, returns a copy of the
'string that ends in a forward slash.
'Otherwise returns a copy of the string
function SlashTerminateString(orig as String) as String
dim lastChar as String
lastChar = Right(orig, 1)
if lastChar = "/" OR lastChar = "\" then
SlashTerminateString = orig
else
SlashTerminateString = orig & "/"
end if
end function

'Returns the minimum number of decimal digits required to represent a given integer
function NumDigitsIn(num as Integer) as Integer
decimalRep = cstr(num)
NumDigitsIn = Len(decimalRep)
end function

'Returns the a string consisting of the given number of zeros
function Zeroes(num as Integer) as String
dim result as String
dim i as Integer
result = ""
for i = 1 to num
result = result & "0"
next i
Zeroes = result
end function

REM Author: Andrew Pitonyak
Sub DocumentFileNames
' Dim Doc
Dim sDocURL
Doc = ThisComponent
If (Not GlobalScope.BasicLibraries.isLibraryLoaded("Tools")) Then
GlobalScope.BasicLibraries.LoadLibrary("Tools")
End If
Dim sDocPath As String
If (Doc.hasLocation()) Then
sDocPath = ConvertFromURL(Doc.URL)
if sDocPath="" then sDocPath=createUnoService("com.sun.star.util.PathSettings").Work
' Print "Document Directory = " & DirectoryNameoutofPath(sDocURL, "/")
' Print "Document File Name = " & FileNameoutofPath(sDocURL, "/")
docDir = DirectoryNameoutofPath(sDocPath, "/")
'docName = FileNameoutofPath(sDocURL, "/")
docName = GetFileNameWithoutExtension(sDocPath, "/")
End If
End Sub
ubuntu 12.04 + LibO3.6.0

Рыбка Рио

Добавить бы туда расширение и размер экспортируемых картинок (и степень сжатия для JPG).
ubuntu 12.04 + LibO3.6.0

Рыбка Рио

Вот подправленный вариант, в котором можно менять фильтр и задавать разрешение, сжатие, палитру и т.д. Диалог сможете сделать?

REM ***** BASIC *****
REM This macro was written on a base of examples from OOo forums
REM and Andrew Pitonyak http://www.pitonyak.org/book/
REM ***** BASIC *****
Option Explicit

dim doc
dim exportPath
dim exportName
dim slideNum
dim docDir
dim docName
dim ocontrol
dim oFolderPickerDlg
dim cPickedFolder
dim lastPageNumber
dim formatString
dim decimalRep
dim oPropertyValue

Sub ExportAsImage
   dim i
   dim slide
      doc=thiscomponent
      ocontrol=doc.getcurrentcontroller()
   '   exportPath = InputBox("Path to export to?")
   
   DocumentFileNames 'returns current path and the current file name
   
      exportPath = PickFolderSpecific ( docDir )
      if exportPath="" then Exit Sub
   
      exportName = InputBox("Пожалуйста, подтвердите или измените основу имени экспортируемых изображений. Числа будут добавлены автоматически:", "Base Name For Exported Images", docName)
      If exportName="" then Exit Sub
      
      lastPageNumber = doc.getdrawpages().count - 1
      formatString = Zeroes(numDigitsIn(lastPageNumber+1)) 'Format string for zero-padding
      for i = 0 to lastPageNumber
         slideNum = Format(i+1, formatString) 'Zero pad slide number
         slide=doc.drawpages(i)
         ExportShape(slide)
      next i
   Msgbox "Images exported!", 64 ,"Info"
end sub

Sub ExportShape(oShape as Any)
Dim Dl As Double
Dl = oShape.Height/oShape.Width
oShape
'http://www.oooforum.org/forum/viewtopic.phtml?t=51021
'inspired by http://codesnippets.services.openoffice.org/Office/Office.GraphicExport.snip

'creating filter data
Dim aFilterData (7) as new com.sun.star.beans.PropertyValue
'properties valid for all filters
aFilterData(0).Name  = "PixelWidth"        '
aFilterData(0).Value = 2000
aFilterData(1).Name  = "PixelHeight"
aFilterData(1).Value = 2000*Dl

'filter data for the image/jpeg MediaType
aFilterData(2).Name  ="Quality"
aFilterData(2).Value = 85 'Quality: 1-100, 100 is best quality / lowest compression
aFilterData(3).Name  ="ColorMode"
aFilterData(3).Value = 0' Color; 1 - Grayscale

'filter data for the image/png MediaType
'aFilterData(2).Name  ="Compression"
'aFilterData(2).Value = 9
'aFilterData(3).Name  ="Interlaced"
'aFilterData(3).Value = 0

'filter data for the image/gif MediaType
'aFilterData(2).Name  ="Translucent"
'aFilterData(2).Value = true
'aFilterData(3).Name  ="Interlaced"
'aFilterData(3).Value = 0

'filter data for the image/bmp MediaType
'aFilterData(2).Name  ="Color"
'aFilterData(2).Value = 7
'aFilterData(3).Name  ="ExportMode"
'aFilterData(3).Value = 0
'aFilterData(4).Name  ="Resolution"
'aFilterData(4).Value = 300
'aFilterData(5).Name  ="RLE_Coding"
'aFilterData(5).Value = true
'aFilterData(6).Name  ="LogicalWidth"
'aFilterData(6).Value = 2000
'aFilterData(7).Name  ="LogicalHeight"
'aFilterData(7).Value = 2000

Dim sFileUrl As String
sFileUrl = ConvertToURL( exportPath + exportName + " - " + slideNum + ".jpg"

Dim aArgs (2) as new com.sun.star.beans.PropertyValue

aArgs(0).Name  = "MediaType"
aArgs(0).Value = "image/jpeg" 'image/gif , image/png ... see http://www.oooforum.org/forum/viewtopic.phtml?t=51021
aArgs(1).Name  = "URL"
aArgs(1).Value = sFileUrl
aArgs(2).Name  = "FilterData"
aArgs(2).Value = aFilterData()

Dim xExporter
xExporter = createUnoService( "com.sun.star.drawing.GraphicExportFilter" )
xExporter.setSourceDocument( oShape )

xExporter.filter( aArgs() )
End Sub

Function PickFolderSpecific( docDir ) as string
   oFolderPickerDlg = createUnoService( "com.sun.star.ui.dialogs.OfficeFolderPicker" )
'   oFolderPickerDlg = createUnoService( "com.sun.star.ui.dialogs.FolderPicker" )
   'oFolderPickerDlg = createUnoService( "com.sun.star.ui.dialogs.SystemFolderPicker" )
   If docDir<>"" Then
      oFolderPickerDlg.setDisplayDirectory( ConvertToURL(docDir) ) Rem... Broken. Does not work with system folder picker.
   End If

   If oFolderPickerDlg.execute()=1 then
      cPickedFolder = oFolderPickerDlg.getDirectory()
      PickFolderSpecific = ConvertFromURL( cPickedFolder )
   Endif
End Function

'Returns the minimum number of decimal digits required to represent a given integer
function NumDigitsIn(num as Integer) as Integer
   decimalRep = cstr(num)
   NumDigitsIn = Len(decimalRep)
end function

'Returns the a string consisting of the given number of zeros
function Zeroes(num as Integer) as String
   dim result as String
   dim i as Integer
   result = ""
   for i = 1 to num
      result = result & "0"
   next i
   Zeroes = result
end function

REM Author: Andrew Pitonyak
Sub DocumentFileNames
   ' Dim Doc
   Dim sDocURL
   Doc = ThisComponent
   If (Not GlobalScope.BasicLibraries.isLibraryLoaded("Tools")) Then
      GlobalScope.BasicLibraries.LoadLibrary("Tools")
   End If
   Dim sDocPath As String
   If (Doc.hasLocation()) Then
      sDocPath = ConvertFromURL(Doc.URL)
      'if sDocPath="" then sDocPath=createUnoService("com.sun.star.util.PathSettings").Work
   '   Print "Document Directory = " & DirectoryNameoutofPath(sDocURL, "/")
   '   Print "Document File Name = " & FileNameoutofPath(sDocURL, "/")
   docDir = DirectoryNameoutofPath(sDocPath, "/")
   'docName = FileNameoutofPath(sDocURL, "/")
   docName = GetFileNameWithoutExtension(sDocPath, "/")
   End If
End Sub


REM Author: Andrew Pitonyak
Sub DocumentFileNames
   ' Dim Doc
   Dim sDocURL
   Doc = ThisComponent
   If (Not GlobalScope.BasicLibraries.isLibraryLoaded("Tools")) Then
      GlobalScope.BasicLibraries.LoadLibrary("Tools")
   End If
   Dim sDocPath As String
   If (Doc.hasLocation()) Then
      sDocPath = ConvertFromURL(Doc.URL)
      Dim sep As String
      sep = getPathSeparator()
      'if sDocPath="" then sDocPath=createUnoService("com.sun.star.util.PathSettings").Work
   '   Print "Document Directory = " & DirectoryNameoutofPath(sDocURL, "/")
   '   Print "Document File Name = " & FileNameoutofPath(sDocURL, "/")
   docDir = DirectoryNameoutofPath(sDocPath, sep)
   'docName = FileNameoutofPath(sDocURL, "/")
   docName = GetFileNameWithoutExtension(sDocPath, sep)
   End If
End Sub
ubuntu 12.04 + LibO3.6.0

serhiy.k

Я попробую сделать диалог. Если будут трудности, спрошу здесь.

serhiy.k

ОБНОВЛЕНО: Все уже работает!!

Внизу есть скрин диалога.

Вот код, что запускает этот диалог. Нижняя часть меняется в зависимости от выбранного типа изображения:

Sub ShowDialog()
    Dim oLibContainer As Object, oLib As Object
     Dim oInputStreamProvider As Object
    Dim oDialog As Object
    Const sLibName = "ExportImages"
     Const sDialogName = "Dialog1"
   
     REM library container
     oLibContainer = DialogLibraries
     REM load the library
     oLibContainer.loadLibrary( sLibName )
     REM get library
     oLib = oLibContainer.getByName( sLibName )
     REM get input stream provider
     oInputStreamProvider = oLib.getByName( sDialogName )
     REM create dialog control
     oDialog = CreateUnoDialog( oInputStreamProvider )
     REM show the dialog
     oDialog.Model.Step = 1

' далее вставляем папку текущего файла  
     dirText = oDialog.Model.getByName("dirTextField")
     oDialog.getControl("dirTextField").setText(docDir)
     
     oDialog.execute()
 End Sub


Перед запуском макроса переменная docDir принимает значение текущей папки документа.

Есть текстовое поле dirTextField и сбоку кнопка к макросу выбора папки. Тот макрос возвращает обновленную переменную docDir и имеет следующий код:

Sub PickFolder
exportPath = PickFolderSpecific ( docDir )

oDialog.getControl("dirTextField").setText(docDir)
'dirText = oDialog.Model.getByName("dirTextField") ' эти две строчки тоже не обновляют текстовое поле dirTextField
'dirText.text = docDir  
End Sub


Функция PickFolderSpecific описана в предыдущих сообщениях.

Проблема теперь в том, что я не могу возвратить значение docDir в текстовое поле dirTextField. То есть, когда я выбрал папку с помощью FolderPicker, текст в текстовом поле не меняется на новый путь, а остается прежний.

Единственное, что я нашел - это вот это сообщение:
http://www.oooforum.org/forum/viewtopic.phtml?t=53092&highlight=dialog+text+field

Но у меня почему-то так не работает  ???

Возможно нужно создать какой-то Listener? Но в этом я сам не могу разобраться. Может кто-то помочь?
[/s]

[вложение удалено Администратором]

serhiy.k

Прошу прощения, все работает.
Я не обновлял переменную docDir.

Рыбка Рио

Sub PickFolder
exportPath = PickFolderSpecific ( docDir )
If exportPath="" then Exit Sub 'если нажали на кнопку "отмена", то ничего не менять
oDialog.getControl("dirTextField").setText(exportPath)
'dirText = oDialog.Model.getByName("dirTextField") ' эти две строчки тоже не обновляют текстовое поле dirTextField
'dirText.text = docDir  
End Sub
?
ubuntu 12.04 + LibO3.6.0

serhiy.k

экспортировал библиотеку пока просто как расширение, не подготовленное для публикации.
Есть следующие проблемы.
1. У меня на Windows 7 не работал макрос DocumentFileNames с переменной sep, только если разделитель указан как "/".
Иначе и в поле папка, и в поле имя файла диалогового окна просто дается по умолчанию полный путь к файлу с именем файла.
2. Если сохраненный файл содержит русские имена в пути или названии, в полях появляется текст вида: %D1%80%D1%83%D1%81%D1%81%D0%BA%D0%B8%D0%B9. Если сам ввожу в эти поля русский текст, тогда он экспортируется нормально.
3. Не добавляется ноль к номеру слайда в имени файла, что необходимо для нормальной сортировки.

Клио, как Вы думаете, что возможно поправить? Сможете ли помочь?

[вложение удалено Администратором]

Рыбка Рио

1) там URL вместо Path, поэтому там и символы кодируются как в HTML
2) следствие из пункта 1
3) formatString должна быть в виде 0#, если к примеру там всего 30 слайдов.

Вот доработанная версия. Там кое-что убрано, отформатировано табуляциями, кнопка Экспорт теперь - это кнопка типа ОК, а кнопка отмена - кнопка типа Отмена (для неё не обязательно название, она автоматически называется), для кнопки OK тоже не обязательно название, но у вас было её дано назание "Экспорт". (Работает на WinXP и на Linux)

[вложение удалено Администратором]
ubuntu 12.04 + LibO3.6.0

serhiy.k

Прилагаю готовое расширение. Как вы думаете, можно публиковать :D ? Проверьте, пожалуйста, на Линуксе.

Только отсюда не устанавливайте на постоянно, так как, думаю, что обновляться на новые версии будет только при установке с официального сайта расширений.

[вложение удалено Администратором]

Рыбка Рио

Цитата: serhiy.k от 12 мая 2011, 20:42Только отсюда не устанавливайте на постоянно, так как, думаю, что обновляться на новые версии будет только при установке с официального сайта расширений.
Нет, будет обновляться, неважно откуда вы скачали расширение. Там есть идентификатор в description.xml vnd.svkppua.exportimages (он должен оставаться неизменным когда вы будете выпускать новую версию, т.к. расширения с разными идентификаторами, даже если они называются одинаково, считаются разными расширениями).
ubuntu 12.04 + LibO3.6.0

Рыбка Рио

У меня есть замечания/предложения, сейчас я их тут пошлю.
1) В Addons.xcu не должно быть ru-RU, а просто ru. Но en-US можно оставить. Из-за этого в 3.3 и 3.4 этот пункт не переводится. См. http://openoffice.org/bugzilla/show_bug.cgi?id=114078
2) В desctiption.xml можно добавить строчку:
   <display-name>

      <name lang="en">Name in English</name>

      <name lang="ru">Название по-русски</name>

   </display-name>
Что бы в менеджере расширений отбражалось локализованное название (иначе будет имя файла)

3) Ошибку выдаёт на строчке oLibContainer.loadLibrary( sLibName )
(видимо Const sLibName = "ExportAsImages" нужно заменить на Const sLibName = "ExportImages")
(у вас наверное установлено две библиотеки ExportAsImages и ExportImages, поэтому ошибки и нет)
ubuntu 12.04 + LibO3.6.0

Рыбка Рио

Ещё одна ошибка
4) Если документ не сохранён, то переменная sep всегда равна ""
Поэтому нужно строчку sep = getPathSeparator() в процедуре DocumentFileNames переместиь в самое начало, т.е.
Sub DocumentFileNames
   Doc = ThisComponent
   sep = getPathSeparator()
   If ...............
ubuntu 12.04 + LibO3.6.0

Рыбка Рио

Ещё кое-что
5) в диалоге на шаге 3 (GIF) не хватает места для всех букв, расширить нужно Label gifILCB. См. снимок.

[вложение удалено Администратором]
ubuntu 12.04 + LibO3.6.0