progmain.bas

guan yu pai ke xi tong de ruan jian

    If Asc(Right(FileName, 1)) = 34 Then FileName = Left(FileName, Len(FileName) - 1)
    If Len(GetString(HKEY_CURRENT_USER, LOGON_REG_APPLY, "Apply")) < 1 Then
        '如果是第一次运行，还没有保存申请码，则产生一个申请码并保存到注册表中,同时启动注册向导。
        TemStr = GetString(HKEY_CURRENT_USER, LOGON_REG_LOGON, "Apply")        '错位保存申请，注册时进行校对，以防止解密者通过搜索注册表蒙混过关。
        If Len(TemStr) = 16 Then
            MsgBox "发现注册信息损坏！" & Chr(13) & "本机注册信息专属本机使用，用户不得试图通过修改注册信息非法使用本软件！" & Chr(13) & "如果非法对本软件进行解密，将受到法律的严惩！" & Chr(13) & "受损信息已经清除，现在重新给出一个申请码，请通过正常渠道进行注册！" & Chr(13) & "如因不明原因造成，请及时通知我们，联系方法详见帮助文档。"
        End If
        TemStr = LogonIn() '随机获取一个申请码字符串。
        SaveString HKEY_CURRENT_USER, LOGON_REG_APPLY, "Apply", TemStr '保存申请码原本。
        TemStr = Mid(TemStr, 13, 2) & Mid(TemStr, 11, 2) & Mid(TemStr, 8, 2) & Mid(TemStr, 6, 2) & Mid(TemStr, 18, 2) & Mid(TemStr, 16, 2) & Mid(TemStr, 3, 2) & Mid(TemStr, 1, 2)
        SaveString HKEY_CURRENT_USER, LOGON_REG_LOGON, "Verify", TemStr '错位保存申请，注册时进行校对，以防止解密者通过搜索注册表蒙混过关。
    End If
    If ApplyMode = False Then
        If MsgBox("支持国产软件！请注册您的产品！" & Chr(13) & "您现在就要注册吗？", vbYesNo, "未注册...") = vbYes Then Apply.Show 1
    End If
    PassWord = False
    If GetString(HKEY_CURRENT_USER, LOGON_REG_PATH, "PassWord") = "" Then PassWord = True Else ComeProg.Show 1 '如果还没有设置密码，系统将直接正常启动。如果已经设置了用户密码，则系统启动时必须进行登陆操作，并且只有成功登陆，‘操作’菜单才可见。
    MainFrm.Show
    If Len(FileName) < 1 Then '如果没有命令行参数，则完成。否则作为数据文件打开。
        MainFrm.MenuEnabledSet False '没有打开文件,相应菜单不可用.
    Else
        MainFrm.MenuEnabledSet Not (MyDataSet.OpenDataFile(FileName)) '只有成功打开文件,相应菜单才可用.
    End If
End Sub
Public Function LogonIn() As String
'随机产生申请码。
    Const SouStr As String = "1375406289"
    Dim ForIndex1 As Integer
    Dim ForIndex2 As Integer
    Dim ForIndex3 As Integer
    For ForIndex3 = 0 To Val(Right(timeGetTime, 2)) '由当前获取时间决定循环次数。
        LogonIn = ""
        For ForIndex1 = 1 To 4 '获取一个4X4随机数阵列。
            For ForIndex2 = 1 To 4
                LogonIn = LogonIn & Mid(SouStr, Rnd() * 100 Mod 10 + 1, 1)
            Next
            If ForIndex1 < 4 Then LogonIn = LogonIn & "-" '添加数据之间的‘-’字符。
        Next
    Next
End Function
Public Function LogonOut(ByVal InString As String) As String
'由申请码产生注册码。
    On Error Resume Next
    Const SouStr As String = "TBGDEZYFPILSJRKAHVNCXUWQMO"
    Dim ForIndex As Integer
    Dim Temp As String
    Dim TempString As String
    If InString = "" Then End
    '交换位置并除去连接符。
    TempString = Mid(InString, 16, 1) & Mid(InString, 18, 1) & Mid(InString, 17, 1) & Mid(InString, 19, 1) & Mid(InString, 6, 1) & Mid(InString, 8, 1) & Mid(InString, 7, 1) & Mid(InString, 9, 1) & Mid(InString, 11, 1) & Mid(InString, 13, 1) & Mid(InString, 12, 1) & Mid(InString, 14, 1) & Mid(InString, 1, 1) & Mid(InString, 3, 1) & Mid(InString, 2, 1) & Mid(InString, 4, 1)
    For ForIndex = 1 To 16 '检测是否有非法字符。
        If Asc(Mid(TempString, ForIndex, 1)) < 48 Or Asc(Mid(TempString, ForIndex, 1)) > 57 Then End
    Next
    InString = ""
    '给第一个数字与其"位置码"进行相乘操作,取其最末一个数字。
    For ForIndex = 1 To 16
        InString = InString & Right(Val(Mid(TempString, ForIndex, 1)) * ForIndex, 1)
    Next
    TempString = ""
    '根据数据取得字符。
    For ForIndex = 1 To 16
        TempString = TempString & Mid(SouStr, Val(Mid(InString, ForIndex, 1) + 5), 1)
    Next
    LogonOut = Mid(TempString, 1, 4) & "-" & Mid(TempString, 5, 4) & "-" & Mid(TempString, 9, 4) & "-" & Mid(TempString, 13, 4)
