Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Как определить высоту вставленной картинки - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
Страница 1 из 11
Модератор форума: _Boroda_, Pelena, Manyasha, SLAVICK 
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Как определить высоту вставленной картинки (Макросы/Sub)
Как определить высоту вставленной картинки
Udik Дата: Понедельник, 21.11.2016, 15:38 | Сообщение № 1
Группа: Друзья
Ранг: Старожил
Сообщений: 1201
Репутация: 152 ±
Замечаний: 0% ±

Excel 2013
Такой вопрос встал, копирую картинку из одной ячейки в другую. И как у этой скопированной картинки определять имя, высоту/ширину и т.д. Как к ней вообще обращаться, имена у "старой" и новой получаются одинаковые? Как удалить "новую"картинку из ячейки?
[vba]
Код

Public Sub test()

Range("A4").Copy Range("C4")
End Sub

[/vba]
К сообщению приложен файл: 0t.xlsm(21Kb)


вот вам барабан
яд 41001231307558 wm R419131876897
udik1968@gmail.com
 
Ответить
СообщениеТакой вопрос встал, копирую картинку из одной ячейки в другую. И как у этой скопированной картинки определять имя, высоту/ширину и т.д. Как к ней вообще обращаться, имена у "старой" и новой получаются одинаковые? Как удалить "новую"картинку из ячейки?
[vba]
Код

Public Sub test()

Range("A4").Copy Range("C4")
End Sub

[/vba]

Автор - Udik
Дата добавления - 21.11.2016 в 15:38
Roman777 Дата: Понедельник, 21.11.2016, 15:59 | Сообщение № 2
Группа: Проверенные
Ранг: Ветеран
Сообщений: 700
Репутация: 75 ±
Замечаний: 20% ±

Excel 2007, Excel 2013
Udik,
Я, обычно делаю, типа такого:
[vba]
Код
Sub test()
Dim o As Object
For Each o In ActiveSheet.Shapes
If o.Top > Range("A4").Top And o.Top < Range("A5").Top _
And o.Left > Range("A4").Left And o.Left < Range("B5").Left Then
    MsgBox o.Name
    o.Delete
End If
Next o
End Sub
[/vba]


Много чего не знаю!!!!
 
Ответить
СообщениеUdik,
Я, обычно делаю, типа такого:
[vba]
Код
Sub test()
Dim o As Object
For Each o In ActiveSheet.Shapes
If o.Top > Range("A4").Top And o.Top < Range("A5").Top _
And o.Left > Range("A4").Left And o.Left < Range("B5").Left Then
    MsgBox o.Name
    o.Delete
End If
Next o
End Sub
[/vba]

Автор - Roman777
Дата добавления - 21.11.2016 в 15:59
Pelena Дата: Понедельник, 21.11.2016, 16:22 | Сообщение № 3
Группа: Модераторы
Ранг: Экселист
Сообщений: 9839
Репутация: 2252 ±
Замечаний: 0% ±

Excel 2010 & Mac Excel 2011
Или типа такого
[vba]
Код
Public Sub test()
    Dim sh As Shape
    Range("A4").Copy Range("C4")
    For Each sh In ActiveSheet.Shapes
        If sh.TopLeftCell.Address = "$C$4" Then
            MsgBox "Удаляем " & sh.Name & " высотой " & sh.Height & Chr(10) & " из ячейки " & sh.TopLeftCell.Address
            sh.Delete
        End If
    Next sh
End Sub
[/vba]


"Черт возьми, Холмс! Но как??!!"
ЯД 41001765434816
 
Ответить
СообщениеИли типа такого
[vba]
Код
Public Sub test()
    Dim sh As Shape
    Range("A4").Copy Range("C4")
    For Each sh In ActiveSheet.Shapes
        If sh.TopLeftCell.Address = "$C$4" Then
            MsgBox "Удаляем " & sh.Name & " высотой " & sh.Height & Chr(10) & " из ячейки " & sh.TopLeftCell.Address
            sh.Delete
        End If
    Next sh
End Sub
[/vba]

Автор - Pelena
Дата добавления - 21.11.2016 в 16:22
_Boroda_ Дата: Понедельник, 21.11.2016, 16:34 | Сообщение № 4
Группа: Модераторы
Ранг: Экселист
Сообщений: 9346
Репутация: 3922 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
Или такого
Присваиваем новой картинке имя hhh, а дальше уже работаем с этим именем
[vba]
Код
Sub test77()
    With ActiveSheet
        .Range("A4").Copy .Range("C4")
        .Shapes(.Shapes.Count).Name = "hhh"
    End With
End Sub
[/vba]
Основано на том, что у нововставленной картинки наибольший индекс


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеИли такого
Присваиваем новой картинке имя hhh, а дальше уже работаем с этим именем
[vba]
Код
Sub test77()
    With ActiveSheet
        .Range("A4").Copy .Range("C4")
        .Shapes(.Shapes.Count).Name = "hhh"
    End With
End Sub
[/vba]
Основано на том, что у нововставленной картинки наибольший индекс

Автор - _Boroda_
Дата добавления - 21.11.2016 в 16:34
Udik Дата: Понедельник, 21.11.2016, 16:46 | Сообщение № 5
Группа: Друзья
Ранг: Старожил
Сообщений: 1201
Репутация: 152 ±
Замечаний: 0% ±

Excel 2013
Без перебора всех картинок не обойтись, похоже :) Немного код модернизировал, чтобы определить находится ли левый верхний угол картинки в проверяемой ячейке.
[vba]
Код

