以前投稿した【備忘録】Excel2010以降のVBAで画像の実体を挿入する関連のマクロの話。

Excelにブラウザのキャプチャを画像ファイル名に沿ってぺちぺち貼り付けていくのをマクロでやってたんだけど、1シートに何枚画像が貼られるか決まってないわけです。更に画像の大きさも揃ってません。
となると、画像の範囲と重なる最大行と最大列を取得したいわけです。
普通に文字入力されたセルであれば簡単なんですけど、画像の範囲をどうやって取得すんの？ってなったのでメモっときます。

2019/04/24　更新
画像の右下の行番号・列番号の取得方法を変更
何故あんなに色々無駄なコードを書いてたのか自分でもわからない…

「ActiveSheet.Shapes」のインデックスの不思議

前提として、ワークシート上には挿入したキャプチャ画像の他に、マーキング用に矩形のオブジェクトがちりばめられたりしています。
それらは画像の上からはみ出さずに乗ってる状態なので、そいつらの位置を基準に最大範囲を取得することはまずないです。
とりあえず最後に貼り付けた画像の最大範囲を印刷範囲にすればええんじゃろ？と思ってたんですけど。
「ActiveSheet.Shapes」のインデックスはオブジェクトの種類が混在していると最大インデックスが最後に追加したオブジェクトのものとは限らなくなっちゃうんですよね…何でこんな仕様なんだ…
だから最後のインデックス取得したらマーキング用オブジェクトのものだったとかそんなことがありまして。
なので「挿入した画像ファイル」のオブジェクトの中で最大のインデックスを取得し、その画像の範囲を取得することにしました。

コード

画像ファイル分ループして処理する中で、1枚画像を貼ったら印刷範囲を拡張して…ってやってました。
なので最後に貼り付けた画像オブジェクトの範囲を取得する感じです。

追記
「GetPrintArea」の引数について
実際呼び出すときはこんな感じ。具体的に言うと「\$A\$1:\$BV\$140」みたいなアドレスの文字列です。

GetPrintArea(ActiveWorkbook.ActiveSheet.PageSetup.printArea)

' 印刷範囲のアドレスを取得
Function GetPrintArea(ByVal currentPrintArea As String) As String
    With CreateObject("VBScript.RegExp")
        .Pattern = "^.*\$"
        .ignoreCase = True
        .Global = True
        Dim currentRow As Integer
        currentRow = CInt(.Replace(currentPrintArea, ""))
        .Pattern = "^.*:"
        Dim currentCol as integer
        currentCol = range(.Replace(currentPrintArea, "")).column
    End With
    If currentCol < 最小印刷範囲の列番号 Then
        currentCol = 最小印刷範囲の列番号
    End If

    Dim bottomRightCell As Range
    Set bottomRightCell = GetImgBottomRightCell(GetLastIdxOfImgShapes())

    ' 最大行取得
    Dim maxRow As Integer
    maxRow = bottomRightCell.row + 1
    If maxRow < currentRow Then
        maxRow = currentRow
    End If

    ' 最大列取得
    Dim maxColumn As Integer
    maxColumn = bottomRightCell.column + 1
    If maxColumn < currentCol Then
        maxColumn = currentCol
    End If

    GetPrintArea = "$A$1:" & ActiveSheet.Cells(maxRow, maxColumn).Address
End Function

' シート内n番目(0の場合は最後)の画像の右下のセル取得
Function GetImgBottomRightCell(ByVal imgIdx As Integer) As Range
    Set GetImgBottomRightCell = Nothing
    If ActiveSheet.Shapes.Count = 0 Then
        Exit Function
    End If

    If imgIdx = 0 Then
        imgIdx = GetLastIndexOfShapes()
        If imgIdx = 0 Then
            Exit Function
        End If
    End If
    Set GetImgBottomRightCell = ActiveSheet.Shapes(imgIdx).BottomRightCell
End Function

' 最後に追加された画像シェイプのインデックスを取得
Function GetLastIndexOfShapes() As Integer
    GetLastIndexOfShapes = 0
    If ActiveSheet.Shapes.Count = 0 Then
        Exit Function
    End If

    Dim i As Integer
    Dim currentIdx As Integer
    Dim bfrIdx As Integer
    bfrIdx = 0
    For i = 1 To ActiveSheet.Shapes.Count
        With ActiveSheet.Shapes(i)
            If .Type = msoPicture Then
                currentIdx = CInt(Replace(.name, "Picture ", ""))
                If currentIdx > bfrIdx Then
                    GetLastIndexOfShapes = i
                End If
                bfrIdx = currentIdx
            End If
        End With
    Next
End Function

まわりくどいんですけど、これでうまいこと解決できたので残しておきます。
一番下と右端のセルを取得するやつは画像貼り付けるときにも使いました。他にも使い回せそうです。

普段ツール作るときは、正規表現の置換とか汎用的な処理まとめて共通モジュール作っちゃうし、参照設定もするので、もうちょっとすっきりしたコードになってます。

誰かの助けになれば幸いです。

【Excel VBA】画像を含むシートの適切な印刷範囲を取得する

「ActiveSheet.Shapes」のインデックスの不思議

コード