回答編集履歴
5
コメント追加
test
CHANGED
|
@@ -43,6 +43,10 @@
|
|
|
43
43
|
'----------------------------------
|
|
44
44
|
|
|
45
45
|
' ダウンロード
|
|
46
|
+
|
|
47
|
+
' url ダウンロード先リンク（phpのリンクでも可）
|
|
48
|
+
|
|
49
|
+
' savedir ファイルの保存先フォルダ
|
|
46
50
|
|
|
47
51
|
Sub DownloadFile(url As String, savedir As String)
|
|
48
52
|
|
4
全体を追加
test
CHANGED
|
@@ -1,16 +1,28 @@
|
|
|
1
|
-
※勘違いしていたので修正
|
|
2
|
-
|
|
3
|
-
|
|
4
|
-
|
|
5
|
-
リンクから
|
|
1
|
+
phpのリンクから実際のダウンロード先を取得し、ファイル名を抽出して保存します。
|
|
6
|
-
|
|
7
|
-
HTTPのHEADメソッドを使います。
|
|
8
2
|
|
|
9
3
|
|
|
10
4
|
|
|
11
5
|
```VBA
|
|
12
6
|
|
|
7
|
+
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
|
|
8
|
+
|
|
9
|
+
(ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, _
|
|
10
|
+
|
|
11
|
+
ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
|
|
12
|
+
|
|
13
|
+
|
|
14
|
+
|
|
15
|
+
'----------------------------------
|
|
16
|
+
|
|
17
|
+
'リンクから本当のダウンロード先を得る関数。
|
|
18
|
+
|
|
19
|
+
'たとえば
|
|
20
|
+
|
|
21
|
+
'GetLocation("http://www.hogegege.jp/index.php?type=download&no=101")
|
|
22
|
+
|
|
23
|
+
'とすればrealUrlに本当のダウンロード先（ファイル名含む）が入る
|
|
24
|
+
|
|
13
|
-
Function GetLocation(url)
|
|
25
|
+
Function GetLocation(url As String) As String
|
|
14
26
|
|
|
15
27
|
Dim httpObj As Object
|
|
16
28
|
|
|
@@ -26,25 +38,91 @@
|
|
|
26
38
|
|
|
27
39
|
End Function
|
|
28
40
|
|
|
41
|
+
|
|
42
|
+
|
|
43
|
+
'----------------------------------
|
|
44
|
+
|
|
45
|
+
' ダウンロード
|
|
46
|
+
|
|
47
|
+
Sub DownloadFile(url As String, savedir As String)
|
|
48
|
+
|
|
49
|
+
Dim res, idx As Long
|
|
50
|
+
|
|
51
|
+
Dim realUrl, fname As String
|
|
52
|
+
|
|
53
|
+
Dim strPath As String
|
|
54
|
+
|
|
55
|
+
|
|
56
|
+
|
|
57
|
+
'指定した保存先ディレクトリの末尾にパス区切りが付いているかチェック
|
|
58
|
+
|
|
59
|
+
If Right(savedir, 1) <> "\" Then
|
|
60
|
+
|
|
61
|
+
savedir = savedir & "\"
|
|
62
|
+
|
|
63
|
+
End If
|
|
64
|
+
|
|
65
|
+
|
|
66
|
+
|
|
67
|
+
'urlからファイル名を抜き出す
|
|
68
|
+
|
|
69
|
+
realUrl = GetLocation(url)
|
|
70
|
+
|
|
71
|
+
idx = InStrRev(realUrl, "/")
|
|
72
|
+
|
|
73
|
+
fname = Mid(realUrl, idx + 1)
|
|
74
|
+
|
|
75
|
+
|
|
76
|
+
|
|
77
|
+
'保存するファイルパス・ファイル名を作成
|
|
78
|
+
|
|
79
|
+
strPath = savedir & fname
|
|
80
|
+
|
|
81
|
+
|
|
82
|
+
|
|
83
|
+
res = URLDownloadToFile(0, url, strPath, 0, 0)
|
|
84
|
+
|
|
85
|
+
If res = 0 Then
|
|
86
|
+
|
|
87
|
+
Debug.Print "ダウンロード完了: " & url
|
|
88
|
+
|
|
89
|
+
Else
|
|
90
|
+
|
|
91
|
+
Debug.Print "エラー： " & url
|
|
92
|
+
|
|
93
|
+
End If
|
|
94
|
+
|
|
95
|
+
End Sub
|
|
96
|
+
|
|
97
|
+
|
|
98
|
+
|
|
99
|
+
'----------------------------------
|
|
100
|
+
|
|
101
|
+
' テスト
|
|
102
|
+
|
|
103
|
+
Sub Test()
|
|
104
|
+
|
|
105
|
+
Dim ret, str, savedir
|
|
106
|
+
|
|
107
|
+
savedir = "C:\TEST\" '保存フォルダ
|
|
108
|
+
|
|
109
|
+
|
|
110
|
+
|
|
111
|
+
For Each s In Sheets(1).Range("A1:A10")
|
|
112
|
+
|
|
113
|
+
url = s.Value
|
|
114
|
+
|
|
115
|
+
ret = DownloadFile(url, savedir) 'ダウンロード実行
|
|
116
|
+
|
|
117
|
+
s.Offset(0, 1) = ret 'ダウンロード結果をB列に記録
|
|
118
|
+
|
|
119
|
+
Next
|
|
120
|
+
|
|
121
|
+
End Sub
|
|
122
|
+
|
|
29
123
|
```
|
|
30
124
|
|
|
31
125
|
|
|
32
|
-
|
|
33
|
-
つかいかた
|
|
34
|
-
|
|
35
|
-
|
|
36
|
-
|
|
37
|
-
たとえば
|
|
38
|
-
|
|
39
|
-
```
|
|
40
|
-
|
|
41
|
-
realUrl = GetLocation("http://www.hogegege.jp/index.php?type=download&no=101")
|
|
42
|
-
|
|
43
|
-
```
|
|
44
|
-
|
|
45
|
-
とすればrealUrlに本当のダウンロード先（ファイル名含む）が入るはずなので
|
|
46
|
-
|
|
47
|
-
あとは URLDownloadToFile()を使えばダウンロードできると思います。
|
|
48
126
|
|
|
49
127
|
|
|
50
128
|
|
3
test
CHANGED
|
@@ -42,7 +42,7 @@
|
|
|
42
42
|
|
|
43
43
|
```
|
|
44
44
|
|
|
45
|
-
とすればrealUrlに本当のダウンロード先が入るはずなので
|
|
45
|
+
とすればrealUrlに本当のダウンロード先（ファイル名含む）が入るはずなので
|
|
46
46
|
|
|
47
47
|
あとは URLDownloadToFile()を使えばダウンロードできると思います。
|
|
48
48
|
|
2
修正
test
CHANGED
|
@@ -1,54 +1,28 @@
|
|
|
1
|
-
|
|
1
|
+
※勘違いしていたので修正
|
|
2
2
|
|
|
3
|
-
filepath：ファイル保存先
|
|
4
3
|
|
|
5
|
-
※filepathは、途中のフォルダが存在しなかったり、保存先に同名のファイルが存在するとエラーになります。
|
|
6
4
|
|
|
7
|
-
|
|
5
|
+
リンクから本当のダウンロード先を得る関数。
|
|
8
6
|
|
|
9
|
-
|
|
7
|
+
HTTPのHEADメソッドを使います。
|
|
10
8
|
|
|
11
9
|
|
|
12
10
|
|
|
13
11
|
```VBA
|
|
14
12
|
|
|
15
|
-
Function
|
|
13
|
+
Function GetLocation(url)
|
|
16
|
-
|
|
17
|
-
|
|
18
14
|
|
|
19
15
|
Dim httpObj As Object
|
|
20
16
|
|
|
21
|
-
|
|
17
|
+
|
|
22
|
-
|
|
23
|
-
|
|
24
18
|
|
|
25
19
|
Set httpObj = CreateObject("MSXML2.ServerXMLHTTP")
|
|
26
20
|
|
|
27
|
-
httpObj.Open "
|
|
21
|
+
httpObj.Open "HEAD", url, False
|
|
28
22
|
|
|
29
23
|
httpObj.send
|
|
30
24
|
|
|
31
|
-
If httpObj.readyState = 4 Then
|
|
32
|
-
|
|
33
|
-
|
|
25
|
+
GetLocation = httpObj.getOption(-1) 'SXH_OPTION_URL
|
|
34
|
-
|
|
35
|
-
stream.Type = 1
|
|
36
|
-
|
|
37
|
-
stream.Open
|
|
38
|
-
|
|
39
|
-
stream.Write httpObj.responseBody
|
|
40
|
-
|
|
41
|
-
stream.savetofile filepath
|
|
42
|
-
|
|
43
|
-
stream.Close
|
|
44
|
-
|
|
45
|
-
Set httpObj = Nothing
|
|
46
|
-
|
|
47
|
-
Else
|
|
48
|
-
|
|
49
|
-
Debug.Print "エラー"
|
|
50
|
-
|
|
51
|
-
End If
|
|
52
26
|
|
|
53
27
|
End Function
|
|
54
28
|
|
|
@@ -58,11 +32,19 @@
|
|
|
58
32
|
|
|
59
33
|
つかいかた
|
|
60
34
|
|
|
35
|
+
|
|
36
|
+
|
|
37
|
+
たとえば
|
|
38
|
+
|
|
61
39
|
```
|
|
62
40
|
|
|
63
|
-
|
|
41
|
+
realUrl = GetLocation("http://www.hogegege.jp/index.php?type=download&no=101")
|
|
64
42
|
|
|
65
43
|
```
|
|
44
|
+
|
|
45
|
+
とすればrealUrlに本当のダウンロード先が入るはずなので
|
|
46
|
+
|
|
47
|
+
あとは URLDownloadToFile()を使えばダウンロードできると思います。
|
|
66
48
|
|
|
67
49
|
|
|
68
50
|
|
1
typo
test
CHANGED
|
@@ -4,7 +4,7 @@
|
|
|
4
4
|
|
|
5
5
|
※filepathは、途中のフォルダが存在しなかったり、保存先に同名のファイルが存在するとエラーになります。
|
|
6
6
|
|
|
7
|
-
※遷移したリンク先でhtmlページが出て
|
|
7
|
+
※遷移したリンク先でhtmlページが出てきてダウンロード同意ボタンを押さないといけないような場合は対応できないと思います。
|
|
8
8
|
|
|
9
9
|
※その他ダウンロードリンクの個別内容によってはエラーが出るかも。
|
|
10
10
|
|