moddog.bas

VB6.0编写的医院影像系统

Attribute VB_Name = "modDog"

Option Explicit

DefLng A-Z

Type APIPACKET
 Data(4096) As Byte
End Type

Type DATAQUERY
 Data(16) As Byte
End Type

Public Const MSG_DOG_INITIALIZE_ERROR = "软件狗初始化错误,请检查软件狗是否已安装好!" & vbCrLf & "选择'确认'以退出本程序。" & vbCrLf & vbCrLf & "请使用正版软件!"
Public Const MSG_DOG_ERROR = "软件狗校验错误,请检查软件狗是否已安装好!" & vbCrLf & "选择'确认'以退出本程序。" & vbCrLf & vbCrLf & "请使用正版软件!"
Public Const MSG_ERR_HAPPEN = "加密狗"

Declare Function RNBOsproFormatPacket% Lib "sx32w.dll" (ApiPack As APIPACKET, ByVal ApiPackSize As Integer)
Declare Function RNBOsproInitialize% Lib "sx32w.dll" (ApiPack As APIPACKET)
Declare Function RNBOsproGetFullStatus% Lib "sx32w.dll" (ApiPack As APIPACKET)
Declare Function RNBOsproGetVersion% Lib "sx32w.dll" (ApiPack As APIPACKET, majv As Integer, MinV As Integer, rev As Integer, ostype As Integer)
Declare Function RNBOsproFindFirstUnit% Lib "sx32w.dll" (ApiPack As APIPACKET, ByVal developerID As Integer)
Declare Function RNBOsproFindNextUnit% Lib "sx32w.dll" (ApiPack As APIPACKET)
Declare Function RNBOsproRead% Lib "sx32w.dll" (ApiPack As APIPACKET, ByVal Address As Integer, datum As Integer)
Declare Function RNBOsproExtendedRead% Lib "sx32w.dll" (ApiPack As APIPACKET, ByVal Address As Integer, datum As Integer, accessCode As Integer)
Declare Function RNBOsproWrite% Lib "sx32w.dll" (ApiPack As APIPACKET, ByVal wPass As Integer, ByVal Address As Integer, ByVal datum As Integer, ByVal accessCode As Integer)
Declare Function RNBOsproOverwrite% Lib "sx32w.dll" (ApiPack As APIPACKET, ByVal wPass As Integer, ByVal oPass1 As Integer, ByVal oPass2 As Integer, ByVal Address As Integer, ByVal datum As Integer, ByVal accessCode As Integer)
Declare Function RNBOsproDecrement% Lib "sx32w.dll" (ApiPack As APIPACKET, ByVal wPass As Integer, ByVal Address As Integer)
Declare Function RNBOsproActivate% Lib "sx32w.dll" (ApiPack As APIPACKET, ByVal wPass As Integer, ByVal aPass1 As Integer, ByVal aPass2 As Integer, ByVal Address As Integer)
Declare Function RNBOsproQuery% Lib "sx32w.dll" (ApiPack As APIPACKET, ByVal Address As Integer, query As DATAQUERY, response As DATAQUERY, unused As Long, ByVal Length As Integer)

Global XreadD, wPass, oPass1, oPass2, datum, dID
Global XreadAcc%, aCode%, Data%
Global Valid$, nl$

Private Const SPSUCCESS = 0
Dim DATAIN(50) As String      '用于校验的字符串(输入)
Dim DATAOUT(50) As String     '用于校验的字符串(输出)
Dim ApiPack As APIPACKET

Public Sub IniDog()
    
    '-----------------------
    '本过程用于初始化软件狗
    '-----------------------
    
