Calcular o número de dias úteis entre duas datas

The following formula counts the number of weekdays (but not weekend days):

diffDays := (EndDate - StartDate) / 86400 + 1;
strtDay := @Modulo(@Weekday(StartDate); 7);
endDay := @Modulo(@c(EndDate); 7);
result := (diffDays - endDay + strtDay - 8) * 5 / 7 - @Max(-2; -strtDay) - @Min(1; endDay) + 5 - strtDay + endDay

Recuperar valores de células de tabelas no campo rich-text

Developers sometimes need to retrieve cell values within a table in a Lotus Notes rich-text field (RTF). The following LotusScript code will display the values in each cell within the body of any Lotus Notes mail document.
GetElementCount is used to count different types of RichTextItems in a field. This example uses the Table type.
Sub Initialize
Dim ws As New NotesUIWorkspace
Dim s As New NotesSession
Dim db As NotesDatabase
Dim dc As NotesDocumentCollection
Dim maildoc As NotesDocument
Dim rtitem As NotesRichTextItem
Dim rtnav As NotesRichTextNavigator


Set db=s.CurrentDatabase
Set dc=db.UnprocessedDocuments

If dc.Count>1 Then
Msgbox "Please select a single document", MB_OK,
"Travel HelpDesk"
Continue=False
End
Else
Set maildoc=dc.GetFirstDocument()
Set rtitem=maildoc.GetFirstItem("Body")
Set rtnav=rtitem.CreateNavigator
count = GetElementCount(rtnav, RTELEM_TYPE_TABLE)
'msg$ = msg$ & "Tables:" & Chr(9) & Chr(9) & count% & Chr(10)
'Messagebox msg$,, maildoc.Subject(0)
If count=0 Then
Messagebox "Body item does not contain a table,",, _
"Error"
Exit Sub
End If

For k=1 To count
If rtnav.FindNthElement(RTELEM_TYPE_TABLE,k) Then
Dim rttab As NotesRichTextTable
Set rttab=rtnav.GetElement
Dim rtrange As NotesRichTextRange
Set rtrange=rtitem.CreateRange
If k=1 Then
Call rtnav.FindFirstElement(RTELEM_TYPE_TABLECELL)
Else
Call rtnav.FindNextElement(RTELEM_TYPE_TABLECELL)
End If

firstFlag = True

For i& = 1 To rttab.RowCount
For j& = 1 To rttab.ColumnCount
If Not firstFlag Then
Call rtnav.FindNextElement(RTELEM_TYPE_TABLECELL)
Else
firstFlag = False
End If
Call rtrange.SetBegin(rtnav)
Messagebox rtrange.TextParagraph,, _
"Row " & i& & _
", Column " & j&
Next
Next
End If
Next
End If

End Sub

Function GetElementCount(rtnav As NotesRichTextNavigator,
eType As Integer) As Integer
GetElementCount = 0
If rtnav.FindFirstElement(eType) Then
Do
GetElementCount = GetElementCount + 1
Loop While rtnav.FindNextElement()
End If
End Function

Biblioteca de exportação para Excel e Word

'MSOffice_Integration:

Option Public
Use "GlobalVariables"


Dim objExcel As Variant
Dim varPathDest As Variant
Dim objWord As Variant
Dim worddoc As Variant
Dim word As Variant





Public Function EXCEL_CreateFile() As Integer
'******************************************************************************************************************************
'OBJETIVO: Criar uma instância do Excel
'PARÂMETROS: Nenhum
'RETORNO: True : Instância Criada
' False : Instância não criada
'******************************************************************************************************************************
Dim ws As New NotesUIWorkspace

' varPathDest = ws.SaveFileDialog( False )
' If Not Isempty(varPathDest) Then
' If varPathDest(0) <> "" Then

'Cria o objeto do excel
Set objExcel = CreateObject("Excel.Application")
objExcel.DisplayAlerts = False
objExcel.Visible = False
Call objExcel.Workbooks.Add


EXCEL_CreateFile = True

' Else
' EXCEL_CreateFile = False
' End If
' Else
' EXCEL_CreateFile = False
' End If
End Function



Public Sub EXCEL_AddCell(intCol As Integer, intLin As Integer, varValor As Variant)
'******************************************************************************************************************************
'OBJETIVO: Adiciona um determinado valor a uma célula dentro do arquivo no Excel
'PARÂMETROS: intCol [Integer] - Informa o código ASCII da célula do excel (Ex. A = 65).
' intLin [Integer] - Informa a linha da célula do excel
' varValor [Variant] - Informa o valor que será colocado na célula
'RETORNO: Nenhum
'******************************************************************************************************************************
objExcel.Cells(intLin, intCol).value = varValor
End Sub




Public Sub EXCEL_SaveFile(flagAbreArquivo As Integer)
'******************************************************************************************************************************
'OBJETIVO: Salva a instância do Excel na máquina
'PARÂMETROS: flagAbreArquivo [Integer] - Informa se o arquivo deve ser aberto na tela ou não.
'RETORNO: Nenhum
'******************************************************************************************************************************

Call objExcel.ActiveWorkbook.SaveAs(varPathDest(0))

If flagAbreArquivo Then
objExcel.Visible = True
Else
objExcel.Visible = False
Call objExcel.ActiveWorkbook.Close
objExcel.Quit
Set objExcel = Nothing
End If
End Sub


Public Sub EXCEL_MergeCells(intColInicio As Integer, intLinInicio As Integer, intColFim As Integer, intLinFim As Integer)
'******************************************************************************************************************************
'OBJETIVO: Mescla células dentro do arquivo no Excel
'PARÂMETROS: intColInicio [Integer] - Informa o código ASCII da coluna inicial a ser mesclada (Ex. A = 65).
' intLinInicio [Integer] - Informa a linha inicial a ser mesclada
' intColFim [Integer] - Informa o código ASCII da coluna final a ser mesclada (Ex. A = 65).
' intLinFim [Integer] - Informa a linha final a ser mesclada
'RETORNO: Nenhum
'******************************************************************************************************************************
Call objExcel.Range(objExcel.Cells(intLinInicio, intColInicio), objExcel.Cells(intLinFim, intColFim)).Select
objExcel.Selection.Merge
End Sub


Public Sub EXCEL_FormatCell(intCol As Integer, intLin As Integer, intInteriorColor As Integer, _
intFontColor As Integer, intColWidth As Integer, flagBold As Integer, _
flagWrapText As Integer, flagCenterAlign As Integer)
'******************************************************************************************************************************
'OBJETIVO: Adiciona um determinado valor a uma célula dentro do arquivo no Excel
'PARÂMETROS: intCol [Integer] - Informa o código ASCII da célula do excel (Ex. A = 65).
' intLin [Integer] - Informa a linha da célula do excel
' intInteriorColor [Integer] - Informa o numero que representa a cor do preenchimento da célula
' intFontColor [Integer] - Informa o numero que representa a cor da fonte do texto da célula
' intColWidth [Integer] - Informa a largura da célula
' flagBold [boolean] - Informa se o texto será em negrito ou não
' flagWrapText [boolean] - Informa se deseja que o texto quebre de linha automaticamente
' flagCenterAlign [boolean] - Informa se deseja centralizar ou não o texto da célula

'RETORNO: Nenhum
'******************************************************************************************************************************
Call objExcel.Range(objExcel.Cells(intLin, intCol), objExcel.Cells(intLin, intCol)).Select
With objExcel.Selection
If intInteriorColor <> 0 Then
.Interior.ColorIndex = intInteriorColor
.Interior.Pattern = 1
End If

.Font.Bold = flagBold
.Font.ColorIndex = intFontColor

If flagCenterAlign Then
.HorizontalAlignment = -4108
Else
.HorizontalAlignment = -4131
End If

.VerticalAlignment = -4108
.WrapText = flagWrapText
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = -5002
.MergeCells = False
End With

If intColWidth > 0 Then
objExcel.Columns(intCol).ColumnWidth = intColWidth
End If
End Sub

Public Sub EXCEL_GenerateChart(intColInicio As Integer, intLinInicio As Integer, intColFim As Integer, intLinFim As Integer, strTextoFiltro As String)
With objExcel
Call .Range(.Cells(intLinInicio, intColInicio), .Cells(intLinFim, intColFim)).Select
.Charts.Add
.ActiveChart.ChartType = 54
.ActiveChart.SetSourceData .Sheets("Plan1").Range(.Sheets("Plan1").Cells(intLinInicio, intColInicio), .Sheets("Plan1").Cells(intLinFim, intColFim)), 2
.ActiveChart.Location 2, "Plan2"
End With

With objExcel.ActiveChart
.HasTitle = True

If strTextoFiltro <> "" Then
.ChartTitle.Characters.Text = strTextoFiltro + Chr(13) + "Pesquisa de Reação - Índice de Favorabilidade"
Else
.ChartTitle.Characters.Text = "Pesquisa de Reação - Índice de Favorabilidade"
End If

.Axes(1).HasTitle = False
.Axes(3).HasTitle = False
.Axes(2).HasTitle = False
End With
With objExcel.ActiveChart
.HasAxis(1) = True
.HasAxis(3) = False
.HasAxis(2) = True
End With
objExcel.ActiveChart.Axes(1).CategoryType = -4105
objExcel.ActiveChart.HasLegend = False
objExcel.ActiveChart.HasDataTable = False
objExcel.ActiveChart.ChartArea.Select
objExcel.ActiveChart.ChartArea.AutoScaleFont = True

objExcel.ActiveChart.ApplyDataLabels True, False, False, False, False, False, True, False

With objExcel.ActiveChart.ChartArea.Font
.Name = "Arial"
.FontStyle = "Normal"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = -4142
.ColorIndex = -4105
.Background = -4105
End With

