画像が指定したセルにおさまらない

投稿者 : ももネクター     投稿日時 : 2025/05/27(Tue) 13:48:50     OS : Windows 11     EXCEL : Excel 2021

---

素人です。
iphoneで撮影した縦型の画像(3024×4032)がセルから縦がはみ出ます。
(3120×4160の場合ははみ出ない)
解決策を教えてください。

－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim i As Long
    Dim j As Long
    Dim FileName As Variant
    Dim rX As Double, rY As Double
    
    If ActiveCell.Value Like "ダブルクリックで*" Then
    
        FileName = Application.GetOpenFilename( _
            FileFilter:="画像ファイル,*.bmp;*.jpg;*.gif", _
            MultiSelect:=True)
        If Not IsArray(FileName) Then
            Exit Sub
        End If
        For Each sp In ActiveSheet.Shapes
        If sp.TopLeftCell.Column = 1 Then
            sp.Delete
        End If

        Next
        j = 1
        For i = LBound(FileName) To UBound(FileName)
        
        With ActiveSheet.Shapes.AddPicture( _
            FileName:=FileName(i), _
            LinkToFile:=False, _
            SaveWithDocument:=True, _
            Left:=Selection.Left, _
            Top:=Selection.Top, _
            Width:=-1, _
            Height:=-1)
            
            '縦横比を固定
            .LockAspectRatio = msoTrue
            'セルにあわせて移動やサイズ変更
            .Placement = xlMoveAndSize
            '一旦、元のサイズに戻す
            .ScaleHeight 1, msoTrue
            .ScaleWidth 1, msoTrue
            
        rX = Target.Width / .Width
        rY = Target.Height / .Height
        If rX > rY Then
            .Height = .Height * rY
        Else
            .Width = .Width * rX
        End If

        'セルの中央（横方向/縦方向の中央）に配置
        .Left = Target.Left + (Target.Width - .Width) / 2
        .Top = Target.Top + (Target.Height - .Height) / 2

        End With
        
        j = j + 1
        Next i

        Cancel = True

    End If
    
End Sub

－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

投稿者 : てらてら     投稿日時 : 2025/05/27(Tue) 19:52:19

---

こんにちは。
提示されたコードで試してみましたが正常に動作するようです。

iPhoneで撮影した縦型の画像という事なので、jpgでしたら横向き情報が付いているのかもしれません。
ペイントで保存し直すと治るかもしれません。
https://help-vba.com/jpg-rotate/

ちなみに横向き情報が付いた画像ではセルからはみ出ました。

外していたらごめんなさい。

投稿者 : ももネクター     投稿日時 : 2025/05/28(Wed) 10:39:05

---

てらてらさん
ペイントで保存することで解決しました。
ありがとうございました。