frm数据系统验证.frm

FLA-502控制、标定、分析用

         Exit Sub
      End If
      If ret <= 5 And ret > 1 Then
          MsgLab.Caption = "注册提示:你的使用期限还有" & CStr(ret) & "天;到时请与深圳汇银实业联系注册,按[确定]进入系统"
          ValidDate = True
          Exit Sub
      End If
      If ret <= 1 Then
          '用户密码已经到期
          MsgLab.Caption = "你的使用期限已经到期，请将序列号抄下传真到深圳汇银实业公司申请使用权限,在取得许可密码前不要退出此系统,否则需要抄下下次新的序列号，重新申请许可密码 "
          ValidDate = False
      End If
      
      tempNo = seriaNo
      tempNo = GetPruductSeriaNumByLast(seriaNo)
      tempkey = GetKey(tempNo)
      Do
         tempNo = GetPruductSeriaNumByLast(tempNo)
         tempkey = GetKey(tempNo)
         Set rs = Database.取数据("select count(*) counts from cdkeytest where seriano='" & tempNo & "' or cdkey='" & tempkey & "'")
         If rs!counts = 0 Then
            findNext = False
         Else
            findNext = True
         End If
         rs.Close
      Loop While (findNext)
      seriaNo = tempNo
      SeriaNumLab.Caption = " " + GetDisplay(seriaNo)
      Call setVisible
     Exit Sub
ErrHandle:
     MsgBox (Err.Description)
End Sub

Public Function ValidDays() As Boolean
   Set rs = Database.取数据("select count(*)  counts from 日常运行日志 where 检测日期>getdate()")
   If rs!counts > 0 Then
         MsgBox ("你已经修改日期,系统将退出!错误代码2")
         rs.Close
         ValidDays = False
         Exit Function
   End If
   rs.Close
   Set rs = Database.取数据("select count(*)  counts from turnslog where startdate>getdate()")
   If rs!counts > 0 Then
         MsgBox ("你已经修改日期,系统将退出!错误代码3")
         rs.Close
         ValidDays = False
         Exit Function
   End If
   rs.Close
   ValidDays = True
End Function

Public Function ValidDayDiff() As Integer
   Dim days As Integer
   Set rs = Database.取数据("select datediff(dd,registerdate, getdate()) as days from hylimit")
      If IsNull(rs!days()) Then
         days = 30
      Else
         days = rs!days
      End If
   rs.Close
   days = 30 - days
   ValidDayDiff = days
End Function

Private Sub quitCmd_Click()
    Database.Class_Terminate
    End
End Sub

Public Function GetPruductSeriaNum(ByVal diskSeriaNo As Long) As String
   Dim YYYY As Integer
   Dim MM As Integer
   Dim Dd As Integer
   Dim HH As Integer
   Dim Mins As Integer
   Dim ss As Integer
   Dim seriaNo As String
   Dim i As Integer
   Dim sLen As Integer
   Dim tempStr As String
   Dim tempstr1 As String
   Dim chksum As Integer
   YYYY = Year(Date)
   MM = Month(Date)
   Dd = Day(Date)
   HH = Hour(Time)
   Mins = Minute(Time)
   ss = Second(Time)
   diskSeriaNo = diskSeriaNo Xor (545423 * ss) And HH
   YYYY = YYYY Mod 279
   MM = (MM * 911) And 7071
   Dd = (Dd * 3) Xor (871)
   HH = (HH * 61) Or 10245
   Mins = (59 * Mins)    'Mins
   ss = 1791 Xor (ss * 111)
   diskSeriaNo = diskSeriaNo
   
   seriaNo = CStr(YYYY) & CStr(diskSeriaNo) & CStr(MM) & CStr(Dd) & CStr(ss) & CStr(HH) & CStr(Mins)
   sLen = Len(seriaNo)
   tempStr = ""
   For i = 1 To sLen Step 3
     tempStr = tempStr & Mid(seriaNo, i, 1)
   Next
   For i = 1 To sLen Step 3
     tempStr = tempStr & Mid(seriaNo, i + 1, 1)
   Next
   For i = 1 To sLen Step 3
     tempStr = tempStr & Mid(seriaNo, i + 2, 1)
   Next
   
   tempstr1 = ""
   
   For i = 1 To sLen Step 2
   tempstr1 = tempstr1 & Mid(tempStr, i + 1, 1) & Mid(tempStr, i, 1)
   Next
   seriaNo = Mid(tempstr1, 1, 20)
   For i = 1 To 20
        chksum = chksum + Asc(Mid(seriaNo, 1, 1))
        chksum = chksum Mod 1024
   Next
   seriaNo = seriaNo & Format(chksum, "0000")
   GetPruductSeriaNum = seriaNo