For x = 1 To objExcel.ActiveChart.SeriesCollection.Count
objExcel.ActiveChart.SeriesCollection(x).DataLabels.Select
With objExcel.ActiveChart.SeriesCollection(x).DataLabels.Border
.Weight = 1
.LineStyle = -4105
End With
objExcel.ActiveChart.SeriesCollection(x).DataLabels.Shadow = True
objExcel.ActiveChart.SeriesCollection(x).DataLabels.Interior.ColorIndex = -4105
objExcel.ActiveChart.SeriesCollection(x).DataLabels.AutoScaleFont = True
With objExcel.ActiveChart.SeriesCollection(x).DataLabels.Font
.Name = "Arial"
.FontStyle = "Negrito"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = -4142
.ColorIndex = -4105
.Background = -4105
End With
Next

With objExcel.ActiveChart.ChartTitle.Font
.Name = "Arial"
.FontStyle = "Negrito"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = -4142
.ColorIndex = -4105
.Background = -4105
End With

With objExcel.ActiveChart.ChartTitle
.HorizontalAlignment = -4131
.VerticalAlignment = -4108
.ReadingOrder = -5002
.Orientation = -4128
End With

objExcel.ActiveChart.Walls.Select
With objExcel.ActiveChart
.Elevation = 15
.Perspective = 30
.Rotation = 20
.RightAngleAxes = True
.HeightPercent = 100
.AutoScaling = True
End With
End Sub

Public Sub EXCEL_GenerateChart2(intColInicio As Integer, intLinInicio As Integer, intColFim As Integer, intLinFim As Integer, strTextoFiltro As String)
With objExcel
.Charts.Add
.ActiveChart.ChartType = 54
.ActiveChart.SetSourceData .Sheets("Plan1").Range(.Sheets("Plan1").Cells(intLinInicio, intColInicio), .Sheets("Plan1").Cells(intLinFim, intColFim)), 2
.ActiveChart.Location 2, "Plan2"
End With

With objExcel.ActiveChart
.HasTitle = True

If strTextoFiltro <> "" Then
.ChartTitle.Characters.Text = strTextoFiltro + Chr(13) + "Pesquisa de Reação"
Else
.ChartTitle.Characters.Text = "Pesquisa de Reação"
End If

.Axes(1).HasTitle = False
.Axes(3).HasTitle = False
.Axes(2).HasTitle = False
.HasAxis(1) = True
.HasAxis(3) = False
.HasAxis(2) = True
End With

objExcel.ActiveChart.Axes(1).CategoryType = -4105
objExcel.ActiveChart.HasLegend = True
objExcel.ActiveChart.HasDataTable = False
objExcel.ActiveChart.ChartArea.Select
objExcel.ActiveChart.ChartArea.AutoScaleFont = True

objExcel.ActiveChart.ApplyDataLabels True, False, False, False, False, False, True, False

With objExcel.ActiveChart.ChartArea.Font
.Name = "Arial"
.FontStyle = "Normal"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = -4142
.ColorIndex = -4105
.Background = -4105
End With

For x = 1 To objExcel.ActiveChart.SeriesCollection.Count
objExcel.ActiveChart.SeriesCollection(x).DataLabels.Select
With objExcel.ActiveChart.SeriesCollection(x).DataLabels.Border
.Weight = 1
.LineStyle = -4105
End With
objExcel.ActiveChart.SeriesCollection(x).DataLabels.Shadow = True
objExcel.ActiveChart.SeriesCollection(x).DataLabels.Interior.ColorIndex = -4105
objExcel.ActiveChart.SeriesCollection(x).DataLabels.AutoScaleFont = True
With objExcel.ActiveChart.SeriesCollection(x).DataLabels.Font
.Name = "Arial"
.FontStyle = "Negrito"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = -4142
.ColorIndex = -4105
.Background = -4105
End With
Next

With objExcel.ActiveChart.ChartTitle.Font
.Name = "Arial"
.FontStyle = "Negrito"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = -4142
.ColorIndex = -4105
.Background = -4105
End With

With objExcel.ActiveChart.ChartTitle
.HorizontalAlignment = -4131
.VerticalAlignment = -4108
.ReadingOrder = -5002
.Orientation = -4128
End With

objExcel.ActiveChart.Walls.Select
With objExcel.ActiveChart
.Elevation = 15
.Perspective = 30
.Rotation = 20
.RightAngleAxes = True
.HeightPercent = 100
.AutoScaling = True
End With
End Sub

Public Sub EXCEL_GenerateChart3(intColInicio As Integer, intLinInicio As Integer, intColFim As Integer, intLinFim As Integer, strTextoFiltro As String)
With objExcel
.Range(.Cells(intLinInicio, intColInicio), .Cells(intLinFim, intColFim)).Select
.Charts.Add
.ActiveChart.ChartType = 54
.ActiveChart.SetSourceData .Sheets("Plan1").Range(.Sheets("Plan1").Cells(intLinInicio, intColInicio), .Sheets("Plan1").Cells(intLinFim, intColFim)), 2
.ActiveChart.Location 2, "Plan2"
End With

With objExcel.ActiveChart
.HasTitle = True

If strTextoFiltro <> "" Then
.ChartTitle.Characters.Text = strTextoFiltro + Chr(13) + "Pesquisa de Reação - Índice de Favorabilidade"
Else
.ChartTitle.Characters.Text = "Pesquisa de Reação - Índice de Favorabilidade"
End If

.Axes(1).HasTitle = False
.Axes(3).HasTitle = False
.Axes(2).HasTitle = False
End With
With objExcel.ActiveChart
.HasAxis(1) = True
.HasAxis(3) = False
.HasAxis(2) = True
End With
objExcel.ActiveChart.Axes(1).CategoryType = -4105
objExcel.ActiveChart.HasLegend = True
objExcel.ActiveChart.HasDataTable = False
objExcel.ActiveChart.ChartArea.Select
objExcel.ActiveChart.ChartArea.AutoScaleFont = True

objExcel.ActiveChart.ApplyDataLabels True, False, False, False, False, False, True, False

With objExcel.ActiveChart.ChartArea.Font
.Name = "Arial"
.FontStyle = "Normal"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = -4142
.ColorIndex = -4105
.Background = -4105
End With

For x = 1 To objExcel.ActiveChart.SeriesCollection.Count
objExcel.ActiveChart.SeriesCollection(x).DataLabels.Select
With objExcel.ActiveChart.SeriesCollection(x).DataLabels.Border
.Weight = 1
.LineStyle = -4105
End With
objExcel.ActiveChart.SeriesCollection(x).DataLabels.Shadow = True
objExcel.ActiveChart.SeriesCollection(x).DataLabels.Interior.ColorIndex = -4105
objExcel.ActiveChart.SeriesCollection(x).DataLabels.AutoScaleFont = True
With objExcel.ActiveChart.SeriesCollection(x).DataLabels.Font
.Name = "Arial"
.FontStyle = "Negrito"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = -4142
.ColorIndex = -4105
.Background = -4105
End With
Next

With objExcel.ActiveChart.ChartTitle.Font
.Name = "Arial"
.FontStyle = "Negrito"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = -4142
.ColorIndex = -4105
.Background = -4105
End With

With objExcel.ActiveChart.ChartTitle
.HorizontalAlignment = -4131
.VerticalAlignment = -4108
.ReadingOrder = -5002
.Orientation = -4128
End With

objExcel.ActiveChart.Walls.Select
With objExcel.ActiveChart
.Elevation = 15
.Perspective = 30
.Rotation = 20
.RightAngleAxes = True
.HeightPercent = 100
.AutoScaling = True
End With
End Sub

Public Sub EXCEL_GenerateChart_Default(intTipoGrafico As Integer, intColInicio As Integer, intLinInicio As Integer, _
intColFim As Integer, intLinFim As Integer, strLabelGrafico As String, strNomePasta As String, strTipoDado As String, strTextoFiltro As String)
REM
' strTipoDado - [String] - "Valor" ou "Percentual"

'Gráfico de Barras = 54
'Gráfico de Pizza = -4102
objExcel.Charts.Add
objExcel.ActiveChart.ChartType = intTipoGrafico

Stop

If intTipoGrafico = 54 Then
objExcel.ActiveChart.SetSourceData objExcel.Sheets(strNomePasta).Range(objExcel.Sheets(strNomePasta).Cells(intLinInicio, intColInicio), objExcel.Sheets(strNomePasta).Cells(intLinFim, intColFim)), 2
Else
objExcel.ActiveChart.SetSourceData objExcel.Sheets(strNomePasta).Range(objExcel.Sheets(strNomePasta).Cells(intLinInicio, intColInicio), objExcel.Sheets(strNomePasta).Cells(intLinFim, intColFim)), 1
End If
objExcel.ActiveChart.Location 2, strNomePasta

With objExcel.ActiveChart
.HasTitle = True

If strTextoFiltro <> "" Then
' .ChartTitle.Characters.Text = strTextoFiltro + Chr(13) + strLabelGrafico
.ChartTitle.Characters.Text = strTextoFiltro + Chr(13) + strNomePasta
Else
' .ChartTitle.Characters.Text = strLabelGrafico
.ChartTitle.Characters.Text = strNomePasta
End If

If intTipoGrafico = 54 Then
.Axes(1).HasTitle = False
.Axes(3).HasTitle = False
.Axes(2).HasTitle = False
.HasAxis(1) = True
.HasAxis(3) = False
.HasAxis(2) = True
End If
End With

objExcel.ActiveChart.Axes(1).CategoryType = -4105
objExcel.ActiveChart.HasLegend = True
objExcel.ActiveChart.HasDataTable = False
objExcel.ActiveChart.ChartArea.AutoScaleFont = True

If intTipoGrafico = 54 Or strTipoDado = "Valor" Then
objExcel.ActiveChart.ApplyDataLabels True, False, False, False, False, False, True, False
Else
objExcel.ActiveChart.ApplyDataLabels True, False, False, False, False, False, False, True
End If

