frmupdate.frm

VB写的通过串口与考勤机连接通讯的程序

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form frmUpDate 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "数据更新"
   ClientHeight    =   1980
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   4605
   ControlBox      =   0   'False
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MDIChild        =   -1  'True
   MinButton       =   0   'False
   ScaleHeight     =   1980
   ScaleWidth      =   4605
   ShowInTaskbar   =   0   'False
   Begin VB.Frame Frame1 
      Height          =   1815
      Left            =   120
      TabIndex        =   0
      Top             =   120
      Width           =   4335
      Begin VB.CommandButton Command1 
         Caption         =   "Command1"
         Height          =   375
         Left            =   2760
         TabIndex        =   3
         Top             =   600
         Width           =   1095
      End
      Begin MSComctlLib.ProgressBar ProgressBar1 
         Height          =   375
         Left            =   480
         TabIndex        =   1
         Top             =   1080
         Width           =   3255
         _ExtentX        =   5741
         _ExtentY        =   661
         _Version        =   393216
         Appearance      =   1
      End
      Begin VB.Label Label1 
         AutoSize        =   -1  'True
         Caption         =   "请您稍等，系统正在更新数据"
         BeginProperty Font 
            Name            =   "宋体"
            Size            =   12
            Charset         =   134
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H8000000D&
         Height          =   240
         Left            =   480
         TabIndex        =   2
         Top             =   360
         Width           =   3120
      End
   End
End
Attribute VB_Name = "frmUpDate"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim cCard, cSecond, cDay, cMonth, cMin, cType, cHour As String

Private Sub Command1_Click()
Unload Me
End Sub

Private Sub Form_Load()
On Error GoTo Errmsg
Dim sFile, NextLine, Txtformat As String
 'Dim CRLF As String
Dim Fhandle As Integer
Dim cUpHour, cUpMin, cDownHour, cDownMin As String
Set adoRs = adoCon.Execute("select KaoQinID from KaoQin")
If adoRs.EOF Then
   cID = 1
Else
   'adoRs.MoveLast
   'cID = adoRs(KaoQinID)
End If
sFile = "c:\DG.txt"
Fhandle = FreeFile
Txtformat = ""
  ' CRLF = Chr$(13) + Chr$(10)
Open sFile For Input As Fhandle
Set adoRs = adoCon.Execute("select * from Time where Type='Nom'")
cUpHour = adoRs!UpHour

cUpMin = adoRs!UpMin

cDownHour = adoRs!DownHour
cDownMin = adoRs!DownMin
Dim i As Integer
i = 1
Do Until EOF(Fhandle)
   cType = "0"
   Line Input #Fhandle, NextLine
   NextLine = Trim(NextLine)
   If NextLine = "" Then
      Exit Sub
   End If
   Txtformat = Txtformat + NextLine + Chr$(13) + Chr$(10)
   cCard = Mid(NextLine, 2, 4)
   cMonth = Mid(NextLine, 7, 1)
   
   cDay = Mid(NextLine, 8, 2)
   cHour = Mid(NextLine, 10, 2)
   cMin = Mid(NextLine, 12, 2)
   cSecond = Mid(NextLine, 14, 2)
   If Not IsNumeric(cMonth) Then
      cMonth = UCase(cMonth)
      Select Case cMonth
      
      Case "A"
         cMonth = "10"
      Case "B"
         cMonth = "11"
      Case "C"
         cMonth = "12"
      End Select
    End If
'上下午判断
    If cHour <= 12 Then
       '上午时间
       Set adoRs = adoCon.Execute("select count(*) from KaoQin where CardID='" & cCard & "'and Day='" & cDay & "'")
       '当天是否有此人第一条记录
       If adoRs(0) = 0 Then
          '如果没有，判断是否迟到
          If (cHour > cUpHour) Or (cHour = cUpHour And cMin > cUpMin) Then
             cType = "1"
          End If
          adoCon.Execute ("insert into KaoQin values ('" & cCard & "','" & cMonth & "','" & cDay & "','" & cHour & "','" & cMin & "','" & cSecond & "','" & cType & "')")
       End If
    Else
    '下午时间
    '是否早退
       If (cHour < cDownHour) Or (cHour = cDownHour And cMin < cDownMin) Then
    '迟到
          cType = 2
       Else
          '判断是否加班
          'if     then
              '是
              'cType = 3
       ' End If
       '是否有两条记录
        End If
        Set adoRs = adoCon.Execute("select count(CardID) from KaoQin where CardID='" & cCard & "'and Day='" & cDay & "'")
         If adoRs(0) > 1 Then
            Set adoRs = adoCon.Execute("select * from KaoQin where CardID='" & cCard & "'and Day='" & cDay & "'")
            'adoRs.Open "select * from KaoQin where CardID='" & cCard & "'and Day='" & cDay & "'", , adOpenDynamic, adLockBatchOptimistic
            'adoRs.MoveLast
           ' adoRs.MaxRecords
             adoRs.MoveNext
            adoCon.Execute ("update KaoQin set CardID='" & cCard & "',Month='" & cMonth & "',Day='" & cDay & "',Hour='" & cHour & "',Minute='" & cMin & "',Second='" & cSecond & "',Type='" & cType & "' where KaoQinID=" & adoRs!KaoQinID & "")
          Else
             adoCon.Execute ("insert into KaoQin values ('" & cCard & "','" & cMonth & "','" & cDay & "','" & cHour & "','" & cMin & "','" & cSecond & "','" & cType & "')")
          End If
       
    End If













i = i + 1
Loop
Close Fhandle
'Clear the DG.Txt
Open sFile For Output As Fhandle
Print #Fhandle, ""
Close Fhandle
'Back Date to DG1.txt
sFile = "c:\DG1.txt"
'Fhandle = FreeFile
Open sFile For Output As Fhandle
Print #Fhandle, Trim(Txtformat)
Close Fhandle
On Error GoTo Errmsg
Me.Move (Screen.Width - Me.Width) / 2, (Screen.Height - Me.Height) / 2 - 1000
cType = 0

Errmsg:
   If Err.Number <> 0 Then
      MsgBox CStr(Err.Number) + Err.Description, vbOKOnly + vbDefaultButton1, "错误提示"
      Exit Sub
    End If
End Sub