frmmain.frm

对文件的加密解密

VERSION 5.00
Begin VB.Form frmMain 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "正在合并文件,请稍候..."
   ClientHeight    =   1005
   ClientLeft      =   45
   ClientTop       =   435
   ClientWidth     =   4680
   Icon            =   "frmMain.frx":0000
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   1005
   ScaleWidth      =   4680
   StartUpPosition =   2  '屏幕中心
   Begin VB.CommandButton Command1 
      Caption         =   "开始合并"
      Height          =   375
      Left            =   3345
      TabIndex        =   2
      Top             =   585
      Width           =   1260
   End
   Begin VB.CheckBox chkDel 
      Caption         =   "完成后删除合并文件"
      Height          =   225
      Left            =   105
      TabIndex        =   1
      Top             =   630
      Value           =   1  'Checked
      Width           =   2775
   End
   Begin VB.PictureBox Prg 
      Appearance      =   0  'Flat
      BackColor       =   &H00C00000&
      BorderStyle     =   0  'None
      ForeColor       =   &H80000008&
      Height          =   285
      Left            =   135
      ScaleHeight     =   285
      ScaleWidth      =   720
      TabIndex        =   0
      Top             =   165
      Width           =   720
   End
   Begin VB.Shape PrgTop 
      Height          =   345
      Left            =   105
      Top             =   135
      Width           =   4500
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Declare Sub InitCommonControls Lib "comctl32.dll" ()

Private Sub FORM_Initialize()
  InitCommonControls
End Sub
Private Sub Command1_Click()

  Dim fn1 As Byte
  Dim fn2 As Byte
  Dim meLen As Long
  Dim Buffer() As Byte
  Dim tmp As Byte
  Dim Num As Long
  Dim meFileName As String
  Dim FileName As String
  Dim FileName2 As String
  Dim i As Long

    meFileName = IIf(Right$(App.Path, 1) = "\", App.Path, App.Path & "\") & App.EXEName & ".exe"
    fn1 = FreeFile
    meLen = FileLen(meFileName)
    Open meFileName For Binary Access Read As #fn1
    Get #fn1, meLen, tmp
    tmp = Val(Chr$(tmp))
    ReDim Buffer(1 To tmp)
    Get #fn1, meLen - tmp, Buffer()
    Num = Val(StrConv(Buffer(), vbUnicode))
    FileName = Left$(meFileName, InStrRev(meFileName, ".") - 1)
    Prg.Visible = True
    Prg.Width = 1
    If Len(Dir$(FileName)) > 0 Then
        If MsgBox("目标文件 " & FileName & " 已存在,是否覆盖?", vbYesNo + vbExclamation, "目标文件存在") = vbYes Then
            On Error Resume Next
              Kill FileName
            On Error GoTo 0
            If Err.Number > 0 Then
                MsgBox "无法删除目标文件,可能目标文件正在使用,请关闭目标文件后再运行本程序.", vbCritical, "无法删除"
                End
            End If
          Else
            End
        End If
    End If
    fn1 = FreeFile
    Open FileName For Binary As #fn1
    For i = 1 To Num
        FileName2 = FileName & "." & Format(i, String(Len(CStr(Num)), "0"))
        If Len(Dir$(FileName2)) > 0 Then
            fn2 = FreeFile
            ReDim Buffer(1 To FileLen(FileName2))
            Open FileName2 For Binary As #fn2
            Get #fn2, , Buffer()
            Close #fn2
            Put #fn1, , Buffer
          ElseIf MsgBox("文件 " & FileName2 & " 没有找到,继续合并后的文件可能有缺损.是否继续合并?", vbExclamation + vbYesNo) = vbNo Then
            Exit For
        End If
        On Error Resume Next
        Prg.Width = i / Num * PrgTop.Width - 60
        On Error GoTo 0
        DoEvents
    Next i
    
    Close #fn1
    If i <= Num Then
        Kill FileName
      ElseIf chkDel.Value = 1 Then
        On Error Resume Next
          For i = 1 To Num
              FileName2 = FileName & "." & Format(i, String(Len(CStr(Num)), "0"))
              Kill FileName2
          Next i
        On Error GoTo 0
    End If
    
    MsgBox "文件合并完毕!", vbInformation, "合并完毕"
    End

End Sub

Private Sub Form_Load()

    Prg.Visible = False
    Me.Caption = "文件合并"

End Sub