Macros

From The Document Foundation Wiki
< Macros‎ | General‎ | 007
Jump to: navigation, search

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

Cette macro télécharge un fichier à partir d'une adresse internet sur l'ordinateur local. Elle ne fonctionne que sous Windows et Linux. Mac OS X 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é.


'Copyright (c) 2011 Frieder Delor, Mailto: delorfr@googlemail.com
'The Funktion "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
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 'Mac os
    MsgBox "Cette macro ne fonctionne pas sous Mac-OS." _
            ,0 ,"Error"
  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
'--------------------------------------------------------------------------------------------
Sub Linux_Download (sURL As String, sPath As String )
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
 
'---------------------------------------------------------------------
Sub Win_Download(sURL As String, sPath As String )
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
'Téléchargement
  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

'--------------------------------------------------------------------------------
'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 
'--------------------------------------------------------------------------
'Get the folder of the folder selection dialog
Function GetPath() As String
  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