マクロ/全般/007
Appearance
TDF LibreOffice Document Liberation Project Community Blogs Weblate Nextcloud Redmine Ask LibreOffice Donate
説明
このマクロは、指定されたインターネットアドレスからローカル コンピュータにファイルをダウンロードします。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