Удаление всех изображений в выделенной части документа

[NewUser]

Подскажите, пожалуйста, есть ли возможность пакетно удалить все изображения в выделенной части текстового документа, при сохранении оформления (гарнитура, цвет, таблицы и т.п.). Пытаюсь через расширение "AltSearch", но оно удаляет лишь первые несколько изображений, а затем всегда зависает. Раздел "Изображения" в доке "Навигатор" не позволяет выделить несколько изображений, удаление только по одному. Макрос удаляет все изображения в документе, независимо от выделения, так что тоже не подходит. LO 7.2, Win 8.1. Спасибо.

[mikekaganski]

На основе макроса, который Вы упомянули, и кода этого расширения:

Код Выделить Развернуть

Function IsSelectionEmpty(ByRef oSel) As Boolean
  IsSelectionEmpty = False
  If (IsNull(oSel)) Then
    IsSelectionEmpty = True
  ElseIf (HasUnoInterfaces(oSel, "com.sun.star.drawing.XShape")) Then
    ' Selected single object - selection isn't empty; do nothing
  ElseIf (HasUnoInterfaces(oSel, "com.sun.star.sheet.XSheetCellRange")) Then
    ' Something is selected anyway
  ElseIf (HasUnoInterfaces(oSel, "com.sun.star.text.XTextTableCursor")) Then
    ' Some cells in table are selected - assume non-empty selection
  ElseIf (oSel.Count = 0) Then
    IsSelectionEmpty = True
  ElseIf ((oSel.Count = 1) And oSel.supportsService("com.sun.star.text.TextRanges")) Then
    With oSel(0)
      If (.text.compareRegionStarts(.getStart, .getEnd)=0) Then
        IsSelectionEmpty = True
      End If
    End With
  End If
End Function

Function GetObjectsFromTextRange(ByRef oSel, ByRef vObjects() As Object)
  Dim oEnum As Object
  oEnum = oSel.createEnumeration()
  Do While oEnum.hasMoreElements()            REM Traverse Paragraphs.
    Dim oParagraphOrTable As Object
    oParagraphOrTable = oEnum.nextElement()
    If (HasUnoInterfaces(oParagraphOrTable, "com.sun.star.text.XTextTable")) Then
      With oParagraphOrTable
        Dim j As Long
        For j = LBound(.CellNames) To UBound(.CellNames)
          vObjects = GetObjectsFromTextRange(.getCellByName(.CellNames(j)), vObjects)
        Next j
      End With
    Else
      Dim oEnum2 As Object
      oEnum2 = oParagraphOrTable.createEnumeration()
      Do While oEnum2.hasMoreElements()       REM Traverse TextPortions.
        Dim oPortion As Object
        oPortion = oEnum2.nextElement()
        Dim oEnum3 As Object
        oEnum3 = oPortion.createContentEnumeration( "com.sun.star.text.TextContent" )
        Do While oEnum3.hasMoreElements()   REM Traverse TextContents.
          Dim oContent As Object
          oContent = oEnum3.nextElement()
          ReDim Preserve vObjects(LBound(vObjects) To 1+UBound(vObjects))
          vObjects(UBound(vObjects)) = oContent
        Loop
      Loop
    End If
  Loop
  GetObjectsFromTextRange = vObjects
End Function

Function IsCellRangeInsideRange(ByRef oRange1, ByRef oRange2) As Boolean
  IsCellRangeInsideRange = _
            (oRange1.RangeAddress.Sheet        = oRange2.RangeAddress.Sheet      )_
        And (oRange1.RangeAddress.StartColumn >= oRange2.RangeAddress.StartColumn)_
        And (oRange1.RangeAddress.EndColumn   <= oRange2.RangeAddress.EndColumn  )_
        And (oRange1.RangeAddress.StartRow    >= oRange2.RangeAddress.StartRow   )_
        And (oRange1.RangeAddress.EndRow      <= oRange2.RangeAddress.EndRow     )
End Function

Function IsTextRangeInsideRange(ByRef oRange1, ByRef oRange2) As Boolean
  IsTextRangeInsideRange = (oRange2.text.compareRegionStarts(oRange1, oRange2)<=0)_
                       And (oRange2.text.compareRegionEnds(oRange1, oRange2)>=0)
End Function

