先日、仕事で写真をエクセルに一括挿入するVBAのツールを作成してちょっとはまりました。
ツールは画像挿入ボタンを押すと、決まったフォーマットに順次写真を挿入していくものなのですが、発注者が試したところ写真がセルからずれていたりとおかしいものがあるから見てほしいとのことでした。
自分でツールを回しても、ピッタリセルに合います。おかしなところはなさそうです。フォーマットのセルに挿入する際にサイズはセルに合わせるようにし、位置はセンターに来るようにしてはいます。処理はこんな感じ。※サンプルなので１枚挿入パターン。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 |
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でうまくフォーマットのセル内にピッタリ収まるようにすることができました。
修正したコード
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 |
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アップデートとかで回転認識対応してくれませんかねえ。
コメント