frmsteg.frm

文件的加密解密实现

            Strikethrough   =   0   'False
         EndProperty
         Height          =   615
         Left            =   -74880
         TabIndex        =   27
         Top             =   2280
         Width           =   5175
      End
      Begin VB.Image picThumb 
         BorderStyle     =   1  'Fixed Single
         Height          =   3975
         Left            =   240
         Stretch         =   -1  'True
         Top             =   1320
         Width           =   4935
      End
      Begin VB.Image Image6 
         Appearance      =   0  'Flat
         BorderStyle     =   1  'Fixed Single
         Height          =   1545
         Left            =   -73680
         Picture         =   "frmSteg.frx":0226
         Top             =   600
         Width           =   2730
      End
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'Stegosaurus

Public IsLoaded As Boolean 'has an image been loaded?

Private Sub txtPassword_Change() 'user is typing a password
On Error Resume Next
PBKey.Value = Len(txtPassword.Text) 'add to progress bar which denotes security
End Sub

Private Sub chkMaskKey_Click() 'mask password?

    If chkMaskKey.Value = 0 Then 'don't mask password
        txtPassword.PasswordChar = None
    ElseIf chkMaskKey.Value = 1 Then 'mask password
        txtPassword.PasswordChar = "|"
    End If
    
End Sub

Private Sub Form_Load()

PBKey.Max = 32
optNone.Value = True
picImage.ScaleMode = vbPixels
picImage.AutoRedraw = True
CD1.InitDir = App.Path 'common dialog's default dir = our app's path

End Sub

Private Sub Open_Click() 'open image
On Error Resume Next

With CD1
    .CancelError = True
    .Flags = cdlOFNFileMustExist Or cdlOFNHideReadOnly Or cdlOFNLongNames
    .Filter = "Bitmap Files (*.bmp)|*.bmp|GIF (*.gif)|*.gif|JPEG (*.jpeg, *.jpg)|*.jpeg;*.jpg|All Files (*.*)|*.*"
    .ShowOpen

If Err.Number <> 0 Then Exit Sub

picImage.Picture = LoadPicture(CD1.FileName)
picThumb.Picture = LoadPicture(CD1.FileName)
IsLoaded = True 'file is loaded

If Err.Number <> 0 Then Exit Sub

    .InitDir = CD1.FileName
    .FileName = CD1.FileTitle

End With

SB1.Panels(1).Text = CD1.FileName

End Sub

Private Sub SaveAs_Click() 'save image
On Error Resume Next

With CD1
    .CancelError = True
    .Flags = cdlOFNOverwritePrompt Or cdlOFNHideReadOnly Or cdlOFNLongNames
    .Filter = "Bitmap Files (*.bmp)|*.bmp)"
    .ShowSave

If Err.Number <> 0 Then Exit Sub
SavePicture picImage.Picture, CD1.FileName
If Err.Number <> 0 Then Exit Sub

    .InitDir = CD1.FileName
    .FileName = CD1.FileTitle

End With

End Sub

Private Sub cmdRC4Encrypt_Click() 'RC4 Encrypt text
    
    txtRC4Msg.Text = cRC4(txtRC4Msg.Text, txtRC4Pass.Text)

End Sub

Private Sub cmdRC4Decrypt_Click() 'RC4 Decrypt Text
    txtRC4Msg.Text = cRC4(txtRC4Msg.Text, txtRC4Pass.Text)
End Sub

Private Sub chkRC4MaskKey_click()

    If chkRC4MaskKey.Value = 0 Then 'don't mask password
        txtRC4Pass.PasswordChar = None
    ElseIf chkRC4MaskKey.Value = 1 Then 'mask password
        txtRC4Pass.PasswordChar = "|"
    End If

End Sub


'The following code was taken mainly from an old article
'on www.vb-helper.com. I hardly wrote any of it and I am
'not claiming to be its author. I just thought you might
'find it useful.


Private Sub EncodeByte(ByVal Value As Byte, ByVal used_positions As Collection, ByVal iWidth As Integer, ByVal iHeight As Integer)
On Error GoTo ErrSub 'error handling

Dim i As Integer
Dim byte_mask As Integer
Dim r As Integer
Dim c As Integer
Dim pixel As Integer
Dim clrr As Byte
Dim clrg As Byte
Dim clrb As Byte
Dim color_mask As Integer

byte_mask = 1
For i = 1 To 8
    'pick a random pixel and RGB
    PickPosition used_positions, iWidth, iHeight, r, c, pixel

'find out each specific pixel's colouring
UnRGB picImage.Point(r, c), clrr, clrg, clrb

If Value And byte_mask Then 'the value to be stored
    color_mask = 1 'mask colouring? yes...
Else
    color_mask = 0 'or no...
End If

Select Case pixel 'update with the new colour
Case 0
    clrr = (clrr And &HFE) Or color_mask
Case 1
    clrg = (clrg And &HFE) Or color_mask
Case 2
    clrb = (clrb And &HFE) Or color_mask
End Select

picImage.PSet (r, c), RGB(clrr, clrg, clrb) 'new colour
byte_mask = byte_mask * 2

Next i

ErrSub: 'error handling
If Err.Number <> 0 Then
    MsgBox (Err.Number & vbCrLf & Err.Description), vbCritical + vbOKOnly, "Error)"
Exit Sub
End If

End Sub


Private Function DecodeByte(ByVal used_positions As Collection, ByVal iWidth As Integer, ByVal iHeight As Integer) As Byte
On Error GoTo ErrSub 'error handling

