Образмеривание плит Автор: Dmitry Rudenko Эта статья ещё не завершена. Вы можете помочь проекту, исправив или дополнив её. Dim ms Set ms = ThisDrawing.ModelSpace Dim ut Set ut = ThisDrawing.Utility ut.Prompt "" Dim sSet, line, ax, check2 Dim i, m, cnt, ppt0, ppt1, ax0, ax1, pt0(2), pt1(2), pt2(2) check2 = 0 pt0(2) = 0 pt1(2) = 0 pt2(2) = 0 dim dx, dy dx = 999999 dy = 999999 set sSet = ThisDrawing.ActiveSelectionSet sSet.SelectOnScreen cnt = sSet.Count for i=0 to cnt-1 set line = sSet.Item(i) if (line.ObjectName = "AcDbLine") then if line.Layer = "КЖ_элементы ПМ" then ppt0 = ut.CreateSafeArrayFromVector(line.StartPoint) ppt1 = ut.CreateSafeArrayFromVector(line.EndPoint) pt0(0) = (ppt0(0) + ppt1(0))/2 pt0(1) = (ppt0(1) + ppt1(1))/2 if int(ppt0(0)) = int(ppt1(0)) then 'ut.Prompt "вертикальная грань" for m=0 to cnt-1 set ax = sSet.Item(m) if (ax.ObjectName = "AcDbLine") then if ax.Layer = "КЖ_оси" then ax0 = ut.CreateSafeArrayFromVector(ax.StartPoint) ax1 = ut.CreateSafeArrayFromVector(ax.EndPoint) if int(ax0(0)) = int(ax1(0)) then 'ut.Prompt "вертикальная ось" if abs(pt0(0) - ax0(0)) < dx then dx = abs(pt0(0) - ax0(0)) pt1(0) = ax0(0) pt1(1) = pt0(1) end if end if end if end if next dx = 999999 pt2(0) = (pt0(0) + ax0(0))/2 pt2(1) = pt0(1) - 100 DimAlignedText pt0, pt1, pt2 else if int(ppt0(1)) = int(ppt1(1)) then 'ut.Prompt "горизонтальная грань" for m=0 to cnt-1 set ax = sSet.Item(m) if (ax.ObjectName = "AcDbLine") then if ax.Layer = "КЖ_оси" then ax0 = ut.CreateSafeArrayFromVector(ax.StartPoint) ax1 = ut.CreateSafeArrayFromVector(ax.EndPoint) if int(ax0(1)) = int(ax1(1)) then 'ut.Prompt "горизонтальная ось" if abs(pt0(1) - ax0(1)) < dy then dy = abs(pt0(1) - ax0(1)) pt1(0) = pt0(0) pt1(1) = ax0(1) end if end if end if end if next dy = 999999 pt2(0) = pt0(0) - 100 pt2(1) = (pt0(1) + ax0(1))/2 DimAlignedText pt0, pt1, pt2 end if end if end if else check2 = 1 end if next ut.Prompt "Готово, проверяй!" if check2 = 1 then ut.Prompt " " ut.Prompt "Внимание! В набор вошли не только отрезки" end if sSet.Clear Sub DimAlignedText(pt0,pt1, pt2) Dim oDim Set oDim = ms.AddDimAligned(pt0, pt1, pt2) oDim.Layer = "КЖ_размеры" 'oDim.TextOverride = dimtext oDim.ScaleFactor = "100" oDim.TextInside = true End Sub nanocad , vba , отрезки , swell