[[20230622182748]]　『画像を全て同じサイズでずれずに挿入したい』（VBA初心者）　ページの最後に飛ぶ

『画像を全て同じサイズでずれずに挿入したい』（VBA初心者）

以下のコードを作成して、一括で画像をセルに挿入するようにしましたが、実際に実行してみると縦長の画像を張り付ける際には、貼り付け位置がずれてしまいます。（横長の画像は全て問題なく貼り付けができています。）
過去ログを調べてみましたが分からず、初歩的な質問で恐れ入りますが、コードの修正箇所をご教授いただけましたら幸いです。よろしくお願いします。

Sub InsertImages()

    Dim ws As Worksheet
    Dim lastRow As Long
    Dim filePath As String
    Dim fileName As String
    Dim img As Picture
    ' 全てのシートに対して処理を実行
    For Each ws In ThisWorkbook.Sheets
        ws.Activate
        ' 最終行を取得
        lastRow = Cells(Rows.Count, "A").End(xlUp).Row
        ' 各行のA列の値に対応するファイルを検索して画像を挿入
        For i = 1 To lastRow
            filePath = ThisWorkbook.Path & "\" & Cells(i, "A").Value & ".jpg" ' ファイルパスを作成
            fileName = Dir(filePath) ' ファイルが存在するかチェック
            If fileName <> "" Then ' ファイルが存在する場合
                Set img = ws.Pictures.Insert(filePath) ' 画像を挿入
                With img
                    .ShapeRange.LockAspectRatio = msoFalse ' アスペクト比を固定解除
                    .Top = Cells(i, "J").Top ' D列のセルの上部に配置
                    .Left = Cells(i, "J").Left ' D列のセルの左側に配置
                    .Width = Cells(i, "J").Width
                    .Height = Cells(i, "J").Height
                    .ShapeRange.Line.Visible = msoTrue
                    .ShapeRange.Line.ForeColor.RGB = RGB(0, 0, 0)   '色の指定（黒）
                   End With
            End If
        Next i
    Next ws
End Sub

＜使用 Excel：Excel2016、使用 OS：Windows10 ＞

 私の手元では再現しません。（Excel2019,Windows10）
 とりあえず下記について、示してください。
 1．Zoomは100%ですか？
 2. 縦長と横長の画像の出所は同じですか？
 3. ステップ実行しても変化なしですか？
 4. Top,Left,Width,Heightのどの設定で、想定と違ってきますか？
 5. 全く新しいブックでも再現しますか。
 6. ネットで同様の事象に関する記事はないですか？

（xyz） 2023/06/23(金) 07:21:34

（xyz）さん
昨日に続きありがとうございます。

1.Zoomは100％です。
2.スマホ(iPhone)とタブレット(iPad)で撮影した画像が元となります。
3.結果は変わりませんでした。
4.ステップ実行してみたところ、
.Left = Cells(i, "I").Left ' D列のセルの左側に配置
を実行した際に画像が本来の位置より何故か上に移動してしまっているようです。
5.新しいブックで試すと画像のサイズ（縦・横）まで指定したサイズではなく崩れてしまいました。
6.画像挿入時にずれるという記事はいくつか見つけたのですが、縦長の画像だけというのは見つけられていませんでした。一応、アスペクト比の解除を追記してみたのですが、上手くできておりません。

使用している元画像の解像度が縦長の画像は4032×3024ピクセルですが何か影響がありますでしょうか。

（VBA初心者） 2023/06/23(金) 08:50:01

 画像を挿入した直後から、横長の画像を90度回転させた状態になってませんか？
 Exifの画像の向きを反映しているのだと思います

 TOPプロパティは回転角が0度の時の位置で、回転の中心が画像の中心にあるので、
 回転角90度だと頭がちょっと飛び出す状態になっているのだと思います。

 回転角を調べて、90度の時は (Width-Height)\2だけTOPを調整してやればいいような気がします。
