VB - Copiando arquivos com barra de progresso

Neste artigo vou mostrar , usando a forma estruturada e clássica de codificação , como copiar arquivos e exibir e acompanhar a tarefa por meio de uma barra de progresso.

O projeto e o código é simples mas pode servir de grande ajuda para quem esta começando agora com a linguagem VB.

Neste projeto eu vou o componente CommonDialog para exibir a janela Procurar Arquivo e vou  usar também uma API que será usada para fazer a mesma coisa. O objetivo é mostrar que você pode substituir o controle CommonDialog por uma API.

Inicie então uma nova versão do VB6 ou do VB5 ( o projeto roda nas duas versões) e no formulário principal inclua os controles conforme o layout abaixo:

Controles usados no projeto:

- 2 caixas de texto : caminhoOrigem.text e caminhoDestino.text

- 4 botões de comando - procuraOrigem e procuraDestino , Copiar e Encerra

- 1 Barra de Progresso - pbCopiaArquivos

- 1 CommonDialog - dialogo

- formulário CopiaArquivo.frm

- projeto : CopiarArquivos.vbp

Inclua no projeto um módulo .bas chamado - CopiaArq.bas e nele digite o código abaixo que irá declarar as API´s usadas para exibir a janela Procurar Arquivo:

Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hwndOwner As Long, ByVal nFolder As Long, pidl As ITEMIDLIST) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Type SHITEMID
  cb As Long
  abID As Byte
End Type

Type ITEMIDLIST
   mkid As SHITEMID
End Type

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

Public Const NOERROR = 0

Public Const BIF_RETURNONLYFSDIRS = &H1
Public Const BIF_DONTGOBELOWDOMAIN = &H2
Public Const BIF_STATUSTEXT = &H4
Public Const BIF_RETURNFSANCESTORS = &H8
Public Const BIF_BROWSEFORCOMPUTER = &H1000
Public Const BIF_BROWSEFORPRINTER = &H2000

Agora no formulário do projeto no evento Click do primeiro botão Procura para origem insira o seguinte código :

Private Sub procuraOrigem_Click()

Dialog.DialogTitle = "Procura origem..." 'define o titulo
Dialog.ShowOpen 'exibe o dialogo
caminhoOrigem.Text = Dialog.FileName 'define o texto da caixa de origem

End Sub

Este código irá abrir a janela de diálogo Procurar Arquivo

No evento Click do outro botão Procura para destino insira o código a seguir :

Private Sub procuraDestino_Click()
Dim bi As BROWSEINFO 'declara as variaveis
Dim rtn&
Dim pidl&
Dim path As String
Dim pos As Integer

bi.hOwner = Me.hWnd 'centraliza o dialogo na tela
bi.lpszTitle = "Procura destino..." 'define o titulo do texto
bi.ulFlags = BIF_RETURNONLYFSDIRS 'o tipo de pasta para retornar
pidl& = SHBrowseForFolder(bi) 'exibe o dialogo

path = Space(512) 'define o tamanho maximo
T = SHGetPathFromIDList(ByVal pidl&, ByVal path) 'obtem o caminho selecionado

pos% = InStr(path$, Chr$(0)) 'extrai o caminho da string
SpecIn = Left(path$, pos - 1) 'define o caminho extraido

If Right$(SpecIn, 1) = "\" Then 'esteja certo de que a barra "\" esta no fim do caminho
saida = SpecIn 'se nao estiver , nao faça nada
Else 'senao
saida = SpecIn + "\" 'inclui a barra "\" no fim do caminho
End If

caminhoDestino.Text = saida + ExtraiNome(caminhoOrigem.Text) 'monta o nome dos arquivos

End Sub

Este código também abre uma janela para Procurar Arquivos . mas usa a API do Windows. (Note que as janelas são diferentes)

No evento Click do botão - Copiar - inclua o código abaixo que irá chamar a rotina para efetuar a copia dos arquivos selecionados:

