mapbasic程序有详细的解释.doc

河道比降计算程序mapinfo
===================================================================
' 项目：河道比降计算
' 作者：崔军明
' 版本：2.2
' 日期：2009-12-23
'
' 使用说明：
'   1、新建图层，绘制主河道（也可以复制水系，然后整理出主河道）。
'   2、确定高程的单位（米/分米）。如果与主河道相交的等高线的高程单位不统一，则将其修改一致。
'   3、运行此程序，打开需要的表，设置计算选项，计算河道比降。
'   4、如果遇到错误，根据提示将河道上的节点吸附在等高线上， 并保存河道表(Stream)。
'     关闭全部表（不必保存），重新运行程序。
'   5、程序运行结束后，保存计算结果，然后浏览比降计算表(Gradient)。
'     (1) 复查高程列(Elev)的单位是否统一，确认设置计算选项时所作的选择是正确的。
'   6、注意，计算某个流域的河道比降时，只需打开对应部分的等高线图层。 如果等高线图层太大，会大大影响计算速度。
'===================================================================
'-----------------------
'MapBasic的调试方法：
' (1) 在出错或需要的地方，使用Note（或Print）语句将变量的值显示出来。
' (2) 在MapInfo中，打开MapBasic窗口，回车就会执行当前语句。
'
'MapBasic中SQL的特性：
' (1) Delete 语句，执行的是无条件删除，即删除表中的全部记录。它不像SQL Server的SQL语句，可以加Where限制从句。
'     它的Where Rowid = ? 子句用处不大！
' (2) Update 语句，执行的也是无条件更新，默认情况下，它会更新全部记录。但是，Update语句可以通过视图更新，这就
'     等价于使用了Where子句。如：Select * From Table Where column = ? , Update Selection Set Column = Value，
'     参考MapBasic帮助。
'---------------------------------------------------------------------------------
Include "MAPBASIC.DEF"
Declare Sub Main
Declare Sub OpenTable
Declare Sub Init
Declare Sub SetupCalcOption
Declare Sub WriteElev2Gradient
Declare Sub AddCrossingOnStream
Declare Sub GetReachLen
Declare Sub WriteLen2Gradient
Declare Function IsDownStream As Logical
Declare Function LocateCrossing(L As Object, Li As Object, ByVal C As Integer) As Integer
Declare Function CalcGradient As Float
Declare Sub SaveGradient(ByVal J As Float)
Global EV As Integer    '等高线的高程，用来查询当前正在处理的等高线，便于找到没有吸附的等高线
Global ELEV_UNITS As Integer '高程单位选项值
'----------------------------------------
'计算河道比降
'-------------------------------------
Sub Main
Dim J As Float    '河道比降
Call OpenTable    '打开相关表
Call Init      '初始化
Call SetupCalcOption   '设置计算选项
Call WriteElev2Gradient '查询和河道相交的等高线并将其写入比降计算表
Call AddCrossingOnStream '在河道上添加交点节点
Call GetReachLen    '获取河段长度，并将其存入河段长度临时表
Call WriteLen2Gradient   '将河段长度导入比降计算表中
J = CalcGradient()    '计算河道比降
Call SaveGradient(J)   '保存计算结果
End Sub
'----------------------------------------
'打开河道、等高线和比降计算表
'----------------------------------------
Sub OpenTable
Dim StreamFileName As String
Dim ContourFileName As String
Dim GradientFileName As String
'弹出对话框，打开相关表
StreamFileName FileOpenDlg("", "", "TAB", "打开主河道")
ContourFileName = FileOpenDlg("", "", "TAB", "打开等高线")
GradientFileName = FileOpenDlg("", "", "TAB", "打开比降计算表")
Open Table StreamFileName As Stream
Open Table ContourFileName As Contour
Open Table GradientFileName As Gradient
End Sub
'---------------------
'初始化
'----------------------------------------
Sub Init
'Dim MapWinId As Integer   '地图窗口ID
'Dim MapCoordSys As String   '地图坐标系（投影）
'设置坐标系（投影）
'Map From Stream
'MapWinId = FrontWindow()
'MapCoordSys = MapperInfo(MapWinId, MAPPER_INFO_COORDSYS_CLAUSE)
'Set CoordSys Earth

' Projection MapCoordSys
'Close Window MapWinId
'设置长度单位为米
Set Distance Units "m"
'创建河段长度临时表
Create Table ReachLen (Length Float)
Open Table ReachLen
End Sub
'-----------------------------------------------
'设置计算选项
'-----------------------------------------------
Sub SetupCalcOption
'定义了河道起点和高程单位两个选项
Dialog
   Title "计算选项"
   Control StaticText
    Title "高程单位："
   Control RadioGroup
    Title "米;分米"
    Into ELEV_UNITS
   Control OKButton
    Title "确定"
   Control CancelButton
    Title "取消"
'如果取消设置或关闭了设置窗口，则退出程序
If Not CommandInfo(CMD_INFO_DLG_OK) Then
   Drop Table ReachLen
   Close Table Stream
   Close Table Contour
   Close Table Gradient
   End Program
