OpenOffice.cz - web věnovaný kancelářským balíkům OpenOffice.org

barevnej

Člen

Registrace: 6. 8. 2015

Příspěvků: 173

Jak vyexportovat PDF makrem bez ptaní (VYŘEŠENO)

Snažím se udělat makro které by uložilo PDF na stejném místě jako je zdrojová tabulka pod stejným názvem jako je zdrojová tabulka.
Prakticky by to vypadlo stejně jako když kliknu na ikonku Přímý export do PDF a hned dal OK.

Už jsem dokázal aby si to načetlo místo souboru ale nedaří se mi aby si to ještě načetlo jméno souboru. Celkem mám pocit že to dělám hrozně složitě.

Sub ulozitPDF()
    Dim ZdrojovySoubor As String
    Dim CilovySoubor As String
    Dim args1(1) As New com.sun.star.beans.PropertyValue
    
    ' Získání cesty k zdrojovému sešitu
    Dim docURL As String
    docURL = ThisComponent.getURL()
    ZdrojovySoubor = ConvertFromURL(docURL)
    
    ' Vytvoření cesty pro cílový soubor s příponou PDF
    Dim directory As String
    directory = GetPath(ZdrojovySoubor)
    CilovySoubor = directory & "Vysledek.pdf" ' Tady potřebuji aby si načetl správný název zdroje
    
    ' Převedení cesty na formát Linuxu
    Dim fileURL As String
    fileURL = ConvertToURL(CilovySoubor)
    
    ' Nastavení argumentů pro export do PDF
    args1(0).Name = "URL"
    args1(0).Value = fileURL
    args1(1).Name = "FilterName"
    args1(1).Value = "calc_pdf_Export"
    
    ' Vytvoření objektu Desktop pro volání exportní metody
    Dim desktop As Object
    desktop = createUnoService("com.sun.star.frame.Desktop")
    
    ' Export aktuálního sešitu do cílového PDF souboru
    desktop.getCurrentComponent().storeToURL(fileURL, args1())
End Sub

' Patch aby fungovalo umístění adresáře pod Linuxem
Function GetPath(ByVal sFilePath As String) As String
    Dim arrPath() As String
    arrPath = Split(sFilePath, "/")
    ReDim Preserve arrPath(UBound(arrPath) - 1)
    GetPath = Join(arrPath, "/") & "/"
End Function

Prakticky chci navázat na toto makro aby se po úspěšném uložení automaticky vytvořilo PDF.
https://forum.openoffice.cz/viewtopic.php?id=6048

Editoval barevnej (12. 7. 2023 16:36:35)

barevnej

Člen

Registrace: 6. 8. 2015

Příspěvků: 173

Re: Jak vyexportovat PDF makrem bez ptaní (VYŘEŠENO)

Tak toto makro již funguje. Řešil jsem tam ještě problém spůvodní příponou .ods tak jsem jí odstranil

Sub ulozitPDF()
    Dim ZdrojovySoubor As String
    Dim CilovySoubor As String
    Dim args1(1) As New com.sun.star.beans.PropertyValue
    
    ' Získání názvu sešitu (souboru)
    Dim docName As String
    docName = ThisComponent.Title
    
    ' Odstranění původní přípony .ods
	docName = Replace(docName, ".ods", "")
    
    ' Získání cesty k zdrojovému sešitu
    Dim docURL As String
    docURL = ThisComponent.getURL()
    ZdrojovySoubor = ConvertFromURL(docURL)
    
    ' Vytvoření cesty pro cílový soubor s příponou PDF
    Dim directory As String
    directory = GetPath(ZdrojovySoubor)
    CilovySoubor = directory & docName & ".pdf"
    
    ' Převedení cesty na formát Linuxu
    Dim fileURL As String
    fileURL = ConvertToURL(CilovySoubor)
    
    ' Nastavení argumentů pro export do PDF
    args1(0).Name = "URL"
    args1(0).Value = fileURL
    args1(1).Name = "FilterName"
    args1(1).Value = "calc_pdf_Export"
    
    ' Vytvoření objektu Desktop pro volání exportní metody
    Dim desktop As Object
    desktop = createUnoService("com.sun.star.frame.Desktop")
    
    ' Export aktuálního sešitu do cílového PDF souboru
    desktop.getCurrentComponent().storeToURL(fileURL, args1())
End Sub

