PROGRESSBAR ENQUANTO GERAR RELATORIO EXCEL

USUARIO.EXCLUIDOS 21/05/2004 16:57:29
#26039

Preciso inserir um progressbar em um processo onde gero um relatorio.Ã© o seguinte:
Tenho um form chamado relatorio. Nele faco a consulta de uma data.Quanto clico no botao OK, ele executa a seguinte funcao:
Public Function RelaCompDia(ByVal inicial As Date)

Dim xlApp As Excel.Application
Dim xlWork As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim rela As QueryDef
Dim LINHA As Integer

On Error GoTo GerarPlanilha

Screen.MousePointer = vbHourglass

MsgBox "Gerando relatório..."

Set xlApp = CreateObject("EXCEL.Application")
Set xlWork = xlApp.Workbooks.Open("C:\Documents and Settings\melissa\Usr\vb\Agenda.xls")
Set xlWork = xlApp.Workbooks(1)
Set xlSheet = xlApp.Worksheets("Dados")

xlSheet.Cells.Clear

Set rela = db.QueryDefs("ComprDia")
With rela

.Parameters("Uma data") = inicial
.Execute

End With

Set frmReld.Data1.Recordset = db.OpenRecordset("CompDia")
frmReld.Data1.Refresh

xlSheet.Cells(4, 1) = "Data"
xlSheet.Cells(4, 1).Font.Bold = True
xlSheet.Cells(4, 1).Borders.LineStyle = 3
xlSheet.Cells(4, 1).Borders.Weight = 1
xlSheet.Cells(4, 1).Font.Name = "Verdana"
xlSheet.Cells(4, 1).Font.Size = 7
xlSheet.Cells(4, 1).Interior.ColorIndex = 6

xlSheet.Cells(4, 2) = "Hora"
xlSheet.Cells(4, 2).Font.Bold = True
xlSheet.Cells(4, 2).Borders.LineStyle = 3
xlSheet.Cells(4, 2).Borders.Weight = 1
xlSheet.Cells(4, 2).Font.Name = "Verdana"
xlSheet.Cells(4, 2).Font.Size = 7
xlSheet.Cells(4, 2).Interior.ColorIndex = 6

xlSheet.Cells(4, 3) = "Assunto"
xlSheet.Cells(4, 3).Font.Name = "Verdana"
xlSheet.Cells(4, 3).Font.Bold = True
xlSheet.Cells(4, 3).Borders.LineStyle = 3
xlSheet.Cells(4, 3).Borders.Weight = 1
xlSheet.Cells(4, 3).Font.Size = 7
xlSheet.Cells(4, 3).Interior.ColorIndex = 6

xlSheet.Cells(4, 4) = "Compromissos"
xlSheet.Cells(4, 4).Font.Name = "Verdana"
xlSheet.Cells(4, 4).Font.Bold = True
xlSheet.Cells(4, 4).Borders.LineStyle = 3
xlSheet.Cells(4, 4).Borders.Weight = 1
xlSheet.Cells(4, 4).Font.Size = 7
xlSheet.Cells(4, 4).Interior.ColorIndex = 6

xlSheet.Cells(4, 5) = "Obs"
xlSheet.Cells(4, 5).Font.Bold = True
xlSheet.Cells(4, 5).Borders.LineStyle = 3
xlSheet.Cells(4, 5).Borders.Weight = 1
xlSheet.Cells(4, 5).Font.Name = "Verdana"
xlSheet.Cells(4, 5).Font.Size = 7
xlSheet.Cells(4, 5).Interior.ColorIndex = 6

LINHA = 6

Do While Not frmReld.Data1.Recordset.EOF

xlSheet.Cells(LINHA, 1) = Format(frmReld.Data1.Recordset("dat"), "mm/dd/yyyy")
xlSheet.Cells(LINHA, 1).Borders.LineStyle = 3
xlSheet.Cells(LINHA, 1).Borders.Weight = 1
xlSheet.Cells(LINHA, 1).Font.Name = "Verdana"
xlSheet.Cells(LINHA, 1).Font.Size = 7

