Exportação Genêrica para Excel

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