Макрос Microsoft Excel для работы в Libreoffice

[Вячеслав22]

Здравствуйте! Будьте добры, помогите переписать макрос Microsoft Excel для работы в Libreoffice. Перешли на отечественное ПО и времени на изучение пока нет.

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

Sub Адрес()
'
' Адрес
'
dosyaadi1 = Cells(1, 3)
donbasa:
Set klasor = CreateObject("shell.application").Browseforfolder(0, "Выберите место для сохранения заключений", 100, &H0)

If klasor Is Nothing Then GoTo donbasa
kaynak = klasor.self.Path
Cells(1, 3) = kaynak
kayityeri = Cells(1, 3)

End Sub


Sub Печать()

'
' Печать
'

reportno = Cells(8, 3)
dosyayolu = Cells(1, 3)
AA = Cells(6, 3)
BB = Cells(6, 4)
If AA > BB Then
    Cells(6, 3) = AA
    BB = Cells(6, 3)
Else
End If
If dosyayolu = "" Then
    MsgBox "Lutfen Klasor Secimini Yapiniz !", vbInformation, "Uyari"
    Call Адрес
    dosyayolu = Cells(1, 3)
Else
End If
Application.ScreenUpdating = False
For jts = AA To BB Step 1
    Cells(6, 3) = jts
    Sheets("Данные").Calculate
    reportno = Cells(5, 9)

    ChDir dosyayolu

    Sheets("ВИК-РД").Select
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
        IgnorePrintAreas:=False
        Sheets("РК-РД").Select
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
        IgnorePrintAreas:=False
        Sheets("КАП-РД").Select
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
        IgnorePrintAreas:=False
        Sheets("ВИК-РАД").Select
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
        IgnorePrintAreas:=False
        Sheets("РК-РАД").Select
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
        IgnorePrintAreas:=False
        Sheets("КАП-РАД").Select
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
        IgnorePrintAreas:=False
       
        Worksheets(Array("ВИК-РД", "РК-РД", "КАП-РД")).Select
        Клеймо = Sheets("ВИК-РД").Cells(2, 12)
        имяфайла = Клеймо & " Заключение-РД"
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        имяфайла, Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False

        Worksheets(Array("ВИК-РАД", "РК-РАД", "КАП-РАД")).Select
        Клеймо = Sheets("ВИК-РАД").Cells(2, 12)
        имяфайла = Клеймо & " Заключение-РАД"
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        имяфайла, Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
         Sheets("Данные").Select
       
Next jts
Application.ScreenUpdating = True

End Sub


[bigor]

Добрый вечер.
А сам файлик можно приложить?

[Вячеслав22]

Добрый день! Вот он)

[bigor]

Вот он)

он под МАК ? В МСО 2007 под винду, некорректно отображаются макросы, и они немного отличаются, от того, что в стартовом посту. 

[sokol92]

он под МАК

В файле кодировка макросов 10007 (MAC - кириллица).

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

Sub Адрес()
'
' Адрес
'
dosyaadi1 = Cells(1, 4)
donbasa:
Set klasor = CreateObject("shell.application").Browseforfolder(0, "Выберите место для сохранения заключений", 100, &H0)

If klasor Is Nothing Then GoTo donbasa
kaynak = klasor.self.Path
Cells(1, 4) = kaynak
kayityeri = Cells(1, 4)

End Sub


Sub ПечатьРД()

'
' Печать
'

reportno = Cells(8, 3)
dosyayolu = Cells(1, 4)
AA = Cells(6, 4)
BB = Cells(6, 5)
If AA > BB Then
    Cells(6, 4) = AA
    BB = Cells(6, 4)
ЬФСElse
End If
If dosyayolu = "" Then
    MsgBox "Lutfen Klasor Secimini Yapiniz !", vbInformation, "Uyari"
    Call Адрес
    dosyayolu = Cells(1, 4)
Else
End If
Application.ScreenUpdating = False
For jts = AA To BB Step 1
    Cells(6, 4) = jts
    Sheets("Данные").Calculate
    reportno = Cells(5, 9)

    ChDir dosyayolu

    Sheets("ВИК-РД").Select
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
        IgnorePrintAreas:=False
        Sheets("РК-РД").Select
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
        IgnorePrintAreas:=False
              
        Worksheets(Array("ВИК-РД", "РК-РД")).Select
        №закл = Sheets("ВИК-РД").Cells(3, 40)
        ФИО = Sheets("ВИК-РД").Cells(7, 33)
        №АВР = Sheets("ВИК-РД").Cells(6, 30)
        имяфайла = №закл & " " & ФИО & " АТТ АВР №" & №АВР
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        имяфайла, Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
         Sheets("Данные").Select
       