End Function
Public Function GetString(hKey As Long, strPath As String, strValue As String)
    '获取注册信息?
    Dim ret
    'Open the key
    RegOpenKey hKey, strPath, ret
    'Get the key's content
    GetString = RegQueryStringValue(ret, strValue)
    'Close the key
    RegCloseKey ret
End Function
Public Function RegQueryStringValue(ByVal hKey As Long, ByVal strValueName As String) As String
    Dim lResult As Long, lValueType As Long, strBuf As String, lDataBufSize As Long
    'retrieve nformation about the key
    lResult = RegQueryValueEx(hKey, strValueName, 0, lValueType, ByVal 0, lDataBufSize)
    If lResult = 0 Then
        If lValueType = REG_SZ Then
            'Create a buffer
            strBuf = String(lDataBufSize, Chr$(0))
            'retrieve the key's content
            lResult = RegQueryValueEx(hKey, strValueName, 0, 0, ByVal strBuf, lDataBufSize)
            If lResult = 0 Then
                'Remove the unnecessary chr$(0)'s
                If lDataBufSize < 1 Then
                    RegQueryStringValue = ""
                    Exit Function
                End If
                RegQueryStringValue = Left$(strBuf, InStr(1, strBuf, Chr$(0)) - 1)
            End If
        ElseIf lValueType = REG_BINARY Then
            Dim strData As Integer
            'retrieve the key's value
            lResult = RegQueryValueEx(hKey, strValueName, 0, 0, strData, lDataBufSize)
            If lResult = 0 Then
                RegQueryStringValue = strData
            End If
        End If
    End If
End Function
Public Sub SaveString(hKey As Long, strPath As String, strValue As String, strData As String)
    '保存注册信息。
    Dim ret
    'Create a new key
    RegCreateKey hKey, strPath, ret
    'Save a string to the key
    RegSetValueEx ret, strValue, 0, REG_SZ, ByVal strData, Len(strData)
    'close the key
    RegCloseKey ret
End Sub
Public Sub Help()
    '显示帮助文件。
    Dim HelpFile As String
    Dim TempString As String
    Dim TempInteger As Long
    Dim ShellString As String
    Dim MyFile As Long '文件对象。
    Dim myOverlAppend As OVERLAPPED
    Dim myOfstruct As OFSTRUCT
    HelpFile = App.Path & "\help.htm"
    MyFile = OpenFile(HelpFile, myOfstruct, OF_EXIST)
    If MyFile < 0 Then
        MsgBox "找不到帮助文件！" & Chr(13) & "文件丢失或损坏！", , "错误..."
        Exit Sub
    End If
    TempString = String(MAX_FILENAME_LEN, 32)
    TempInteger = FindExecutable(HelpFile, vbNullString, TempString)
    ShellString = Left$(TempString, InStr(1, TempString, Chr(0)) - 1) & Chr(32) & HelpFile
    If TempInteger > 32 Then
        TempInteger = Shell(ShellString, vbMaximizedFocus)
    Else
        MsgBox "找不到与帮助文件关联的程序！" & Chr(13) & "无法打开帮助文件！", , "错误..."
    End If
End Sub
Public Function ApplyMode() As Boolean
    Dim FileName As String
    Dim MyFile As Long '文件对象。
    Dim FileSize As Long
    Dim TemNum(2) As Byte
    Dim ForIndex As Long
    Dim myOfstruct As OFSTRUCT
On Error Resume Next
    '检测注册标志。成功注册返回True，否则返回False.
    '第一步，检测注册表中的注册标志。
    ApplyMode = False
    FileName = GetString(HKEY_CURRENT_USER, LOGON_REG_LOGON, "Using") '检测注册成功的标志数据（598 ）。
    If Val(FileName) + 2 <> 600 Then Exit Function '不出现598是为了防止恶意解密.
    '第二步，检测安装目录下的\images\Paike.ico文件最后两字节，其数据应为598.
    FileName = App.Path & "\images\paike.ico"
    MyFile = OpenFile(FileName, myOfstruct, OF_EXIST)
    If MyFile < 0 Then Exit Function '文件已经不存在，则提示错误。
    '测试文件大小。
    MyFile = OpenFile(FileName, myOfstruct, OF_READ)
    FileSize = GetFileSize(MyFile, ForIndex)
    CloseHandle MyFile
    '打开文件并写入注册数据。
    Open FileName For Binary Access Read As #1
    If Err.Number <> 0 Then  '打开文件错误。
        MsgBox "无法访问！" & Chr(13) & "请确保你对安装目录的访问权限，请与你的系统管理员联系！" & Chr(13) & "如果还是不行，请重新安装本软件！", vbOKOnly, "错误.."
        Close #1
        Exit Function
    End If
    Get #1, FileSize - 2, TemNum(1)
    Get #1, FileSize - 1, TemNum(2)
    Close #1
    If TemNum(1) * 256 + TemNum(2) + 2 <> 600 Then Exit Function
    ApplyMode = True '表示已经成功注册。
End Function