Jump to content

マクロ/全般/007

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


説明

このマクロは、指定されたインターネットアドレスからローカル コンピュータにファイルをダウンロードします。Linux と Windows では動作しますが、現時点ではmacOSでは動作しません。Linuxでは、マクロは wget を使用してファイルをダウンロードします。Windowsでは、マクロは Windows API 関数 urlmon を使用します。インターネットアドレスとファイル名は、"DownloadToFile" の宣言部分でカスタマイズする必要があります。最初にマクロをテストしたい場合は、実際のデータを試すことができます。このコードで ドイツ語のツール "accounting-tool" がダウンロードされます。

Code

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
    '''マスター・サブルーチンで、関連するパラメータを宣言し、他のOS固有のサブルーチンを呼び出すためにOSをチェックします'''

    Dim iSystem%
    Dim sURL As String
    Dim sPath$ 

    ' インターネットアドレスはダウンロードへの直接リンクである必要があります
    sURL="http://wurzelmanager.blogger.de/getfile?name=abrechnungs_tool2.1.1.ods"

    ' クライアントコンピュータ上のパス
    sPath = GetPath	

    If sPath = "" Then
        MsgBox "正しいディレクトリパスが選択されていません" ,0 ,"エラー"
        Exit Sub
    End if

    sPath =  ConvertFromUrl(sPath)
    sPath = sPath  & "abrechnungs_tool2.1.1.ods" ' カスタマイズしてください
    iSystem = GetGUIType

    Select Case iSystem 	
        Case 1 ' オペレーティングシステムはWindowsです
  	    Win_Download (sURL, sPath )		
        Case 3 ' macOS
            MsgBox "このマクロはMac-OSでは動作しません" ,0 ,"エラー"
        Case 4  ' Unix または Linux
            Linux_Download (sURL, sPath )
        Case Else
            MsgBox "OSが認識されませんでした" ,0 ,"エラー"
    End Select

End Sub ' DownloadToFile


Sub Linux_Download (sURL As String, sPath As String)
    '''GNU/Linuxシステムの実装をダウンロードする'''

    Dim iVar%,i%
    Dim dummy()
    If FileExists(sPath) Then
  	iVar = MsgBox ("ファイルは " & Chr(10) & sPath & Chr(10) & " 既に存在します" & Chr(10) & _
  	               "既存のファイルを置き換える必要がありますか?",4,"エラー")
  	If iVar = 7 Then Exit Sub  	
    End if

    ' ファイルをダウンロードしています
    Shell("wget -q " & sURL &" -O " & "'" & sPath & "'")

    For i = 1 To 10
        Wait 1000
        If FileExists(sPath) Then Exit For   ' ダウンロードが完了するまで最大10秒待ちます
        Next
        If Not FileExists(sPath) Then ' 10秒後にエラー
            MsgBox "ファイルをダウンロードできませんでした " & Chr(10) & _
                "インターネットのアドレスを再確認してください" ,0, "エラー"
            Exit Sub  
            Else
                MsgBox "ダウンロードが完了しました" ,0, "成功"
        End If 

End Sub ' Linux_Download


Sub Win_Download(sURL As String, sPath As String)
    '''Windowsシステムの実装をダウンロード'''

    Dim iVar%

    If FileExists(sPath)Then 
        iVar = MsgBox ("ファイルは " & Chr(10) & sPath & Chr(10) & " 既に存在します" & Chr(10) & _
                "既存のファイルを置き換える必要がありますか?",4,"エラー")
    If iVar = 7 Then Exit Sub
    End if

    'File downloading
    If DownloadFile(sURL, sPath) = False Then 
        MsgBox "ファイルをダウンロードできませんでした " & Chr(10) & _
            "インターネットのアドレスを再確認してください" ,0, "エラー"
        Exit Sub
    Else
        MsgBox "ダウンロードが完了しました" ,0, "成功"
    End If 

End Sub ' Win_Download


' Windows APIからプロシージャ"urlmon"を開きます。
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
    '''フォルダ選択ダイアログのフォルダを取得'''

    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