Next jts
Application.ScreenUpdating = True

End Sub


Sub ПечатьРАД()

'
' Печать
'

reportno = Cells(31, 3)
dosyayolu = Cells(1, 4)
AA = Cells(29, 4)
BB = Cells(29, 5)
If AA > BB Then
    Cells(29, 4) = AA
    BB = Cells(29, 4)
Else
End If
If dosyayolu = "" Then
    MsgBox "Lutfen Klasor Secimini Yapiniz !", vbInformation, "Uyari"
    Call Адрес
    dosyayolu = Cells(1, 4)
Else
End If
Application.ScreenUpdating = False
For jts = AA To BB Step 1
    Cells(29, 4) = jts
    Sheets("Данные").Calculate
    reportno = Cells(5, 9)

    ChDir dosyayolu

    Sheets("ВИК-РАД").Select
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
        IgnorePrintAreas:=False
        Sheets("РК-РАД").Select
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
        IgnorePrintAreas:=False
      
       
        Worksheets(Array("ВИК-РАД", "РК-РАД")).Select
        №закл = Sheets("ВИК-РАД").Cells(3, 40)
        ФИО = Sheets("ВИК-РАД").Cells(7, 33)
        №АВР = Sheets("ВИК-РАД").Cells(6, 30)
        имяфайла = №закл & " " & ФИО & " АТТ АВР №" & №АВР
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        имяфайла, Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
         Sheets("Данные").Select
       
Next jts
Application.ScreenUpdating = True

End Sub


Sub ПечатьРАДРД()

'
' Печать
'

reportno = Cells(54, 3)
dosyayolu = Cells(1, 4)
AA = Cells(52, 4)
BB = Cells(52, 5)
If AA > BB Then
    Cells(52, 4) = AA
    BB = Cells(52, 4)
Else
End If
If dosyayolu = "" Then
    MsgBox "Lutfen Klasor Secimini Yapiniz !", vbInformation, "Uyari"
    Call Адрес
    dosyayolu = Cells(1, 4)
Else
End If
Application.ScreenUpdating = False
For jts = AA To BB Step 1
    Cells(52, 4) = jts
    Sheets("Данные").Calculate
    reportno = Cells(5, 9)

    ChDir dosyayolu

    Sheets("ВИК-РАД+РД").Select
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
        IgnorePrintAreas:=False
        Sheets("РК-РАД+РД").Select
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
        IgnorePrintAreas:=False
      
       
        Worksheets(Array("ВИК-РАД+РД", "РК-РАД+РД")).Select
        №закл = Sheets("ВИК-РАД+РД").Cells(3, 40)
        ФИО = Sheets("ВИК-РАД+РД").Cells(7, 33)
        №АВР = Sheets("ВИК-РАД+РД").Cells(6, 30)
        имяфайла = №закл & " " & ФИО & " АТТ АВР №" & №АВР
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        имяфайла, Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
         Sheets("Данные").Select
       
Next jts
Application.ScreenUpdating = True

End Sub



[bigor]

В общем примерно так, солянка макроса из первоначального поста с правками на файл. Не правильно работает выгрузка в пдф, выгружает
все листы. Знаю как выгрузить один, а с двумя попробовал выделить их (подсмотрел у sokol92 как выделял для печати), но фокус не удался

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

Sub Адрес()
'
' Адрес
'

dosyaadi1 = ThisComponent.sheets.GetbyName("Данные").getCellByPosition(3, 0).getString

kaynak=getFolder("Выберите место для сохранения заключений")&"/"
ThisComponent.sheets.GetbyName("Данные").getCellByPosition(3, 0).setString(kaynak)
kayityeri = kaynak

End Sub


Sub Печать()

'
' Печать
'
Dim Props(0) As New com.sun.star.beans.PropertyValue
Dim aSel(0) as new com.sun.star.beans.PropertyValue
dispatcher = createUnoService("com.sun.star.frame.DispatchHelper")

