Download einer Datei

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

TDF LibreOffice Document Liberation Project Community Blogs Weblate Nextcloud Redmine Ask LibreOffice Spende

Other languages:

Beschreibung

Dieses Makro lädt eine Datei von einer angegebenen Internetadresse auf den lokalen Computer herunter. Es arbeitet unter Linux und unter Windows, aber momentan nicht unter MacOS. Unter Linux verwendet das Makro wget um die Datei herunter zu laden. Unter Windows wird die Windows API Funktion urlmon verwendet. Die Internetadresse und der Dateiname werden im Deklarationsteil von "DownloadToFile" angepasst. Sie können die aktuellen Daten verwenden um das Makro auszuprobieren. Das deutsche Tool "Abrechungs-Tool" wird heruntergeladen.

Code

In 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
    '''Master Subroutine, deklariert relevante Parameter, überprüft das Betriebssystem um Betriebssystem andere spezifische Unterroutinen aufzurufen.'''

    Dim iSystem%
    Dim sURL As String
    Dim sPath$ 

    ' Internetadressen müssen einen direkten Link zum Download haben
    sURL="http://wurzelmanager.blogger.de/getfile?name=abrechnungs_tool2.1.1.ods"

    ' Pfad am Client
    sPath = GetPath	

    If sPath = "" Then
        MsgBox "Es wurde kein korrekter Dateipfad angegeben" ,0 ,"Fehler"
        Exit Sub
    End if

    sPath =  ConvertFromUrl(sPath)
    sPath = sPath  & "abrechnungs_tool2.1.1.ods" ' bitte anpassen
    iSystem = GetGUIType

    Select Case iSystem 	
        Case 1 ' das Betriebssystem ist Windows
  	    Win_Download (sURL, sPath )		
        Case 3 ' macOS
            MsgBox "Dieses Makro arbeitet nicht unter MacOS." ,0 ,"Fehler"
        Case 4  ' Unix oder Linux
            Linux_Download (sURL, sPath )
        Case Else
            MsgBox "Das Betriebssystem konnte nicht ermittelt werden." ,0 ,"Fehler"
    End Select

End Sub ' DownloadToFile


Sub Linux_Download (sURL As String, sPath As String)
    '''die Implementierung für GNU/Linux herunterladen'''

    Dim iVar%,i%
    Dim dummy()
    If FileExists(sPath) Then
  	iVar = MsgBox ("Die Datei " & Chr(10) & sPath & Chr(10) & " existiert bereits." & Chr(10) & _
  	               "Soll die existierende Datei ersetzt werden?",4,"Fehler")
  	If iVar = 7 Then Exit Sub  	
    End if

    ' Datei wird heruntergeladen
    Shell("wget -q " & sURL &" -O " & "'" & sPath & "'")

    For i = 1 To 10
        Wait 1000
        If FileExists(sPath) Then Exit For   ' 10 Sekunden warten bis der Download beendedt wurde
        Next
        If Not FileExists(sPath) Then ' Fehler nach 10 Sekunden
            MsgBox "Die Datei konnte nicht heruntergeladen werden. " & Chr(10) & _
                "Bitte die Internetadresse kontrollieren." ,0, "Fehler"
            Exit Sub  
            Else
                MsgBox "Der Download wurde abgeschlossen." ,0, "Erfolgreich"
        End If 

End Sub ' Linux_Download


Sub Win_Download(sURL As String, sPath As String)
    '''die Implementierung für Windows herunterladen'''

    Dim iVar%

    If FileExists(sPath)Then 
        iVar = MsgBox ("Die Datei " & Chr(10) & sPath & Chr(10) & " existiert bereits." & Chr(10) & _
                "Soll die existierende Datei ersetzt werden?",4,"Fehler")
    If iVar = 7 Then Exit Sub
    End if

    'File downloading
    If DownloadFile(sURL, sPath) = False Then 
        MsgBox "Die Datei konnte nicht heruntergeladen werden. " & Chr(10) & _
            "Bitte die Internetadresse kontrollieren." ,0, "Fehler"
        Exit Sub
    Else
        MsgBox "Der Download wurde abgeschlossen." ,0, "Erfolgreich"
    End If 

End Sub ' Win_Download


' Öffnet die Prozedur "urlmon" der 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
    '''Holt den Ordner aus dem Ordner-Auswahl-Dialog'''

    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