shfileop.bas

格式化软盘的VB源代码

Attribute VB_Name = "basSHFileOp"
Option Explicit

' ---------------------------------------------------------
' Constants and variables
' ---------------------------------------------------------
  Public Const ASCII_TEST_FILE = "A:\X"
  Public Const FMT_BAT_FILE = "BFormat.bat"
  Public Const FMT_KEY_FILE = "BFormat.key"

' ---------------------------------------------------------
' Declare, Type, and variable needed to obtain
' free disk space information
' ---------------------------------------------------------
  Public Type DISKSPACEINFO
       RootPath As String * 3
       FreeBytes As Long
       TotalBytes As Long
       FreePcnt As Single
       UsedPcnt As Single
  End Type
 
  Public DskInfo As DISKSPACEINFO

  Public Declare Function GetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceA" (ByVal lpRootPathName As String, lpSectorsPerCluster As Long, lpBytesPerSector As Long, lpNumberOfFreeClusters As Long, lpTotalNumberOfClusters As Long) As Long

' ------------------------------------------------------------------------
' TYPE required for SHFileOperation API call
' ------------------------------------------------------------------------
  Public Type SHFILEOPSTRUCT
          hwnd As Long
          wFunc As Long
          pFrom As String
          pTo As String
          fFlags As Integer
          fAnyOperationsAborted As Long
          hNameMappings As Long
          lpszProgressTitle As String '  only used if FOF_SIMPLEPROGRESS
  End Type
  
  Public FileOp As SHFILEOPSTRUCT

' ------------------------------------------------------------------------
' Function constants
' ------------------------------------------------------------------------
  Public Const FO_COPY = &H2
  Public Const FO_DELETE = &H3
  Public Const FO_MOVE = &H1
  Public Const FO_RENAME = &H4
  
' ------------------------------------------------------------------------
' Flags that control the file operation. This member can be a
' combination of the following values:
'
' FOF_ALLOWUNDO           Preserves undo information, if possible.
' FOF_CONFIRMMOUSE        Not implemented.
' FOF_FILESONLY           Performs the operation only on files if
'                         a wildcard filename (*.*) is specified.
' FOF_MULTIDESTFILES      Indicates that the pTo member specifies
'                         multiple destination files (one for each
'                         source file) rather than one directory
'                         where all source files are to be deposited.
' FOF_NOCONFIRMATION      Responds with "yes to all" for any dialog
'                         box that is displayed.
' FOF_NOCONFIRMMKDIR      Does not confirm the creation of a new
'                         directory if the operation requires one to
'                         be created.
' FOF_RENAMEONCOLLISION   Gives the file being operated on a new name
'                         (such as "Copy #1 of...") in a move, copy,
'                         or rename operation if a file of the target
'                         name already exists.
' FOF_SILENT              Does not display a progress dialog box.
' FOF_SIMPLEPROGRESS      Displays a progress dialog box, but does
'                         not show the filenames.
' FOF_WANTMAPPINGHANDLE   Fills in the hNameMappings member.
' ------------------------------------------------------------------------
  Public Const FOF_ALLOWUNDO = &H40
  Public Const FOF_CONFIRMMOUSE = &H2
  Public Const FOF_FILESONLY = &H80
  Public Const FOF_MULTIDESTFILES = &H1
  Public Const FOF_NOCONFIRMATION = &H10
  Public Const FOF_NOCONFIRMMKDIR = &H200
  Public Const FOF_RENAMEONCOLLISION = &H8
  Public Const FOF_SILENT = &H4
  Public Const FOF_SIMPLEPROGRESS = &H100
  Public Const FOF_WANTMAPPINGHANDLE = &H20

' ------------------------------------------------------------------------
' Declares required for SHFileOperation API call
' ------------------------------------------------------------------------
  Public Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
  Public Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long
  Public Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Public Sub GetDiskSpace()

' ------------------------------------------------------
' Define local variables
' ------------------------------------------------------
  Dim SxC As Long         ' Sectors Per Cluster
  Dim BxS As Long         ' Bytes Per Sector
  Dim NOFC As Long        ' Number Of Free Clusters
  Dim TNOC As Long        ' Total Number Of Clusters
  Dim lRetVal As Long
  
' ------------------------------------------------------
' Make API call to get disk infomation
' ------------------------------------------------------
  lRetVal = GetDiskFreeSpace(DskInfo.RootPath, SxC, BxS, NOFC, TNOC)