Function IsInSelection(ByRef oObj, ByRef oSel) As Boolean
  Dim i As Long
  If (IsNull(oSel)) Then
    IsInSelection = True
  ElseIf (HasUnoInterfaces(oSel, "com.sun.star.drawing.XShape")) Then
    IsInSelection = EqualUnoObjects(oObj, oSel)
  ElseIf (HasUnoInterfaces(oSel, "com.sun.star.drawing.XShapes")) Then
    IsInSelection = False
    For i = 0 To oSel.Count - 1
      If (EqualUnoObjects(oObj, oSel(i))) Then
        IsInSelection = True
        Exit For
      End If
    Next i
  ElseIf (HasUnoInterfaces(oSel, "com.sun.star.sheet.XSheetCellRange")) Then
    IsCellRangeInsideRange(oObj.Anchor, oSel)
  ElseIf (HasUnoInterfaces(oSel, "com.sun.star.sheet.XSheetCellRangeContainer")) Then
    IsInSelection = False
    For i = 0 To oSel.Count - 1
      If (IsCellRangeInsideRange(oObj.Anchor, oSel(i))) Then
        IsInSelection = True
        Exit For
      End If
    Next i
  Else
    IsInSelection = False
    For i = 0 To oSel.Count - 1
      If (IsTextRangeInsideRange(oObj.Anchor, oSel(i))) Then
        IsInSelection = True
        Exit For
      End If
    Next i
  End If
End Function

Function GetObjectsFromDrawPage(ByRef oDrawPage, ByRef oSel)
  ' Create an array with 1 extra element to simplify things
  Dim vObjects(0 To oDrawPage.Count) As Object
  Dim i As Long
  Dim oObj As Object
  For i = 0 to oDrawPage.Count-1
    oObj=oDrawPage(i)
    If (IsInSelection(oObj, oSel)) Then
      vObjects(i) = oObj
    End If
  Next i
  GetObjectsFromDrawPage = vObjects
End Function

Function GetObjectsFromDrawPages(ByRef oDoc, ByRef oSel)
  Dim vObjects() As Object
  Dim oPage As Object
  Dim k As Long
  For k = 0 To oDoc.DrawPages.Count-1
    Dim vObj() As Object
    vObj = GetObjectsFromDrawPage(oDoc.DrawPages(k), oSel)
    Dim i As Long, j As Long
    j = UBound(vObjects)-LBound(vObj)+1
    ReDim Preserve vObjects(LBound(vObjects) To j+UBound(vObj))
    For i = LBound(vObj) To UBound(vObj)
      vObjects(i+j) = vObj(i)
    Next i
  Next k
  GetObjectsFromDrawPages = vObjects
End Function

Function GetObjectsFromDoc(ByRef oDoc)
  Dim oSel As Object, oViewCursor As Object
  oSel = oDoc.getCurrentSelection()
  oViewCursor = oDoc.CurrentController.getViewCursor()

  Dim vObjects() As Object
  Dim i As Long
  If (IsSelectionEmpty(oSel)) Then
    oSel = Nothing
  ElseIf (oSel.supportsService("com.sun.star.text.TextRanges")) Then
    For i = 0 To oSel.getCount() - 1          REM Traverse Selections.
      vObjects = GetObjectsFromTextRange(oSel.getByIndex(i), vObjects)
    Next i
    GetObjectsFromDoc = vObjects
    Exit Function
  ElseIf (HasUnoInterfaces(oSel, "com.sun.star.text.XTextTableCursor")) Then
    Dim oTab As Object
    oTab=oViewCursor.TextTable
    Dim rangeName$
    rangeName = oSel.getRangeName()
    Dim oCellRange As Object
    oCellRange = oTab.getCellRangeByName(rangeName)
    Dim j As Long
    Dim aData
    aData = oCellRange.Data
    For i = LBound(aData) To UBound(aData)
      For j = LBound(aData(i)) To UBound(aData(i))
        Dim oCell
        oCell = oCellRange.getCellByPosition(j, i)
        vObjects = GetObjectsFromTextRange(oCell, vObjects)
      Next j
    Next i
    GetObjectsFromDoc = vObjects
    Exit Function
  End If
  If (HasUnoInterfaces(oDoc, "com.sun.star.drawing.XDrawPagesSupplier")) Then
    vObjects = GetObjectsFromDrawPages(oDoc, oSel)
  ElseIf (HasUnoInterfaces(oDoc, "com.sun.star.drawing.XDrawPageSupplier")) Then
    vObjects = GetObjectsFromDrawPage(oDoc.DrawPage, oSel)
  End If
  GetObjectsFromDoc = vObjects
End Function

Sub RemoveObjectsFromSelection
  Dim oDoc As Object, oGraphics As Object, oUndo As Object, oImg As Object
  oDoc = ThisComponent
  oGraphics = oDoc.getGraphicObjects()
  oUndo = oDoc.getUndoManager()

  oUndo.enterUndoContext("RemoveSelectedObjects")
  oDoc.lockControllers()
  On Local Error GoTo Cleanup

  ' create selected list first, before changing document, to avoid selection inconsistency
  Dim vSelectedObjects
  vSelectedObjects = GetObjectsFromDoc(oDoc)

  For Each oImg in vSelectedObjects
    oDoc.getText().removeTextContent(oImg)
  Next

Cleanup:
  oDoc.unlockControllers()
  oUndo.leaveUndoContext()
End Sub

[NewUser]

Спасибо, Михаил!
Ваш макрос отрабатывает великолепно!