xlSheet.Cells(LINHA, 2) = frmReld.Data1.Recordset("Hora")
xlSheet.Cells(LINHA, 2).Borders.LineStyle = 3
xlSheet.Cells(LINHA, 2).Borders.Weight = 1
xlSheet.Cells(LINHA, 2).Font.Name = "Verdana"
xlSheet.Cells(LINHA, 2).Font.Size = 7

xlSheet.Cells(LINHA, 3) = frmReld.Data1.Recordset("Assunto")
xlSheet.Cells(LINHA, 3).Borders.LineStyle = 3
xlSheet.Cells(LINHA, 3).Borders.Weight = 1
xlSheet.Cells(LINHA, 3).Font.Name = "Verdana"
xlSheet.Cells(LINHA, 3).Font.Size = 7

xlSheet.Cells(LINHA, 4) = frmReld.Data1.Recordset("Compromissos")
xlSheet.Cells(LINHA, 4).Borders.LineStyle = 3
xlSheet.Cells(LINHA, 4).Borders.Weight = 1
xlSheet.Cells(LINHA, 4).Font.Name = "Verdana"
xlSheet.Cells(LINHA, 4).Font.Size = 7

xlSheet.Cells(LINHA, 5) = frmReld.Data1.Recordset("Obs")
xlSheet.Cells(LINHA, 5).Borders.LineStyle = 3
xlSheet.Cells(LINHA, 5).Borders.Weight = 1
xlSheet.Cells(LINHA, 5).Font.Name = "Verdana"
xlSheet.Cells(LINHA, 5).Font.Size = 7

frmReld.Data1.Recordset.MoveNext
LINHA = LINHA + 1
Loop

xlWork.Close True
xlApp.Quit
Set xlApp = Nothing

GerarPlanilha:
Select Case Err
Case 0
MsgBox "Pronto"
Screen.MousePointer = vbNormal
MsgBox "Relatório gerado com sucesso. Maximize o Excel para ver o arquivo e salve-o com o nome desejado.", vbOKOnly + vbInformation
Shell "C:\Arquivos de programas\Microsoft Office\Office\excel.exe \\melissa\Usr\vb\Agenda.xls"
Case 1004
Unload frmReld
MsgBox "Pronto"
Screen.MousePointer = vbNormal
MsgBox "O caminho não foi encontrado, por favor mude o caminho" & Chr(13) & " nas configurações e tente gerar o mapa novamente!", vbCritical + vbOKOnly

Case 3010
With db
.TableDefs.Refresh
.TableDefs.Delete "CompDia"
.TableDefs.Refresh
End With
Resume
Case Else
MsgBox "Pronto"
Screen.MousePointer = vbNormal
MsgBox Err.Number & "-" & Err.Description, vbCritical + vbOKOnly
xlWork.Close True
xlApp.Quit
Set xlApp = Nothing

End Select
Unload frmReld
End Function

Onde coloco o progress bar e como fazer
Ajudem-me
Mel

USUARIO.EXCLUIDOS 26/05/2004 17:37:52
#26810 Resposta escolhida

ProgressBar1.min =0
ProgressBar1.max = frmReld.data1.recordset.recordcount

Do While Not frmReld.Data1.Recordset.EOF

xlSheet.Cells(LINHA, 1) = Format(frmReld.Data1.Recordset("dat"), "mm/dd/yyyy")
xlSheet.Cells(LINHA, 1).Borders.LineStyle = 3
xlSheet.Cells(LINHA, 1).Borders.Weight = 1
xlSheet.Cells(LINHA, 1).Font.Name = "Verdana"
xlSheet.Cells(LINHA, 1).Font.Size = 7

xlSheet.Cells(LINHA, 2) = frmReld.Data1.Recordset("Hora")
xlSheet.Cells(LINHA, 2).Borders.LineStyle = 3
xlSheet.Cells(LINHA, 2).Borders.Weight = 1
xlSheet.Cells(LINHA, 2).Font.Name = "Verdana"
xlSheet.Cells(LINHA, 2).Font.Size = 7

