none
Abrir planilha protegida RRS feed

  • Pergunta

  • Caros, tenho uma planilha onde consta o código abaixo, mas quando tento abrir o arquivo DBPath = "C:\RC\APOIO.xlsx" ela da erro pois esse arquivo é protegido por senha.

    Minha dúvida é, consigo colocar a senha na linha de código abaixo para que ele abra o arquivo e me transfira os dados?

    sconnect = "Provider=MSDASQL.1;DSN=Excel Files;DBQ=" & DBPath & ";HDR=Yes';"


    Sub Transf_Dados()
    Dim sSQLQry As String
    Dim ReturnArray
    Dim Conn As New ADODB.Connection
    Dim mrs As New ADODB.Recordset
    Dim DBPath As String, sconnect As String
    Dim newSheet As Worksheet
    DBPath = "C:\RC\APOIO.xlsx"
    sconnect = "Provider=MSDASQL.1;DSN=Excel Files;DBQ=" & DBPath & ";HDR=Yes';"
    Conn.Open sconnect
    sSQLSting = "SELECT [Responsável],[Canal],[Data Entrada],[Data Tratamento],[Código assinante],[Nome],[Revista],[Fato Gerador],[Motivo do Contato],[Contato SAC],[Cidade],[Estado],[Representação],[Nº Contrato],[Status],[Valores] FROM [Base$]"
    mrs.Open sSQLSting, Conn
    Set newSheet = Sheets.Add
    ActiveSheet.Range("A1").CopyFromRecordset mrs
    mrs.Close
    Conn.Close
    End Sub

    sexta-feira, 23 de fevereiro de 2018 12:38

