frmkrypt.frm

加密/解密字符串的例子

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form frmkrypt 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "Encrypt / Decrypt Files"
   ClientHeight    =   4500
   ClientLeft      =   2310
   ClientTop       =   2520
   ClientWidth     =   6585
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   PaletteMode     =   2  'Custom
   ScaleHeight     =   4500
   ScaleWidth      =   6585
   Begin VB.TextBox txtcancel 
      Height          =   285
      Left            =   3885
      TabIndex        =   11
      Top             =   135
      Visible         =   0   'False
      Width           =   1335
   End
   Begin VB.CommandButton cmdabout 
      Caption         =   "&About"
      Height          =   375
      Left            =   3360
      TabIndex        =   4
      Top             =   3600
      Width           =   1455
   End
   Begin MSComDlg.CommonDialog cdlg1 
      Left            =   2940
      Top             =   45
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
      CancelError     =   -1  'True
   End
   Begin VB.CommandButton cmdcancel 
      Cancel          =   -1  'True
      Caption         =   "&Cancel"
      Height          =   375
      Left            =   4920
      TabIndex        =   5
      Top             =   3600
      Width           =   1455
   End
   Begin VB.CommandButton cmddecrypt 
      Caption         =   "&Decrypt"
      Height          =   375
      Left            =   240
      TabIndex        =   2
      Top             =   3600
      Width           =   1455
   End
   Begin VB.CommandButton cmdkrypt 
      Caption         =   "&Encrypt"
      Height          =   375
      Left            =   1800
      TabIndex        =   3
      Top             =   3600
      Width           =   1455
   End
   Begin VB.CommandButton cmdbrowse2 
      Caption         =   "&Browse"
      Height          =   375
      Left            =   5040
      TabIndex        =   1
      Top             =   2280
      Width           =   1215
   End
   Begin VB.CommandButton cmdbrowse1 
      Caption         =   "&Browse"
      Default         =   -1  'True
      Height          =   375
      Left            =   5040
      TabIndex        =   0
      Top             =   840
      Width           =   1215
   End
   Begin VB.TextBox txtdestination 
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   9.75
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Left            =   240
      Locked          =   -1  'True
      TabIndex        =   7
      Top             =   2280
      Width           =   4815
   End
   Begin VB.TextBox txtsource 
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   9.75
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Left            =   240
      Locked          =   -1  'True
      TabIndex        =   6
      Top             =   840
      Width           =   4815
   End
   Begin VB.TextBox txtpaxz 
      Height          =   375
      Left            =   45
      TabIndex        =   10
      Top             =   45
      Visible         =   0   'False
      Width           =   2295
   End
   Begin VB.Label Label2 
      BackStyle       =   0  'Transparent
      Caption         =   "Destination File"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   12
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Left            =   225
      TabIndex        =   9
      Top             =   1980
      Width           =   2535
   End
   Begin VB.Label Label1 
      BackStyle       =   0  'Transparent
      Caption         =   "Source File"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   12
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Left            =   240
      TabIndex        =   8
      Top             =   540
      Width           =   2655
   End
End
Attribute VB_Name = "frmkrypt"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub cmdabout_Click()
'' Display About Box
MsgBox "This Program Encrypts and Decrypts files using the same algorithm" & Chr(13) & "used in EasyByte EasyMailer" & Chr(13) & Chr(13) & Chr(13) & "Go to www.easybyte.com to get a FREE copy of the SOURCE CODE for this program", vbInformation
   
End Sub

Private Sub cmdbrowse1_Click()

''
''  This Procedure Lets the user Choose a file to Encrypt / Decrypt
''

On Error GoTo errhandler

'open text file
Dim CRTF_Text As Integer
CRTF_Text = 1


cdlg1.Filter = "All Files (*.*)|*.*"
cdlg1.FilterIndex = 0
cdlg1.DialogTitle = "Choose Source File"
cdlg1.InitDir = App.Path
cdlg1.Flags = cdlOFNHideReadOnly
cdlg1.ShowOpen


txtsource.Text = cdlg1.Filename
cmdbrowse2.SetFocus

errhandler:


eds:
End Sub

Private Sub cmdbrowse2_Click()

''
''  This Procedure Lets the user Choose where the Encrypted / Decrypted
''  Source File is Placed.

On Error GoTo errhandler

If txtsource.Text = "" Then
  MsgBox "You Must Select a Source File First", 64
  cmdbrowse1.SetFocus
  GoTo eds
End If

'open text file
Dim CRTF_Text As Integer
CRTF_Text = 1

cdlg1.Filter = "All Files (*.*)|*.*"
cdlg1.FilterIndex = 0
cdlg1.DialogTitle = "Choose Destination File"
cdlg1.InitDir = App.Path
cdlg1.Flags = cdlOFNOverwritePrompt + cdlOFNHideReadOnly
cdlg1.ShowSave


txtdestination.Text = cdlg1.Filename
FileCopy txtsource.Text, txtdestination.Text

GoTo eds


errhandler:

Select Case Err.Number
Case 75
  MsgBox "You have not Chosen a Source File Yet.", 64
  txtdestination.Text = ""
  cmdbrowse1.SetFocus
  Resume Next
Case Else
  GoTo eds
End Select