xlSheet.Cells(LINHA, 3) = frmReld.Data1.Recordset("Assunto")
xlSheet.Cells(LINHA, 3).Borders.LineStyle = 3
xlSheet.Cells(LINHA, 3).Borders.Weight = 1
xlSheet.Cells(LINHA, 3).Font.Name = "Verdana"
xlSheet.Cells(LINHA, 3).Font.Size = 7

xlSheet.Cells(LINHA, 4) = frmReld.Data1.Recordset("Compromissos")
xlSheet.Cells(LINHA, 4).Borders.LineStyle = 3
xlSheet.Cells(LINHA, 4).Borders.Weight = 1
xlSheet.Cells(LINHA, 4).Font.Name = "Verdana"
xlSheet.Cells(LINHA, 4).Font.Size = 7

xlSheet.Cells(LINHA, 5) = frmReld.Data1.Recordset("Obs")
xlSheet.Cells(LINHA, 5).Borders.LineStyle = 3
xlSheet.Cells(LINHA, 5).Borders.Weight = 1
xlSheet.Cells(LINHA, 5).Font.Name = "Verdana"
xlSheet.Cells(LINHA, 5).Font.Size = 7

frmReld.Data1.Recordset.MoveNext
LINHA = LINHA + 1
progressbar1.value = linha-6
Loop

USUARIO.EXCLUIDOS 27/05/2004 14:43:07
#26981

para isto voce precisa definir um valor para cada fase - vou colocar aqui uma forma, mas voce precisa distribuir como achar melhor

Dim xlApp As Excel.Application
Dim xlWork As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim rela As QueryDef
Dim linha As String

On Error GoTo GerarPlanilha

Screen.MousePointer = vbHourglass

frmReld.pgr.Visible = True
frmReld.pgr.Min = 0

'10 - VALOR TOTAL DE PROCESSO INICIAL (definido por voce)
frmReld.pgr.Max = frmReld.Data1.Recordset.RecordCount + 10
frmReld.prg.Value = 0

Set xlApp = CreateObject("EXCEL.Application")
Set xlWork = xlApp.Workbooks.Open("C:\Documents and Settings\melissa\Usr\vb\Agenda.xls")
Set xlWork = xlApp.Workbooks(1)
Set xlSheet = xlApp.Worksheets("Dados")

'3 - VALOR QUE DEFINE A CRIACAO DA PLANILHA
frmReld.prg.Value = 3

xlSheet.Cells.Clear

Set rela = db.QueryDefs("ComprDia")
With rela

'7 - antigos 3 + 4 - 4 de Criacao de RELA em querydefs
frmReld.prg.Value = 7

.Parameters("Uma data") = inicial
.Execute

End With

Set frmReld.Data1.Recordset = db.OpenRecordset("CompDia")
frmReld.Data1.Refresh

'9 = 7 + 2 - 2 de refresh e criacao de Recordset
frmReld.pgr.Min = 9

xlSheet.Cells(4, 1) = "Data"
xlSheet.Cells(4, 1).Font.Bold = True
xlSheet.Cells(4, 1).Borders.LineStyle = 3
xlSheet.Cells(4, 1).Borders.Weight = 1
xlSheet.Cells(4, 1).Font.Name = "Verdana"
xlSheet.Cells(4, 1).Font.Size = 7
xlSheet.Cells(4, 1).Interior.ColorIndex = 6

xlSheet.Cells(4, 2) = "Hora"
xlSheet.Cells(4, 2).Font.Bold = True
xlSheet.Cells(4, 2).Borders.LineStyle = 3
xlSheet.Cells(4, 2).Borders.Weight = 1
xlSheet.Cells(4, 2).Font.Name = "Verdana"
xlSheet.Cells(4, 2).Font.Size = 7
xlSheet.Cells(4, 2).Interior.ColorIndex = 6

xlSheet.Cells(4, 3) = "Assunto"
xlSheet.Cells(4, 3).Font.Name = "Verdana"
xlSheet.Cells(4, 3).Font.Bold = True
xlSheet.Cells(4, 3).Borders.LineStyle = 3
xlSheet.Cells(4, 3).Borders.Weight = 1
xlSheet.Cells(4, 3).Font.Size = 7
xlSheet.Cells(4, 3).Interior.ColorIndex = 6