End Function

Public Function GetPruductSeriaNumByLast(ByVal LastSeriaNo As String) As String
    Dim YYYY As Integer
    Dim MM As Integer
    Dim Dd As Integer
    Dim HH As Integer
    Dim Mins As Integer
    Dim ss As Integer
    Dim seriaNo As String
    Dim i As Integer
    Dim sLen As Integer
    Dim tempStr As String
    Dim tempstr1 As String
    Dim chksum As Integer
    Dim digitals(24) As Byte
    Dim U, v As Integer
    Dim segments(1 To 6) As Integer
    YYYY = Year(Date)
    MM = Month(Date)
    Dd = Day(Date)
    HH = Hour(Time)
    Mins = Minute(Time)
    ss = Second(Time)
    
    diskSeriaNo = diskSeriaNo Xor (545423 * ss) And HH
    
    YYYY = YYYY Mod 279
    MM = (MM * 901) And 7031
    Dd = (Dd * 3) Xor (871)
    HH = (HH * 61) Or 10215
    Mins = (59 * Mins)
    ss = 1791 Xor (ss * 111)
    
    sLen = Len(LastSeriaNo)
    For i = 1 To sLen
        digitals(i) = CInt(Mid(LastSeriaNo, i, 1))
    Next
    
    For i = 1 To sLen \ 2
        U = digitals(i)
        digitals(i) = digitals(sLen \ 2 + i)
        digitals(sLen \ 2 + i) = U
    Next
    
    For i = 1 To sLen \ 2
        U = digitals(i)
        digitals(i) = digitals(sLen - i + 1)
        digitals(sLen - i + 1) = U
    Next
    
    For i = 0 To 5
        segments(i + 1) = digitals(i * 4 + 1) * 100 + digitals(i * 4 + 2) * 10 + digitals(i * 4 + 3) * 1000 + digitals(i * 4 + 4) * 9
    Next
    U = segments(1)
    segments(1) = segments(5)
    segments(5) = U
    
    U = segments(2)
    segments(2) = segments(6)
    segments(6) = U
    
    U = segments(4)
    segments(4) = segments(3)
    segments(3) = U
    
    segments(1) = (segments(1) And HH Xor (Rnd(3) * 191)) Mod 10000
    segments(2) = (segments(2) Or YYYY Xor (Rnd(5) * 100)) Mod 10000
    segments(3) = (segments(3) Xor Dd Or (Rnd(2) * 133)) Mod 10000
    segments(4) = (segments(4) Xor ss And (Rnd(1) * 100)) Mod 10000
    segments(5) = (segments(5) Or MM Xor (Rnd(6) * 561)) Mod 10000
    segments(6) = (segments(6) And Mins Xor (Rnd(7) * 159)) Mod 10000
    
    'seriaNo = CStr(YYYY) & CStr(diskSeriaNo) & CStr(MM) & CStr(Dd) & CStr(SS) & CStr(HH) & CStr(Mins)
    seriaNo = ""
    For i = 1 To 6
        seriaNo = seriaNo & Format(segments(i), "0000")
    Next
    
    sLen = Len(seriaNo)
    tempStr = ""
    For i = 1 To sLen Step 3
        tempStr = tempStr & Mid(seriaNo, i, 1)
    Next
    For i = 1 To sLen Step 3
        tempStr = tempStr & Mid(seriaNo, i + 1, 1)
    Next
    For i = 1 To sLen Step 3
        tempStr = tempStr & Mid(seriaNo, i + 2, 1)
    Next
    
    tempstr1 = ""
    
    For i = 1 To sLen Step 2
        tempstr1 = tempstr1 & Mid(tempStr, i + 1, 1) & Mid(tempStr, i, 1)
    Next
    seriaNo = Mid(tempstr1, 1, 20)
    For i = 1 To 20
         chksum = chksum + Asc(Mid(seriaNo, 1, 1))
         chksum = chksum Mod 1024
    Next
    seriaNo = seriaNo & Format(chksum, "0000")
    GetPruductSeriaNumByLast = seriaNo