' ------------------------------------------------------
' If it was a good call, then separate the information
' ------------------------------------------------------
  With DskInfo
        If lRetVal Then
            .FreeBytes = BxS * SxC * NOFC
            .TotalBytes = BxS * SxC * TNOC
            .FreePcnt = ((.TotalBytes - .FreeBytes) / .TotalBytes) * 100
            .UsedPcnt = (.FreeBytes / .TotalBytes) * 100
        Else
            .FreeBytes = 0
            .TotalBytes = 0
            .FreePcnt = 0
            .UsedPcnt = 0
        End If
  End With

End Sub

Public Sub BuildFormatBatFile(sDriveLetter As String)

' --------------------------------------------------------
' sDriveLetter = "A:"
' --------------------------------------------------------
  
' --------------------------------------------------------
' Define local variables
' --------------------------------------------------------
  Dim iFile As Integer
  Dim sFormatCmd As String
  
' --------------------------------------------------------
' Initialize variables
' --------------------------------------------------------
  iFile = FreeFile
  sFormatCmd = "Format.com " & sDriveLetter & " /q/u<" & FMT_KEY_FILE
  
' --------------------------------------------------------
' build the DOS batch file that will do the quick format
' --------------------------------------------------------
  Open FMT_BAT_FILE For Output As #iFile
  Print #iFile, "@echo off"
  Print #iFile, sFormatCmd
  Print #iFile, "del bformat.key"
  Close #iFile

' --------------------------------------------------------
' Build the key file that will answer the DOS Format.COM
' prompts
' --------------------------------------------------------
  Open FMT_KEY_FILE For Output As #iFile
  Print #iFile, vbCrLf & vbCrLf & "n" & vbCrLf
  Close #iFile
   
End Sub
Public Sub Delay(lAmtOfDelay As Long)

' -----------------------------------------------------------
' This routine will cause a delay for the time requested,
' yet will not interrupt with the program progress like the
' Sleep API.  The Sleep API will stop all processing while
' it is sleeping.  We also do not need a timer control.
'
' Parameters:
'       lAmtOfDelay - amount of time to delay
' -----------------------------------------------------------

' -----------------------------------------------------------
' Define local variables
' -----------------------------------------------------------
  Dim vDelayTime As Variant
  
' -----------------------------------------------------------
' Determine the length of time to delay using the
' VB DateAdd function.  These options could also be
' variables.
'
'    "s" - seconds
'    "n" - minutes
'    "h" - hours
'
' We are adding the amount of delay to the current time
' -----------------------------------------------------------
  vDelayTime = DateAdd("s", lAmtOfDelay, Now)

' -----------------------------------------------------------
' Loop thru and continualy check the curent time with the
' calculated time so we know when to leave
' -----------------------------------------------------------
  Do
      If Now < vDelayTime Then
          ' Let the application do its work
          DoEvents
      Else
          Exit Do
      End If
  Loop

End Sub
Public Function FileExist(Filename As String) As Boolean

' -----------------------------------------------------------
' If there is an error, ignore it
' -----------------------------------------------------------
  On Error Resume Next
  
' -----------------------------------------------------------
' See if the File exist then return TRUE else FALSE
' -----------------------------------------------------------
  FileExist = IIf(Dir(Filename) <> "", True, False)

' -----------------------------------------------------------
' Nullify the "On Error" routine now that we are
' finished here
' -----------------------------------------------------------
  On Error GoTo 0
  
End Function

Public Function BuildDummyFile(iChar As Integer) As Boolean

On Error GoTo Data_Errors
' ---------------------------------------------------
' Define local variables
' ---------------------------------------------------
  Dim iFile As Integer
  Dim i As Integer
  Dim sRec1 As String
  Dim sRec2 As String
  Dim sMsg As String
  Dim lBuffersize As Long
  
' ---------------------------------------------------
' initialize variables
' ---------------------------------------------------
  sMsg = ""                     ' Empty the error message string
  iFile = FreeFile              ' get first available file handle
  lBuffersize = 1457664         ' Max size of 1.44mb disk in bytes
  
  ' 2 bytes short to accomodate the carriage return and linefeed
  ' that VB adds when a record is written to a file
  sRec1 = String(32766, iChar)
  sRec2 = String(15870, iChar)
  
' ------------------------------------------------------------
' See if we have enough free space to do our job
' ------------------------------------------------------------
  DskInfo.RootPath = "A:\"
  GetDiskSpace

