Con este proyecto se muestra como copiar un fichero representando el porcentaje procesado.
El proyecto abre en binario el fichero de origen y traslada la información al fichero de destino (también abierto en modo Binario).
Aquí esta el código:
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, _ ByVal pszPath As String) As Long Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hwndOwner As Long, ByVal nFolder As Long, _ pidl As ITEMIDLIST) As Long Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" _ (lpBrowseInfo As BROWSEINFO) As Long Private Type SHITEMID cb As Long abID As Byte End Type Private Type ITEMIDLIST mkid As SHITEMID End Type Private Type BROWSEINFO hOwner As Long pidlRoot As Long pszDisplayName As String lpszTitle As String ulFlags As Long lpfn As Long lParam As Long iImage As Long End Type Private Const NOERROR = 0 Private Const BIF_RETURNONLYFSDIRS = &H1 Private Const BIF_DONTGOBELOWDOMAIN = &H2 Private Const BIF_STATUSTEXT = &H4 Private Const BIF_RETURNFSANCESTORS = &H8 Private Const BIF_BROWSEFORCOMPUTER = &H1000 Private Const BIF_BROWSEFORPRINTER = &H2000 'This code is used to copy the file provided in the Source text box. The 'file is calculated and then copied to the destination path while advancing 'the progress bar at the same time. Function CopyFile(Src As String, Dst As String) As Single Static Buf$ Dim BTest!, FSize! 'declare the needed variables Dim Chunk%, F1%, F2% Const BUFSIZE = 1024 'set the buffer size If Len(Dir(Dst)) Then 'check to see if the destination file already exists 'prompt the user with a message box Response = MsgBox(Dst + Chr(10) + Chr(10) + "File already exists. Do you want to overwrite it?", _ vbYesNo + vbQuestion) If Response = vbNo Then 'if the "No" button was clicked Exit Function 'exit the procedure Else 'otherwise Kill Dst 'delete the already found file, and carryon with the code End If End If On Error GoTo FileCopyError 'incase of error goto this label F1 = FreeFile 'returns file number available Open Src For Binary As F1 'open the source file F2 = FreeFile 'returns file number available Open Dst For Binary As F2 'open the destination file FSize = LOF(F1) BTest = FSize - LOF(F2) Do If BTest < BUFSIZE Then Chunk = BTest Else Chunk = BUFSIZE End If Buf = String(Chunk, " ") Get F1, , Buf Put F2, , Buf BTest = FSize - LOF(F2) ProgressBar.Value = (100 - Int(100 * BTest / FSize)) 'advance the progress bar as the file is copied Loop Until BTest = 0 Close F1 'closes the source file Close F2 'closes the destination file CopyFile = FSize ProgressBar.Value = 0 'returns the progress bar to zero Exit Function 'exit the procedure FileCopyError: 'file copy error label MsgBox "Copy Error!, Please try again..." 'display message box with error Close F1 'closes the source file Close F2 'closes the destination file Exit Function 'exit the procedure End Function 'This code is used to extract the filename provided by the user from the 'Source text box. The filename is extracted and passed to the string 'SpecOut. Once the filename is extraced from the text box, it is then added 'to the destination path provided by the user. Public Function ExtractName(SpecIn As String) As String Dim i As Integer 'declare the needed variables Dim SpecOut As String On Error Resume Next 'ignore any errors For i = Len(SpecIn) To 1 Step -1 ' assume what follows the last backslash is the file to be extracted If Mid(SpecIn, i, 1) = "" Then SpecOut = Mid(SpecIn, i + 1) 'extract the filename from the path provided Exit For End If Next i ExtractName = SpecOut 'returns the extracted filename from the path End Function Private Sub Browsedestination_Click() Dim bi As BROWSEINFO 'declare the needed variables Dim rtn&, pidl&, path$, pos% bi.hOwner = Me.hWnd 'centres the dialog on the screen bi.lpszTitle = "Browse for Destination..." 'set the title text bi.ulFlags = BIF_RETURNONLYFSDIRS 'the type of folder(s) to return pidl& = SHBrowseForFolder(bi) 'show the dialog box path = Space(512) 'sets the maximum characters T = SHGetPathFromIDList(ByVal pidl&, ByVal path) 'gets the selected path pos% = InStr(path$, Chr$(0)) 'extracts the path from the string SpecIn = Left(path$, pos - 1) 'sets the extracted path to SpecIn If Right$(SpecIn, 1) = "" Then 'makes sure that "" is at the end of the path SpecOut = SpecIn 'if so then, do nothing Else 'otherwise SpecOut = SpecIn + "" 'add the "" to the end of the path End If 'merges both the destination path and the source filename into one string Destinationpath.Text = SpecOut + ExtractName(Filepath.Text) End Sub Private Sub Browsefile_Click() Dialog.DialogTitle = "Browse for source..." 'set the dialog title Dialog.ShowOpen 'show the dialog box Filepath.Text = Dialog.filename 'set the target text box to the file chosen End Sub Private Sub Cancel_Click() Unload Me 'exit the program End Sub Private Sub Copy_Click() On Error Resume Next 'ignore any errors If Filepath.Text = "" Then 'make sure that a target file is specified MsgBox "You must specify a file and path in the text box provided", vbCritical 'if not then display a message Exit Sub 'and exit the procedure End If If Destinationpath.Text = "" Then 'make sure that a destination path is specified MsgBox "You must specify a destination path in the text box provided", vbCritical 'if not then display a message Exit Sub 'and exit the procedure End If 'if all is OK then copy the file ProgressBar.Value = CopyFile(Filepath.Text, Destinationpath.Text) End Sub Private Sub FilePath_Change() Destinationpath.Enabled = True 'enables the destination path text box Browsedestination.Enabled = True 'enables the browse button Destinationpath.SetFocus 'puts the cursor in the desination path text box End Sub Private Sub Form_Load() Move (Screen.Width - Width) 2, (Screen.Height - Height) 2 'centre the form on the screen 'This project was downloaded from 'http://www.brianharper.demon.co.uk/ 'Please use this project and all of its source code however you want. 'UNZIPPING 'To unzip the project files you will need a 32Bit unzipper program that 'can handle long file names. If you have a latest copy of Winzip installed 'on your system then you may use that. If you however dont have a copy, 'then visit my web site, go into the files section and from there you can 'click on the Winzip link to goto their site and download a copy of the 'program. By doing this you will now beable to unzip the project files 'retaining their proper long file names. 'Once upzipped, load up your copy of Visual Basic and goto 'File/Open Project. Locate the project files to where ever you unzipped 'them, then click Open. The project files will be loaded and are now ready 'for use. 'THE PROJECT 'I created this project in order to try and spice up a menu system I was 'once working on. I needed to copy files betweem disks and needed some 'indication of how long it would take and how it was doing. Using a percent 'bar in the project would have been ideal. Percent bars are now used as a 'common method of indicating how a procedure is doing. They might not be '100% accurate but they are the next best thing. After hours of research 'and many hours of debugging, I finally came up with an easy to use 'executable using a percent bar while copying a file, which was ideally 'suited to what I needed. 'NOTES 'I have only provided the necessary project files with the zip. This keeps 'the size of the zip files down to a minimum and enables me to upload more 'prjects files to my site. 'I hope you find the project usful in what ever you are programming. I 'have tried to write out a small explanation of what each line of code 'does in the project, although most of it is pretty simple to understand. 'If you find any bugs in the code then please dont hesitate to Email me and 'I will get back to you as soon as possible. If you however need help on a 'different matter concerning Visual Basic then please please Email me as 'I like to here from people and here what they are programming. 'My Email address is: 'Brian@brianharper.demon.co.uk 'My web site is: 'http://www.brianharper.demon.co.uk/ 'Please visit my web site and find many other useful projects like this. End Sub
Colaboración enviada por Oscar Di Criscenzo