module1.bas

MAPINFO+VB的地图编程, 运行前需先安装mapx

Attribute VB_Name = "Module1"
Option Explicit
Public g_ftQueryPosition As MapXLib.Feature
Public fFeature As MapXLib.Feature
Public tracefeature As MapXLib.Feature
Public Sub Freshfeature()
Dim Pt As New MapXLib.Point
Dim st As MapXLib.Style
Dim Index As Integer
Dim tempFt As MapXLib.Feature
Dim temp1 As String
Dim temp2 As String
Dim tempFeature As MapXLib.Feature
On Error Resume Next
    
'    index = GetQueryIndex(Tel)

'    m_iCount = lsvQueryCar.ListItems.Count
'    Me.Caption = "位置查询" + "——结果：（" + CStr(m_iCount) + "）" 'temp1 + temp2
    
    'With QueryMobileInfo.mobile(index)
        Call Pt.Set(110, 30)
        
        Form1.Map1.Zoom = 50
        'Form1.Map1.Rotation = 30
'        Form1.Map1.CenterX = 120
'        Form1.Map1.CenterY = 40
        If Form1.Map1.IsPointVisible(Pt.x, Pt.y) = False Then
           Form1.Map1.ZoomTo Form1.Map1.Zoom, Pt.x, Pt.y
        End If
      
'**********************画个红色的圆***************START
     
        With Form1.Map1.DefaultStyle
             .RegionPattern = 0
             .RegionTransparent = True
             .RegionBorderColor = RGB(255, 0, 0)
             .RegionBorderWidth = 4
        End With
       
        If g_ftQueryPosition Is Nothing Then
            Set tempFeature = Form1.Map1.FeatureFactory.CreateCircularRegion(1, Pt, Form1.Map1.Zoom / 30, , , Form1.Map1.DefaultStyle)
            Set g_ftQueryPosition = Form1.Map1.Layers.AnimationLayer.AddFeature(tempFeature)
        Else
            Form1.Map1.Layers.AnimationLayer.DeleteFeature (g_ftQueryPosition)
            Set g_ftQueryPosition = Nothing
            Set tempFeature = Form1.Map1.FeatureFactory.CreateCircularRegion(1, Pt, Form1.Map1.Zoom / 30, , , Form1.Map1.DefaultStyle)
            Set g_ftQueryPosition = Form1.Map1.Layers.AnimationLayer.AddFeature(tempFeature)
        End If
        Set tempFeature = Nothing
        Set Pt = Nothing
        
'*******************画个红色的圆**********************END
       
   ' End With
    Set tempFt = Nothing
    Set st = Nothing
End Sub

Public Sub ShowQueryMobileinfo(i As Integer)
Dim Pt As New MapXLib.Point
Dim st As MapXLib.Style
Dim tempFt As MapXLib.Feature
'Dim fFeature As MapXLib.Feature
Dim Temp As String
Dim KeyValueTemp As String
Dim itmX As ListItem
Dim MobileFeature As MapXLib.Feature
On Error Resume Next
        Pt.Set 120 + i, 30
        Set st = Form1.Map1.DefaultStyle
        st.SymbolType = miSymbolTypeTrueTypeFont
        Call GetIconStyle(st, 7)
'        st.SymbolFont.Name = "GpsIcon"
'        st.SymbolCharacter = 33
'        st.SymbolFontColor = RGB(0, 0, 255)
        
        Set tempFt = Form1.Map1.FeatureFactory.CreateSymbol(Pt, st)
            
        Set MobileFeature = Form1.Map1.Layers.AnimationLayer.AddFeature(tempFt)
            MobileFeature.KeyValue = 123
        Set fFeature = MobileFeature
            fFeature.Update
        'Call FrmQueryPlay.Freshfeature(.strmobilenum)
    
    Set tempFt = Nothing
    Set Pt = Nothing
    Set st = Nothing
End Sub

Public Function GetIconStyle(st As MapXLib.Style, iconnum) As Integer
On Error Resume Next
st.SymbolType = miSymbolTypeTrueTypeFont
st.SymbolFont.Name = "GpsIcon"
Select Case Val(iconnum)
       Case 1
                st.SymbolFont.Size = 24
                st.SymbolCharacter = 33
                st.SymbolFontColor = RGB(0, 0, 0)
        
        Case 2
            
                st.SymbolFont.Size = 24
                st.SymbolCharacter = 33
                st.SymbolFontColor = RGB(0, 255, 64)
            
        Case 3
                st.SymbolFont.Size = 24
                st.SymbolCharacter = 33
                st.SymbolFontColor = RGB(255, 0, 255)
        Case 4
                st.SymbolFont.Size = 24
                st.SymbolCharacter = 33
                st.SymbolFontColor = RGB(128, 0, 255)
        Case 5
                st.SymbolFont.Size = 24
                st.SymbolCharacter = 35
                st.SymbolFontColor = RGB(0, 0, 0)
        
        Case 6
            
                st.SymbolFont.Size = 24
                st.SymbolCharacter = 35
                st.SymbolFontColor = RGB(0, 255, 64)
            
        Case 7
                st.SymbolFont.Size = 24
                st.SymbolCharacter = 35
                st.SymbolFontColor = RGB(255, 0, 255)
        Case 8
                st.SymbolFont.Size = 24
                st.SymbolCharacter = 35
                st.SymbolFontColor = RGB(128, 0, 255)
        Case 9
                st.SymbolFont.Size = 24
                st.SymbolCharacter = 34
                st.SymbolFontColor = RGB(0, 0, 0)
        
        Case 10
            
                st.SymbolFont.Size = 24
                st.SymbolCharacter = 34
                st.SymbolFontColor = RGB(0, 255, 64)
            
        Case 11
                st.SymbolFont.Size = 24
                st.SymbolCharacter = 34
                st.SymbolFontColor = RGB(255, 0, 255)
        Case 12
                st.SymbolFont.Size = 24
                st.SymbolCharacter = 34
                st.SymbolFontColor = RGB(128, 0, 255)
        Case Else
End Select

st.SymbolFontHalo = True
'st.SymbolFontRotation = (GPSData.direction) Mod 360
End Function
Public Sub movevehicle(ByVal i As Integer)
  Dim Pt As New MapXLib.Point
  Dim pts As New MapXLib.Points
  Dim Ft As MapXLib.Feature
  Dim isfirst As Boolean
  Dim x As Single
  Dim y As Single
  Dim tempStr As String
  Dim Intemp As Integer
 On Error GoTo ErrorHandle
  If Not fFeature Is Nothing Then
  isfirst = True
'     If fFeature.Point.x <> 0 And fFeature.Point.y <> 0 Then
'        Call pts.Add(fFeature.Point)
'        isfirst = False
'     End If
     fFeature.Point.Set 110 + i, 30
     
'     If isfirst = False Then
'        If tracefeature Is Nothing Then
'           Set tracefeature = fFeature.Clone
'        End If
'        Call pts.Add(fFeature.Point)
        
'         tracefeature.Type = miFeatureTypeLine
'        With tracefeature.Style
'                .LineColor = RGB(0, 0, 0)
'                .LineStyle = 59
'        End With
'        tracefeature.Parts.Add pts
'        If tracefeature.Parts.Count > 100 Then
'          tracefeature.Parts.RemoveAll
'        End If
        'Set .pts = pts
'     End If
     
     Call GetIconStyle(fFeature.Style, i Mod 12 + 1)
     

     
   fFeature.KeyValue = i
     fFeature.Update
End If
  Set pts = Nothing
  Set Pt = Nothing
  Set Ft = Nothing
  Exit Sub
ErrorHandle:

 Resume Next

End Sub