' Patch aby fungovalo umístění adresáře pod Linuxem
Function GetPath(ByVal sFilePath As String) As String
    Dim arrPath() As String
    arrPath = Split(sFilePath, "/")
    ReDim Preserve arrPath(UBound(arrPath) - 1)
    GetPath = Join(arrPath, "/") & "/"
End Function

barevnej

Člen

Registrace: 6. 8. 2015

Příspěvků: 173

Re: Jak vyexportovat PDF makrem bez ptaní (VYŘEŠENO)

Nyní ovšem nastal nový problém po spojení s původním makrem kdy toto makro nepočká až se dokončí to první.
https://forum.openoffice.cz/viewtopic.php?id=6048

barevnej

Člen

Registrace: 6. 8. 2015

Příspěvků: 173

Re: Jak vyexportovat PDF makrem bez ptaní (VYŘEŠENO)

Tak už to mám, musel jsem upravit i původní makro aby šlo poznat kdy se uspěšně uloží.

Sub Ulozit_jako_datumem()
    Dim oSheet
    Dim sVar, sVal As String
    Dim iCount, iLeft As Integer
    Dim Propval()
    Sheets = ThisComponent.getSheets()
    oSheet = ThisComponent.CurrentController.ActiveSheet
    sVar = ConvertFromUrl(ThisComponent.URL)
    sVal = oSheet.getCellRangeByName("W2").String
    sVal = sVal & "_" & Day(NOW) & "_" & Month(NOW) & "_" & Year(NOW) & ThisComponent.Title & ""
    sVar = FilPickFolder()

    If sVar <> "" Then
        FileURL = convertToURL(sVar & "/" & sVal)
        ThisComponent.StoreAsURL(FileURL, Propval())
        ulozitPDF sVar, sVal
    End If
End Sub

Function FilPickFolder() As String
    Dim oFolderPicker As Object
    Dim oAccept As Integer
    Dim oFolder As String
    Dim oFolderURL As String, oGetFolderName As String
    oFolderPicker = createUnoService("com.sun.star.ui.dialogs.FolderPicker")
    oFolderPicker.setTitle("Vyber složku kam uložit")
    oFolderPicker.setDisplayDirectory("file:///home/uživatel/") 'cesta k výchozímu linux adresáři
    oFolderPicker.setDescription("Vyber adresář")
    oAccept = oFolderPicker.execute()
    If oAccept = 1 Then
        oFolder = oFolderPicker.getDirectory()
        oFolderURL = oFolder(0)
        oGetFolderName = ConvertFromURL(oFolderURL)
        FilPickFolder = oGetFolderName
    Else
        oFolderPicker.cancel()
        FilPickFolder = ""
    End If
End Function

Sub ulozitPDF(ByVal sVar As String, ByVal sVal As String)
    Dim ZdrojovySoubor As String
    Dim CilovySoubor As String
    Dim args1(1) As New com.sun.star.beans.PropertyValue
    
    ' Získání názvu sešitu (souboru)
    Dim docName As String
    docName = ThisComponent.Title
    
    ' Odstranění původní přípony .ods
    docName = Replace(docName, ".ods", "")
    
    ' Získání cesty k zdrojovému sešitu
    Dim docURL As String
    docURL = ThisComponent.getURL()
    ZdrojovySoubor = ConvertFromURL(docURL)
    
    ' Vytvoření cesty pro cílový soubor s příponou PDF
    Dim directory As String
    directory = GetPath(ZdrojovySoubor)
    CilovySoubor = directory & docName & ".pdf"
    
    ' Převedení cesty na formát Linuxu
    Dim fileURL As String
    fileURL = ConvertToURL(CilovySoubor)
    
    ' Nastavení argumentů pro export do PDF
    args1(0).Name = "URL"
    args1(0).Value = fileURL
    args1(1).Name = "FilterName"
    args1(1).Value = "calc_pdf_Export"
    
    ' Vytvoření objektu Desktop pro volání exportní metody
    Dim desktop As Object
    desktop = createUnoService("com.sun.star.frame.Desktop")
    
    ' Export aktuálního sešitu do cílového PDF souboru
    desktop.getCurrentComponent().storeToURL(fileURL, args1())
End Sub

    ' Patch aby fungovalo umístění adresáře pod Linuxem
Function GetPath(ByVal sFilePath As String) As String
    Dim arrPath() As String
    arrPath = Split(sFilePath, "/")
    ReDim Preserve arrPath(UBound(arrPath) - 1)
    GetPath = Join(arrPath, "/") & "/"
End Function

Editoval barevnej (12. 7. 2023 16:13:31)