MyTetra Share
Делитесь знаниями!
Фигуры в выделенном диапазоне ячеек
Время создания: 16.03.2019 23:43
Раздел: !Закладки - VBA - Excel - Shapes
Запись: xintrea/mytetra_db_adgaver_new/master/base/1482819573h5rnsghap3/text.html на raw.githubusercontent.com

Почему же не нужно? Представьте, что автофигура с размеров во весь лист, у неё TopLeftCell - это ячейка A1. Если не учитывать BottomRightCell, то в выделенном диапазонк B2:G20 её как бы и нет, но на самом деле она перекрывает все ячейки. Впрочем, "выбрать все рисунки в выделенном диапазоне ячеек" может иметь и иной смысл - Вам виднее.

Вот пример того, как загнать все объекты DrawingObjects заданного диапазона в коллекцию:

Sub Test()
Dim x, Rng As Range, Col As New Collection
Set Rng = Range("B2:G20")
For Each x In ActiveSheet.DrawingObjects
If Not Intersect(Range(x.TopLeftCell, x.BottomRightCell), Rng) Is Nothing Then
Debug.Print x.Name
Col.Add x
End If
Next
End Sub


А если кроме рисунков нужны ещё и автофигуры, то у прямоугольников, например, имена могут повторяться (вариант - при копировании), поэтому dic.Add x.Name, ... не есть гуд ;-)
В варианте же с коллекцией без ключа собираются все объекты, а не только с уникальными именами


Sub t()
Dim x, dic
Set dic = CreateObject("scripting.dictionary")
For Each x In ActiveSheet.DrawingObjects.ShapeRange
If Not Intersect(Selection, x.TopLeftCell) Is Nothing Then
dic.Add x.Name, x
End If
Next
ActiveSheet.Shapes.Range(dic.keys).Select
Set dic = Nothing
End Sub



Sub t()
Dim x, dic
On Error Resume Next
Set dic = CreateObject("scripting.dictionary")
For Each x In ActiveSheet.DrawingObjects.ShapeRange
If Not Intersect(Selection, x.TopLeftCell) Is Nothing Then
dic.Add x.DrawingObject.Index, 0
End If
Next
ActiveSheet.Shapes.Range(dic.keys).Select
Set dic = Nothing
End Sub



Почти то же самое, но без словаря и с учётом области пересечения по 2-м углам:
Sub tt()
Dim x, r As Range

Set r = ActiveWindow.RangeSelection
On Error Resume Next
For Each x In ActiveSheet.DrawingObjects.ShapeRange
If Not Intersect(Range(x.TopLeftCell, x.BottomRightCell), r) Is Nothing Then x.Select (False)
Next x
End Sub



Алексей, не понятно, зачем Вам нужно выделять картинки, обычно select - лишнее действие, если это не интерфесная необходимость, конечно.

Для коллекции приведу еще пример кода для общего случая, когда нужно хранить группу картинок в переменной ShpsRng для последующих групповых операций.

ShpsRng можно было бы объявить и вне процедуры на уровне модуля или глобально.

Sub SelectPictures()
' Выделение рисунков видимой области экрана
Dim a(), i&, n&
Dim Shp As Shape, Shps As Shapes, ShpsRng As ShapeRange, Rng As Range
Set Shps = ActiveSheet.Shapes
If Shps.Count = 0 Then Exit Sub
ReDim a(1 To Shps.Count)
Set Rng = Windows(1).VisibleRange
For i = 1 To Shps.Count
With Shps.Item(i)
If .Type = msoPicture Then
If Not Intersect(Range(.TopLeftCell, .BottomRightCell), Rng) Is Nothing Then
n = n + 1
a(n) = i
End If
End If
End With
Next
If n Then
ReDim Preserve a(1 To n)
Set ShpsRng = Shps.Range(a) ' ShpsRng может быть и глобальной
ShpsRng.Select ' <-- для примера
End If
End Sub


Попытал разные варианты кода и всё-таки остановился на Володином (с ActiveWindow.RangeSelection). Так получается и короче, и немного корректнее: программа не отказывается работать если выбран не диапазон, а обрабатывает графические объекты, попадающие в диапазон, который был выбран до того, как выбран графический объект:
Private Sub Draws_In_Selection_Select() ' выделить все рисунки в выбранном диапазоне
Dim oDraw, rSel As Range
Set rSel = ActiveWindow.RangeSelection
For Each oDraw In ActiveSheet.DrawingObjects.ShapeRange
If Not Intersect(Range(oDraw.TopLeftCell, oDraw.BottomRightCell), rSel) Is Nothing Then oDraw.Select (False)
Next
End Sub




Меня вполне удовлетворил выбор с Shape.Select(False)
Не столько в конце-концов на листе шэйпов чтобы заметить медленность метода.
Поэтому оставил так:
Private Sub Draws_In_Selection_Select() ' выделить В ВЫБРАННОМ ДИАПАЗОНЕ все рисунки
Dim oDraw, rSel As Range
Set rSel = ActiveWindow.RangeSelection
For Each oDraw In ActiveSheet.DrawingObjects.ShapeRange
If Not Intersect(Range(oDraw.TopLeftCell, oDraw.BottomRightCell), rSel) Is Nothing Then oDraw.Select (False)
Next
End Sub

Ну и заодно по такому же принципу слепил макрос, выделяющий на листе все рисунки с нулевыми размерами (они остаются на листе после удаления строк/столбцов):

Private Sub Draws_0D_Select() ' выделить НА ЛИСТЕ все рисунки с нулевыми размерами
Dim oDraw As Shape
For Each oDraw In ActiveSheet.DrawingObjects.ShapeRange
If oDraw.Width = 0 Or oDraw.Height = 0 Then oDraw.Select (False)
Next
End Sub

Так же в этом разделе:
 
MyTetra Share v.0.59
Яндекс индекс цитирования