'    Exit Sub        '测试中暂时屏蔽
    
    '以下检查是否存在软件狗
    Dim stval As Integer
    Dim ApiSize As Integer
    
    Const hID As Integer = &HDF2E
    
    ApiSize = 4096
    
    stval = RNBOsproFormatPacket%(ApiPack, ApiSize%)
    stval = RNBOsproInitialize%(ApiPack)
    If stval > 0 Then
        MsgBox MSG_DOG_INITIALIZE_ERROR, vbOKOnly + vbExclamation + vbDefaultButton1 + vbApplicationModal, MSG_ERR_HAPPEN
        FuncExit
    End If
    
    '-----------------------
    '以下检查软件狗是否
    '符合要求:
    '-----------------------
    stval = RNBOsproFindFirstUnit%(ApiPack, hID)
    
    If stval <> SPSUCCESS Then
        MsgBox MSG_DOG_ERROR, vbOKOnly + vbExclamation + vbDefaultButton1 + vbApplicationModal, MSG_ERR_HAPPEN
        FuncExit
    End If
    
    '----------------------
    '以下初始化校验字符串
    '----------------------
    DATAIN(0) = "76E1B7CB"
    DATAOUT(0) = "53DBC566"
    
    DATAIN(1) = "AE06118F"
    DATAOUT(1) = "AAEC153F"
    
    DATAIN(2) = "D6DBBBF5"
    DATAOUT(2) = "F3F7709A"
    
    DATAIN(3) = "4DD6FD28"
    DATAOUT(3) = "80F9465F"
    
    DATAIN(4) = "8ED1C2BA"
    DATAOUT(4) = "8F26FB1F"
    
    DATAIN(5) = "EF442012"
    DATAOUT(5) = "B531FFD7"
    
    DATAIN(6) = "7F9DDC54"
    DATAOUT(6) = "09F29057"
    
    DATAIN(7) = "BBF15F46"
    DATAOUT(7) = "15E0304D"
    
    DATAIN(8) = "3B8B2CC5"
    DATAOUT(8) = "DBE865BB"
    
    DATAIN(9) = "128B9183"
    DATAOUT(9) = "AAD47247"
    
    DATAIN(10) = "DE56C455"
    DATAOUT(10) = "B1DDA671"
    
    DATAIN(11) = "2E4FBBD3"
    DATAOUT(11) = "CE52F6FB"
    
    DATAIN(12) = "CE538AE1"
    DATAOUT(12) = "C3BC330B"

    DATAIN(13) = "F294F270"
    DATAOUT(13) = "A39B8F15"

    DATAIN(14) = "954D8AF8"
    DATAOUT(14) = "C2672E49"

    DATAIN(15) = "3490B742"
    DATAOUT(15) = "85D90498"
    
    DATAIN(16) = "7B0DF3EC"
    DATAOUT(16) = "FBFAB70F"
    
    DATAIN(17) = "15DB64E0"
    DATAOUT(17) = "B3A4BED8"
    
    DATAIN(18) = "F40672FA"
    DATAOUT(18) = "AA6B32D7"
    
    DATAIN(19) = "A7ED15CF"
    DATAOUT(19) = "87C91CDF"
    
    DATAIN(20) = "93FCFEDB"
    DATAOUT(20) = "4EC01251"
    
    DATAIN(21) = "561A7364"
    DATAOUT(21) = "D7D8718B"
    
    DATAIN(22) = "9DC79358"
    DATAOUT(22) = "72420E35"
    
    DATAIN(23) = "150976ED"
    DATAOUT(23) = "6F42AA3D"
    
    DATAIN(24) = "3FB668E5"
    DATAOUT(24) = "4A8B3619"
    
    DATAIN(25) = "7861E3D4"
    DATAOUT(25) = "C27020C2"
    
    DATAIN(26) = "FC807A5A"
    DATAOUT(26) = "D2ED077E"
    
    DATAIN(27) = "8866D27B"
    DATAOUT(27) = "C8AF367B"
    
    DATAIN(28) = "EB6FD1F0"
    DATAOUT(28) = "AED43C20"

    DATAIN(29) = "9AA95545"
    DATAOUT(29) = "CE22281B"

    DATAIN(30) = "5C39625B"
    DATAOUT(30) = "927FD343"
    
    DATAIN(31) = "FBC33009"
    DATAOUT(31) = "52FC0AFB"

    DATAIN(32) = "7F38300D"
    DATAOUT(32) = "963A5631"
    
    DATAIN(33) = "7BB2B633"
    DATAOUT(33) = "1B350E59"
    
    DATAIN(34) = "133028FE"
    DATAOUT(34) = "80B00A4B"
    
    DATAIN(35) = "02052C77"
    DATAOUT(35) = "08978297"

    DATAIN(36) = "2CF09918"
    DATAOUT(36) = "4AE11C74"
    
    DATAIN(37) = "9EF928A3"
    DATAOUT(37) = "C3F36EBA"

    DATAIN(38) = "72E81000"
    DATAOUT(38) = "AEC6289F"
    
    DATAIN(39) = "75628805"
    DATAOUT(39) = "8174B5B5"

    DATAIN(40) = "B651C043"
    DATAOUT(40) = "B21A7A26"
    
    DATAIN(41) = "7F89BE7C"
    DATAOUT(41) = "07F96C2C"

    DATAIN(42) = "345A8FE7"
    DATAOUT(42) = "A321AE51"
    
    DATAIN(43) = "0247CB3D"
    DATAOUT(43) = "552A1306"

    DATAIN(44) = "630A2A4E"
    DATAOUT(44) = "CAF51E63"
    
    DATAIN(45) = "A1D02FEC"
    DATAOUT(45) = "86E06813"

    DATAIN(46) = "931377E8"
    DATAOUT(46) = "CEB8CEEB"
    
    DATAIN(47) = "75A429CA"
    DATAOUT(47) = "DE5E422B"

    DATAIN(48) = "0FC29359"
    DATAOUT(48) = "E0B18331"
    
    DATAIN(49) = "C4189F5D"
    DATAOUT(49) = "A963606C"