With objExcel.ActiveChart.ChartArea.Font
.Name = "Arial"
.FontStyle = "Normal"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = -4142
.ColorIndex = -4105
.Background = -4105
End With

For x = 1 To objExcel.ActiveChart.SeriesCollection.Count
objExcel.ActiveChart.SeriesCollection(x).DataLabels.Select
With objExcel.ActiveChart.SeriesCollection(x).DataLabels.Border
.Weight = 1
.LineStyle = -4105
End With
objExcel.ActiveChart.SeriesCollection(x).DataLabels.Shadow = True
objExcel.ActiveChart.SeriesCollection(x).DataLabels.Interior.ColorIndex = -4105
objExcel.ActiveChart.SeriesCollection(x).DataLabels.AutoScaleFont = True
With objExcel.ActiveChart.SeriesCollection(x).DataLabels.Font
.Name = "Arial"
.FontStyle = "Negrito"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = -4142
.ColorIndex = -4105
.Background = -4105
End With
Next

With objExcel.ActiveChart.ChartTitle.Font
.Name = "Arial"
.FontStyle = "Negrito"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = -4142
.ColorIndex = -4105
.Background = -4105
End With

With objExcel.ActiveChart.ChartTitle
.HorizontalAlignment = -4131
.VerticalAlignment = -4108
.ReadingOrder = -5002
.Orientation = -4128
End With

If intTipoGrafico = -4102 Then
objExcel.ActiveChart.PlotArea.Select
With objExcel.ActiveChart.PlotArea.Border
.Weight = 2
.LineStyle = -4142
End With
objExcel.ActiveChart.PlotArea.Interior.ColorIndex = -4142
End If

If intTipoGrafico = 54 Then

objExcel.ActiveChart.Walls.Select
With objExcel.ActiveChart
.Elevation = 15
.Perspective = 30
.Rotation = 20
.RightAngleAxes = True
.HeightPercent = 100
.AutoScaling = True
End With
End If
End Sub

Public Sub WORD_CreateFile
'Create the Word object:
Set word = GetWordObject

Call word.documents.add("normal.dot") 'Cria novo documento baseado no tempate cadastrado no sistema
Set worddoc = word.activedocument 'Get a handle for the active document
word.visible = False
End Sub





Public Sub WORD_AddText(strTexto As String)
word.Selection.TypeText strTexto
End Sub

Public Sub WORD_AddLine(intLinhas As Integer)
Dim J As Integer
For J = 1 To intLinhas
word.Selection.TypeParagraph
Next
End Sub

Public Sub WORD_Save(strFileName As String, intAbreArquivo As Integer)
worddoc.saveas(strFileName) 'salva o documento Word

If intAbreArquivo Then
word.visible = True
Else
word.visible = False 'Não mostrar o Word
word.Application.Quit 'Fechar a instancia do word
End If
End Sub

Public Sub WORD_Bold
word.selection.Font.Bold = 9999998
End Sub

Function GetWordObject As Variant
On Error Goto Error_Handler
Dim objWord As Variant

'Create the Word object:
Set objWord = GetObject(, "Word.Application")
Set GetWordObject = objWord
Goto fim

Error_Handler:
Set objWord = CreateObject("Word.Application") 'Cria o objeto Word
Set GetWordObject = objWord
Resume fim

fim:
End Function

Public Sub EXCEL_AddSheet(total As Integer)
'******************************************************************************************************************************
'OBJETIVO: Adiciona um determinado valor a uma célula dentro do arquivo no Excel
'PARÂMETROS: total [Integer] - Quantidade de Planilhas a inserir.
'RETORNO: Nenhum
'******************************************************************************************************************************
For i = 1 To total
objExcel.Sheets.Add
Next
End Sub



Public Sub EXCEL_RenameSheet(total As Integer, texto As String)
'******************************************************************************************************************************
'OBJETIVO: Adiciona um determinado valor a uma célula dentro do arquivo no Excel
'PARÂMETROS: total [Integer] - Quantidade de Planilhas a inserir.
' texto [String] - Valor para qual será renomeado
'RETORNO: Nenhum
'******************************************************************************************************************************
For i = 1 To total
objExcel.Sheets(i).Name = texto + Cstr(i)
Next
End Sub


Public Sub EXCEL_SelectSheet(intNum As Integer)
'Posiciona o cursor na pasta solicitada dentro de uma planilha excel
objExcel.Sheets(intNum).Select
objExcel.Range("A1").Select
End Sub

Public Sub EXCEL_AutoFit()
'Função utilizada para que as colunas da planilha Excel fiquem do tamanho dos textos informados nas colunas.
objExcel.Cells.Select
objExcel.Cells.EntireColumn.AutoFit
End Sub

Public Function EXCEL_GetCellValue(intLin As Integer, intCol As Integer) As String
'Recupera a informação armazenada na celula solicitada
EXCEL_GetCellValue = objExcel.Cells(intLin, intCol).value
End Function

Public Function EXCEL_SUM(intColInicio As Integer, intLinInicio As Integer, intColFim As Integer, intLinFim As Integer) As String
'******************************************************************************************************************************
'OBJETIVO: Retorna a formula para somar celulas
'PARÂMETROS: intColInicio [Integer] -> Informa o número da coluna da celula inicial usada para a soma
' intLinInicio [Integer] -> Informa o número da linha da celula inicial usada para a soma
' intColFim [Integer] -> Informa o número da coluna da celula final usada para a soma
' intLinFim [Integer] -> Informa o número da linha da celula final usada para a soma
'RETORNO: Fórmula da SOMA
'******************************************************************************************************************************
Dim strCelulaInicial As String, strCelulaFinal As String

strCelulaInicial = EXCEL_GetCellName(intColInicio, intLinInicio)
strCelulaFinal = EXCEL_GetCellName(intColFim, intLinFim)

Select Case Left(session.NotesVersion, 9)
Case "Release 5":
EXCEL_SUM = "SOMA(" + strCelulaInicial + ":" + strCelulaFinal + ")"

Case "Release 6":
EXCEL_SUM = "SUM(" + strCelulaInicial + ":" + strCelulaFinal + ")"

Case Else
EXCEL_SUM = "SUM(" + strCelulaInicial + ":" + strCelulaFinal + ")"
End Select
End Function

Function EXCEL_GetCellName(intColuna As Integer, intLinha As Integer) As String
' Passa a informação do número da linha e o número da coluna e a função retorna o nome da celula.
'Exemplo: Passar como parâmetro: coluna 1 e linha 1.
' A função retornará A1
Dim pos As Integer
Dim strColuna As String, strLinha As String

objExcel.Range(objExcel.Cells(intLinha, intColuna), objExcel.Cells(intLinha, intColuna)).Select
pos = Instr(2, objExcel.ActiveCell.Address, "$")
strColuna = Mid(objExcel.ActiveCell.Address, 2, pos - 2)
strLinha = Right(objExcel.ActiveCell.Address, Len(objExcel.ActiveCell.Address) - pos)

EXCEL_GetCellName = strColuna + strLinha
End Function

Public Function EXCEL_PERCENT(intColVal As Integer, intLinVal As Integer, intColTotal As Integer, intLinTotal As Integer) As String
'*********************************************************************************************************
'OBJETIVO: Montar a fórmula de Percentual na célula informada
'PARAMETROS: intColVal [Integer] -> Informa o número da coluna do valor
' intLinVal [Integer] -> Informa o número da linha do valor
' intColTotal [Integer] -> Informa o número da coluna do total
' intLinTotal [Integer] -> Informa o número da linha do total
'RETORNO: Uma string com a fórmula de percentual a ser armazenada na célula
'*********************************************************************************************************
Dim strCelulaValor As String, strCelulaTotal As String

strCelulaValor = EXCEL_GetCellName(intColVal, intLinVal)
strCelulaTotal = EXCEL_GetCellName(intColTotal, intLinTotal)
EXCEL_PERCENT = "(" + strCelulaValor + "*100)/" + strCelulaTotal

End Function

Public Function EXCEL_GetFile() As Integer
Dim ws As New NotesUIWorkspace

FileName = ws.OpenFileDialog( False, "Selecione o arquivo com as respostas" )
If Isempty(FileName) Then
Exit Function
End If

Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = False
Set WorkBooks = objExcel.Workbooks.Open(Filename(0))
Set WorkSheet = WorkBooks.Worksheets(1)

EXCEL_GetFile = True
End Function

Public Function EXCEL_Terminate()
objExcel.Quit
Set objExcel = Nothing
End Function

Public Sub EXCEL_GenerateChart_Opcao(intColInicio As Integer, intLinInicio As Integer, intColFim As Integer, intLinFim As Integer)
On Error Goto erro

strLabelGrafico = "Relatório Gráfico de Opções por Pergunta"

With objExcel
Call .Range(.Cells(intLinInicio, intColInicio), .Cells(intLinFim, intColFim)).Select
.Charts.Add
.ActiveChart.ChartType = 52
.ActiveChart.SetSourceData .Sheets("Plan1").Range(.Sheets("Plan1").Cells(intLinInicio, intColInicio), .Sheets("Plan1").Cells(intLinFim, intColFim)), 2
.ActiveChart.Location 2, "Plan1"
End With

With objExcel.ActiveChart
.HasTitle = True
.ChartTitle.Characters.Text = strLabelGrafico
End With

objExcel.ActiveChart.Axes(1).CategoryType = -4105
objExcel.ActiveChart.HasLegend = True
objExcel.ActiveChart.HasDataTable = False
objExcel.ActiveChart.ChartArea.Select
objExcel.ActiveChart.ChartArea.AutoScaleFont = True

objExcel.ActiveChart.ApplyDataLabels True, False, False, False, False, False, True, False

