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

Вход

Регистрация

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

 

= Мир MS Excel/Удаление соединительных линий между 2 фигурами - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Удаление соединительных линий между 2 фигурами
Megamen2 Дата: Вторник, 02.10.2018, 20:29 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 25
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
Здравствуйте. Есть макрос расстановки соединительных линий между фигурами.

В ячейку E3 - вписывается название первой фигуры, а в ячейку E6 - название второй фигуры.
Но это касается рисования линий.
А вот как удалить соединительные линии - я не понимаю.

Подскажите как удалить соединительные линии (одну или несколько), соединяющие две указанные в этих ячейках фигуры ?
К сообщению приложен файл: 222.xls (70.0 Kb)
 
Ответить
СообщениеЗдравствуйте. Есть макрос расстановки соединительных линий между фигурами.

В ячейку E3 - вписывается название первой фигуры, а в ячейку E6 - название второй фигуры.
Но это касается рисования линий.
А вот как удалить соединительные линии - я не понимаю.

Подскажите как удалить соединительные линии (одну или несколько), соединяющие две указанные в этих ячейках фигуры ?

Автор - Megamen2
Дата добавления - 02.10.2018 в 20:29
krosav4ig Дата: Вторник, 02.10.2018, 23:09 | Сообщение № 2
Группа: Друзья
Ранг: Старожил
Сообщений: 2347
Репутация: 997 ±
Замечаний: 0% ±

Excel 2007,2010,2013
Здравствуйте. Как-то так
[vba]
Код
Sub Нарисовать()
Dim o1 As Shape, o2 As Shape
Set o1 = ActiveSheet.Shapes([E3])
Set o2 = ActiveSheet.Shapes([E6])
Dim x1!, y1!, r1!, x2!, y2!, r2!, xa!, ya!, xb!, yb!
GetParam o1, x1, y1, r1
GetParam o2, x2, y2, r2
Dim i&, j&, p#, l!, lmin!
Dim x1t!, y1t!, x2t!, y2t!, bc&, ec&
p = Atn(1)
lmin = [a65536].Top - [a1].Top
For i = 0 To 7
  x1t = x1 + Cos(p * i) * r1
  y1t = y1 - Sin(p * i) * r1
  For j = 0 To 7
    x2t = x2 + Cos(p * j) * r2
    y2t = y2 - Sin(p * j) * r2
    l = Sqr((x1t - x2t) ^ 2 + (y1t - y2t) ^ 2)
    If l < lmin Then
      lmin = l
      xa = x1t
      ya = y1t
      xb = x2t
      yb = y2t
      bc = i
      ec = j
    End If
  Next
Next
With ActiveSheet.Shapes.AddConnector(msoConnectorStraight, xa, ya, xb, yb)
    .ConnectorFormat.BeginConnect o1, (bc + 6) Mod 8 + 1
    .ConnectorFormat.EndConnect o2, (ec + 6) Mod 8 + 1
    .Name = [E3] & "|" & [E6]
End With
End Sub

Sub Удалить()
    On Error Resume Next
    ActiveSheet.Shapes([E3] & "|" & [E6]).Delete
    If Err = 0 Then Exit Sub
    Dim o1 As Shape, o2 As Shape, o3 As Shape, o4 As Shape
    Set o1 = ActiveSheet.Shapes([E3])
    Set o2 = ActiveSheet.Shapes([E6])
    For Each sh In ActiveSheet.Shapes
        If sh.Connector Then
            With sh.ConnectorFormat
                Set o3 = .BeginConnectedShape
                Set o4 = .EndConnectedShape
                If o1 Is o3 And o2 Is o4 Or o1 Is o4 And o2 Is o3 Then
                    sh.Delete
                    Exit For
                End If
            End With
        End If
    Next
End Sub
[/vba]


email:krosav4ig26@gmail.com WMR R207627035142 WMZ Z821145374535 ЯД 410012026478460
 
Ответить
СообщениеЗдравствуйте. Как-то так
[vba]
Код
Sub Нарисовать()
Dim o1 As Shape, o2 As Shape
Set o1 = ActiveSheet.Shapes([E3])
Set o2 = ActiveSheet.Shapes([E6])
Dim x1!, y1!, r1!, x2!, y2!, r2!, xa!, ya!, xb!, yb!
GetParam o1, x1, y1, r1
GetParam o2, x2, y2, r2
Dim i&, j&, p#, l!, lmin!
Dim x1t!, y1t!, x2t!, y2t!, bc&, ec&
p = Atn(1)
lmin = [a65536].Top - [a1].Top
For i = 0 To 7
  x1t = x1 + Cos(p * i) * r1
  y1t = y1 - Sin(p * i) * r1
  For j = 0 To 7
    x2t = x2 + Cos(p * j) * r2
    y2t = y2 - Sin(p * j) * r2
    l = Sqr((x1t - x2t) ^ 2 + (y1t - y2t) ^ 2)
    If l < lmin Then
      lmin = l
      xa = x1t
      ya = y1t
      xb = x2t
      yb = y2t
      bc = i
      ec = j
    End If
  Next
Next
With ActiveSheet.Shapes.AddConnector(msoConnectorStraight, xa, ya, xb, yb)
    .ConnectorFormat.BeginConnect o1, (bc + 6) Mod 8 + 1
    .ConnectorFormat.EndConnect o2, (ec + 6) Mod 8 + 1
    .Name = [E3] & "|" & [E6]
End With
End Sub

Sub Удалить()
    On Error Resume Next
    ActiveSheet.Shapes([E3] & "|" & [E6]).Delete
    If Err = 0 Then Exit Sub
    Dim o1 As Shape, o2 As Shape, o3 As Shape, o4 As Shape
    Set o1 = ActiveSheet.Shapes([E3])
    Set o2 = ActiveSheet.Shapes([E6])
    For Each sh In ActiveSheet.Shapes
        If sh.Connector Then
            With sh.ConnectorFormat
                Set o3 = .BeginConnectedShape
                Set o4 = .EndConnectedShape
                If o1 Is o3 And o2 Is o4 Or o1 Is o4 And o2 Is o3 Then
                    sh.Delete
                    Exit For
                End If
            End With
        End If
    Next
End Sub
[/vba]

Автор - krosav4ig
Дата добавления - 02.10.2018 в 23:09
Megamen2 Дата: Вторник, 02.10.2018, 23:48 | Сообщение № 3
Группа: Пользователи
Ранг: Новичок
Сообщений: 25
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
Спасибо
 
Ответить
СообщениеСпасибо

Автор - Megamen2
Дата добавления - 02.10.2018 в 23:48
  • Страница 1 из 1
  • 1
Поиск:

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