cleana.frm

格式化软盘的VB源代码

VERSION 4.00
Begin VB.Form frmCleanA 
   BackColor       =   &H00FFFF00&
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Diskette Secure Erase"
   ClientHeight    =   1755
   ClientLeft      =   3870
   ClientTop       =   4020
   ClientWidth     =   3270
   Height          =   2160
   Icon            =   "Cleana.frx":0000
   Left            =   3810
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   1755
   ScaleWidth      =   3270
   Top             =   3675
   Width           =   3390
   Begin VB.PictureBox Picture1 
      Appearance      =   0  'Flat
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      BackColor       =   &H80000005&
      ForeColor       =   &H80000008&
      Height          =   510
      Left            =   240
      Picture         =   "Cleana.frx":08CA
      ScaleHeight     =   480
      ScaleWidth      =   480
      TabIndex        =   3
      Top             =   240
      Width           =   510
   End
   Begin VB.CommandButton cmdExit 
      Caption         =   "Exit"
      Height          =   375
      Left            =   1920
      TabIndex        =   1
      Top             =   1320
      Width           =   1215
   End
   Begin VB.CommandButton cmdStart 
      Caption         =   "Start"
      Height          =   375
      Left            =   1920
      TabIndex        =   0
      Top             =   840
      Width           =   1215
   End
   Begin VB.Label Label4 
      BackStyle       =   0  'Transparent
      Caption         =   "1.44mb Only"
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   255
      Left            =   120
      TabIndex        =   6
      Top             =   840
      Width           =   1335
   End
   Begin VB.Label Label3 
      BackStyle       =   0  'Transparent
      Caption         =   "Kenneth Ives"
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   -1  'True
         Strikethrough   =   0   'False
      EndProperty
      Height          =   255
      Left            =   120
      TabIndex        =   5
      Top             =   1440
      Width           =   1575
   End
   Begin VB.Label Label2 
      BackStyle       =   0  'Transparent
      Caption         =   "Written by"
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   -1  'True
         Strikethrough   =   0   'False
      EndProperty
      Height          =   255
      Left            =   120
      TabIndex        =   4
      Top             =   1200
      Width           =   1455
   End
   Begin VB.Label Label1 
      Alignment       =   2  'Center
      BackStyle       =   0  'Transparent
      Caption         =   "Clean a disk in drive A: so data cannot be retrieved."
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   495
      Left            =   840
      TabIndex        =   2
      Top             =   240
      Width           =   2415
   End
End
Attribute VB_Name = "frmCleanA"
Attribute VB_Creatable = False
Attribute VB_Exposed = False


Option Explicit

Private Sub cmdExit_Click()

' ---------------------------------------------------------
' Unload this form.  Now we go to Form_Unload()
' ---------------------------------------------------------
  Unload frmCleanA    ' deactivate this form

End Sub


Private Sub cmdStart_Click()

' ---------------------------------------------------
' Define local variables
' ---------------------------------------------------
  Dim i As Integer
  Dim fintResponse As Integer
  Dim fstrMsgText As String
  Dim GoodReturn As Boolean
  Dim NoDataOnDisk As Boolean
  
' ---------------------------------------------------
' initialize variables
' ---------------------------------------------------
  NoDataOnDisk = False

' ---------------------------------------------------
' Hide this form
' ---------------------------------------------------
  frmCleanA.Hide
  
' ---------------------------------------------------
' Some say that this is very bad coding.  I feel
' it gets the job done.
' ---------------------------------------------------
TryAgain:

  fstrMsgText = ""
  fstrMsgText = "Insert the disk you want cleaned into drive A:  "
  fintResponse = MsgBox(fstrMsgText, vbOKCancel + vbInformation + vbApplicationModal + vbDefaultButton1, "Insert disk")
 
  Select Case fintResponse
         Case vbOK
              ' verify disk is in drive A:
              On Error Resume Next
              IIf Dir("A:\", vbDirectory) <> "", True, False
              If Err <> 0 Then GoTo TryAgain
              On Error GoTo 0
 
         Case vbCancel
              GoTo LeaveHere
  End Select
    
' ---------------------------------------------------
' See if the disk is ready
' ---------------------------------------------------
  On Error Resume Next
  Open "A:\X" For Output As #1
  
  If Err <> 0 Then
      MsgBox "Is the disk write protected?", vbOKOnly, "Disk Error"
      On Error GoTo 0
      GoTo TryAgain
  End If
  
  Close #1
  On Error GoTo 0
  
' ---------------------------------------------------
' display the working form
' ---------------------------------------------------
  Load frmWorking
  With frmWorking.lblStatus
       .Caption = "Erasing VTOC"
       .Refresh
  End With
  
' ---------------------------------------------------
' Build a DOS batch file to perform a quick format
' ---------------------------------------------------
  BuildFormatBatFile "A:"
  RunDosShell FMT_BAT_FILE, FMT_KEY_FILE
  
' ---------------------------------------------------
' Build a dummy file filled with NUll = Chr(0)
' ---------------------------------------------------
  With frmWorking.lblStatus
       .Caption = "Filling disk with Hex 00"
       .Refresh
  End With
  
  GoodReturn = BuildDummyFile(0)
  If Not GoodReturn Then GoTo LeaveHere
  
' ---------------------------------------------------
' Build a dummy file filled with Hex FF = Chr(255)
' ---------------------------------------------------
  With frmWorking.lblStatus
       .Caption = "Now filling disk with Hex FF"
       .Refresh
  End With
  
  GoodReturn = BuildDummyFile(255)
  If Not GoodReturn Then GoTo LeaveHere
  
' ---------------------------------------------------
' Build a batch file to perform a quick format
' ---------------------------------------------------
  With frmWorking.lblStatus
       .Caption = "Erasing VTOC again"
       .Refresh
  End With
  
  BuildFormatBatFile "A:"
  RunDosShell FMT_BAT_FILE, FMT_KEY_FILE
  
' ---------------------------------------------------
' Hide the working form and display a message box
' ---------------------------------------------------
  frmWorking.Hide
  MsgBox "You may now remove the diskette from drive A:"
  
  
LeaveHere:
  
' ---------------------------------------------------
' See if frmWorking was loaded.  If so, then
' unload it and redisplay the original screen
' ---------------------------------------------------
  For i = 0 To Forms.Count - 1
      If Forms(i).Caption = "Work in progress" Then
          Unload frmWorking
          Set frmWorking = Nothing
          Exit For
      End If
  Next
      
' ---------------------------------------------------
' Redisplay the original screen with little or no
' flickering.
' ---------------------------------------------------
  frmCleanA.Show vbModeless
  frmCleanA.Refresh
  
End Sub

Private Sub Form_Load()

' ---------------------------------------------------------
' display the form with little or no flicker
' ---------------------------------------------------------
  frmCleanA.Show vbModeless
  frmCleanA.Refresh
  
End Sub

Private Sub Form_Unload(Cancel As Integer)

' ---------------------------------------------------------
' free memory allocation
' ---------------------------------------------------------
  Set frmCleanA = Nothing
  
End Sub