For x = 1 To objExcel.ActiveChart.SeriesCollection.Count
objExcel.ActiveChart.SeriesCollection(x).DataLabels.Select
With objExcel.ActiveChart.SeriesCollection(x).DataLabels.Border
.Weight = 1
.LineStyle = -4105
End With
objExcel.ActiveChart.SeriesCollection(x).DataLabels.Shadow = True
objExcel.ActiveChart.SeriesCollection(x).DataLabels.Interior.ColorIndex = -4105
objExcel.ActiveChart.SeriesCollection(x).DataLabels.AutoScaleFont = True
Next

With objExcel.ActiveChart.ChartArea.Font
.Name = "Arial"
.FontStyle = "Normal"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = -4142
.ColorIndex = -4105
.Background = -4105
End With

' Movendo o gráfico - (1) indica o primeiro gráfico
objExcel.ActiveSheet.Shapes(1).Select
objExcel.ActiveSheet.Shapes(1).Left = objExcel.ActiveSheet.Cells(intLinFim + 2, 1).Left
objExcel.ActiveSheet.Shapes(1).Top = objExcel.ActiveSheet.Cells(intLinFim + 2, 1).Top

Goto fim

erro:
Msgbox "Generate Chart (Opcao) - " + Cstr(Error) + Chr(13) + Chr(10) + "Linha " + Cstr(Erl) + " - Cod. " + Cstr(Err)

fim:
End Sub

Public Sub EXCEL_GenerateChart_Completo(intTipoGrafico As Integer, intColInicio As Integer, intLinInicio As Integer, _
intColFim As Integer, intLinFim As Integer, contTitulo As String, strNomePasta As String, strTipoDado As String, strTextoFiltro As String)
REM
' strTipoDado - [String] - "Valor" ou "Percentual"

'Gráfico de Barras = 54
'Gráfico de Pizza = -4102
On Error Goto erro

objExcel.Charts.Add
objExcel.ActiveChart.ChartType = intTipoGrafico

If intTipoGrafico = 54 Then
objExcel.ActiveChart.SetSourceData objExcel.Sheets(strNomePasta).Range(objExcel.Sheets(strNomePasta).Cells(intLinInicio, intColInicio), objExcel.Sheets(strNomePasta).Cells(intLinFim, intColFim)), 2
Else
objExcel.ActiveChart.SetSourceData objExcel.Sheets(strNomePasta).Range(objExcel.Sheets(strNomePasta).Cells(intLinInicio, intColInicio), objExcel.Sheets(strNomePasta).Cells(intLinFim, intColFim)), 1
End If
objExcel.ActiveChart.Location 2, strNomePasta

With objExcel.ActiveChart
.HasTitle = True
.ChartTitle.Characters.Text = "Pergunta " + contTitulo

If intTipoGrafico = 54 Then
.Axes(1).HasTitle = False
.Axes(3).HasTitle = False
.Axes(2).HasTitle = False
.HasAxis(1) = True
.HasAxis(3) = False
.HasAxis(2) = True
End If
End With

objExcel.ActiveChart.Axes(1).CategoryType = -4105
objExcel.ActiveChart.HasLegend = True
objExcel.ActiveChart.HasDataTable = False
objExcel.ActiveChart.ChartArea.AutoScaleFont = True

If intTipoGrafico = 54 Or strTipoDado = "Valor" Then
objExcel.ActiveChart.ApplyDataLabels True, False, False, False, False, False, True, False
Else
objExcel.ActiveChart.ApplyDataLabels True, False, False, False, False, False, False, True
End If

With objExcel.ActiveChart.ChartArea.Font
.Name = "Arial"
.FontStyle = "Normal"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = -4142
.ColorIndex = -4105
.Background = -4105
End With

For x = 1 To objExcel.ActiveChart.SeriesCollection.Count
objExcel.ActiveChart.SeriesCollection(x).DataLabels.Select
With objExcel.ActiveChart.SeriesCollection(x).DataLabels.Border
.Weight = 1
.LineStyle = -4105
End With
objExcel.ActiveChart.SeriesCollection(x).DataLabels.Shadow = True
objExcel.ActiveChart.SeriesCollection(x).DataLabels.Interior.ColorIndex = -4105
objExcel.ActiveChart.SeriesCollection(x).DataLabels.AutoScaleFont = True
With objExcel.ActiveChart.SeriesCollection(x).DataLabels.Font
.Name = "Arial"
.FontStyle = "Negrito"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = -4142
.ColorIndex = -4105
.Background = -4105
End With
Next

If intTipoGrafico = -4102 Then
objExcel.ActiveChart.PlotArea.Select
With objExcel.ActiveChart.PlotArea.Border
.Weight = 2
.LineStyle = -4142
End With
objExcel.ActiveChart.PlotArea.Interior.ColorIndex = -4142
End If

If intTipoGrafico = 54 Then
objExcel.ActiveChart.Walls.Select
With objExcel.ActiveChart
.Elevation = 15
.Perspective = 30
.Rotation = 20
.RightAngleAxes = True
.HeightPercent = 100
.AutoScaling = True

If strTextoFiltro <> "" Then
.Axes(1).HasTitle = True
.Axes(1).AxisTitle.Characters.Text = strTextoFiltro
End If
End With

If strTextoFiltro <> "" Then
objExcel.ActiveChart.Axes(1).AxisTitle.Select
With objExcel.ActiveChart.Axes(1).AxisTitle
.HorizontalAlignment = -4131
.VerticalAlignment = -4108
.ReadingOrder = -5002
.Orientation = -4128
End With
End If
End If

' Movendo o gráfico
objExcel.ActiveSheet.Shapes(contTitulo).Select
objExcel.ActiveSheet.Shapes(contTitulo).Left = objExcel.ActiveSheet.Cells(intLinInicio + 3, 1).Left
objExcel.ActiveSheet.Shapes(contTitulo).Top = objExcel.ActiveSheet.Cells(intLinInicio + 3, 1).Top

Goto fim

erro:
Msgbox "Generate Chart (Completo) - " + Cstr(Error) + Chr(13) + Chr(10) + "Linha " + Cstr(Erl) + " - Cod. " + Cstr(Err)

fim:
End Sub

Public Sub EXCEL_SortColumn(intColInicio As Integer, intLinInicio As Integer, intColFim As Integer, intLinFim As Integer, intLinhaSort As Integer, intColSortearA As Integer, intColSortearB As Integer, intColSortearC As Integer)
'Public Sub EXCEL_SortColumn(intColInicio As Integer, intLinInicio As Integer, intColFim As Integer, intLinFim As Integer, intColSortearA As Integer, intLinSortearA As Integer, intColSortearB As Integer, intLinSortearB As Integer, intColSortearC As Integer, intLinSortearC As Integer)
' Parâmetros:
' intColInicio, intLinInicio, intColFim, intLinFim => dados da seleção usada no range
' intLinhaSort => linha de início do sort
' intColSortearA, intColSortearB, intColSortearC => Coluna para ordenar

Dim strCelIni As String, strCelFim As String
Dim strCelSort1 As String, strCelSort2 As String, strCelSort3 As String

strCelIni = EXCEL_GetCellName(intColInicio, intLinInicio)
strCelFim = EXCEL_GetCellName(intColFim, intLinFim)

strCelSort1 = EXCEL_GetCellName(intColSortearA, intLinhaSort)
strCelSort2 = EXCEL_GetCellName(intColSortearB, intLinhaSort)
strCelSort3 = EXCEL_GetCellName(intColSortearC, intLinhaSort)

' objExcel.Range(strCelIni + ":" + strCelFim).Sort objExcel.Range(strCelSort), 1, , , , , , 0, 1, False, 1
objExcel.Range(strCelIni + ":" + strCelFim).Sort objExcel.Range(strCelSort1), 1, objExcel.Range(strCelSort2), , 1, objExcel.Range(strCelSort3), 1, 2, 1, False, 1, 0, 0, 0
End Sub

Function WORD_CreateTable(intNumTabela As Integer, intNumLinha As Integer, intNumColuna As Integer)
word.Selection.MoveDown 5, 2
word.Selection.TypeParagraph

' Cria uma nova tabela
word.ActiveDocument.Tables.Add word.Selection.Range, intNumLinha, intNumColuna, 1, 2
With word.Selection.Tables(1)
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = True
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = True
End With
End Function



Function WORD_SplitCells(intTab As Integer, intLinhaTab As Integer, intColunaTab As Integer, intNumLinha As Integer, intNumColuna As Integer)
worddoc.Tables(intTab).Cell(intLinhaTab, intColunaTab).Split intNumLinha, intNumColuna
End Function

Function WORD_AltTableBackGround(intTextura, intForeGround, intBackGround)
With word.Selection.Cells.Shading
.Texture = intTextura
.ForegroundPatternColor = intForeGround
.BackgroundPatternColor = intBackGround
End With
End Function

Function WORD_MergeCells(intNumCol As Integer)
word.Selection.MoveRight 1, intNumCol, 1
word.Selection.Cells.Merge
word.Selection.MoveLeft 1, 1
End Function

Function WORD_PreencheCabecalhoTabela(intNumTabela As Integer, intCompleta As Integer, strDescPerg As String)
If intCompleta = True Then
word.Selection.Tables(1).Columns(4).SetWidth 59.25, 0
word.Selection.Tables(1).Columns(3).SetWidth 140.3, 0
word.Selection.Tables(1).Columns(2).SetWidth 158.35, 0
word.Selection.Tables(1).Columns(1).SetWidth 207, 0
word.Selection.Tables(1).Rows.SetLeftIndent -68.5, 0
Call WORD_MergeCells(4)
Else
word.Selection.Tables(1).Columns(3).SetWidth 59.25, 0
word.Selection.Tables(1).Columns(2).SetWidth 140.3, 0
word.Selection.Tables(1).Columns(1).SetWidth 379.9, 0
word.Selection.Tables(1).Rows.SetLeftIndent -68.5, 0
Call WORD_MergeCells(3)
End If

Call WORD_Bold
word.Selection.TypeText strDescPerg
word.Selection.MoveRight 12
Call WORD_Bold
word.Selection.TypeText "Resposta"

