Копирование модулей макросов в LibreOffice

[timal1234]

Попробую

заменил :

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

Dim oDocDestination As Object
oDocDestination = starDeskTop.loadComponentFromURL(oURL, "_blank", 0, Array() ) 'файл куда копироватьна :

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

                Dim oDocDestination As Object
Dim oProp(0) As New com.sun.star.beans.PropertyValue
oProp(0).Name = "MacroExecutionMode"
oProp(0).Value = com.sun.star.document.MacroExecMode.NEVER_EXECUTE 'Определяет политику выполнения макросов, шоб не ругался
oDocDestination = StarDesktop.loadComponentFromURL(oURL, "_blank", 0, oProp() )  'открываем файлик
теперь первый из указанных файлов открывает без запроса, на втором опять запрос, и дальше ошибка....
ругается на :

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

oDocDestination = StarDesktop.loadComponentFromURL(oURL, "_blank", 0, oProp() )  'открываем файликчто не так?

[timal1234]

что не так?

походу понял в чём ошибка:

заменил внутри

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

FOR w = 0 to UBound(Selected_Files_Arr)
        ...
        NEXT w
все

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

Dim на

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

ReDim
Похоже что работает.
Спасибо!

[timal1234]

Макрос получился такой....
Теперь при открытии файлов назначения не появляется запрос ( включить или отключить макросы), установлено значение "NEVER_EXECUTE".
Скорость выполнения соответственно увеличилась 

"MyInfoBar" убрал, т.к. её видно только до момента открытия первого из указанноых файлов ...
да ещё и бывают глюки....
например, если после выполнения этого (предыдущего) макроса открыть и сохранить другой файл, в статус-баре внизу слева появляется надпись "Выполняется макрос", хотя ничего сейчас не выполняется....
Разбираться пока некогда.... да и нет в ней надобности для меня в этом макросе.

Всем СПАСИБО!!!

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

'===================================================================
REM  ***** Copy_Library (Копирование библиотек) *****
'==================================================================
Sub Copy_Library

rem ----------------------------------------------------------------------
' define variables
dim document   as object
dim dispatcher as object
rem ----------------------------------------------------------------------
' get access to the document
document   = ThisComponent.CurrentController.Frame
dispatcher = createUnoService("com.sun.star.frame.DispatchHelper")


if MsgBox ("Выполнить копирование макросов из этого файла?", 4+128+32, "Начало") = 7 then
Exit Sub 'если нажата кнопка НЕТ (=7) то выход из макроса
end if


'-------------------------------------------------------------------------------------------
Dim oSheetMacrosRun As Object 'лист, с  которого запустили макрос
oSheetMacrosRun = ThisComponent.CurrentController.ActiveSheet

Dim SheetMacrosRun_Name ' имя листа, с которого запустили макрос
SheetMacrosRun_Name = oSheetMacrosRun.Name

Dim oSheets As Variant
Dim oSheet As Variant
oSheets = ThisComponent.getSheets()

Dim MacrosSheet As Variant ' лист с кнопкой выполнения макроса
MacrosSheet = ThisComponent.Sheets.GetByName(SheetMacrosRun_Name) 'лист с кнопкой макроса
'------------------------------------------------------------------------------------------

Dim SrcLibName ' имя исходной библиотеки, содержащейся в oSourceLibs
Dim DestLibName 'имя целевой библиотеки, содержащейся в oDestinationLibs

Dim oSourceLibs ' объект контейнер исходной библиотеки
oSourceLibs = ThisComponent.BasicLibraries

' ----- получаем имена библиотек источника -------------------
Dim libName As String    ' имя библиотеки
Dim oLib ' объект для библитотеки
Dim SourceLibs_Arr()  ' массив библиотек источника

i = 0

For Each libName In oSourceLibs.elementNames
oSourceLibs.loadLibrary(libName)
oLib = oSourceLibs.getByName(libName)
ReDim Preserve SourceLibs_Arr(0 to i)
SourceLibs_Arr(i) = libName
i = i + 1
Next libName


SrcLibName = InputBox( "Укажите имя копируемой библиотеки:" _
+ CHR(13) + CHR(13) _
+ Join(SourceLibs_Arr(), CHR(13) ) _
, "Начало", _
libName _
) 'ввести имя библиотеки для копирования

IF SrcLibName = "" or IsNull(SrcLibName) or IsEmpty(SrcLibName) THEN
MsgBox("Пустое имя библиотеки !" & CHR(13) & "Выход из макроса.")
Exit Sub
END IF

