实现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 '测距时的当前点
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
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
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
'如果主地图工具不是测距工具,则弹出"视图"菜单,否则调用"测距结束过程"
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
.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
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
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
'设置点
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
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
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 '线图元
'设置临时图层为"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
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
Next ftrTemp
'测距结束,测距总距离设为0
dblDistanceSum = 0
Else
strRuleFlag = "stop"
End If
End Sub
大概的移屏测距过程就是这样的了。接着要完成MapX的其他功能了。
从现在开始记录每个功能的完成。
实现MapX的移屏测距功能相关推荐
- 实现MapX的移屏测距功能(转)
本文转载自hi.baidu.com/redpanda/blog/category/Mapx/index/1 实现MapX的移屏测距功能(转) 前一段时间想利用业余时间把MapX的一些功能写出来,特别是 ...
- ThreeJS 测距功能
文章目录 选点绘线 绘制标签 1.使用 TextGeometry 创建标签文字 2. 使用 CSS2DObject 创建标签 动态绘制点.线和标签 绘制辅助线 撤销操作 测距功能,也就是选择两点, ...
- 百度地图 测距功能 DistanceTool 在不同浏览器下标注不一致的解决办法，打开新地图测距不生效的解决办法
1. 在项目中用到百度地图的测距功能,在主页面的地图中用没问题,如果从主页的地图跳转到详情页的地图,在返回到主页,打开地图的测距功能,测距一直不显示.下面是解决办法 将测距功能的工具类函数下载到本地, ...
- ipad分屏功能怎么开启_mac分屏怎么开启？Mac上的分屏小功能
很多小伙伴在使用Mac电脑办公或学习的过程中忙起来可能觉得要好几个屏幕才够用,其实Mac是自带的分屏功能的,本次我为您带来了mac分屏开启教程,想知道怎么操作的朋友快来看看吧! 分屏功能 借助分屏浏览 ...
- mac多开屏幕_mac分屏怎么开启？Mac上的分屏小功能
很多小伙伴在使用Mac电脑办公或学习的过程中忙起来可能觉得要好几个屏幕才够用,其实Mac是自带的分屏功能的,本次我为您带来了mac分屏开启教程,想知道怎么操作的朋友快来看看吧! 分屏功能 借助分屏浏览 ...
- 为所有弹窗增加全屏切换功能
1.现状 在开发两个管理系统,现在的页面20+,其中包含不少的弹窗.在项目开发过程中没人提过弹窗要全屏的事情,且在数据量较大的位置已经增加了可全屏的入口.但老板两次说为什么不给所有的弹窗增加全屏的功能 ...
- OpenMV实现多色块监测功能、测距功能---robomaster飞镖制导一种思路
OpenMV简介 简单的来说,它是一个可编程的摄像头,通过MicroPython语言,可以实现你的逻辑.而且摄像头本身内置了一些图像处理算法,很容易使用.OpenMV只有30万的像素,通常使用320_ ...
- 【UE4】基于Spline的测距功能
基于Spline的测距功能插件 一.功能分析 这里首先分析一下整个插件的功能部件 SplineActor-基于Spline的线条显示模块 Ranging-对整个插件功能的整体控制 DistancePa ...
- 【MAPBOX基础功能】32、实现mapbox的测距功能
前言 官网指引,生成accesstoken,下载相关依赖请翻阅[https://blog.csdn.net/weixin_44402694/article/details/125414381?spm= ...
最新文章
- Unity制作2D动作平台游戏视频教程
- Opportunity retrieval in SalesPipeline
- LeetCode 80. 删除排序数组中的重复项 II
- Linux系统安装及配置——Centos-7-X86_64-DVD-2009
- power bi可视化表_滚动器可视化功能，用于Power BI Desktop中的股价变动
- 小程序入门学习14--用户管理
- 蓝桥杯 ADV-69 算法提高 质因数
- 没有ajax以前的隐藏 iframe 技术
- Java基础编程题（一）——用冒泡排序法从大到小排序输入的4个数
- javaweb连接mysql教程_javaweb链接数据库教程
- VS2015 LNK2001:无法解析的外部符号 debug调试
- 中控指纹仪 后台比对小结
- android导航功能介绍,百度导航功能介绍
- MStar点屏（LVDS接口屏）
- org.springframework.dao.InvalidDataAccessApiUsageException: ERR wrong number of arguments for ‘srem‘
- 2022年高端投影仪--当贝投影F5
- win10远程桌面连接都有哪些工具
- AD18如何修改原理图页面图纸的大小
- 常用数据集/工具下载地址
- java狗具有特别的接飞盘的方法_java第七章 多态 课堂笔记/作业