Образмеривание плит
Автор: 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