IF oSourceLibs.hasByName(SrcLibName) = FALSE THEN
MsgBox("Нет такой библиотеки !" & CHR(13) & SrcLibName & CHR(13) & "Выход из макроса.")
Exit Sub
END IF

DestLibName = SrcLibName
'-------------------------------------------------------


Dim Selected_Files_Arr()
'--------------------------------------------------------------------------------------------------------
' ------ вызываем диалог открытия файла   -----------
GET_FILES(Selected_Files_Arr() ) ' возвращает пути к выбранным файлам в формате URL
'---------------------------------------------------------------------------------
'--------------------------------------------------------------------------------------------------------

Dim oURL 'путь к файлу


IF UBound(Selected_Files_Arr) >= 0 THEN

FOR w = 0 to UBound(Selected_Files_Arr)

oURL = Selected_Files_Arr(w)


If oURL = "" or IsNull(oURL) or IsEmpty(oURL) then
MsgBox("Пустой путь !" & CHR(13) & "Выход из макроса.")
Exit Sub
end if

'------------------------------------------------------------------------------
' ---------------   открываем файл по URL ------------------
'StarDesktop.loadComponentFromURL(URL, Frame, SearchFlags, FileProperties)
ReDim oDocDestination As Object

'-----------------
'Открываешь документ с помощью .loadComponentFromURL()?
'У него четыре параметра. Последний - массив структур типа com.sun.star.beans.PropertyValue
'Чтобы управлять макросами открываемого документа, нужно в этот массив вставить элемент с именем "MacroExecutionMode" и с нужным значением из этого перечисления

ReDim oProp(0) As New com.sun.star.beans.PropertyValue
oProp(0).Name = "MacroExecutionMode"
'oProp(0).Value = com.sun.star.document.MacroExecMode.ALWAYS_EXECUTE_NO_WARN
' oProp(0).Value = com.sun.star.document.MacroExecMode.NEVER_EXECUTE 'Определяет политику выполнения макросов, шоб не ругался
oProp(0).Value = 0 'Определяет политику выполнения макросов, шоб не ругался
oDocDestination = StarDesktop.loadComponentFromURL(oURL, "_blank", 0, oProp() )  'открываем файлик куда копировать
'-----------------

'---------------------------------------------------------------
'------------------------------------------------------------------------------

ReDim oDestinationLibs ' объект контейнер библиотеки назначения
oDestinationLibs = oDocDestination.BasicLibraries


'' =========== возврат на лист, с которого запускали макрос  ===============
ThisComponent.CurrentController.ActiveSheet = ThisComponent.Sheets.GetByName(SheetMacrosRun_Name) 'выбираем  лист
'============================================================================


'------------------------------------------------------------------------------
'------------ отправляем на копирование библиотеки ----------
'AddOneLib(sSrcLib$, sDestLib$, oSrcLibs, oDestLibs, bClearDest As Boolean)
'sSrcLib$ - это имя исходной библиотеки, содержащейся в oSrcLibs
'sDestLib$ - это имя целевой библиотеки, содержащейся в oDestLibs
'oSrcLibs - это контейнер исходной библиотеки
'oDestLibs - это контейнер библиотеки назначения
'если значение bClearDest равно True, то библиотека назначения очищается

AddOneLib(SrcLibName, DestLibName, oSourceLibs, oDestinationLibs, TRUE)
'---------------------------------------------------------------------
'------------------------------------------------------------------------------


ReDim DestinationPath
DestinationPath = oDocDestination.getURL()


''================================================
' Определение имени нового файла (в ту же директорию) добавляем ''(1)'' или следующий номер
''=================================================
ReDim file 'As String   ' путь к входному файлу
file = ConvertFromURL(oDocDestination.URL) ' Получим URL документа и превратим его в строку
' или
'file = ConvertFromURL(DestinationPath) ' Получим URL документа и превратим его в строку

pos_cut = InStr(file, ".ods") 'Производит поиск номера символа, с которого начинается образец поиска (string2) в заданной строке (string1).
'Поиск начинается от указанной позиции (start) слева.

ReDim Cuted_Path
Cuted_Path = Left(file, pos_cut -1) ' обрезанный (без расширения) путь входного файла

ReDim DestinationPath_NEW ' новый обрезанный (без расширения) путь файла назначения
ReDim Next_Number ' следующий номер версии файла
Next_Number = 1

