frmgpsboy.frm

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

    MSComm1.Output = "$PRWIILOG,ZCH,V,,," & vbCrLf
End If
End If

flag = 1
txtDisplay.Text = ""
End Sub

Private Sub btnMap_Click()
    curURL = "http://tiger.census.gov/cgi-bin/mapgen?&mlat=" & curlat & "&mlon=" & curlng & "&msym=bigdot&lat=" & curlat & "&lon=" & curlng & "&wid=1.000&ht=1.000"
    frmMap.Show
    frmMap.Caption = "Show map (" & curlat & "," & curlng & ")"
    frmMap.wbMap.Navigate curURL
End Sub

Private Sub btnStop_Click()
flag = 0
If MSComm1.PortOpen = True Then MSComm1.PortOpen = False
End Sub

Private Sub Form_Load()
flag = 0

lblStatus.ForeColor = &HFF0000
lblStatus.Caption = "AWAITING FIX"

curlat = 33.386
curlng = -111.55

Set fs = CreateObject("Scripting.FileSystemObject")
PlotLines picCompass
PlotLines picBearings

End Sub

Private Sub form_unload(Cancel As Integer)
On Error Resume Next
   FOut.Close
End Sub

Private Sub mnuFileEmulate_Click()
If (Not mnuFileEmulate.Checked) Then
    mnuFileEmulate.Checked = True
    Timer1.Interval = 50
Else
    mnuFileEmulate.Checked = False
    Timer1.Interval = 1000
End If

End Sub



Private Sub Timer1_Timer()
On Error Resume Next

If flag = 1 Then
    If mnuFileEmulate.Checked = True Then
        B$ = FOut.ReadLine & vbCr
        If Err = 62 Then ' past eof
        FOut.Close
        flag = 0
        End If
    Else
        B$ = MSComm1.Input
    End If
    strUnparsed = strUnparsed + B$
    
    ParseInput
End If

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
flag = 0
token = ","
tokenpos = 0
oldtokenpos = 1
crpos = InStr(1, inrmc, vbCr)
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 = "Time: " & Left(curstr, 2) & ":" & Mid(curstr, 3, 2) & ":" & Right(curstr, 2) & " GMT"
    End If
        
    If n = 3 Then
    
    If (Left(curstr, 1) = "V") Then
        lblStatus.ForeColor = RGB(255, 0, 0)
        lblStatus.Caption = "AWAITING FIX"
    ElseIf (Left(curstr, 1) = "A") Then
        lblStatus.ForeColor = RGB(0, 128, 0)
        lblStatus.Caption = "SATS OK"
    End If
    End If
    
    If n = 4 Then
        lblLat = "Lat: " & StrToDeg(curstr)
        curlat = StrToDeg(curstr)
    End If
    If n = 5 Then lblLat = lblLat & curstr
    If n = 6 Then
        lblLong = "Long: " & StrToDeg(curstr)
        curlong = -StrToDeg(curstr)
    End If
    If n = 7 Then lblLong = lblLong & curstr
    If n = 8 Then
        If (curstr * 1.151) > maxspd Then maxspd = (curstr * 1.151)
        lblSpeed = "Speed (mph): " & Format(curstr * 1.151, "0.00") & " (" & Format(maxspd, "0.00") & " MAX)"
        DrawCurrSpeed picSpeed, (curstr * 1.151)
    End If
    
    If n = 9 Then
    lblTrack = "Track: " & curstr
    PlotBearings picBearings, 0# + curstr
    End If
    
    If n = 10 Then lblDate = "Date: " & Left(curstr, 2) & "-" & Mid(curstr, 3, 2) & "-" & Right(curstr, 2)
    oldtokenpos = tokenpos
Next
flag = 1
' 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 ParseInput()
If Len(strUnparsed) = 0 Then Exit Sub

crpos = InStr(1, strUnparsed, vbCr)

Do While crpos > 0
   strCurrent = Left(strUnparsed, crpos - 1)
   strUnparsed = Mid(strUnparsed, crpos + 2)
   crpos = InStr(1, strUnparsed, vbCr)
   
   If mnuFileEmulate.Checked = False Then
   'Make unit start sending raw NMEA data
   If InStr(1, strCurrent, "ASTRAL") > 0 Then
       MSComm1.Output = "ASTRAL" & vbCr
       ' Turn on GPMRC msgs every 2 seconds
       MSComm1.Output = "$PRWIILOG,RMC,A,T,2,0" & vbCrLf
       ' Turn on GPMRC msgs every 2 seconds
       MSComm1.Output = "$PRWIILOG,GSA,A,T,5,0" & vbCrLf
       ' Turn on GPMRC msgs every 2 seconds
       MSComm1.Output = "$PRWIILOG,GSV,A,T,6,0" & vbCrLf
       ' Turn on GPGGA msgs every 2 seconds
       MSComm1.Output = "$PRWIILOG,GGA,A,T,4,0" & vbCrLf
       ' Turn off PRWIZCH messages
       MSComm1.Output = "$PRWIILOG,ZCH,V,,," & vbCrLf
       ' Preset lat/long/time   FIX THIS LINE
       MSComm1.Output = "$PRWIINIT,V,,,3338.6000,N,11155.0000,W,0,0,M,0,T,190500,021000" & 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 mnuFileEmulate.Checked = False Then
   FOut.WriteLine (strCurrent)