xlSheet.Cells(4, 4) = "Compromissos"
xlSheet.Cells(4, 4).Font.Name = "Verdana"
xlSheet.Cells(4, 4).Font.Bold = True
xlSheet.Cells(4, 4).Borders.LineStyle = 3
xlSheet.Cells(4, 4).Borders.Weight = 1
xlSheet.Cells(4, 4).Font.Size = 7
xlSheet.Cells(4, 4).Interior.ColorIndex = 6

xlSheet.Cells(4, 5) = "Obs"
xlSheet.Cells(4, 5).Font.Bold = True
xlSheet.Cells(4, 5).Borders.LineStyle = 3
xlSheet.Cells(4, 5).Borders.Weight = 1
xlSheet.Cells(4, 5).Font.Name = "Verdana"
xlSheet.Cells(4, 5).Font.Size = 7
xlSheet.Cells(4, 5).Interior.ColorIndex = 6

linha = 6

'10 = 9 + 1 - para acertar os titulos da tabela
frmReld.pgr.Min = 10

Do While Not frmReld.Data1.Recordset.EOF

xlSheet.Cells(linha, 1) = Format(frmReld.Data1.Recordset("dat"), "mm/dd/yyyy")
xlSheet.Cells(linha, 1).Borders.LineStyle = 3
xlSheet.Cells(linha, 1).Borders.Weight = 1
xlSheet.Cells(linha, 1).Font.Name = "Verdana"
xlSheet.Cells(linha, 1).Font.Size = 7

xlSheet.Cells(linha, 2) = frmReld.Data1.Recordset("Hora")
xlSheet.Cells(linha, 2).Borders.LineStyle = 3
xlSheet.Cells(linha, 2).Borders.Weight = 1
xlSheet.Cells(linha, 2).Font.Name = "Verdana"
xlSheet.Cells(linha, 2).Font.Size = 7

xlSheet.Cells(linha, 3) = frmReld.Data1.Recordset("Assunto")
xlSheet.Cells(linha, 3).Borders.LineStyle = 3
xlSheet.Cells(linha, 3).Borders.Weight = 1
xlSheet.Cells(linha, 3).Font.Name = "Verdana"
xlSheet.Cells(linha, 3).Font.Size = 7

xlSheet.Cells(linha, 4) = frmReld.Data1.Recordset("Compromissos")
xlSheet.Cells(linha, 4).Borders.LineStyle = 3
xlSheet.Cells(linha, 4).Borders.Weight = 1
xlSheet.Cells(linha, 4).Font.Name = "Verdana"
xlSheet.Cells(linha, 4).Font.Size = 7

xlSheet.Cells(linha, 5) = frmReld.Data1.Recordset("Obs")
xlSheet.Cells(linha, 5).Borders.LineStyle = 3
xlSheet.Cells(linha, 5).Borders.Weight = 1
xlSheet.Cells(linha, 5).Font.Name = "Verdana"
xlSheet.Cells(linha, 5).Font.Size = 7

frmReld.Data1.Recordset.MoveNext
linha = linha + 1
frmReld.pgr.Value = linha - 6
Loop

xlWork.Close True
xlApp.Quit
Set xlApp = Nothing

GerarPlanilha:

Select Case Err
Case 0

Screen.MousePointer = vbNormal
MsgBox "Relatório gerado com sucesso. Maximize o Excel para ver o arquivo e salve-o com o nome desejado.", vbOKOnly + vbInformation
Shell "C:\Arquivos de programas\Microsoft Office\Office\excel.exe \\melissa\Usr\vb\Agenda.xls"
Case 1004
Unload frmReld
MsgBox "Pronto"
Screen.MousePointer = vbNormal
MsgBox "O caminho não foi encontrado, por favor mude o caminho" & Chr(13) & " nas configurações e tente gerar o mapa novamente!", vbCritical + vbOKOnly

