Formatando Disket, c/ mais Eficiencia

[DaRkS.222 1]

<div align='left'>Programa para Formata Disket Com mais Eficiencia.

 

1º Crie Dois Forms, Nomeio o Form 1 para frmCleanA

e Form 2 para frmWorking

 

2º No frmCleanA Crie 2 CommandButton, Nas Propiedades Mude:

 

- Name: cmdStart

- Capiton: Start

- TabIndex: 1

 

e o Outro CommandButton Mude:

 

- Name: cmdExit

- Capiton: Exit

- TabIndex: 0

 

3º No frmCleanA Abra ah Janela de Codigo, apague tudo que estiver escrito ih Coloque o seguntei codigo:

<div class='codetop'>CODE</div><div class='codemain' style='height:200px;white-space:pre;overflow:auto'>

 

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

Private Sub Label2_Click()

 

End Sub</div>

 

4º No frmWorking crie um Label, nas Propiedades Mude:

 

- Name: lblStatus

- Alignmet: 2-Center

- BackColor: Coloque ah Cor Branca

- BorderStyle: 1-Fixed Sing

- TabIndex: 7

 

5º No frmWorking Abra ah Janela de Codigo, apague tudo que estiver escrito ih Coloque o seguntei codigo:

<div class='codetop'>CODE</div><div class='codemain' style='height:200px;white-space:pre;overflow:auto'>

 

Option Explicit

 

Private Sub Form_Load()

 

frmWorking.Show vbModeless

frmWorking.Refresh

 

End Sub</div>

 

6º Agora Crie 2 Modulos, Mude o Nome do 1º para basPrevInst e o 2º basSHFileOp

 

7º no basPrevInst Adicione o Seguinte Codigo:

<div class='codetop'>CODE</div><div class='codemain' style='height:200px;white-space:pre;overflow:auto'>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</div>

 

8º No basSHFileOp, Coloque o Outro Codigo:

<div class='codetop'>CODE</div><div class='codemain' style='height:200px;white-space:pre;overflow:auto'>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</div>

 

Pronto ;D

Eu Tentei Fazer um Codigo Baseado nessa Para Disfragmentar a Unidade "C:\"

Ih Tbm Para Deletar os Arquivos que quizer nos "Cds-RW"....

Eu To Conseguindo Fazer, mais ainda tah dando alguns erros, qdo eu conseguir fazer

fucionar completamente eu Posto aki no Forum.!

.Creditos: ScriptBR

Flwz.</div>

[.DnL 0]

kkkkkkkkk q foda goste pacas disso uasfhuashf

tu q sabe pacas disso podia posta mais coisas assim XD

flw ae

[Be_Killer 2]

Gostei xD.

Vlw e isso ae podia postar mais msm