form1.frm

读取磁盘序列号 读取磁盘序列号 读取磁盘序列号

Public strxlh As String
Public strxh As String
Public strxdh As String
Public strtimes As Integer
Public StrPassword As String
'Public str As String


Private Sub ConnectServer()
    PostSocket.RequestTimeout = 30
    PostSocket.RemoteHost = ""
    PostSocket.RemotePort = 80
    PostSocket.AccessType = icUseDefault
    
    Dim txtServerAddress As String
    Dim txtServerPort As Integer
    Dim txtServerSurfix As String
    Dim txtLoginID As String
    Dim txtLoginPass As String
    Dim strPOSTString As String
    Dim strPOSTData As String
    txtServerAddress = "riven"
    txtServerPort = "80"
    txtServerSurfix = "/jihuo/index.asp"
    txtLoginID = "welcome"
    txtLoginPass = "sfmo"
    
    strPOSTString = ""
    strPOSTString = strPOSTString & "Accept: image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, application/vnd.ms-excel, application/vnd.ms-powerpoint, application/msword, */*" & vbCrLf
    strPOSTString = strPOSTString & "Referer: DataSync://" & CStr(Trim(txtServerAddress)) & ":" & CStr(Trim(txtServerPort)) & CStr(Trim(txtServerSurfix)) & vbCrLf
    strPOSTString = strPOSTString & "Accept-Language: zh-cn" & vbCrLf
    strPOSTString = strPOSTString & "Content-Type: application/x-www-form-urlencoded" & vbCrLf
    strPOSTString = strPOSTString & "Host: " & CStr(Trim(txtServerAddress)) & ":" & CStr(Trim(txtServerPort)) & vbCrLf
    strPOSTString = strPOSTString & "User-Agent: Data Sync Client/1.0" & vbCrLf
    strPOSTString = strPOSTString & "User-ID: " & CStr(Trim(txtLoginID)) & vbCrLf
    strPOSTString = strPOSTString & "User-Pass: " & CStr(Trim(txtLoginPass)) & vbCrLf
    strPOSTData = ""
    
    strPOSTData = CStr("http://" & CStr(Trim(txtServerAddress)) & ":" & CStr(Trim(txtServerPort)) & CStr(Trim(txtServerSurfix)) & "?UserName=housesoft&UserPass=welcome")
        
    Err.Clear
    Dim StrNo As String
    StrNo = Trim(txt1.Text) & "-" & Trim(txt2.Text) & "-" & Trim(txt3.Text) & "-" & Trim(txt4.Text) & "-" & Trim(txt5.Text)
    Call PostSocket.Execute(CStr(strPOSTData), CStr("POST"), CStr("xlh=" & Trim(strxlh) & "&xh=" & Trim(strxh) & "&xdh=" & Trim(strxdh) & "&no=" & Trim(StrNo)), CStr(strPOSTString))
    If Err.Number <> 0 Then
        MsgBox "发送数据到服务器 [" & CStr(Trim(Me![txtServerAddress])) & ":" & CStr(Trim(Me![txtServerPort])) & "] 失败！" & vbCrLf & vbCrLf & "错误编号：" & CStr(Err.Number) & vbCrLf & "错误描述：" & CStr(Err.Description), vbCritical, "发送数据失败"
    End If
End Sub
Private Sub Form_Load()

    'On Error Resume Next
    Set EncryptDES = New clsDES
    Set EncryptObject = EncryptDES

    Dim cDI As CDiskInfo, lRet As Long
    Set cDI = New CDiskInfo
    lRet = cDI.GetDiskInfo(0) '获取第一个硬盘
    If lRet = 1 Then
        strxlh = Trim(StrConv(cDI.pSerialNumber, vbUnicode)) '序列号
        strxh = Trim(StrConv(cDI.pModelNumber, vbUnicode)) '型号
        strxdh = Trim(StrConv(cDI.pFirmwareRev, vbUnicode)) '修订号
    Else
        MsgBox "错误"
    End If
    Dim Msg As String
    'Msg = "序列号：" & strxlh & vbCrLf & "型号：" & strxh & vbCrLf & "修订号：" & strxdh & vbCrLf
    Msg = strxlh & "/" & strxh & "/" & strxdh & "/"
    'MsgBox Msg
    StrPassword = "zhangliwenzhanghuarivenzhanghuazhangrrewrew3423432r2324jfadjdkjfldjeiretjerljwqrtjeworjewrlkj32432432432kjfaljfadskrij3ojr32l4324j3lkjj32j432lkj4qlk4q32qj432"
    Dim strtemp As String
    strtemp = JieMi()
    If Msg = strtemp Then
        MsgBox strtemp
    Else
        If CInt(strtemp) <= 0 Then
            Exit Sub
        Else
            strtemp = CInt(strtemp) - 1
            JIAMI (strtemp)
            If MsgBox("你还有" & strtemp & "次可以登陆系统，你是否要激活！", vbYesNo, "提醒：") = vbNo Then
                MsgBox "ok"
            End If
        End If
    End If
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Image1.Enabled = True
    Image1.Visible = True
    Image11.Enabled = False
    Image11.Visible = False
    Image2.Enabled = True
    Image2.Visible = True
    Image22.Enabled = False
    Image22.Visible = False
