VBA を使用してWeb上の画像を貼り付ける方法（40321の追加質問です）

###実現したいこと

下記の質問への回答に対する追加質問で、
画像を取り込んだ後のペースト方法についてです：
https://teratail.com/questions/40321

URLから画像は取り込めましたが、
左上を起点としてペーストされます。

以下のようなペースト方法についてアドバイスをいただければ助かります：

１．セルのセンター（上下左右）への配置
２．縦横比を保持したたまま、セルサイズに合わせてリサイズ

調べてみたのですが、的確な回答をまだ見つけられていないので、ここで質問させていただく次第です。

下記、使用したコードです：
後半"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件

ベストアンサー

.Shapes.AddPicture ではなく .Pictures.Insert を使ってならこんな感じです

Dim objPic As Object

・・・

With Cells(i, 2) 

Set objPic = ActiveSheet.Pictures.Insert(strFname)

'縦横の縮尺を保持しながらセルサイズに合わせる
myH = .Height / objPic.Height
myW = .Width / objPic.Width
If myH > myW Then
  objPic.Height = objPic.Height * myW
  objPic.Width = .Width
Else
  objPic.Height = .Height
  objPic.Width = objPic.Width * myH
End If

'セルの中央へ配置
objPic.Top = .Top + ((.Height - objPic.Height) / 2)
objPic.Left = .Left + ((.Width - objPic.Width) / 2)

Set objPic = Nothing

End With