Skill Note

平凡なエンジニアがメモ代わりにプログラミング, インフラ, ネットワークを書き綴るブログ

Excelのセル幅に合わせて縦横比を維持したまま画像サイズを自動調整する方法

      2019/12/20

VBAで画像を挿入することができますが、単純にセル幅に合わせて画像サイズを変更すると、縦長や横長の画像として挿入されます。
縦横比を維持したまま、画像を挿入する方法についてついて記載します。

VBAのマクロ機能を使用して画像サイズを調整する

ダブルクリックしたセルに画像を挿入するサンプルプログラムを記載します。
サンプルプログラムでは、ダブルクリックしたセルが結合セルの場合のみファイル選択画面を表示しています。

JPEG画像を貼り付ける場合にShapeRangeプロパティでは
幅と高さが正確に取得できない為、AddPictureで画像の幅と高さを調整しています。

サンプルプログラム

Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    'セル選択判定
    '条件①結合セル②セル高さ100以上③セル幅100以上
    If Target.MergeCells And Target.Height >= 100 And Target.Width >= 100 Then

        Cancel = True

        '画像挿入
        Call PasteImage(Target)
    End If

End Sub


Option Explicit

Public Sub PasteImage(ByVal Target As Range)

    Dim fileNm As String
    Dim shp As Object
    Dim rng As Range
    Dim myRange As Range
    Dim pWidth As Single
    Dim pHeight As Single
    Dim pLeft As Single
    Dim pTop As Single
    Dim mWidth As Integer
    Dim mHeight As Integer
    Dim rX As Single
    Dim rY As Single
    Dim objShape As Shape

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

    'セル内の画像削除
    For Each shp In ActiveSheet.Pictures
        Set rng = Range(shp.TopLeftCell, shp.BottomRightCell)

        If Not (Intersect(rng, Selection) Is Nothing) Then
            shp.Delete
        End If
    Next

    mWidth = 3  '左右余白
    mHeight = 3 '上下余白
    Set myRange = Target
    Application.ScreenUpdating = False

    '表示位置の取得
    With ActiveSheet.Pictures.Insert(fileNm).ShapeRange
        '左上隅の位置取得
        pLeft = .Left
        pTop = .Top
        '一旦画像を削除する
        .Delete
    End With

    '画像サイズの取得
    Set objShape = ActiveSheet.Shapes.AddPicture( _
        Filename:=fileNm, _
        LinkToFile:=False, _
        SaveWithDocument:=True, _
        Left:=0, _
        Top:=0, _
        Width:=0, _
        Height:=0)

    With objShape
        .LockAspectRatio = msoTrue
        .ScaleHeight 1, msoTrue
        .ScaleWidth 1, msoTrue

        '画像サイズをセルの幅、高さに合わせる
        rX = myRange.Width / .Width
        rY = myRange.Height / .Height

        If rX > rY Then
            .Height = .Height * rY - mHeight
            .Width = .Width - mWidth
        Else
            .Height = .Height - mHeight
            .Width = .Width * rX - mWidth
        End If
        pWidth = .Width
        pHeight = .Height

        '表示位置をセルの幅、高さに合わせる
        pLeft = pLeft + (myRange.Width - .Width) / 2
        pTop = pTop + (myRange.Height - .Height) / 2
        '一旦画像を削除する
        .Delete
     End With

    '画像の貼り付け
    Set objShape = ActiveSheet.Shapes.AddPicture( _
        Filename:=fileNm, _
        LinkToFile:=False, _
        SaveWithDocument:=True, _
        Left:=pLeft, _
        Top:=pTop, _
        Width:=pWidth, _
        Height:=pHeight)

    Application.ScreenUpdating = True

End Sub

Google AdSense PC

Google AdSense PC

Message

メールアドレスが公開されることはありません。 * が付いている欄は必須項目です

  関連記事

microsoft
[Windows]リモートデスクトップのシングルサインオン

ドメイン参加PCでシングルサインオンする Active Directoryのドメインに所属した場合、既定の設定のままでは、資格情報が使用できないため、 リモート …

microsoft
[Windows]WSUSサーバの構築手順 1/6

Windows 2008 R2サーバにWSUSサーバを構築する Windows Server Update Services(WSUS)とは Windows S …

microsoft
VBAからOracleのストアドプロシージャを実行する方法

VBAからOracleのストアドプロシージャを実行する方法について記載します。 VBAからOracleに接続する方法は以前の記事を参考にしてください。 ストアド …

microsoft
[Windows]Windows Server 2008 R2 IISインストール手順

Windows Server 2008 R2にIISをインストールする 環境 OS:Windows Server 2008 R2 IIS:ver7.5 インスト …

microsoft
既存パソコンを有効活用した、Windows 10への移行方法を考える

企業や個人用など数多くのパソコンで稼働しているOS、Windows 7のサポート期間が2020年1月14日に終了します。 サポート期間終了に向けてWindows …

microsoft
Windows10パソコンを使ってKY-01Lの電話帳・連絡先を登録する方法

NTTドコモのカードケータイ KY-01Lの電話帳・連絡先の取り込みは、BluetoothやSIMカードを使った方法が説明書に記載されています。 Bluetoo …

VBAからSQL Serverに接続する方法(Microsoft OLE DB Provider for SQL Server)

VBAから業務システムなどに使用しているデータベースに接続し、データを抽出することができます。 定期的に作成する資料などは、VBAでデータ取得処理を自動化し、ボ …

microsoft
[Windows]「このリモートコンピューターのIDを識別できません。接続しますか?」の対応方法

警告の原因と対応方法 リモートデスクトップ接続をしたときに表示されるこのメッセージ 「このリモートコンピューターのIDを識別できません。接続しますか?」 「はい …

microsoft
[Windows]共有フォルダへのアクセスログを取得する方法

VVAULT AUDITを使用したログ管理 Windowsでは監査ポリシーを設定することにより共有フォルダやファイルへのアクセスログを記録し、インベントビューア …

microsoft
[Windows]共有フォルダのアクセス権を設定する

アクセス権の種類 共有フォルダのアクセス権は[共有アクセス許可]と[NTFSアクセス許可]の2つの許可エントリのセットによって決定します。 [共有アクセス許可] …