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

Вход

Регистрация

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

 

= Мир MS Excel/Невидимость объектов на определенном расстоянии - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, Manyasha, SLAVICK, китин  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Невидимость объектов на определенном расстоянии (Макросы/Sub)
Невидимость объектов на определенном расстоянии
bazanski Дата: Пятница, 21.12.2018, 18:42 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 4
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Всем привет.
Появился вопрос следующего содержания:

Как сделать все объекты, которые стоят от прямоугольника 1 - дальше 100 единиц - невидимыми. ?
То есть фигуры, что стоят ближе 100 - видимы, а те что дальше 100 - невидимы.
К сообщению приложен файл: 6629234.xls(66.5 Kb)
 
Ответить
СообщениеВсем привет.
Появился вопрос следующего содержания:

Как сделать все объекты, которые стоят от прямоугольника 1 - дальше 100 единиц - невидимыми. ?
То есть фигуры, что стоят ближе 100 - видимы, а те что дальше 100 - невидимы.

Автор - bazanski
Дата добавления - 21.12.2018 в 18:42
Roman777 Дата: Суббота, 22.12.2018, 11:55 | Сообщение № 2
Группа: Проверенные
Ранг: Ветеран
Сообщений: 956
Репутация: 122 ±
Замечаний: 0% ±

Excel 2007, Excel 2013
bazanski, если считать расстояния между центрами фигур можно так.
[vba]
Код
Sub makro1()
    Dim shps As Shapes, shp As Shape
    Dim i As Long, x1,x2,y1,y2
    Set shps = ActiveSheet.Shapes
    Set shp = ActiveSheet.Shapes("Прямоугольник 1")
    For i = 1 To shps.Count
        If Not shps(i) Is shp And shps(i).Name <> "Oval 19" Then
            x1 = shps(i).Left + shps(i).Width / 2
            y1 = shps(i).Top + shps(i).Height / 2
            x2 = shp.Left + shp.Width / 2
            y2 = shp.Top + shp.Height / 2
            If ((x2 - x1) ^ 2 + (y2 - y1) ^ 2) ^ 0.5 > 100 Then
                shps(i).Fill.Transparency = 1
                shps(i).Line.Transparency = 1
            Else
                shps(i).Fill.Transparency = 0
                shps(i).Line.Transparency = 0
            End If
        End If
    Next i
End Sub
[/vba]

Если же необходимо считать именно расстояния от самих границ фигур, будет сложнее. Необходимо будет учитывать фигура построена ломанной линией или сплайном (со сплайном всё гораздо сложнее будет).
Если будут только прямоугольники, то можно будет переписать относительно несильно изменив код.


Много чего не знаю!!!!

Сообщение отредактировал Roman777 - Суббота, 22.12.2018, 12:01
 
Ответить
Сообщениеbazanski, если считать расстояния между центрами фигур можно так.
[vba]
Код
Sub makro1()
    Dim shps As Shapes, shp As Shape
    Dim i As Long, x1,x2,y1,y2
    Set shps = ActiveSheet.Shapes
    Set shp = ActiveSheet.Shapes("Прямоугольник 1")
    For i = 1 To shps.Count
        If Not shps(i) Is shp And shps(i).Name <> "Oval 19" Then
            x1 = shps(i).Left + shps(i).Width / 2
            y1 = shps(i).Top + shps(i).Height / 2
            x2 = shp.Left + shp.Width / 2
            y2 = shp.Top + shp.Height / 2
            If ((x2 - x1) ^ 2 + (y2 - y1) ^ 2) ^ 0.5 > 100 Then
                shps(i).Fill.Transparency = 1
                shps(i).Line.Transparency = 1
            Else
                shps(i).Fill.Transparency = 0
                shps(i).Line.Transparency = 0
            End If
        End If
    Next i
End Sub
[/vba]

Если же необходимо считать именно расстояния от самих границ фигур, будет сложнее. Необходимо будет учитывать фигура построена ломанной линией или сплайном (со сплайном всё гораздо сложнее будет).
Если будут только прямоугольники, то можно будет переписать относительно несильно изменив код.