Case 3010
With db
.TableDefs.Refresh
.TableDefs.Delete "CompDia"
.TableDefs.Refresh
End With
Resume
Case Else
MsgBox "Pronto"
Screen.MousePointer = vbNormal
MsgBox Err.Number & "-" & Err.Description, vbCritical + vbOKOnly
xlWork.Close True
xlApp.Quit
Set xlApp = Nothing

End Select
Unload frmReld
End Function

USUARIO.EXCLUIDOS 27/05/2004 15:25:25
#27009

joga esta linha

Set frmReld.Data1.Recordset = db.OpenRecordset("CompDia")

para uma linha antes desta e remove ela lah do meio

USUARIO.EXCLUIDOS 27/05/2004 15:38:50
#27014

frmReld.pgr.Value = 10 + linha - 6 'onde 10 Ã© o numero que voce assumiu lah em cima...

agora se voce precisa fazer a pesquisa antes - uma coisa que voce pode fazer eh rodar com o progress bar duas vezes... - como abaixo

Dim xlApp As Excel.Application
Dim xlWork As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim rela As QueryDef
Dim linha As String

On Error GoTo GerarPlanilha

Screen.MousePointer = vbHourglass

frmReld.pgr.Visible = True
frmReld.pgr.Min = 0

'10 - VALOR TOTAL DE PROCESSO INICIAL (definido por voce)
frmReld.pgr.Max = 10
frmReld.prg.Value = 0

Set xlApp = CreateObject("EXCEL.Application")
Set xlWork = xlApp.Workbooks.Open("C:\Documents and Settings\melissa\Usr\vb\Agenda.xls")
Set xlWork = xlApp.Workbooks(1)
Set xlSheet = xlApp.Worksheets("Dados")

'3 - VALOR QUE DEFINE A CRIACAO DA PLANILHA
frmReld.prg.Value = 3

xlSheet.Cells.Clear

Set rela = db.QueryDefs("ComprDia")
With rela

'7 - antigos 3 + 4 - 4 de Criacao de RELA em querydefs
frmReld.prg.Value = 7

.Parameters("Uma data") = inicial
.Execute

End With

Set frmReld.Data1.Recordset = db.OpenRecordset("CompDia")
frmReld.Data1.Refresh

'9 = 7 + 2 - 2 de refresh e criacao de Recordset
frmReld.pgr.Min = 9

xlSheet.Cells(4, 1) = "Data"
xlSheet.Cells(4, 1).Font.Bold = True
xlSheet.Cells(4, 1).Borders.LineStyle = 3
xlSheet.Cells(4, 1).Borders.Weight = 1
xlSheet.Cells(4, 1).Font.Name = "Verdana"
xlSheet.Cells(4, 1).Font.Size = 7
xlSheet.Cells(4, 1).Interior.ColorIndex = 6

xlSheet.Cells(4, 2) = "Hora"
xlSheet.Cells(4, 2).Font.Bold = True
xlSheet.Cells(4, 2).Borders.LineStyle = 3
xlSheet.Cells(4, 2).Borders.Weight = 1
xlSheet.Cells(4, 2).Font.Name = "Verdana"
xlSheet.Cells(4, 2).Font.Size = 7
xlSheet.Cells(4, 2).Interior.ColorIndex = 6

xlSheet.Cells(4, 3) = "Assunto"
xlSheet.Cells(4, 3).Font.Name = "Verdana"
xlSheet.Cells(4, 3).Font.Bold = True
xlSheet.Cells(4, 3).Borders.LineStyle = 3
xlSheet.Cells(4, 3).Borders.Weight = 1
xlSheet.Cells(4, 3).Font.Size = 7
xlSheet.Cells(4, 3).Interior.ColorIndex = 6

xlSheet.Cells(4, 4) = "Compromissos"
xlSheet.Cells(4, 4).Font.Name = "Verdana"
xlSheet.Cells(4, 4).Font.Bold = True
xlSheet.Cells(4, 4).Borders.LineStyle = 3
xlSheet.Cells(4, 4).Borders.Weight = 1
xlSheet.Cells(4, 4).Font.Size = 7
xlSheet.Cells(4, 4).Interior.ColorIndex = 6

