Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Страницы: 1 2 След.
RSS
Как выбрать все рисунки в выделенном диапазоне ячеек? (VBA)
 
Народ, подскажите, пожалуйста как можно выбрать все рисунки в выделенном диапазоне ячеек?  
 
На всём листе-то это сделать не трудно:  
Sub All_Draws_Select()   ' выделить все рисунки на листе  
  ActiveSheet.DrawingObjects.Select  
End Sub  
 
А вот как выбрать в Selection?  
При этом, конечно, хотелось бы обойтись без цикла перебора всех элементов DrawingObjects в Selection :), но если нельзя, то и ладно, пусть с циклом …  
 
К сожалению, Справка про коллекцию .DrawingObjects молчит как рыба об лёд и узнать что-то про свойства её элементов, относящиеся к привязке картинок к ячейкам, по аналогии с элементами коллекции .Shapes при моём слабом знании инглиша трудно.  
 
Мне нужно выделять только РИСУНКИ, поэтому я и пытаюсь использовать именно коллекцию .DrawingObjects, а не .Shapes, т.к. (насколько я смог нарыть по разным источникам) в .DrawingObjects в отличие от .Shapes не входят примечания, выпадающие списки проверки данных, автофильтра, списков и сводных таблиц
С уважением, Алексей (ИМХО: Excel-2003 - THE BEST!!!)
 
activesheet.drawingobjects.shaperange(n).topleftcell
Живи и дай жить..
 
Может можно использовать свойства объекта  
.TopLeftCell.Address  
.BottomRightCell.Address  
и сравнивать в адресами Selection ?
 
{quote}{login=слэн}{date=05.04.2012 11:39}{thema=}{post}ActiveSheet.DrawingObjects.ShapeRange(n).TopLeftCell{/post}{/quote}  
слэн,  
спасибо, но что-то я с ShapeRange никак по Справке не разберусь… Инглиш хромает.  
Как его набрать-то из объектов, входящих в Selection?  
 
Kuzmich,  
спасибо. Про TopLeftCell (именно по нему, кажется, привязывается картинка к ячейке, а BottomRightCell тут не нужно) я уже думал.  
Но делать цикл по всем DrawingObject и проверять, входят ли их адреса в Selection мне показалось как-то сложновато.
С уважением, Алексей (ИМХО: Excel-2003 - THE BEST!!!)
 
{quote}{login=Alex_ST}{date=05.04.2012 12:03}{thema=Re: }{post}Про TopLeftCell (именно по нему, кажется, привязывается картинка к ячейке, а BottomRightCell тут не нужно) я уже думал.{/post}{/quote}  
Добрый день, Алексей!  
Почему же не нужно? Представьте, что автофигура с размеров во весь лист, у неё 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
 
да ничего сложного:  
 
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
Живи и дай жить..
 
о, вот и zvi о том же :)..  
 
но у меня вроде немножко полнее  
 
и можно dic.Add x.Name, 0
Живи и дай жить..
 
{quote}{login=слэн}{date=05.04.2012 01:18}{thema=}{post}но у меня вроде немножко полнее{/post}{/quote}  
Привет, Слэн! Для объектов Pисунок ShapeRange избыточен.  
А если кроме рисунков нужны ещё и автофигуры, то у прямоугольников, например, имена могут повторяться (вариант - при копировании), поэтому dic.Add x.Name, ... не есть гуд ;-)  
В варианте же с коллекцией без ключа собираются все объекты, а не только с уникальными именами
 
Слэн, ZVI,  
спасибо за помощь.  
Извините, что вчера замолчал: грузанули на работе один мерзкий застарелый вопрос разгребать на совещании... И совещались "от забора до обеда" :)    
Сегодня малость разгрёб дела. Попробовал.  
Как только не извращался со всякими объектами, которые не Range на листе, так дублирования имён добиться и не смог.  
Поэтому остановился на варианте со словарём, т.к. из него проще вытащить массив имён накопленных элементов.  
(Но защиту от ошибок я всё-таки на всякий случай, послушав ZVI, поставил)  
Вот, что получилось в конце-концов:  
Sub Draws_In_Selection_Select()   ' выделить все рисунки в выбранном диапазоне  
  If TypeName(Selection) <> "Range" Then Exit Sub  
  Dim oDraw  
  On Error Resume Next  
  With CreateObject("Scripting.Dictionary")  
     For Each oDraw In ActiveSheet.DrawingObjects   '.ShapeRange  
        If Not Intersect(Selection, Range(oDraw.TopLeftCell, oDraw.BottomRightCell)) Is Nothing Then .Add oDraw.Name, oDraw  
     Next  
     If .Count > 0 Then ActiveSheet.Shapes.Range(.keys).Select  
  End With  
