Copiar Ficheros con porcentajes

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

     mkid As SHITEMID
End Type

     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_STATUSTEXT = &H4

'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)
    If BTest < BUFSIZE Then
       Chunk = BTest
       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
    'Please use this project and all of its source code however you want.
    '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.
    '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.
    '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:
    'My web site is:
    'Please visit my web site and find many other useful projects like this.
End Sub

Colaboración enviada por Oscar Di Criscenzo



Introduce tus datos o haz clic en un icono para iniciar sesión:

Logo de

Estás comentando usando tu cuenta de Cerrar sesión /  Cambiar )

Google photo

Estás comentando usando tu cuenta de Google. Cerrar sesión /  Cambiar )

Imagen de Twitter

Estás comentando usando tu cuenta de Twitter. Cerrar sesión /  Cambiar )

Foto de Facebook

Estás comentando usando tu cuenta de Facebook. Cerrar sesión /  Cambiar )

Conectando a %s