質問編集履歴

1

追記

2016/07/07 00:29

投稿

future
future

スコア62

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
+ ```