画像抽出するVBAで画像を同じサイズにしたい

質問

サイトから画像を抽出する下記のVBAで、出力される結果について

（１）画像の縦横比（サイズ）をすべて同じにしたい
（２）（１）にあわせたセルのサイズにしたい
（３）２列出力を３列出力にしたい

のですが、どのようなソースに変更すればよいでしょうか？
教えていただけると幸いです。

Sub hoge()
　　Dim oIE As Object
　　Dim e As Object
　　Dim i As Long
　　Dim j As Long
　　ActiveSheet.DrawingObjects.Delete
　　Rows.RowHeight = 140
　　Columns.ColumnWidth = 40
　　Set oIE = CreateObject("InternetExplorer.Application")
　　oIE.Visible = True
　　oIE.navigate "https://pro.foto.ne.jp/free/products_list.php/cPath/21_28_71"
　　Do While oIE.Busy Or oIE.ReadyState <> 4
　　　　DoEvents
　　Loop
　　Range("A1").Select
　　i = 1: j = 1
　　For Each e In oIE.Document.getElementsByTagName("img")
　　　　If LCase(e.nameProp) Like "*.jpg" _
　　　　　　Or LCase(e.nameProp) Like "*.png" Then
　　　　　　Cells(i, j).Select
　　　　　　ActiveSheet.Pictures.Insert e.href
　　　　　　If j = 2 Then
　　　　　　　　i = i + 1
　　　　　　End If
　　　　　　If j = 1 Then
　　　　　　　　j = 2
　　　　　　Else
　　　　　　　　j = 1
　　　　　　End If
　　　　End If
　　Next
　　oIE.Quit
End Sub

回答No.1

ushi2015 · ベストアンサー

こんばんは
画像と言っても縦長横長が有るので縦横比統一は、縦長横長それぞれになります。
セルの縦横を決めてそこに入るように調整する事にして、
Sub test2()
　　Dim oIE As Object
　　Dim e As Object
　　Dim i As Long
　　Dim j As Long
　　Dim s As Shape
　　Dim x1 As Single
　　Dim y1 As Single
　　Const z1 As Single = 200
　　Const z2 As Single = 150
　　ActiveSheet.DrawingObjects.Delete
　　Rows.RowHeight = 150
　　Columns.ColumnWidth = 33
　　Set oIE = CreateObject("InternetExplorer.Application")
　　oIE.Visible = True
　　oIE.navigate "https://pro.foto.ne.jp/free/products_list.php/cPath/21_28_71"
　　Do While oIE.Busy Or oIE.ReadyState <> 4
　　　　DoEvents
　　Loop
　　i = 1: j = 1
　　For Each e In oIE.Document.getElementsByTagName("img")
　　　　If LCase(e.nameProp) Like "*.jpg" _
　　　　　　Or LCase(e.nameProp) Like "*.png" Then
　　　　　　Set s = ActiveSheet.Shapes(ActiveSheet.Pictures.Insert(e.href).Name)
　　　　　　With s
　　　　　　　　.LockAspectRatio = msoFalse　　 '固定解除
　　　　　　　　x1 = .Width　　　　　　　　　　 '横取得
　　　　　　　　y1 = .Height　　　　　　　　　　'縦取得
　　　　　　　　.Left = Cells(i, j).Left　　　　'左位置指定
　　　　　　　　.Top = Cells(i, j).Top　　　　 '上位置指定
　　　　　　　　If x1 > y1 Then　　　　　　　　 '縦横判定
　　　　　　　　　　.Width = z1　　　　　　　　 '横形
　　　　　　　　　　.Height = y1 * z1 / x1
　　　　　　　　Else
　　　　　　　　　　.Height = z2　　　　　　　　'縦形
　　　　　　　　　　.Width = x1 * z2 / y1
　　　　　　　　End If
　　　　　　End With
　　　　　　If j = 3 Then
　　　　　　　　i = i + 1
　　　　　　End If
　　　　　　If j = 1 Then
　　　　　　　　j = 2
　　　　　　ElseIf j = 2 Then
　　　　　　　　j = 3
　　　　　　Else
　　　　　　　　j = 1
　　　　　　End If
　　　　End If
　　Next
　　oIE.Quit
End Sub
こんな感じです。

補足

ご回答ありがとうございます。
ushi2015 様のご回答により、どんどん解決していきます。
大変感謝しておりますし、素晴らしいコードで満足しています。

もし可能でしたら、これに、画像が挿入されたセルを自動で黒枠を
付けたいのですが、そういうことは可能なのでしょうか？

お聞かせねがえたら幸いです。

回答No.2

ushi2015

こんにちは
黒枠って、罫線ですか？
Sub test2()
　　Dim oIE As Object
　　Dim e As Object
　　Dim i As Long
　　Dim j As Long
　　Dim s As Shape
　　Dim x1 As Single
　　Dim y1 As Single
　　Dim z1 As Single
　　Dim z2 As Single
　　ActiveSheet.DrawingObjects.Delete
　　ActiveSheet.UsedRange.Clear
　　Rows.RowHeight = 150
　　Columns.ColumnWidth = 33
　　z1 = 180
　　z2 = 148
　　Set oIE = CreateObject("InternetExplorer.Application")
　　oIE.Visible = True
　　oIE.navigate "https://pro.foto.ne.jp/free/products_list.php/cPath/21_28_71"
　　Do While oIE.Busy Or oIE.ReadyState <> 4
　　　　DoEvents
　　Loop
　　i = 1: j = 1
　　For Each e In oIE.Document.getElementsByTagName("img")
　　　　If LCase(e.nameProp) Like "*.jpg" _
　　　　　　Or LCase(e.nameProp) Like "*.png" Then
　　　　　　Set s = ActiveSheet.Shapes(ActiveSheet.Pictures.Insert(e.href).Name)
　　　　　　With s
　　　　　　　　.LockAspectRatio = msoFalse　　 '固定解除
　　　　　　　　x1 = .Width　　　　　　　　　　 '横取得
　　　　　　　　y1 = .Height　　　　　　　　　　'縦取得
　　　　　　　　.Left = Cells(i, j).Left + 2　　'左位置指定
　　　　　　　　.Top = Cells(i, j).Top + 2　　　'上位置指定
　　　　　　　　If x1 > y1 Then　　　　　　　　 '縦横判定
　　　　　　　　　　.Width = z1　　　　　　　　 '横形
　　　　　　　　　　.Height = y1 * z1 / x1
　　　　　　　　Else
　　　　　　　　　　.Height = z2　　　　　　　　'縦形
　　　　　　　　　　.Width = x1 * z2 / y1
　　　　　　　　End If
　　　　　　End With
　　　　　　Cells(i, j).BorderAround xlContinuous, xlThick
　　　　　　If j = 3 Then
　　　　　　　　i = i + 1
　　　　　　End If
　　　　　　If j = 1 Then
　　　　　　　　j = 2
　　　　　　ElseIf j = 2 Then
　　　　　　　　j = 3
　　　　　　Else
　　　　　　　　j = 1
　　　　　　End If
　　　　End If
　　Next
　　oIE.Quit
End Sub

お礼

大変ありがとうございした。
素晴らしいコードを記述していただき大変勉強になりましたし、実装できるようになりました。
素晴らしい知識の方に出会えたことがうれしく思います。
ありがとうございました。