Follows a simple LotusScript function that will embed a file system picture (strFilePath As String) into the Body RichText field of a Notes document (doc As NotesDocument). This will not embed as an icon, but as the image itself.
Function EmbedPictureIntoRichText(doc As NotesDocument, strFilePath As String) As Boolean
EmbedPictureIntoRichText = False
Dim session As New NotesSession
Dim db As NotesDatabase
Dim body As NotesMIMEEntity
Dim header As NotesMIMEHeader
Dim child As NotesMIMEEntity
Dim stream As NotesStream
Dim fileFormat As String
Dim rtitemA As NotesRichTextItem
Dim rtitemB As NotesRichTextItem
Set db = doc.Parentdatabase
Set stream = session.CreateStream
Call stream.Open(strFilePath)
Set body = doc.CreateMIMEEntity("DummyRichText")
Set header = body.CreateHeader("Content-Type")
Call header.SetHeaderVal("multipart/mixed")
Set child = body.CreateChildEntity() 'Set childEntity = richTextItemObj.CreateChildEntity()
fileFormat = "image/jpeg" 'Other formats are "image/gif" "image/bmp"
Call child.Setcontentfrombytes(stream, fileFormat, 1730)
Call stream.Close()
Call doc.save(false, false) 'JUST TO REFRESH
Set rtitemA = doc.GetFirstItem("Body")
Set rtitemB = doc.GetFirstItem("DummyRichText")
Call rtitemA.AppendRTItem( rtitemB )
Call rtitemB.Remove()
Call doc.save(False, False)
EmbedPictureIntoRichText = True
End Function
terça-feira, 31 de janeiro de 2012
Classe XML
REF http://www.vbweb.com.br/dicas_visual.asp?Codigo=2256
.. classe para trabalhar com XML, espero q ajude. Na verdade, a classe serve mais para criar XML, sem ter q ficar dando um monte de comandos...
Class ClsXML
Public Root
Public XML
Private PIs
Sub NewXML(TagPai, versao)
Set XML = CreateObject ("Msxml2.DOMDocument" & Versao)
XML.Async = False
Set Root = XML.CreateElement(TagPai)
XML.AppendChild(Root)
Set PIs = XML.CreateProcessingInstruction("xml", "version='1.0' encoding='ISO-8859-1'")
XML.InsertBefore PIs, Root
End Sub
Function Open(Path, versao)
Dim Result
Set XML = CreateObject ("Msxml2.DOMDocument" & Versao)
XML.Async = False
Result = XML.Load(Path)
if Result = true then
Set Root = XML.DocumentElement
end if
Open = Result
End Function
Function CriaNodo(TagPai, Nome, Atributos, ValorAtributos,ValorNodo)
Dim Nodo
Dim Valor
Set Nodo = XML.CreateElement(Nome)
If TagPai Is Nothing Then
XML.AppendChild(Nodo)
Else
TagPai.AppendChild(Nodo)
End If
If Isarray(Atributos) And Isarray(ValorAtributos) Then
NumAtributos = Ubound(Atributos)
For i = 0 To NumAtributos
Call Nodo.setAttribute(Atributos(i), ValorAtributos(i))
Next
End If
If ValorNodo <> "" Then
Set Valor = XML.CreateTextNode(ValorNodo)
Nodo.AppendChild(Valor)
End If
Set CriaNodo = Nodo
Set Nodo = Nothing
Set Valor = Nothing
End Function
Function RemoveNodo(Expressao)
Dim Nodo
Set Nodo = Xml.GetElementsByTagName(Expressao)
if not Nodo is nothing then
Call Nodo.RemoveAll
RemoveNodo = true
else
RemoveNodo = false
end if
End Function
Sub Save (Caminho)
Call XML.Save(Caminho)
End Sub
End Class
Usando a Classe para criar um XML com a seguinte estrutura:
Rodrigo
Lotus Notes
Dim NomeAtributos(), ValorAtributos()
Set objXML = New ClsXML()
'O primeiro parâmetro é a Tag pai de todas, o segundo é a versão do MSXML q você quer usar
Call NewXML("teste", "")
Redim NomeAtributos(0), ValorAtributos(0)
NomeAtributos(0) = "nome"
ValorAtributos(0) = "Teste"
Set Tag1 = objXML.CriaNodo(objXML.root, "tag1", NomeAtributos, ValorAtributos, "")
Call objXML.CriaNodo(Tag1, "nome1", "", "", "Rodrigo")
Call objXML.CriaNodo(Tag1, "ferramenta", "", "", "Lotus Notes")
Call objXML.Save("teste")
.. classe para trabalhar com XML, espero q ajude. Na verdade, a classe serve mais para criar XML, sem ter q ficar dando um monte de comandos...
Class ClsXML
Public Root
Public XML
Private PIs
Sub NewXML(TagPai, versao)
Set XML = CreateObject ("Msxml2.DOMDocument" & Versao)
XML.Async = False
Set Root = XML.CreateElement(TagPai)
XML.AppendChild(Root)
Set PIs = XML.CreateProcessingInstruction("xml", "version='1.0' encoding='ISO-8859-1'")
XML.InsertBefore PIs, Root
End Sub
Function Open(Path, versao)
Dim Result
Set XML = CreateObject ("Msxml2.DOMDocument" & Versao)
XML.Async = False
Result = XML.Load(Path)
if Result = true then
Set Root = XML.DocumentElement
end if
Open = Result
End Function
Function CriaNodo(TagPai, Nome, Atributos, ValorAtributos,ValorNodo)
Dim Nodo
Dim Valor
Set Nodo = XML.CreateElement(Nome)
If TagPai Is Nothing Then
XML.AppendChild(Nodo)
Else
TagPai.AppendChild(Nodo)
End If
If Isarray(Atributos) And Isarray(ValorAtributos) Then
NumAtributos = Ubound(Atributos)
For i = 0 To NumAtributos
Call Nodo.setAttribute(Atributos(i), ValorAtributos(i))
Next
End If
If ValorNodo <> "" Then
Set Valor = XML.CreateTextNode(ValorNodo)
Nodo.AppendChild(Valor)
End If
Set CriaNodo = Nodo
Set Nodo = Nothing
Set Valor = Nothing
End Function
Function RemoveNodo(Expressao)
Dim Nodo
Set Nodo = Xml.GetElementsByTagName(Expressao)
if not Nodo is nothing then
Call Nodo.RemoveAll
RemoveNodo = true
else
RemoveNodo = false
end if
End Function
Sub Save (Caminho)
Call XML.Save(Caminho)
End Sub
End Class
Usando a Classe para criar um XML com a seguinte estrutura:
Dim NomeAtributos(), ValorAtributos()
Set objXML = New ClsXML()
'O primeiro parâmetro é a Tag pai de todas, o segundo é a versão do MSXML q você quer usar
Call NewXML("teste", "")
Redim NomeAtributos(0), ValorAtributos(0)
NomeAtributos(0) = "nome"
ValorAtributos(0) = "Teste"
Set Tag1 = objXML.CriaNodo(objXML.root, "tag1", NomeAtributos, ValorAtributos, "")
Call objXML.CriaNodo(Tag1, "nome1", "", "", "Rodrigo")
Call objXML.CriaNodo(Tag1, "ferramenta", "", "", "Lotus Notes")
Call objXML.Save("teste")
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
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
Ordenar um NotesDocumentCollection por um campo
// Sorts a NotesDocumentCollection by item name
// @param col, unsorted NotesDocumentCollection
// @param iName, the name of the item to sort the collection by.
// @return sorted NotesDocumentCollection
// @author Ulrich Krause
// @version 1.0
function sortColByItemName(col:NotesDocumentCollection, iName:String) {
var rl:java.util.Vector = new java.util.Vector();
var doc:NotesDocument = col.getFirstDocument();
var tm:java.util.TreeMap = new java.util.TreeMap();
while (doc != null) {
tm.put(doc.getItemValueString(iName), doc);
doc = col.getNextDocument(doc);
}
var tCol:java.util.Collection = tm.values();
var tIt:java.util.Iterator = tCol.iterator();
while (tIt.hasNext()) {
rl.add(tIt.next());
}
return rl;
}
// @param col, unsorted NotesDocumentCollection
// @param iName, the name of the item to sort the collection by.
// @return sorted NotesDocumentCollection
// @author Ulrich Krause
// @version 1.0
function sortColByItemName(col:NotesDocumentCollection, iName:String) {
var rl:java.util.Vector = new java.util.Vector();
var doc:NotesDocument = col.getFirstDocument();
var tm:java.util.TreeMap = new java.util.TreeMap();
while (doc != null) {
tm.put(doc.getItemValueString(iName), doc);
doc = col.getNextDocument(doc);
}
var tCol:java.util.Collection = tm.values();
var tIt:java.util.Iterator = tCol.iterator();
while (tIt.hasNext()) {
rl.add(tIt.next());
}
return rl;
}
Cálculo de dias úteis
REM{ Numero de dias para atender};
nDiasAtendimento := @DbLookup("";"";"viewBuscaProdt";@Text(mnfstProduto+"#"+mnfstCorrente) ;12);
REM{contador recebe o número de dias para atender};
cont := @TextToNumber(nDiasAtendimento);
REM{dataPrevista recebe a data selecionada no sistema para iniciar o atendimento};
dataPrevista := mnfstDataManifest;
@While(cont > 0;
REM{Adiciona + 1 dia se o dia for diferente de domingo ou sabado};
dataPrevista := @Adjust(dataPrevista;0;0;1;0;0;0);
diaSemana := @Weekday(dataPrevista);
@If(diaSemana = 1 | diaSemana = 7 ; cont := cont ; cont := cont - 1)
);
dataPrevista
nDiasAtendimento := @DbLookup("";"";"viewBuscaProdt";@Text(mnfstProduto+"#"+mnfstCorrente) ;12);
REM{contador recebe o número de dias para atender};
cont := @TextToNumber(nDiasAtendimento);
REM{dataPrevista recebe a data selecionada no sistema para iniciar o atendimento};
dataPrevista := mnfstDataManifest;
@While(cont > 0;
REM{Adiciona + 1 dia se o dia for diferente de domingo ou sabado};
dataPrevista := @Adjust(dataPrevista;0;0;1;0;0;0);
diaSemana := @Weekday(dataPrevista);
@If(diaSemana = 1 | diaSemana = 7 ; cont := cont ; cont := cont - 1)
);
dataPrevista
Assinar:
Postagens (Atom)