frmHistorico

'******************************************************************************'
' Project    : Sanepar
' Author     : leandro.pedro@intech-automacao.com.br
' File       : frmHistory.frm
' Date       : 2019.03.13
' FormVersion: 0.0.5
'
' Revision history
'------------------------------------------------------------------------------'
' Date      Author  Revision
' 19.03.18  lbp     Adicionado filtro.
' 19.03.19  lbp     Corrigido caminho para pasta \ALM configurada no SCU.
'------------------------------------------------------------------------------'
' Copyright (c) 2018 by In-Tech Automacao & Sistemas. All Rights Reserved.
'******************************************************************************'
Option Explicit
'
' Cria browse dialog.
' @save_as {boolean} savar como ou abrir.
' @custom_filter {string} filtro tipo de arquivo.
'
Private Function Dialog( _
        Optional ByVal save_as As Boolean = False, _
        Optional ByVal custom_filter As String = "All Files (*.*)|*.*|") As String

    Dim dlgCommonDialog
    Set dlgCommonDialog = CreateObject("MSComDlg.CommonDialog")
    With dlgCommonDialog
        .CancelError = False
        .Filter = custom_filter
        If save_as Then
            .ShowSave
        Else
            .ShowOpen
        End If
    End With
    Dialog = dlgCommonDialog.filename
End Function
'
' Retorna dd/MM/yy
' @param {string} nome do arquivo yyMMdd.ALM
'
Function FormatFileNameToDate(filename As String) As String
    FormatFileNameToDate = Mid(filename, 5, 2) & "/" & Mid(filename, 3, 2) & "/" & Mid(filename, 1, 2)
End Function
'
' Retorna yymmdd.ALM
' @param {string} data dd/MM/yy
'
Function FormatDateToFileName(strDate As String) As String
    If strDate <> "" Then
        FormatDateToFileName = Mid(strDate, 7, 2) & Mid(strDate, 4, 2) & Mid(strDate, 1, 2) & ".ALM"
    End If
End Function
'
' Retorna array com os arquivos contidos na pasta \ALM com ou sem filtro.
' @param {string} filtro por tipo de arquivo.
'
Private Function GetFiles(Optional Filter As String = "*.*") As Variant
    Dim arr
    Dim Path As String
    Dim strFile As String
    'Dim list As Object
    'Set list = CreateObject("System.Collections.ArrayList")
    arr = Array()

    Path = System.FixPath(12) & "\"
    strFile = Dir(Path & Filter)

    Do While (strFile <> vbNullString)
        'list.Add str_file
        ReDim Preserve arr(0 To UBound(arr) + 1)
        arr(UBound(arr)) = strFile
        strFile = Dir
    Loop
    'list.Sort
    'list.Reverse
    GetFiles = arr  'listoArray
End Function

'
' Filter
'
Private Sub btnFilter_Click()
    PopulateList True
End Sub

'
' Combobox
'
Private Sub cboFile_Change()
    PopulateList
End Sub
Private Sub PopulateList(Optional Filtered As Boolean = False)
    Dim c As New Cursor
    Dim match As Boolean
    Dim regex As Object
    Dim str_file As String
    Dim txt_line As String
    Dim Path As String

    Path = System.FixPath(12) & "\"
    str_file = FormatDateToFileName(cboFile)

    If str_file = "" Then Exit Sub

    lvwAlarm.ListItems.Clear
    lvwEvent.ListItems.Clear

    Open (Path & str_file) For Input As #1

    Do Until EOF(1)
        Line Input #1, txt_line
        c.Init txt_line

        If txtTagName = "" Then txtTagName = "*"
        If txtMessage = "" Then txtMessage = "*"

        If c.sTime <> "" Then
            match = IIf(Not Filtered, True, _
                    ((LCase(c.sTagname) Like LCase(txtTagName)) Or c.IsEvent) And _
                    LCase(c.sDescription) Like LCase(txtMessage) And _
                    TimeValue(c.sTime) >= TimeValue(dtStartTime) And _
                    TimeValue(c.sTime) <= TimeValue(dtEndTime))

            If (match) Then
                Select Case c.IsEvent
                    Case True   ' Lista de eventos.
                        With lvwEvent.ListItems.Add()
                            .Text = c.sDate
                            .SubItems(1) = c.sTime
                            .SubItems(2) = c.sDescription
                        End With
                    Case False  ' Lista de alarmes.
                        With lvwAlarm.ListItems.Add()
                            .Text = c.sDate
                            .SubItems(1) = c.sTime
                            .SubItems(2) = c.sTagname
                            .SubItems(3) = c.sType
                            .SubItems(4) = c.sValue
                            .SubItems(5) = c.sDescription
                        End With
                End Select
            End If
        End If
    Loop

    Close #1
