DECLARATION
Dim session As NotesSession
Dim wks As NotesUIWorkspace
Dim db
As NotesDataBase
Dim Uiview As NotesUIView
Dim view As NotesView
Dim column As NotesViewColumn
Dim doc
As NotesDocument
Dim qtdePlanilha As Long
Dim Linha
As Long
Dim Coluna As Long
Dim ExcelApp As Variant
Dim WorkBook As Variant
Dim NomePlanilha As Variant
Dim ConteudoColuna As Variant
Dim PrimeiroTraco As Variant
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
INICIALIZE
Sub Initialize
On Error Goto TratarErro
Dim Path As String
Dim QtdeTotalDocs As Long
Dim qtdedocs As Long
Set session = New NotesSession
Set wks = New NotesUIWorkspace
Set uiView = wks.CurrentView
Set db
= session.CurrentDataBase
Set view = db.GetView( uiView.ViewName ) ' seta a visão corrente
Set doc = view.GetFirstDocument
QtdeTotalDocs = view.AllEntries.Count
NomePlanilha = view.Aliases
Path = "N:\GJD_Online\EXPORTACAO_JAN2012\"
If doc Is Nothing Then
Msgbox "Não existem documentos para exportar."
Exit Sub
End If
Set ExcelApp = CreateObject("Excel.Application")
With ExcelApp
.Visible
= True
Set WorkBook
= .Workbooks
WorkBook.Add
'*****************************************************************************************************************************************************************************************
If QtdeTotalDocs > 65536 Then ' se quantidade de documentos da visão corrente for maior que o total de linhas do excel
QtdePlanilha = 1 ' inicializa QtdePlanilha para gerar varias planilhas da mesma visão
Else
QtdePlanilha = 0
End If
'*****************************************************************************************************************************************************************************************
'*************************************************************PREENCHIMENTO DO CABEÇALHO EXCEL****************************************************************************
Coluna = 1 'inicializa a coluna para preencher o cabeçalho
Call sub__Cabecalho()
'******************************************************************************************************************************************************************************************
Linha = 2 'preenche as informações a partir da linha 2
qtdedocs = 1 ' quantidade de documentos exportados
While Not doc Is Nothing
%REM
'******************************************************************** criação de novas planilhas no mesmo arquivo excel***************************************************
If Linha > 65536 Then
NomePlanilha = "Plan" + Cstr(qtdePlanilha)
ExcelApp.Sheets(NomePlanilha).Select ' seleciona a proxima planilha da mesma pasta
If qtdePlanilha > 3 Then
ExcelApp.Sheets.Add ' adiciona nova planilha
End If
Coluna = 1 ' inicializa a coluna para preencher o cabeçalho
Call sub__Cabecalho()
Coluna = 1 ' inicializa a coluna para preencher as informações
Linha = 2 ' inicializa a linha
qtdePlanilha = qtdePlanilha + 1
Else
Coluna = 1
End If
'********************************************************************************************************************************************************************************
%END REM
Coluna = 1
Forall col In view.Columns
'*****************************************************INCLUSÃO DE UM ESPAÇO VAZIO NO INICO DO TEXTO PARA TRATAR O ERRO NA EXPORTAÇÃO ( automation object error)**********************
If Instr(col.Title,"COMENTARIO") > 0 Or Instr(col.Title,"DESCRICAO") > 0 Or Instr(col.Title,"OBSERVA") Then
If Not Isarray(doc.ColumnValues(Coluna-1)) Then
PrimeiroTraco = Left(doc.ColumnValues(Coluna-1),1)
If PrimeiroTraco = "-" Or PrimeiroTraco = "=" Then
ConteudoColuna = " " + doc.ColumnValues(Coluna-1)
Else
ConteudoColuna = doc.ColumnValues(Coluna-1)
End If
End If
Else ' não é campo de comentario
ConteudoColuna = doc.ColumnValues(Coluna-1)
End If
'****************************************************************************************************************************************************************************************
If Isempty(ConteudoColuna)Then
.cells(Linha,Coluna) = ""
Else
If Isarray(ConteudoColuna) Then ' é um array
.cells(Linha,Coluna) = Join(ConteudoColuna,",") ' transforma array em uma string
Else ' não é array
If Isnumeric(ConteudoColuna) Then
If Instr(Ucase(col.Title),"DAT") > 0 Or Instr(Ucase(col.Title),"DT") > 0 Or Instr(Ucase(col.Title),"AJUIZAMENTO")_ ' CAMPOS DE DATA
Or Instr(Ucase(col.Title),"ID") > 0 Then
.cells(Linha,Coluna) = Cstr(ConteudoColuna)
Else
.cells(Linha,Coluna).FormulaR1C1 = ConteudoColuna ' Retorna ou define a fórmula para o objeto, usando notação em estilo L1C1 no idioma do usuário
End If
Else ' não é numero
.cells(Linha,Coluna) = Cstr(ConteudoColuna)
End If ' IS NUMERIC
End If ' IS ARRAY
End If ' IS EMPTY
Coluna = Coluna + 1
End Forall
If QtdeTotalDocs > 65536 And Linha = 65536 Then ' ultimo registro do excel
'salva a planilha
.ActiveWorkbook.SaveAs Path & NomePlanilha(0) & "_" + Cstr(QtdePlanilha)
'Criar outro arquivo excel ( pasta)
.Workbooks.Add
Coluna = 1 ' inicializa a coluna para preencher o cabeçalho
Call sub__Cabecalho()
Coluna = 1 ' inicializa a coluna para preencher as informações
Linha = 2 ' inicializa a linha
QtdePlanilha = QtdePlanilha + 1
Elseif (QtdeTotalDocs = qtdedocs) And (QtdePlanilha > 0) Then ' ultimo doc exportado
.ActiveWorkbook.SaveAs Path & NomePlanilha(0) & "_" + Cstr(QtdePlanilha) ' salva arquivo
Else
Linha = Linha + 1
End If
Set doc = view.GetNextDocument(doc)
If Not doc Is Nothing Then
qtdedocs = qtdedocs + 1
End If
Wend
'********************************************CONVERTE AS COLUNAS DE DATA PARA O TIPO GERAL***********************************
Coluna = 1
Forall col In view.Columns
Set column = view.Columns( Coluna -1)
If column.Formula<>"""1""" And column.Formula<>"1" Then
If Instr(Ucase(col.Title),"DAT") > 0 Or Instr(Ucase(col.Title),"DT") > 0 Or Instr(Ucase(col.Title),"AJUIZAMENTO")_
Or Instr(Ucase(col.Title),"VALOR") > 0 Or Instr(Ucase(col.Title),"LITRO") >0 Or Instr(Ucase(col.Title),"ID") > 0 Then
ExcelApp.Columns(Coluna).NumberFormat = "Geral" ' Converte a coluna para o tipoGeral
End If
End If
Coluna = Coluna + 1
End Forall
'*****************************************************************************************************************************************************
If QtdePlanilha = 0 Then
.ActiveWorkbook.SaveAs Path & NomePlanilha(0)
End If
Set ExcelApp
= Nothing
Set WorkBook
= Nothing
End With
Exit Sub
TratarErro:
If Not ExcelApp Is Nothing Then
Set ExcelApp = Nothing
Set WorkBook = Nothing
'Call ExcelApp.Quit
End If
Msgbox "Erro " + Cstr(Err) + " " + Error + " Na linha " + Cstr(Erl)
End Sub
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
FUNCTION REPLACESUBSTRING
Function ReplaceSubstring(StrConteudo As String, StrDe As String, StrPara As String) As String
' Essa Função substitui caracteres na String que é passada atraves da variavel StrConteudo
' StrDe é(são) o(s) caracter(es) a ser(em) alteardo(s)
'StrPara (é(são) o(s) novo(s) caracter(es)
Dim StrTemp As String
Dim StrConvertido As String
Dim i As Long
Dim length As Long
StrTemp = StrConteudo
If Len(StrDe) = 0 Then
ReplaceSubstring = StrConteudo
Exit Function
End If
If Instr(StrPara, StrDe) <> 0 Then
i = 128
length = 1
StrConvertido = ""
While StrConvertido = ""
If Instr(StrTemp, String$(length, Chr$(i))) = 0 Then StrConvertido = String$(length, Chr$(i))
i = i + 1
If i = 256 Then
length = length + 1
i = 128
End If
Wend
While Instr(StrTemp, StrDe) <> 0
StrTemp = Left(StrTemp, Instr(StrTemp, StrDe)-1) & StrConvertido _
& Mid(StrTemp, Instr(StrTemp, StrDe)+Len(StrDe))
Wend
While Instr(StrTemp, StrConvertido) <> 0
StrTemp = Left(StrTemp, Instr(StrTemp, StrConvertido)-1) & StrPara _
& Mid(StrTemp, Instr(StrTemp, StrConvertido)+Len(StrConvertido))
Wend
Else
While Instr(StrTemp, StrDe) <> 0
StrTemp = Left(StrTemp, Instr(StrTemp, StrDe)-1) & StrPara _
& Mid(StrTemp, Instr(StrTemp, StrDe)+Len(StrDe))
Wend
End If
ReplaceSubstring = StrTemp
End Function
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
SUB_CABECALHO
Sub sub__Cabecalho ()
'preencher o cabeçalho
Forall col In view.Columns
Set column = view.Columns( Coluna -1)
If column.Formula<>"""1""" And column.Formula<>"1" Then
'As colunas com valores de data, foram convertidas para texto para o tratamento do erro "automation object error" devido a data invalida com ano de 3 digitos
If Instr(Ucase(col.Title),"COMENTARIO") > 0 Or Instr(Ucase(col.Title),"DESCRICAO") > 0 Or Instr(Ucase(col.Title),"OBSERVA") Or Instr(Ucase(col.Title),"DAT") > 0_
Or Instr(Ucase(col.Title),"DT") > 0 Or Instr(Ucase(col.Title),"AJUIZAMENTO") > 0 Or Instr(Ucase(col.Title),"VALOR") > 0 Or Instr(Ucase(col.Title),"LITRO") >0_
Or Instr(Ucase(col.Title),"ID") > 0 Then
ExcelApp.Columns(Coluna).NumberFormat = "@" ' Converte a coluna para o tipo Texto
End If
ExcelApp.cells(1,coluna) = column.Title
ExcelApp.Columns(Coluna).EntireColumn.AutoFit
Coluna = Coluna + 1
End If
End Forall
End Sub
