VBA Timer for P.Action

'Bu kod Modules/scheduler içine gidecek

'Program sistem saatinin saat hanesini sira numarasi olarak kullanip bir sonraki siradaki saati zamanlar
'yani su an saat 18:00 ise 19:00'a ayarlar
Public Const hours As String = "01:00:00,02:00:00,03:00:00,04:00:00,05:00:00,06:00:00,07:00:00,08:00:00,09:00:00,10:00:00,11:00:00,12:00:00,13:00:00,14:00:00,15:00:00,16:00:00,17:00:00,18:00:00,19:00:00,20:00:00,21:00:00,22:00:00,23:00:00,00:00:00"

Public Const DebugMode As Boolean = False 'Kendin kullandigin zaman False yap

Public Const ExportType = "xlsm"
Public Const sayfa = "genel"
Public Col As New Collection

Public Function getNextTimer()
    If DebugMode Then
        t = Now() + TimeSerial(0, 1, 0)
    Else
        array_hours = Split(hours, ",")
        t = array_hours(Hour(Now()))
    End If
    getNextTimer = t
End Function

Public Sub scheduledMacro()
    t = getNextTimer()
    Application.OnTime t, "scheduledMacro"

    Set Sh = ThisWorkbook.Sheets(sayfa)
    output = "D:\" + Format(Now(), "yyyy-MM-dd_hh-mm-ss")

    If ExportType = "html" Then
        Set PO = ThisWorkbook.PublishObjects.Add( _
            SourceType:=xlSourceSheet, _
            Filename:=output & "." & ExportType, _
            Sheet:=Sh.Name, _
            HtmlType:=xlHtmlStatic)
        PO.Publish True
        PO.Delete

    ElseIf ExportType = "pdf" Then
        Sh.ExportAsFixedFormat _
            Type:=xlTypePDF, _
            Filename:=output & "." & ExportType, _
            Quality:=xlQualityStandard, _
            IncludeDocProperties:=True, _
            IgnorePrintAreas:=False, _
            OpenAfterPublish:=False

    ElseIf ExportType = "xlsm" Then
        Dim wb As Workbook
        Dim sh2 As Worksheet

        Sh.Copy
        Set wb = ActiveWorkbook

        Set sh2 = wb.Sheets(Sh.Name)
        sh2.Cells.Copy
        sh2.Cells.PasteSpecial xlPasteValues

        wb.SaveAs Filename:=output & "." & ExportType, FileFormat:=xlOpenXMLWorkbookMacroEnabled
        wb.Close True

    ElseIf ExportType = "png" Then
        zoom_coef = 100 / Sh.Parent.Windows(1).Zoom
        Set area = Sh.Range(Sh.PageSetup.PrintArea)
        area.CopyPicture xlPrinter
        Set chartobj = Sh.ChartObjects.Add(0, 0, area.Width * zoom_coef, area.Height * zoom_coef)
        chartobj.Chart.Paste
        chartobj.Chart.Export output, ExportType
        chartobj.Delete
    End If

End Sub

Function sum_counter(CELL As Range)
    Dim cell_address As String
    cell_address = CELL.Address
    new_value = CELL.Value
    counter = 0
    If cHas(Col, cell_address) Then
        arr = cGet(Col, cell_address)
        old_value = arr(0)
        counter = arr(1)
        If new_value > old_value Then
            counter = counter + 1
        End If
    End If
    cSet Col, cell_address, Array(new_value, counter)
    sum_counter = counter
End Function

Private Function cGet(ByRef Col As Collection, Key As String) As Variant
    If Not cHas(Col, Key) Then Exit Function
    On Error Resume Next
        Err.Clear
        Set cGet = Col(Key)(1)
        If Err.Number = 13 Then
            Err.Clear
            cGet = Col(Key)(1)
        End If
    On Error GoTo 0
    If Err.Number <> 0 Then Call Err.Raise(Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext)
End Function

Private Sub cSet(ByRef Col As Collection, Key As String, Item As Variant)
    If (cHas(Col, Key)) Then Col.Remove Key
    Col.Add Array(Key, Item), Key
End Sub

Public Function cHas(Col As Collection, Key As String) As Boolean
    cHas = True
    On Error Resume Next
        Err.Clear
        Col (Key)
        If Err.Number <> 0 Then
            cHas = False
            Err.Clear
        End If
    On Error GoTo 0
End Function
Private Sub cRemove(ByRef Col As Collection, Key As String)
    If cHas(Col, Key) Then Col.Remove Key
End Sub
Private Function cKeys(ByRef Col As Collection) As String()
    Dim Initialized As Boolean
    Dim Keys() As String

    For Each Item In Col
        If Not Initialized Then
            ReDim Preserve Keys(0)
            Keys(UBound(Keys)) = Item(0)
            Initialized = True
        Else
            ReDim Preserve Keys(UBound(Keys) + 1)
            Keys(UBound(Keys)) = Item(0)
        End If
    Next Item

    cKeys = Keys
End Function