reportno = ThisComponent.sheets.GetbyName("Данные").getCellByPosition(2, 7).getString
dosyayolu = ThisComponent.sheets.GetbyName("Данные").getCellByPosition(3, 0).getString
AA = ThisComponent.sheets.GetbyName("Данные").getCellByPosition(3, 5).getValue
BB = ThisComponent.sheets.GetbyName("Данные").getCellByPosition(4, 5).getValue
If AA > BB Then
    BB = AA
 Else
End If
If dosyayolu = "" Then
    MsgBox "Lutfen Klasor Secimini Yapiniz !", vbInformation, "Uyari"
    Call Адрес
    dosyayolu = ThisComponent.sheets.GetbyName("Данные").getCellByPosition(3, 0).getString
Else
End If
'Application.ScreenUpdating = False
For jts = AA To BB Step 1
    ThisComponent.sheets.GetbyName("Данные").getCellByPosition(3, 5).setValue(jts)
    'Sheets("Данные").Calculate
    reportno = ThisComponent.sheets.GetbyName("Данные").getCellByPosition(8, 4).getValue

' Props(0).Name = "Wait"
' Props(0).Value = true
Props(0).Name = "CopyCount"
Props(0).Value = 1
ThisComponent.CurrentController.setActiveSheet(ThisComponent.sheets.GetbyName("ВИК-РД"))
' ThisComponent.print(Props())
' Props(0).Name = "Wait"
' Props(0).Value = true
Props(0).Name = "CopyCount"
Props(0).Value = 1
ThisComponent.CurrentController.setActiveSheet(ThisComponent.sheets.GetbyName("РК-РД"))
' ThisComponent.print(Props())
 
 
 

'Print ThisComponent.Sheets.getByName("ВИК-РД").RangeAddress.Sheet
aSel(0).Name="Tables"
aSel(0).Value=Array(ThisComponent.Sheets.getByName("ВИК-РД").RangeAddress.Sheet, ThisComponent.Sheets.getByName("РК-РД").RangeAddress.Sheet)      ' индексы листов для печати (нумерация от 0)
dispatcher.executeDispatch(ThisComponent.CurrentController.Frame, ".uno:SelectTables", "", 0, aSel)
 
Props(0).Name = "FilterName"
Props(0).Value = "calc_pdf_Export"
' Props(1).Name = "FilterName"
' Props(1).Value = "calc_pdf_Export"

             
   '     Worksheets(Array("ВИК-РД", "РК-РД")).Select
        Nзакл = ThisComponent.sheets.GetbyName("ВИК-РД").getCellByPosition(39, 2).getString
        ФИО = ThisComponent.sheets.GetbyName("ВИК-РД").getCellByPosition(32, 6).getString
        NАВР = ThisComponent.sheets.GetbyName("ВИК-РД").getCellByPosition(29, 5).getString
        имяфайла = Nзакл & " " & ФИО & " АТТ АВР №" & NАВР
   '     ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
   '     имяфайла, Quality:=xlQualityStandard, _
   '     IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
   '      Sheets("Данные").Select
      ThisComponent.storeToURL( dosyayolu & имяфайла & ".pdf",Props()) 
Next jts
'Application.ScreenUpdating = True

End Sub
 


Function getFolder(sTitle AS String, optional sInitDir) AS String
   oPicker = CreateUnoService("com.sun.star.ui.dialogs.FolderPicker")
   oPicker.setTitle(sTitle)
   if not ismissing(sInitDir) then oPicker.setDisplayDirectory(sInitDir)
   if oPicker.execute() then getFolder = oPicker.getDirectory()
   'msgbox getFolder
End Function

[sokol92]

Не правильно работает выгрузка в пдф, выгружает
все листы

Самое простое и надежное:
1. Скрыть все листы, кроме требуемых
2. Эспортировать с помощью команды .uno:ExportToPDF
3. Отобразить листы, скрытые в п.1
Напишу завтра такой макрос (если кто-то не сделал / сделает раньше).

[bigor]

Не правильно работает выгрузка в пдф

Разобрался. Нашел код mikekaganski, теперь выгружает нужные листы

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

Sub Печать()

