实现MapX的移屏测距功能

MapX & MapInfo 专栏收录该内容
1 篇文章 0 订阅

前一段时间想利用业余时间把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的其他功能了。

从现在开始记录每个功能的完成。

  • 0
    点赞
  • 2
    评论
  • 0
    收藏
  • 一键三连
    一键三连
  • 扫一扫,分享海报

©️2021 CSDN 皮肤主题: 大白 设计师:CSDN官方博客 返回首页
实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

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

余额充值