MapX历史轨迹回放[开发源代码]：

Option Explicit

Dim xDown As Double
Dim yDown As Double
Dim HisBeginFlag As Boolean
Dim Lyr As MapXLib.Layer
Dim LayerInfo As New MapXLib.LayerInfo
Dim Flds As New MapXLib.Fields
Dim Icount As Integer
Dim Angle() As Double
Dim RecordTime() As Date
Dim StopFlag As Boolean
Dim TempPnt As New Point
Dim DisTemp As Double
Dim DisSum As Double

Private Sub Form_Load()
Dim strsql As String
Dim i As Integer
Dim ResShowVehicle As ADODB.Recordset

'On Error Resume Next
    
    Set ResShowVehicle = New ADODB.Recordset
    strsql = "select * from mapinfo where mapname='" & cSelectMapName & "'"
    If CreateRecordSetbySQL_Tempdb(ResShowVehicle, strsql) Then
        If Not (ResShowVehicle.BOF And ResShowVehicle.EOF) Then
            fZoom = ResShowVehicle.Fields("zoom" 
            fCenterX = ResShowVehicle.Fields("fcenterx" 
            fCenterY = ResShowVehicle.Fields("fcentery" 
        End If
    End If
    
    Set ResShowVehicle = Nothing
    
    txtVehicle.Text = FrmHistory.cboVehicle.Text
    txtMap.Text = FrmHistory.cboMap.Text
    txtStart.Text = FrmHistory.txtYear(0) + "-" + FrmHistory.txtMonth(0) + "-" + FrmHistory.txtDay(0) + " " + FrmHistory.txtHour(0) + ":" + FrmHistory.txtMinute(0) + ":00"
    txtEnd.Text = FrmHistory.txtYear(1) + "-" + FrmHistory.txtMonth(1) + "-" + FrmHistory.txtDay(1) + " " + FrmHistory.txtHour(1) + ":" + FrmHistory.txtMinute(1) + ":00"

HistoryMap.CreateCustomTool CreateCJTool, miToolTypePoly, miCrossCursor
    
    '设置默认工具
    HistoryMap.CurrentTool = miArrowTool
    
    HistoryMap.MapUnit = miUnitMeter
    
    HistoryMap.Geoset = IIf(Right(cSelectMapPath, 1) = "\", cSelectMapPath, cSelectMapPath & "\" + cSelectMapName
    HistoryMap.Zoom = fZoom
    HistoryMap.CenterX = fCenterX
    HistoryMap.CenterY = fCenterY
    
    TxtDataTime.Text = CStr(Year(Date)) + "年" + CStr(Month(Date)) + "月" + CStr(Day(Date)) + "日" + " " + CStr(Hour(Time)) + "时" + CStr(Minute(Time)) + "分" + CStr(Second(Time)) + "秒"
     
    StopFlag = False
    Toolbar1.Buttons(10).Enabled = False
    Toolbar1.Buttons(11).Enabled = False
    TimerShowMap.Interval = Slider.Value * 50
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    '清除临时图层
Dim i As Integer

For i = 1 To HistoryMap.Layers.Count
        If HistoryMap.Layers.Item(i).Name = "TempLayer" Then
            HistoryMap.Layers.Remove i
            i = HistoryMap.Layers.Count + 1
        End If
    Next i
    Set Lyr = Nothing
    Set Flds = Nothing
    Set LayerInfo = Nothing 
End Sub

Private Sub Form_Resize()

If Me.WindowState = 1 Then Exit Sub
    HistoryMap.Height = Me.ScaleHeight - 300 - frFrame.Height
    HistoryMap.Width = Me.ScaleWidth
    HistoryMap.Left = Me.ScaleLeft
    frFrame.Width = Me.ScaleWidth
    StatusBar.Panels(1).Width = 350
    StatusBar.Panels(2).Width = (Me.ScaleWidth - 400) / 10 * 4
    StatusBar.Panels(3).Width = (Me.ScaleWidth - 400) / 10 * 3.5
    StatusBar.Panels(4).Width = (Me.ScaleWidth - 400) / 10 * 2.5
    Picture1.Top = Me.ScaleHeight - 330
    Picture1.Left = Me.ScaleLeft + 100
End Sub

Private Sub HistoryMap_DblClick()
    If HistoryMap.CurrentTool = CreateCJTool Then
        HistoryMap.CurrentTool = miArrowTool 
        MsgBox "距离：" & CStr(DisSum) & " 米", vbOKOnly + vbInformation, "测距结果"
        StatusBar.Panels(3).Text = ""
        HisBeginFlag = False
    End If
End Sub

Private Sub HistoryMap_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    '测距
    If HistoryMap.CurrentTool = CreateCJTool And Button = vbLeftButton Then
        HistoryMap.MapUnit = miUnitMeter
        HistoryMap.ConvertCoord x, y, xDown, yDown, miScreenToMap
        HisBeginFlag = True
        DisTemp = DisSum 'distemp变量记录历史长度
    End If 
End Sub

Private Sub HistoryMap_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim xx As Double, yy As Double
Dim MapCoordX As Double, MapCoordY As Double

HistoryMap.ConvertCoord x, y, MapCoordX, MapCoordY, miScreenToMap
    If HistoryMap.CurrentTool = CreateCJTool And HisBeginFlag = True Then
        DisSum = DisTemp + HistoryMap.Distance(xDown, yDown, MapCoordX, MapCoordY)
        StatusBar.Panels(3).Text = "距离：" & CStr(DisSum) & "米"
    End If
    HistoryMap.ConvertCoord x, y, xx, yy, miScreenToMap
    StatusBar.Panels(2).Text = "经度: " & CStr(Round(xx, 4)) & "    " & "纬度: " & CStr(Round(yy, 4))
End Sub

Private Sub Slider_Click() dedecms.com 
    If Slider.Value <> 0 Then
        Slider.ToolTipText = "回放速度：" & Slider.Value * 10 & "倍"
        TimerShowMap.Interval = Slider.Value * 10
    End If
End Sub

Private Sub TimerTime_Timer()
    TxtDataTime.Text = CStr(Year(Date)) + "年" + CStr(Month(Date)) + "月" + CStr(Day(Date)) + "日" + " " + CStr(Hour(Time)) + "时" + CStr(Minute(Time)) + "分" + CStr(Second(Time)) + "秒"
End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
Dim i As Integer

Select Case Button.Key
        Case "fullmap"
            HistoryMap.Bounds = HistoryMap.Layers.Bounds copyright dedecms 
        Case "zoomin"
            HistoryMap.CurrentTool = miZoomInTool
        Case "zoomout"
            HistoryMap.CurrentTool = miZoomOutTool
        Case "pan"
            HistoryMap.CurrentTool = miPanTool
        Case "cj"
            HistoryMap.CurrentTool = CreateCJTool
            DisSum = 0
        Case "default"
            HistoryMap.CurrentTool = miArrowTool 内容来自dedecms 
        Case "start"
            If StopFlag Then
                TimerShowMap.Enabled = True
                Toolbar1.Buttons(10).Enabled = True
                Toolbar1.Buttons(11).Enabled = True
                Toolbar1.Buttons(9).Enabled = False
            Else
                Call BackPutHistoryLocus
            End If
        Case "pause" 
            TimerShowMap.Enabled = False
            Toolbar1.Buttons(9).Enabled = True
            Toolbar1.Buttons(10).Enabled = False
            StopFlag = Not StopFlag
        Case "stop"
            TimerShowMap.Enabled = False
            Toolbar1.Buttons(10).Enabled = False
            Toolbar1.Buttons(11).Enabled = False
            Toolbar1.Buttons(9).Enabled = True
        Case "clear" 
            TimerShowMap.Enabled = False
            '清除临时图层
            For i = 1 To HistoryMap.Layers.Count
                If HistoryMap.Layers.Item(i).Name = "TempLayer" Then
                    HistoryMap.Layers.Remove i
                    i = HistoryMap.Layers.Count + 1
                End If
            Next i
            Set Lyr = Nothing 
            Set Flds = Nothing
            Set LayerInfo = Nothing
        Case "exit"
            Unload Me
    End Select
End Sub

Private Sub BackPutHistoryLocus() '回放历史轨迹
Dim ExistFlag As Boolean
Dim i As Integer
Dim TempLyr As MapXLib.Layer

On Error GoTo aa:

'判断临时图层是否存在
    ExistFlag = False '不存在
    For i = 1 To HistoryMap.Layers.Count
        If HistoryMap.Layers.Item(i).Name = "TempLayer" Then
            ExistFlag = True '存在
            i = HistoryMap.Layers.Count + 1 
        End If
    Next i
    
    If Not ExistFlag Then '不存在，新建临时图层
        '创建临时图层
        Flds.AddStringField "ID", 12
         
        LayerInfo.Type = miLayerInfoTypeTemp
        LayerInfo.AddParameter "NAME", "TempLayer"
        LayerInfo.AddParameter "Fields", Flds
        
        Set Lyr = HistoryMap.Layers.Add(LayerInfo, 1)

Else
        For i = 1 To HistoryMap.Layers.Count
            If HistoryMap.Layers.Item(i).Name = "TempLayer" Then 
                HistoryMap.Layers.Remove i
                i = HistoryMap.Layers.Count + 1
            End If
        Next i
        Set Lyr = Nothing
        Set LayerInfo = Nothing
        '创建临时图层
        
        Flds.AddStringField "ID", 12
         
        LayerInfo.Type = miLayerInfoTypeTemp
        LayerInfo.AddParameter "NAME", "TempLayer" 
        LayerInfo.AddParameter "Fields", Flds
        
        Set Lyr = HistoryMap.Layers.Add(LayerInfo, 1)
    End If

ReDim Angle(Res.RecordCount - 1)
    ReDim RecordTime(Res.RecordCount - 1)
    
    Res.MoveFirst
    
    For i = 0 To Res.RecordCount - 1
        Hispnt.Set Res.Fields("Longitude" , Res.Fields("Latitude" 
        Hispnts.Add Hispnt
        Angle(i) = Res.Fields("angle" 
        RecordTime(i) = Res.Fields("time" 
        Res.MoveNext 
    Next i
        Icount = 0
        TempPnt.Set Hispnts.Item(1).x, Hispnts.Item(1).y
        TimerShowMap.Enabled = True
        'TimerShowMap.Interval = 100
        Toolbar1.Buttons(10).Enabled = True
        Toolbar1.Buttons(11).Enabled = True
        Toolbar1.Buttons(9).Enabled = False
    Exit Sub
aa:
    MsgBox "历史记录回放错误，请检测.", vbOKOnly + vbExclamation, "历史记录回放..."
    Exit Sub
End Sub

Private Sub TimerShowMap_Timer()
Dim NewStyle As New MapXLib.Style
Dim ftr As New Feature
Dim fnt As New StdFont

On Error GoTo aa:

Icount = Icount + 1
    If Hispnts.Count = Icount Then
        TimerShowMap.Enabled = False
        TimerShowMap.Interval = 0
        StopFlag = Not StopFlag
        MsgBox "历史轨迹回放完毕!"
        Exit Sub
    End If
    With fnt
        .Name = "gisdisplay"
        .Bold = False
    End With
    
    With NewStyle
        .SymbolType = miSymbolTypeTrueTypeFont
        .SymbolFont = fnt
        .SymbolFontShadow = True 
        .SymbolCharacter = 34
        .SymbolFont.Size = 12
        .SymbolFontColor = gisBlue    '蓝色
    End With

StatusBar.Panels(3).Text = "第 " & CStr(Icount) & " 条  " & CStr(Round(Hispnts.Item(Icount).x, 4)) & "::::" & CStr(Round(Hispnts.Item(Icount).y, 4)) & "   方位角: " & CStr(Angle(Icount)) & " 度"
    txtRecordTime.Text = RecordTime(Icount - 1)
    If Icount <> 1 And TempPnt.x = Hispnts.Item(Icount).x And TempPnt.y = Hispnts.Item(Icount).y Then
        TempPnt.Set Hispnts.Item(Icount).x, Hispnts.Item(Icount).y
        Exit Sub
    End If 
    ftr.Attach HistoryMap
    ftr.Type = miFeatureTypeSymbol
    ftr.Style = NewStyle
    ftr.Offset Hispnts.Item(Icount).x, Hispnts.Item(Icount).y
    HistoryMap.Layers("TempLayer" .AddFeature ftr
    
    TempPnt.Set Hispnts.Item(Icount).x, Hispnts.Item(Icount).y
    
    If Hispnts.Item(Icount).x > HistoryMap.Bounds.XMax Then
        HistoryMap.CenterX = Hispnts.Item(Icount).x
        HistoryMap.CenterY = Hispnts.Item(Icount).y
    End If
    If Hispnts.Item(Icount).x < HistoryMap.Bounds.XMin Then
        HistoryMap.CenterX = Hispnts.Item(Icount).x
        HistoryMap.CenterY = Hispnts.Item(Icount).y 
    End If
    If Hispnts.Item(Icount).y > HistoryMap.Bounds.YMax Then
        HistoryMap.CenterX = Hispnts.Item(Icount).x
        HistoryMap.CenterY = Hispnts.Item(Icount).y
    End If
    If Hispnts.Item(Icount).y < HistoryMap.Bounds.YMin Then
        HistoryMap.CenterX = Hispnts.Item(Icount).x
        HistoryMap.CenterY = Hispnts.Item(Icount).y
    End If
    Exit Sub
aa:
    TimerShowMap.Enabled = False
    TimerShowMap.Interval = 0
    StopFlag = Not StopFlag
    MsgBox "历史轨迹回放完毕!"
    Exit Sub
End Sub