FOR i = Len(Cuted_Path) to 1 STEP -1
if Right(Cuted_Path, 1) = ")" then
for z = Len(Cuted_Path) to 1 STEP -1
IF Mid(Cuted_Path,z,1) = "(" THEN
if isNumeric( Mid(Cuted_Path, z+1, Len(Cuted_Path)-z-1 ) ) and CInt( Mid(Cuted_Path, z+1, Len(Cuted_Path)-z-1 ) ) <> Next_Number then
Next_Number = CInt( Mid(Cuted_Path, z+1, Len(Cuted_Path)-z-1) ) + 1
DestinationPath_NEW = Left(Cuted_Path, z) & Next_Number  & ").ods" 'новое имя выходного файла назначения (полный путь с расширением)
Exit FOR
elseif isNumeric( Mid(Cuted_Path, z+1, Len(Cuted_Path)-z-1 ) ) and CInt( Mid(Cuted_Path, z+1, Len(Cuted_Path)-z-1 ) ) = Next_Number then
Next_Number = Next_Number + 1
DestinationPath_NEW = Left(Cuted_Path, z) & Next_Number  & ").ods" 'новое имя выходного файла назначения (полный путь с расширением)
Exit FOR
end if
ELSEIF Mid(Cuted_Path,z,1) = "\" THEN
DestinationPath_NEW = Cuted_Path & "(1).ods" 'новое имя выходного файла назначения (полный путь с расширением)
Exit FOR
END IF
next z
Exit FOR

elseif Mid(Cuted_Path,i,1) = "." then
IF IsNumeric( Right(Cuted_Path, Len(Cuted_Path)-i) ) and CInt( Right(Cuted_Path, Len(Cuted_Path)-i) ) >= 0 THEN
Next_Number = CInt( Right(Cuted_Path, Len(Cuted_Path)-i) ) + 1
DestinationPath_NEW = Left(Cuted_Path, i) & Next_Number & ".ods" 'новое имя выходного файла назначения (полный путь с расширением)
Exit FOR
END IF
elseif Mid(Cuted_Path,i,1) = "\" then
DestinationPath_NEW = Cuted_Path & "(1).ods" 'новое имя выходного файла назначения (полный путь с расширением)
Exit FOR
end if
NEXT i




IF DestinationPath_NEW = "" OR IsNull(DestinationPath_NEW) OR IsEmpty(DestinationPath_NEW) THEN
MsgBox("Что-то не так с новым именем файла назначения" & CHR(13) & "Выход из макроса.",  0+0+48, "ВНИМАНИЕ !!!" )
'---- закрываем открытый файл назначения ---------
oDocDestination.close(true)
'------------------------------------------------
Exit Sub
END IF

'-------------------------------------------------------------------------------------------------------------------
'-------------- Проверка существует ли файл  с новым именем ---------------
'Обычно в LO при открытии файла по записи ранее существовавший файл с данным путем перезаписывается.
'Если нужно избежать диалога с пользователем, то можно удалить существующий файл.
'Для удаления файла или папки используется конструкция (фрагмент):
ReDim oSFA   ' объект SimpleFileAccess     
oSFA = CreateUnoService("com.sun.star.ucb.SimpleFileAccess")

If oSFA.exists(  ConvertToURL(DestinationPath_NEW)  ) Then
' удалить
' 'oSFA.kill(  ConvertToURL(DestinationPath_NEW) )
' создать копию (переименовать)
'oSFA.copy(SourceURL, DestURL)
' oSFA.copy(  ConvertToURL(DestinationPath_NEW),   ConvertToURL(DestinationPath_NEW & ".bkp") )
' переместить (чтобы дата и время изменения не поменялась)
'oSFA.move(SourceURL, DestURL)
oSFA.move(  ConvertToURL(DestinationPath_NEW),   ConvertToURL(DestinationPath_NEW & ".bkp") )
End If
'-----------------------------------------------------------------------------------------------------
'-------------------------------------------------------------------------------------------------------------------


''=============================================================
'---------------- сохраняем открытый файл назначения ---------------------
'oDocDestination.store() 'Save
oDocDestination.storeAsURL( ConvertToURL( DestinationPath_NEW) , Array()  ) 'Save As'
'oDocDestination.storeToURL( ConvertToURL( DestinationPath_NEW ) )
'-------------------------------------------------------------------------
''=============================================================

''=============================================================
'---------------- закрываем открытый файл назначения ---------------------
oDocDestination.close(true)
'-------------------------------------------------------------------------
''=============================================================

NEXT w
ELSE
MsgBox("Что-то не так с выбором файлов." & CHR(13) & "Попробуйте снова" & CHR(13) & "Выход из макроса.",  0+0+48, "ВНИМАНИЕ !!!" )
Exit Sub
END IF


MsgBox ("ГОТОВО !", 0+0+48, "Завершение")