End Sub

Public Sub CheckDog()
    
'    Exit Sub        '测试中暂时屏蔽
    
    
    '---------------------------------------
    '本过程用于随机的QUERY软件狗的加密算法
    '如发生错误,则退出程序
    '---------------------------------------
    Dim i As Integer
    Dim N As Integer
    Dim stval As Integer
    Dim Leng As Integer
    Dim Address As Integer
    Dim nul As Long
    Dim QueryIn As DATAQUERY
    Dim QueryOut As DATAQUERY
    Dim strH As String
    Dim strOUT As String
    
    '随机取一个检验值
    N = Int(Rnd() * 50)
    
    QueryIn = StringToDataQuery(DATAIN(N))
    nul = 0
    Address = 8
    Leng = Len(DATAIN(N)) / 2
    stval = RNBOsproQuery%(ApiPack, Address, QueryIn, QueryOut, nul, Leng)
    
    '如果返回值错误,则退出
    If stval <> SPSUCCESS Then
        MsgBox MSG_DOG_ERROR, vbOKOnly + vbExclamation + vbDefaultButton1 + vbApplicationModal, MSG_ERR_HAPPEN
        FuncExit
    Else
        '如果值与已知值不匹配,则也退出程序
        strOUT = vbNullString
        For i = 0 To Leng - 1
            strH = Hex$(QueryOut.Data(i))               '展开
            If Len(strH) = 1 Then strH = "0" + strH     '强制前导0
            strOUT = strOUT + strH
        Next i
        If strOUT <> DATAOUT(N) Then
            MsgBox MSG_DOG_ERROR, vbOKOnly + vbExclamation + vbDefaultButton1 + vbApplicationModal, MSG_ERR_HAPPEN
            FuncExit
        End If
    End If
        
End Sub

Public Sub NullCheck()
    
'    Exit Sub        '测试中暂时屏蔽
    
    
    '---------------------------------------
    '本过程用于随机的QUERY软件狗的加密算法
    '并不验证返回值
    '---------------------------------------
    Dim i As Integer
    Dim N As Integer
    Dim stval As Integer
    Dim Leng As Integer
    Dim Address As Integer
    Dim nul As Long
    Dim QueryIn As DATAQUERY
    Dim QueryOut As DATAQUERY
    Dim strIN As String
    Const Valid As String = "0123456789ABCDEF"
    
    '随机取一个检验值
    For i = 1 To 8
        N = Int(Rnd() * 16) + 1
        strIN = strIN & Mid$(Valid, N, 1)
    Next i
    
    QueryIn = StringToDataQuery(strIN)
    nul = 0
    Address = 8
    Leng = Len(strIN) / 2
    stval = RNBOsproQuery%(ApiPack, Address, QueryIn, QueryOut, nul, Leng)
    
    '如果返回值错误,则退出
    If stval <> SPSUCCESS Then
        MsgBox MSG_DOG_ERROR, vbOKOnly + vbExclamation + vbDefaultButton1 + vbApplicationModal, MSG_ERR_HAPPEN
        FuncExit
    End If
    
End Sub

Public Function StringToDataQuery(ByVal str As String) As DATAQUERY
    
    '--------------------------
    '将一个字符串形式的16进制数
    '转换为DATAQUERY形式
    '--------------------------
    Dim i As Integer
    Dim j As Integer
    Dim A As Integer
    Dim B As Integer
    Const Valid As String = "0123456789ABCDEF"
    
    For i = 1 To Len(str) - 1 Step 2
        j = j + 1                                  'j=index to result string
        A = InStr(Valid, Mid(str, i, 1)) - 1       '1st of pair
        B = InStr(Valid, Mid(str, i + 1, 1)) - 1   '2nd of pair
        Mid(str, j, 1) = Chr(A * 16 + B)           'use same string for query string
        StringToDataQuery.Data(j - 1) = A * 16 + B
    Next
    
End Function