Exportar a Excel Archivos Adjuntos en Tablas de Access
Publicado por Martin (17 intervenciones) el 13/11/2022 14:53:51
Buenos dias gente!! He descargado de un sitio un ejemplo para exportar Tablas y Consultas desde Access a Excel. Lo adapté a mi DB pero no puedo exportar a Excel aquellas Tablas que contengan "Archivos Adjuntos".
Si alguien me puede hechar una mano se los agradecere!!!!
Aqui está el Codigo VBA:
Private Sub subCriaPlanilhas()
Dim oExcel As Object
Dim oPasta As Object
Dim oPlanilha As Object
Dim strLocalSalvar As String
Dim i%, i2%, i3%, i4%
Dim rs As DAO.Recordset
On Error GoTo TrataErro
strLocalSalvar = Me.txtLocal & IIf(IsNull(Me.txtNome), "ExportadoExcel_" & Format(Date, "dd-mm-yyyy") & "_" & Format(Time, "hh-mm-ss"), Me.txtNome) & Me.cbxFormato.Column(0)
Me.cxBarra.Width = 0
Me.lblInfo.ForeColor = vbBlack
Me.lblInfo.FontBold = False
Me.TimerInterval = 0
Me.cxBarra.BackColor = 3770394
i4% = 7035 / (Me.lbx.ItemsSelected.count + 5) 'Defino o valor de incremento da barra (cada vez que o loop for feito nas tabelas
DoCmd.Hourglass True
Me.cxBarra.Width = i4%: Me.lblInfo.Caption = "Criando os objetos iniciais"
Set oExcel = CreateObject("Excel.Application") 'Crio o objeto execel
Set oPasta = oExcel.Workbooks.Add 'Crio o arquivo do excel (uma pasta de trabalho)
For Each l In Me.lbx.ItemsSelected 'Percorro por todos os itens selecionados na listbox para pegar as tabelas/consultas que quero exportar
i2% = i2% + 1
Me.cxBarra.Width = Me.cxBarra.Width + i4%: Me.lblInfo.Caption = "Criando a planilha " & Me.lbx.Column(0, l) & " e inserido dados (caso existam)..."
Set rs = CurrentDb.OpenRecordset(Me.lbx.Column(0, l), , dbForwardOnly) 'Abro o recordset da tabela
If i2% = 1 Then
Set oPlanilha = oPasta.Worksheets(i2%) 'Crio a planilha
Else
'ActiveWorkbook.Sheets.Add(After:=Worksheets(Worksheets.Count))
Set oPlanilha = oPasta.Sheets.Add 'Crio a planilha
End If
oPlanilha.Name = Me.lbx.Column(0, l) 'Defino o nome da planilha para o nome da tabela
For Each f In rs.Fields 'Percorro todos os campos da tabela
oPlanilha.Cells(1, i3% + 1).Value = rs.Fields(i3%).Name 'Defino a linha 1 com os nomes dos campos em cada coluna para ser o cabeçalho
oPlanilha.Cells(1, i3% + 1).Font.Bold = True 'Defino negrito
i3% = i3% + 1
Next
If Me.cbxLarguraColunas = "Cabeçalho" Then oPlanilha.Columns.AutoFit 'Defino a lagura das colunas de acordo com a quantidade de caracteres dos cabeçalhos
'Agora insiro os registros nos seus respectivos locais na planilha
i3% = 2 'como os dados serão inseridos a partir da linha 2, inicio a variável que representa a linha com 2 (aproveito a variável i3% já que ela não será mais usada nesse laço anterir)
Do Until rs.EOF 'Percorro todos os registros da tabela para assim inseri-los na planilha
For i% = 0 To rs.Fields.count - 1
oPlanilha.Cells(i3%, i% + 1).Value = rs.Fields(i%) 'Defino o valor da celula com o valor da coluna do recordset
If rs.Fields(i%).Type = 5 And Me.ckxMoeda = True Then oPlanilha.Cells(i3%, i% + 1).NumberFormat = "$ #,##0.00_);[Red]($ #,##0.00)"
Next i%
rs.MoveNext
i3% = i3% + 1
Loop
i3% = 0 'Zero a variável para iniciar o processo em outra tabela/consulta
'Defino a lagura das colunas de acordo com a quantidade de caracteres dos registros do recodset
'Ha essa mesma linha (oPlanilha.Columns.AutoFit) acima, porque lá ainda não há conteúdo e o autofit
'assume a quantidade maior de caracteres para determinar a largura de colunas.
'Dessa forma, aqui, já há conteúdo e a largura será agora do conteúdo e não do cabeçalho, como acima
If Me.cbxLarguraColunas = "Conteúdo" Then oPlanilha.Columns.AutoFit
Next
Me.cxBarra.Width = Me.cxBarra.Width + i4%: Me.lblInfo.Caption = "Executando etapas finais e gravando a planilha..."
If Me.cbxFormato.Column(0) = ".xls" Then
oPasta.SaveAs FileName:=strLocalSalvar, FileFormat:=56
Else
oPasta.SaveAs FileName:=strLocalSalvar, FileFormat:=51
End If
Me.cxBarra.Width = Me.cxBarra.Width + i4%: Me.lblInfo.Caption = "Encerrando programa em segundo plano..."
oExcel.Quit
Me.cxBarra.Width = 7035: Me.lblInfo.Caption = "Planilha do Excel no formato " & LCase(Me.cbxFormato.Column(1)) & " criada com sucesso!": Me.lblInfo.ForeColor = vbWhite
Me.TimerInterval = 500
ApagaObjetos:
Set oPlanilha = Nothing
Set oPasta = Nothing
Set oExcel = Nothing
DoCmd.Hourglass False
Exit Sub
TrataErro:
If Err.Number <> 1004 Then
MsgBox Err.Description, vbCritical, "Erro: " & Err.Number
Err.Clear
End If
Me.cxBarra.Width = 7035: Me.lblInfo.Caption = "Houve uma falha ao criar a planilha...": Me.lblInfo.ForeColor = vbWhite: Me.cxBarra.BackColor = vbRed
GoTo ApagaObjetos
End Sub
Si alguien me puede hechar una mano se los agradecere!!!!
Aqui está el Codigo VBA:
Private Sub subCriaPlanilhas()
Dim oExcel As Object
Dim oPasta As Object
Dim oPlanilha As Object
Dim strLocalSalvar As String
Dim i%, i2%, i3%, i4%
Dim rs As DAO.Recordset
On Error GoTo TrataErro
strLocalSalvar = Me.txtLocal & IIf(IsNull(Me.txtNome), "ExportadoExcel_" & Format(Date, "dd-mm-yyyy") & "_" & Format(Time, "hh-mm-ss"), Me.txtNome) & Me.cbxFormato.Column(0)
Me.cxBarra.Width = 0
Me.lblInfo.ForeColor = vbBlack
Me.lblInfo.FontBold = False
Me.TimerInterval = 0
Me.cxBarra.BackColor = 3770394
i4% = 7035 / (Me.lbx.ItemsSelected.count + 5) 'Defino o valor de incremento da barra (cada vez que o loop for feito nas tabelas
DoCmd.Hourglass True
Me.cxBarra.Width = i4%: Me.lblInfo.Caption = "Criando os objetos iniciais"
Set oExcel = CreateObject("Excel.Application") 'Crio o objeto execel
Set oPasta = oExcel.Workbooks.Add 'Crio o arquivo do excel (uma pasta de trabalho)
For Each l In Me.lbx.ItemsSelected 'Percorro por todos os itens selecionados na listbox para pegar as tabelas/consultas que quero exportar
i2% = i2% + 1
Me.cxBarra.Width = Me.cxBarra.Width + i4%: Me.lblInfo.Caption = "Criando a planilha " & Me.lbx.Column(0, l) & " e inserido dados (caso existam)..."
Set rs = CurrentDb.OpenRecordset(Me.lbx.Column(0, l), , dbForwardOnly) 'Abro o recordset da tabela
If i2% = 1 Then
Set oPlanilha = oPasta.Worksheets(i2%) 'Crio a planilha
Else
'ActiveWorkbook.Sheets.Add(After:=Worksheets(Worksheets.Count))
Set oPlanilha = oPasta.Sheets.Add 'Crio a planilha
End If
oPlanilha.Name = Me.lbx.Column(0, l) 'Defino o nome da planilha para o nome da tabela
For Each f In rs.Fields 'Percorro todos os campos da tabela
oPlanilha.Cells(1, i3% + 1).Value = rs.Fields(i3%).Name 'Defino a linha 1 com os nomes dos campos em cada coluna para ser o cabeçalho
oPlanilha.Cells(1, i3% + 1).Font.Bold = True 'Defino negrito
i3% = i3% + 1
Next
If Me.cbxLarguraColunas = "Cabeçalho" Then oPlanilha.Columns.AutoFit 'Defino a lagura das colunas de acordo com a quantidade de caracteres dos cabeçalhos
'Agora insiro os registros nos seus respectivos locais na planilha
i3% = 2 'como os dados serão inseridos a partir da linha 2, inicio a variável que representa a linha com 2 (aproveito a variável i3% já que ela não será mais usada nesse laço anterir)
Do Until rs.EOF 'Percorro todos os registros da tabela para assim inseri-los na planilha
For i% = 0 To rs.Fields.count - 1
oPlanilha.Cells(i3%, i% + 1).Value = rs.Fields(i%) 'Defino o valor da celula com o valor da coluna do recordset
If rs.Fields(i%).Type = 5 And Me.ckxMoeda = True Then oPlanilha.Cells(i3%, i% + 1).NumberFormat = "$ #,##0.00_);[Red]($ #,##0.00)"
Next i%
rs.MoveNext
i3% = i3% + 1
Loop
i3% = 0 'Zero a variável para iniciar o processo em outra tabela/consulta
'Defino a lagura das colunas de acordo com a quantidade de caracteres dos registros do recodset
'Ha essa mesma linha (oPlanilha.Columns.AutoFit) acima, porque lá ainda não há conteúdo e o autofit
'assume a quantidade maior de caracteres para determinar a largura de colunas.
'Dessa forma, aqui, já há conteúdo e a largura será agora do conteúdo e não do cabeçalho, como acima
If Me.cbxLarguraColunas = "Conteúdo" Then oPlanilha.Columns.AutoFit
Next
Me.cxBarra.Width = Me.cxBarra.Width + i4%: Me.lblInfo.Caption = "Executando etapas finais e gravando a planilha..."
If Me.cbxFormato.Column(0) = ".xls" Then
oPasta.SaveAs FileName:=strLocalSalvar, FileFormat:=56
Else
oPasta.SaveAs FileName:=strLocalSalvar, FileFormat:=51
End If
Me.cxBarra.Width = Me.cxBarra.Width + i4%: Me.lblInfo.Caption = "Encerrando programa em segundo plano..."
oExcel.Quit
Me.cxBarra.Width = 7035: Me.lblInfo.Caption = "Planilha do Excel no formato " & LCase(Me.cbxFormato.Column(1)) & " criada com sucesso!": Me.lblInfo.ForeColor = vbWhite
Me.TimerInterval = 500
ApagaObjetos:
Set oPlanilha = Nothing
Set oPasta = Nothing
Set oExcel = Nothing
DoCmd.Hourglass False
Exit Sub
TrataErro:
If Err.Number <> 1004 Then
MsgBox Err.Description, vbCritical, "Erro: " & Err.Number
Err.Clear
End If
Me.cxBarra.Width = 7035: Me.lblInfo.Caption = "Houve uma falha ao criar a planilha...": Me.lblInfo.ForeColor = vbWhite: Me.cxBarra.BackColor = vbRed
GoTo ApagaObjetos
End Sub
Valora esta pregunta
0