本文转载自hi.baidu.com/redpanda/blog/category/Mapx/index/1

实现MapX的移屏测距功能(转)

前一段时间想利用业余时间把MapX的一些功能写出来，特别是移屏测距的功能。
刚开始想的是仿MapInfo的测距功能，打算使用符号工具、折线工具和平移功能实现。
后来经过验证那样的测距方案行不通，主要表现为折线工具在画线的时候也是虚的，当地图屏移动的时候，画线也跟原测距工具的效果一样。后来想出另一个方案：在map_mousedown事件中画点，并记录该点到点集，之后在map_mousemove事件中把记录的点和鼠标所在点连成线，当再一次map_mousedown事件出现时，画点，记录该点到点集，这时把点集的两个点连成线图元添加到图层中，并移除第一个点。如此循环，到map_dblclick事件停止点集清空。

现在已经把移屏测距功能实现了，但是有一个速度问题，如果机子配置不太好的话，当移屏测距时的mousemove事件中画线速度跟不上。
------------------------------------------------------------------
Dim strRuleFlag As String '测距工具的使用标志:"start"测距开始;"over"测距过程;"stop"测试结束
Dim blnAutoPanFlag As Boolean '"自动滚屏"标志:True为自动滚屏;False为不自动滚屏
Dim ptPoint As New MapXLib.Point '测距时的当前点

字串9

Dim ptsLine As New MapXLib.Points '测距时的点集(用来生成直线)

Dim sngMoveX As Single '由mapMain_MouseMove传给mapMain_MapViewChange的地图屏幕坐标X
Dim sngMoveY As Single '由mapMain_MouseMove传给mapMain_MapViewChange的地图屏幕坐标Y

Dim dblDistanceTemp As Double '测距时从mapMain_MouseDown到mapMain_MouseMove的直线距离
Dim dblDistanceSum As Double '测距时从第一次mapMain_ToolUse到mapMain_DblChick的折线距离

Const RuleTool As Integer = 101 '测距工具编号
------------------------------------------------------------------
'*说明 : 主地图的双击事件
'*实现功能 : 测距结束
Private Sub mapMain_DblClick()
Call RuleEnd
End Sub
------------------------------------------------------------------
'*说明 : 主地图的键盘按键按下事件
'*实现功能 : 如果按键"Escape"按下则测距结束
Private Sub mapMain_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeyEscape Then 字串3 
Call RuleEnd
End If
End Sub
------------------------------------------------------------------
'*说明 : 主地图的视图改变事件
'*实现功能 : 使主地图的"自动滚屏"更流畅
Private Sub mapMain_MapViewChanged()
Dim dblMapX As Double '由屏幕坐标X转为地图坐标X
Dim dblMapY As Double '由屏幕坐标Y转为地图坐标Y

Me.mapMain.ConvertCoord sngMoveX, sngMoveY, dblMapX, dblMapY, miScreenToMap
Me.staMain.Panels(2).Text = "经度: " & dblMapX & " 纬度: " & dblMapY

'如果"自动滚屏"标志为True,调用自动滚屏过程
If blnAutoPanFlag = True Then
Call AutoMapPan(sngMoveX, sngMoveY)

'如果主地图工具为测距工具,并且测距标志为"over",转换地图坐标,调用"测距过程"
If Me.mapMain.CurrentTool = RuleTool And strRuleFlag = "over" Then
Call RuleMove(dblMapX, dblMapY)
End If

字串1

End If
End Sub
------------------------------------------------------------------
'*说明 : 主地图的鼠标按下事件
'*实现功能 : 如果按下的是鼠标右键,并且主地图工具不是测距工具,则弹出"视图"菜单,否则调用主地图双击事件(即结束测距)
'* 如果按下的是鼠标左键,并且主地图工具是测距工具,则在主地图的"rule"图层创建一个点图元
Private Sub mapMain_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim ftrPoint As MapXLib.Feature '点图元
Dim stylePoint As New MapXLib.Style '点图元样式
Dim ptsTemp As New Points '临时点集
Dim lyrTemp As MapXLib.Layer '临时图层

Dim dblMapX As Double '由屏幕坐标X转为地图坐标X
Dim dblMapY As Double '由屏幕坐标Y转为地图坐标Y

Select Case Button
'鼠标右键
Case vbRightButton
'如果主地图工具不是测距工具,则弹出"视图"菜单,否则调用"测距结束过程"

字串9

If Me.mapMain.CurrentTool <> RuleTool And Me.mapMain.Layers.Count > 0 Then
PopupMenu mnuView
Else
Call RuleEnd
End If