Dim Value As Integer
Dim i As Integer
Dim byte_mask As Integer
Dim r As Integer
Dim c As Integer
Dim pixel As Integer
Dim clrr As Byte
Dim clrg As Byte
Dim clrb As Byte
Dim color_mask As Integer

byte_mask = 1
For i = 1 To 8
    'pick a random pixel and RGB
    PickPosition used_positions, iWidth, iHeight, r, c, pixel

'find out each specific pixel's colouring
UnRGB picImage.Point(r, c), clrr, clrg, clrb

Select Case pixel 'update with the new colour
Case 0
    color_mask = (clrr And &H1)
Case 1
    color_mask = (clrg And &H1)
Case 2
    color_mask = (clrb And &H1)
End Select

If color_mask Then
    Value = Value Or byte_mask
End If

byte_mask = byte_mask * 2

Next i

DecodeByte = CByte(Value)

ErrSub: 'error handling
If Err.Number <> 0 Then
    MsgBox (Err.Number & vbCrLf & Err.Description), vbCritical + vbOKOnly, "Error)"
End If

End Function


Private Sub PickPosition(ByVal used_positions As Collection, ByVal iWidth As Integer, ByVal iHeight As Integer, ByRef r As Integer, ByRef c As Integer, ByRef pixel As Integer)
'find an unused combination (R,C, Pixel)

Dim position_code As String

On Error Resume Next 'error handling

Do  'pick a position
    r = Int(Rnd * iWidth)
    c = Int(Rnd * iHeight)
    pixel = Int(Rnd * 3)

    'find out if we can use the position or not
    position_code = "(" & r & "," & c & "," & pixel & ")"
    used_positions.Add position_code, position_code

If Err.Number = 0 Then Exit Do
    Err.Clear
    
Loop

End Sub

Private Sub UnRGB(ByVal color As OLE_COLOR, ByRef r As Byte, ByRef g As Byte, ByRef b As Byte)
'sub to return the colour's values

    r = color And &HFF&
    g = (color And &HFF00&) \ &H100&
    b = (color And &HFF0000) \ &H10000
    
End Sub

Private Sub cmdDecode_Click() 'decode file
On Error GoTo ErrSub 'error handling

Dim msg_length As Byte
Dim msg As String
Dim ch As Byte
Dim i As Integer
Dim used_positions As Collection
Dim iWidth As Integer
Dim iHeight As Integer
Dim show_pixels As Boolean

If IsLoaded = False Then 'if no image is loaded
    MsgBox ("No file has been loaded, please select one."), vbCritical + vbOKOnly, "Error"
End If

Rnd -1
Randomize NumericPassword(txtPassword.Text)
'randomize the password

iWidth = picImage.ScaleWidth
iHeight = picImage.ScaleHeight
Set used_positions = New Collection

'decode the message length
msg_length = DecodeByte(used_positions, iWidth, iHeight)

For i = 1 To msg_length 'decode the message
    ch = DecodeByte(used_positions, iWidth, iHeight) 'by using the used positions...
    msg = msg & Chr$(ch)
Next i

picImage.Picture = picImage.Image

txtMessage.Text = msg 'set the message

If optRC4.Value = True Then 'if RC4 is selected
    txtMessage.Text = cRC4(txtMessage.Text, txtPassword.Text) 'decode the message using RC4
End If

ErrSub: 'error handling
If Err.Number <> 0 Then
    MsgBox (Err.Number & vbCrLf & Err.Description), vbCritical + vbOKOnly, "Error)"
Exit Sub
End If

End Sub

Private Sub cmdEncode_Click() 'encode file
On Error GoTo ErrSub

Dim msg As String
Dim i As Integer
Dim used_positions As Collection
Dim iWidth As Integer
Dim iHeight As Integer
Dim show_pixels As Boolean

If IsLoaded = False Then 'if no image is loaded
    MsgBox ("No file has been loaded, please select one."), vbCritical + vbOKOnly, "Error"
End If

If optRC4.Value = True Then 'if RC4 is selected
    txtMessage.Text = cRC4(txtMessage.Text, txtPassword.Text) 'then use RC4 to encode the message before we write it into the pic
End If

Rnd -1
Randomize NumericPassword(txtPassword.Text)
'randomize the password

iWidth = picImage.ScaleWidth
iHeight = picImage.ScaleHeight
msg = Left$(txtMessage.Text, 255)

Set used_positions = New Collection

'encode the message length
EncodeByte CByte(Len(msg)), used_positions, iWidth, iHeight

For i = 1 To Len(msg) 'length of message
    EncodeByte Asc(Mid$(msg, i, 1)), used_positions, iWidth, iHeight
Next i

picImage.Picture = picImage.Image

ErrSub: 'error handling
If Err.Number <> 0 Then
    MsgBox (Err.Number & vbCrLf & Err.Description), vbCritical + vbOKOnly, "Error)"
Exit Sub
End If

End Sub


Private Function NumericPassword(ByVal password As String) As Long
'This takes your password and generated a number combination
'based on it. This new number combination is used to encode
'the file. If you replace this with a commercial quality
'algorithm then it would be very, very hard to recover your
'message.

Dim Value As Long
Dim ch As Long
Dim shift1 As Long
Dim shift2 As Long
Dim i As Integer
Dim str_len As Integer

shift1 = 3
shift2 = 17

str_len = Len(password)
For i = 1 To str_len

ch = Asc(Mid$(password, i, 1))
Value = Value Xor (ch * 2 ^ shift1)
Value = Value Xor (ch * 2 ^ shift2)

shift1 = (shift1 + 7) Mod 19
shift2 = (shift2 + 13) Mod 23

Next i
NumericPassword = Value

End Function