xlSheet.Cells(4, 5) = "Obs"
xlSheet.Cells(4, 5).Font.Bold = True
xlSheet.Cells(4, 5).Borders.LineStyle = 3
xlSheet.Cells(4, 5).Borders.Weight = 1
xlSheet.Cells(4, 5).Font.Name = "Verdana"
xlSheet.Cells(4, 5).Font.Size = 7
xlSheet.Cells(4, 5).Interior.ColorIndex = 6

linha = 6

'10 = 9 + 1 - para acertar os titulos da tabela
frmReld.pgr.Min = 10

frmReld.pgr.Max = frmReld.Data1.Recordset.RecordCount
frmReld.prg.value = 0

Do While Not frmReld.Data1.Recordset.EOF

xlSheet.Cells(linha, 1) = Format(frmReld.Data1.Recordset("dat"), "mm/dd/yyyy")
xlSheet.Cells(linha, 1).Borders.LineStyle = 3
xlSheet.Cells(linha, 1).Borders.Weight = 1
xlSheet.Cells(linha, 1).Font.Name = "Verdana"
xlSheet.Cells(linha, 1).Font.Size = 7

xlSheet.Cells(linha, 2) = frmReld.Data1.Recordset("Hora")
xlSheet.Cells(linha, 2).Borders.LineStyle = 3
xlSheet.Cells(linha, 2).Borders.Weight = 1
xlSheet.Cells(linha, 2).Font.Name = "Verdana"
xlSheet.Cells(linha, 2).Font.Size = 7

xlSheet.Cells(linha, 3) = frmReld.Data1.Recordset("Assunto")
xlSheet.Cells(linha, 3).Borders.LineStyle = 3
xlSheet.Cells(linha, 3).Borders.Weight = 1
xlSheet.Cells(linha, 3).Font.Name = "Verdana"
xlSheet.Cells(linha, 3).Font.Size = 7

xlSheet.Cells(linha, 4) = frmReld.Data1.Recordset("Compromissos")
xlSheet.Cells(linha, 4).Borders.LineStyle = 3
xlSheet.Cells(linha, 4).Borders.Weight = 1
xlSheet.Cells(linha, 4).Font.Name = "Verdana"
xlSheet.Cells(linha, 4).Font.Size = 7

xlSheet.Cells(linha, 5) = frmReld.Data1.Recordset("Obs")
xlSheet.Cells(linha, 5).Borders.LineStyle = 3
xlSheet.Cells(linha, 5).Borders.Weight = 1
xlSheet.Cells(linha, 5).Font.Name = "Verdana"
xlSheet.Cells(linha, 5).Font.Size = 7

frmReld.Data1.Recordset.MoveNext
linha = linha + 1
frmReld.pgr.Value = linha - 6
Loop

xlWork.Close True
xlApp.Quit
Set xlApp = Nothing

GerarPlanilha:

Select Case Err
Case 0

Screen.MousePointer = vbNormal
MsgBox "Relatório gerado com sucesso. Maximize o Excel para ver o arquivo e salve-o com o nome desejado.", vbOKOnly + vbInformation
Shell "C:\Arquivos de programas\Microsoft Office\Office\excel.exe \\melissa\Usr\vb\Agenda.xls"
Case 1004
Unload frmReld
MsgBox "Pronto"
Screen.MousePointer = vbNormal
MsgBox "O caminho não foi encontrado, por favor mude o caminho" & Chr(13) & " nas configurações e tente gerar o mapa novamente!", vbCritical + vbOKOnly

Case 3010
With db
.TableDefs.Refresh
.TableDefs.Delete "CompDia"
.TableDefs.Refresh
End With
Resume
Case Else
MsgBox "Pronto"
Screen.MousePointer = vbNormal
MsgBox Err.Number & "-" & Err.Description, vbCritical + vbOKOnly
xlWork.Close True
xlApp.Quit
Set xlApp = Nothing

End Select
Unload frmReld
End Function

Página única

Tópico encerrado , respostas não são mais permitidas

Voltar