checktime.frm

GPS校时小程序

VERSION 5.00
Object = "{648A5603-2C6E-101B-82B6-000000000014}#1.1#0"; "Mscomm32.ocx"
Begin VB.Form Form1 
   AutoRedraw      =   -1  'True
   Caption         =   "校对时间"
   ClientHeight    =   1500
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   4095
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   1500
   ScaleWidth      =   4095
   StartUpPosition =   3  '窗口缺省
   Begin VB.CommandButton Command1 
      Caption         =   "校时"
      Height          =   855
      Left            =   3720
      TabIndex        =   4
      Top             =   360
      Width           =   375
   End
   Begin VB.Timer Timer2 
      Interval        =   60000
      Left            =   3960
      Top             =   960
   End
   Begin VB.TextBox Text1 
      Height          =   270
      Left            =   4080
      MultiLine       =   -1  'True
      ScrollBars      =   3  'Both
      TabIndex        =   0
      Text            =   "CheckTime.frx":0000
      Top             =   1440
      Visible         =   0   'False
      Width           =   375
   End
   Begin VB.Timer Timer1 
      Interval        =   500
      Left            =   3840
      Top             =   2520
   End
   Begin MSCommLib.MSComm MSComm1 
      Left            =   3120
      Top             =   2280
      _ExtentX        =   1005
      _ExtentY        =   1005
      _Version        =   393216
      DTREnable       =   -1  'True
   End
   Begin VB.Label Label2 
      BorderStyle     =   1  'Fixed Single
      BeginProperty Font 
         Name            =   "黑体"
         Size            =   14.25
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H0000FF00&
      Height          =   615
      Index           =   1
      Left            =   1920
      TabIndex        =   3
      Top             =   240
      Width           =   1695
   End
   Begin VB.Label Label2 
      BorderStyle     =   1  'Fixed Single
      BeginProperty Font 
         Name            =   "黑体"
         Size            =   14.25
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H0000FF00&
      Height          =   615
      Index           =   0
      Left            =   0
      TabIndex        =   2
      Top             =   240
      Width           =   1815
   End
   Begin VB.Label Label1 
      BackStyle       =   0  'Transparent
      BorderStyle     =   1  'Fixed Single
      BeginProperty Font 
         Name            =   "黑体"
         Size            =   10.5
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00008000&
      Height          =   375
      Left            =   0
      TabIndex        =   1
      Top             =   960
      Width           =   3615
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim BUF As String, CheckDate As String, CheckTime As String
Dim Comm As Integer, AutoCheck As Integer
Dim CommStatus As Boolean

   Const EM_GETLINECOUNT = "&HBA"
   Const EM_GETLINE = &HC4
   Const EM_LINELENGTH = &HC1
   Const EM_LINEINDEX = &HBB

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Sub RtlMoveMemory Lib "kernel32" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)

Private Sub Command1_Click()
   If CommStatus = False Then
     Call CheckDateTime
     AutoCheck = 0
   End If
End Sub

Private Sub Form_Load()
 Dim LineString As String
    If App.PrevInstance Then
       MsgBox ("程序已经运行！！！"), vbExclamation
       Unload Me
       Exit Sub
    End If
    
     If MSComm1.PortOpen = True Then MSComm1.PortOpen = False
   Open App.Path & "\config.ini" For Binary As #1
     Text1.Text = Input(LOF(1), 1)
   Close #1
   
   Call TB_GetLine(Text1.hwnd, 1, LineString)

   If Left(LineString, 8) = "ComPort=" Then
       If Len(LineString) > 8 Then MSComm1.CommPort = CLng(Mid(LineString, 9))
   End If
   
   Call TB_GetLine(Text1.hwnd, 2, LineString)

   If Left(LineString, 11) = "ComSetting=" Then
       If Len(LineString) > 11 Then MSComm1.Settings = Mid(LineString, 12)
   End If
   
   Label1.Caption = "GPS 端口号= " & MSComm1.CommPort & "  参数：" & MSComm1.Settings
    Comm = 0
    AutoCheck = 0
    MSComm1.InputMode = comInputModeBinary
    MSComm1.RThreshold = 1
    MSComm1.RThreshold = 1
    MSComm1.PortOpen = True