Todas as Respostas

  • Bom dia amigo,

    Com este método, não pode abrir a pasta de trabalho para acesso a dados, mesmo fornecendo a senha correta com suas configurações de conexão. (veja o link abaixo)

    Já tentou usar o Application.Workbooks.Open(caminho / Arquivo).

    Como usar o ADO com dados do Excel do Visual Basic ou VBA

    Atualizando...

    Uma opção é usar o o getobject para abrir a pasta de trabalho, ai solicita a senha, e seu codigo faz a importação dos dados.

    Fica assim exemplo (*não testado): 

    Sub Transf_Dados()
        Dim sSQLQry As String
        Dim ReturnArray
        Dim Conn As New ADODB.Connection
        Dim mrs As New ADODB.Recordset
        Dim DBPath As String, sconnect As String
        Dim newSheet As Worksheet
        Dim sSQLSting As String
        Dim xlObj As Object
        
        DBPath = "C:\RC\APOIO.xlsx"
        
        Set xlObj = GetObject(DBPath)
        
        sconnect = "Provider=MSDASQL.1;DSN=Excel Files;DBQ=" & DBPath & ";HDR=Yes';"
        
        Conn.Open sconnect
        
        sSQLSting = "SELECT [Responsável],[Canal],[Data Entrada],[Data Tratamento],[Código assinante],[Nome],[Revista],[Fato Gerador],[Motivo do Contato],[Contato SAC],[Cidade],[Estado],[Representação],[Nº Contrato],[Status],[Valores] FROM [Base$]"
        
        mrs.Open sSQLSting, Conn
        
        Set newSheet = Sheets.Add
        
        ActiveSheet.Range("A1").CopyFromRecordset mrs
        
        mrs.Close
        
        Conn.Close
        
        Set xlObj = Nothing
        
    End Sub

      Fonte: https://www.connectionstrings.com/how-to-open-password-protected-excel-workbook/


    Click em propor como resposta se foi util a voce. ricardodm@outlook.com.br




    • Editado Ricardo Vba sexta-feira, 23 de fevereiro de 2018 13:18
    sexta-feira, 23 de fevereiro de 2018 12:59
  • Tentei com esse código agora, mas ele diz que não é possível descriptografar o arquivo.


    Sub Transf_Arq()
    Dim Principal
    Principal = Application.ThisWorkbook.Name
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
        Dim cn As ADODB.Connection
        Dim rs As ADODB.Recordset
        Dim ws As Worksheet
        Dim sSql As String
        Dim lCol As Long
        Dim Pos_Final
    Plan6.Select

    ThisWorkbook.Sheets("Jrd").Range("A2:XFD100000").ClearContents
        
        Set ws = ThisWorkbook.Sheets("Jrd")
        Set cn = New ADODB.Connection
            
            cn.ConnectionString = _
              "Provider=Microsoft.ACE.OLEDB.12.0;" & _
              "Data Source=" & cCaminhoServidor4 & ";" & _
              "Extended Properties=Excel 8.0;"
        
        cn.Open
        
        sSql = ""
        sSql = sSql & " " & "SELECT [Responsável],[Data Entrada],[Nome],[Cidade],[Estado],[Valores] FROM [Base$]"

        Set rs = cn.Execute(sSql)
        ws.Cells(2, 1).CopyFromRecordset rs

        rs.Close
        cn.Close
        
        Set ws = Nothing
        Set cn = Nothing
        Set rs = Nothing
    End Sub

    sexta-feira, 23 de fevereiro de 2018 13:14
  • Eu atualizei o meu post anterior, de uma olhada por favor.

    Click em propor como resposta se foi util a voce. ricardodm@outlook.com.br

    sexta-feira, 23 de fevereiro de 2018 13:19
  • Olá, rodei a macro e ela abre dai eu informo a senha e ela abre normalmente.

    Mas o que gostaria é poder deixar essa senha informada na macro e ao abrir a planilha ela já busque essa senha e continue o processamento sem a necessidade de eu estar digitando senha.


    sexta-feira, 23 de fevereiro de 2018 13:36
  • Agora deu certo, cosegui.

    Grato pela ajuda.

    Sub Transf_Dados()
        Dim sSQLQry As String
        Dim ReturnArray
        Dim Conn As New ADODB.Connection
        Dim mrs As New ADODB.Recordset
        Dim DBPath As String, sconnect As String
        Dim newSheet As Worksheet
        Dim sSQLSting As String
        Dim xlObj As Object

        'DBPath = "C:\RC\APOIO.xlsx"

        Set xlObj = GetObject(DBPath)

        sconnect = "Provider=MSDASQL.1;DSN=Excel Files;DBQ=" & DBPath & ";HDR=Yes';"

        Conn.Open sconnect, , "acesso"

        sSQLSting = "SELECT [Responsável],[Canal],[Data Entrada],[Data Tratamento],[Código assinante],[Nome],[Revista],[Fato Gerador],[Motivo do Contato],[Contato SAC],[Cidade],[Estado],[Representação],[Nº Contrato],[Status],[Valores] FROM [Base$]"

        mrs.Open sSQLSting, Conn

       ' Set newSheet = Sheets.Add

        ActiveSheet.Range("A2").CopyFromRecordset mrs

        mrs.Close

        Conn.Close

        Set xlObj = Nothing

    End Sub

                                                        
    sexta-feira, 23 de fevereiro de 2018 13:58
  • Bom mesmo já conseguido deixo o código corrigido para outas pessoas que precisarem.

    Se a pasta de trabalho não estiver com a senha de gravação, o código importará os dados sem a necessidade de digitar a senha manualmente. 

    Sub Transf_Dados()
        ' marque a ref. microsoft activeX data objects x.xx library
        On Error GoTo Trata_Erro
        Dim sSQLQry     As String
        Dim Conn        As New ADODB.Connection
        Dim mrs         As New ADODB.Recordset
        Dim DBPath      As String
        Dim sconnect    As String
        Dim newSheet    As Worksheet
        Dim sSQLSting   As String
        Dim xlObj       As Object
        Dim xlWb        As Object
        Dim SuaSnh      As String
        
        DBPath = "C:\RC\APOIO.xlsx"
        SuaSnh = "123" ' ALTERE A SUA SENHA
        
        On Error Resume Next
        Set xlObj = GetObject(, "Excel.Application")
        If Err.Number <> 0 Then
            Err.Clear
            On Error GoTo Trata_Erro
            Set xlObj = CreateObject("excel.application")
        Else
            On Error GoTo Trata_Erro
        End If
        
        Set xlWb = CreateObject("excel.application")
        xlObj.Visible = True
    
        Set xlWb = xlObj.Workbooks.Open(DBPath, False, False, , SuaSnh)
        
        sconnect = "Provider=MSDASQL.1;DSN=Excel Files;DBQ=" & DBPath & ";HDR=Yes';"
        
        Conn.Open sconnect
        
        sSQLSting = "SELECT * FROM [Base$]"
        
        mrs.Open sSQLSting, Conn
        
        Set newSheet = ThisWorkbook.Sheets.Add
        
        ThisWorkbook.ActiveSheet.Range("A1").CopyFromRecordset mrs
    
        On Error Resume Next
        mrs.Close
        Conn.Close
        Set mrs = Nothing
        Set Conn = Nothing
        xlWb.Close False
        Set xlWb = Nothing
        xlObj.Close False
        Set xlObj = Nothing
        
        Exit Sub
        
    Trata_Erro:   MsgBox Err.Number & " " & Err.Description, vbCritical
        
    End Sub
    

     


    Click em propor como resposta se foi util a voce. ricardodm@outlook.com.br

    sexta-feira, 23 de fevereiro de 2018 15:10