VBAでエクセルに写真を挿入して回転がおかしいとき

先日、仕事で写真をエクセルに一括挿入するVBAのツールを作成してちょっとはまりました。

ツールは画像挿入ボタンを押すと、決まったフォーマットに順次写真を挿入していくものなのですが、発注者が試したところ写真がセルからずれていたりとおかしいものがあるから見てほしいとのことでした。

自分でツールを回しても、ピッタリセルに合います。おかしなところはなさそうです。フォーマットのセルに挿入する際にサイズはセルに合わせるようにし、位置はセンターに来るようにしてはいます。処理はこんな感じ。※サンプルなので１枚挿入パターン。

Option Explicit
Public Sub InsertPicture()

    
    Dim mySh As Worksheet
    Dim myRng As Range
    Dim shp As Shape
    Dim picPath As String
    Dim picWidth As Double
    Dim picHeight As Double
    
    
        Application.ScreenUpdating = False
        
        Set mySh = ThisWorkbook.Sheets("test")
        
        picPath = "D:\test\sample.jpg"

        '既存の図を全て削除
        For Each shp In mySh.Shapes
            shp.Delete
        Next

        Set myRng = mySh.Range("A1")
        
        With myRng
            picWidth = .Width * 0.992
            picHeight = .Height * 0.992
        End With
        
        '画像を挿入
        Set shp = ActiveSheet.Shapes.AddPicture( _
            Filename:=picPath, _
            LinkToFile:=False, _
            SaveWithDocument:=True, _
            Left:=myRng.Left + 1, _
            Top:=myRng.Top + 1, _
            Width:=0, Height:=0)

        shp.ScaleHeight 1!, msoTrue
        shp.ScaleWidth 1!, msoTrue
        shp.LockAspectRatio = msoTrue
        
        '画像サイズをセルサイズに調整
        With shp
            .Height = picHeight
            If .Width > picWidth Then
                .Width = picWidth
            End If
          
            .Left = myRng.Left + (picWidth / 2 - .Width / 2) + 0.9
            .Top = myRng.Top + (picHeight / 2 - .Height / 2) + 0.9
        End With
              
        Set shp = Nothing
        Set myRng = Nothing
        Set mySh = Nothing
        
        Application.ScreenUpdating = True
        

End Sub

発注者がツールを使って写真を落とし込んだエクセルファイルを見てみると、確かにずれていました。ずれているのは縦の画像が著しくはみ出ていたりするものばかりでした。

そこで落とし込んだエクセルファイルだけでなく写真も一緒に送ってもらい、同じ写真でツールを回してみました。きれいにセルサイズにピッタリ合っています。

再現できない・・・。

よくみると発注者側でツールを回して送ってもらったエクセルファイルでは位置がずれているのは、縦画像で確かに人が縦に写っているものです。

あれ？

送ってもらった写真を見ると、全て横画像です。なぜに縦で挿入されている。

発注者に聞いてみると、発注者のPCでは縦の写真は縦で表示されており写真は縦横混ざっているとのこと。自分のPCでは縦画像はない。

自分はWindows7。発注者はWindows10。

調べてみると、Windows7までは画像のExifの回転情報を認識しないとのこと。なので、自分のPCでは縦の回転情報はなく、横画像として認識してしまっている為でした。

で、縦画像がずれる問題は、Windows10でもVBAで縦画像をエクセルに挿入する際、写真の縦横のサイズを逆で認識してしまっていたためでした。

つまり、Windows10で回転の認識はでき、画像挿入した際、縦は縦として挿入されます。その後、VBAでセルにピッタリ合わせる際に画像の幅と高さを取得しているのですが、このときには回転の認識をせず、縦は横の幅高さ、横は縦の幅高さで取得してしまっているようです。

なんとまあ。

そこでいろいろ試行錯誤し、画像を一旦挿入しJPEGとして貼り付け直し、その後そのJPEGの縦横サイズを見るという、なんだかアナログチックな方法で両方のPCでうまくフォーマットのセル内にピッタリ収まるようにすることができました。

修正したコード

Option Explicit
Public Sub InsertPicture()

    
    Dim mySh As Worksheet
    Dim myRng As Range
    Dim shp As Shape
    Dim picPath As String
    Dim picWidth As Double
    Dim picHeight As Double
    
    
        Application.ScreenUpdating = False
        
        Set mySh = ThisWorkbook.Sheets("test")
        
        picPath = "D:\test\sample.jpg"

        '既存の図を全て削除
        For Each shp In mySh.Shapes
            shp.Delete
        Next

        Set myRng = mySh.Range("A1")
        
        With myRng
            picWidth = .Width * 0.992
            picHeight = .Height * 0.992
        End With
        
        '画像を挿入
        Set shp = ActiveSheet.Shapes.AddPicture( _
            Filename:=picPath, _
            LinkToFile:=False, _
            SaveWithDocument:=True, _
            Left:=myRng.Left + 1, _
            Top:=myRng.Top + 1, _
            Width:=0, Height:=0)
            
        shp.ScaleHeight 1!, msoTrue
        shp.ScaleWidth 1!, msoTrue
        shp.LockAspectRatio = msoTrue
         
        'Windowsの回転が認識できないためJPEGの図として貼り付け直す
        shp.Cut
        ActiveSheet.PasteSpecial Format:="図 (JPEG)", Link:=False

        With Selection.ShapeRange
            .Top = myRng.Top + 1
            .Left = myRng.Left + 1

            .Height = picHeight
            If .Width > picWidth Then
                .Width = picWidth
            End If

            .Left = myRng.Left + (picWidth / 2 - .Width / 2) + 0.9
            .Top = myRng.Top + (picHeight / 2 - .Height / 2) + 0.9
        End With
           
        Set shp = Nothing
        Set myRng = Nothing
        Set mySh = Nothing
        
        Application.ScreenUpdating = True
        

End Sub

45行目から59行目でWindowsの回転が認識できないためのJPEGの図として貼り付け直しています。

但し、JPEGの図として貼り付けを行った場合、画像の解像度は落ちます。今回自分が依頼されたツールは、A4サイズに６×４＝２４枚のサムネイル形式のフォーマットで小さいサイズなので、画像劣化は気になるほどではありませんでしたが、A4サイズ１枚に３枚の画像とかの場合は、見れるレベルか確認したほうがよいかと思います。

Windows7もWindowsアップデートとかで回転認識対応してくれませんかねえ。