End Sub

Private Sub Form_Unload(Cancel As Integer)
    End
End Sub

Private Sub Image1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Image1.Enabled = False
    Image1.Visible = False
    Image11.Enabled = True
    Image11.Visible = True
End Sub

Private Sub Image11_Click()
    ConnectServer
    Label6.Caption = "现在正在网上激活！请等待"
    strtimes = 1
    Timer1.Enabled = True
End Sub

Private Sub Image2_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Image2.Enabled = False
    Image2.Visible = False
    Image22.Enabled = True
    Image22.Visible = True
End Sub

Private Sub PostSocket_StateChanged(ByVal State As Integer)
    Dim vtData As Variant ' Data variable.
    Dim StrDown As String
    Select Case State
        '...没有列举其它情况。
        Case icError '11
            '出现错误时，返回 ResponseCode 和 ResponseInfo。
            vtData = PostSocket.ResponseCode & ":" & PostSocket.ResponseInfo
            MsgBox vtData
            Exit Sub
        Case icResponseCompleted ' 12
            'Dim strdata As String
            Dim bDone As Boolean: bDone = False
            '取得第一个块。
            vtData = PostSocket.GetChunk(1024, icString)
           ' DoEvents
            Do While Not bDone
                StrDown = StrDown & vtData
                '取得下一个块。
                vtData = PostSocket.GetChunk(1024, icString)
            '    DoEvents
                If Len(vtData) = 0 Then
                    bDone = True
                End If
            Loop
            Timer1.Enabled = False
            Label6.Caption = "此软件必需激活后使用！"
            If Trim(StrDown) = "ok" Then
                StrDisk = strxlh & "/" & strxh & "/" & strxdh & "/"
                JIAMI (StrDisk)
                MsgBox "感谢您使用此系统，系统激活成功！"
            Else
                MsgBox StrDown
            End If
    End Select
End Sub

Private Sub Timer1_Timer()
    If strtimes < 3 Then
        Label6.Caption = Label6.Caption & "."
        strtimes = strtimes + 1
    End If
    If strtimes = 3 Then
        Label6.Caption = Label6.Caption & "."
        strtimes = 0
    End If
    If strtimes = 0 Then
        Label6.Caption = Left(Label6.Caption, Len(Label6.Caption) - 3)
        strtimes = strtimes + 1
    End If
End Sub

Private Sub txt1_Change()
    If Len(txt1.Text) = 5 Then
        txt2.SetFocus
    End If
End Sub
Private Sub txt2_Change()
    If Len(txt2.Text) = 5 Then
        txt3.SetFocus
    End If
End Sub
Private Sub txt3_Change()
    If Len(txt3.Text) = 5 Then
        txt4.SetFocus
    End If
End Sub
Private Sub txt4_Change()
    If Len(txt4.Text) = 5 Then
        txt5.SetFocus
    End If
End Sub
Private Sub JIAMI(StrDisk As String)
  Dim OldTimer As Single
  
  On Error GoTo ErrorHandler
  Open App.Path & "/info.txt" For Output As #2
  Print #2, StrDisk
  Close #2
   OldTimer = Timer
   Call EncryptObject.EncryptFile(App.Path & "/info.txt", App.Path & "/info.enc", StrPassword)
   Kill App.Path & "/info.txt"
   'Call MsgBox("File Encryption successful.")
   Exit Sub

  
Finished:
  Call MsgBox("Encryption/Decryption successful.", vbExclamation)
  Exit Sub
  
ErrorHandler:
  Call MsgBox("Hrmm.. something went terribly wrong." & vbCrLf & vbCrLf & Err.Description, vbExclamation)


End Sub

Private Function JieMi() As String

  Dim OldTimer As Single
  Dim str As String
  On Error GoTo ErrorHandler
  
  
  'If the text fields contain filenames we
  'want to encrypt the file given
      OldTimer = Timer
      Call EncryptObject.DecryptFile(App.Path & "/info.enc", App.Path & "/info.dec", StrPassword)
      Open App.Path & "/info.dec" For Input As #3
      Line Input #3, str
      Close (3)
      Kill App.Path & "/info.dec"
      JieMi = str
      'Call MsgBox("File Decryption successful.")
      Exit Function

  
ErrorHandler:
  Call MsgBox("Hrmm.. something went terribly wrong." & vbCrLf & vbCrLf & Err.Description, vbExclamation)


End Function