Abrir planilha protegida

Question

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

Answer 1

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. [e-mail]

Answer 2

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

Answer 3

Eu atualizei o meu post anterior, de uma olhada por favor.

---

Click em propor como resposta se foi util a voce. [e-mail]

Answer 4

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.

Answer 5

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

                                                    

Answer 6

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. [e-mail]