If intCompleta = True Then
word.Selection.MoveRight 12
Call WORD_Bold
word.Selection.TypeText "Comentários/Justificativas"
End If

word.Selection.MoveRight 12
Call WORD_Bold
word.Selection.TypeText "Nome"
word.Selection.MoveRight 12
Call WORD_Bold
word.Selection.TypeText "Chave"
End Function

Public Sub EXCEL_ShowFile()
' Função que exibe o arquivo excel na tela
objExcel.Visible = True

End Sub

Public Sub EXCEL_FormatCellType(intColIni As Integer, intLinIni As Integer, intColFim As Integer, intLinFim As Integer)
'******************************************************************************************************************************
'OBJETIVO: Adiciona um determinado valor a uma célula dentro do arquivo no Excel
'PARÂMETROS: intCol [Integer] - Informa o código ASCII da célula do excel (Ex. A = 65).
' intLin [Integer] - Informa a linha da célula do excel

'RETORNO: Nenhum
'******************************************************************************************************************************
Call objExcel.Range(objExcel.Cells(intLinIni, intColIni), objExcel.Cells(intLinFim, intColFim)).Select
With objExcel.Selection
.NumberFormat = "0,00%" ' Formato da célula - "Número, 2 casas decimais
'.NumberFormat = "11"
End With

End Sub
Sub Initialize

End Sub

Biblioteca de exportação do BR Office Writer

'bs_BrOffice_Writer:

%REM
Library bs_BrOffice_Writer
Description: Comments for Library
Biblioteca criada para armazenar as funções utilizadas para montagem de relatórios
na ferramenta BrOffice.org Writer
%END REM
Option Public
'Option Declare


Dim objServiceManager As Variant
Dim objCoreReflection As Variant
Dim StarDesktop As Variant
Dim dispatcher As Variant
Dim sUrl As Variant

Dim oDoc As Variant
Dim frame As Variant
Dim oPlanilha As Variant
Dim oCellRange As Variant
Dim oAddr As Variant
Dim border
Dim vEnd As Variant

Dim Charts As Variant
Dim Chart
Dim Rect As Variant
Dim classSize As Variant

'sWriter
Dim oCursor
Dim oText
Dim oField
Dim oCelula
Dim oCurTab As Variant

Dim IntCelula() As Integer 'Array de inteiros das Linhas e Colunas de todas as Abas (PRIMEIRA DIMENSAO - POSIÇÃO 0 PARA LINHA E 1 PARA COLUNA)
Dim strListNomeCelula List As String 'Armazena as letras correspondentes a celula




%REM
Sub WRITER_Initialize
Description: Comments for Sub
%END REM
Sub WRITER_Initialize

Set objServiceManager = CreateObject("com.sun.star.ServiceManager")
Set objCoreReflection = objServiceManager.createInstance("com.sun.star.reflection.CoreReflection")
Set StarDesktop = objServiceManager.createInstance("com.sun.star.frame.Desktop")
Set dispatcher = objServiceManager.createInstance("com.sun.star.frame.DispatchHelper")

'Cria um novo documento do WRITER
Dim args(0)
Set args(0) = WRITER_makePropertyValue("Hidden", True)

sUrl = "private:factory/swriter"
Set oDoc = StarDesktop.loadComponentFromURL(sUrl, "_blank", 0, args())

'Set oPlanilha = oDoc.getSheets().getByIndex(0)

Set frame = oDoc.CurrentController.Frame
End Sub

Function WRITER_makePropertyValue(sName As String, vValue) As Variant

Dim vStruct
Set vStruct = objServiceManager.Bridge_GetStruct("com.sun.star.beans.PropertyValue")
vStruct.name = sName
vStruct.value = vValue
Set WRITER_makePropertyValue = vStruct

End Function

Function WRITER_createStruct(strTypeName)
Dim aStruct

Set classSize = objCoreReflection.forName(strTypeName)
classSize.createObject aStruct

Set WRITER_createStruct = aStruct

End Function

%REM
Sub WRITER_Terminate
Description: Comments for Sub
%END REM
Sub WRITER_Terminate()
Set objServiceManager = Nothing
Set objCoreReflection = Nothing
Set StarDesktop = Nothing
Set dispatcher = Nothing
Set oDoc = Nothing
Set classSize = Nothing
End Sub

%REM
Sub WRITER_showFile
Description: Comments for Sub
%END REM
Sub WRITER_showFile()
oDoc.getCurrentController().getFrame().getContainerWindow().setVisible(True)
End Sub

%REM
Sub WRITER_insertText
Description: Comments for Sub
%END REM
Sub WRITER_insertText(strTexto As String)

Set oText = oDoc.Text
Set oCursor = oText.createTextCursor()
Call oCursor.SetString(strTexto)

End Sub

%REM
Sub WRITER_montaTable
Description: Comments for Sub
%END REM
Sub WRITER_montaTable(intLinha As Integer, intColuna As Integer, nomeTabela As String)


Set table = oDoc.createInstance("com.sun.star.text.TextTable")
table.Name = nomeTabela
Call table.initialize( intLinha, intColuna )
Set oText = oDoc.Text
Set oCursor = oText.createTextCursor()
Call oText.insertTextContent( oCursor, table, False )


End Sub

%REM
Sub WRITER_insertTextTable
Description: Comments for Sub
%END REM
Sub WRITER_insertTextTable(nomeTabela As String, posicaoCelula As String, strTexto As String)
Set table = oDoc.getTextTables().getByName(nomeTabela)
Set oCelula = table.getCellByName(posicaoCelula)
Call oCelula.SetString(strTexto)
End Sub

%REM
Sub WRITER_mergeCells
Description: Comments for Sub
%END REM
Sub WRITER_mergeCells(nomeTabela As String, posicaoCelula As String, QtdeCelula As Integer)
Dim table As Variant
Set table = oDoc.getTextTables().getByName(nomeTabela)
Set oCurTab = table.createCursorByCellName("A1")

Call oCurTab.gotoCellByName(posicaoCelula, False)
Call oCurTab.goRight(QtdeCelula, True)
Call oCurTab.mergeRange()
End Sub

%REM
Sub WRITER_insertParagraph
Description: Comments for Sub
%END REM
Sub WRITER_insertParagraph
Set oText = oDoc.Text
Set oTxtRng = oText.getEnd()

'com.sun.star.text.ControlCharacter.LINE_BREAK
Call oText.insertControlCharacter(oTxtRng, 1, False)

End Sub

Biblioteca de exportação do BR Office CALC

'bs_BrOffice_Calc:

%REM
Library bs_BrOffice_Calc
Biblioteca criada para armazenar as funções utilizadas para montagem de relatórios na ferramenta BrOffice.org Calc
%END REM
Option Public
'Option Declare


Dim objServiceManager As Variant
Dim objCoreReflection As Variant
Dim StarDesktop As Variant
Dim dispatcher As Variant
Dim sUrl As Variant

Dim oDoc As Variant
Dim frame As Variant
Dim oPlanilha As Variant
Dim oCelula As Variant
Dim oCellRange As Variant
Dim oAddr As Variant
Dim border
Dim oCursor As Variant
Dim vEnd As Variant

Dim Charts As Variant
Dim Chart
Dim Rect As Variant
Dim classSize As Variant

Dim oText
Dim oField

Dim IntCelula() As Integer 'Array de inteiros das Linhas e Colunas de todas as Abas (PRIMEIRA DIMENSAO - POSIÇÃO 0 PARA LINHA E 1 PARA COLUNA)
Dim strListNomeCelula List As String 'Armazena as letras correspondentes a celula




%REM
Sub CALC_Initialize
Description: Comments for Sub
%END REM
Sub CALC_Initialize

Set objServiceManager = CreateObject("com.sun.star.ServiceManager")
Set objCoreReflection = objServiceManager.createInstance("com.sun.star.reflection.CoreReflection")
Set StarDesktop = objServiceManager.createInstance("com.sun.star.frame.Desktop")
Set dispatcher = objServiceManager.createInstance("com.sun.star.frame.DispatchHelper")

'Cria um novo documento do CALC
Dim args(0)
Set args(0) = CALC_makePropertyValue("Hidden", True)

sUrl = "private:factory/scalc"
Set oDoc = StarDesktop.loadComponentFromURL(sUrl, "_blank", 0, args())

Set oPlanilha = oDoc.getSheets().getByIndex(0)

Set frame = oDoc.CurrentController.Frame
End Sub

Function CALC_makePropertyValue(sName As String, vValue) As Variant

Dim vStruct
Set vStruct = objServiceManager.Bridge_GetStruct("com.sun.star.beans.PropertyValue")
vStruct.name = sName
vStruct.value = vValue
Set CALC_makePropertyValue = vStruct

End Function

%REM
Description: Comments for Sub
Monta o cabeçalho com os valors dos títulos das colunas
Parâmetro de entrada:
arrayTitulo -> Array com os títulos
coluna -> Coluna inicial onde o primeiro título será inserido
linha -> Linha inicial onde o primeiro título será inserido
%END REM
Sub CALC_montaCabecalho(arrayTitulo As Variant, coluna As Long, linha As Long)

Dim i As Long

i = coluna

Forall titulo In arrayTitulo
Call CALC_preencheCelula(i, linha, "String", Cstr(titulo), 0, True)
i = i + 1
End Forall

End Sub