Автор - Roman777
Дата добавления - 22.12.2018 в 11:55
bazanski Дата: Суббота, 22.12.2018, 12:12 | Сообщение № 3
Группа: Пользователи
Ранг: Прохожий
Сообщений: 4
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Roman777, все хорошо работает.

Подскажите - как сделать, чтобы этот макрос работал только только в диапазоне B4:S45 ?

(Потому что вы добавили в исключение Oval 19", но если фигур-исключений будет больше - их все в коде перечислять очень долго придется. )
 
Ответить
СообщениеRoman777, все хорошо работает.

Подскажите - как сделать, чтобы этот макрос работал только только в диапазоне B4:S45 ?

(Потому что вы добавили в исключение Oval 19", но если фигур-исключений будет больше - их все в коде перечислять очень долго придется. )

Автор - bazanski
Дата добавления - 22.12.2018 в 12:12
Апострофф Дата: Суббота, 22.12.2018, 17:13 | Сообщение № 4
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 181
Репутация: 65 ±
Замечаний: 0% ±

Excel 2003
как сделать, чтобы этот макрос работал только только в диапазоне B4:S45 ?

Проверить - лежат ли углы фигур в указанном диапазоне-
[vba]
Код
Sub makro1()
    Dim shps As Shapes, shp As Shape
    Dim i As Long, x1, x2, y1, y2
    Set shps = ActiveSheet.Shapes
    Set shp = ActiveSheet.Shapes([k3])
    x2 = shp.Left + shp.Width / 2
    y2 = shp.Top + shp.Height / 2
    For i = 1 To shps.Count
          With shps(i)
            If Not (Intersect(.TopLeftCell, [B4:S45]) Is Nothing Or Intersect(.BottomRightCell, [B4:S45]) Is Nothing) Then
              x1 = shps(i).Left + shps(i).Width / 2
              y1 = shps(i).Top + shps(i).Height / 2
              shps(i).Fill.Transparency = -(((x2 - x1) ^ 2 + (y2 - y1) ^ 2) ^ 0.5 > 100)
              shps(i).Line.Transparency = shps(i).Fill.Transparency
            End If
          End With
    Next i
End Sub
[/vba]
 
Ответить
Сообщение
как сделать, чтобы этот макрос работал только только в диапазоне B4:S45 ?

Проверить - лежат ли углы фигур в указанном диапазоне-
[vba]
Код
Sub makro1()
    Dim shps As Shapes, shp As Shape
    Dim i As Long, x1, x2, y1, y2
    Set shps = ActiveSheet.Shapes
    Set shp = ActiveSheet.Shapes([k3])
    x2 = shp.Left + shp.Width / 2
    y2 = shp.Top + shp.Height / 2
    For i = 1 To shps.Count
          With shps(i)
            If Not (Intersect(.TopLeftCell, [B4:S45]) Is Nothing Or Intersect(.BottomRightCell, [B4:S45]) Is Nothing) Then
              x1 = shps(i).Left + shps(i).Width / 2
              y1 = shps(i).Top + shps(i).Height / 2
              shps(i).Fill.Transparency = -(((x2 - x1) ^ 2 + (y2 - y1) ^ 2) ^ 0.5 > 100)
              shps(i).Line.Transparency = shps(i).Fill.Transparency
            End If
          End With
    Next i
End Sub
[/vba]

Автор - Апострофф
Дата добавления - 22.12.2018 в 17:13
bazanski Дата: Суббота, 22.12.2018, 18:57 | Сообщение № 5
Группа: Пользователи
Ранг: Прохожий
Сообщений: 4
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Апострофф, Roman777, спасибо за ответы.
Теперь все работает.
 
Ответить
СообщениеАпострофф, Roman777, спасибо за ответы.
Теперь все работает.

Автор - bazanski
Дата добавления - 22.12.2018 в 18:57
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Невидимость объектов на определенном расстоянии (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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