cdiskinfo.cls

本系统可用于医院和专业体检中心的健康体检管理

End Function

Private Sub ChangeByteOrder(szString() As Byte, ByVal uscStrSize As Integer)
    Dim i As Integer
    Dim bTemp As Byte

    For i = 0 To uscStrSize - 1 Step 2
        bTemp = szString(i)
        szString(i) = szString(i + 1)
        szString(i + 1) = bTemp
    Next i
End Sub

Private Sub DisplayIdInfo(pids As IDSECTOR, pSCIP As SENDCMDINPARAMS, _
    ByVal bIDCmd As Byte, ByVal bDfpDriveMap As Byte, ByVal bDriveNum As Byte)
    '--------------------------------------------------------------------------
    ChangeByteOrder pids.sModelNumber, UBound(pids.sModelNumber) + 1
    ChangeByteOrder pids.sFirmwareRev, UBound(pids.sFirmwareRev) + 1
    ChangeByteOrder pids.sSerialNumber, UBound(pids.sSerialNumber) + 1
End Sub

'调用过程：GetDiskInfo 0    磁盘序列,从 0 开始
Public Function GetDiskInfo(ByVal nDrive As Byte) As Long
    Dim hSMARTIOCTL As Long
    Dim cbBytesReturned As Long
    Dim VersionParams As GETVERSIONOUTPARAMS
    Dim scip As SENDCMDINPARAMS
    Dim scop() As Byte
    Dim OutCmd As SENDCMDOUTPARAMS
    Dim bDfpDriveMap As Byte
    Dim bIDCmd As Byte
    Dim uDisk As IDSECTOR

    m_DiskInfo = uDisk
    
    hSMARTIOCTL = OpenSMART(nDrive)
    If hSMARTIOCTL <> INVALID_HANDLE_VALUE Then
        Call DeviceIoControl(hSMARTIOCTL, DFP_GET_VERSION, ByVal 0, 0, _
            VersionParams, Len(VersionParams), cbBytesReturned, 0)

        If Not (VersionParams.bIDEDeviceMap \ 2 ^ nDrive And &H10) Then
            If DoEnableSMART(hSMARTIOCTL, scip, OutCmd, nDrive, cbBytesReturned) Then
                bDfpDriveMap = bDfpDriveMap Or 2 ^ nDrive
            End If
        End If
        bIDCmd = IIf((VersionParams.bIDEDeviceMap \ 2 ^ nDrive And &H10), _
            IDE_ATAPI_ID, IDE_ID_FUNCTION)

        ReDim scop(LenB(OutCmd) + IDENTIFY_BUFFER_SIZE - 1) As Byte
        If DoIDENTIFY(hSMARTIOCTL, scip, scop, bIDCmd, nDrive, cbBytesReturned) Then
            CopyMemory m_DiskInfo, scop(LenB(OutCmd) - 4), LenB(m_DiskInfo)
            Call DisplayIdInfo(m_DiskInfo, scip, bIDCmd, bDfpDriveMap, nDrive)
            CloseHandle hSMARTIOCTL
            GetDiskInfo = 1
            Exit Function
        End If
        CloseHandle hSMARTIOCTL
        GetDiskInfo = 0
      Else
        GetDiskInfo = -1
    End If
End Function

