fileio.cls

vb的一段加密算法

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "FileIO"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'作者：Guilty Gear   Mania Studio    2002/03/15
'=========文件加密类模块=========
'可采用自定义的加密算法,这里采用的是按位异或加密
'在子程序 MakePsw 中加入算法即可

Dim FileIn As String
Dim FileOut As String
Dim Fpct As Label  '<------------- |   这两者的可用性为较晚赋值者
Dim fpScBar As ProgressBar '<----- |
Dim iPswBox As TextBox
Dim IsBar As Boolean
Dim Buffer() As Byte
Dim pswRlt(1 To 16) As Byte
Dim isProccessing As Boolean
Const BLOCK_SIZE = 4096    '设置读写缓存块大小为 4K

'获得密匙输入框
Public Property Let pswBox(ByRef pswBox As TextBox)
   Set iPswBox = pswBox
   iPswBox.PasswordChar = "*"
      
End Property

'获取源文件
Public Property Let SourceFile(SourceFileName As String)
   FileIn = SourceFileName
End Property

Public Property Get SourceFile() As String
   SourceFile = FileIn
End Property

'获取目标文件
Public Property Let TargetFile(TargetFileName As String)
   FileOut = TargetFileName
End Property

Public Property Get TargetFile() As String
   TargetFile = FileOut
End Property

Public Property Get IsProccess() As Boolean
   IsProccess = isProccessing
End Property

'获取并初始化文件进度标签(Label)
Public Property Let FilePercentBox(ByRef fpBox As Label)
   Set Fpct = fpBox
   IsBar = False
   Fpct.Caption = ""
   Fpct.AutoSize = True
End Property

'获取并初始化文件进度滚动条(PrograssBar)
Public Property Let FilePrograssBar(ByRef fpBar As ProgressBar)
   Set fpScBar = fpBar
   IsBar = True
   With fpScBar
      .Scrolling = ccScrollingSmooth
      .Appearance = ccFlat
      .Max = 100
      .Min = 0
      .Value = 0
      .BorderStyle = ccFixedSingle
   End With
End Property

Public Function FixFile() As Long
On Error GoTo ofHandle
  
  Dim fFile As Integer
  Dim Blocks As Long, BytesLeft As Long
  Dim bufPsw(1 To 16) As Byte
  'Dim IsRepsw As String
  'Dim unPsw As Boolean
  'Dim IsSame As Boolean
  ReDim Buffer(1 To BLOCK_SIZE) As Byte
  
  Call MakePsw
  iPswBox.Text = ""
  Blocks = FileLen(FileIn) \ BLOCK_SIZE        '获取块数量
  BytesLeft = FileLen(FileIn) Mod BLOCK_SIZE   '获取剩余长度，单位：字节
  isProccessing = True
  
  Open FileIn For Binary As #1
  Open FileOut For Binary As #2
     
  '   Get #1, , IsRepsw
  '   Get #1, , bufPsw
  '   If IsRepsw = "pswt" Then
  '     IsSame = True
  '     For psi = 1 To 16
  '       If bufPsw(psi) <> pswRlt(psi) Then
  '          IsSame = False
  '       End If
  '     Next psi
  '     If Not IsSame Then
  '       MsgBox "Password wrong!"
  '       Exit Function
  '     End If
  '   ElseIf IsRepsw = "pswf" Then
  '     Close #1
  '     Open FileIn For Binary As #1
  '     IsRepsw = True
  '     Put #2, , IsRepsw
  '     Put #2, , pswRlt
  '   End If
     
     For i = 1 To Blocks
       Get #1, , Buffer
       For j = 1 To BLOCK_SIZE
          Buffer(j) = FixByte(Buffer(j), (j Mod 16) + 1)
       Next j
       Put #2, , Buffer
       If IsBar Then
           fpScBar.Value = Int((i / Blocks) * 100)
       Else
           Fpct.Caption = Int((i / Blocks) * 100) & "%"
       End If
       'DoEvents
     Next i
     
     '处理剩余部分
     ReDim Buffer(1 To BytesLeft) As Byte
     Get #1, , Buffer
     For j = 1 To BytesLeft
        Buffer(j) = FixByte(Buffer(j), (j Mod 16) + 1)
     Next j
     Put #2, , Buffer
     If IsBar Then
        fpScBar.Value = 100
     Else
        Fpct.Caption = "100%"
     End If
  Close #1
  Close #2
  MsgBox "Proccess finished !"
  If IsBar Then
     fpScBar.Value = 0
  Else
     Fpct.Caption = ""
  End If
  isProccessing = False
Exit Function
ofHandle:
  isProccessing = False
  FixFile = Err   ' <-------- 函数操作失败返回错误代码，成功则返回 0
  'Err.Raise Err  ' <-------- 错误处理
End Function


Private Function FixByte(SourceByte As Byte, pswN As Integer) As Byte
  Dim buf As Byte
  
  '对每字节进行加密
  '--------------------------
  
  buf = SourceByte Xor pswRlt(pswN)
  '--------------------------
  FixByte = buf
End Function

Private Sub MakePsw()
  Dim wordLen As Integer
  Dim iWord As String
  
  iWord = iPswBox.Text
  wordLen = Len(iWord)
  MsgBox "Password defined !" & Chr$(13) & "Length: " & wordLen & Chr$(13) & "Programmer:HD (Guilty Gear)"
  Select Case wordLen
     Case 0
        For i = 1 To 16
           pswRlt(i) = 125
        Next i
     Case Is > 16
        For i = 1 To 16
           pswRlt(i) = Asc(Mid(iWord, i, 1))
        Next i
     Case Else
        For i = 1 To wordLen
           pswRlt(i) = Asc(Mid(iWord, i, 1))
        Next i
        For i = wordLen + 1 To 16
           pswRlt(i) = 125
        Next i
  End Select
End Sub