MapX历史轨迹回放[开发源代码]：
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
