Téléchargement d'un fichier depuis internet sur l'ordinateur client

This page is a translated version of the page Macros/General/007 and the translation is 100% complete.

TDF LibreOffice Document Liberation Project Blogs communautaires Weblate Nextcloud Redmine Ask LibreOffice Donner

Other languages:

Description

Cette macro télécharge un fichier à partir d'une adresse internet sur l'ordinateur local. Elle ne fonctionne que sous Windows et Linux. macOS n'est pas pris en charge.

Sous Linux la macro utilise wget pour télécharger le fichier, sous Windows la macro utilise la fonction URLDownloadToFile de la bibliothèque urlmon de l'API Windows.

L'adresse Internet et le nom de fichier doivent être personnalisés dans la partie de la déclaration de DownloadToFile. Vous pouvez essayer avec l'url exemple si vous voulez tester la macro. Le classeur abrechnungs_tool2.1.1.ods sera téléchargé.

Code

En LibreOffice Basic:

' Copyright (c) 2011 Frieder Delor, Mailto: delorfr@googlemail.com
' the function "GetPath" is originally from Copyright (c) 2011 Volker Lenhardt
'
'
' This program is free software; you can redistribute it and/or modify it under 
' the terms of the GNU General Public License as published by the Free Software
' Foundation; either version 2 of the License, or (at your option) any later 
' version.

' This program is distributed in the hope that it will be useful, but WITHOUT 
' ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
' FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.

' You should have received a copy of the GNU General Public License along with 
' this program; if not, write to the Free Software Foundation, Inc., 59 Temple 
' Place, Suite 330, Boston, MA 02111-1307 USA


Option Explicit

Sub DownloadToFile
    '''Sous-routine principale, déclare les paramètres pertinents vérifie le OS pour appeler d'autres sub spécifiques au OS.'''

    Dim iSystem%
    Dim sURL As String
    Dim sPath$ 

    ' Adapter l'adresse Internet (doit etre un lien de telechargement direct)
    sURL="http://wurzelmanager.blogger.de/getfile?name=abrechnungs_tool2.1.1.ods"

    ' Chemin sur le PC client
    sPath = GetPath	

    If sPath = "" Then
        MsgBox "Vous n'avez pas sélectionné de dossier" ,0 ,"Erreur"
        Exit Sub
    End if

    sPath =  ConvertFromUrl(sPath)
    sPath = sPath  & "abrechnungs_tool2.1.1.ods" ' ne pas oublier de personnaliser
    iSystem = GetGUIType

    Select Case iSystem 	
        Case 1 ' system Windows
  	    Win_Download (sURL, sPath )		
        Case 3 ' macOS
            MsgBox "Cette macro ne fonctionne pas sous Mac-OS." ,0 ,"Erreur"
        Case 4  ' Unix ou Linux
            Linux_Download (sURL, sPath )
        Case Else
            MsgBox "Le système n'a pas été détecté." ,0 ,"Erreur"
    End Select

End Sub ' DownloadToFile


Sub Linux_Download (sURL As String, sPath As String)
    '''Téléchargement pour un système GNU/Linux'''

    Dim iVar%,i%
    Dim dummy()
    If FileExists(sPath) Then
  	iVar = MsgBox ("le fichier " & Chr(10) & sPath & Chr(10) & " existe déjà." & Chr(10) & _
  	               "Remplacer le fichier existant ?",4,"Erreur")
  	If iVar = 7 Then Exit Sub  	
    End if

    ' Téléchargement
    Shell("wget -q " & sURL &" -O " & "'" & sPath & "'")

    For i = 1 To 10
        Wait 1000
        If FileExists(sPath) Then Exit For   ' attendre jusqu'à 10 que le telechargement soit terminé
        Next
        If Not FileExists(sPath) Then ' Erreur apres 10 secondes
            MsgBox "Le fichier ne pourra être téléchargé. " & Chr(10) & _
                "Merci de vérifier l'adresse internet." ,0, "Erreur"
            Exit Sub  
            Else
                MsgBox "Téléchargement terminé." ,0, "Réussi"
        End If 

End Sub ' Linux_Download


Sub Win_Download(sURL As String, sPath As String)
    '''Téléchargement pour un system Windows'''

    Dim iVar%

    If FileExists(sPath)Then 
        iVar = MsgBox ("Le fichier " & Chr(10) & sPath & Chr(10) & " existe déjà." & Chr(10) & _
                "Remplacer le fichier existant ?",4,"Erreur")
    If iVar = 7 Then Exit Sub
    End if

    'File downloading
    If DownloadFile(sURL, sPath) = False Then 
        MsgBox "Le fichier ne pourra être téléchargé. " & Chr(10) & _
            "Merci de vérifier l'adresse internet." ,0, "Erreur"
        Exit Sub
    Else
        MsgBox "Téléchargement terminé." ,0, "Réussi"
    End If 

End Sub ' Win_Download


' Declaration de la procedure "urlmon" de Windows API.
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
                       (ByVal pCaller As Long, _
                        ByVal szURL As String, _
                        ByVal szFileName As String, _
                        ByVal dwReserved As Long, _
                        ByVal lpfnCB As Long) As Long
                        

Public Function DownloadFile (URL As String, LocalFilename As String) As Boolean 
    Dim lngRetVal As Long
    lngRetVal = URLDownloadToFile(0, URL, LocalFilename, 0, 0) 
    If lngRetVal = 0 Then DownloadFile = True 
End Function ' DownloadFile



Function GetPath() As String
    '''Obtenir le dossier du dialogue de sélection des dossiers'''

    Dim  oPathSettings, oFolderDialog
    Dim sPath As String

    oPathSettings = CreateUnoService("com.sun.star.util.PathSettings")
    sPath = oPathSettings.Work
    oFolderDialog = _
          CreateUnoService("com.sun.star.ui.dialogs.FolderPicker")
    oFolderDialog.SetDisplayDirectory(sPath)
    If oFolderDialog.Execute() = com.sun.star.ui.dialogs.ExecutableDialogResults.OK Then
        sPath = oFolderDialog.GetDirectory
    Else
        GetPath = ""
        Exit Function
    End If

    If Right(sPath, 1) <> "/" Then sPath = sPath & "/"
    GetPath = sPath

End Function ' GetPath