End Sub

Private Sub chkFilter_Click()
    PopulateList chkFilter.Value
End Sub

'
' Ordenar lista de alarmes.
'
Private Sub lvwAlarm_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)
    With lvwAlarm
        .SortKey = ColumnHeader.Index - 1
        .SortOrder = (.SortOrder - 1) * -1
        .Sorted = True
    End With
End Sub
'
' Ordenar lista de eventos.
'
Private Sub lvwEvent_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)
    With lvwEvent
        .SortKey = ColumnHeader.Index - 1
        .SortOrder = (.SortOrder - 1) * -1
        .Sorted = True
    End With
End Sub
'
' Multipage mudanca de aba.
'
Private Sub multiPage_Change()
    lblTagName.Enabled = (multiPage.Value = 0)
    txtTagName.Enabled = (multiPage.Value = 0)
End Sub

'
' Activate
'
Private Sub UserForm_Initialize()

    CentralizeForm

    ' Cria nome das colunas de alarme.
    With lvwAlarm
        .View = lvwReport
        .ColumnHeaders.Add , , "Data", 60
        .ColumnHeaders.Add , , "Hora", 60
        .ColumnHeaders.Add , , "Nome do tag", 120
        .ColumnHeaders.Add , , "Tipo", 60
        .ColumnHeaders.Add , , "Valor", 60
        .ColumnHeaders.Add , , "Mensagem", 196
        .FullRowSelect = True
    End With

    ' Cria nome das colunas de eventos.
    With lvwEvent
        .View = lvwReport
        .ColumnHeaders.Add , , "Data", 60
        .ColumnHeaders.Add , , "Hora", 60
        .ColumnHeaders.Add , , "Mensagem", 436
        .FullRowSelect = True
    End With

    ' Preenche combox.
    cboFile.Clear
    Dim itm As Variant
    For Each itm In GetFiles("*.alm")
        cboFile.AddItem FormatFileNameToDate(CStr(itm))
    Next
End Sub
'
' Close
'
Private Sub btnClose_Click()
    Unload Me