'鼠标左键
Case vbLeftButton
'如果主地图工具是测距工具,则在主地图的"rule"图层创建一个点图元
If Me.mapMain.CurrentTool = RuleTool Then
'测距标志为"over"
strRuleFlag = "over"
'设置临时图层为"rule"图层
Set lyrTemp = Me.mapMain.Layers("rule")
'屏幕坐标转换地图坐标
Me.mapMain.ConvertCoord X, Y, dblMapX, dblMapY, miScreenToMap
'设置点
ptPoint.Set dblMapX, dblMapY
'设置点图元样式
With stylePoint
.SymbolType = miSymbolTypeTrueTypeFont
.SymbolCharacter = 39

字串8

.SymbolFont.Size = 4
End With
'临时点集增加点
ptsTemp.Add ptPoint
'创建点图元
Set ftrPoint = Me.mapMain.FeatureFactory.CreateMultipoint(ptsTemp, stylePoint)
'临时图层加载点图元
lyrTemp.AddFeature ftrPoint
Else
'"自动滚屏"标志为False
blnAutoPanFlag = False
End If
End Select

End Sub
------------------------------------------------------------------
'*说明 : 主地图的鼠标移动事件
'*实现功能 : 激活"自动滚屏"过程;调用测距过程实现测距功能
Private Sub mapMain_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim dblMapX As Double '由屏幕坐标X转为地图坐标X
Dim dblMapY As Double '由屏幕坐标Y转为地图坐标Y

'传给mapMain_MapViewChange的地图屏幕坐标X和Y 字串8 
sngMoveX = X
sngMoveY = Y

Me.mapMain.ConvertCoord X, Y, dblMapX, dblMapY, miScreenToMap
Me.staMain.Panels(2).Text = "经度: " & dblMapX & " 纬度: " & dblMapY

'如果"自动滚屏"标志为True,调用"自动滚屏"过程
If blnAutoPanFlag = True Then
Call AutoMapPan(X, Y)
End If

'如果主地图工具是测距工具,并且测距标志为"over",调用"测距过程"
If strRuleFlag = "over" Then
Call RuleMove(dblMapX, dblMapY)
End If
End Sub
------------------------------------------------------------------
'*说明 : 主地图的鼠标弹起事件
'*实现功能 : 如果"自动滚屏"菜单为True,并且"自动滚屏"标志为False时设置"自动滚屏"标志为True
Private Sub mapMain_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
'如果"自动滚屏"菜单为True,并且"自动滚屏"标志为False时设置"自动滚屏"标志为True 字串8 
If mnuAutoPan.Checked = True And blnAutoPanFlag = False Then
blnAutoPanFlag = True
End If
End Sub
------------------------------------------------------------------
'*说明 : 主地图的自定义工具使用事件
'*实现功能 : 如果主地图工具是测距工具,并且点集的个数大于等于2时,则根据点集画出线图元
Private Sub mapMain_ToolUsed(ByVal ToolNum As Integer, ByVal X1 As Double, ByVal Y1 As Double, ByVal X2 As Double, ByVal Y2 As Double, ByVal Distance As Double, ByVal Shift As Boolean, ByVal Ctrl As Boolean, EnableDefault As Boolean)
Dim ftrLine As MapXLib.Feature '线图元
Dim lyrTemp As MapXLib.Layer '临时图层

If Me.mapMain.CurrentTool = RuleTool Then
Set lyrTemp = Me.mapMain.Layers("rule")

'如果测距标志为"stop",则改为"start",这是测距开始
If strRuleFlag = "stop" Then
strRuleFlag = "start"
End If

字串4