End If
End Sub
'--------------------------------------------------
'查询和河道相交的等高线并将其插入比降计算表中
'--------------------------------------------------
Sub WriteElev2Gradient
Dim E As Integer   '高程
Dim oLine As Object '等高线对象
'清空河段表中的记录
Delete From Gradient
'查询和主河道相交的等高线
Select contour.Elev, contour.Obj From contour, Stream
   Where contour.Obj Intersects Stream.Obj
   Order By contour.Elev DESC
   Into Intersection
'将高程值和等高线对象都写入比降计算表中
Fetch First From Intersection
Do While Not EOT(Intersection)
   E = Intersection.Elev
   oLine = Intersection.Obj
   Insert Into Gradient (Elev, Obj) Values (E, oLine)
   Fetch Next From Intersection
Loop
'保存比降计算表
Commit Table Gradient
End Sub
'-------------------------------------------------
'在河道上添加和等高线的交点节点
' OverlayNodes() 函数返回添加了交点的折线对象（但是该函数有误差，有时添加的节点不能完全吸附）
'-------------------------------------------------
Sub AddCrossingOnStream
Dim S As Object '河道折线对象
Dim C As Object '与河道相交的等高线对象
Dim E As Integer '高程值，作为更新等高线的条件
'在河道和等高线上添加相交节点
Fetch First From Gradient
Do While Not EOT(Gradient)
   '在河道上添加相交节点
   S = OverlayNodesStream.Obj, Gradient.Obj) '
   Update Stream Set Obj = S
   '在等高线上也添加一个相交节点
   C = OverlayNodes(Gradient.Obj, Stream.Obj)
   E = Gradient.Elev
   Select * From Gradient Where Elev = E
   Update Selection Set Obj = C
   Fetch Next From Gradient
Loop
End Sub
'-------------------------------
'获取河段长度，并将其存入河段长度临时表中
'关于ExtractNodes()函数的说明：begin_node 要小于 end_node
'--------------------------------------------------
Sub GetReachLen
Dim S As Object   '河道
Dim N As Integer   '河道上的节点数
Dim I, C As Integer '循环控制变量
Dim Line1 As Object '等高线1
Dim Line2 As Object '等高线2
Dim B, E As Integer '河段的首尾节点序号
Dim R As Object   '河段对象
Dim L As Float   '河段长度
'清空河段长度表
Delete From ReachLen
'获取河道对象及其节点数
Fetch First From Stream
S = Stream.Obj
N = ObjectInfo(S, OBJ_INFO_NPNTS)
'统计等高线条数，控制循环
Select Count(*) From Gradient
C = Selection.Col1
'河道起点位置不同，计算河段长度时的起止顺序就不同
Dim IsDown As Logical        '是否顺流而下
IsDown = IsDownStream()
If IsDown Then         '如果河道起点从源头开始
   '计算河段长度并将其插入河段长度表
   Fetch First From Gradient
   EV = Gradient.Elev        '用来寻找没有吸附的等高线
   Line1 = Gradient.Obj       '第一条等高线对象
   E = LocateCrossing(S, Line1, N)     '河道与第一条等高线的交点位置
   For I = 1 To C - 1
    B = E         '首节点序号  
    Fetch Next From Gradient
    EV = Gradient.Elev       '用来寻找没有吸附的等高线
    Line2 = Gradient.Obj      '下一条等高线
    E = LocateCrossing(S, Line2, N)    '尾节点序号，河道与下一条等高线的交点位置
    R = ExtractNodes(S, 1, B, E, FALSE)   '抽取河段，按 B -> E
    L = ObjectLen(R, "m")       '获取河段长度  
    Insert Into ReachLen (Length) Values (L) '将河段长保存在河段长度临时表中
   Next
Else            '如果河道起点从断面处开始
   '计算河段长度并将其插入河段长度表
   Fetch First From Gradient
   EV = Gradient.Elev        '用来寻找没有吸附的等高线
   Line1 = Gradient.Obj       '第一条等高线对象
   E = LocateCrossing(S, Line1, N)     '河道与第一条等高线的交点位置
   For I = 1 To C - 1
    B = E         '首节点序号  
    Fetch Next From Gradient
    EV = Gradient.Elev       '用来寻找没有吸附的等高线
    Line2 = Gradient.Obj      '下一条等高线
    E = LocateCrossing(S, Line2, N)    '尾节点序号，河道与下一条等高线的交点位置
    R = ExtractNodes(S, 1, E, B, FALSE)   '抽取河段，按 E -> B
    L = ObjectLen(R, "m")       '获取河段长度  
    Insert Into ReachLen (Length) Values (L) '将河段长保存在河段长度临时表中
   Next  
