[[20190905153610]]　『セルのサイズに合わせて画像挿入』（りあき）　ページの最後に飛ぶ

『セルのサイズに合わせて画像挿入』（りあき）

ＶＢＡ初心者です。
現在エクセルで写真帳を作っています。
ネットで拾ったコードを組み合わせ、写真がセルの中におさまるようにしております。しかし、横向き写真はセルの中におさまるのですが、縦向き写真の場合は上下がセルからはみだしてしまいます。
ちなみに縦横が同じサイズのセルに挿入するとちゃんとおさまります。
横長のセルでもおさまるようにできないでしょうか？
使用しているコードは以下です。

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean)

    Dim myF As Variant
    Dim mySp As Object
    Dim myAD1 As String
    Dim myAD2 As String
    Dim myHH As Double
    Dim myWW As Double
    Dim myHH2 As Double
    Dim myWW2 As Double

    If Not Intersect(Range("N:N"), Target) Is Nothing Then

Cancel = True

'===============画像選択
myF = Application.GetOpenFilename _
("jpg bmp tif png gif,*.jpg;*.bmp;*.tif;*.png;*.gif", , "画像の選択", , False)
If myF = False Then
MsgBox "画像を選択してください(終了)"
Exit Sub
End If

'===============画像の掃除
For Each mySp In ActiveSheet.Shapes
myAD1 = mySp.TopLeftCell.MergeArea.Address
myAD2 = Target.Address
If myAD1 = myAD2 Then mySp.Delete
Next

'===============画像の貼り付け

 Set mySp = ActiveSheet.Shapes.AddPicture(Filename:=myF, LinkToFile:=False, _
        SaveWithDocument:=True, Left:=Target.Left, Top:=Target.Top, _
        Width:=0, Height:=0)    '★　とりあえず　縦横０で。
    mySp.ScaleHeight 1, msoTrue '★元のサイズに戻す
    mySp.ScaleWidth 1, msoTrue  '★元のサイズに戻す
'===============タテヨコの縮尺を保持
 myHH = Target.Height / mySp.Height
    myWW = Target.Width / mySp.Width
    If myHH > myWW Then
        mySp.Height = mySp.Height * myWW
        mySp.Width = Target.Width
    Else
        mySp.Height = Target.Height
        mySp.Width = mySp.Width * myHH
    End If
'===============中央へ調整
myHH2 = (Target.Height / 2) - (mySp.Height / 2)
myWW2 = (Target.Width / 2) - (mySp.Width / 2)
mySp.Top = Target.Top + myHH2
mySp.Left = Target.Left + myWW2

Set mySp = Nothing
End If
End Sub

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

TIFF画像は貼れないような気がしますが、実際に使う画像形式は何でしょう？ TIFFとPNGが無いならば、画像を貼る前にImageオブジェクトで画像サイズを得る手が使えるかも知れません。（PNGの場合は、バイナリファイル扱いして画素数を直接調べる手もあります）

