Macros
From The Document Foundation Wiki
TDF LibreOffice Blogs communautaires Pootle (traduction) TestLink ODFAuthors Nextcloud Redmine Ask LibreOffice | Donner
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