none
Proplema com codigo VB 6 Recuperar Backup RRS feed

  • Pergunta

  • No modulo eu uso este codigo:

    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

     

    No Form referente, este codigo

    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 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, "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
    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 Command1_Click()
    Dialogo.DialogTitle = "procurar..." 'define o titulo
    Dialogo.FileName = "Agendas.mdb"
    caminhoOrigem.Text = Dialogo.FileName
    Dialogo.ShowOpen

    procuraOrigem.Visible = False
    procuraDestino.Visible = False
    caminhoDestino.Text = App.path & "\Agendas.mdb"
    caminhoOrigem.Text = Dialogo.FileName
    End Sub

    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


    Private Sub Form_Load()
    procuraOrigem.Visible = False
    procuraDestino.Visible = False
    caminhoOrigem.Text = "A:\Agendas.mdb"
    caminhoDestino.Text = App.path & "\Agendas.mdb"
    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
        Copiar.Enabled = True
        End Sub
    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
    Private Sub procuraOrigem_Click()

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

    End Sub

    Este é o Desenho dos objetos do form

    file:///C:/Documents%20and%20Settings/Marco/Meus%20documentos/Minhas%20imagens/Desenho.bmp

    MEU PROBLEMA É ESTE PROGRAMA FUNCIONA SOMENTE ISOLADO DE OUTROS FORM

    INCLUINDO ELE COM OUTROS FORM UM PROGRAMA COMPLETO FAZER BACKUP E RESTAURAR NÃO FUNCIONA ELE PARA APATIR DESTE SETOR DESTACADO ABAIXO

    FAVOR PRECISO DE AJUDA, PARA ESTE PROBLEMA

    OBRIGADO



     

     

       "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, "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
    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 Command1_Click()
    Dialogo.DialogTitle = "procurar..." 'define o titulo
    Dialogo.FileName = "Agendas.mdb"
    caminhoOrigem.Text = Dialogo.FileName
    Dialogo.ShowOpen

    procuraOrigem.Visible = False
    procuraDestino.Visible = False
    caminhoDestino.Text = App.path & "\Agendas.mdb"
    caminhoOrigem.Text = Dialogo.FileName
    End Sub

    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


    Private Sub Form_Load()
    procuraOrigem.Visible = False
    procuraDestino.Visible = False
    caminhoOrigem.Text = "A:\Agendas.mdb"
    caminhoDestino.Text = App.path & "\Agendas.mdb"
    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
        Copiar.Enabled = True
        End Sub
    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
    Private Sub procuraOrigem_Click()

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

    End Sub"


    domingo, 11 de julho de 2010 18:52