とりあえずは、セルの縦横比と画像の縦横比なんて気にせず、まずセル幅に合わせてリサイズしましょう。そして、リサイズ後の画像高さとセル高さを比べて、画像高さの方が大きいようならば、セル高さに合わせて再度リサイズすることで解決できると思います。
（???） 2019/09/05(木) 17:57

 ダメだー。手持ちの画像だと再現しなかったです。
 セルのサイズも色々変えてやってみましたけど、はみ出さない。
 縦横比が[1対9]くらい極端な画像も使ってみましたが、これもはみ出さない。
 ピクセル縦横比が正方形じゃないjpgも使ってみましたが、縦横比は狂ったままでも、はみ出しはしない。

 どういう条件下での現状なんでしょうね...?
 (どなたか再現出来ますか?)

 ↓はセルに合せてリサイズする部分だけ別の方法に変えたものですが、これもはみ出しますかね?

    Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean)
        Dim myF As Variant
        Dim mySp As Object
        Dim myAD1 As String
        Dim myAD2 As String
        Dim myHH As Double
        Dim myWW As Double
        Dim myHH2 As Double
        Dim myWW2 As Double
        If Not Intersect(Range("N:N"), Target) Is Nothing Then
            Cancel = True
    '===============画像選択
            myF = Application.GetOpenFilename("jpg bmp tif png gif,*.jpg;*.bmp;*.tif;*.png;*.gif", , "画像の選択", , False)
            If myF = False Then
                MsgBox "画像を選択してください(終了)"
                Exit Sub
            End If
    '===============画像の掃除
            For Each mySp In ActiveSheet.Shapes
                myAD1 = mySp.TopLeftCell.MergeArea.Address
                myAD2 = Target.Address
                If myAD1 = myAD2 Then mySp.Delete
            Next
    '===============画像の貼り付け
            Set mySp = ActiveSheet.Shapes.AddPicture(Filename:=myF, LinkToFile:=False, SaveWithDocument:=True, Left:=Target.Left, Top:=Target.Top, Width:=0, Height:=0)
            mySp.ScaleHeight 1, msoTrue '★元のサイズに戻す
            mySp.ScaleWidth 1, msoTrue  '★元のサイズに戻す
    ''===============タテヨコの縮尺を保持
    '        myHH = Target.Height / mySp.Height
    '        myWW = Target.Width / mySp.Width
    '        If myHH > myWW Then
    '            mySp.Height = mySp.Height * myWW
    '            mySp.Width = Target.Width
    '        Else
    '            mySp.Height = Target.Height
    '            mySp.Width = mySp.Width * myHH
    '        End If
            mySp.LockAspectRatio = True
            If mySp.Height > Target.Height Then mySp.Height = Target.Height
            If mySp.Width > Target.Width Then mySp.Width = Target.Width
            mySp.LockAspectRatio = False
    '===============中央へ調整
            myHH2 = (Target.Height / 2) - (mySp.Height / 2)
            myWW2 = (Target.Width / 2) - (mySp.Width / 2)
            mySp.Top = Target.Top + myHH2
            mySp.Left = Target.Left + myWW2

            Set mySp = Nothing
        End If
    End Sub

 単に再現したいだけの人なんで、なんか、スミマセン...^^;

（白茶） 2019/09/05(木) 21:01

縦と横が逆になるということかと思います。
古いバージョンでは問題なかったはずです。
わたしの365では、再現します。

（マナ） 2019/09/05(木) 21:28

検索してみました。
[[20180810145912]]　『イメージ画像？で張り付けていた昔の写真張り付け』（すが）

（マナ） 2019/09/05(木) 21:44

 はぁーそゆことですか。へぇー。
 そんな事になっちゃうんですね。

 マナさん、ありがとうございました。

 (りあきさん、無駄にスレ汚してゴメンナサイでした)

（白茶） 2019/09/05(木) 22:16

皆さんありがとうございます！
コメントを読んでいるうちにもしかしてJPEGとJPGは違うのか…？と思い、ペイントで画像を保存しなおしたのですがJPEG イメージ (.JPG)からJPEG イメージ (.jpg)に変わっただけ。一応写真挿入してみるとはみださずに入りました！
もともとデジカメから取り込んだ写真だったのですが一度保存しなおさないといけないのでしょうか…？
（りあき） 2019/09/06(金) 09:48

リンク先でも説明されていますが、元画像が、回転情報を使っているのかも知れません。（拡張子による違いは全く無いです）

Windowsのプロパティ表示では、回転情報は表示しなかったように思うので、JPEGのタグ情報を表示できるフリーツール（JpegAnalyzer Plus等）を使って、元画像と再保存した画像を比べてみてください。

ちなみに、JPEGって不可逆圧縮しているので、再圧縮保存する度に画像が劣化していくので、注意。（まぁ、数回くらいなら気づかないレベルですが）
（???） 2019/09/06(金) 10:12

ありがとうございます！
違う質問になり申し訳ないのですが、画像を選択してからボタンをクリックすると90度回転するマクロはどうしたらできますでしょうか？回転してもセルの大きさに合わせて画像が自動で拡大縮小するようにしたいのですが…。
（りあき） 2019/09/06(金) 10:28

 業務連絡。

 ↓で再質問されたようです。

[[20190910162053]]　『画像を回転させる』（りあき）
（OK） 2019/09/10(火) 17:44

コメント返信：

[ 一覧(最新更新順) ]

[[20190905153610]] 『セルのサイズに合わせて画像挿入』（りあき） ページの最後に飛ぶ

[[20190905153610]]　『セルのサイズに合わせて画像挿入』（りあき）　ページの最後に飛ぶ