Forum-Francophone-LinuxMint.fr

Code : Tout sélectionner

SUB Main_genererPdf
    Dim doc, lesPages, unePage, page, fp, uneImg, lImage, gp as object
    Dim UrlImg() as variant
    Dim leDossImg_url, url_image, url_DossCopiePDF as string
    Dim x ,y ,z ,a ,b ,xMax, nImg, nPages as integer
    Dim props(0) as New com.sun.star.beans.PropertyValue
    Dim logg as boolean
   
    doc = thiscomponent
    lesPages = doc.Drawpages
    'logg = true
    logg = false
    fp = createunoservice("com.sun.star.ui.dialogs.FolderPicker")
    With fp
        .DisplayDirectory = convertToURL("/home/")
        .Title = "Sélectionner un dossier contenant les images à transformer"
        If .execute = com.sun.star.ui.dialogs.ExecutableDialogResults.OK then
            leDossImg_url = .directory & "/"
        End if
    End with
   
    UrlImg() = FilesName(leDossImg_url)
    xMax = Ubound(UrlImg)
    if logg then
        Msgbox("le nombre d'images est: " & xMax+1)
    end if
    With lesPages
        nPages = .getCount()
        if logg then
            Msgbox("le nombre de pages est: " & nPages)
        end if
        If nPages > 1 then
            For each page in lesPages.ElementNames
                lesPages.remove(lesPages.getbyname(page))
                if logg then
                    Msgbox(page & " a été supprimée")
                end if
            Next page       
        End if
       
        For y = 1 to xMax
            .InsertNewByIndex(y)
            if logg then
                Msgbox("la Page " & y+1 & " a été crée")
            end if
        Next   
    End with
   
    For z = 0 to xMax
        if logg then
                Msgbox("la Page " & z+1 & " est appellée")
        end if   
        unePage = lesPages.getbyindex(z)
        With unePage
            '.name = "Page " & z+1 suspendu pour test
            .name = UrlImg(z) 'activée pour test
            nImg = .getCount()
            If nImg > 0 then
                For a=0 to nImg-1
                    .remove(.getbyindex(a))
                Next
            End if
        End with   
        url_image = ConvertToURL(leDossImg_url & UrlImg(z))
        gp = createUnoservice("com.sun.star.graphic.GraphicProvider")
          props(0).Name = "URL"
          props(0).Value = url_image
          lImage = doc.createInstance("com.sun.star.drawing.GraphicObjectShape")
          lImage.Graphic = gp.queryGraphic(props())
          unePage.add(lImage)
          New_resizeImageByWidth(lImage, 21000)
    Next
   
    With fp
        .DisplayDirectory = convertToURL("/home/")
        .Title = "Sélectionner un dossier de destination pour la copie PDF"
        If .execute = com.sun.star.ui.dialogs.ExecutableDialogResults.OK then
            url_DossCopiePDF = convertToURL(.directory & "/")
        End if
    End with
    GenererUnPdfAvec(doc, url_DossCopiePDF)   
END SUB


Function FilesName(leRepertoire as string)
    dim f2 as string
    dim x, xFiles as integer
    xFiles = 0
    f2 = Dir(leRepertoire & "*", 0)
    Do while Len(f2) >0
        f2 = Dir
        xFiles = xFiles+1
    Loop
    Dim arrayF(xFiles-1) as variant
    f2 = Dir(leRepertoire & "*", 0)
    For x = 0 to xFiles-1
        arrayF(x) = f2
        f2 = Dir
    Next
    Filesname = triAlpha(arrayF())
End Function

Sub New_resizeImageByWidth(uneImage As Object, largeur As Long)
'Fonction extraite du livre "programmation open office.org et libre office"
Dim imageInfo As Object, Proportion As Double, Taille1 As Object