eds:
End Sub


Private Sub cmdcancel_Click()
  End
End Sub

Private Sub cmddecrypt_Click()

On Error GoTo errorhandler  ' Enable error-handling routine.

'' The procedure for decrypting files

Dim Password As String
Dim Filename As String
Dim Message As String
Dim TryPass As String
Dim charnum As Currency, randominteger As Currency
Dim singlechar As String * 1
Dim keyvalue As Currency
Dim secondkey As Currency
Dim CurrChar As String
Dim msg As String
Dim ctxt As Integer
Dim Q As Currency
Dim filenum As Currency
Dim X As Currency
Dim I As Currency

If txtsource.Text = "" Then
  MsgBox "You must Choose a Source File.", 64
  cmdbrowse1.SetFocus
  GoTo eds
End If

If txtdestination.Text = "" Then
  MsgBox "You must Choose a Destination File.", 64
  cmdbrowse2.SetFocus
  GoTo eds
End If

frmpass.Caption = "Enter Password to Decrypt Message"
frmpass.Show vbModal

TryPass = txtpaxz.Text


'' If the user clicked on Cancel on the Password entry dialog
'' box.
If txtcancel.Text = "yes" Then
  GoTo eds
End If





'' Change mouse to hour glass
MousePointer = 11

Password = TryPass


'' All of the code below de-ciphers the message
'' get each ascii from each letter in password
    
 For Q = Len(Password) To 1 Step -1
      
      CurrChar = Mid(Password$, Q, 1)
      keyvalue = Asc(CurrChar)

    filenum = FreeFile
    X = Rnd(-keyvalue)
    
    Filename$ = txtdestination.Text
    
    'The following code is labeled with obvious variables
    'So it is easy to follow what is going on

    Open Filename$ For Binary As #filenum     'open the file name for output/input.
    For I = 1 To LOF(filenum)
      Get #filenum, I, singlechar
      charnum = Asc(singlechar)
      randominteger = Int(256 * Rnd)
      charnum = charnum Xor randominteger
      singlechar = Chr$(charnum)
      Put #filenum, I, singlechar
    Next I
  Close #filenum

Next Q

Close #filenum

  
errorhandler:     ' Error-handling routine.
    Select Case Err.Number  ' Evaluate error number.
         Case 0
           Resume Next
         Case 20
           Resume Next
        Case Else
            MsgBox "Error Number " & Err.Number & " Happened"
            GoTo eds
    End Select
    
Close #1
     



eds:

txtcancel.Text = "no"
MousePointer = 0
End Sub

Private Sub ReKrypt()

 MsgBox "ReKrypt"

End Sub

Private Sub cmdkrypt_Click()
On Error GoTo errorhandler  ' Enable error-handling routine.

'' The procedure for Encrypting files

Dim Password As String
Dim Filename As String
Dim Message As String
Dim TryPass As String
Dim charnum As Currency, randominteger As Currency
Dim singlechar As String * 1
Dim keyvalue As Currency
Dim secondkey As Currency
Dim CurrChar As String
Dim msg As String
Dim ctxt As Integer
Dim Q As Currency
Dim filenum As Currency
Dim X As Currency
Dim I As Currency
Dim XX As Currency


If txtsource.Text = "" Then
  MsgBox "You must Choose a Source File.", 64
  cmdbrowse1.SetFocus
  GoTo eds
End If

If txtdestination.Text = "" Then
  MsgBox "You must Choose a Destination File.", 64
  cmdbrowse2.SetFocus
  GoTo eds
End If

frmpass.Caption = "Enter Password to Encrypt Message"
frmpass.Show vbModal

TryPass = txtpaxz.Text


'' If the user clicked on Cancel on the Password entry dialog
'' box.
If txtcancel.Text = "yes" Then
  GoTo eds
End If



'' Change mouse to hour glass
MousePointer = 11

Password = TryPass


'' All of the code below ciphers the message
'' get each ascii from each letter in password
    
 For Q = 1 To Len(Password)

      CurrChar = Mid(Password$, Q, 1)
      keyvalue = Asc(CurrChar)

    filenum = FreeFile
    X = Rnd(-keyvalue)
    
    Filename$ = txtdestination.Text
    
    'The following code is labeled with obvious variables
    'So it is easy to follow what is going on

    Open Filename$ For Binary As #filenum     'open the file name for output/input.
    For I = 1 To LOF(filenum)
      Get #filenum, I, singlechar
      charnum = Asc(singlechar)
      randominteger = Int(256 * Rnd)
      charnum = charnum Xor randominteger
      singlechar = Chr$(charnum)
      Put #filenum, I, singlechar
    Next I
  Close #filenum

Next Q

Close #filenum

  
errorhandler:     ' Error-handling routine.
    Select Case Err.Number  ' Evaluate error number.
         Case 0
           Resume Next
         Case 20
           Resume Next
        Case Else
            MsgBox "Error Number " & Err.Number & " Happened"
            GoTo eds
    End Select
    
Close #1
     



eds:

txtcancel.Text = "no"
MousePointer = 0
End Sub

Private Sub txtdestination_GotFocus()
   cmdbrowse2.SetFocus
End Sub


Private Sub txtsource_GotFocus()
   cmdbrowse1.SetFocus
End Sub