utc.bas

使用串口获取标准GPS卫星时间的VB代码 1 获取GPS时间字串 2 演算UTC和当地时间差 3 纠正系统时间和卫星时间差 注:误差精度在5秒内(和计算机时钟以及GPS信号干扰有关)

Attribute VB_Name = "UTC"
'UTC和当地时间转换
'UTCtoLocal(..) UTC到当地时间
'LocalToUTC(..) 当地时间到UTC.


Option Explicit

Public sDate As Date

' System time structure
Public Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type

' Time zone information. Note that this one is defined wrong in API viewer.
Private Type TIME_ZONE_INFORMATION
Bias As Long
StandardName(0 To 31) As Integer
StandardDate As SYSTEMTIME
StandardBias As Long
DaylightName(0 To 31) As Integer
DaylightDate As SYSTEMTIME
DaylightBias As Long
End Type

Private Declare Sub GetSystemTime Lib "kernel32" (lpSystemTime As SYSTEMTIME)
Private Declare Sub GetLocalTime Lib "kernel32" (lpSystemTime As SYSTEMTIME)

Public Declare Function SetLocalTime Lib "kernel32" (lpSystemTime As SYSTEMTIME) As Long


Private Declare Function SystemTimeToTzSpecificLocalTime Lib "kernel32" (lpTimeZoneInformation As TIME_ZONE_INFORMATION, lpUniversalTime As SYSTEMTIME, lpLocalTime As SYSTEMTIME) As Long
Private Declare Function GetTimeZoneInformation Lib "kernel32" (lpTimeZoneInformation As TIME_ZONE_INFORMATION) As Long

' Return current time as UTC
Public Function UTCTime() As Date
Dim t As SYSTEMTIME

GetSystemTime t
UTCTime = DateSerial(t.wYear, t.wMonth, t.wDay) + TimeSerial(t.wHour, t.wMinute, t.wSecond) + t.wMilliseconds / 86400000#
End Function

' Return current time as local time
Public Function LocalTime() As Date
Dim t As SYSTEMTIME

GetLocalTime t
LocalTime = DateSerial(t.wYear, t.wMonth, t.wDay) + TimeSerial(t.wHour, t.wMinute, t.wSecond) + t.wMilliseconds / 86400000
End Function

' Convert UTC time to local time for current time zone
Public Function UTCtoLocal(ByVal tdate As Date) As Date
Dim tzi As TIME_ZONE_INFORMATION
Dim stUTC As SYSTEMTIME
Dim stLocal As SYSTEMTIME
Dim lRes As Long

lRes = GetTimeZoneInformation(tzi)
stUTC.wYear = Year(tdate)
stUTC.wMonth = Month(tdate)
stUTC.wDay = Day(tdate)
stUTC.wHour = Hour(tdate)
stUTC.wMinute = Minute(tdate)
stUTC.wSecond = Second(tdate)
stUTC.wMilliseconds = 0
lRes = SystemTimeToTzSpecificLocalTime(tzi, stUTC, stLocal)
UTCtoLocal = DateSerial(stLocal.wYear, stLocal.wMonth, stLocal.wDay) + TimeSerial(stLocal.wHour, stLocal.wMinute, stLocal.wSecond)
End Function

' Convert Local time to UTC time if possible.
' Note: The function may return 0, 1 or 2 datetime values.
' During switch from Standard to Daylight time, there is (usually) one hour missing
' and there is an invalid time range of one hour. This function returns an empty collection.
' When time changes from Daylight to Standard, there is an ambguity so one local time
' corresponds to two different UTC times. This function then returns a collection with
' two elements.
Public Function LocalToUTC(ByVal tdate As Date) As Collection
Dim tzi As TIME_ZONE_INFORMATION
Dim lRes As Long
Dim col As Collection
Dim tUTC As Date

Set col = New Collection
lRes = GetTimeZoneInformation(tzi)
tUTC = tdate + tzi.Bias / 1440
If tzi.StandardDate.wMonth = 0 Then
' No daylight time -- no problem
col.Add tUTC
Else
' Assume we are fuzzing with +- one daylight bias, which is normally negative.
' So, datetimes will be ordered from earliest to latest in collection.
If Round(UTCtoLocal(tUTC + tzi.DaylightBias / 1440) * 86400) = Round(tdate * 86400) Then
col.Add CDate(tUTC + tzi.DaylightBias / 1440)
End If
If Round(UTCtoLocal(tUTC) * 86400) = Round(tdate * 86400) Then
col.Add tUTC
End If
If Round(UTCtoLocal(tUTC - tzi.DaylightBias / 1440) * 86400) = Round(tdate * 86400) Then
col.Add CDate(tUTC - tzi.DaylightBias / 1440)
End If
End If
Set LocalToUTC = col
End Function

Public Function GetGpsTime() As Date
    
    Dim sTemp As String
    Dim sAr() As String
    Dim sDT() As String
    Dim i As Long
    Dim n As Integer
    Dim t As SYSTEMTIME
    
    
    On Error GoTo ERR
    
    sDate = Now
    frmMain.mscGPS.PortOpen = True
            
    Do While Len(sTemp) < 299
        
        sTemp = sTemp + frmMain.mscGPS.Input
    
    Loop
    
    sAr = Split(sTemp, "$")

    i = UBound(sAr)
            
               
    frmMain.mscGPS.PortOpen = False
    
    For n = i - 1 To 0 Step -1

        If Left(sAr(n), 5) = "GPRMC" Then

            sDT = Split(sAr(n), ",")
            
            'GetGpsTime = sDT(1) & "|" & sDT(9)
            
            Exit For
        
        End If

    Next n
    
    
    With t
        .wDay = CInt(Mid(sDT(9), 1, 2))
        .wMonth = CInt(Mid(sDT(9), 3, 2))
        .wYear = CInt(Mid(sDT(9), 5, 2)) + 2000
        .wHour = CInt(Mid(sDT(1), 1, 2))
        .wMinute = CInt(Mid(sDT(1), 3, 2))
        .wSecond = CInt(Mid(sDT(1), 1, 2))
        .wMilliseconds = 0
        .wDayOfWeek = 0
    End With
    
    GetGpsTime = DateSerial(t.wYear, t.wMonth, t.wDay) + TimeSerial(t.wHour, t.wMinute, t.wSecond) + t.wMilliseconds / 86400000#

ERR:
   

End Function

Public Function SetLTime(ByVal tdate As Date) As Integer
    
    Dim tzi As TIME_ZONE_INFORMATION
    Dim stUTC As SYSTEMTIME
    Dim stLocal As SYSTEMTIME
    Dim lRes As Long

    lRes = GetTimeZoneInformation(tzi)
    
    tdate = DateAdd("s", DateDiff("s", sDate, Now) + 20, tdate)  '时间补正
    
    stUTC.wYear = Year(tdate)
    stUTC.wMonth = Month(tdate)
    stUTC.wDay = Day(tdate)
    stUTC.wHour = Hour(tdate)
    stUTC.wMinute = Minute(tdate)
'    If Second(tdate) < 59 - WT Then '误差系数
'        stUTC.wSecond = Second(tdate) + WT
'    Else
        stUTC.wSecond = Second(tdate)  '- 59 + WT
'    End If
    
    stUTC.wMilliseconds = 0
    
    SetLTime = SetLocalTime(stUTC)

End Function