'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
terça-feira, 19 de julho de 2011
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
%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
%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
Assinar:
Postagens (Atom)