（´・ω・`） 2023/06/23(金) 09:58:38

 雰囲気だけくみ取ってもらえれば
    Sub trial()
       Dim path As String, jpg As String, RowPos As Long
       path = "D:test\"
       jpg = Dir(path & "*.jpg")
       RowPos = 1
       Do While jpg <> ""
         With ActiveSheet.Pictures.Insert(path & jpg)
             Select Case .ShapeRange.Rotation
                Case 0, 180
                   .Height = Cells(RowPos, "D").Height
                   .Top = Cells(RowPos, "D").Top
                   .Left = Cells(RowPos, "D").Left
                Case 90, 270
                   .Width = Cells(RowPos, "D").Height
                   .Top = Cells(RowPos, "D").Top + (.Width - .Height) / 2
                   .Left = Cells(RowPos, "D").Left - (.Width - .Height) / 2
             End Select
             RowPos = RowPos + 1
         End With
         jpg = Dir
       Loop
    End Sub
（´・ω・`） 2023/06/23(金) 10:15:22

（´・ω・`）さん
ご助言ありがとうございます。私の環境では、縦横がいれかわることにならずに只位置がずれるといった状況でした。いただいたご助言をもとに色々試した結果、以下のことが分かりました。

1.画像のピクセルを予めExcel以外のソフトで縮小したら上手くセルのサイズに合わせて貼り付けができました。
2.画像をリサイズする処理の際、縦長の画像はセルのWeightとHeightが逆転してリサイズされていました。
（画像の縦・横の情報が誤認されている？）

もう少し試行錯誤してみます。ありがとうございました。
（VBA初心者） 2023/06/23(金) 11:07:08

 なんとなく私のいってることが分かってもらえてないような気がしますが、
 解決できそうならそれでいいです
（´・ω・`） 2023/06/23(金) 13:11:48

 質問者さん向けの簡単な解説（さわりの部分だけ）です。

 以下のコードを実行してみてください。
     ・図形（正方形ではない長方形）を描画
     ・Left,Topをデバグ出力
     ・90度右回転
     ・再度、Left,Topを出力すると、
       現実の図形は回転されているので、
       LeftもTopも前とは変わると想定するが、
       意に反して、前と同じものが表示されるのである。
       （どうやら、実際のものは、内部でrotationプロパティの数値をもとに、
        再計算させているものと見られる。）

 Sub test()
     Dim sp As Shape
     Set sp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, 100, 50, 70, 140)
     Debug.Print sp.Left; sp.Top     '100 50 が出力される
     sp.IncrementRotation 90         ' 90度回転
     Debug.Print sp.Left; sp.Top     '100 50 が出力される（驚き!)
 End Sub

 画像でも同じようなことが起きていると想像されるということです。
 ・rotationプロパティに相当するものが画像データに含まれていて、
 ・それを読み込んだときにrotationプロパティに反映されているものと思われる。
 ・この状態では、TopもLeftも実際のものとは違うのですよ。
      （上のテストの状況と同じです）
 と、まあこういうことなんでしょう。

 以前こちらのサイトで同じ話の議論に加わったことがあります。
 スタートラインにつければ幸いです。
（xyz） 2023/06/23(金) 16:08:26

（xyz）さん
分かりやすく具体例をお示しいただき、誠にありがとうございます。

仰る通りに実行してみましたところ、確かに回転後の図形のTop/Leftも変更されていませんでした。
このことを念頭に当初のこちらの環境でもう一度ステップ実行してみたところTop/Leftの移動処理を行うところから一部の画像でセルの縦横の指定値が正しく取得できていないことが分かりました。

今回は急ぐためとりあえず代替案として正方形にセル及び画像を指定した上で、天地さえ気を付けて配置すれば良い事にしましたが、より理解を深めるため、今後も検証してみたいと思います。

今回も大変勉強になりました。また機会がありましたらよろしくお願いします。

（VBA初心者） 2023/06/23(金) 17:26:34

コメント返信：

[ 一覧(最新更新順) ]

[[20230622182748]] 『画像を全て同じサイズでずれずに挿入したい』（VBA初心者） ページの最後に飛ぶ

[[20230622182748]]　『画像を全て同じサイズでずれずに挿入したい』（VBA初心者）　ページの最後に飛ぶ