End Function

Public Function GetKey(ByVal seriaNo As String) As String
    Dim i As Integer
    Dim U, v As Integer
    Dim sLen As Integer
    Dim digitals() As Byte
    Dim segments(1 To 6) As Integer
    Dim keystr As String
    sLen = Len(seriaNo)
    ReDim digitals(1 To sLen)
    For i = 1 To sLen
       digitals(i) = CInt(Mid(seriaNo, i, 1))
    Next
    For i = 1 To sLen \ 2
        U = digitals(i)
        digitals(i) = digitals(sLen - i + 1)
        digitals(sLen - i + 1) = U
    Next
    For i = 1 To sLen \ 2
        U = digitals(i)
        digitals(i) = digitals(sLen \ 2 + i)
        digitals(sLen \ 2 + i) = U
    Next
    For i = 0 To 5
        segments(i + 1) = digitals(i * 4 + 1) * 100 + digitals(i * 4 + 2) * 10 + digitals(i * 4 + 3) * 1000 + digitals(i * 4 + 4) * 9
    Next
    segments(1) = (segments(1) Xor segments(3) Xor 8173 Or 1111) Mod 10000
    segments(2) = (segments(2) And segments(3) And 9110 And segments(1)) Mod 10000
    segments(3) = (segments(4) Or segments(3) Xor 5167 Xor segments(6)) Mod 10000
    segments(4) = (segments(4) And segments(3) And 1091 Xor segments(5)) Mod 10000
    segments(5) = (segments(5) Or segments(6) Xor 9818 And segments(1)) Mod 10000
    segments(6) = (segments(6) Or segments(1) Or segments(2) And segments(5)) Mod 10000
    keystr = ""
    For i = 1 To 6
        keystr = keystr & Format(segments(i), "0000")
    Next
    For i = 0 To 5
        'KeyTxt(I).Text = Format(segments(I + 1), "0000")
    Next
    GetKey = keystr
End Function

Public Function GetDisplay(str As String) As String
    Dim i As Integer
    Dim sLen As Integer
    Dim Str1 As String
    sLen = Len(str)
    For i = 1 To sLen Step 4
        Str1 = Str1 & Mid(str, i, 4)
        If i + 3 < sLen Then Str1 = Str1 & "，"
    Next
    GetDisplay = Str1
End Function

Function GetSerialNumber(sRoot As String) As Long
    Dim R, lSerialNum As Long
    Dim strlabel, strType As String
    strlabel = String$(255, Chr$(0))
    strType = String$(255, Chr$(0))
    R = GetVolumeInformation(sRoot, strlabel, Len(strlabel), lSerialNum, 0, 0, strType, Len(strType))
    GetSerialNumber = lSerialNum
End Function

Public Sub setVisible()
    PwdLab.Visible = True
    KeyTxt(0).Visible = True
    KeyTxt(1).Visible = True
    KeyTxt(2).Visible = True
    KeyTxt(3).Visible = True
    KeyTxt(4).Visible = True
    KeyTxt(5).Visible = True
    validCmd.Visible = True
    Line1.Visible = True
    Line2.Visible = True
    Line3.Visible = True
    Line4.Visible = True
    Line5.Visible = True
End Sub