'
' Печать
'
Dim Props(0 To 1) As New com.sun.star.beans.PropertyValue
Dim aSel(0) as new com.sun.star.beans.PropertyValue
Dim aSel1(0) as new com.sun.star.beans.PropertyValue
dispatcher = createUnoService("com.sun.star.frame.DispatchHelper")

reportno = ThisComponent.sheets.GetbyName("Данные").getCellByPosition(2, 7).getString
dosyayolu = ThisComponent.sheets.GetbyName("Данные").getCellByPosition(3, 0).getString
AA = ThisComponent.sheets.GetbyName("Данные").getCellByPosition(3, 5).getValue
BB = ThisComponent.sheets.GetbyName("Данные").getCellByPosition(4, 5).getValue
If AA > BB Then
    BB = AA
 Else
End If
If dosyayolu = "" Then
    MsgBox "Lutfen Klasor Secimini Yapiniz !", vbInformation, "Uyari"
    Call Адрес
    dosyayolu = ThisComponent.sheets.GetbyName("Данные").getCellByPosition(3, 0).getString
Else
End If
'Application.ScreenUpdating = False
For jts = AA To BB Step 1
    ThisComponent.sheets.GetbyName("Данные").getCellByPosition(3, 5).setValue(jts)
    'Sheets("Данные").Calculate
    reportno = ThisComponent.sheets.GetbyName("Данные").getCellByPosition(8, 4).getValue
   
        Props(0).Name = "Wait"
        Props(0).Value = true
        Props(1).Name = "CopyCount"
        Props(1).Value = 1
    ThisComponent.CurrentController.setActiveSheet(ThisComponent.sheets.GetbyName("ВИК-РД"))
'    ThisComponent.print(Props())
        Props(0).Name = "Wait"
        Props(0).Value = true
        Props(1).Name = "CopyCount"
        Props(1).Value = 1
    ThisComponent.CurrentController.setActiveSheet(ThisComponent.sheets.GetbyName("РК-РД"))
'    ThisComponent.print(Props())
 
    aSel(0).Name="Tables"
    aSel(0).Value=Array(ThisComponent.Sheets.getByName("ВИК-РД").RangeAddress.Sheet, ThisComponent.Sheets.getByName("РК-РД").RangeAddress.Sheet)      ' индексы листов для печати (нумерация от 0)
    dispatcher.executeDispatch(ThisComponent.CurrentController.Frame, ".uno:SelectTables", "", 0, aSel)
    
     aSel1(0).Name="Selection"
     aSel1(0).Value=ThisComponent.CurrentSelection
    Props(0).Name = "FilterName"
    Props(0).Value = "calc_pdf_Export"   
    Props(1).Name = "FilterData"
    Props(1).Value = aSel1   

            
   Nзакл = ThisComponent.sheets.GetbyName("ВИК-РД").getCellByPosition(39, 2).getString
   ФИО = ThisComponent.sheets.GetbyName("ВИК-РД").getCellByPosition(32, 6).getString
   NАВР = ThisComponent.sheets.GetbyName("ВИК-РД").getCellByPosition(29, 5).getString
   имяфайла = Nзакл & " " & ФИО & " АТТ АВР №" & NАВР
   '     ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
   '     имяфайла, Quality:=xlQualityStandard, _
   '     IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
   '      Sheets("Данные").Select
         ThisComponent.storeToURL( dosyayolu & имяфайла & ".pdf",Props())
        
Next jts
'Application.ScreenUpdating = True
ThisComponent.CurrentController.setActiveSheet(ThisComponent.sheets.GetbyName("Данные"))
End Sub
Доделал остальные кнопки.

[Вячеслав22]

Добрый день!Благодарю за помощь! В файле Заключения макрос Адрес прокладывает путь без привязки к листу, а макрос печать сохраняет (ПДФ) и печатает нужные листы подтягивая информацию из листа "Данные". В файле Заявки также Адрес задаёт место сохранения Печать сохраняет и печатает нужный лист.

[Вячеслав22]

Добрый день! Будьте добры, подскажите как исправить ошибку - Ошибка времени выполнения Basic. Подпрограмма или функция не определена.

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

Sub Main()
'
' Адрес
'

filename1 = ThisComponent.sheets.GetbyName("Данные").getCellByPosition(1, 4).getString