End Sub  
 
Ещё раз спасибо за советы.
С уважением, Алексей (ИМХО: Excel-2003 - THE BEST!!!)
 
Лёша, рад тебя видеть!  
Попробуй переименовать гр. объект (это важно), а затем создай несколько копий - имя сдублируется!
 
Володя, спасибо за подсказку.  
И действительно, после копирования переименованных группированных объектов они получают одинаковые имена!  
Чушь какая!!! Но что-то у них разное должно ведь быть. Иначе Excel не смог бы их корректно обрабатывать.  
Ща попытаюсь разобраться...
С уважением, Алексей (ИМХО: Excel-2003 - THE BEST!!!)
 
Думал разобраться при помощи макрорекордера...  
Сделал на листе две автофигуры-смайлики, сгруппировал их и назвал группированый объект Smile1  
Потом два раза скопировал его.  
Получил на листе ещё два сгруппированных объекта Smile1 (обалдеть!!! ???)  
Включил макрорекордер и записал последовательность действий:  
1. Выбор мышкой одной группы  
2. Выбор мышкой второй группы  
3. Выбор мышкой третьей группы  
4. Выбор мышкой второй группы  
5. Удаление выбранной группы  
Остановил запись. Посмотрел, что записалось и ещё раз обалдел:  
Sub Макрос1()  
   ActiveSheet.Shapes("Smile1").Select  
   ActiveSheet.Shapes("Smile1").Select  
   ActiveSheet.Shapes("Smile1").Select  
   ActiveSheet.Shapes("Smile1").Select  
   Selection.Delete  
End Sub  
 
И как тут можно обращаться к объектам?  
Не понимаю...
С уважением, Алексей (ИМХО: Excel-2003 - THE BEST!!!)
 
Лёш, меня пора отстреливать за косноязычие!  
Я имел в виду графический объект, а не группированный объект  
Всё, что поименовано после переименования будет плодить себе подобное (увы или ура?)  
Дальше - больше: при копировании всех объектов в новую книгу часть имён изменится (те, что ты переименовал - нет)  
А ещё интереснее то, что отдельные имена, присвоенные самим приложением по умолчанию, будут изменены даже при (cut >> paste) в новую книгу!
 
{quote}{login=Alex_ST}{date=09.04.2012 10:19}{thema=}{post}И как тут можно обращаться к объектам?  
Не понимаю...{/post}{/quote}  
Ну, так а я ж за что? См. вариант с коллекцией :-)
 
ZVI,  
я уже и сам понял на предыдущем опыте, что использовать имена объектов в качестве ключей словаря не удастся.  
Но ведь никто не мешает каждый рисованный объект запоминать как oDict.Item под ключом Key := oDoct.Count+1  
Зато потом можно будет без перебора одним махом считать массив oDict.Items и выделить их все.  
Только вот вопрос, а что за объекты будут запоминаться в каждом из oDict.Item и можно ли всё-таки по ним однозначно идентифицировать разные объекты, имеющие одинаковые имена?  
Ща попробую. Отпишусь.
С уважением, Алексей (ИМХО: Excel-2003 - THE BEST!!!)
 
Лёш, те же проблемы в нашем с тобой фитнесе  
Там надо восстановить имена графич. объектов после копирования в новую книгу  
Вот где как воздух нужна полная ясность, поэтому позволю себе обрисовать картину настолько полно, насколько смогу  
Для DrawingObjects (DO):  
 - оригинальные имена легко изменяются на пользовательские;  
 - пользовательские имена сохраняются при копировании, в том числе в другую книгу (исключение - OLE);  
 - оригинальные имена групп (включая вложенные) и OLE могут быть изменены при копировании и даже вырезании в новую книгу.  
 
