frmserice.frm

智能门锁的程序,用于控制门锁发卡程序,是科布尔的

VERSION 5.00
Begin VB.Form FrmService 
   Caption         =   "系统升迁"
   ClientHeight    =   1410
   ClientLeft      =   2565
   ClientTop       =   2895
   ClientWidth     =   6150
   LinkTopic       =   "Form1"
   ScaleHeight     =   1410
   ScaleWidth      =   6150
   Begin VB.PictureBox PicMSG 
      BackColor       =   &H00C0C0C0&
      BorderStyle     =   0  'None
      ForeColor       =   &H000000FF&
      Height          =   375
      Left            =   240
      ScaleHeight     =   375
      ScaleWidth      =   2175
      TabIndex        =   3
      Top             =   960
      Width           =   2172
   End
   Begin VB.CommandButton CmdAccept 
      Caption         =   "确认"
      Default         =   -1  'True
      Enabled         =   0   'False
      Height          =   375
      Left            =   4920
      TabIndex        =   1
      Top             =   120
      Width           =   1095
   End
   Begin VB.CommandButton CmdCancel 
      Cancel          =   -1  'True
      Caption         =   "取消"
      Height          =   375
      Left            =   4920
      TabIndex        =   2
      Top             =   720
      Width           =   1095
   End
   Begin VB.TextBox TxtUpCode 
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   12
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Left            =   120
      MaxLength       =   36
      TabIndex        =   0
      Top             =   360
      Width           =   4575
   End
End
Attribute VB_Name = "FrmService"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'madaybmddbdbmbybdama
'a cur date
'b update
Private Sub CmdAccept_Click()
Dim UpCode_Array(17) As Integer
Dim dTmp As Date
Dim CurDate, UpDate, Today, OldUpdate As String

Dim sTmp As String
On Error GoTo ErrHand:
    For i = 0 To 17
       UpCode_Array(i) = (Val("&h" & Mid$(TxtUpCode, i * 2 + 1, 2)))
    Next
    
    '取当天
    sTmp = Year(Date) & "-" & (Abs(UpCode_Array(9) - UpCode_Array(0))) & "-" & (Abs(UpCode_Array(8) - UpCode_Array(1)))
    If IsDate(sTmp) Then
       CurDate = sTmp
      Else
       GoTo ErrHand:
    End If
    
    '升迁日期
    sTmp = (Abs(UpCode_Array(7) - UpCode_Array(2))) & "-" & (Abs(UpCode_Array(6) - UpCode_Array(3))) & "-" & (Abs(UpCode_Array(5) - UpCode_Array(4)))
    dTmp = Format(sTmp, "yyyy-mm-dd")
    sTmp = Year(dTmp) & "-" & Month(dTmp) & "-" & Day(dTmp)
    If IsDate(sTmp) Then
       UpDate = sTmp
      Else
       GoTo ErrHand:
    End If
    
    '取发卡机编号
    sRegisterNo = "" & Hex(Abs(UpCode_Array(17) - UpCode_Array(10))) & Hex(Abs(UpCode_Array(16) - UpCode_Array(11))) & Hex(Abs(UpCode_Array(15) - UpCode_Array(12))) & Hex(Abs(UpCode_Array(14) - UpCode_Array(13)))
    sRegisterNo1 = Mid(gRegisterNo, 3, 2) & Mid(gRegisterNo, 7, 2)
    
    Today = Year(Date) & "-" & Month(Date) & "-" & Day(Date)
    '上次升迁时间，控制那天升迁只能用一次
    OldUpdate = gSecrecyData.ValidOldYear & "-" & gSecrecyData.ValidOldMonth & "-" & gSecrecyData.ValidOldDay
    If Not IsDate(OldUpdate) Then
       OldUpdate = Date - 1
    End If
        
        
  '  If (CurDate = Today) And (OldUpdate <> Today) And (sRegisterNo = sRegisterNo1) Then
    If (CurDate = Today) And (sRegisterNo = sRegisterNo1) Then
       gSecrecyData.ValidOldYear = Year(Date)
       gSecrecyData.ValidOldMonth = Month(Date)
       gSecrecyData.ValidOldDay = Day(Date)
       gSecrecyData.ValidYear = Year(UpDate)
       gSecrecyData.ValidMonth = Month(UpDate)
       gSecrecyData.ValidDay = Day(UpDate)
       gUserValidDate = UpDate
       Call WriteSecrecyData
       sTmp = "升迁成功！"
       Else
       sTmp = "升迁失败！"
    End If
    PicMSG.Cls
    PicMSG.Print sTmp
    Exit Sub
ErrHand:
    sTmp = "升迁失败！"
    PicMSG.Cls
    PicMSG.Print sTmp
End Sub
Private Sub CmdCancel_Click()
    Unload Me
End Sub
Private Sub TxtUpCode_Change()
   If Len(TxtUpCode.Text) >= 16 Then
      CmdAccept.Enabled = True
      Else
      CmdAccept.Enabled = False
   End If
End Sub