ｼｰﾄに貼り付けている画像を消去すると「OLEObjectクラスのTopleftCellプロパティを取得できません」といいうエラーメッセージが表示される。

Question

前提

以下のコードを実行し、シート内の画像を削除しようとすると、
「OLEObjectクラスのTopleftCellプロパティを取得できません」
というエラーが出てしまいます。

実現したいこと

・エラーメッセージが出ない様にしたい
・何が起きているか知りたい。
・自分の認識が間違っていたら指摘してもらいたい。

###シートの画像を削除するプロシージャ

Sub 画像削除()
  Dim xrg As Range
  Dim shp As Shape
  Dim Erow As Long
  
  Erow = Cells(Rows.Count, 2).End(xlUp).row
  Set xrg = Range(Cells(11, 1), Cells(Erow, 1))

    For Each xPic In ActiveSheet.Pictures
        Set xPicRg = Range(xPic.TopLeftCell.Address & ":" & xPic.BottomRightCell.Address)
        If Not Intersect(xrg, xPicRg) Is Nothing Then xPic.Delete
    Next
  Columns(1).ColumnWidth = 3.25
  Rows("11:" & Erow).RowHeight = 18.75
End Sub

For文を使い、シート内の画像(OLEObject)を削除する際に、表示されている所（セル）の画像を認識し、削除するものと思っていたのですが、画像の場所（TopleftCell）が無いという事が有るのでしょうか・・・。

理解できずに質問しました。
原因や上記に記載した認識で相違点有ればご指摘いただきたいです。

ちなみに上記のシートに画像を貼り付けるコードは以下のコードです。
JpegとPNGとPDFでｻｲｽﾞの調整と貼り付けを条件分岐しています。

よろしくお願いします！

Sub 画像貼付(grow, gcol, gazou)
  Dim sename As String
  sename = ActiveSheet.name
   '画像ｻｲｽﾞ
   If InStr(gazou, ".png") > 0 Then
       Set sp = ActiveSheet.Shapes.AddPicture( _
                  Filename:=gazou, _
                  LinkToFile:=False, _
                  SaveWithDocument:=True, _
                  Left:=0, _
                  Top:=0, _
                  Width:=0, _
                  Height:=0 _
                  )
        With sp
          .LockAspectRatio = msoTrue
          .ScaleHeight 1, msoTrue
          .ScaleWidth 1, msoTrue
          Pwi = CLng(.Width * 4 / 3)
          Phi = CLng(.Height * 4 / 3)
          .Delete
        End With
        
   ElseIf InStr(gazou, ".pdf") > 0 Then
    Cells(grow, gcol).Activate
    ActiveSheet.OLEObjects.Add Filename:=gazou
   
   Else
     Set Pi = LoadPicture(gazou)
     Phi = CLng(Pi.Height * 0.0378)
     Pwi = CLng(Pi.Width * 0.0378)
   End If
  
    'ｻｲｽﾞ設定
   
   If InStr(gazou, ".pdf") > 0 Then
     

    For Each pic In ActiveSheet.OLEObjects
     With pic.TopLeftCell
      pic.Top = .Top
      pic.Left = .Left
      pic.Width = .MergeArea.Width
      'pic.Height = .MergeArea.Height
     End With
    Next
   
   Else
    Cells(grow, gcol).Select
    Chi = Selection.Height
    Cwi = Selection.Width

    If Pwi > Phi Then
      w = Cwi
      rat = Cwi / Pwi '縮小幅の縦横比
      H = Phi * rat '’画像高さを縦横比に合わせる
     
    ElseIf Phi > Pwi Then
      H = Chi
      rat = Chi / Phi
      w = Pwi * rat

    ElseIf Phi = Pwi Then '画像の縦と横同じ場合
      If Cwi > Chi Or Cwi = Chi Then    'セルの幅の方が大きければ(又は同じならば)
        w = Chi             'セルの高さに幅を合わせる
        H = Chi
      ElseIf Chi > Cwi Then 'セルの高さの方が大きければ
        w = Cwi             'セルの高さに幅を合わせる
        H = Cwi
      End If
     End If

     '画像貼付
      Set shp = Worksheets(sename).Shapes.AddPicture(gazou, msoFalse, msoTrue, _
      Range(Cells(grow, gcol), Cells(grow, gcol)).Left, _
      Range(Cells(grow, gcol), Cells(grow, gcol)).Top, w, H)
      
       With shp
        .Left = .Left + (ActiveCell.MergeArea.Width - shp.Width) / 2
        .Top = .Top + (ActiveCell.MergeArea.Height - shp.Height) / 2
       End With
   End If
End Sub

※growには画像を貼り付ける行、gcolには貼り付ける列、gazouには画像のパスが入っています。

Comments

[bebebe_]

適当な画像を挿入してそれに対しては取得はできますか？

[sk.exe]

> Erow = Cells(Rows.Count, 2).End(xlUp).row
> Set xrg = Range(Cells(11, 1), Cells(Erow, 1))

「B 列の最後のデータ行の行番号」を変数 Erow に代入しておきながら、「A 列の 11 行目から Erow 行目までの範囲」を参照されている（列が異なる）のには何か意味があるのでしょうか。

[ice930]

返信遅れ申し訳ありません。

下記に記載したコード（画像を貼り付けるｺｰﾄﾞ）では、表に関連した画像をA列に貼り付けています。
そのA列に貼り付けた画像をを消去するためのコードとして作成したものが上部のコードにな亭ます。

EowにてB列の最終行を求める理由与しては、B列以降にデータ（文字列）が入っている為、その列の最終行を求めました。

Answer 1

とりあえず、次のようなプロシージャを実行してみても同様のエラーが返されてしまうのか否かをご確認してみて下さい。

Sub DeletePicturesAndOLEObjects()

    Dim ws As Worksheet
    Dim rngArg1 As Range
    Dim lngFirstRow As Long
    Dim lngLastRow As Long
    
    Set ws = ActiveSheet
    
    With ws
    
        If .Shapes.Count = 0 Then
            Set ws = Nothing
            Exit Sub
        End If
    
        lngFirstRow = 11
        lngLastRow = .Cells(.Rows.Count, 2).End(xlUp).Row
        
        If lngLastRow < lngFirstRow Then
            Set ws = Nothing
            Exit Sub
        End If
        
        Set rngArg1 = .Range(.Cells(lngFirstRow, 1), _
                             .Cells(lngLastRow, 1))
    End With
    
    Dim shpLast As Shape
    Dim lngShapeIndex As Long
    Dim strAddress As String
    Dim rngArg2 As Range
    
    Application.ScreenUpdating = False
    
    For lngShapeIndex = ws.Shapes.Count To 1 Step -1
        
        Set shpLast = ws.Shapes(lngShapeIndex)
        
        With shpLast
            Select Case .Type
                Case msoPicture, msoLinkedPicture, msoEmbeddedOLEObject, msoLinkedOLEObject
                    Debug.Print .Name
                    strAddress = .TopLeftCell.Address & ":" & .BottomRightCell.Address
                Case Else
                    strAddress = ""
            End Select
            If strAddress <> "" Then
                Debug.Print strAddress
                Set rngArg2 = ws.Range(strAddress)
                If Not Intersect(rngArg1, rngArg2) Is Nothing Then
                    .Delete
                End If
                Set rngArg2 = Nothing
            End If
        End With
        
        Set shpLast = Nothing
    
    Next

    Application.ScreenUpdating = True

    Set rngArg1 = Nothing
    Set ws = Nothing
    
End Sub

Comments

[ice930]

回答ありがとうございます！
エラーなく実行されました！

原因としては何が濃厚でしょうか・・・。