测量点根据高程投影到剖面上,花了一天时间,算是可以了【EPS基于vbs】

 立面图都是垂直于xoy平面的,我的思路是,绘制一条线,该线为面上的线,根据该线计算面的法向量,然后选中的点任意一点作为面上的点,面上点和法向量唯一确定一个投影面,先将点都投影到这个面,然后将所有点旋转到水平方向,最后根据高程将点“立”起来。没有做异常处理。设计到计算【点在面上投影坐标】、【点绕点旋转】、【计算两点连线与x轴夹角】这三个小问题。当然也有别的思路,比如投影到面上之后,由于都是旋转到水平方向,y轴坐标和旋转点值是一样的,根据距离就可以计算,前提是要判断方向。代码如下,效果见代码后

'将测量点根据高程和投影面展点,用于日照分析测量三视图,断面绘制
'简单模式,一次只操作一个面,选中面上点及方向线,执行脚本,确定,左键
dim a,b,c'投影面法向量
dim xm,ym,zm'投影面上的一点,选择选中的第一个点,法向量和该点唯一确定了投影面
dim ax(),ay(),az(),an()'待转点,n为点名
dim pointCnt'点数
dim deltX,deltY'方向线的坐标差
pointCnt=0
dim lineCnt'线数
dim mx,my'移动后的旋转中心
Const Pi=3.14159265358979323
Sub OnInitScript()
mode = 0 '=0 无参数对话框 =1 有参数对话框
title="功能名称"
SSProcess.ShowScriptDlg mode,title 

SSProcess.UpdateSysSelection 0 
	dim cnt
	cnt=  SSProcess.GetSelGeoCount
	'遍历选择的地物,获取所有点和法线向量
	for i = 0 to cnt-1
		objType=SSProcess.GetSelGeoValue (i, "SSObj_Type")
		if objType="POINT" then
			pointCnt=pointCnt+1'点数累加
			redim preserve ax(pointCnt),ay(pointCnt),az(pointCnt),an(pointCnt)
			SSProcess.GetSelGeoPoint i, 0, x,  y,  z,  ptype,  name 
			ax(pointCnt-1)=x:ay(pointCnt-1)=y:az(pointCnt-1)=z:an(pointCnt-1)=name
		elseif objType="LINE" Then
			SSProcess.GetSelGeoPoint i, 0, xs,  ys,  zs,  ptype,  name 
			SSProcess.GetSelGeoPoint i, 1, xe,  ye,  ze,  ptype,  name
			'一条线,根据线斜率,计算投影面的法向量
			deltX=xe-xs:deltY=ye-ys
			a=deltY:b=-deltX:c=0		
		end if
	next
	xm=ax(0):ym=ay(0):zm=az(0)'面上一点
	'遍历所有点,计算点在面上投影
	for i=0 to pointCnt-1
		GetPrjPoint a,b,c,xm,ym,zm,ax(i),ay(i),az(i)
	next
End Sub
Sub OnExitScript()
'添加代码
End Sub
Sub OnOK()
	
End Sub
Sub OnCancel()
End Sub

Function OnLButtonDown(x, y, spx, spy, flags)
	mx=spx:my=spy
	dx=ax(0)-mx:dy=ay(0)-my
	'将投影后的点平移到左键处
	for i=0 to pointCnt-1
		ax(i)=ax(i)-dx:ay(i)=ay(i)-dy
	next
		angle=GetRotationAngle( 0,0,DeltX,deltY)'计算旋转角
	'计算旋转点
	for i=0 to pointCnt-1
		Rotation mx,my,ax(i),ay(i),angle'旋转
		'绘制该点
		SSProcess.CreateNewObjByCode 9
		SSProcess.AddNewObjPoint ax(i),ay(i)+az(i)-15,az(i),code,an(i)		
		SSProcess.AddNewObjToSaveObjList
	NEXT
End Function
'求点在平面上的投影,其中平面由法向量和面上一点确定
'(x0,y0,z0)为法向量,(x1,y1,z1)为面上点,(x2,y2,z2)为待计算点
function GetPrjPoint(x0,y0,z0,x1,y1,z1,byref x2,byref y2,byref z2)
	t=(x0*x1+y0*y1+z0*z1-(x0*x2+y0*y2+z0*z2))/(x0^2 +y0^2 +z0^2)
	x2=x2+x0*t
	y2=y2+y0*t
	z2=z2+z0*t