Private Sub validCmd_Click()
    Dim tempinput As String
    Dim keystr As String
    Dim rs As ADODB.Recordset
    Dim x As Long
    Dim i As Integer
    If ValidDate = True Then
        Database.Class_Terminate
        Unload Me
        Set frm数据系统验证 = Nothing
        frm数据第一屏计量环保认证标志.Show
        Exit Sub
    End If
    For i = 0 To 5
        If CheckNum(KeyTxt(i)) = False Then
            nErrorTimes = nErrorTimes + 1
            MsgBox ("密码输入错误!")
            If nErrorTimes > 10 Then
                MsgBox ("你错误的次数大于了10,将退出")
                Database.Class_Terminate
                End
            End If
            Exit Sub
        End If
    Next
    tempinput = KeyTxt(0).Text & KeyTxt(1).Text & KeyTxt(2).Text & KeyTxt(3).Text & KeyTxt(4).Text & KeyTxt(5).Text
    keystr = GetKey(seriaNo)
    '------------------------
    '新增功能:当全部付款后
    '------------------------
    Dim strFirstSubString As String
    Dim strLastSubString As String
    If IsNumeric(KeyTxt(0).Text) = True Then
        strFirstSubString = CSng(KeyTxt(0).Text) + 1
        If Len(strFirstSubString) = 1 Then
            strFirstSubString = "000" + strFirstSubString
        ElseIf Len(strFirstSubString) = 2 Then
            strFirstSubString = "00" + strFirstSubString
        ElseIf Len(strFirstSubString) = 3 Then
            strFirstSubString = "0" + strFirstSubString
        End If
    End If
    If IsNumeric(KeyTxt(5).Text) = True Then
        strLastSubString = CSng(KeyTxt(5).Text) + 1
        If Len(strLastSubString) = 1 Then
            strLastSubString = "000" + strLastSubString
        ElseIf Len(strLastSubString) = 2 Then
            strLastSubString = "00" + strLastSubString
        ElseIf Len(strLastSubString) = 3 Then
            strLastSubString = "0" + strLastSubString
        End If
    End If
    Dim strTemp As String
    strTemp = strFirstSubString & KeyTxt(1).Text & KeyTxt(2).Text & KeyTxt(3).Text & KeyTxt(4).Text & strLastSubString
    If compareString(strTemp, keystr) Then
        Set rs = Database.取数据("select count(*)  counts from 日常运行日志 where 检测日期>getdate()")
        If rs!counts > 0 Then
            MsgLab.Caption = "你已经将日期更改了，请恢复真实的日期!错误代码4。"
            SystemFail.新增计算机时钟被调校故障
            Exit Sub
        End If
        MsgLab.Caption = "你已经通过验证!"
        Database.更新数据库 ("update hylimit set  expiredLevel= expiredLevel+1, registerdate='2001-01-01 12:01:01', desckey='" & keystr & "'")
        Database.更新数据库 ("insert into cdkeytest(seriano,cdkey)values('" & seriaNo & "','" & keystr & "')")
        Database.Class_Terminate
        Unload Me
        Set frm数据系统验证 = Nothing
        frm数据第一屏计量环保认证标志.Show
        Exit Sub
    End If
    '-------------------
    If compareString(tempinput, keystr) Then
        Set rs = Database.取数据("select count(*)  counts from 日常运行日志 where 检测日期>getdate()")
        If rs!counts > 0 Then
            MsgLab.Caption = "你已经将日期更改了，请恢复真实的日期!错误代码4。"
            SystemFail.新增计算机时钟被调校故障
            Exit Sub
        End If
        MsgLab.Caption = "你已经通过验证!"
        Database.更新数据库 ("update hylimit set  expiredLevel= expiredLevel+1, registerdate=getdate(), desckey='" & keystr & "'")
        Database.更新数据库 ("insert into cdkeytest(seriano,cdkey)values('" & seriaNo & "','" & keystr & "')")
        Database.Class_Terminate
        Unload Me
        Set frm数据系统验证 = Nothing
        frm数据第一屏计量环保认证标志.Show
    Else
        retrys = retrys + 1
        MsgLab.Caption = "你没有通过验证!"
        If retrys >= 5 Then
            SeriaNumLab.Caption = ""
            MsgLab.Caption = "你的尝试次数已经超过允许次数，系统将自动关闭!"
            x = ExitWindowsEx(EWX_POWEROFF, dwReserved)
            Call ExitWindowsEx(EWX_SHUTDOWN, 0)
        End If
    End If
End Sub

Private Function compareString(ByVal Str1 As String, ByVal Str2 As String) As Boolean
    Dim i As Integer
    Dim sLen1, sLen2 As String
    sLen1 = Len(Str1)
    sLen2 = Len(Str2)
    If sLen1 <> sLen2 Then
       compareString = False
       Exit Function
    End If
    For i = 1 To sLen2
          If Mid(Str1, i, 1) <> Mid(Str2, i, 1) Then
             compareString = False
             Exit Function
          End If
    Next
    compareString = True
End Function

Public Function CheckNum(s As String) As Boolean
    Dim i As Integer
    Dim sLen As Integer
    sLen = Len(s)
    If sLen <> 4 Then
       CheckNum = False
       Exit Function
    End If
    For i = 1 To sLen
      If IsNumeric(Mid(s, i, 1)) <> True Then
          CheckNum = False
          Exit Function
      End If
    Next
    CheckNum = True
End Function