End Sub





Private Sub MSComm1_OnComm()

    Select Case MSComm1.CommEvent
        Case comEventBreak '收到中断讯号
        Case comEventCDTO '
        Case comEventCTSTO
        Case comEventDSRTO
        Case comEventFrame
        Case comEventOverrun '数据遗失
        Case comEventRxOver '接收缓冲区漫溢
        Case comEventRxParity '极性错误
        Case comEventTxFull '传送缓冲区漫溢
        Case comEventDCB '未预期错误
        Case comEvCD
        Case comEvCTS
        Case comEvDSR
        Case comEvRing
        Case comEvReceive '收到字符
            Dim InByte() As Byte
            Dim i As Integer, m As Integer, n As Integer
            Dim k As Double
            Dim TempString As String, TempDate As String, TempTime As String
            
            
            TempString = ""
            TempDate = ""
            TempTime = ""
            CheckDate = ""
            CheckTime = ""
            Comm = 0
            
            m = MSComm1.InBufferCount
            InByte = MSComm1.Input
            For i = LBound(InByte) To UBound(InByte)
                k = Len(CStr(Hex(InByte(i)))) / 2
                If k <> Int(k) Then TempString = "0" & CStr(Hex(InByte(i)))
                If k = Int(k) Then TempString = CStr(Hex(InByte(i)))
                
                BUF = BUF & Trim(TempString)
              If Right(BUF, 4) = "0D0A" Then
                If Left(BUF, 8) = "424A542C" Then
                  For n = 0 To 10 Step 2
                  TempDate = TempDate & Chr("&H" & Mid(BUF, 9 + n, 2))
                  TempTime = TempTime & Chr("&H" & Mid(BUF, 23 + n, 2))
                  Next n
              
                CommStatus = False
                
                CheckDate = "20" & Left(TempDate, 2) & "-" & Mid(TempDate, 3, 2) & "-" & Right(TempDate, 2)
                CheckTime = Left(TempTime, 2) & ":" & Mid(TempTime, 3, 2) & ":" & Right(TempTime, 2)
                
                Label2(0).Caption = CheckDate
                Label2(1).Caption = CheckTime
                End If
                BUF = ""
              End If
            Next
         If (CommStatus = False And AutoCheck > 10) Then
          Call CheckDateTime
          AutoCheck = 0
         End If
          
        Case comEvSend
        Case comEvEOF
    End Select
    End Sub


Private Sub TB_GetLine(ByVal hwnd As Long, ByVal whichLine As Long, Line As String)
Dim length As Long, bArr() As Byte, bArr2() As Byte, lc As Long
lc = SendMessage(hwnd, EM_LINEINDEX, whichLine, ByVal 0&)
length = SendMessage(hwnd, EM_LINELENGTH, lc, ByVal 0&)
If length > 0 Then
ReDim bArr(length + 1) As Byte, bArr2(length - 1) As Byte
Call RtlMoveMemory(bArr(0), length, 2)
Call SendMessage(hwnd, EM_GETLINE, whichLine, bArr(0))
Call RtlMoveMemory(bArr2(0), bArr(0), length)
Line = StrConv(bArr2, vbUnicode)
Else
Line = ""
End If
End Sub

Private Sub CheckDateTime()
If (CheckDate <> "" And CheckTime <> "") Then
  Date = CheckDate
  Time = CheckTime
End If
  
End Sub

Private Sub Timer2_Timer()
 If AutoCheck < 20 Then AutoCheck = AutoCheck + 1
End Sub

Private Sub Timer1_Timer()
 If Comm < 50 Then Comm = Comm + 1
 If Comm > 6 Then
    CommStatus = True
    CheckDate = ""
    CheckTime = ""
    Label2(0).Caption = "通讯不成功！"
    Label2(1).Caption = "检查GPS！"
 End If
End Sub