AutoCAD二次开发基础（三）：船体型线绘制

AutoCAD二次开发系列

---

前言

用程序生成船体型线图，无疑会提高开发效率。

---

一、绘制船体横剖线

• 任务：编制程序，根据水线图，绘制船体横剖线图，其中站号为0至20站，间隔均为1站。
• 主要思想：在各站处建立竖直辅助线，与水线图求交点，交点y坐标即为横剖线图x坐标，交点所处水线对应的吃水即为横剖线图y坐标。
• 前提：有水线图

Sub DrawBodyline()
Dim c1 as AcadLine
Dim ss1 as AcadSelectionSet  ' 定义选择集
Lpp = 176  ' 船长
On Error GoTo endSub
Set ss1 = ThisDrawing.SelectionSets.Add("s2")  ' 将选择集添加至图形数据库
ss1.SelectOnScreen  ' 执行选择操作
For I = 0 To 20
	X = I / 20# * Lpp  ' #表示双精度浮点类型
	Dim p0(2) as double : Dim p1(2) as double
	p0(0) = X
	p1(0) = X : p1(1) = Lpp
	Set c1 = ThisDrawing.ModelSpace.AddLine(p0, p1)
	ReDim ptAll(10000) as double
	NN = 0
	For each c2 in ss1
		pta = c1.IntersectWith(c2, acExtendNone)  ' 每条水线与各站处竖直线求交点
		cc = (Ubound(pta) + 1) / 3
		if cc = 1 Then
			ptAll(NN * 3) = pta(0) : ptAll(NN * 3 + 1) = pta(1) : ptAll(NN * 3 + 2) = c2.Linetypescale  ' 画图纸时借用水线的Linetypescale属性存放了水线对应吃水信息
			NN = NN + 1
		End if
	Next c2
	ReDim Preserve ptAll(NN * 3 - 1) as double
	Dim tt(2) as double
	Set sp = ThisDrawing.ModelSpace.AddSpline(ptAll, tt, tt)  ' 绘制第I站处横剖线
	c1.delete  ' 删除辅助线
Next I
endSub:
ss1.delete  ' 删除选择集
If Err.Number Then MsgBox Err.Description
End Sub	

二、绘制船体纵剖线

• 任务：编制程序，根据水线图，绘制船体横剖线图。
• 主要思想：和上述基本一致
• 前提：有水线图

Sub drawSheerlineWithoutParam()
Dim c1 as AcadLine
Dim ss1 as AcadSelectionSet
Lpp = 176  ' 船长
On Error GoTo endSub
Set ss1 = ThisDrawing.SelectionSets.Add("s2")  ' 将选择集添加至图形数据库
ss1.SelectOnScreen  ' 执行选择操作
For AOrF = 0 To 1  ' 根据参数AOrF的不同，分别画尾部和首部的横剖线
	For y = 1 To 16 Step 1
		Dim p0(2) as double : Dim p1(2) as double
		p0(0) = Lpp + 50 : p0(1) = y
		p1(0) = Lpp / 2 : p1(1) = y
		If AOrF = 0 Then p0(0) = -Lpp  ' 参数AorF为0，则画尾部横剖线；为1，则画首部横剖线
		Set c1 = ThisDrawing.ModelSpace.AddLine(p0, p1)
		ReDim ptAll(10000) as double
		NN = 0
		For each c2 in ss1
			pta = c1.IntersectWith(c2, acExtendNone)
			cc = (UBound(pta) + 1) / 3
			if cc = 1 Then
				ptAll(NN * 3) = pta(0) : ptAll(NN * 3 + 1) = pta(1) : ptAll(NN * 3 + 2) = c2.Linetypescale
				NN = NN + 1
			End If
		Next c2
		ReDim Preserve ptAll(NN * 3 - 1) as double
		Dim tt(2) as double
		Set sp = ThisDrawing.ModelSpace.AddSpline(ptAll, tt, tt)  ' 绘制第I站处横剖线
		c1.delete  ' 删除辅助线
	Next y
Next AOrF
endSub:
ss1.delete  ' 删除选择集
If Err.Number Then MsgBox Err.Description
End Sub	

三、绘制船体肋骨型线图

• 任务：假定肋骨间距为等间距0.5 m(实际中大型船舶肋骨通常是不等间距的)，根据水线图，绘制船体肋骨型线图。
• 主要思想：和绘制横剖线一致，只不过肋骨型线图更密集
• 前提：有水线图

Sub drawFrame()
Dim c1 as AcadLine
Dim ss1 as AcadSelectionSet
Lpp = 176  ' 船长
On Error GoTo endSub
Set ss1 = ThisDrawing.SelectionSets.Add("s2")  ' 将选择集添加至图形数据库
ss1.SelectOnScreen  ' 执行选择操作
For X = -3# To 178 Step 0.5
	Dim p0(2) as double : Dim p1(2) as double
	p0(0) = X
	p1(0) = X : p1(1) = Lpp
	Set c1 = ThisDrawing.ModelSpace.AddLine(p0, p1)
	ReDim ptAll(10000) as double
	NN = 0
	For each c2 in ss1
		pta = c1.IntersectWith(c2, acExtendNone)
		cc = (UBound(pta) + 1) / 3
		if cc = 1 Then
			ptAll(NN * 3) = pta(0) : ptAll(NN * 3 + 1) = pta(1) : ptAll(NN * 3 + 2) = c2.Linetypescale
			NN = NN + 1
		End If
	Next c2
	ReDim Preserve ptAll(NN * 3 - 1) as double
	Dim tt(2) as double
	Set sp = ThisDrawing.ModelSpace.AddSpline(ptAll, tt, tt)  ' 绘制第I站处横剖线
	c1.delete  ' 删除辅助线
Next X
endSub:
ss1.delete  ' 删除选择集
If Err.Number Then MsgBox Err.Description
End Sub	

---