Sub CALC_preencheCelula(coluna As Long, linha As Long, tipo As String, strTexto As String, dblNum As Double, flagBold As Boolean)
%REM
Description: Comments for Sub
Monta o gráfico conforme tabela montada
Parâmetros de entrada:
coluna -> Coluna onde o valor será inserido
linha -> Linha onde o valor será inserido
tipo -> tipo de dado (pode ser 'String', 'Number' ou 'Formula'
strTexto -> String a ser inserida na célula, passar "" caso seja do tipo 'Integer'
startRow -> Valor a ser inserido na célula, passar 0 caso seja do tipo 'String'
flagBold -> Indicação se o valor será negrito. True or False
%END REM

Set oCelula = oPlanilha.getCellByPosition(coluna, linha)

Select Case tipo
Case "String": oCelula.setString(strTexto)
Case "Number": oCelula.setValue(dblNum)

Case "Percentual":
oCelula.setValue(dblNum)
oCelula.NumberFormat = 11 'Formata para %

Case "Formula": oCelula.SetFormula(strTexto)
End Select

If flagBold Then
oCelula.CharWeight = 150
End If

Call CALC_setBorder()
Call CALC_autoFit(1)
'oCelula.isTextWrapped = True


End Sub

Sub CALC_setBorder()

On Error Goto trataerro

'Parâmetros de configuração de borda das células
Set border = CALC_createStruct("com.sun.star.table.BorderLine")
border.Color = 0
border.InnerLineWidth = 1
border.OuterLineWidth = 1
border.LineDistance = 0

oCelula.setPropertyValue "LeftBorder", border
oCelula.setPropertyValue "RightBorder", border
oCelula.setPropertyValue "TopBorder", border
oCelula.setPropertyValue "BottomBorder", border

Exit Sub
trataerro:
Msgbox "Erro - Rotina:'setBorder' - Linha: " & Erl & " Tipo: " & Error , 16 , "Operação Cancelada!"
Exit Sub
End Sub

%REM
Sub CALC_formataFontPlanilha
Description: Comments for Sub
Define qual será o nome e tamanho da fonte utilizada
Parâmetros de entrada:
fontSize -> Tamanho da fonte que será utilizada
fontName -> Define o nome da fonte que será utilizada
fontColorRGB -> Código RGB. Ex: "#FFFFFF"

Obs. Para verificar a paleta de cores, acesse a page "Paleta de Cores"
%END REM
Sub CALC_formataFontPlanilha(fontSize As Integer, fontName As String, fontColorRGB As String)

Set oCursor = oPlanilha.createCursor()
oCursor.gotoEndOfUsedArea(False)
Set vEnd = oCursor.getRangeAddress()

Set oCellRange = oPlanilha.getCellRangeByPosition(0, 0, 100, vEnd.EndRow)
oCellRange.CharHeight = fontSize
oCellRange.CharFontName = fontName
oCellRange.CharColor = UTIL_Hex2Dec(fontColorRGB)

End Sub

Sub CALC_montaGrafico(tipoGrafico As String, posX As Long, posY As Long, startColumn As Long, startRow As Long, endColumn As Long, endRow As Long, strYAxisTitle As String, intPlan As Integer)

'MsgBox "CALC"
'Stop

%REM
Description: Comments for Sub
Monta o gráfico conforme tabela montada
Parâmetros de entrada:
tipoGrafico -> "B (barra)", "L (linha)" e "P (pizza)"
posX -> Posicionamento do gráfico na tela
posY -> Posicionamento do gráfico na tela
startColumn -> Coluna inicial da tabela
startRow -> Linha inicial da tabela
endColumn -> Coluna final da tabela
endRow -> Linha final da tabela
strYAxisTitle -> Título do eixo do gráfico
%END REM

Dim nomeGrafico As String

Set Rect = CALC_createStruct("com.sun.star.awt.Rectangle")'aStruct

Dim RangeAddress(0)
Set RangeAddress(0) = CALC_createStruct("com.sun.star.table.CellRangeAddress") 'aStruct

Set Charts = oDoc.getSheets().getByIndex(intPlan).Charts

Rect.X = posX
Rect.Y = posY
Rect.Width = 10000
Rect.Height = 7000
RangeAddress(0).Sheet = 0
RangeAddress(0).StartColumn = startColumn
RangeAddress(0).StartRow = startRow
RangeAddress(0).EndColumn = endColumn
RangeAddress(0).EndRow = endRow

nomeGrafico = "MyChart" + Cstr(Rnd)
Call Charts.addNewByName(nomeGrafico, Rect, RangeAddress(), True, True)
Set Chart = Charts.getByName(nomeGrafico).embeddedObject

If tipoGrafico = "B" Then
Set Chart.Diagram = Chart.createInstance("com.sun.star.chart.BarDiagram")
Elseif tipoGrafico = "L" Then
Set Chart.Diagram = Chart.createInstance("com.sun.star.chart.LineDiagram")
Elseif tipoGrafico = "P" Then
Set Chart.Diagram = Chart.createInstance("com.sun.star.chart.PieDiagram")
Chart.Diagram.DataRowSource = 0 '0 = ROWS; 1 = COLUMNS
End If

Chart.HasMainTitle = True
Chart.Title.String = "Representação Gráfica"
Chart.HasLegend = True
Chart.Legend.CharHeight = 7
Chart.Diagram.HasYAxisTitle = True
Chart.Diagram.YAxisTitle.String = strYAxisTitle
Chart.Diagram.DataCaption = 1 'True - percentual e legenda; '4 - legenda

End Sub

Function CALC_createStruct(strTypeName)
Dim aStruct

Set classSize = objCoreReflection.forName(strTypeName)
classSize.createObject aStruct

Set CALC_createStruct = aStruct

End Function

%REM
Sub CALC_Terminate
Description: Comments for Sub
%END REM
Sub CALC_Terminate()
Set objServiceManager = Nothing
Set objCoreReflection = Nothing
Set StarDesktop = Nothing
Set dispatcher = Nothing
Set oDoc = Nothing
Set classSize = Nothing
End Sub

%REM
Sub CALC_autoFit
Description: Comments for Sub
Seleciona a planilha para ajustar o tamanho das colunas de acordo com o tamanho dos valores
Parâmetro de entrada:
intPlan -> Número da planilha, ex. Planilha 1 (0)
%END REM
Sub CALC_autoFit(intPlan As Integer)
Set oPlanilha = oDoc.getSheets().getByIndex(intPlan - 1)
oPlanilha.columns.optimalwidth = True
'oPlanilha.columns.wraptext = true
End Sub

%REM
Sub CALC_insertTable
Description: Comments for Sub
Insere link para o documento do banco de dados
Parâmetros de entrada:
strHiperLink -> Link para o documento.
"Notes://" + Server.Common + "/" + bd.ReplicaID + "/vi_All/" + + doc.UniversalID
coluna -> Coluna que indicará a posição do link
linha -> Linha que indicará a posição do link
%END REM
Sub CALC_insertHiperLink(strUrl As String, coluna As Long, linha As Long)

Set oCelula = oPlanilha.getCellByPosition(coluna, linha)
oCelula.setString("Link")

REM Create a URL Text field
Set oField = oDoc.createInstance("com.sun.star.text.TextField.URL")
oField.Representation = "Link"
oField.URL = strUrl

oCelula.setString("")
Set oText = oCelula.getText()
Call oText.insertTextContent(oText.createTextCursor(), oField, False)

End Sub

%REM
Sub CALC_autoFiltro
Description: Comments for Sub
%END REM
Sub CALC_autoFiltro(colunaInicial As Long, linhaInicial As Long, colunaFinal As Long, linhaFinal As Long)

Set oCellRange = oPlanilha.getCellRangeByPosition(colunaInicial, linhaInicial, colunaFinal, linhaFinal)
Set oAddr = oCellRange.getRangeAddress()
Call oDoc.DatabaseRanges.addNewByName("dbRange", oAddr)

Set oCellRange = oDoc.DatabaseRanges.getByName("dbRange")
oCellRange.AutoFilter = True

End Sub

%REM
Sub CALC_showFile
Description: Comments for Sub
%END REM
Sub CALC_showFile()
oDoc.getCurrentController().getFrame().getContainerWindow().setVisible(True)
End Sub

%REM
Funtion UTIL_Hex2Dec
Description: Comments for Function
Essa função faz a conversão de um número hexadecimal para decimal
%END REM

Function UTIL_Hex2Dec( hexadecimal )
Dim n, aux, valores, decimal, fator

'Busca e retira o caracter "#" do código RGB informado
Dim pos As Integer
pos = Instr(hexadecimal, "#")

If pos > 0 Then
hexadecimal = Right(hexadecimal, Len(hexadecimal) - pos)
End If

'Conversão HEX to DEC
valores = "0123456789ABCDEF"
n = 1
decimal = 0

For n = Len( hexadecimal ) To 1 Step -1
fator = 16 ^ ( Len( hexadecimal ) - n )
aux = Instr( valores, Mid( hexadecimal, n, 1 ) ) - 1
decimal = decimal + ( aux * fator )
Next

UTIL_Hex2Dec = decimal
End Function

%REM
Sub CALC_AddSheet
Description: Comments for Sub
OBJETIVO: Adiciona um determinado valor a uma célula dentro do arquivo no Excel
PARÂMETROS: total [Integer] - Quantidade de Planilhas a inserir.
RETORNO: Nenhum
%END REM
Sub CALC_addSheet(total As Integer)
Dim i As Integer
For i = 0 To total -1
oDoc.Sheets.insertNewByName "Planilha_" + Cstr(i),1
Next
End Sub

Sub CALC_selectSheet(intNum As Integer)
'Posiciona o cursor na pasta solicitada dentro de uma planilha
Set oPlanilha = oDoc.getSheets().getByIndex(intNum)
Set oCelula = oPlanilha.getCellByPosition(0, 0)
End Sub

%REM
'OBJETIVO: Adiciona um determinado valor a uma célula dentro do arquivo no Excel
'PARÂMETROS: total [Integer] - Quantidade de Planilhas a inserir.
' texto [String] - Valor para qual será renomeado
'RETORNO: Nenhum
%END REM
Sub CALC_renameSheet(total As Integer, texto As String)

Dim i As Integer

For i = 1 To total
Set oPlanilha = oDoc.getSheets().getByIndex(i - 1)
Call oPlanilha.setName(texto + Cstr(i))
Next

End Sub

%REM
Function CALC_GetCellValue
Description: Comments for Function
%END REM
Function CALC_getCellValue(intLin As Long, intCol As Long) As String
Set oCelula = oPlanilha.getCellByPosition(intCol, intLin)
CALC_getCellValue = oCelula.getString()

End Function



%REM
Function CALC_getCellName
Description: Comments for Function
%END REM
Function CALC_getCellName(nLeft As Long, nTop As Long, nRight As Long, nBottom As Long) As String


Set oCelula = oPlanilha.getCellRangeByPosition(1, 1, 2, 1)
Set oAddr = oCelula.getRangeAddress()


End Function

%REM
Sub UTIL_InicializaVetorColuna
Description: Comments for Sub
%END REM
Sub UTIL_InicializaVetorColuna

strListNomeCelula("0") = "A"
strListNomeCelula("1") = "B"
strListNomeCelula("2") = "C"
strListNomeCelula("3") = "D"
strListNomeCelula("4") = "E"
strListNomeCelula("5") = "F"
strListNomeCelula("6") = "G"
strListNomeCelula("7") = "H"
strListNomeCelula("8") = "I"
strListNomeCelula("9") = "J"
strListNomeCelula("10") = "K"
strListNomeCelula("11") = "L"
strListNomeCelula("12") = "M"
strListNomeCelula("13") = "N"
strListNomeCelula("14") = "O"
strListNomeCelula("15") = "P"
strListNomeCelula("16") = "Q"
strListNomeCelula("17") = "R"
strListNomeCelula("18") = "S"
strListNomeCelula("19") = "T"
strListNomeCelula("20") = "U"
strListNomeCelula("21") = "V"
strListNomeCelula("22") = "W"
strListNomeCelula("23") = "X"
strListNomeCelula("24") = "Y"
strListNomeCelula("25") = "Z"

End Sub

%REM
Function UTIL_RecuperaLetraColuna
Description: Comments for Function
%END REM
Function UTIL_RecuperaLetraColuna(intCol As Long)
UTIL_RecuperaLetraColuna = strListNomeCelula(intCol)
End Function

%REM
Sub CALC_merge
Description: Comments for Sub
Efetua o merge de células no BrOffice_Calc

Parâmetros:
intPlanilha -> Número da planilha, '0 (zero)' para planilha 1
intColInicio -> Coluna de início para montar o range
intLinhaInicio -> Linha de início para montar o range
intColFim -> Coluna final para montar o range
intLinhaFim -> Linha final para montar o range
%END REM
Sub CALC_mergeCells(intPlanilha As Long, intColInicio As Long, intLinhaInicio As Long, intColFim As Long, intLinhaFim As Long)
Set oPlanilha = oDoc.getSheets().getByIndex(intPlanilha)
Call oPlanilha.getCellRangeByPosition(intColInicio, intLinhaInicio, intColFim, intLinhaFim).Merge(True)
End Sub
Sub Initialize

End Sub

Rotina completa para envio de e-mail

Public Sub email(destinatario As Variant, copia As Variant, copiaoculta As Variant, _
assunto As String, texto As String, remetente As String, doc As notesdocument)
Dim docmsg As NotesDocument
Dim itemrtf As notesrichtextitem
Dim itemrecipients As notesitem
Dim itemcopyto As notesitem
Dim itemblindcopyto As notesitem

On Error Goto ErrorHandler

Set docmsg = New NotesDocument(BdLocal)

docmsg.Form="Memo"

If remetente <> "" Then

docmsg.From = remetente
docmsg.Principal = remetente

Else

docmsg.From = Sessao.username
docmsg.Principal = Sessao.username

End If

docmsg.SendTo = destinatario
docmsg.CopyTo = copia
docmsg.BlindCopyTo = copiaoculta

docmsg.Recipients = docmsg.SendTo
Set itemrecipients = docmsg.getfirstitem("Recipients")
Set itemcopyto = docmsg.getfirstitem("CopyTo")
Set itemblindcopyto = docmsg.getfirstitem("BlindCopyTo")

Forall d In itemcopyto.values
itemrecipients.appendtotextlist d
End Forall

Forall d In itemblindcopyto.values
itemrecipients.appendtotextlist d
End Forall


docmsg.subject = assunto

Set itemrtf = docmsg.createrichtextitem("Body")
Call itemrtf.appendtext(texto)
Call itemrtf.AddNewLine( 2 )

If Not(doc Is Nothing) Then
Call itemrtf.AppendText("Para abrir o documento clique aqui -> ")
Call itemrtf.AppendDocLink( doc, "" )
Call itemrtf.AddNewLine( 2 )
End If

docmsg.PostedDate = Now

docmsg.savemessagemonsend = False
docmsg.send False

Exit Sub

ErrorHandler:
If Err>=1000 And Err<=1999 Then
Error Err, Error$
Else
Error Err, "ScriptLibrary Core - Função Email - Erro : " + Error + " - linha : " + Cstr(Erl)
End If
End Sub

Base64

'Base64:

Option Public
Option Explicit

%REM
This set of functions will allow you to encode and decode strings and files
in Base64 format. The implementation is all in LotusScript, and requires no
external DLLs or tricks. It was written and tested in R5, but it should be
backwards compatible to at least 4.6

This is the 1.4 "release" of the functions, from December 28, 2002.
The code was originally written by Julian Robichaux, and is maintained
by him on the http://www.nsftools.com website.

Release History:
1.4 (Dec 28, 2002)
-- fixed TrimBytesFromFile function to properly handle writing odd numbers
of bytes to a new file (thanks to Peter Leugner at www.as-computer.de)

1.3 (Dec 26, 2002)
-- Modified DecodeFile function to properly handle the line terminators
that the Print statement adds
-- Fixed GetFileChunk function to properly read the last byte in a file

1.2 (Dec 17, 2002)
-- Added functions for encrypting and decrypting entire files

1.1 (Nov 5, 2002)
-- Fixed typo/error in EncodeBase64 function

1.0 (Nov 1, 2002)
-- Initial release
%END REM


'** the characters used to encode in Base64, in order of appearance
Const b64chars = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
Sub Initialize
%REM
'** examples of using the Base64 functions in this agent
Dim eString As String, dString As String
Dim isOkay As Integer

eString = "QUJDREVGRw==" '** ABCDEFG
dString = DecodeBase64(eString)

isOkay = IsBase64(eString)

eString = EncodeBase64("AbCdEfG" & Chr(0) & "123")
eString = BreakString(eString, 5)
dString = DecodeBase64(eString)

isOkay = IsBase64(RemoveWhitespace(eString))
isOkay = IsBase64(dString)

isOkay = EncodeFile("C:\Autoexec.bat", "C:\Autoexec.enc")
isOkay = DecodeFile("C:\Autoexec.enc", "C:\Autoexec.dec")
%ENDREM
End Sub
Function DecodeBase64 (Byval encText As String) As String
'** This function will decode a Base64 string. It's probably a good
'** idea to check the validity of the string with the IsBase64 function
'** prior to processing it, to avoid strange errors.
'** by Julian Robichaux -- http://www.nsftools.com
On Error Goto endOfFunction

Dim encNum As Long
Dim decText As String
Dim i As Integer

'** remove any line termination characters and whitespace first
encText = RemoveWhitespace(encText)

For i = 1 To Len(encText) Step 4
'** convert the next 2 of 4 characters to a number we can decode
encNum = (Instr(b64chars, Mid$(encText, i, 1)) - 1) * (2 ^ 18)
encNum = encNum Or ((Instr(b64chars, Mid$(encText, i+1, 1)) - 1) * (2 ^ 12))

'** deal with trailing '='
If (Mid$(encText, i+2, 1) = "=") Then
decText = decText & Chr(Fix(encNum / (2 ^ 16)) And &HFF)
Elseif (Mid$(encText, i+3, 1) = "=") Then
encNum = encNum Or ((Instr(b64chars, Mid$(encText, i+2, 1)) - 1) * (2 ^ 6))
decText = decText & Chr(Fix(encNum / (2 ^ 16)) And &HFF)
decText = decText & Chr(Fix(encNum / (2 ^ 8)) And &HFF)
Else
encNum = encNum Or ((Instr(b64chars, Mid$(encText, i+2, 1)) - 1) * (2 ^ 6))
encNum = encNum Or (Instr(b64chars, Mid$(encText, i+3, 1)) - 1)
decText = decText & Chr(Fix(encNum / (2 ^ 16)) And &HFF)
decText = decText & Chr(Fix(encNum / (2 ^ 8)) And &HFF)
decText = decText & Chr(encNum And &HFF)
End If

Next

endOfFunction:
DecodeBase64 = decText
Exit Function

End Function
Function EncodeBase64 (decText As String) As String
'** This function will Base64 encode a string. The string doesn't have to
'** be text-only, either. You can also encode strings of non-ASCII data,
'** like the contents of a binary file. If you're encoding a whole file,
'** make sure you break the contents into lengths divisible by three, so
'** you can concatenate them together properly.
'** by Julian Robichaux -- http://www.nsftools.com
On Error Goto endOfFunction

Dim decNum As Long
Dim encText As String
Dim chunk As String
Dim i As Integer

For i = 1 To Len(decText) Step 3
'** pad the 3-character string with Chr(0), if need be
chunk = Left$(Mid$(decText, i, 3) & Chr(0) & Chr(0), 3)

'** get the number we'll use for encoding
decNum = Asc(Mid$(chunk, 1, 1)) * (2 ^ 16)
decNum = decNum Or Asc(Mid$(chunk, 2, 1)) * (2 ^ 8)
decNum = decNum Or Asc(Mid$(chunk, 3, 1))

'** calculate the first 2 of 4 encoded characters
encText = encText & Mid$(b64chars, (Fix(decNum / (2 ^ 18)) And &H3F) + 1, 1)
encText = encText & Mid$(b64chars, (Fix(decNum / (2 ^ 12)) And &H3F) + 1, 1)

'** pad with '=' as necessary when we reach the end of the string
Select Case ( Len(decText) - i )
Case 0 :
encText = encText & "=="
Case 1 :
encText = encText & Mid$(b64chars, (Fix(decNum / (2 ^ 6)) And &H3F) + 1, 1)
encText = encText & "="
Case Else :
encText = encText & Mid$(b64chars, (Fix(decNum / (2 ^ 6)) And &H3F) + 1, 1)
encText = encText & Mid$(b64chars, (decNum And &H3F) + 1, 1)
End Select

Next

endOfFunction:
EncodeBase64 = encText
Exit Function

End Function
Function IsBase64 (someString As String) As Integer
'** check to see if the string is a well-formed Base64 string
Dim legalString As String
Dim i As Integer

IsBase64 = False
legalString = b64chars & "="

'** check for bad string length (must be a multiple of 4)
If (Len(someString) Mod 4 > 0) Then
Exit Function
End If

'** check for illegal characters
For i = 1 To Len(someString)
If (Instr(legalString, Mid$(someString, i, 1)) = 0) Then
Exit Function
End If
Next

'** make sure any '=' are only at the end
Select Case (Instr(someString, "="))
Case 0 :
'** no equals signs is okay
Case Is < (Len(someString) - 1) : Exit Function Case (Len(someString) - 1) : If (Right$(someString, 1) <> "=") Then
Exit Function
End If
End Select

'** if we made it through all the conditions, then the string looks good
IsBase64 = True

End Function
Function BreakString (text As String, lineLength As Integer) As String
'** add line terminators to a string at the given interval
Dim newText As String
Dim lineTerm As String
Dim i As Integer

lineTerm = Chr(13) & Chr(10)

For i = 1 To Len(text) Step lineLength
newText = newText & Mid$(text, i, lineLength) & lineTerm
Next

newText = Left$(newText, Len(newText) - Len(lineTerm))
BreakString = newText
End Function
Function RemoveWhitespace (Byval text As String) As String
'** remove line terminators, spaces, and tabs from a string
Call ReplaceSubstring(text, Chr(13), "")
Call ReplaceSubstring(text, Chr(10), "")
Call ReplaceSubstring(text, Chr(9), "")
Call ReplaceSubstring(text, " ", "")

RemoveWhitespace = text
End Function
Function EncodeFile (fileIn As String ) As String

'** Base64 encode an entire file (fileIn) and write the output to
'** another file (fileOut). We're writing the output to another file
'** because there's a possibility that the output will be larger than
'** 32,000 characters, which would overflow an output String.

On Error Goto processError

Dim fin As Integer, fout As Integer
Dim finOpen As Integer, foutOpen As Integer
Dim datain As String, dataout As String
Dim worktext As String, leftover As String
Const CHUNKSIZE = 15000
Dim resp As String

'** open the files for input/output (if there are any errors here,
'** we'll exit in the processError section at the bottom)
fin = Freefile()
Open fileIn For Input As fin
finOpen = True

