Wiki ЖБК

Материалы для проектирования железобетонных конструкций

Инструменты пользователя

Инструменты сайта


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

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

Автор: 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 "Готово, проверяй!"

Обсуждение

Vladimir, 2013-03-20 09:56
В поэтажных планах встречаются еще и точки, думаю добавить округление координат точек не лишнее.
xokhotax, 2013-09-10 17:50
А есть подобный скрипт для AutoCad
Dmitry Rudenko, 2013-09-11 13:15
Да, вот здесь: http://experement.spb.ru/wiki/doku.php?id=rounding_coordinates
tohaha, 2013-11-30 11:39
программа по этой ссылке не округляет координаты 3д граней. подскажите как для 3д граней сделать выравнивание координат. пока нигде не нашел???
Dmitry Rudenko, 2013-11-30 12:43
Добрый день.
Если я и могу чем помочь, то только для нанокада, т.к. автокадом я не пользуюсь. Если решение нужно для автокада - посмотрите/спросите здесь: http://experement.spb.ru/wiki/doku.php?id=rounding_coordinates
tohaha, 2013-11-30 20:28
эту ссылку я и имею в виду
Dmitry Rudenko, 2013-11-30 23:03
Так а Вы написали Владимиру? Я думаю ему доделать свою программу - дело нескольких минут. Я могу свой код допилить, но работу могу гарантировать только в нанокаде.
Татьяна, 2018-10-05 16:13
Здравствуйте, Дмитрий.
Благодаря вашей чудесной ссылке прекрасно выравнивала чертежи в автокаде несколько лет!!! Но теперь, адрес не активен и программа не работает. Случайно не знаете, где можно найти активный скрипт?
Dmitry Rudenko, 2018-10-05 16:25
В смысле адрес не активен? Вроде работает всё.
Да и потом, код же есть. Сохраните его в текстовый файлик, дайте расширение vbs и всё будет работать.
Ваш комментарий:
  _____   ___    ___ 
 / ___/  / _ \  / _ |
/ (_ /  / , _/ / __ |
\___/  /_/|_| /_/ |_|
 
PDF Export Download this page as a pdf Text Export Download this page as a plain text
округление_координат.txt · Последнее изменение: 2013-03-14 23:31 (внешнее изменение)

Инструменты страницы