' ------------------------------------------------------------
' If we have a space problem.  Display a message.
' ------------------------------------------------------------
  If (lBuffersize > DskInfo.FreeBytes) Then
       sMsg = "Are you viewing a file on this disk with another tool?    " & vbCrLf
       sMsg = sMsg & "Please point the tool somewhere else or close it.  " & vbCrLf & vbCrLf
       sMsg = sMsg & "If not, then there may be some bad clusters here.  " & vbCrLf
       sMsg = sMsg & "Discard the disk or try again.  Thank you."
       '
       MsgBox sMsg, vbQuestion + vbOKOnly, "Disk Access Error"
       BuildDummyFile = False
       Exit Function
  End If
      
' ---------------------------------------------------
' open the new file on drive A: and write data that
' is in 32k chunks except for the last write,
' which is 15872 bytes.  This way, we save on memory
' allocations.
' ---------------------------------------------------
  Open ASCII_TEST_FILE For Output As #iFile
  
  ' write a total of 1441792 bytes
  For i = 1 To 44
      Print #iFile, sRec1
  Next
  
  ' Write the last record to the disk (15872 bytes)
  Print #iFile, sRec2
  Close #iFile
  
' ---------------------------------------------------
' Delete the file on drive A:
' ---------------------------------------------------
  Kill ASCII_TEST_FILE
  
' ---------------------------------------------------
' Now leave
' ---------------------------------------------------
  BuildDummyFile = True
  On Error GoTo 0       ' Nullify the "On Error" in this routine
  Exit Function
  
' ---------------------------------------------------
' initialize variables
' ---------------------------------------------------
Data_Errors:
  
  sMsg = "Did someone remove the disk or is it damaged?  " & vbCrLf & vbCrLf
  sMsg = sMsg & "Error: " & Err.Number & vbCrLf & Err.Description
  
  MsgBox sMsg, vbQuestion + vbOKOnly, "Disk Access Error"
  BuildDummyFile = False
  Close #iFile
  
  On Error GoTo 0      ' Nullify the "On Error" in this routine
  
End Function
Public Function RemoveAllData() As Boolean
  
' ---------------------------------------------------
' Define local variables
' ---------------------------------------------------
  Dim lReturn As Long

On Error GoTo Disk_Errors
' ---------------------------------------------------
' Make source path the current directory
' ---------------------------------------------------
  ChDrive "A:\"
  ChDir "A:\"

' ---------------------------------------------------
' open the new file on drive A: and write one
' long record to it
' ---------------------------------------------------
  Open "A:\X" For Output As #1
  Close #1

' ---------------------------------------------------
' Options
' ---------------------------------------------------
  With FileOp
       .hwnd = 0                  ' Parent window of dialog box
       .wFunc = FO_DELETE         ' ID the function to do a delete
       .pFrom = "A:\" & Chr(0)    ' ID the drive
       ' do not prompt the user
       .fFlags = FOF_NOCONFIRMATION + FOF_NOCONFIRMMKDIR + FOF_SIMPLEPROGRESS
  End With
  
' ---------------------------------------------------
' Call SHFileOperation API
' ---------------------------------------------------
  lReturn = SHFileOperation(FileOp)
  
' ---------------------------------------------------
' Check the return value.  If non-zero the FALSE
' ---------------------------------------------------
  If lReturn <> 0 Then
      MsgBox "Did not complete operation successfully."
      RemoveAllData = False
  Else
      RemoveAllData = True
  End If

  On Error GoTo 0      ' Nullify the "On Error" in this routine

  Exit Function
  

Disk_Errors:
  
  MsgBox "Did not complete operation successfully." & vbCrLf & vbCrLf & _
         "Error: " & Err.Number & vbCrLf & Err.Description, vbOKOnly, "Error Message"
  RemoveAllData = False
  On Error GoTo 0      ' Nullify the "On Error" in this routine

End Function

Public Sub RunDosShell(sBatchFile As String, sDummyFile As String)

' ---------------------------------------------------------
' Note:  I use "Command.com /c" to prefix the batchfile.
'        This ensures that the DOS window will close upon
'        completion.
' ---------------------------------------------------------
  Dim lRetVal As Long

  lRetVal = Shell("Command.com /c " & sBatchFile, 0)
  
  Do
      If FileExist(sDummyFile) Then
          Delay 5     ' Delay for 5 seconds before checking again
      Else
          Exit Do
      End If
  Loop
  
' ---------------------------------------------------------
' Now we delete the batch file
' ---------------------------------------------------------
  If FileExist(sBatchFile) Then
      Kill sBatchFile
  End If
  
End Sub