Convidado 12/9/2013, 02:10
O Código completo...
As vezes mesmo quando um programa é finalizado seu processo ainda fica ativo no task Manager, por isso encerro o processo antes de compactar a pasta fotos
Private Sub Form_Timer()
'---------------------------------------------------------------------------
'Este código se encontra no evento timer para alimentar a barra de progresso
'---------------------------------------------------------------------------
On Error GoTo TrataErro
Dim msg As String
Evento = Evento + 1
Select Case Evento
Case 1
'-------------------------------------------------------------------------
'Desabilita os botões enquanto a cópia estiver sendo realizada
'Divide a barra de progresso, que tem um comprimento de 11cm, em 8 pedaços
'-------------------------------------------------------------------------
Me!cx1.Visible = True
Me!btFoco.SetFocus
Me!btIniciarBackup.Enabled = False
Escala = (11.2 * 567) / 8
Me!cx1.width = Escala
Case 2
Me!cx1.width = Escala * 2
Set objFS = CreateObject("Scripting.FileSystemObject")
Me!Status.Caption = "Verificando Base de Dados..."
Case 3
Me!Status.Caption = "Copiando Base de Dados..."
Me!cx1.width = Escala * 3
Case 4
'----------------------------------------------------------------------------
'Inicia o processo de cópia simples da base de dados para o destino indicado.
'Aqui a barra de progresso fica parada até a cópia ser concluída
'----------------------------------------------------------------------------
objFS.CopyFile Me!txOrigem, Me!txDestino
Case 5
'----------------------------------------------
'Após a conclusão da cópia o código prossegue
'----------------------------------------------
Me!Status.Caption = "Compactando Base de Dados..."
Me!cx1.width = Escala * 4
Case 6
Dim booResultado As Boolean
'---------------------------------------------------------------------------------
'Se a sua base de dados contiver uma senha de acesso, o método compactar e reparar
'irá solicitá-la.
'
'A função do SendKeys é passar a senha no processo sem a intervenção do usuário.
'
'A função fncProtegido verifica se a base de dados possui senha e então permite
'o uso do SendKeys.
'
'A função fncCapturSenha captura a senha da tabela vinculada
'---------------------------------------------------------------------------------
If fncProtegido = True Then
Dim objws As Object
Set objws = CreateObject("wscript.shell")
'objws.SendKeys fncCapturaSenha, True '"a1234"
objws.SendKeys SenhaBD
objws.SendKeys "{ENTER}"
End If
'-----------------------------------------------------------------------
'Observe que está sendo compactado e reparado a copia que foi gerada
'pelo objfs.CopyFile no destino.
'
'É gerado então um outro arquivo, devidamente compactado e reparado, no
'mesmo local de destino.
'-----------------------------------------------------------------------
DestinoNovo = Replace(Me!txDestino, "-", "-c")
booResultado = Application.CompactRepair(Me!txDestino, DestinoNovo, True)
'-----------------------------------------------------------------------------
'O arquivo que foi copiado para o destino, pelo objfs.CopyFile, será excluído,
'pois só nos interessa o que foi compactado e reparado.
'-----------------------------------------------------------------------------
If booResultado = True Then FileSystem.Kill Me!txDestino
Me!cx1.width = Escala * 5
Set objws = Nothing
Case 7
'-------------------------------------------------
'Executa o winrar oculto se este tiver habilitado
'--------------------------------------------------
If Me!selWinrar = True Then
Me!Status.Caption = "Compactando com o Winrar..."
Dim Compri
Compri = shell(strLocalWinRar & "\Winrar\WinRAR.EXE a " & Chr(34) & Replace(DestinoNovo, ".accdb", "") & ".rar" & Chr(34) & " " & Chr(34) & DestinoNovo & Chr(34), vbHide)
End If
'---------------------------------------------------------------------------
'Se a caixa de seleção para compactar fotos estiver marcada executa a função
'---------------------------------------------------------------------------
If Me.SelFotos.Value = -1 Then
Dim strOrigem As String
'Encerra o processo do WinRar caso exista algum resíduo no Task Manager
Call MatarProcesso("WinRAR.exe")
Pause (2)
strOrigem = CurrentProject.path & "\Fotos\Fotos.rar"
Compri = shell(strLocalWinRar & "\Winrar\WinRAR.EXE a " & Chr(34) & strOrigem & Chr(34) & " " & Chr(34) & CurrentProject.path & "\Fotos" & Chr(34), vbHide)
Volta:
If ProgramaAtivo("WinRar") = True Then
Pause (5)
GoTo Volta
End If
End If
Me!cx1.width = Escala * 6
Case 8
If Me!selWinrar = True Then
'--------------------------------------------------------------------------
'Enquanto o winrar não completar a tarefa de compactação, o comprimento
'do arquivo gerado fica em zero. Verifico este comprimento com o FileLen.
'A barra de progresso vai crescendo gradativamente enquanto o winrar não
'concluir a tarefa.
'--------------------------------------------------------------------------
If FileSystem.FileLen((Replace(DestinoNovo, ".accdb", "") & ".rar ")) = 0 Then
Evento = 7
If Me!cx1.width < (11.2 * 567) Then intCont = intCont + 1
Me!cx1.width = (Escala * 7) + (15 * intCont)
Else
'----------------------------------------------------
'Deleto o arquivo que não foi compactado pelo WinRAR
'----------------------------------------------------
FileSystem.Kill DestinoNovo
Me!Status.Caption = "Backup concluído..."
If Me.chkPen = -1 Then Call fncDestinoBackupPen
Screen.MousePointer = 0
Me!cx1.width = Escala * 8
Me.TimerInterval = 3000
End If
Else
Me!Status.Caption = "Backup concluído..."
If Me.chkPen = -1 Then Call fncDestinoBackupPen
Screen.MousePointer = 0
Me!cx1.width = Escala * 8
Me.TimerInterval = 3000
'Caso esteja selecionado a chkbox DropBopx... envia copia do bakup para o mesmo
If Me.SelDrop.Value = -1 Then
Me.CopiaDrop
End If
End If
Case 9
Set objFS = Nothing
'-------------------------------------------------------------------------------------
'Caso tenha ocorrido uma correção da base de dados, pelo método compactar e reparar
'é gerado um arquilo de log.
'
'Então abre um comunicado, para chamada urgente do adminitrador, que deverá verificar
'e corrigir a base de dados em uso.
'-------------------------------------------------------------------------------------
If Len(Dir(Left(Me!txDestino, InStrRev(Me!txDestino, "\")) & "*.log", vbArchive) & "") > 0 Then
MsgBox "Foi detectado problemas no arquivo de backup." & vbCrLf & _
vbCrLf & "Entre em contato imediatamente com o administrador do Banco de Dados", vbCritical, "Aviso"
End If
Me.TimerInterval = 0
Evento = 0
End Select
Sair:
If Me.TimerInterval = 0 Then DoCmd.Close acDefault
Exit Sub
TrataErro:
MsgBox err.Number & " - " & err.Description, vbInformation, "Aviso"
Evento = 0: Screen.MousePointer = 0: Me.TimerInterval = 0
Resume Sair
End Sub
Finaliza Processo:
'---------------------------------------------------------------------------------------
' Procedure : MatarProcesso
' Author : Harysohn P. Pina (PILOTO) - Harysohn@hotmail.com
' Fórum : Fórum Máximo Access - http://maximoaccess.forumeiros.com/
' Date : 11/09/2013
' Comentários : Função para terminar o processo
'---------------------------------------------------------------------------------------
Private Function MatarProcesso(ByRef StrNombreProceso As String, Optional ByRef DecirSINO As Boolean = True) As Boolean
On Error Resume Next
Dim colProcessList
Dim objProcess As Object
Dim msg As String
Set colProcessList = GetObject("Winmgmts:").ExecQuery("Select * from Win32_Process")
MatarProcesso = False
'-------------------------------------------------------------------------------------
'Faz um loop pelos processos ativos caso o processo seja igual ao processo selecionado
'Vai para mensagem de questionamwnto sobre o encerramento
'-------------------------------------------------------------------------------------
For Each objProcess In colProcessList
If UCase(objProcess.Name) = UCase(StrNombreProceso) Then
'-----------------------------------------
'Matamos o processo com o método Terminate
'-----------------------------------------
objProcess.Terminate (0)
MatarProcesso = True
End If
Next
'--------------------
'Elimina as variaveis
'--------------------
objProcess = Nothing
End Function
Cumprimentos.
Início
![[Resolvido]Provocar pausa no código enquanto pasta é compactada Empty](https://2img.net/i/empty.gif)