'获取加密的字符串
Private Function EncryptString(ByVal strData As String) As String
    Dim strReturn As String
    Dim arrCircle(35) As String
    Dim lngDepth As Long
    Dim lngLength As Long
    Dim i As Integer
    Dim j As Integer
    
    arrCircle(0) = "P":  arrCircle(1) = "L":  arrCircle(2) = "3"
    arrCircle(3) = "7":  arrCircle(4) = "K":  arrCircle(5) = "N"
    arrCircle(6) = "5":  arrCircle(7) = "J":  arrCircle(8) = "I"
    arrCircle(9) = "9":  arrCircle(10) = "4": arrCircle(11) = "V"
    arrCircle(12) = "C": arrCircle(13) = "6": arrCircle(14) = "G"
    arrCircle(15) = "8": arrCircle(16) = "X": arrCircle(17) = "F"
    arrCircle(18) = "D": arrCircle(19) = "Z": arrCircle(20) = "0"
    arrCircle(21) = "1": arrCircle(22) = "A": arrCircle(23) = "S"
    arrCircle(24) = "Q": arrCircle(25) = "9": arrCircle(26) = "W"
    
    arrCircle(27) = "2": arrCircle(28) = "R": arrCircle(29) = "M"
    arrCircle(30) = "U": arrCircle(31) = "B": arrCircle(32) = "Y"
    arrCircle(33) = "O": arrCircle(34) = "T": arrCircle(35) = "E"
    
    lngLength = Len(strData)
    For i = 1 To lngLength
        lngDepth = 0
        For j = i To lngLength
            lngDepth = lngDepth + Abs(Asc(Mid(strData, j, 1)))
            If i > 1 Then
                lngDepth = lngDepth + Abs(Asc(Mid(strData, i - 1, 1)))
            End If
            If i > 2 Then
                lngDepth = lngDepth + Abs(Asc(Mid(strData, i - 2, 1)))
            End If
        Next
        lngDepth = lngDepth * Abs(Asc(Mid(strData, i, 1)))
        lngDepth = lngDepth Mod 36
        
        strReturn = strReturn & arrCircle(lngDepth)
    Next
    
    EncryptString = strReturn
End Function

'获取定长的注册码（25位）
'返回格式：*****-*****-*****-*****-*****
Public Function GetFixedSerialNumber(ByVal incomeStr As String, ByVal CodeLen As Integer) As String
    Dim i As Integer, j As Integer, K As Integer
    Dim strReturn As String
    Dim strEncrypted As String
    Dim strTemp As String
    Dim strZJM As String
    
    If incomeStr = "" Then
        '**********************20040416封闭 闻***************************
'        strEncrypted = EncryptString(Trim(StrConv(m_DiskInfo.sSerialNumber, vbUnicode)))
        '**********************20040416封闭 闻***************************
        
        '**********************20040416加入 闻*****************************
        '如果机器码前有“wd-”则将其去掉
''        strZJM = strDelHead(Trim(StrConv(m_DiskInfo.sSerialNumber, vbUnicode)), "WD-")
    If GetINI(gstrCurrPath & "Config\DSN\odbc.ini", "ServerReg", "SCSIREG", "?") = True Then
        Dim Driver, VolName, Fsys As String
        Dim volNumber, MCM, FSF As Long
        Driver = "c:\"
        Dim res As Long
        res = GetVolumeInformation(Driver, VolName, 127, volNumber, MCM, FSF, Fsys, 127)
        strZJM = Abs(volNumber)
    Else
        strZJM = strDelSpecial(Trim(StrConv(m_DiskInfo.sSerialNumber, vbUnicode)))
    End If
'        MsgBox "主机码:" & vbCrLf & "***" & strZJM & "***"
        strEncrypted = EncryptString(strZJM)
        '**********************20040416加入完 闻***************************
    ElseIf incomeStr = "IP" Then
        strEncrypted = EncryptString(Trim(GetLocalMac()))
    Else
        strEncrypted = EncryptString(incomeStr)
    End If
    i = 1
    Do While Len(strReturn) < CodeLen
        Select Case i
            Case 1
                For j = Len(strEncrypted) To 1 Step -1
                    strReturn = strReturn & Mid(strEncrypted, j, 1)
                Next j
            Case 2
                K = Len(strEncrypted) \ 3
                For j = 2 * K To K + 1 Step -1
                    strReturn = strReturn & Mid(strEncrypted, j, 1)
                Next j
                For j = 2 * K + 1 To Len(strEncrypted)
                    strReturn = strReturn & Mid(strEncrypted, j, 1)
                Next j
                For j = K To 1 Step -1
                    strReturn = strReturn & Mid(strEncrypted, j, 1)
                Next j
            Case 3
                K = Len(strEncrypted) \ 3
                For j = 2 * K + 1 To Len(strEncrypted)
                    strReturn = strReturn & Mid(strEncrypted, j, 1)
                Next j
                For j = K To 1 Step -1
                    strReturn = strReturn & Mid(strEncrypted, j, 1)
                Next j
                For j = K + 1 To 2 * K
                    strReturn = strReturn & Mid(strEncrypted, j, 1)
                Next j
            Case Else
                K = Len(strEncrypted) \ 2
                For j = K To 1 Step -1
                    strReturn = strReturn & Mid(strEncrypted, j, 1)
                Next j
                For j = K + 1 To Len(strEncrypted)
                    strReturn = strReturn & Mid(strEncrypted, j, 1)
                Next j
        End Select
        i = i + 1
        strEncrypted = EncryptString(strEncrypted)
        If Len(strEncrypted) < 2 Then
            '**********************20040416封闭 闻*****************************
