###実現したいこと
下記の質問への回答に対する追加質問で、
画像を取り込んだ後のペースト方法についてです:
https://teratail.com/questions/40321
URLから画像は取り込めましたが、
左上を起点としてペーストされます。
以下のようなペースト方法についてアドバイスをいただければ助かります:
1.セルのセンター(上下左右)への配置
2.縦横比を保持したたまま、セルサイズに合わせてリサイズ
調べてみたのですが、的確な回答をまだ見つけられていないので、ここで質問させていただく次第です。
下記、使用したコードです:
後半"Set objShape"以降の部分になると思いますが、詳しい方のアドバイスをいただければと思います。
###該当のソースコード
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
Sub GetPicture()
Dim strFname As String, strURL As String
Dim retValue As Long, i As Long
Dim endRow As Long
Dim objShape As Object
endRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To endRow
strURL = Cells(i, 1).Text
If strURL <> "" Then
strFname = "C:DownloadPic" & Mid(strURL, InStrRev(strURL, "/") + 1)
retValue = URLDownloadToFile(0, strURL, strFname, 0, 0)
If retValue = 0 Then
With Cells(i, 2)
Set objShape = ActiveSheet.Shapes.AddPicture( _
Filename:=strFname, LinkToFile:=False, _
SaveWithDocument:=True, Left:=.Left, _
Top:=.Top, Width:=0, Height:=0)
With objShape
.ScaleHeight 1!, msoTrue
.ScaleWidth 1!, msoTrue
.ScaleHeight 30! / .Width, msoTrue
.ScaleWidth 30! / .Width, msoTrue
End With
Set objShape = Nothing
End With
Else
MsgBox "Complete"
End If
End If
Next i
End Sub
回答1件
あなたの回答
tips
プレビュー
バッドをするには、ログインかつ
こちらの条件を満たす必要があります。
2016/07/14 15:04