source=getFolder("Выберите место для сохранения заключений")&"/"
ThisComponent.sheets.GetbyName("Данные").getCellByPosition(1, 4).setString(source)
registration = source

End Sub


Sub Main1

'
' Печать
'
Dim Props(0 To 1) As New com.sun.star.beans.PropertyValue
Dim aSel(0) as new com.sun.star.beans.PropertyValue
Dim aSel1(0) as new com.sun.star.beans.PropertyValue
dispatcher = createUnoService("com.sun.star.frame.DispatchHelper")

reportno = ThisComponent.sheets.GetbyName("Данные").getCellByPosition(2, 7).getString
thepathtothefile = ThisComponent.sheets.GetbyName("Данные").getCellByPosition(1, 4).getString
AA = ThisComponent.sheets.GetbyName("Данные").getCellByPosition(6, 4).getValue
BB = ThisComponent.sheets.GetbyName("Данные").getCellByPosition(6, 5).getValue
If AA > BB Then
    BB = AA
 Else
End If
If thepathtothefile = "" Then
    MsgBox "Выберите место для сохранения заключений", vbInformation, "Предупреждение"
    Call Main
    dosyayolu = ThisComponent.sheets.GetbyName("Данные").getCellByPosition(1, 4).getString
Else
End If
'Application.ScreenUpdating = False
For jts = AA To BB Step 1
    ThisComponent.sheets.GetbyName("Данные").getCellByPosition(3, 5).setValue(jts)
    'Sheets("Данные").Calculate
    reportno = ThisComponent.sheets.GetbyName("Данные").getCellByPosition(8, 4).getValue
   
        Props(0).Name = "Wait"
        Props(0).Value = true
        Props(1).Name = "CopyCount"
        Props(1).Value = 1
    ThisComponent.CurrentController.setActiveSheet(ThisComponent.sheets.GetbyName("ВИК-РД"))
'    ThisComponent.print(Props())
        Props(0).Name = "Wait"
        Props(0).Value = true
        Props(1).Name = "CopyCount"
        Props(1).Value = 1
    ThisComponent.CurrentController.setActiveSheet(ThisComponent.sheets.GetbyName("РК-РД"))
'    ThisComponent.print(Props())
 
    aSel(0).Name="Tables"
    aSel(0).Value=Array(ThisComponent.Sheets.getByName("ВИК-РД").RangeAddress.Sheet, ThisComponent.Sheets.getByName("РК-РД").RangeAddress.Sheet)      ' индексы листов для печати (нумерация от 0)
    dispatcher.executeDispatch(ThisComponent.CurrentController.Frame, ".uno:SelectTables", "", 0, aSel)
   
     aSel1(0).Name="Selection"
     aSel1(0).Value=ThisComponent.CurrentSelection
    Props(0).Name = "FilterName"
    Props(0).Value = "calc_pdf_Export"   
    Props(1).Name = "FilterData"
    Props(1).Value = aSel1   

           
   conclusions = ThisComponent.sheets.GetbyName("ВИК-РД").getCellByPosition(3, 40).getString
   FCs = ThisComponent.sheets.GetbyName("ВИК-РД").getCellByPosition(7, 33).getString
   AVR = ThisComponent.sheets.GetbyName("ВИК-РД").getCellByPosition(6, 30).getString
   filename = conclusions & " " & FCs & " АТТ АВР №" & AVR
   '     ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
   '     filename, Quality:=xlQualityStandard, _
   '     IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
   '      Sheets("Данные").Select
         ThisComponent.storeToURL( dosyayolu & filename & ".pdf",Props())
       
Next jts
'Application.ScreenUpdating = True
ThisComponent.CurrentController.setActiveSheet(ThisComponent.sheets.GetbyName("Данные"))
End Sub

[bigor]

Добрый. А на что конкретно ругается? Он же в какой то строчке ошибку находит. И лучше с файликом выложить, что бы потестить можно было

[Вячеслав22]

source=getFolder("Выберите место для сохранения заключений")&"/"

[bigor]

А где вы взяли getFolder? Поиском по форуму ищется самописная функция getFolder, но тогда её нужно добавить в ваш  модуль.

[mikekaganski]

Здесь в ответе #5

[bigor]

#5

Тогда если бы файлик был родной ods -ий можно было потестить почему она ругается, а вот с xlsm уже врядли