樱之花

网上找来的代码自己修改之后放到这里的。

参考地址：

http://www.pcppc.cn/kaifa/VBjiaocheng/kaifa_18010.html
http://www.itqoo.com/programme/ASPNET/200609/1489.html
http://topic.csdn.net/t/20060812/21/4945572.html
http://bbs.pdafans.com/viewthread.php?tid=154187

Imports System.Runtime.InteropServices
Public Class Form1
    Private StrInfo As String = ""
    Private StrX As String = ""
    Private StrY As String = ""
    Public Class dcb
        Friend DCBlength As UInt32
        Friend BaudRate As UInt32
        Friend fBinary As UInt32
        Friend fParity As UInt32
        Friend fOutxCtsFlow As UInt32
        Friend fOutxDsrFlow As UInt32
        Friend fDtrControl As UInt32
        Friend fDsrSensitivity As UInt32
        Friend fTXContinueOnXoff As UInt32
        Friend fOutX As UInt32
        Friend fInX As UInt32
        Friend fErrorChar As UInt32
        Friend fNull As UInt32
        Friend fRtsControl As UInt32
        Friend fAbortOnError As UInt32
        Friend fDummy2 As UInt32
        Friend wReserved As UInt32
        Friend XonLim As UInt32
        Friend XoffLim As UInt32
        Friend ByteSize As Byte
        Friend Parity As Byte
        Friend StopBits As Byte
        Friend XonChar As Char
        Friend XoffChar As Char
        Friend ErrorChar As Char
        Friend EofChar As Char
        Friend EvtChar As Char
        Friend wReserved1 As UInt16
    End Class

    <DllImport("coredll.dll")> _
    Private Shared Function CreateFile _
    (ByVal lpFileName As String, _
     ByVal dwDesiredAccess As Integer, _
     ByVal dwShareMode As Integer, _
     ByVal lpSecurityAttributes As Integer, _
     ByVal dwCreationDisposition As Integer, _
     ByVal dwFlagAndAttributes As Integer, _
     ByVal hTemplateFile As Integer) As Integer
    End Function

    <DllImport("coredll.dll")> _
    Private Shared Function GetCommState _
    (ByVal hFile As Integer, _
     ByVal mdcb As dcb) As Integer
    End Function

    <DllImport("coredll.dll")> _
    Private Shared Function SetCommState _
    (ByVal hFile As Integer, _
     ByVal mdcb As dcb) As Integer
    End Function

    <DllImport("coredll.dll")> _
    Private Shared Function ReadFile _
    (ByVal hFile As Integer, _
     ByVal Buffer() As Byte, _
     ByVal nNumberOfBytesToRead As Integer, _
     ByRef lpNumberOfBytesRead As Integer, _
     ByRef lpOverlapped As Integer) As Integer
    End Function

    <DllImport("coredll.dll")> _
    Private Shared Function WriteFile _
    (ByVal hFile As Integer, _
     ByVal Buffer() As Byte, _
     ByVal nNumberOfBytesToWrite As Integer, _
     ByRef lpNumberOfBytesWritten As Integer, _
     ByVal lpOverlapped As Integer) As Boolean
    End Function

    <DllImport("coredll.dll")> _
    Private Shared Function CloseHandle _
    (ByVal hObject As Integer) As Integer
    End Function

    Dim inoutfileHandler As Long
    Dim numReadWrite As Integer
    Dim t1 As System.Threading.Thread
    Dim stopThread As Boolean = False

    Dim pdcb As New dcb

    Public Sub openPort()
        Dim ioPort As Short = 4
        inoutfileHandler = CreateFile("COM" & ioPort & ":", &HC0000000, 0, 0, 3, 0, 0)
        '设置波特率
        GetCommState(inoutfileHandler, pdcb)
        pdcb.BaudRate.Parse("4800")
        SetCommState(inoutfileHandler, pdcb)
        stopThread = False
        t1 = New Threading.Thread(AddressOf receiveLoop)
        t1.Start()
    End Sub

    Public Sub receiveLoop()
        Dim inbuff(300) As Byte
        Dim retCode As Integer = ReadFile _
        (inoutfileHandler, _
         inbuff, _
         inbuff.Length, _
         numReadWrite, _
         0)
        Application.DoEvents()
        While True
            If retCode = 0 Or stopThread Then
                Exit While
            Else
                Dim updateDelegate As New myDelegate(AddressOf displayReceivedMessage)

                updateDelegate.Invoke _
                (byteArrayToString(inbuff))
                ReDim inbuff(300)
                retCode = ReadFile(inoutfileHandler, inbuff, inbuff.Length, numReadWrite, 0)
                Application.DoEvents()
            End If
        End While
    End Sub

    Function byteArrayToString(ByVal b() As Byte) As String
        Dim str As String
        Dim enc As System.Text.ASCIIEncoding
        enc = New System.Text.ASCIIEncoding
        str = enc.GetString(b, 0, b.Length())
        Return str
    End Function

    Public Delegate Sub myDelegate(ByVal str As String)

    Public Sub displayReceivedMessage(ByVal str As String)
        If str.Length > 0 Then
            'MessageBox.Show(str)
            'MessageBox.Show(GetGPS(str, "X") & " " & GetGPS(str, "Y"))
            StrInfo = StrInfo + str
            StrX = GetGPS(str, "X")
            StrY = GetGPS(str, "Y")
            If StrX <> "" And StrX <> "-1" And StrX <> "V" Then
                MessageBox.Show("成功获得数据 经度" & StrX & " 纬度" & StrY)
                stopThread = True
                CloseHandle(inoutfileHandler)
            End If
        End If
    End Sub

    Private Sub MnuOpenPort_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MnuOpenPort.Click
        Call openPort()
    End Sub

    Private Sub MnuShow_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MnuShow.Click
        TxtInfo.Text = StrInfo
        TxtGPS.Text = StrX & " " & StrY
    End Sub

    Private Sub MnuClosePort_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MnuClosePort.Click
        stopThread = True
        CloseHandle(inoutfileHandler)
    End Sub

    Private Function GetGPS(ByVal sGpsStr As String, ByVal sFindStr As String)
        Dim HanderStr As String = "$GPRMC" 'GPS串头
        Dim FindHander As Integer = sGpsStr.IndexOf(HanderStr)
        If FindHander < 0 Then
            Return "-1"
        Else
            sGpsStr = sGpsStr.Substring(FindHander, sGpsStr.Length - FindHander)
            Dim ArryTmp() As String = sGpsStr.Split(",")
            Try
                If ArryTmp(2) = "V" Then
                    Return "V" '信号不好
                Else
                    Select Case sFindStr
                        Case "X"    '返回经度
                            Return DM2DD(ArryTmp(5))
                        Case "Y"    '返回纬度
                            Return DM2DD(ArryTmp(3))
                        Case "T"
                            Return ArryTmp(9) & " " & ArryTmp(1)
                        Case "V"
                            Return Convert.ToString(Convert.ToDouble(ArryTmp(7)) * 1.852)
                    End Select
                End If
            Catch ex As Exception
                Return "V"
            End Try
        End If
    End Function
    Public Function DM2DD(ByVal DegreeMinutes As String) As String
        '转换NMEA协议的“度分”格式为十进制“度度”格式
        Dim sDegree As String
        Dim sMinute As String
        Dim sReturn As String = ""
        If DegreeMinutes.IndexOf(".") = 4 Then
            DegreeMinutes = DegreeMinutes.Replace(".", "")
            Dim sDegree1 As Double = Convert.ToDouble(DegreeMinutes.Substring(0, 2))
            Dim sDegree2 As Double = Convert.ToDouble(DegreeMinutes.Substring(2, DegreeMinutes.Length - 2))
            Dim sTmp As String = Convert.ToString(sDegree2 / 60)
            sDegree2 = Convert.ToDouble(sTmp.Substring(0, sTmp.Length))
            sDegree2 = sDegree2 / 10000
            sDegree = Convert.ToString(sDegree1 + sDegree2)
            If (sDegree.Length > 11) Then
                sDegree = sDegree.Substring(0, 11)
            End If
            sReturn = sDegree
        ElseIf DegreeMinutes.IndexOf(".") = 5 Then
            DegreeMinutes = DegreeMinutes.Replace(".", "")
            Dim sMinute1 As Double = Convert.ToDouble(DegreeMinutes.Substring(0, 3))
            Dim sMinute2 As Double = Convert.ToDouble(DegreeMinutes.Substring(3, DegreeMinutes.Length - 2))
            Dim sTmp As String = Convert.ToString(sMinute2 / 60)
            sMinute2 = Convert.ToDouble(sTmp.Substring(0, sTmp.Length))
            sMinute2 = sMinute2 / 10000
            sMinute = Convert.ToString(sMinute1 + sMinute2)
            If sMinute.Length > 10 Then
                sMinute = sMinute.Substring(0, 10)
                sReturn = sMinute
            End If
        End If
        Return sReturn
    End Function
End Class