Всем привет. Появился вопрос следующего содержания:
Как сделать все объекты, которые стоят от прямоугольника 1 - дальше 100 единиц - невидимыми. ? То есть фигуры, что стоят ближе 100 - видимы, а те что дальше 100 - невидимы.
Всем привет. Появился вопрос следующего содержания:
Как сделать все объекты, которые стоят от прямоугольника 1 - дальше 100 единиц - невидимыми. ? То есть фигуры, что стоят ближе 100 - видимы, а те что дальше 100 - невидимы.bazanski
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]
Если же необходимо считать именно расстояния от самих границ фигур, будет сложнее. Необходимо будет учитывать фигура построена ломанной линией или сплайном (со сплайном всё гораздо сложнее будет). Если будут только прямоугольники, то можно будет переписать относительно несильно изменив код.
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
Много чего не знаю!!!!
Сообщение отредактировал Roman777 - Суббота, 22.12.2018, 12:01
как сделать, чтобы этот макрос работал только только в диапазоне 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
как сделать, чтобы этот макрос работал только только в диапазоне 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