end function
'计算两点之间连线与x轴之间的角度(顺时针)
Function GetRotationAngle(x1,y1,x2,y2)
	dx = x2 - x1
	dy = y2 - y1
	GetRotationAngle=atn(dy/dx)*180/Pi
	if dx=0 and dy>0 then
		GetRotationAngle=90
	elseif dx=0 and dy<0 then
		GetRotationAngle=270
	elseif dy<0 and  dx<0 then
		GetRotationAngle=GetRotationAngle+180
	end if
End Function
'执行旋转操作,x0,y0为旋转中心,xs,ys为要旋转的点,ang为旋转的角度,单位为角度
Sub Rotation(x0,y0, xs, ys,byval ang)
	ang=Pi*ang/180
	xa= (xs - x0)*cos(ang) +(ys - y0)*sin(ang) + x0 
	ya= -(xs - x0)*sin(ang) + (ys - y0)*cos(ang) + y0
	xs=xa
	ys=ya
End Sub


  • 0
    点赞
  • 5
    收藏
    觉得还不错? 一键收藏
  • 0
    评论
'统计字符串中是否有文字,是否全是数字 Function hasnoChinese(str) bl = True For i = 1 to Len(str) - 0 'ss=CStr(Asc(Mid(str,i,1))) 'msgbox ss If Asc(Mid(str,i,1)) < 0 Then bl = False End If Next hasnoChinese = bl End Function Function UnAdjustNote(FontClass,dx,dy,widscale,heightscale,nochinese) SSProcess.ClearSelection SSProcess.ClearSelectCondition SSProcess.SetSelectCondition "SSObj_Type", "=", "NOTE" SSProcess.SetSelectCondition "SSObj_FontClass", "=", FontClass SSProcess.SetSelectCondition "[DGNAttr_FontID]", "<>", "188" SSProcess.SelectFilter SSProcess.PushUndoMark notecount = SSProcess.GetSelNoteCount 'msgbox notecount For i=0 To notecount-1 txtx=SSProcess.GetSelNoteValue( i, "SSObj_FontString") If hasnoChinese(txtx) = nochinese Then pointcount = SSProcess.GetSelNotePointCount(i) For j=0 To pointcount-1 Dim x, y, z, pointtype, name SSProcess.GetSelNotePoint i, j, x, y, z, pointtype, name x = x - dx y = y - dy SSProcess.SetSelNotePoint i, j, x, y, z, pointtype, name Next wid=SSProcess.GetSelNoteValue( i, "SSObj_FontWidth") hit=SSProcess.GetSelNoteValue( i, "SSObj_FontHeight") wid1=CStr(CDbl(wid) / widscale) hit1=CStr(CDbl(hit) / heightscale) SSProcess.SetSelNoteValue i, "SSObj_FontWidth", wid1 SSProcess.SetSelNoteValue i, "SSObj_FontHeight", hit1 SSProcess.AddSelNoteToSaveNoteList i End If Next End Function Function changeNoteDw() UnAdjustNote "#",0,0,1.16,1,True UnAdjustNote "#",0,0,1.16,1,False UnAdjustNote "FZ",0,0,1.25,1,True UnAdjustNote "FZ",0,0,1.25,1,False UnAdjustNote "@",0,0,1.275,1,True UnAdjustNote "@",0,0,1.275,1,False UnAdjustNote "899000",0,0,1.27,1,True UnAdjustNote "899000",0,0,1.27,1,False UnAdjustNote "DXLC",0,0,1.333,1,True UnAdjustNote "DXLC",0,0,1.333,1,False UnAdjustNote "499000",-0.117,0,1,1.3,True UnAdjustNote "499000",-0.117,0,1,1.3,False End Function Function UnAdjustNote1(EpsFontClass,dx,dy,widscale,heightscale,nochinese) SSProcess.ClearSelection SSProcess.ClearSelectCondition SSProcess.SetSelectCondition "SSObj_Type", "=", "NOTE" SSProcess.SetSelectCondition "SSObj_FontClass", "=", EpsFontClass SSProcess.SelectFilter SSProcess.PushUndoMark notecount = SSProcess.GetSelNoteCount 'msgbox notecount For i=0 To notecount-1 txtx=SSProcess.GetSelNoteValue( i, "SSObj_FontString") If hasnoChinese(txtx) = nochinese Then pointcount = SSProcess.GetSelNotePointCount(i) For j=0 To pointcount-1 Dim x, y, z, pointtype, name SSProcess.GetSelNotePoint i, j, x, y, z, pointtype, name x = x - dx y = y - dy SSProcess.SetSelNotePoint i, j, x, y, z, pointtype, name Next wid=SSProcess.GetSelNoteValue( i, "SSObj_FontWidth") hit=SSProcess.GetSelNoteValue( i, "SSObj_FontHeight") wid1=CStr(CDbl(wid) / widscale) hit1=CStr(CDbl(hit) / heightscale) SSProcess.SetSelNoteValue i, "SSObj_FontWidth", wid1 SSProcess.SetSelNoteValue i, "SSObj_FontHeight", hit1 SSProcess.AddSelNoteToSaveNoteList i End If Next End Function Function changeNoteDw1() '属于86号字体(居民地注记) UnAdjustNote1 "297000",2.5,0,1.33,1.25,True UnAdjustNote1 "297000",2.5,0,1.33,1.25,False UnAdjustNote1 "297100",1.25,-0.3,1.33,1.25,True UnAdjustNote1 "297100",1.25,-0.3,1.33,1.25,False UnAdjustNote1 "297200",2.25,-0.3,1.33,1.25,True UnAdjustNote1 "297200",2.25,-0.3,1.33,1.25,False UnAdjustNote1 "297500",1.8,0,1.33,1.33,True UnAdjustNote1 "297500",1.8,0,1.33,1.33,False '属于86号字体(地貌注记) UnAdjustNote1 "881000",0.7,-0.15,1.3,1.25,True UnAdjustNote1 "881000",0.7,-0.15,1.3,1.25,False UnAdjustNote1 "882000",0.7,-0.15,1.3,1.33,True UnAdjustNote1 "882000",0.7,-0.15,1.3,1.33,False '属于242号字体(居民地注记) UnAdjustNote1 "297300",1.6,0,1.3,1.3,True UnAdjustNote1 "297300",1.6,0,1.3,1.3,False UnAdjustNote1 "297400",2,0,1.3,1.3,True UnAdjustNote1 "297400",2,0,1.3,1.3,False '属于86号字体(水系注记) 'UnAdjustNote "698100",0.3,0.25,1.25,1.4,True 'UnAdjustNote "698100",0.3,0.25,1.25,1.4,False UnAdjustNote1 "698100",-0.2,0,1.27,1.25,True UnAdjustNote1 "698100",-0.2,0,1.27,1.25,False UnAdjustNote1 "698200",-0.1,0.1,1.27,1.26,True UnAdjustNote1 "698200",-0.1,0.1,1.27,1.26,False UnAdjustNote1 "698300",-0.1,0.1,1.27,1.26,True UnAdjustNote "698300",-0.1,0.1,1.27,1.26,False '属于43号字体(居民地注记) UnAdjustNote1 "298000",0,-0.1,1.2,1.3,True UnAdjustNote1 "298000",0,-0.1,1.2,1.3,False UnAdjustNote1 "298200",0,-0.1,1.23,1.3,True UnAdjustNote1 "298200",0,-0.1,1.23,1.3,False '属于43号字体(交通注记注记) UnAdjustNote1 "498000",0.3,0,1.35,1.5,True UnAdjustNote1 "498000",0.3,0,1.35,1.5,False UnAdjustNote1 "498100",0.5,0,1.35,1.5,True UnAdjustNote1 "498100",0.5,0,1.35,1.5,False '属于88号字体(交通注记) UnAdjustNote1 "498200",1.3,-0.15,1.33,1.35,True UnAdjustNote1 "498200",1.3,-0.15,1.33,1.35,False UnAdjustNote1 "498300",1.3,-0.15,1.33,1.35,True UnAdjustNote1 "498300",1.3,-0.15,1.33,1.35,False UnAdjustNote1 "498400",1,-0.15,1.33,1.35,True UnAdjustNote1 "498400",1,-0.15,1.33,1.35,False End Function Function AddNewPointFormLine(Code,NewCode,distx,disty) SSProcess.ClearSelection SSProcess.ClearSelectCondition SSProcess.SetSelectCondition "SSObj_Type", "=", "LINE" SSProcess.SetSelectCondition "SSObj_Code", "=", Code SSProcess.SelectFilter geocount = SSProcess.GetSelGeoCount For i = 0 To geocount - 1 sso= SSProcess.GetSelGeoPointCount(i) If sso = 5 or sso = 4 Then '取出处理对象 ppid = SSProcess.GetSelGeoValue( i, "SSObj_ID") ppcode = SSProcess.GetSelGeoValue( i, "SSObj_Code") '取出对象点坐标 x0 = CDbl(SSProcess.GetObjectAttr( ppid, "SSObj_X(0)")) y0 = CDbl(SSProcess.GetObjectAttr( ppid, "SSObj_Y(0)")) x1 = CDbl(SSProcess.GetObjectAttr( ppid, "SSObj_X(1)")) Y1 = CDbl(SSProcess.GetObjectAttr( ppid, "SSObj_Y(1)")) x3 = CDbl(SSProcess.GetObjectAttr( ppid, "SSObj_X(3)")) y3 = CDbl(SSProcess.GetObjectAttr( ppid, "SSObj_Y(3)")) '算出准备插入点符号的位置x,y If ppcode <> 515100 Then x = (x0 + x3)/2 y = (y0 + y3)/2 '距离 dist1 = sqr((x0-x3)*(x0-x3)+(y0-y3)*(y0-y3)) dist2 = sqr((x0-x1)*(x0-x1)+(y0-y1)*(y0-y1)) scalex = dist1/distx scaley = dist2/disty '角度 Dx = x1-x0 Dy = y1-y0 If Dx = 0 and Dy > 0 Then arc = 0 ElseIf Dx = 0 and Dy < 0 Then arc = 3.1415926 ElseIf Dx < 0 and Dy < 0 Then arc = 3.1415926-atn(Dx/Dy) ElseIf Dx < 0 and Dy = 0 Then arc = 3.1415926/2 ElseIf Dx > 0 and Dy = 0 Then arc = -3.1415926/2 ElseIf Dx > 0 and Dy < 0 Then arc = 3*3.1415926-atn(Dx/Dy) Else arc = 2*3.1415926-atn(Dx/Dy) End If Else x = (x1 + x3)/2 y = (y1 + y3)/2 '距离 dist1 = sqr((x0-x3)*(x0-x3)+(y0-y3)*(y0-y3)) dist2 = sqr((x0-x1)*(x0-x1)+(y0-y1)*(y0-y1)) scalex = dist1/distx scaley = dist2/disty '角度 Dx = x1-x0 Dy = y1-y0 If Dx = 0 and Dy > 0 Then arc = 0 ElseIf Dx = 0 and Dy < 0 Then arc = 3.1415926 ElseIf Dx < 0 and Dy < 0 Then arc = 3.1415926-atn(Dx/Dy) ElseIf Dx < 0 and Dy = 0 Then arc = 3.1415926/2 ElseIf Dx > 0 and Dy = 0 Then arc = -3.1415926/2 ElseIf Dx > 0 and Dy < 0 Then arc = 3*3.1415926-atn(Dx/Dy) Else arc = 2*3.1415926-atn(Dx/Dy) End If End If '按照x,y,scale插入点符号 SSProcess.CreateNewObj 0 SSProcess.SetNewObjValue "SSObj_Code", NewCode SSProcess.SetNewObjValue "SSObj_LineType", "0" SSProcess.SetNewObjValue "SSObj_LayerName", "DEFAULT" SSProcess.SetNewObjValue "SSObj_Color", "RGB(255,255,0)" SSProcess.SetNewObjValue "SSObj_Angle", arc SSProcess.SetNewObjValue "SSObj_ScaleX", scalex SSProcess.SetNewObjValue "SSObj_ScaleY", scaley SSProcess.AddNewObjPoint x, y, 0, 0, "" SSProcess.AddNewObjToSaveObjList End If Next End Function Function lineTopoint() AddNewPointFormLine "221100","2211001","1","0.75" AddNewPointFormLine "861100","8611001","1","0.5" AddNewPointFormLine "515100","5151001","0.5","0.5" End Function Function arcTodgn() SSProcess.ClearSelection SSProcess.ClearSelectCondition SSProcess.SetSelectCondition "SSObj_Type", "==", "LINE" SSProcess.SetSelectCondition "SSObj_LineType", "==", "4" SSProcess.SetSelectCondition "<Clockwise>", "==", "1" SSProcess.SelectFilter geoCount = SSProcess.GetSelGeoCount For i=0 To geoCount-1 geoID = CLng(SSProcess.GetSelGeoValue (i, "SSObj_ID")) SSProcess.ObjectDeal geoID, "GotoPoints", "", result Next End Function Function ExportDgn( fileName ) SSProcess.SetMapStatus 1,2 '输出DGN前的锁库处理 changeNoteDw changeNoteDw1 lineTopoint arcTodgn '工作台面目录下的DGN种子文件 dgnSeedFile = SSProcess.GetSysPathName (8) & "seed5h.dgn" '工作台面目录下的线型对照文件 dgnlinestylefile = SSProcess.GetSysPathName (8) & "dgnlinestyle.lin" '清空转换参数 SSProcess.ClearDataXParameter '设置输出文件格式为DGN SSProcess.SetDataXParameter "DataType", "9" 'DGN种子文件 SSProcess.SetDataXParameter "EXCHANGE_DGN_SeedFile", dgnSeedFile 'DGN线型对照文件 SSProcess.SetDataXParameter "EXCHANGE_DGN_LineStyleFile", dgnlinestylefile '设置输出文件名 SSProcess.SetDataXParameter "ExportPathName", fileName '设置使用编码表 SSProcess.SetDataXParameter "FeatureCodeTBName", "FeatureCodeTB_OutDgn" SSProcess.SetDataXParameter "SymbolScriptTBName", "SymbolScriptTB_OutDgn" SSProcess.SetDataXParameter "NoteTemplateTBName", "NoteTemplateTB_OutDgn" SSProcess.SetDataXParameter "ExplodeObjLayerStatus","0" SSProcess.SetDataXParameter "DataBoundMode", "2" SSProcess.SetDataXParameter "LayerRelationCount", "1" SSProcess.SetDataXParameter "LayerRelation1", "图廓层:60:60:60:60:60" '打散对象编组输出 SSProcess.SetDataXParameter "ExplodeObjMakeGroup", "1" '颜色使用编码表指定 SSProcess.SetDataXParameter "ColorUseStatus", "0" '图层使用编码表指定 SSProcess.SetDataXParameter "LayerUseStatus", "0" '面地物输出方式 0 Shape 1 LineString SSProcess.SetDataXParameter "EXCHANGE_DGN_ExportAreaMode", "1" '线串最多点数 SSProcess.SetDataXParameter "EXCHANGE_DGN_MaxLineStringPointCount", "101" '开始输出数据 SSProcess.ExportData SSProcess.SetMapStatus 0,2 SSProcess.MapMethod "Unloaddata","" SSProcess.MapMethod "loaddata", "" End Function Sub OnClick() pathName = SSProcess.SelectPathName( ) If pathName = "" Then Exit Sub End If SSProcess.CreateMapFrame frameCount = SSProcess.GetMapFrameCount() For i=0 To frameCount-1 SSProcess.GetMapFrameCenterPoint i, x, y SSProcess.SetCurMapFrame x, y, 0, "" frameID = SSProcess.GetCurMapFrame() mapNumber = SSProcess.GetObjectAttr( CLng(frameID), "[MapNumber]") If mapNumber <> "" Then fileName = pathName & mapNumber & ".DGN" ExportDgn fileName End If Next SSProcess.FreeMapFrame End Sub
评论
添加红包

请填写红包祝福语或标题

红包个数最小为10个

红包金额最低5元

当前余额3.43前往充值 >
需支付:10.00
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包
实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

1.余额是钱包充值的虚拟货币,按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载,可以购买VIP、付费专栏及课程。

余额充值