gpsboyce.ebf

用VB+MapX实现的用于PDA和PC机的GPS显示源码（很有参考价值）

       Else
           strDate = ","
       End If
       MSComm1.Output = "$PRWIINIT,V,,," & strPos & "0,0,M,0,T," & strDate & vbCrlf
    End If
   End If
   
   If InStr(1, strCurrent, "$GPRMC") Then ParseRMC strCurrent
   
   If InStr(1, strCurrent, "$GPGSV") Then ParseGSV strCurrent
   If InStr(1, strCurrent, "$GPGGA") Then ParseGGA strCurrent
   
''   txtDisplay.Text = txtDisplay.Text & strCurrent & vbCrlf
'   If Len(txtDisplay.Text) > 1500 Then txtDisplay.Text = Right(txtDisplay.Text, 1500)
'   txtDisplay.SelStart = Len(txtDisplay.Text)

If Emulate = False Then
'   FOut.WriteLine (strCurrent)
End If

Loop

End Sub

Sub ParseRMC(inrmc As String)
' $GPRMC,031736,V,4043.3101,N,07317.5308,W,0.000,0.0,120800,14.1,W*52
Dim rmcdata(12) As String
Dim token, tokenpos, oldtokenpos
Dim outrmc

token = ","
tokenpos = 0
oldtokenpos = 1

outrmc = inrmc

For n = 1 To 11
    tokenpos = InStr(oldtokenpos + 1, outrmc, token)
    curstr = Mid(outrmc, oldtokenpos + 1, tokenpos - oldtokenpos - 1)
    If n = 2 Then
        If Len(curstr) > 0 Then lblUTC = Mid(curstr, 1, 2) & ":" & Mid(curstr, 3, 2) & ":" & Mid(curstr, 5, 2) & " GMT"
    End If
        
    If n = 3 Then
    
    If (Mid(curstr, 1, 1) = "V") Then
        lblStatus.ForeColor = RGB(255, 0, 0)
       lblStatus.Caption = "AWAITING FIX"
    ElseIf (Mid(curstr, 1, 1) = "A") Then
        lblStatus.ForeColor = RGB(0, 128, 0)
        lblStatus.Caption = "SATS OK"
    End If
    End If
    
    If n = 4 Then
        lblLat.Caption = (curstr / 100)
        curlat = curstr / 100
    End If
    If n = 5 Then lblLat.Caption = lblLat.Caption & curstr
    If n = 6 Then
        lblLong.Caption = (curstr / 100)
        curlng = -(curstr / 100)
    End If
    If n = 7 Then lblLong.Caption = lblLong.Caption & curstr
    If n = 8 Then
        If (curstr * 1.151) > maxspd Then
            maxspd = (curstr * 1.151)
        End If
        spdstrg = (Int(100 * curstr * 1.151) / 100) & " MPH"
        lblSpeed.Caption = spdstrg
        lblMaxMPH.Caption = Int(100 * maxspd) / 100
    End If
    
    If n = 9 Then
'    lblTrack = "Track: " & curstr
    PlotBearings picBearings, 0# + curstr
    End If
    
    If n = 10 Then
        lblDate = Mid(curstr, 1, 2) & "-" & Mid(curstr, 3, 2) & "-" & Mid(curstr, 5, 2)
    End If
    
    oldtokenpos = tokenpos
Next

' lblLat, lblLong
'   **  1) UTC Time
'   **  2) Status, V = Navigation receiver warning
'   **  3) Latitude
'   **  4) N or S
'   **  5) Longitude
'   **  6) E or W
'   **  7) Speed over ground, knots
'   **  8) Track made good, degrees true
'   **  9) Date, ddmmyy
'   ** 10) Magnetic Variation, degrees
'   ** 11) E or W
'   ** 12) Checksum

End Sub

Sub ParseGGA(ingga As String)
' $GPGGA,120757,5152.985,N,00205.733,W,1,06,2.5,121.9,M,49.4,M,,*52
Dim hDC, hWnd

Dim ggadata(12) As String
token = ","
tokenpos = 0
oldtokenpos = 1

outgga = ingga

For n = 1 To 11
    tokenpos = InStr(oldtokenpos + 1, outgga, token)
    curstr = Mid(outgga, oldtokenpos + 1, tokenpos - oldtokenpos - 1)
    If n = 2 Then
    If Len(curstr) > 0 Then lblUTC = Mid(curstr, 1, 2) & ":" & Mid(curstr, 3, 2) & ":" & Right(curstr, 2) & " GMT"
    End If
    If n = 3 Then
        lblLat.Caption = (curstr / 100)
        curlat = curstr / 100
    End If
    If n = 4 Then lblLat.Caption = lblLat.Caption & " " & curstr
    
    If n = 5 Then
        lblLong.Caption = (curstr / 100)
        curlng = -(curstr / 100)
    End If
    If n = 6 Then
    lblLong.Caption = lblLong.Caption & " " & curstr
    End If
    
    If n = 10 Then
    altft = (curstr * 39.36) / 12
    If altft > maxalt Then
        maxalt = altft
        lblMaxAlt.Caption = Mid(altft, 1, 6)
    End If
    
    lblAlt = "Alt " & Mid(altft, 1, 6) & " ft"
    
    'ScrollImg picAlt
    DrawCurrAlt picAlt, 0 + altft, 200, 100    '===========

    End If
    
    oldtokenpos = tokenpos