Private Sub Copiar_Click()
On Error Resume Next 'ignora quaisquer erros

If caminhoOrigem.Text = "" Then 'tenha certeza de que a origem foi informado
MsgBox "Você deve definir o nome e o caminho do arquivo de origem.", vbCritical 'se não informar exibe mensagem
Exit Sub 'sai da rotina
End If
If caminhoDestino.Text = "" Then 'tenha certeza de que o arquivo de destino foi informado
MsgBox "Você deve definir o nome e caminho do arquivo de destino.", vbCritical 'se nao informar exibe mensagem
Exit Sub 'sai da rotina
End If

'se tudo estiver correto então copia o arquivo
pbCopiaArquivos.Value = CopiarArquivo(caminhoOrigem.Text, caminhoDestino.Text)
End Sub

A função mais importante é a função CopiarArquivo() que possui o seguinte código :

Function CopiarArquivo(Origem As String, Destino As String) As Single

'declara as variaveis
Static Buf As String
Dim BTest As Long
Dim FSize As Long
Dim Chunk As Integer
Dim F1 As Integer
Dim F2 As Integer

Const BUFSIZE = 1024 'define o tamanho do buffer

If Len(Dir(Destino)) Then 'verifica se o arquivo de destino ja existe
Resposta = MsgBox(Destino + Chr(10) + Chr(10) +  _
"Arquivo já existe. Deseja sobrescrever o arquivo existente ?", vbYesNo + vbQuestion) 'exibe ao usuário uma caixa de mensagem
If Resposta = vbNo Then 'Se clicou no botão Não
Exit Function 'sai da rotina
Else 'senao
Kill Destino 'exclui o arquivo existente e continua a executar o codigo
End If
End If

On Error GoTo FileCopyError 'se houver erro trata aqui
F1 = FreeFile 'retorna o numero do arquivo disponivel
Open Origem For Binary As F1 'abre o arquivo de destino
F2 = FreeFile 'retorna o numero do arquivo disponivel
Open Destino For Binary As F2 'abre o arquivo de destino

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)

pbCopiaArquivos.Value = (100 - Int(100 * BTest / FSize)) 'avanca com a barra de progresso durante a copia

Loop Until BTest = 0
Close F1 'fecha o fonte
Close F2 'fecha o destino
CopiarArquivo = FSize

MsgBox "Arquivo copiado com sucesso.", vbInformation, "Copia com sucesso"

pbCopiaArquivos.Value = 0 'retorna a barra de progresso para o valor zero
Exit Function 'sai da rotina

FileCopyError: 'trata o erro aqui
MsgBox "Erro durante a copia...!, Tente novamente..." 'exibe mensagem de erro
Close F1 'fecha a fonte
Close F2 'fecha o destino
Exit Function 'sai da rotina

End Function

A função de suporte - ExtraiNome - que extrai o nome de um arquivo a partir de um caminho completo informado tem o seguinte código :

Public Function ExtraiNome(SpecIn As String) As String

Dim i As Integer
Dim saida As String

On Error Resume Next 'ignora qualquer erro

For i = Len(SpecIn) To 1 Step -1
If Mid(SpecIn, i, 1) = "\" Then
saida = Mid(SpecIn, i + 1) 'extrai o nome do arquivo do caminho
Exit For
End If
Next i

ExtraiNome = saida 'retorna o nome do arquivo extraido
End Function

Finalmente no evento Change da caixa de texto caminhoOrigem para habilitar a segunda caixa de texto quando algo for informado.

Private Sub caminhoOrigem_Change()

caminhoDestino.Enabled = True 'habilita a caixa de texto
procuraDestino.Enabled = True 'habilita o botão Procurar
caminhoDestino.SetFocus 'poe o cursor na caixa de texto destino

End Sub

Como o código esta todo documentado creio que não preciso dar mais detalhes.

Pegue o projeto aqui : copiaArquivos.zip   e divirta-se...

Eu sei é apenas VB, mas eu gosto...

José Carlos Macoratti