Public Sub test()
Dim rng1 As Range
Dim o As Object

Set rng1 = Range("A4")
rng1.Copy Range("C4")
For Each o In ActiveSheet.Shapes
If o.TopLeftCell.Column = rng1.Column And o.TopLeftCell.Column = rng1.Column Then
    MsgBox o.Name
    o.Delete
End If
Next o
End Sub
[/vba]

==
Вариант Бороды наиболее интересный, позволяет обойтись без перебора.
Пока писал, Лена свой вариант предложила. У меня чет ругаться на Адрес стал, поэтому я через столбцы и строки пошел.

Спасибо всем!


вот вам барабан
яд 41001231307558 wm R419131876897
udik1968@gmail.com


Сообщение отредактировал Udik - Понедельник, 21.11.2016, 16:59
 
Ответить
СообщениеБез перебора всех картинок не обойтись, похоже :) Немного код модернизировал, чтобы определить находится ли левый верхний угол картинки в проверяемой ячейке.
[vba]
Код

Public Sub test()
Dim rng1 As Range
Dim o As Object

Set rng1 = Range("A4")
rng1.Copy Range("C4")
For Each o In ActiveSheet.Shapes
If o.TopLeftCell.Column = rng1.Column And o.TopLeftCell.Column = rng1.Column Then
    MsgBox o.Name
    o.Delete
End If
Next o
End Sub
[/vba]

==
Вариант Бороды наиболее интересный, позволяет обойтись без перебора.
Пока писал, Лена свой вариант предложила. У меня чет ругаться на Адрес стал, поэтому я через столбцы и строки пошел.

Спасибо всем!

Автор - Udik
Дата добавления - 21.11.2016 в 16:46
krosav4ig Дата: Вторник, 22.11.2016, 02:59 | Сообщение № 6
Группа: Друзья
Ранг: Старожил
Сообщений: 1334
Репутация: 533 ±
Замечаний: 0% ±

Excel 2007, 2013
Танцы с бубном заказывали? :D
[vba]
Код
Sub dd()
    Dim cell(3) As Range, sel(1) As Object, sh As Worksheet, shts As Sheets, I, r As Range, l, t
    Application.EnableEvents = 0
    With ThisWorkbook.Windows(1)
        Set shts = .SelectedSheets: Set sh = ActiveSheet: Set cell(0) = .VisibleRange(1, 1)
        Set sel(0) = Selection: Set cell(1) = ActiveCell
        Set r = [Лист2!A4]: r.Parent.Select
        Set cell(2) = .VisibleRange(1, 1): Set cell(3) = ActiveCell
        Set sel(1) = Selection
        Application.Goto r, 1
        For I = 1 To .Panes.Count
            If Not Intersect(r, .Panes(I).VisibleRange) Is Nothing Then
                With .Panes(I)
                    Dim pic
                    l = .PointsToScreenPixelsX(r.Left) + 1
                    t = .PointsToScreenPixelsY(r.Top) + 1
                    AppActivate (Application.Caption)
                    DoEvents
                    Set pic = ActiveWindow.RangeFromPoint(l, t)
                    Debug.Print pic.Name
                    Stop
                End With
            End If
        Next
        Application.Goto cell(2): sel(1).Select: cell(3).Activate
        shts.Select: sh.Activate: Application.Goto cell(0), 1: sel(0).Select: cell(1).Activate
        Erase cell, sel: Set sh = Nothing: Set shts = Nothing: Set r = Nothing
    End With
    Application.EnableEvents = 1
End Sub
[/vba]


(_)Õvõ(_)

Сообщение отредактировал krosav4ig - Вторник, 22.11.2016, 03:08
 
Ответить
СообщениеТанцы с бубном заказывали? :D
[vba]
Код
Sub dd()
    Dim cell(3) As Range, sel(1) As Object, sh As Worksheet, shts As Sheets, I, r As Range, l, t
    Application.EnableEvents = 0
    With ThisWorkbook.Windows(1)
        Set shts = .SelectedSheets: Set sh = ActiveSheet: Set cell(0) = .VisibleRange(1, 1)
        Set sel(0) = Selection: Set cell(1) = ActiveCell
        Set r = [Лист2!A4]: r.Parent.Select
        Set cell(2) = .VisibleRange(1, 1): Set cell(3) = ActiveCell
        Set sel(1) = Selection
        Application.Goto r, 1
        For I = 1 To .Panes.Count
            If Not Intersect(r, .Panes(I).VisibleRange) Is Nothing Then
                With .Panes(I)
                    Dim pic
                    l = .PointsToScreenPixelsX(r.Left) + 1
                    t = .PointsToScreenPixelsY(r.Top) + 1
                    AppActivate (Application.Caption)
                    DoEvents
                    Set pic = ActiveWindow.RangeFromPoint(l, t)
                    Debug.Print pic.Name
                    Stop
                End With
            End If
        Next
        Application.Goto cell(2): sel(1).Select: cell(3).Activate
        shts.Select: sh.Activate: Application.Goto cell(0), 1: sel(0).Select: cell(1).Activate
        Erase cell, sel: Set sh = Nothing: Set shts = Nothing: Set r = Nothing
    End With
    Application.EnableEvents = 1
End Sub
[/vba]

Автор - krosav4ig
Дата добавления - 22.11.2016 в 02:59
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Как определить высоту вставленной картинки (Макросы/Sub)
Страница 1 из 11
Поиск:

Яндекс цитирования
© 2010-2016 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!