BACKUP
Boa noite galera, blz. é o seguinte baseado no exemplo que o Tecla mim passou, era realmente o que estava precisando, mais gostaria que quando existir um arquivo de backup na pasta backup e por acaso o operador do sistema clicasse novamente em backup, mostrar uma mensagem informando que já existe um arquivo com mesmo nome e mês.
deste já agradeço.
deste já agradeço.
Campeão tenta isso,....
If Dir(arqDestino) <> [Ô][Ô] Then [ô]verificando se existe o arquivo
If MsgBox([Ô]O backup já foi realizado, deseja continuar?[Ô], vbQuestion + vbYesNo) = vbNo Then
Exit Sub
End If
End If
[ô]Efetuar backup
If (Backup(arqOrigem, arqDestino)) = True Then
MsgBox [Ô]Backup realizado com sucesso.[Ô], , [Ô]Backup[Ô]
Else
MsgBox [Ô]Ocorreu um erro ao efetuar Backup. Contate o suporte.[Ô], , [Ô]Erro Backup[Ô]
End If
If Dir(arqDestino) <> [Ô][Ô] Then [ô]verificando se existe o arquivo
If MsgBox([Ô]O backup já foi realizado, deseja continuar?[Ô], vbQuestion + vbYesNo) = vbNo Then
Exit Sub
End If
End If
[ô]Efetuar backup
If (Backup(arqOrigem, arqDestino)) = True Then
MsgBox [Ô]Backup realizado com sucesso.[Ô], , [Ô]Backup[Ô]
Else
MsgBox [Ô]Ocorreu um erro ao efetuar Backup. Contate o suporte.[Ô], , [Ô]Erro Backup[Ô]
End If
Obrigado Pela Ajuda LEOBEVI, mais não consegui ainda deu erro na linha If Dir(arqDestino) <> [Ô][Ô]
Dim reccnt
Dim RS As New ADODB.Recordset
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Dim Resp As Byte
Resp = MsgBox([Ô]Tem certeza que deseja finalizar Cópia. ![Ô], vbQuestion + vbYesNo, [Ô] Sisnews Sistemas[Ô])
If Resp = 7 Then Cancel = True
End Sub
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, [Ô]Sisnews Sistemas[Ô]) [ô]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 progrossse 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, [Ô] Cópia 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...[Ô], vbQuestion, [Ô] Sisnews Sistemas[Ô] [ô]exibe mensagem de erro
Close F1 [ô]fecha a fonte
Close F2 [ô]fecha o destino
Exit Function [ô]sai da rotina
End Function
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
Private Sub GBotaoCopiar_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, [Ô] Sisnews Sistemas[Ô] [ô]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, [Ô] Sisnews Sistemas[Ô] [ô]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
Private Sub GBotaoEncerra_Click()
CnSql.Open
Unload Me [ô]sai do programa
End Sub
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
Private Sub caminhoOrigem_Change()
caminhoDestino.Enabled = True [ô]habilita a caixa de texto
procuraDestino.Enabled = True [ô]habilita o botão Procurar
GBotaoCopiar.Enabled = True [ô]habilita o botão Copiar
caminhoDestino.SetFocus [ô]poe o cursor na caixa de texto destino
End Sub
Private Sub GBotaoConfirma_Click()
[ô]Dialogo.DialogTitle = [Ô]Procura origem...[Ô] [ô]define o titulo
[ô][ô][ô][ô][ô][ô][ô][ô][ô][ô][ô][ô][ô][ô][ô][ô][ô][ô]Dialogo.DialogTitle = [Ô]C:\Dados\SIS\SIS.mdb[Ô]
[ô]Dialogo.ShowOpen [ô]exibe o dialogo
[ô]caminhoOrigem.Text = Dialogo.FileName [ô]define o texto da caixa de origem
caminhoOrigem.Text = [Ô]C:\Dados\BOL\Bol.mdb[Ô]
End Sub
Dim RS As New ADODB.Recordset
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Dim Resp As Byte
Resp = MsgBox([Ô]Tem certeza que deseja finalizar Cópia. ![Ô], vbQuestion + vbYesNo, [Ô] Sisnews Sistemas[Ô])
If Resp = 7 Then Cancel = True
End Sub
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, [Ô]Sisnews Sistemas[Ô]) [ô]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 progrossse 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, [Ô] Cópia 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...[Ô], vbQuestion, [Ô] Sisnews Sistemas[Ô] [ô]exibe mensagem de erro
Close F1 [ô]fecha a fonte
Close F2 [ô]fecha o destino
Exit Function [ô]sai da rotina
End Function
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
Private Sub GBotaoCopiar_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, [Ô] Sisnews Sistemas[Ô] [ô]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, [Ô] Sisnews Sistemas[Ô] [ô]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
Private Sub GBotaoEncerra_Click()
CnSql.Open
Unload Me [ô]sai do programa
End Sub
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
Private Sub caminhoOrigem_Change()
caminhoDestino.Enabled = True [ô]habilita a caixa de texto
procuraDestino.Enabled = True [ô]habilita o botão Procurar
GBotaoCopiar.Enabled = True [ô]habilita o botão Copiar
caminhoDestino.SetFocus [ô]poe o cursor na caixa de texto destino
End Sub
Private Sub GBotaoConfirma_Click()
[ô]Dialogo.DialogTitle = [Ô]Procura origem...[Ô] [ô]define o titulo
[ô][ô][ô][ô][ô][ô][ô][ô][ô][ô][ô][ô][ô][ô][ô][ô][ô][ô]Dialogo.DialogTitle = [Ô]C:\Dados\SIS\SIS.mdb[Ô]
[ô]Dialogo.ShowOpen [ô]exibe o dialogo
[ô]caminhoOrigem.Text = Dialogo.FileName [ô]define o texto da caixa de origem
caminhoOrigem.Text = [Ô]C:\Dados\BOL\Bol.mdb[Ô]
End Sub
Oi NILTON_VIANNA tudo bem. Você tem um exemplo utilizando esse código fonte seu.
No COMMAND1 (botão responsável por executar a rotina de BACKUP), altere conforme abaixo:
Private Sub Command1_Click()
[txt-color=#0B610B][ô]Nome dos arquivos[/txt-color]
Dim arqOrigem As String, arqDestino As String
arqOrigem = App.Path & [Ô]\BD.mdb[Ô]
arqDestino = App.Path & [Ô]\Backup\[Ô] & Text1 & [Ô]_[Ô] & CStr(UCase(Format(Now, [Ô]mmmm[Ô]))) & [Ô]_[Ô] & CStr(Format(Now, [Ô]yyyy[Ô])) & [Ô].mdb[Ô]
[txt-color=#088A08][ô]Validar se o backup já foi feito[/txt-color]
If Dir(arqDestino, vbArchive) <> [Ô][Ô] Then
MsgBox [Ô]O backup já foi efetuado.[Ô], , [Ô]Backup[Ô]
Exit Sub
End If
[txt-color=#0B6138][ô]Efetuar backup[/txt-color]
If (Backup(arqOrigem, arqDestino)) = True Then
MsgBox [Ô]Backup realizado com sucesso.[Ô], , [Ô]Backup[Ô]
Else
MsgBox [Ô]Ocorreu um erro ao efetuar Backup. Contate o suporte.[Ô], , [Ô]Erro Backup[Ô]
End If
End Sub
Tópico encerrado , respostas não são mais permitidas