Next

'1 time of fix (hhmmss),
'2 latitude,
'3 N/S,
'4 longitude,
'5 E/W,
'6 Fix quality (0=invalid, 1=GPS fix, 2=DGPS fix),
'7 number of satellites being tracked,
'8 horizontal dilution of position,
'9 altitude above sea level,
'10 M (meters),
'11 height of geoid (mean sea level) above WGS84 ellipsoid,
'12 time in seconds since last DGPS update,
'13 DGPS station ID number,
'14 checksum
End Sub

Sub ParseGSV(ingsv As String)
'$GPGSV,2,2,08,05,31,055,29,11,14,290,,15,13,221,28,23,13,152,*7B
On Error Resume Next

Dim vColor As Long

token = ","
tokenpos = 0
oldtokenpos = 1

outgsv = ingsv
endsent = 0

' GSV token
    tokenpos = InStr(oldtokenpos + 1, outgsv, token)
    curstr = Mid(outgsv, oldtokenpos + 1, tokenpos - oldtokenpos - 1)
    oldtokenpos = tokenpos
    
' Tot GSV msgs in block
    tokenpos = InStr(oldtokenpos + 1, outgsv, token)
    curstr = Mid(outgsv, oldtokenpos + 1, tokenpos - oldtokenpos - 1)
    oldtokenpos = tokenpos

' Cur GSV msg num
    tokenpos = InStr(oldtokenpos + 1, outgsv, token)
    curstr = Mid(outgsv, oldtokenpos + 1, tokenpos - oldtokenpos - 1)
    oldtokenpos = tokenpos
    
    If Int(curstr) = 1 Then
        lstSats.Clear
    End If


' Sats in view
    tokenpos = InStr(oldtokenpos + 1, outgsv, token)
    curstr = Mid(outgsv, oldtokenpos + 1, tokenpos - oldtokenpos - 1)
    oldtokenpos = tokenpos
    satsinview = Int(curstr)
    
' Up to 4 sats
For n = 1 To 4
    tokenpos = InStr(oldtokenpos + 1, outgsv, token)
    curstr = Mid(outgsv, oldtokenpos + 1, tokenpos - oldtokenpos - 1)
    satname = Int(curstr)
    oldtokenpos = tokenpos

    tokenpos = InStr(oldtokenpos + 1, outgsv, token)
    curstr = Mid(outgsv, oldtokenpos + 1, tokenpos - oldtokenpos - 1)
    satelev = curstr
    If Len(curstr) = 0 Then satelev = "??"
    oldtokenpos = tokenpos
    
    tokenpos = InStr(oldtokenpos + 1, outgsv, token)
    curstr = Mid(outgsv, oldtokenpos + 1, tokenpos - oldtokenpos - 1)
    satazim = curstr
    If Len(curstr) = 0 Then satazim = "??"
    oldtokenpos = tokenpos
    
    tokenpos = InStr(oldtokenpos + 1, outgsv, token)
    If tokenpos = 0 Then
        satstrg = "00"
        endsent = 1
    Else
        curstr = Mid(outgsv, oldtokenpos + 1, tokenpos - oldtokenpos - 1)
        satstrg = curstr
        If Len(curstr) = 0 Then satstrg = "00"
        oldtokenpos = tokenpos
    End If
    
    ' Now that we have sat info, plot it
    
    vColor = GetSatColor(satname)
    
    If vColor = -1 Then vColor = RGB(0, 0, 0)
    
    If ((0 + satstrg) > 0) Then
        lstSats.AddItem satname & " (E" & satelev & " A" & satazim & " S" & satstrg & ")"
        PlotSat picCompass, 0 + satname, 0 + satelev, 0 + satazim, vColor
    End If
        
    If endsent = 1 Then Exit Sub
Next

End Sub

Sub PlotSat(Pic As Object, satname As Integer, satelev As Integer, satazim As Integer, clr As Long)

Dim x, y
pi = 3.14159265358979

' Correct so that N = up
satazim = (satazim - 90) Mod 360

x = 180 + satelev * Cos((satazim * pi / 180))
y = 180 + satelev * Sin((satazim * pi / 180))
Pic.DrawWidth = 2
Pic.DrawPoint Int(x), Int(y), clr

End Sub

Sub PlotBearings(Pic As Object, satbear As Double)
Dim x, y
pi = 3.14159265358979

' Correct so that N = up
corrbear = (satbear - 90) Mod 360

x = 180 + 100 * Cos((corrbear * pi / 180))
y = 180 + 100 * Sin((corrbear * pi / 180))