'            strEncrypted = EncryptString(Trim(StrConv(m_DiskInfo.sSerialNumber, vbUnicode)))
            '**********************20040416封闭完 闻*****************************
            '**********************20040416加入 闻*****************************
            '如果机器码前有“wd-”则将其去掉
'            strZJM = strDelHead(Trim(StrConv(m_DiskInfo.sSerialNumber, vbUnicode)), "WD-")
            strZJM = Trim(StrConv(m_DiskInfo.sSerialNumber, vbUnicode))
            strEncrypted = EncryptString(strZJM)
            '**********************20040416加入完 闻***************************

        End If
    Loop
    
    '将strReturn顺序颠倒
    For i = Len(strReturn) To 1 Step -1
        strTemp = strTemp & Mid(strReturn, i, 1)
    Next
    strReturn = strTemp
    
    strReturn = Left(strReturn, CodeLen)
    strReturn = EncryptString(strReturn)
    If CodeLen = 25 Then
        GetFixedSerialNumber = Mid(strReturn, 1, 5) & "-" & Mid(strReturn, 6, 5) & "-" _
              & Mid(strReturn, 11, 5) & "-" & Mid(strReturn, 16, 5) & "-" & Mid(strReturn, 21, 5)
    Else
        GetFixedSerialNumber = strReturn
    End If
End Function

'试用时，获取已试用时间
Public Property Get ProbationDays() As Integer
    Dim strSysDir As String
    Dim strRegFileName As String
    Dim f As Integer
    Dim intNum As Integer
    Dim strValue As String
    
    strSysDir = Space$(256)
    GetSystemDirectory strSysDir, 255
    strSysDir = Left(strSysDir, InStr(1, strSysDir, Chr(0)) - 1)
    
    strRegFileName = strSysDir & "\" & RegFile
    f = FreeFile
    If Dir(strRegFileName) = "" Then
        '文件不存在的情况，意味着第一次运行
        Open strRegFileName For Output As #f
        Print #f, "[MicroTelnet]"
        Print #f, "Num=1"
        Close #f
        
        intNum = 1
    Else
        '获取使用次数
        strValue = GetINI(strRegFileName, "MicroTelnet", "Num", "?")
        '被非法修改的情况
        If strValue = "?" Then GoTo NoRegister

        '判断使用次数
        intNum = Int(Val(strValue))
        If intNum < 1 Then GoTo NoRegister
        If intNum > 30 Then GoTo NoRegister

        '重新写入使用次数，在原来的基础上加1
        intNum = intNum + 1
        Call WriteINI(strRegFileName, "MicroTelnet", "Num", str(intNum))
    End If
    ProbationDays = intNum
    Exit Function
    
NoRegister:
    ProbationDays = 31
End Property

'删除次数文件
Public Function KillRegFile()
    Dim strSysDir As String
    Dim strRegFileName As String
    
    strSysDir = Space$(256)
    GetSystemDirectory strSysDir, 255
    strSysDir = Left(strSysDir, InStr(1, strSysDir, Chr(0)) - 1)
    
    strRegFileName = strSysDir & "\" & RegFile
    If Dir(strRegFileName) <> "" Then Kill strRegFileName
End Function

'硬盘序列号
Public Property Get pSerialNumber() As String
   If GetINI(gstrCurrPath & "Config\DSN\odbc.ini", "ServerReg", "SCSIREG", "?") = True Then
        Dim Driver, VolName, Fsys As String
        Dim volNumber, MCM, FSF As Long
        Driver = "c:\"
        Dim res As Long
        res = GetVolumeInformation(Driver, VolName, 127, volNumber, MCM, FSF, Fsys, 127)
        pSerialNumber = Abs(volNumber)
   Else
        pSerialNumber = Trim(StrConv(m_DiskInfo.sSerialNumber, vbUnicode))
   End If
End Property

'硬盘生产厂/型号
Public Property Get pModelNumber() As String
    pModelNumber = Trim(StrConv(m_DiskInfo.sModelNumber, vbUnicode))
End Property