'设置点
ptPoint.Set X1, Y1
'点集增加点
ptsLine.Add ptPoint
'如果点集个数大于等于2,则根据点集画出线图元
If ptsLine.Count >= 2 Then
'创建线图元
Set ftrLine = Me.mapMain.FeatureFactory.CreateLine(ptsLine, Me.mapMain.DefaultStyle)
'临时图层加载线图元
lyrTemp.AddFeature ftrLine
'点集移走第一个点
ptsLine.Remove 1
'得到测距总距离
dblDistanceSum = dblDistanceSum + ftrLine.Length
End If
End If
End Sub
------------------------------------------------------------------
'*说明 : "自动滚屏"菜单点击事件
'*实现功能 : 打开和关闭"自动滚屏"功能
Private Sub mnuAutoPan_Click()
'如果"自动滚屏"菜单为True,则改为False,"自动滚屏"标志也设置False;否则改为True,"自动滚屏"标志也设置True
If mnuAutoPan.Checked = True Then
mnuAutoPan.Checked = False 字串4 
blnAutoPanFlag = False
Else
mnuAutoPan.Checked = True
blnAutoPanFlag = True
End If
End Sub
------------------------------------------------------------------
'*说明 : "自动滚屏"过程
'*实现功能 : 当鼠标在主地图的如下某一位置时自动滚屏
Private Function AutoMapPan(sngScreenX As Single, sngScreenY As Single)
'地图左边
If sngScreenX < 30 And sngScreenY > 30 And sngScreenY < Me.mapMain.MapScreenHeight - 30 Then
Me.mapMain.Pan -10, 0
'地图右边
ElseIf sngScreenX > Me.mapMain.MapScreenWidth - 30 And sngScreenY > 30 And sngScreenY < Me.mapMain.MapScreenHeight - 30 Then
Me.mapMain.Pan 10, 0
'地图上边
ElseIf sngScreenX > 30 And sngScreenX < Me.mapMain.MapScreenWidth - 30 And sngScreenY < 30 Then
Me.mapMain.Pan 0, 5
'地图下边
ElseIf sngScreenX > 30 And sngScreenX < Me.mapMain.MapScreenWidth - 30 And sngScreenY > Me.mapMain.MapScreenHeight - 30 Then

字串5

Me.mapMain.Pan 0, -5
'地图左上角
ElseIf sngScreenX < 30 And sngScreenY < 30 Then
Me.mapMain.Pan -10, 5
'地图左下角
ElseIf sngScreenX < 30 And sngScreenY > Me.mapMain.MapScreenHeight - 30 Then
Me.mapMain.Pan -10, -5
'地图右上角
ElseIf sngScreenX > Me.mapMain.MapScreenWidth - 30 And sngScreenY < 30 Then
Me.mapMain.Pan 10, 5
'地图右下角
ElseIf sngScreenX > Me.mapMain.MapScreenWidth - 30 And sngScreenY > Me.mapMain.MapScreenHeight - 30 Then
Me.mapMain.Pan 10, -5
End If
End Function
------------------------------------------------------------------
'*说明 : 测距移动过程
'*实现功能 : 创建mapMain_MouseDown到mapMain_MouseMove两点间的线图元,并得到其距离
Private Function RuleMove(dblMapX As Double, dblMapY As Double)
Dim lyrTemp As MapXLib.Layer '临时图层
Dim ftrTemp As MapXLib.Feature '临时图元
Dim ftrLine As MapXLib.Feature '线图元 字串3

'设置临时图层为"rule"图层
Set lyrTemp = Me.mapMain.Layers("rule")
'删除临时图层名为"temp"的线图元
For Each ftrTemp In lyrTemp.AllFeatures
If ftrTemp.Type = miFeatureTypeLine And ftrTemp.Name = "temp" Then
lyrTemp.DeleteFeature ftrTemp
End If
Next ftrTemp

'设置点位置
ptPoint.Set dblMapX, dblMapY
'点集增加点
ptsLine.Add ptPoint

'如果点集个数大于等于2时,根据点集创建线图元
If ptsLine.Count >= 2 Then
'创建线图元
Set ftrLine = Me.mapMain.FeatureFactory.CreateLine(ptsLine, Me.mapMain.DefaultStyle)
'设置线图元名称为"temp"
ftrLine.KeyValue = "temp"
'临时图层加载线图元
lyrTemp.AddFeature ftrLine
'点集移除第二个点
ptsLine.Remove 2
End If

'得到线图元的长度
dblDistanceTemp = ftrLine.Length 字串3 
frmDistance.lblDistance.Caption = dblDistanceTemp & " 千米"
frmDistance.lblDistanceSum.Caption = (dblDistanceSum + dblDistanceTemp) & " 千米"
End Function
------------------------------------------------------------------

'*说明 : 测距结束过程
'*实现功能 : 设置测距标志,清空点集,移除"rule"图层测距时生成的图元,测距总距离置0
Private Sub RuleEnd()
Dim ftrTemp As MapXLib.Feature '临时图元
Dim lyrTemp As MapXLib.Layer '临时图层

'测距结束,如果主地图工具是测距工具,测距标志为"start",否则为"stop"
If Me.mapMain.CurrentTool = RuleTool Then
strRuleFlag = "start"

'测距结束,清空点集
Set ptsLine = Nothing

'测距结束,清除测距时所生成的图元
Set lyrTemp = Me.mapMain.Layers("rule")
For Each ftrTemp In lyrTemp.AllFeatures
lyrTemp.DeleteFeature ftrTemp 字串5 
Next ftrTemp

'测距结束,测距总距离设为0
dblDistanceSum = 0
Else
strRuleFlag = "stop"
End If
End Sub