'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
Nenhum comentário:
Postar um comentário