www.pudn.com > GPSCheckTime.rar > CheckTime.frm
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