If satbear <> 0 Then
    Pic.Cls
    PlotLines Pic

    Pic.DrawWidth = 2

    Pic.DrawLine 180, 180, x, y, RGB(255, 0, 0)

    Pic.DrawText "N", 176, 0

    Pic.DrawText satbear, 250, 250
End If

End Sub

Sub PlotLines(Pic As Object)
Pic.DrawWidth = 1

Pic.DrawLine 0, 0, 360, 360, RGB(192, 192, 192)
Pic.DrawLine 0, 180, 360, 180, RGB(192, 192, 192)
Pic.DrawLine 180, 0, 180, 360, RGB(192, 192, 192)
Pic.DrawLine 360, 0, 0, 360, RGB(192, 192, 192)

Pic.DrawCircle 180, 180, 45, RGB(192, 192, 192)
Pic.DrawCircle 180, 180, 90, RGB(192, 192, 192)
Pic.DrawCircle 180, 180, 135, RGB(192, 192, 192)
Pic.DrawCircle 180, 180, 180, RGB(192, 192, 192)

End Sub

Sub InitSatColor()
satclr(1) = &HFF&        ' Red
satclr(2) = &HC000&      ' Green
satclr(3) = &H808000    ' Dark cyan
satclr(4) = &H8080&     ' Dark yellow
satclr(5) = &HFF0000     ' Blue
satclr(6) = &HFFFF00     ' Cyan
satclr(7) = &H404040     ' Gray
satclr(8) = &H80&        ' Dark red
satclr(9) = &H4080&      ' Dark orange
satclr(10) = &H0&        ' Black
satclr(11) = &H400040    ' Dark purple
satclr(12) = &H800000    ' Dark blue
satclr(13) = &H80FF&     ' Orange
satclr(14) = &H8000&     ' Dark green
satclr(15) = &HC000C0     ' Purple
satclr(16) = &H404080    ' Brownish
End Sub

Function GetSatColor(sn As Integer) As Long
Dim vColor As Long
vColor = -1

For n = 1 To 16
    If satref(n) = sn Then
        vColor = satclr(n)
        Exit For
    End If
Next

If vColor = -1 Then
    If totsats > 16 Then
        vColor = RGB(128, 0, 0)
    Else
        totsats = totsats + 1
        satref(totsats) = sn
        vColor = satclr(totsats)
    End If
    
End If

GetSatColor = vColor

End Function

'======================================

Private Sub btnSwap_Click()
If picAlt.Visible = False Then
    picAlt.Visible = True
    lstSats.Visible = False
Else
    picAlt.Visible = False
    lstSats.Visible = True
End If
End Sub

Sub DrawCurrAlt(Pic As Object, val As Integer, rang As Integer, base As Integer)
Dim tw, n, p

sh = Pic.ScaleHeight
sw = Pic.ScaleWidth
tw = Pic.ScaleWidth


'   picAlt.DrawLine sw - 1, 0, sw - 1, sh, RGB(255, 255, 255)
'   picAlt.DrawLine sw - 1, sh - Int((sh * (val - base) / rang)), sw - 1, sh, RGB(128, 0, 0)
  
Alt(CurAlt) = val
CurAlt = CurAlt + 1
If CurAlt > tw Then CurAlt = 1
   
For n = 1 To tw
    p = CurAlt + n
    If p > tw Then p = (CurAlt + n - tw)
    
   picAlt.DrawLine n, 0, n, Alt(p), picAlt.BackColor
   picAlt.DrawLine n, sh - Int(sh * (Alt(p) - base) / rang), n, sh, RGB(255, 0, 0)
    
   'For n = 1 To 161
'   p = curloc + n
'   If p > 161 Then p = (curloc + n - 161)
'
'   Pic.DrawLine n, 0, n, Alt(p), RGB(0, 0, 255)
'   Pic.DrawLine n, sh - Alt(p), n, sh, RGB(255, 0, 0)
Next n
'
'curloc = curloc + 1
'If curloc > 161 Then curloc = 1

   
End Sub

Sub ScrollImg(Pic As Object)
      
Dim hOldDC, hWnd, hDC
Dim hDestDC, hSrcDC, nWidth, nHeight

    hOldDC = GetFocus
    Pic.SetFocus
    hWnd = GetFocus
    hDC = GetDC(hWnd)
    
    hDestDC = hDC 'GetDC(Pic.hwnd)
    hSrcDC = hDC ' hDestDC
    nWidth = Pic.ScaleWidth - 2
    nHeight = Pic.ScaleHeight
      
      picSrcX = 1
      picSrcY = 1
      
      picDestX = 0
      picDestY = 1
      
      ' Assign the SRCCOPY constant to the Raster operation.
      dwRop = &HCC0020
      
      Suc = BitBlt(hDestDC, picDestX, picDestY, nWidth, nHeight, hSrcDC, picSrcX, picSrcY, dwRop)
      
'      Pic.Refresh

End Sub