質問編集履歴
1
追記
test
CHANGED
File without changes
|
test
CHANGED
@@ -12,7 +12,11 @@
|
|
12
12
|
|
13
13
|
|
14
14
|
|
15
|
+
```lang-VBA
|
16
|
+
|
15
17
|
ActiveSheet.Pictures.Insert("{画像URL}").Select
|
18
|
+
|
19
|
+
```
|
16
20
|
|
17
21
|
|
18
22
|
|
@@ -31,3 +35,75 @@
|
|
31
35
|
|
32
36
|
|
33
37
|
現状この方法では貼り付ける事は出来ないのでしょうか?
|
38
|
+
|
39
|
+
|
40
|
+
|
41
|
+
|
42
|
+
|
43
|
+
※追記
|
44
|
+
|
45
|
+
以下の方法で画像の貼り付けは出来たのですが、
|
46
|
+
|
47
|
+
画像のサイズがセルのサイズとなってしまい、縦横比率がおかしくなってしまいます。
|
48
|
+
|
49
|
+
縦横比率を保つようにする事は可能なのでしょうか?
|
50
|
+
|
51
|
+
|
52
|
+
|
53
|
+
```lang-VBA
|
54
|
+
|
55
|
+
Private Declare Function URLDownloadToFile Lib "urlmon" Alias _
|
56
|
+
|
57
|
+
"URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal _
|
58
|
+
|
59
|
+
szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
|
60
|
+
|
61
|
+
|
62
|
+
|
63
|
+
Sub PicDownLoad()
|
64
|
+
|
65
|
+
Dim strFname As String, strUrl As String
|
66
|
+
|
67
|
+
Dim retValue As Long, i As Long
|
68
|
+
|
69
|
+
Dim endRow As Long
|
70
|
+
|
71
|
+
endRow = Cells(Rows.Count, 1).End(xlUp).Row
|
72
|
+
|
73
|
+
For i = 1 To endRow
|
74
|
+
|
75
|
+
strUrl = Cells(i, 1).Text
|
76
|
+
|
77
|
+
If strUrl <> "" Then
|
78
|
+
|
79
|
+
strFname = "D:\rinji\" & Mid(strUrl, InStrRev(strUrl, "/") + 1)
|
80
|
+
|
81
|
+
retValue = URLDownloadToFile(0, strUrl, strFname, 0, 0)
|
82
|
+
|
83
|
+
If retValu = 0 Then
|
84
|
+
|
85
|
+
With Cells(i, 2)
|
86
|
+
|
87
|
+
Set objShape = ActiveSheet.Shapes.AddPicture( _
|
88
|
+
|
89
|
+
Filename:=strFname, LinkToFile:=False, _
|
90
|
+
|
91
|
+
SaveWithDocument:=True, Left:=.Left, _
|
92
|
+
|
93
|
+
Top:=.Top, Width:=.Width, Height:=.Height)
|
94
|
+
|
95
|
+
End With
|
96
|
+
|
97
|
+
Else
|
98
|
+
|
99
|
+
MsgBox "DownLoad Fail " & Chr(10) & strUrl
|
100
|
+
|
101
|
+
End If
|
102
|
+
|
103
|
+
End If
|
104
|
+
|
105
|
+
Next i
|
106
|
+
|
107
|
+
End Sub
|
108
|
+
|
109
|
+
```
|