imageInfo = uneImage.Graphic
Taille1 = imageInfo.SizePixel
Proportion = Taille1.Height / Taille1.Width
Taille1.Width = largeur ' largeur en 1/100 de mm
Taille1.Height = Taille1.Width * Proportion
uneImage.Size = Taille1
End Sub

SUB GenererUnPdfAvec(doc, url_dest)
    Dim adresseDoc as string
    Dim propsPDF as variant, propsFiltre as variant
   
    propsFiltre = CreateProperties(Array(_
        "PageRange", "",_
        "UseTaggedPDF", True,_
        "FormsType", 1,_
        "ExportsNotes", True,_
        "DisplayPDFDocumentTitle", False,_
        "PDFViewSelection", 1,_
        "UseLosslessCompression", True,_
        "InitialView", 2,_
        "PageLayout", 2,_
        "Zoom", 100 ))
       
    propsPDF = CreateProperties(Array(_
    "FilterName", "draw_pdf_Export", "FilterData", propsFiltre() ))
   
    adresseDoc = convertToURL(url_dest & getFileNameOnly(doc.URL) & ".pdf")
    doc.storeToURL(adresseDoc, propsPDF())
    Msgbox("fin de la copie!")
END SUB

Function CreateProperties(propList() As Variant) As Object
'Fonction extraite du livre "programmation open office.org et libre office"
Dim n as long, x as long

n = UBound(propList)
if n < 0  then
  CreateProperties = Array()
else
  if (n and 1) = 0  then
    MsgBox("Erreur : nombre impair d'arguments", 16, "CreateProperties")
  else
    Dim p(n\2) As New com.sun.star.beans.PropertyValue
    for x = 0 to n\2
      p(x).Name = propList(2*x)
      p(x).Value = propList(2*x +1)
    next
    CreateProperties = p()
  end if
end if
End Function

Function getFileNameOnly(URLPath As String) As String
'Fonction extraite du livre "programmation open office.org et libre office"
Dim s As String, parts As Variant
s = getFullFileName(URLPath)
parts = split(s, ".")
if UBound(parts()) > 0  then
  parts(UBound(parts())) = ""
  s = join(parts, ".")
  getFileNameOnly = Mid(s, 1, Len(s) -1)
else
  getFileNameOnly = parts(0)
end if
End Function

' renvoie le nom complet d'un fichier : Nom.Ext
Function getFullFileName(URLPath As String) As String
'Fonction extraite du livre "programmation open office.org et libre office"
Dim parts As Variant
parts = split(URLPath, "/")
getFullFileName = parts(UBound(parts())
End Function

function triAlpha(t1()) as variant
rem Fonction récupérée par Alain de la Chaume du forum ooO et modifiée par Hubert Lambert
dim t2() as variant
dim indexMaxi as long
dim cpt1 as long, cpt2 as long
dim varTmp as variant

    indexMaxi = ubound(t1)
    redim t2(indexMaxi)
    t2 = t1
    For cpt1 = 0 To indexMaxi - 1
        For cpt2 = cpt1 + 1 To indexMaxi
            If numberfromstring(t2(cpt1)) > numberfromstring(t2(cpt2)) Then
                varTmp = t2(cpt1)
                t2(cpt1) = t2(cpt2)
                t2(cpt2) = varTmp
            end if
        Next cpt2
    Next cpt1
    triAlpha = t2()
end function

function numberfromstring(txt as string) as integer
Rem Fonction écrite par Hubert Lambert du forum ooO
    dim s as object, search as object
    dim start as long, end_ as long
    s = createUnoService("com.sun.star.util.TextSearch")
    dim opt as new com.sun.star.util.SearchOptions
    opt.algorithmType = com.sun.star.util.SearchAlgorithms.REGEXP
    opt.searchString = "[0-9]+"
    s.setOptions(opt)
    search = s.searchForward(txt, 0, len(txt))
    start = search.startOffset(0)+1
    end_ = search.endOffset(0) - search.startOffset(0)
    numberfromstring = int(mid(txt, start, end_))
end function