Dim ms Set ms = ThisDrawing.ModelSpace Dim ut Set ut = ThisDrawing.Utility ut.Prompt "Небольшой скрипт на VBA, который округляет координаты выделенных отрезков, полилиний и 3dface с заданной точностью" Dim myObj Dim i, m Dim ppt0, ppt1, pt0(2), pt1(2) Dim ppt3d, pt3d(11), pt3da Dim sSet, cnt set sSet = ThisDrawing.ActiveSelectionSet sSet.SelectOnScreen cnt = sSet.Count Dim scale scale = ut.GetInteger("Введите точность округления: ") for i=0 to cnt-1 set myObj = sSet.Item(i) if (myObj.ObjectName = "AcDbLine") then ppt0 = ut.CreateSafeArrayFromVector(myObj.StartPoint) ppt1 = ut.CreateSafeArrayFromVector(myObj.EndPoint) for m = 0 to 2 if int(ppt0(m)/scale) = int(ppt0(m)/scale+0.5) then pt0(m) = int(ppt0(m)/scale) * scale else pt0(m) = int(ppt0(m)/scale+0.5) * scale end if if int(ppt1(m)/scale) = int(ppt1(m)/scale+0.5) then pt1(m) = int(ppt1(m)/scale) * scale else pt1(m) = int(ppt1(m)/scale+0.5) * scale end if next myObj.StartPoint = pt0 myObj.EndPoint = pt1 end if if (myObj.ObjectName = "AcDbFace") then ppt3d = ut.CreateSafeArrayFromVector(myObj.Coordinates) for m = 0 to 11 if int(ppt3d(m)/scale) = int(ppt3d(m)/scale+0.5) then pt3d(m) = int(ppt3d(m)/scale) * scale else pt3d(m) = int(ppt3d(m)/scale+0.5) * scale end if next ut.CreateTypedArray pt3da, 5, pt3d(0), pt3d(1), pt3d(2), pt3d(3), pt3d(4), pt3d(5), pt3d(6), pt3d(7), pt3d(8), pt3d(9), pt3d(10), pt3d(11) myObj.Coordinates = pt3da end if if (myObj.ObjectName = "AcDbPolyline") then dim pptpl pptpl = ut.CreateSafeArrayFromVector(myObj.Coordinates) dim cntpl cntpl = UBound(myObj.Coordinates) dim ptpl(999) dim ptpls for m = 0 to cntpl if int(pptpl(m)/scale) = int(pptpl(m)/scale+0.5) then ptpl(m) = int(pptpl(m)/scale) * scale else ptpl(m) = int(pptpl(m)/scale+0.5) * scale end if if m = 0 then ptpls = ptpl(m) else ptpls = ptpls & ";" & ptpl(m) end if next myObj.Coordinates = ut.CreateTypedArrayFromJSArray (5, CStr(ptpls)) end if next ut.Prompt "Готово, проверяй!" sSet.Clear