End Sub
'
' Export
'
Private Sub btnExport_Click()
    Const xlCellTypeVisible = 12
    Const xlCenter = -4108
    Const xlToLeft = -4159

    Dim excel_app As Object
    Dim workbook As Variant
    Dim sht As Variant
    Dim itmX As Variant, itmY As Variant
    Dim last_col As Integer, last_row As Integer
    Dim lvw As Object

    Select Case multiPage.Value
        Case 0: Set lvw = lvwAlarm  ' Aba alarmes.
        Case 1: Set lvw = lvwEvent  ' Aba eventos.
    End Select

    On Error GoTo ErrorHandler
    If lvw.ListItems.Count > 0 Then
        Set excel_app = CreateObject("Excel.Application")
        Set workbook = excel_app.Workbooks.Add(1)

        ' Nomeia planilha.
        Set sht = workbook.Sheets.Item(1)
        sht.Name = lvw.Parent.Caption

        ' Linha/coluna incial.
        Dim row As Integer: row = 5
        Dim col As Integer: col = 1

        last_col = lvw.ColumnHeaders.Count - 1

        ' Adiciona linha com título e mescla.
        With sht.Cells(row, col)
            .Value = "HISTÓRICO DE " & UCase(lvw.Parent.Caption)
            .Font.Bold = True
            .HorizontalAlignment = xlCenter
        End With
        sht.range(sht.Cells(row, 1), sht.Cells(row, last_col)).Merge
        row = row + 2

        ' Adiciona linha com data.
        With sht.Cells(row, col)
            .Value = "Data:"
            .Font.Bold = True
        End With
        sht.Cells(row, col + 1).Value = "'" & cboFile.Text
        row = row + 2

        ' Estiliza cabecalho.
        With sht.range(sht.Cells(1, 1), sht.Cells(row, last_col))
            .Interior.Color = vbWhite
            .Font.Color = vbBlue
        End With

        ' Cria linha com titulo das colunas.
        For col = 1 To last_col
            sht.Cells(row, col).Value = lvw.ColumnHeaders(col + 1).Text
        Next

        ' Estiliza linha com titulos das colunas.
        With sht.range(sht.Cells(row, 1), sht.Cells(row, last_col))
            .Interior.Color = vbBlue 'RGB(48, 89, 155)
            .Font.Color = vbWhite
            .Font.Bold = True
            .Columns.AutoFilter
            ' .Columns.AutoFit
        End With

        ' Preenche planilha com dados conforme sort e filtro da lista.
        For Each itmX In lvw.ListItems
            col = 1
            row = row + 1
            For Each itmY In itmX.ListSubItems
                sht.Cells(row, col).Value = itmY
                col = col + 1
            Next
        Next

        ' Ajusta largura das colunas.
        sht.Cells.SpecialCells(xlCellTypeVisible).EntireColumn.AutoFit

        ' Adiciona logo sanepar.
        With sht.Pictures.Insert(System.DocumentPath & "\logo.png")
            .Left = 0
            .Top = 0
        End With

        Dim file As String
        file = Dialog(True, "Excel Workbook (*.xlsx), *.xlsx")

        ' Salva e fecha objeto excel.
        If (file <> "") Then
            workbook.SaveAs file
            If MsgBox("Deseja abrir o arquivo gerado?", vbYesNo) = vbYes Then
                Shell excel_app.Path & "\Excel.exe" & " " & file, vbMaximizedFocus
            End If
        End If

        workbook.Close SaveChanges:=False
        excel_app.Quit
    End If

    Exit Sub

ErrorHandler:
    MsgBox Err.Description, vbExclamation
    workbook.Close SaveChanges:=False
    excel_app.Quit
End Sub

'
' CentralizeForm
'
Private Sub CentralizeForm()
    Dim ID As Integer
    Dim X As Double
    Dim Y As Double
    Dim pt As POINTAPI

    GetCursorPos pt

    On Error GoTo ErrorHandler:

    ' Retorna resolucao width x height px do monitor onde o mouse esta posicionado.
    X = GetSystemMetrics(0)
    Y = GetSystemMetrics(1)

    ID = IIf(pt.X > X, 2, 1)

    ' Posicao manual do form.
    Me.StartUpPosition = 0

    ' Transforma px em ppi, unidade de medida utilizada pelo UserForm.
    X = (PixelsToPoints(X) / 2) + ((ID - 1) * PixelsToPoints(X))
    Y = (PixelsToPoints(Y) / 2)

    ' Posiciona o form para abrir centralizado na tela chamadora.
    Me.Left = CSng(X) - Me.width / 2
    Me.Top = CSng(Y) - Me.Height / 2

    Exit Sub '
ErrorHandler:
    Debug.Print Err, Err.Description
    Select Case Err
        Case -2147200630, 91
            ID = 2
            Resume Next
    End Select
End Sub