Рисуем термовкладыши Автор: Dmitry Rudenko Скрипт для замены выбранных отрезков на замкнутые прямоугольники со штриховкой. Длина прямоугольника равна длине отрезка, ширина - либо задаётся с клавиатуры, либо равна 200 по умолчанию. Dim ms Set ms = ThisDrawing.ModelSpace Dim ut Set ut = ThisDrawing.Utility 'создаём слой и настраиваем его Dim layer Set layer = ThisDrawing.Layers.Add("КЖ_элементы ПМ перфорация") layer.color = "140" layer.lineweight = 15 ut.Prompt "Скрипт для замены выбранных отрезков на замкнутые прямоугольники со штриховкой" Dim line, check2 check2 = 0 Dim ppt0, ppt1, pt0(11) pt0(2) = 0 pt0(5) = 0 pt0(8) = 0 pt0(11) = 0 Dim solid Dim pi pi = 3.14159265359 Dim height, height1, height2 'height = ut.GetInteger("Введите высоту стен: ") 'height = 100 height1 = 100 'down height2 = 100 'up 'настройки штриховки dim hatch set hatch = ms.AddHatch(1, "ANSI37", True) hatch.PatternScale = 30 hatch.Layer = "КЖ_элементы ПМ перфорация" Dim sSet, cnt set sSet = ThisDrawing.ActiveSelectionSet sSet.SelectOnScreen cnt = sSet.Count Dim i for i=0 to cnt-1 set line = sSet.Item(i) 'ut.Prompt CStr(line.ObjectName) if (line.ObjectName = "AcDbLine") then if line.length > 199 then ppt0 = ut.CreateSafeArrayFromVector(line.StartPoint) ppt1 = ut.CreateSafeArrayFromVector(line.EndPoint) 'проверяем, чтобы не делить на ноль if ppt1(0)-ppt0(0) <> 0 then alfa = atn((ppt1(1)-ppt0(1))/(ppt1(0)-ppt0(0))) else alfa = 0.5 * pi end if pt0(0) = ppt0(0)+height1*cos(0.5*pi - alfa) pt0(1) = ppt0(1)-height1*cos(alfa) pt0(3) = ppt1(0)+height1*cos(0.5*pi - alfa) pt0(4) = ppt1(1)-height1*cos(alfa) pt0(6) = ppt1(0)-height2*cos(0.5*pi - alfa) pt0(7) = ppt1(1)+height2*cos(alfa) pt0(9) = ppt0(0)-height2*cos(0.5*pi - alfa) pt0(10) = ppt0(1)+height2*cos(alfa) set solid = ms.AddPolyLine(pt0) solid.closed = true solid.Layer = "КЖ_элементы ПМ перфорация" line.delete 'удаляем исходную линию hatch.AppendOuterLoop(solid) 'рисуем штриховку else line.delete end if else check2 = 1 'line.delete end if next hatch.Evaluate ut.Prompt "Готово, проверяй!" if check2 = 1 then ut.Prompt " " ut.Prompt "Внимание! В набор вошли не только отрезки" end if sSet.Clear nanocad , vba , отрезки , swell