Здравствуйте.
Столкнулся с проблемой.
Макрос записывает в столбец P5:P20 - названия фигур, которые пересекает луч (бесконечная линия).
Луч задается отрезком по двум координатам, заданным в L4:M5.
Посоветуйте, если кто разбирается в этом - как выносить в столбец P5:P20 - те фигуры, которые пересекает не луч (бесконечная линия), а только отрезок ?
Option Explicit
Private shp As Shape, sh As Shape, s$, k#, a#, x#, y#, ok As Boolean, x1#, x2#, y1#, y2#
Sub Линия1()
'Dim shp As Shape, sh As Shape, s$, k#, a#, x#, y#, ok As Boolean, x1#, x2#, y1#, y2#
s = Empty
Range("P5:P33").ClearContents
Dim i&
x1 = Range("L4"): y1 = Range("M4")
x2 = Range("L5"): y2 = Range("M5")
k = (y2 - y1) / (x2 - x1): a = y1 - k * x1
Set shp = ActiveSheet.Shapes.AddLine(x1, y1, x2, y2)
shp.Line.EndArrowheadStyle = msoArrowheadTriangle
shp.Line.Weight = 2
shp.Line.ForeColor.RGB = RGB(255, 0, 0)
For Each sh In ActiveSheet.Shapes
If sh.Name <> shp.Name Then
x = sh.Left: y = k * x + a: ok = IsBetween(y, sh.Top, sh.Top + sh.Height)
If Not ok Then x = sh.Left + sh.Width: y = k * x + a: ok = IsBetween(y, sh.Top, sh.Top + sh.Height)
If Not ok Then y = sh.Top: x = (a - y) / k: ok = IsBetween(x, sh.Left, sh.Left + sh.Width)
If Not ok Then y = sh.Top + sh.Height: x = (a - y) / k: ok = IsBetween(x, sh.Left, sh.Left + sh.Width)
If ok Then s = s & vbLf & sh.Name
End If
Next
Range("P5:P20").Value = Application.Transpose(Split(Mid(s, 2), vbLf))
Range("P5:P20").Replace "#N/A", ""
Application.OnTime DateAdd("s", 3, Now), "Delete1"
End Sub
Function IsBetween(x#, x1#, x2#)
IsBetween = x >= x1 And x <= x2
End Function
Sub Delete1()
shp.Delete
Range("P5:P33").ClearContents
ActiveSheet.Calculate
End Sub