Округление координат

Автор: Dmitry Rudenko

Небольшой скрипт на VBA, который округляет координаты выделенных отрезков, полилиний и 3dface с заданной точностью

round-selected.vbs

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

---

Небольшой скрипт на VBA, который округляет координаты всех отрезков, полилиний и 3dface с заданной точностью

round-all.vbs

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 scale 
scale = ut.GetInteger("Введите точность округления: ")
 
for i=0 to ms.count-1
	set myObj = ms.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 "Готово, проверяй!"