VB 版 (精华区)
发信人: student (earth), 信区: VB
标 题: 格式化软盘的源程序
发信站: 哈工大紫丁香 (2001年10月26日09:39:33 星期五), 站内信件
'.bas
Option Explicit
' ---------------------------------------------------------
' This BAS module retrieved from VBNet web pages and
' modified by me. Please visit them. They have a lot
' of neat VB code snippets.
'
' http://home.sprynet.com/sprynet/rasanen/vbnet/default.htm
' ---------------------------------------------------------
' ---------------------------------------------------------
' required for the RestorePreviousInstance routine
' ---------------------------------------------------------
Private Const SW_SHOWMINIMIZED = 2
Private Const SW_SHOWNORMAL = 1
Private Const SW_SHOWNOACTIVATE = 4
Private Const SW_RESTORE = 9
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type WINDOWPLACEMENT
Length As Long
flags As Long
showCmd As Long
ptMinPosition As POINTAPI
ptMaxPosition As POINTAPI
rcNormalPosition As RECT
End Type
' ---------------------------------------------------------
' Declares required for verifying a previous instance
' of program executiion
' ---------------------------------------------------------
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVa
l lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SetWindowPlacement Lib "user32" (ByVal hwnd As Lo
ng, lpwndpl As WINDOWPLACEMENT) As Long
Private Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As L
ong) As Long
Private Declare Function GetWindowPlacement Lib "user32" (ByVal hwnd As Lo
ng, lpwndpl As WINDOWPLACEMENT) As Long
' ---------------------------------------------------------
' required just for debugging puproses
' ---------------------------------------------------------
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA"
(ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Public Sub IsAnotherInstance(SApplName As String)
' ---------------------------------------------------------
' Call this module from the Sub Main()
' ---------------------------------------------------------
' ---------------------------------------------------------
' Define local variable
' ---------------------------------------------------------
Dim savetitle As String
' ---------------------------------------------------------
' Check for a previous instance of a program running
' ---------------------------------------------------------
If App.PrevInstance Then
'
' change the new instance title to prevent it
' from being located instead of the original
' instance. Note however that as this is in
' a BAS module and not the form load sub,
' change "pgm_name" to the name of the application
' that you do not a dupliate instance of.
savetitle = App.Title
App.Title = SApplName ' name of executable here(w/o .exe)
'-------------------------------------------------------------------
' some debug stuff - remove for live use
'MsgBox "about to re-activate the original instance of " & savetitle
'-------------------------------------------------------------------
RestorePreviousInstance savetitle
End
End If
End Sub
Public Sub Main()
' ---------------------------------------------------------
' Set up the path where all of the mail processing
' will take place.
' ---------------------------------------------------------
ChDrive App.Path
ChDir App.Path
' ---------------------------------------------------------
' See if there is another instance of this program running
' ---------------------------------------------------------
IsAnotherInstance "cleana"
' ---------------------------------------------------------
' Load the main form
' ---------------------------------------------------------
Load frmCleanA
End Sub
Public Sub RestorePreviousInstance(prevTitle As String)
' ---------------------------------------------------------
' Define local variable
' ---------------------------------------------------------
Dim lRetVal As Long
Dim hPrevWin As Long
Dim lpString As String
Dim currWinP As WINDOWPLACEMENT
' ---------------------------------------------------------
' VB3 & VB4 use class name "ThunderRTForm"
' VB5 uses class name "ThunderRT5Form"
'
' Including the class name for the compiled EXE class
' prevents the routine from finding and attempting
' to activate the project form of the same name.
' ---------------------------------------------------------
hPrevWin = FindWindow("ThunderRT5Form", prevTitle)
DoEvents
' ---------------------------------------------------------
' If found
' ---------------------------------------------------------
If hPrevWin > 0 Then
'-------------------------------------------------------------------
' some debug stuff - remove for live use
' this is just to verify that the title
' found was the title intended.
'
' lpString = Space(256)
' lRetVal = GetWindowText(hPrevWin, lpString, 256)
' MsgBox "GetWindowText verifies the title as - " & Left(lpString, s)
'-------------------------------------------------------------------
' get the current window state of the previous instance
currWinP.Length = Len(currWinP)
lRetVal = GetWindowPlacement(hPrevWin, currWinP)
' if the currWinP.showCmd member indicates that
' the window is currently minimized, it needs
' to be restored, so ...
If currWinP.showCmd = SW_SHOWMINIMIZED Then
currWinP.Length = Len(currWinP)
currWinP.flags = 0&
currWinP.showCmd = SW_SHOWNORMAL
lRetVal = SetWindowPlacement(hPrevWin, currWinP)
End If
' bring the window to the front and make
' the active window. Without this, it
' may remain behind other windows.
lRetVal = SetForegroundWindow(hPrevWin)
DoEvents
' -------------------------------------------------------------------
' More debug stuff. Comment out the ELSE condition for live use
'
' Else
' MsgBox "FindWindow failed on " & prevTitle
' -------------------------------------------------------------------
End If
End Sub
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 "GetDiskFree
SpaceA" (ByVal lpRootPathName As String, lpSectorsPerCluster As Long, lpByte
sPerSector 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 "SHFileOpe
rationA" (lpFileOp As SHFILEOPSTRUCT) As Long
Public Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileN
ameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUniq
ue As Long, ByVal lpTempFileName As String) As Long
Public Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (B
yVal 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_SIMPLEPROGRES
S
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
'frm
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 + vbApplicat
ionModal + 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
Option Explicit
Private Sub Form_Load()
frmWorking.Show vbModeless
frmWorking.Refresh
End Sub
--
※ 来源:·哈工大紫丁香 bbs.hit.edu.cn·[FROM: student.pact.hit.edu]
Powered by KBS BBS 2.0 (http://dev.kcn.cn)
页面执行时间：215.276毫秒