Download einer Datei

    From The Document Foundation Wiki
    This page is a translated version of the page Macros/General/007 and the translation is 2% complete.


    Other languages:

    Description

    This macro downloads a file from a specified internet address to the local computer. It works Linux and Windows, but not on macOS at the moment. On Linux, the macro uses wget to download the file; while on Windows the macro uses the Windows API function urlmon. The internet address and the file name have to be customized in the declaration part of "DownloadToFile". You can try the actual data out, if you want to test the macro first. The German tool "accounting-tool" will be downloaded then.

    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
        '''<span lang="en" dir="ltr" class="mw-content-ltr">Master subroutine, declares relevant parameters checks OS to call other OS-specific subroutines.</span>'''
    
        Dim iSystem%
        Dim sURL As String
        Dim sPath$ 
    
        ' <span lang="en" dir="ltr" class="mw-content-ltr">Internet address have to be a direct link to the download</span>
        sURL="http://wurzelmanager.blogger.de/getfile?name=abrechnungs_tool2.1.1.ods"
    
        ' <span lang="en" dir="ltr" class="mw-content-ltr">Path on the client computer</span>
        sPath = GetPath	
    
        If sPath = "" Then
            MsgBox "<span lang="en" dir="ltr" class="mw-content-ltr">You have not selected a proper directory path</span>" ,0 ,"<span lang="en" dir="ltr" class="mw-content-ltr">Error</span>"
            Exit Sub
        End if
    
        sPath =  ConvertFromUrl(sPath)
        sPath = sPath  & "abrechnungs_tool2.1.1.ods" ' <span lang="en" dir="ltr" class="mw-content-ltr">please customize</span>
        iSystem = GetGUIType
    
        Select Case iSystem 	
            Case 1 ' <span lang="en" dir="ltr" class="mw-content-ltr">The operating system is Windows</span>
      	    Win_Download (sURL, sPath )		
            Case 3 ' macOS
                MsgBox "<span lang="en" dir="ltr" class="mw-content-ltr">This macro does not work under Mac-OS.</span>" ,0 ,"<span lang="en" dir="ltr" class="mw-content-ltr">Error</span>"
            Case 4  ' <span lang="en" dir="ltr" class="mw-content-ltr">Unix or Linux</span>
                Linux_Download (sURL, sPath )
            Case Else
                MsgBox "<span lang="en" dir="ltr" class="mw-content-ltr">The operating system was not detected.</span>" ,0 ,"<span lang="en" dir="ltr" class="mw-content-ltr">Error</span>"
        End Select
    
    End Sub ' DownloadToFile
    
    
    Sub Linux_Download (sURL As String, sPath As String)
        '''<span lang="en" dir="ltr" class="mw-content-ltr">Download implementation for GNU/Linux system</span>'''
    
        Dim iVar%,i%
        Dim dummy()
        If FileExists(sPath) Then
      	iVar = MsgBox ("<span lang="en" dir="ltr" class="mw-content-ltr">The file</span> " & Chr(10) & sPath & Chr(10) & " <span lang="en" dir="ltr" class="mw-content-ltr">exists already.</span>" & Chr(10) & _
      	               "<span lang="en" dir="ltr" class="mw-content-ltr">Should the existing file be replaced?</span>",4,"<span lang="en" dir="ltr" class="mw-content-ltr">Error</span>")
      	If iVar = 7 Then Exit Sub  	
        End if
    
        ' <span lang="en" dir="ltr" class="mw-content-ltr">File downloading</span>
        Shell("wget -q " & sURL &" -O " & "'" & sPath & "'")
    
        For i = 1 To 10
            Wait 1000
            If FileExists(sPath) Then Exit For   ' <span lang="en" dir="ltr" class="mw-content-ltr">wait up to 10 seconds until the download is finished</span>
            Next
            If Not FileExists(sPath) Then ' <span lang="en" dir="ltr" class="mw-content-ltr">Error after 10 seconds</span>
                MsgBox "<span lang="en" dir="ltr" class="mw-content-ltr">The file couldn't be downloaded.</span> " & Chr(10) & _
                    "<span lang="en" dir="ltr" class="mw-content-ltr">Please double check the internet address.</span>" ,0, "<span lang="en" dir="ltr" class="mw-content-ltr">Error</span>"
                Exit Sub  
                Else
                    MsgBox "<span lang="en" dir="ltr" class="mw-content-ltr">The download was completed.</span>" ,0, "<span lang="en" dir="ltr" class="mw-content-ltr">Successful</span>"
            End If 
    
    End Sub ' Linux_Download
    
    
    Sub Win_Download(sURL As String, sPath As String)
        '''<span lang="en" dir="ltr" class="mw-content-ltr">Download implementation for Windows system</span>'''
    
        Dim iVar%
    
        If FileExists(sPath)Then 
            iVar = MsgBox ("<span lang="en" dir="ltr" class="mw-content-ltr">The file</span> " & Chr(10) & sPath & Chr(10) & " <span lang="en" dir="ltr" class="mw-content-ltr">already exists.</span>" & Chr(10) & _
                    "<span lang="en" dir="ltr" class="mw-content-ltr">Should the existing file be replaced?</span>",4,"<span lang="en" dir="ltr" class="mw-content-ltr">Error</span>")
        If iVar = 7 Then Exit Sub
        End if
    
        'File downloading
        If DownloadFile(sURL, sPath) = False Then 
            MsgBox "<span lang="en" dir="ltr" class="mw-content-ltr">The file couldn't be downloaded.</span> " & Chr(10) & _
                "<span lang="en" dir="ltr" class="mw-content-ltr">Please double check the internet address.</span>" ,0, "<span lang="en" dir="ltr" class="mw-content-ltr">Error</span>"
            Exit Sub
        Else
            MsgBox "<span lang="en" dir="ltr" class="mw-content-ltr">The download was completed.</span>" ,0, "<span lang="en" dir="ltr" class="mw-content-ltr">Successful</span>"
        End If 
    
    End Sub ' Win_Download
    
    
    ' <span lang="en" dir="ltr" class="mw-content-ltr">Open the procedure "urlmon" from Windows API.</span>
    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
        '''<span lang="en" dir="ltr" class="mw-content-ltr">Get the folder of the folder selection dialog</span>'''
    
        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