' fout = Freefile
' Open fileOut For Output As fout
' foutOpen = True

'** start getting data from the input file, encoding it, and sending it
'** to the output file
datain = GetFileChunk(fin, CHUNKSIZE)
Do While (Len(datain) > 0)
'** encode in groups of 57 characters, which will give us output
'** in lines of 76 characters (fairly standard)
leftover = leftover & datain
While (Len(leftover) > 57)
worktext = Left$(leftover, 57)
leftover = Mid$(leftover, 58)
dataout = EncodeBase64(worktext)
' Print #fout, dataout
resp = resp + dataout
Wend
datain = GetFileChunk(fin, CHUNKSIZE)
Loop

'** encode anything we had left, and close the files
If (Len(leftover) > 0) Then
' Print #fout, EncodeBase64(leftover)
resp = resp + EncodeBase64(leftover)
End If

' Close #fin, #fout
Close #fin
EncodeFile = resp
Exit Function

processError:
If (finOpen) Then Close #fin
' If (foutOpen) Then Close #fout
EncodeFile = "Erro"
Exit Function

End Function
Function DecodeFile (fileIn As String, fileOut As String) As Integer
'** Base64 decode an entire file (fileIn) and write the output to
'** another file (fileOut). We're writing the output to another file
'** because there's a possibility that the output will be larger than
'** 32,000 characters, which would overflow an output String.
On Error Goto processError