End If
End Sub
'--------------------------------------------------
'判断河道的起点是否在源头
'--------------------------------------------------
Function IsDownStream As Logical
Dim S As Object   '河道
Dim N As Integer   '河道上的节点数
Dim Line1 As Object '等高线1
Dim Line2 As Object '等高线2
Dim B, E As Integer '河段的首尾节点序号
'获取河道对象及其节点数
Fetch First From Stream
S = Stream.Obj
N = ObjectInfo(S, OBJ_INFO_NPNTS)
'获取河道与第一条等高线的交点的序号
Fetch First From Gradient
EV = Gradient.Elev       '用来寻找没有吸附的等高线
Line1 = Gradient.Obj      '第一条等高线对象
B = LocateCrossing(S, Line1, N)    '河道与第一条等高线的交点位置
'获取河道与第二条等高线的交点的序号
Fetch Next From Gradient
EV = Gradient.Elev       '用来寻找没有吸附的等高线
Line2 = Gradient.Obj      '下一条等高线
E = LocateCrossing(S, Line2, N)    '尾节点序号，河道与下一条等高线的交点位置
IsDownStream = B < E
End Function
'--------------------------------------------------
'功能：寻找交点的位置（节点序号）
'参数： L 河道对象
'   Li 等高线对象
'   C 河道的节点数
'关于IntersectNodes()函数的说明：
' 对于第三个参数points_to_include，INCL_COMMON 表示相交于节点；INCL_CROSSINGS 表示相交于线段；INCL_ALL 表示两种情况
'--------------------------------------------------
Function LocateCrossing(L As Object, Li As Object, ByVal C As Integer) As Integer
Dim P As Object     '两条线的交点
Dim Px, Py As Float    '交点坐标
Dim I As Integer
Dim Lx, Ly As Float    '河道线上的节点坐标
OnError Goto OnExceptionDo   '如果河道与等高线没有吸附，则抛出异常
'获取两条折线的交点
p = IntersectNodes(L, Li, INCL_COMMON)
'得到交点的坐标
Px = ObjectNodeX(P, 1, 1)
Py = ObjectNodeY(P, 1, 1)
'寻找交点的位置（在河道的第几个节点上，折线节点的编号按创建顺序递增）
For I = 1 To C
   Lx = ObjectNodeX(L, 1, I)
   Ly = ObjectNodeY(L, 1, I)
   If (Lx = Px) Then
    If (Ly = Py) Then Exit For End If
   End If
Next  
LocateCrossing = I
EndException:        '异常处理
Exit Function

OnExceptionDo:
Drop Table ReachLen     '销毁河段长度临时表
Map From Contour      '打开等高线图层
Add Map Layer Stream     '添加河道图层
set map redraw off
Set Map Layer "Stream" Editable On '使河道图层可编辑
set map redraw on
Select * From Contour Where Elev = EV
Note "请把河道吸附在图中所示等高线上，并保存Stream表。"
Resume EndException '0    '0，指的是尝试重新执行刚才出错的语句。因找不到中断的办法，只好放弃。
End Function
'----------------------------------------
'将河段长度再导入比降计算表中
'----------------------------------------
Sub WriteLen2Gradient
Dim E As Integer
Dim L As Float
'将河段长度一一写入比降计算表中
Fetch First From Gradient    '游标指向比降计算表的第一条记录
Fetch First From ReachLen    '游标指向河段长度表的第一条记录
Do While Not EOT(ReachLen)
   E = Gradient.Elev
   L = ReachLen.Length
   Select * From Gradient Where Elev = E
   Update Selection Set Len = L
   Fetch Next From Gradient
   Fetch Next From ReachLen
Loop
'销毁河段长度临时表
Drop Table ReachLen
'保存比降计算表
Commit Table Gradient
End Sub
'----------------------------------------
'功能：计算河道比降
'算法：统计河道总长，计算河道比降
'----------------------------------------
Function CalcGradient As Float
Dim L As Float '河道总长
Dim C As Integer '总记录数
Dim I As Integer
Dim H1 As Integer '河段上断面河底高程
Dim H2 As Integer '河段下断面河底高程
Dim L1 As Float '河段长度
Dim J As Float '河道比降
'统计河道总长和河段断面的数量（河段数量加1）
Select Sum(Len), Count(*) From Gradient
L = Selection.Col1
C = Selection.Col2
'计算河道比降
J = 0
Fetch First From Gradient
For I = 1 to C - 1
   L1 = Gradient.Len
   H1 = Gradient.Elev
   Fetch Next From Gradient
   H2 = Gradient.Elev
   J = J + (H1 + H2)*L1  
Next
J = (J - 2 * H2 * L)/L^2
'如果高程单位为分米，则J/10
If ELEV_UNITS = 2 Then
   J = J / 10
End If
CalcGradient = J
End Function
'-----------------------------------------
'保存河道比降
'-----------------------------------------
Sub SaveGradient(ByVal J As Float)
Note "河道比降为：" + Str$(J)
'浏览比降计算表
Browse * From Gradient
'将结果存入河道比降表中
Dim FN As String
FN = FileSaveAsDlg("","","TAB","保存计算结果")
Create Table 河道比降
   (河道比降 Float)
   File FN
'将河道比降值保存在表中
Insert Into 河道比降 (河道比降) Values (J)
'保存河道比降表
Commit Table 河道比降
'浏览河道比降值
Browse * From 河道比降
End Sub

THANKS !!!

致力为企业和个人提供合同协议，策划案计划书，学习课件等等
打造全网一站式需求

欢迎您的下载，资料仅供参考

-可编辑修改-