@11295posted at 2021-03-11

【ExcelVBA】大きな画像を原寸でシートに貼り付けたい

Q&A

Closed

解決したいこと

試験結果のキャプチャ画像をExcelシートに貼り付けて整頓するマクロを作成しています。
画像のサイズは横幅は固定で1280pxなのですが、ファイルによって縦幅は様々です。
そのうち、どうやら縦幅が5000pxを超えると縮小して貼り付けてしてしまうようです。
大きな画像でも貼り付けた際に読み取れる程度の倍率とするような解決方法を教えてください。

開発環境
OS：Windows10
Excel：Microsoft 365 MSO (16.0.13801.20240) 64ビット

発生している問題・エラー

縮小表示されてしまう画像の場合、倍率をn%にしているだけなら貼り付けた後に変更すればいいのですが、縮小表示された画像のシェイプのサイズは、倍率が100%になっています。
そのため、たとえ正しいサイズを指定して表示し直してもボケて読み取れないような状態になってしまいます。

該当するソースコード

With Worksheets(i)
    Call .Range("B4").Select
    Dim shp As Shape: Set shp = .Shapes.AddPicture( _
            fileName:=画像の絶対パス, _
            linktofile:=msoFalse, _
            savewithdocument:=msoTrue, _
            Left:=Selection.Left, _
            Top:=Selection.Top, _
            Width:=-1, _    ' 横幅倍率100%
            Height:=-1)     ' 縦幅倍率100%
End With
With shp
    .LockAspectRatio = True
    Call .ScaleHeight(1, msoTrue, msoScaleFromTopLeft)
End With

自分で試したこと

Worksheets.Shapes.AddPictureの引数で縦横の倍率を原寸で指定し、
なおかつ貼り付けた後に縦横比を保持して100％に設定し直しています。

なお、LoadPicture(画像の絶対パス)を使って画像オブジェクトを取得し、width、heightプロパティで画像のサイズを取得した場合、元の画像サイズが取得できています。

VBAを使わずに手動で「挿入」リボンから画像を取り込んでも、大きいサイズだと縮小表示されてしまいますね…無理なんでしょうか…

解決したコード

With Worksheets(i)
    Call .Range("B4").Select
    Call .Pictures.Insert(画像の絶対パス).Select
    With Application.CommandBars
        If .GetEnabledMso("PictureResetAndSize") Then
            Call .ExecuteMso("PictureResetAndSize")
        End If
    End With

    ' 画像へのリンクになってしまうので、画像オブジェクトとしてファイルに取り込む
    Call CutPict(.Shapes(.Shapes.Count))
    Call PastePict(Worksheets(i))
    Call .Range("A1").Select
End With

' 画像オブジェクトの切り取りと貼り付けは失敗することがあるものの、
' デバッグして実行するとほぼ確実に成功するので、再帰的に処理
Private Sub CutPict(ByVal shp As Shape)
On Error GoTo ERR_CUT
    Call shp.Select
    With Selection
        Call .CopyPicture
        Call .Delete
    End With
    DoEvents
    Exit Sub
ERR_CUT:
    Call CutPict(shp)
On Error GoTo 0
End Sub

Private Sub PastePict(ByVal ws As Worksheet)
On Error GoTo ERR_PASTE
    Call ws.paste
    Call ClearClipboard
    DoEvents
    Exit Sub
ERR_PASTE:
    Call PastePict(ws)
On Error GoTo 0
End Sub

クリップボードのクリア

Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long

Sub ClearClipboard()
    Call OpenClipboard(0&)
    Call EmptyClipboard
    Call CloseClipboard
End Sub

Are you sure you want to delete the question?