Dim fin As Integer, fout As Integer
Dim finOpen As Integer, foutOpen As Integer
Dim datain As String, dataout As String
Dim worktext As String, leftover As String
Const CHUNKSIZE = 16000

'** figure out how long the line terminator character is
Dim session As New NotesSession
Dim lineTermLen As Integer
If (Instr(session.Platform, "Windows") > 0) Then
lineTermLen = 2
Else
lineTermLen = 1
End If

'** open the files for input/output (if there are any errors here,
'** we'll exit in the processError section at the bottom)
fin = Freefile()
Open fileIn For Input As fin
finOpen = True
fout = Freefile
Open fileOut For Output As fout
foutOpen = True

'** start getting data from the input file, encoding it, and sending it
'** to the temporary output file
datain = GetFileChunk(fin, CHUNKSIZE)
Do While (Len(datain) > 0)
datain = RemoveWhitespace(datain)

'** make sure we're decoding in groups of characters
'** that are multiples of 4
leftover = leftover & datain
worktext = Left$(leftover, Len(leftover) - (Len(leftover) Mod 4))
leftover = Right$(leftover, Len(leftover) Mod 4)
dataout = DecodeBase64(worktext)
Print #fout, dataout
'** adjust the cursor position so we overwrite the line terminator that's
'** automatically been appended to the end of the line by Print
Seek #fout, Seek(fout) - lineTermLen

datain = GetFileChunk(fin, CHUNKSIZE)
Loop

'** decode anything we had left, and close the files
If (Len(leftover) > 0) Then
Print #fout, leftover
End If

Close #fin, #fout
finOpen = False
foutOpen = False

'** okay, so here's the problem: the Print statement automatically appends
'** a line terminator to the end of all the lines it printed. We accounted for
'** this while we were writing to the output file in the Do While loop, but
'** there's going to be an extra line terminator at the end of the file that we
'** couldn't do anything about. So we'll need to copy all but the last one or
'** two bytes (depending on the length of the line terminator on this platform)
'** from the temporary output file to the output file that the user wants using
'** Get and Put commands. We couldn't use Put before because when Put
'** writes a text string to a file, it always writes the Unicode version of the
'** string, which isn't what we wanted (try it sometime and see how it looks...)
'** The TrimBytesFromFile function will take care of the problem.
Call TrimBytesFromFile(fileOut, lineTermLen)

DecodeFile = True
Exit Function

processError:
If (finOpen) Then Close #fin
If (foutOpen) Then Close #fout
DecodeFile = False
Exit Function

End Function
Function GetFileChunk (fileNum As Integer, size As Integer) As String
'** get the next chunk of text from a Random file, up to a given size
On Error Goto processError
Dim dataLength As Long

dataLength = Lof(fileNum) - Seek(fileNum) + 1
Select Case (dataLength)
Case Is <= 0 GetFileChunk = "" Case Is > size
GetFileChunk = Input$(size, fileNum)
Case Else
GetFileChunk = Input$(Cint(dataLength), fileNum)
End Select

Exit Function

processError:
GetFileChunk = ""
Exit Function

End Function
Function TrimBytesFromFile (fileName As String, bytesToTrim As Integer)
'** trim the specified number of bytes from the end of the specified
'** file by copying the file contents to a temporary file using Get and
'** Put, and then deleting the specified file and replacing it with
'** the temporary file
On Error Goto processError

Dim tempFileName As String
Dim fin As Integer, fout As Integer
Dim finOpen As Integer, foutOpen As Integer
Dim dataLength As Long
Dim lineLength As Integer
Dim data As String
Dim dataInt As Integer
Const CHUNKSIZE = 15000

tempFileName = fileName & ".tmp"

fin = Freefile()
Open fileName For Binary As fin
finOpen = True
fout = Freefile()
Open tempFileName For Binary As fout
foutOpen = True

'** this works almost exactly like the GetFileChunk function, subtracting
'** bytesToTrim when we reach the last "chunk" of the file
dataLength = Lof(fin) - Seek(fin) + 1 - bytesToTrim
Do While (dataLength > 1)
If (dataLength > CHUNKSIZE) Then
lineLength = CHUNKSIZE
Else
lineLength = Cint(dataLength)
End If

'** a LotusScript string is actually 2 bytes per character, so we only
'** want to get a string that's half the length of the number of bytes
'** that we need
data = Space$(Fix(lineLength / 2))
Get #fin, , data
Put #fout, , data

dataLength = Lof(fin) - Seek(fin) + 1 - bytesToTrim
Loop

'** if there's only one more byte to read, we need to back up one byte
'** because there are no one-byte data types in LotusScript prior to R6,
'** so we're always writing an even number of bytes at a time
If (dataLength = 1) Then
Seek #fin, Seek(fin) - 1
Seek #fout, Seek(fout) - 1
Get #fin, , dataInt
Put #fout, , dataInt
End If

Close #fin, #fout
finOpen = False
foutOpen = False

'** once all the files are closed, delete the original file and rename the
'** temporary file so it becomes the original
Kill fileName
Name tempFileName As fileName
Exit Function

processError:
If (finOpen) Then Close #fin
If (foutOpen) Then Close #fout
Exit Function

End Function

Sub Terminate

End Sub
Function ReplaceSubstring(text As String, find As String, strreplace As String)
Dim pos As Integer
pos = Instr(text, find)

Do While (pos > 0)
text = Left$(text, pos - 1) & strreplace & Mid$(text, pos + Len(find))
pos = Instr(pos + Len(strreplace), text, find)
Loop
End Function