End Sub
'========================================
' ------- Конец Copy_Library ----------
'===============================================




'===================================================================
REM  ***** запуск диалога Открыть файл и получить путь к файлам *****
'==================================================================
Sub GET_FILES(Selected_Files_Arr() ) ' возвращает пути к выбранным файлам в формате URL

Dim oFileDialog as Object ' далог Открыть файл
Dim iOpenFile ' результат выполнения диалога
Dim oFiles 'Возвращаемый диалогом выбора файла массив выбранных файлов


' задать, чтобы фильтр показывал только файлы ods '
oFileDialog = CreateUnoService("com.sun.star.ui.dialogs.FilePicker")
''oFileDialog.SetDisplayDirectory(ConvertToUrl("X:\")) ' для указания стартовой папки
oFileDialog.setMultiSelectionMode(True)  ' для выбора нескольких файлов
oFileDialog.appendFilter("Электронные таблицы (Calc)", "*.ods" )
iOpenFile = oFileDialog.Execute()
If iOpenFile = 0 Then
MsgBox ("Файлы не выбраны !",  0+0+48)
Exit Sub
Else
oFiles = oFileDialog.getSelectedFiles()
IF UBound(oFiles) >= 0 THEN
Selected_Files_Arr() = oFiles()
END IF
End If

End Sub
'==================================
'-----------==============----------------
'===============================================


'===================================================================
REM  ***** AddOneLib (Скопировать библиотеку) *****
'==================================================================
'Питоньяк "OpenOffice.org Macros Explained" (OOME_4_1.odt)
'Листинг 527. Скопировать библиотеку.
'sSrcLib - это имя исходной библиотеки, содержащейся в oSrcLibs
'sDestLib - это имя целевой библиотеки, содержащейся в oDestLibs
'oSrcLibs - это контейнер исходной библиотеки
'oDestLibs - это контейнер библиотеки назначения
'если значение bClearDest равно True, то библиотека назначения очищается

Sub AddOneLib(sSrcLib$, sDestLib$, oSrcLibs, oDestLibs, bClearDest As Boolean)

  Dim oSrcLib   'The source library to copy - это контейнер исходной библиотеки
  Dim oDestLib  'The destination library to receive the modules in oSrcLib - это контейнер библиотеки назначения
  Dim sNames
  Dim i%
 
  'If there is no destination library then simply return
  'Если целевой библиотеки нет, то просто вернитесь
  If IsNull(oDestLibs) OR IsEmpty(oDestLibs) Then
    Exit Sub
  End If

  'Clear the destination library if requested
  'Очистите целевую библиотеку, если потребуется
  If bClearDest AND oDestLibs.hasByName(sDestLib) Then
    oDestLibs.removeLibrary(sDestLib)
  End If

  'If there is no source library, then there is nothing else to do
  'Если исходной библиотеки нет, то делать больше нечего
  If IsNull(oSrcLibs) OR IsEmpty(oSrcLibs) Then
    Exit Sub
  End If

  'If the source library does not exist, then there is nothing else to do
  'Если исходная библиотека не существует, то больше ничего не остается делать
  If NOT oSrcLibs.hasByName(sSrcLib) Then
    Exit Sub
  End If

  'If the destination library does not exist, then create it
  'Если целевая библиотека не существует, то создайте ее
  If NOT oDestLibs.hasByName(sDestLib) Then
    oDestLibs.createLibrary(sDestLib)
  End If

  'the libraries must be loaded first.
  'Common mistake to not load the libraries first!
  'сначала должны быть загружены библиотеки.
  'Распространенная ошибка - не загружать библиотеки в первую очередь!
  oSrcLibs.loadLibrary(sSrcLib)
  oDestLibs.loadLibrary(sDestLib)

  'Get the source and destination libraries
  'Get all of the contained modules that should be copied
  'Получить исходную и целевую библиотеки
  'Получить все содержащиеся в них модули, которые необходимо скопировать
  oSrcLib = oSrcLibs.getByName(sSrcLib)
  oDestLib = oDestLibs.getByName(sDestLib)
  sNames = oSrcLib.getElementNames()

  'For each module, either add it or replace it
  'Для каждого модуля либо добавьте его, либо замените
  For i = LBound(sNames) To UBound(sNames)
    If oDestLib.hasByName(sNames(i)) Then
      oDestLib.replaceByName(sNames(i), oSrcLib.getByName(sNames(i)))
    Else
      oDestLib.insertByName(sNames(i), oSrcLib.getByName(sNames(i)))
    End If
  Next
End Sub
'----------===============-------------------
'======================================================