Очень стабильно ведёт себя свойство AlternativeText, поэтому его можно использовать для записи идентификационного номера коллекции, что позволит восстановить нарушенные имена  
Для внутренних элементов групп начиная с XL2002 (или 2003?) возможно переименование без разгруппировки. Если интересно, соотв. процедуру напишу вечером
 
Алексей, тогда зачем нужен словарь?  
Сохраняйте объекты сразу в массив, индекс элемента массива сделает то же самое, что и в Вашем варианте делает Key:= oDoct.Count+1, только быстрее и с меньшими затратами памяти.
 
Что-то я никак не соображу, что делать с этим массивом объектов (не важно, как он получен - прямым набором объектов в массив или накоплением в словаре)?  
Ну получил я массив объектов, а как их теперь все выделить?
С уважением, Алексей (ИМХО: Excel-2003 - THE BEST!!!)
 
Ну никак не получается загнать массив рисованных объектов в ShapeRange чтобы их потом выделить … :(
С уважением, Алексей (ИМХО: Excel-2003 - THE BEST!!!)
 
Всё будет хорошо!  
 
1) Работаем только с DrawingObjects  
2) Обходим в цикле, проверяем на пересечение с диапазоном  
3) Для выделения с накоплением применяем метод .Select с аргументом False:  
 
.DrawingObjects(i).Select (False)
 
тогда так:  
 
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
 
Володя, я отходил на совещание, а потом покрутил твой вариант.  
Получилось практически то же, что и у тебя. Всё отлично работает.  
 
А вот вариант СЛЭНа выделяет что-то не понятное (см. в аттаче разные варианты)
С уважением, Алексей (ИМХО: Excel-2003 - THE BEST!!!)
 
А ведь у СЛЭНа вариант красивее  
Я-то схимичил, а у него всё задумано капитально  
Это всё Микрософт виноват!  
 
По поводу DrawingObjects: их нет в ObjectBrowser, значит этот объект поддерживается, но заменён новым (по-видимому, Shapes)  
Но если в ObjectBrowser щелкнуть правой клавишей и выбрать Show Hidden Members, то DrawingObjects появятся, только будет выглядеть бледно (обижают нашего брата)  
Появиться и что-то из справки
 
Алексей, не понятно, зачем Вам нужно выделять картинки, обычно 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
 
Лёш, а что будем делать с Ole?
 
{quote}{login=v__step}{date=09.04.2012 04:47}{thema=}{post}... что будем делать с Ole?{/post}{/quote}  
Не знаю,что в конечном итоге изобретаетсся, но всегда можно проверить тип.  
 
Владимир, для Вашего варианта это:  
 
If x.Type = msoPicture Then  
 If Not Intersect(Range(x.TopLeftCell, x.BottomRightCell), r) Is Nothing Then x.Select False  
End If  
 
Понятно, что вместо  = msoPicture могут быть и другие проверки, в том числе и:  
If x.Type <> msoEmbeddedOLEObject  Then
 
ZVI,  
это предварительная проработка очередного подхода к "поднятию тяжести" - фитнесу ожиревших файлов (Володя [v_step] сразу догадался).
Нужно будет в новый файл копировать только те картинки, которые захватываются UsedRange.  
Про другие объекты пока не пробовал. Но объекты, которые вуделить можно только в режиме конструктора (там в моём примере есть чек-бокс и комманд баттон), тоже выделяются.  
 
Володя[v_step]? а просвети про разницу между Selection, которое привык юзать я, и ActiveWindow.RangeSelection, которое использовал в своём примере ты? (одинаково работает в макросе и так и так)
С уважением, Алексей (ИМХО: Excel-2003 - THE BEST!!!)
 
Легко  
RangeSelection имеет тип Range, а ведь могут быть выделены и другие объекты  
 
По поводу фитнеса - вчера вечером наконец выложил очередную версию, где не столько что-то добавил, сколько исправил ряд ошибок и упростил что смог  
А в журнале с удовольствием сослался на помощь Казанского и ZVI
 
To ZVI: Я имел в виду проблему с выделением OLE вне режима конструктора  
Сейчас всё действительно сработало просто так, что меня удивило и обрадовало
Страницы: 1 2 След.
Читают тему (гостей: 1)
Наверх