End If

Loop

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 ggadata(12) As String
token = ","
tokenpos = 0
oldtokenpos = 1
crpos = InStr(1, ingga, vbCr)
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 = "Time: " & Left(curstr, 2) & ":" & Mid(curstr, 3, 2) & ":" & Right(curstr, 2) & " GMT"
    End If
    If n = 3 Then
        lblLat = "Lat: " & StrToDeg(curstr)
        curlat = StrToDeg(curstr)
    End If
    If n = 4 Then lblLat = lblLat & curstr
    
    If n = 5 Then
        lblLong = "Long: " & StrToDeg(curstr)
        curlong = -StrToDeg(curstr)
    End If
    If n = 6 Then
    lblLong = lblLong & curstr
    End If
    
    If n = 10 Then
    altft = (curstr / 39.36) * 12
    lblAlt = "Alt: " & Format(altft, "0.00") & " 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

token = ","
tokenpos = 0
oldtokenpos = 1
crpos = InStr(1, ingsv, vbCr)
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
        lstSats.AddItem "Sat " & vbTab & "Elev " & vbTab & "Azi " & vbTab & "Str"
    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 = "??"
        endsent = 1
    Else
        curstr = Mid(outgsv, oldtokenpos + 1, tokenpos - oldtokenpos - 1)
        satstrg = curstr
        If Len(curstr) = 0 Then satstrg = "??"
        oldtokenpos = tokenpos
    End If
    
    lstSats.AddItem satname & vbTab & satelev & vbTab & satazim & vbTab & satstrg
    
    PlotSat 0 + satname, 0 + satelev, 0 + satazim, 0 + satstrg
    If endsent = 1 Then Exit Sub
Next

End Sub

Sub PlotSat(satname As Integer, satelev As Integer, satazim As Integer, satstrg As Integer)

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))
picCompass.ForeColor = RGB(255, 0, 0)
picCompass.PSet (x, y), RGB(255, 0, 0)

End Sub

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

' Correct so that N = up
satbear = (satbear - 90) Mod 360
x = 180 + 100 * Cos((satbear * pi / 180))
y = 180 + 100 * Sin((satbear * pi / 180))
Pic.Cls
PlotLines Pic

Pic.Line (180, 180)-(x, y)

End Sub

Sub PlotLines(Pic As Object)

Pic.Line (0, 0)-(360, 360), RGB(192, 192, 192)
Pic.Line (0, 180)-(360, 180), RGB(192, 192, 192)
Pic.Line (180, 0)-(180, 360), RGB(192, 192, 192)
Pic.Line (360, 0)-(0, 360), RGB(192, 192, 192)
Pic.Circle (180, 180), 45, RGB(192, 192, 192)
Pic.Circle (180, 180), 90, RGB(192, 192, 192)
Pic.Circle (180, 180), 135, RGB(192, 192, 192)
Pic.Circle (180, 180), 180, RGB(192, 192, 192)

End Sub

Sub DrawCurrAlt(Pic As Object, val As Integer, Range As Integer, base As Integer)
sh = Pic.ScaleHeight
sw = Pic.ScaleWidth

   Pic.Line (sw - 1, 0)-(sw - 1, sh), RGB(255, 255, 255)
   Pic.Line (sw - 1, sh - (sh * (val - base) / Range))-(sw - 1, sh), RGB(128, 0, 0)
End Sub

Sub DrawCurrSpeed(Pic As Object, val As Integer)
Static maxspd As Integer

If val > maxspd Then maxspd = val

sh = Pic.ScaleHeight
sw = Pic.ScaleWidth

Pic.Line (0, 0)-(sw - 1, sh), RGB(255, 255, 255), BF
If (val > 55) Then
    Pic.Line (0, sh - (sh * val / 100))-(sw - 1, sh - (sh * 55 / 100)), RGB(255, 0, 0), BF
    Pic.Line (0, sh)-(sw - 1, sh - (sh * 55 / 100)), RGB(0, 128, 0), BF
Else
    Pic.Line (0, sh - (sh * val / 100))-(sw - 1, sh), RGB(0, 128, 0), BF
End If

End Sub

Sub ScrollImg(Pic As Object)
      
      hDestDC = Pic.hDC
      hSrcDC = Pic.hDC
      nWidth = Pic.ScaleWidth
      nHeight = Pic.ScaleHeight
      
      picSrcX = 0
      picSrcY = 0
      
      picDestX = -1
      picDestY = 0
      
      ' 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
    
    Function StrToDeg(ByVal curstr As String) As Double
    
        Dim curlat As Double
        Dim pe As Integer
        Dim deg As String, minz As String

        pe = InStr(curstr, ".")
        deg = Mid(curstr, 1, pe - 3)
        minz = Mid(curstr, pe - 2, Len(curstr) - (pe - 2))
        curlat = deg + (minz / 60)

        '  curlat = curstr / 100
        StrToDeg = curlat
    End Function