User Tools

Site Tools


vba:classes:date:dateinterval:index

[VBA] DateInterval

Version 1.6.0 21.06.2016
Das Modul hat versteckte Attribute. Damit diese aktiv übernommen werden reicht es nicht aus, den Code in ein neues Modul zu kopieren. Man muss das Modul aus der Datei nach VBA importieren.
Bild zum Import

Download dateinterval.cls (V-1.6.0)

DateInterval stellt ein Abstand zwieschen 2 Datums dar. Als Grundlage dient ISO8601 Duration

Die Klasse [VBA] DateTime muss ebenfalls installiert sein: datetime.cls

Methoden

CONSTRUCT()

Public Function instance(ByVal iIntervalSpec As Variant) As DateInterval

Initialisiert eine DateIteratorInstanz mit einer IntervalSpec oder Anzahl Tage

Parameters

iIntervalSpec

Eine IntervalSpec nach ISO8601 Duration oder eine Zahl. Das währen dann Anzahlt Tage

Return

Eine Referenz auf die aktuelle [VBA] DateInterval-Instanz

Beispiel

Dim di As New DateInterval
di.construct ("P3DT5H")

INSTANCE()

Public Function instance(ByVal iIntervalSpec As Variant) As DateInterval

Erstellt eine neue Instanz eines DateIterators aus einer IntervalSpec oder aus Anzahl Tage

Diese Funktion hat die Attributzeile 'Attribute item.VB_UserMemId = 0'. Ergo ist es die Standartfunktion der Klasse

Parameters

iIntervalSpec

Eine IntervalSpec nach ISO8601 Duration oder eine Zahl. Das währen dann Anzahlt Tage

Return

Eine neue Instanz der [VBA] DateInterval-Klasse

Beispiele

Dim di As DateInterval
'Einmal über Funktionsaufruf mit einer IntervalSpec
Set di = DateInterval.instance("P3D")
'Und dasselbe mit Anzahl Tage. Da instance() die Standartfunktion ist, muss sie nicht explizit angegeben werden
Set di = DateInterval(3)

INSTANCEFROMDATEDIFF()

Erstellt eine Instance von einem DateIterar aus der Differenz von 2 Datum

Public Function instanceFromDateDiff( _
        Optional ByRef iDate1 As Variant = Null, _
        Optional ByRef iDate2 As Variant = Null, _
        Optional ByVal iAbsolute As Boolean = False _
) As DateInterval

Parameters

iDate1

Das erste Datum für die Differenz. Es kann sich dabei um ein VBA-Datum, ein Datumsstring oder ein DateTime-Objekt handeln

iDate2

Das zweite Datum für die Differenz. Es kann sich dabei um ein VBA-Datum, ein Datumsstring oder ein DateTime-Objekt handeln

iAbsolute

Ein Flag mit dem man das Vorzeichen unterdrücken kann. Egal ob iDate1 oder iDate2 grösser ist, es wird immer eine positive DIfferenz sofern iAbsolute auf True steht.

Return

Eine neue Instanz der [VBA] DateInterval-Klasse

Beispiel

Dim di As DateInterval
Set di = DateInterval.instanceFromDateDiff(#8/1/2014 8:15:00 AM#, #9/1/2014 9:30:15 AM#)

format()

Formatiert ein Interval zu einem String. Formate analog zum VBA-Befehl format()

Public Function format(ByVal iFormat As String) As String

Parameters

iFormat

Das Ausgabeformat

Abk. Beschreibung
m Monat ohne führende Null (1-12)
mm Monat mit führende Null (01-12)
mx Total Anzahl Monate ohne führende Null
d Tag ohne führende Null (1-31)
dd Tag mit führende Null (01-31)
dx Total Anzahl Tage ohne führende Null
y Einstelliges Jahr. Analog zu d wird es glösser geschrieben, wenn es mehr Zeichen hat
yy Zweistelliges Jahr
yyyy Vierstelliges Jahr
h Stunden ohne führende Null(0-24)
hh Stunden mit führende Null(00-24)
hx Total Anzahl Stunden ohne führende Null
n Minuten ohne führende Null(0-59)
nn Minuten mit führende Null(00-59)
nx Total Anzahl Minuten ohne führende Null
s Sekunden ohne führende Null(0-59)
ss Sekunden mit führende Null(00-59)
sx Total Anzahl Tage ohne führende Null
r Bei Muinus ein -
R Bei Minus ein -, bei Plus ein +

Mit \ kann ein Format maskiert werden. damit es nichtgeparst wird: m wird als Monat ausgegeben. \m wird zu “m”

Return

Ein formatierter String

Beispiel

Dim di As DateInterval
Set di = DateInterval("P13Y4M1DT15H")
Debug.Print di.format("\Y;: y, \M: m")  '-> "Y: 13, M: 4"

format2()

Formatiert ein Interval zu einem String. Im Gegensatz zu format() werden die Formate als Pattern mitgegeben. Dadurch lassen sich Texte einfach parsen.

Public Function format2(ByVal iFormat As String) As String

Parameters

iFormat

Die Patterns sind analog zu iFormat bei format(). Jedoch müssen sie in {$..} geschrieben werden.

Return

Ein formatierter String

Beispiel

Dim di As DateInterval
Set di = DateInterval("P13Y4M1DT15H")
Debug.Print di.format2("Y: {$y}, M: {$m}")  '-> "Y: 13, M: 4"

Properties

  • year Die Jahre des Intervals
  • month
  • day
  • hour
  • minute
  • second
  • sign Das Vorzeichen des Interval. -1 oder 1
  • years Anzahl Jahre insgesamt. Wird nur bei DateDIff() abgefüllt. Entspricht dem VBA.DateDiff('y', date1, date2)
  • months Dito für Monate
  • days Dito für Tage
  • hours Dito für Stunden
  • minutes Dito für Minuten
  • seconds Dito für Sekunden
  • intervalSpec Gibt den Interval als IntervalSpec zurück: P[n]Y[n]M[n]DT[n]H[n]M[n]S
  • intervalSpec2 IntervalSpecin der Schreibweise: PYYYYMMDDThhmmss
  • intervalSpec3 und P[YYYY]-[MM]-[DD]T[hh]:[mm]:[ss]

Code

dateinterval.cls
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "DateInterval"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'-------------------------------------------------------------------------------
'File         : DateInterval.cls
'               Copyright mpl by ERB software
'               All rights reserved
'               http://wiki.yaslaw.info/dokuwiki/doku.php/vba/
'Environment  : VBA 2007+
'Version      : 1.6.0
'Name         : DateInterval
'Author       : Stefan Erb (ERS)
'History      : 06.08.2014 - ERS - Creation
'               26.08.2015 - ERS - Paramter iOnlyAddReturnDateInterval auf iByRef umbenannt
'               04.01.2016 - ERS - format2() eingebaut um Texte einfacher parsen zu knnen
'               02.03.2016 - ERS - addTo() hinzugefgt
'               30.03.2016 - ERS - testIntervalString() hinzugefgt
'               21.06.2016 - ERS - Add Interface IFormattable
'-------------------------------------------------------------------------------
Option Explicit
 
'-------------------------------------------------------------------------------
' -- ! SETTINGS !
'-------------------------------------------------------------------------------
'In Excel funktionieren Events nicht. Auch der NZ() gibt es dort nicht.
'Darum hier angeben ob es sich um MS Access handelt oder eben nicht. Leider gibts datzu keine Systemvariable
#Const isAccess = True
 
'Das Interface IFormattable ist in diesem Projekt vorhanden
#Const IFormattable_exists = True
 
'Die IntervalSpec entspricht fast der IntervalSpec von PHP: http://php.net/manual/de/dateinterval.construct.php
'Dies enrspricht der ISO8601 Duration Definition  http://en.wikipedia.org/wiki/Iso8601#Durations
'Durations are a component of time intervals and define the amount of intervening time in a time interval.
'They should only be used as part of a time interval as prescribed by the standard. Time intervals are discussed in the next section.
'
'Durations are represented by the format P[n]Y[n]M[n]DT[n]H[n]M[n]S or P[n]W as shown to the right. In these representations,
'the [n] is replaced by the value for each of the date and time elements that follow the [n]. Leading zeros are not required,
'but the maximum number of digits for each element should be agreed to by the communicating parties. '
'The capital letters P, Y, M, W, D, T, H, M, and S are designators for each of the date and time elements and are not replaced.
'
'    P is the duration designator (historically called "period") placed at the start of the duration representation.
'    Y is the year designator that follows the value for the number of years.
'    M is the month designator that follows the value for the number of months.
'    W is the week designator that follows the value for the number of weeks.
'    D is the day designator that follows the value for the number of days.
'    T is the time designator that precedes the time components of the representation.
'    H is the hour designator that follows the value for the number of hours.
'    M is the minute designator that follows the value for the number of minutes.
'    S is the second designator that follows the value for the number of seconds.
'
'For example, "P3Y6M4DT12H30M5S" represents a duration of "three years, six months, four days, twelve hours, thirty minutes, and five seconds".
'Date and time elements including their designator may be omitted if their value is zero, and lower order elements may also be omitted for reduced precision.
'For example, "P23DT23H" and "P4Y" are both acceptable duration representations.
'To resolve ambiguity, "P1M" is a one-month duration and "PT1M" is a one-minute duration (note the time designator, T, that precedes the time value).
'The smallest value used may also have a decimal fraction, as in "P0.5Y" to indicate half a year. This decimal fraction may be specified with either a comma or a full stop,
'as in "P0,5Y" or "P0.5Y". The standard does not prohibit date and time values in a duration representation from exceeding their "carry over points" except as noted below.
'Thus, "PT36H" could be used as well as "P1DT12H" for representing the same duration.
'Alternatively, a format for duration based on combined date and time representations may be used by agreement between the communicating parties either in the
'basic format PYYYYMMDDThhmmss or in the extended format P[YYYY]-[MM]-[DD]T[hh]:[mm]:[ss]. For example, the first duration shown above would be "P0003-06-04T12:30:05".
'However, individual date and time values cannot exceed their moduli (e.g. a value of 13 for the month or 25 for the hour would not be permissible).[16]
'
'Ich habe das ganze noch zustzlich um die Nanosecond erweitert. F
'
 
#If IFormattable_exists Then
    Implements IFormattable
#End If
 
'-------------------------------------------------------------------------------
' -- Private Members
'-------------------------------------------------------------------------------
 
'/**
' * Die verschiedenen Teile
' */
'Die Einzelnen Teile des Intervals. Alle zusammengezhlt ergibt den Gesammtinterval
Private pYear As Integer
Private pMonth As Integer
Private pDay As Integer
Private pHour As Integer
Private pMinute As Integer
Private pSecond As Integer
Private pNanoSecond As Long
Private pWeekDays As Long
Private pWeeks As Long
 
'Den Summen auf verschiedenen Basis. Wird nur bei DateDiff abgefllt
'Print DateInterval.instanceFromDateDiff(#8/8/2014#, #8/10/2014#).seconds -> 172800 Sekunden
Private pYears As Variant
Private pMonths As Variant
Private pDays As Variant
Private pHours As Variant
Private pMinutes As Variant
Private pSeconds As Variant
Private pSign As Integer
 
'-------------------------------------------------------------------------------
' -- Public Methodes
'-------------------------------------------------------------------------------
 
'/**
' * Erstellt eine neue Instance
' * @param  String/Integer  Eine IntervalSpec oder Anzahl Tage
' * @return DateInterval
' */
Public Function instance(Optional ByVal iIntervalSpec As Variant = Empty) As DateInterval
Attribute instance.VB_UserMemId = 0
'Attribute instance.VB_UserMemId = 0
 
    Set instance = New DateInterval: instance.construct iIntervalSpec
End Function
 
' /**
' * Initialisiert die Klasse
' * @param  String/Integer  Eine IntervalSpec oder Anzahl Tage
' * @return DateInterval
' */
Public Function construct(ByVal iIntervalSpec As Variant) As DateInterval
    Dim sm As Object
    clear
    If TypeName(iIntervalSpec) = "DateInterval" Then iIntervalSpec = iIntervalSpec.intervalSPec
 
    If rxIntervalSpec1.test(iIntervalSpec) Then
        'P[n]Y[n]M[n]W[n]DT[n]H[n]M[n]S[n]F
        Set sm = rxIntervalSpec1.execute(iIntervalSpec)(0).subMatches
        sign = IIf(sm(0) = Empty, 1, -1)
        pYear = sm(1)
        pMonth = sm(2)
        'Weeks werden in Days gewandelt
        pDay = sm(3) * 7 + sm(4)
        pHour = sm(5)
        pMinute = sm(6)
        pSecond = sm(7)
        pNanoSecond = sm(8)
    ElseIf rxIntervalSpec23.test(iIntervalSpec) Then
        'PYYYYMMDDThhmmss
        'P[YYYY]-[MM]-[DD]T[hh]:[mm]:[ss]
        Set sm = rxIntervalSpec23.execute(iIntervalSpec)(0).subMatches
        sign = IIf(sm(0) = Empty, 1, -1)
        pYear = sm(1)
        'sm(2) ist das Datumstrennzeichen
        pMonth = sm(3)
        pDay = sm(4)
        pHour = sm(5)
        's(6) ist das Zeittrennzeichen
        pMinute = sm(7)
        pSecond = sm(8)
        'sm(9) ist das Nanosekundentrennzeichen
        pNanoSecond = sm(10)
    ElseIf IsNumeric(iIntervalSpec) Then
        pDay = iIntervalSpec
    End If
 
    Set sm = Nothing
    Set construct = Me
End Function
 
'/**
' * Gibt die Differenz als DateInterval zu einem Datum zurck
' * @param  Date/String/DateTime
' * @param  Boolean
' * @return DateInterval
' */
Public Function instanceFromDateDiff( _
        Optional ByRef iDate1 As Variant = Null, _
        Optional ByRef iDate2 As Variant = Null, _
        Optional ByVal iAbsolute As Boolean = False _
) As DateInterval
    clear
    Set instanceFromDateDiff = New DateInterval
 
    Dim ns1 As Long, ns2 As Long        'NanoSecounds
    'Beine Eingabewerte zum Typ Date wandeln
    Dim dt1 As Date:        dt1 = getDate(iDate1, ns1)
    Dim dt2 As Date:        dt2 = getDate(iDate2, ns2)
    'Datum als Zahl inkl Nanosekunden
    'Normal: cdec(date) = [Tage].[Sekunden]
    'HIer umgerechnet zu [Tage][Sekunden].[Nanosekunden]
    Dim v1 As Variant:      v1 = CDec(dt1) * 10 ^ 10 + ns1 / 10 ^ 9
    Dim v2 As Variant:      v2 = CDec(dt2) * 10 ^ 10 + ns2 / 10 ^ 9
    'Den Kleineren als from, den Grsseren als To definieren
    Dim fromV As Variant:   fromV = least(v1, v2)
    Dim toV As Variant:     toV = greatest(v1, v2)
    'Davon je die Nanosekunden extrahieren
    Dim fromNs As Long:     fromNs = (fromV - Fix(fromV)) * 10 ^ 9
    Dim toNs As Long:       toNs = (toV - Fix(toV)) * 10 ^ 9
    'Dito mit dem Datum
    Dim fromD As Date:      fromD = CDate(Fix(fromV) / 10 ^ 10)
    Dim toD As Date:        toD = CDate(Fix(toV) / 10 ^ 10)
    'Differnez der Nanosekunden
    Dim diffNs As Long:     diffNs = toNs - fromNs
    'Jenchdem eine Sekundenkorrektur im toDate durchfhren
    If diffNs < 0 Then toD = DateAdd("S", -1, toD)
 
    With instanceFromDateDiff
        'Die Differnezen in Totals mt DateDiff von VBA
        .years = DateDiff("YYYY", fromD, toD)
        .months = DateDiff("M", fromD, toD)
        .days = DateDiff("D", fromD, toD)
        .hours = DateDiff("H", fromD, toD)
        .minutes = DateDiff("N", fromD, toD)
        .seconds = DateDiff("S", fromD, toD)
 
        'Das VOrzeichen bestimmen
        .sign = IIf(iAbsolute, 1, Sgn(v1 - v2))
        'Die Differenz auf Datumteile aufgeteilt. Vm Grssten zum kleinsten. fromD wird jeweils um die extrahierte Grsse reduziert
        .year = diffPart(fromD, toD, "yyyy")
        .month = diffPart(fromD, toD, "M")
        .day = diffPart(fromD, toD, "D")
        .hour = diffPart(fromD, toD, "H")
        .minute = diffPart(fromD, toD, "N")
        .second = diffPart(fromD, toD, "S")
        .nanoSecond = IIf(Sgn(diffNs) < 0, 10 ^ 9 + diffNs, diffNs)
    End With
End Function
 
'/**
' * Erstellt eine Instanz aus einem einzelnen Parts
' * @example    Set di = DateInterval.instancePart("M", 3)
' * @param  String  YYMDHNS (auch I)
' * @param  Long    Wert
' * @return DateInterval
' */
Public Function instancePart(ByVal iShort As String, ByVal iValue As Long) As DateInterval
    clear
    Dim intSpec As String
    Select Case UCase(iShort)
        Case "YY", "YYYY":      intSpec = "P" & iValue & "Y"
        Case "M", "MM":         intSpec = "P" & iValue & "M"
        Case "D", "DD":         intSpec = "P" & iValue & "D"
        Case "H", "HH":         intSpec = "T" & iValue & "H"
        Case "N", "NN":         intSpec = "T" & iValue & "M"
        Case "S", "SS":         intSpec = "T" & iValue & "S"
'        Case "F", "FF":         intSpec = "P" & iValue & "Y"
    End Select
    Set instancePart = DateInterval.instance(intSpec)
End Function
 
'/**
' * Erstellt ein DateInterval aus Einzelwerten. Analog zu DateSerial und TimeSerial
' * @param  Variant         Jahre
' * @param  Integer         Monate
' * @param  Integer         Tage
' * @param  Integer         Stunden
' * @param  Integer         Minuten
' * @param  Integer         Sekunden
' * @param  Variant         Nanosekunden
' * @param  Boolean         true: Das DateTimeObjekt wird selber nicht verndert - False: Das Objekt selber wird verndert
' * @return DateInterval
' */
Public Function serial( _
        Optional ByVal iYear As Variant = 0, _
        Optional ByVal iMonth As Integer = 0, _
        Optional ByVal iDay As Integer = 0, _
        Optional ByVal iHour As Integer = 0, _
        Optional ByVal iMinute As Integer = 0, _
        Optional ByVal iSecond As Integer = 0, _
        Optional ByVal iNanoSecond As Variant = 0, _
        Optional ByVal iByRef As Boolean = False _
) As DateInterval
    Dim di As New DateInterval
    If Not iByRef Then Set di = Me
    clear
    With di
        .year = NZ(iYear)
        .month = iMonth
        .day = iDay
        .hour = iHour
        .minute = iMinute
        .second = iSecond
        .nanoSecond = iNanoSecond
    End With
 
    Set serial = di
End Function
'/**
' * Formatiert den Interval. Bisher sind nur die folgenden Formate implementiert
' * m       Monat ohne fhrende Null (1-12)
' * mm      Monat mit fhrende Null (01-12)
' * mx      Total Anzahl Monate ohne fhrende Null
' * mmx     Total Anzahl Monate mit fhrende Null
' * d       Tag des Monats ohne fhrende Null (1-31)
' * dd      Tag des Monats mit fhrende Null (01-31)
' * dx      Total Anzahl Tage ohne fhrende Null
' * ddx     Total Anzahl Tage mit fhrende Null
' * y       Einstelliges Jahr. Analog zu d wird es glsser geschrieben, wenn es mehr Zeichen hat
' * yy      Zweistelliges Jahr
' * yyyy    Vierstelliges Jahr
' * h       Stunden ohne fhrende Null(0-24)
' * hh      Stunden mit fhrende Null(00-24)
' * hx      Total Anzahl Stunden ohne fhrende Null
' * hhx     Total Anzahl Stunden mit fhrende Null
' * n       Minuten ohne fhrende Null(0-59)
' * nn      Minuten mit fhrende Null(00-59)
' * nx      Total Anzahl Minuten ohne fhrende Null
' * nnx     Total Anzahl Minuten mit fhrende Null
' * s       Sekunden ohne fhrende Null(0-59)
' * ss      Sekunden mit fhrende Null(00-59)
' * sx      Total Anzahl Sekunden ohne fhrende Null
' * ssx     Total Anzahl Sekunden mit fhrende Null
' * r       Bei Muinus ein -
' * R       Bei Minus ein -, bei Plus ein +
' *
' * Mit \ kann ein Format maskiert werden. damit es nicht geparst wird: m wird als Monat ausgegeben. \m wird zu "m"
' *
' * @example
' */
Public Function format(ByVal iFormat As String) As String
    Dim tmp As String: tmp = StrReverse(iFormat)    'String umdrehen, Da RegExp Lookbehind (?!>..) nicht kennt...
    tmp = formatByRx(tmp, rxFormatParts)
    format = rxMasked.Replace(StrReverse(tmp), "$1")
End Function
 
'/**
' * Fast analog zu Format. Die Patterns mssen aber so definiert werden
' * {$pattern}
' * @example:   "Es geht noch {$d} Tage und {$mx} Monate bis zum Fest"
' */
Public Function format2(ByVal iFormat As String) As String
    Dim tmp As String: tmp = StrReverse(iFormat)    'String umdrehen, Da RegExp Lookbehind (?!>..) nicht kennt...
    tmp = formatByRx(tmp, rxFormatParts2)
    format2 = StrReverse(tmp)
End Function
 
'/**
' * Klont das Objekt
' * @return DateTime
' */
Public Function clone() As DateInterval
    Set clone = DateInterval(Me.intervalSPec)
End Function
 
'/**
' * Erstellt ein Array mit einem Interval. Als erstes Datum wird der aktuelle DateTime verwendet
' * @param  DateInterval/IntervalSpec/Days
' * @param  Long/DateTime/Timestamp         Anzahl Eintrge oder ein Endzeitpunkt
' * @param  dtReturnTypes                   Rckgabeformat: timestamp oder DateTime
' * @return Array<timestamp/DateTime>
' */
Public Function interval(ByRef iStart As Variant, ByRef iSizeOrEnd As Variant, Optional ByVal iReturnType As dtReturnTypes = dtTimestamp) As Variant()
    interval = DateTime(iStart).interval(Me, iSizeOrEnd, iReturnType)
End Function
 
 
'/**
' * Ersetzt einen einzelnen Teil des Datums und gibt ein DateTime zurck
' * @param  String      Interval-String gem. DateAdd().  YYYY, M, D, H, N, S, F, Y, WW, W
' * @param  Long     Neuer Wert
' * @param  Boolean     true: Das DateTimeObjekt wird selber nicht verndert - False: Das Objekt selber wird verndert
' * @return DateTime
' */
Public Function modify( _
    ByVal iInterval As String, _
    ByVal iNumber As Long, _
    Optional ByVal iByRef As Boolean = False _
) As DateInterval
    With Me.clone
        Select Case UCase(iInterval)
            Case "Y", "YY", "YYYY": .year = iNumber
            Case "M", "MM":         .month = iNumber
            Case "D", "DD":         .day = iNumber
            Case "H", "HH":         .hour = iNumber
            Case "N", "NN":         .minute = iNumber
            Case "S", "SS":         .second = iNumber
            Case "F", "FF":         .nanoSecond = iNumber
        End Select
            Set modify = retDI(.intervalSPec, iByRef)
    End With
End Function
 
'/**
' * Wendet den Interval auf ein DateTime an
' * @param  Date/String/DateTime
' * @param  Boolean                             true: Das DateTimeObjekt wird selber nicht verndert - False: Das Objekt selber wird verndert
' * @return DateTime
' */
Public Function addTo(Optional ByRef iTimestamp As Variant = Null, Optional ByVal iByRef As Boolean = False) As DateTime
    Dim dt As DateTime: Set dt = DateTime(iTimestamp)
    Set addTo = dt.add(Me, iByRef)
End Function
 
'/**
' * Gibt ein Wert nach den blichen Formatierungsbuchstaben zurck
' * @param  String  YMDHNS (auch F)
' * @retrun Integer
' */
Public Function getPartByShort(ByVal iShort As String, Optional ByVal iFormated As Boolean = False) As Variant
    Dim frmt As String
    If Right(UCase(iShort), 1) = "X" Then
        Select Case Right(UCase(iShort), 2)
            Case "MX":              getPartByShort = pMonths:       frmt = String(Len(iShort) - 1, "0")
            Case "DX":              getPartByShort = pDays:         frmt = String(Len(iShort) - 1, "0")
            Case "HX":              getPartByShort = pHours:        frmt = String(Len(iShort) - 1, "0")
            Case "NX":              getPartByShort = pMinutes:      frmt = String(Len(iShort) - 1, "0")
            Case "SX":              getPartByShort = pSeconds:      frmt = String(Len(iShort) - 1, "0")
        End Select
    Else
        Select Case UCase(iShort)
            Case "Y", "YY", "YYYY": getPartByShort = pYear:         frmt = String(Len(iShort), "0")
            Case "M", "MM":         getPartByShort = pMonth:        frmt = String(Len(iShort), "0")
            Case "D", "DD":         getPartByShort = pDay:          frmt = String(Len(iShort), "0")
            Case "H", "HH":         getPartByShort = pHour:         frmt = String(Len(iShort), "0")
            Case "N", "NN":         getPartByShort = pMinute:       frmt = String(Len(iShort), "0")
            Case "S", "SS":         getPartByShort = pSecond:       frmt = String(Len(iShort), "0")
            Case "F", "FF":         getPartByShort = pNanoSecond:   frmt = String(Len(iShort), "0")
        End Select
    End If
    If iFormated Then getPartByShort = Strings.format(getPartByShort, frmt)
End Function
 
'/**
' * Eine Einfache Prfung, ob ein Interval String dem Format entspricht
' * @param  String      Interval String
' * @return Boolean
' */
Public Function testIntervalString(ByVal iIntervalSpec As String) As Boolean
    testIntervalString = rxIntervalSpec1.test(iIntervalSpec)
    If Not testIntervalString Then testIntervalString = rxIntervalSpec23.test(iIntervalSpec)
End Function
 
'-------------------------------------------------------------------------------
' -- Public Properties
'-------------------------------------------------------------------------------
'Year
Public Property Get year() As Integer:                  year = pYear:       End Property
Public Property Let year(ByVal iYear As Integer):       pYear = iYear:      End Property
'Month
Public Property Get month() As Integer:                 month = pMonth:     End Property
Public Property Let month(ByVal iMonth As Integer):     pMonth = iMonth:    End Property
'Day
Public Property Get day() As Integer:                   day = pDay:         End Property
Public Property Let day(ByVal iDay As Integer):         pDay = iDay:        End Property
'Hour
Public Property Get hour() As Integer:                  hour = pHour:       End Property
Public Property Let hour(ByVal iHour As Integer):       pHour = iHour:      End Property
'Minute
Public Property Get minute() As Integer:                minute = pMinute:   End Property
Public Property Let minute(ByVal iMinute As Integer):   pMinute = iMinute:  End Property
'Second
Public Property Get second() As Integer:                second = pSecond:   End Property
Public Property Let second(ByVal iSecond As Integer):   pSecond = iSecond:  End Property
 
Public Property Get nanoSecond() As Long:               nanoSecond = pNanoSecond:                       End Property
Public Property Let nanoSecond(ByVal iNS As Long):      pNanoSecond = iNS:                              End Property
 
Public Property Get microSecond() As Long:              microSecond = CLng(pNanoSecond / 10 ^ 3):       End Property
Public Property Let microSecond(ByVal iMS As Long):     pNanoSecond = iMS * 10 ^ 3:                     End Property
 
Public Property Get milliSecond() As Long:              milliSecond = CLng(pNanoSecond / 10 ^ 6):       End Property
Public Property Let milliSecond(ByVal iMS As Long):     pNanoSecond = iMS * 10 ^ 6:                     End Property
 
'Sign
Public Property Get sign() As Integer:                  sign = pSign:       End Property
Public Property Let sign(ByVal iSign As Integer):       pSign = iSign:      End Property
 
'Die folgenden Properties werden nur bei Diff abgellt. Ansonsten sind sie EMPTY
'Sie Representatieren die Totaldifferez in der jeweiligen Einheit inkl. Vorzeichen
'Im Grunde also das Resultat von VBA.DateDiff() auf die jeweilige Einheit
'Years
Public Property Get years() As Variant:                 years = pYears * pSign:     End Property
Public Property Let years(ByVal iYears As Variant):     pYears = iYears:            End Property
'Months
Public Property Get months() As Variant:                months = pMonths * pSign:   End Property
Public Property Let months(ByVal iMonths As Variant):   pMonths = iMonths:          End Property
'Days
Public Property Get days() As Variant:                  days = pDays * pSign:       End Property
Public Property Let days(ByVal iDays As Variant):       pDays = iDays:              End Property
'Hours
Public Property Get hours() As Variant:                 hours = pHours * pSign:     End Property
Public Property Let hours(ByVal iHours As Variant):     pHours = iHours:            End Property
'Minutes
Public Property Get minutes() As Variant:               minutes = pMinutes * pSign: End Property
Public Property Let minutes(ByVal iMinutes As Variant): pMinutes = iMinutes:        End Property
'Seconds
Public Property Get seconds() As Variant:               seconds = pSeconds * pSign: End Property
Public Property Let seconds(ByVal iSeconds As Variant): pSeconds = iSeconds:        End Property
 
'/**
' * Gibt den Interval als IntervalSpec zurck: P[n]Y[n]M[n]DT[n]H[n]M[n]S
' * http://en.wikipedia.org/wiki/ISO_8601#Durations
' * Das Vorzeichen wird ignoriert
' * @return String
' */
Public Property Get intervalSPec() As String
    intervalSPec = "P"
    If pYear > 0 Then intervalSPec = intervalSPec & pYear & "Y"
    If pMonth > 0 Then intervalSPec = intervalSPec & pMonth & "M"
    If pDay > 0 Then intervalSPec = intervalSPec & pDay & "D"
 
    If pHour + pMinute + pSecond > 0 Then intervalSPec = intervalSPec & "T"
    If pHour > 0 Then intervalSPec = intervalSPec & pHour & "H"
    If pMinute > 0 Then intervalSPec = intervalSPec & pMinute & "M"
    If pSecond > 0 Then intervalSPec = intervalSPec & pSecond & "S"
    If pNanoSecond > 0 Then intervalSPec = intervalSPec & Mid(pNanoSecond / 10 ^ 9, 3) & "F"
 
'    If Not iAbsolute And pSign = -1 Then intervalSPec = "-" & intervalSPec
End Property
Public Property Let intervalSPec(ByVal iIntervalSpec As String)
    retDI iIntervalSpec, True
End Property
 
' /**
' * IntervalSpecin der Schreibweise: P[YYYY][MM][DD]T[hh][mm][ss]
' * Das Vorzeichen wird ignoriert
' * @return String
' */
Public Property Get intervalSPec2() As String
    intervalSPec2 = format("PYYYYMMDDTHHNNSS")
End Property
Public Property Let intervalSPec2(ByVal iIntervalSpec As String)
    retDI iIntervalSpec, True
End Property
 
' /**
' * IntervalSpecin der Schreibweise: und P[yyyy]-[mm]-[dd]T[hh]:[mm]:[ss]
' * Das Vorzeichen wird ignoriert
' * @return String
' */
Public Property Get intervalSPec3() As String
    intervalSPec3 = format("PYYYY-MM-DDTHH:NN:SS")
    If pNanoSecond <> 0 Then intervalSPec3 = intervalSPec3 & "." & Mid(pNanoSecond / 10 ^ 9, 3)
End Property
Public Property Let intervalSPec3(ByVal iIntervalSpec As String)
    retDI iIntervalSpec, True
End Property
 
'/**
' * Gibt ein String-Wert eines Objektes zurck
' * @return String
' */
Public Property Get toString() As String
    toString = intervalSPec
End Property
 
#If IFormattable_exists Then
    '/**
    ' * Gibt das Objekt als IFormattable zurck
    ' * @return IFormattable
    ' */
    Public Property Get IFormattableObject() As IFormattable
        Set IFormattableObject = Me
    End Property
 
    '-------------------------------------------------------------------------------
    ' -- Interface methodes/properties
    '-------------------------------------------------------------------------------
    '/**
    ' * Gibt ein String-Wert eines Objektes zurck
    ' * @return String
    ' */
    Private Property Get IFormattable_object() As Object
        Set IFormattable_object = Me
    End Property
 
 
    '/**
    ' * Gibt das Originalobjekt  zurck
    ' * @object
    ' */
    Private Property Get IFormattable_toString() As String
        IFormattable_toString = toString
    End Property
#End If
 
'-------------------------------------------------------------------------------
' -- Private Methodes
'-------------------------------------------------------------------------------
'/**
' * Wandelt Pattern in Werte um. Je nach RegExp
' * @param  String
' * @param  RegExp
' * @return String
' */
Private Function formatByRx(ByRef iFormatReverse As String, ByRef iRx As Object) As String
    formatByRx = iFormatReverse
    Do While iRx.test(formatByRx)
        Dim m As Object: Set m = iRx.execute(formatByRx)(0)
        If m.subMatches(0) = "r" Then
            formatByRx = repl(formatByRx, m, pSign, ";-;")
        ElseIf m.subMatches(0) = "R" Then
            formatByRx = repl(formatByRx, m, pSign, "+;-;")
        Else
            formatByRx = repl(formatByRx, m, getPartByShort(StrReverse(m.subMatches(0)), True))
        End If
    Loop
End Function
 
'/**
' * Setzt alle Werte zurck
' */
Private Sub clear()
    pYear = 0
    pMonth = 0
    pDay = 0
    pHour = 0
    pMinute = 0
    pSecond = 0
    pNanoSecond = 0
    pWeekDays = 0
    pWeeks = 0
    pYears = 0
    pMonths = 0
    pDays = 0
    pHours = 0
    pMinutes = 0
    pSeconds = 0
    pSign = 1
End Sub
 
'/**
' * Handelt den Return. Ob das aktuelle Objekt angepasst wird oder nicht
' * @param  IntervalSpec
' * @param  Boolean     true: Das DateTimeObjekt wird selber nicht verndert - False: Das Objekt selber wird verndert
' * @return DateInterval
' */
Private Function retDI(ByVal iInterval As Variant, ByVal iByRef As Boolean) As DateInterval
    If TypeName(iInterval) = "DateInterval" Then
        Set retDI = IIf(iByRef, iInterval, iInterval.clone)
    ElseIf Not IsObject(iInterval) Then
        Set retDI = DateInterval(iInterval)
    End If
End Function
 
'/**
' * Hilfsfunktion fr format()
' */
Private Function repl(ByVal iTmp As String, ByRef iM As Object, ByVal iNumber As Variant, Optional ByVal iFormat As String = Empty) As String
    repl = Left(iTmp, iM.firstIndex) & StrReverse(iNumber) & Mid(iTmp, iM.firstIndex + iM.length + 1)
End Function
 
'/**
' * Berechnet eine Teildifferent und reduziert ioFromD um diese Grsse
' * @param  Date
' * @param  Date
' * @param  Interval
' * @return Integer
' */
Private Function diffPart(ByRef ioFromD As Date, ByVal iToD As Date, ByVal iInterval As String) As Integer
    diffPart = DateDiff(iInterval, ioFromD, iToD)
    If round(DateAdd(iInterval, diffPart, ioFromD), 10) > round(iToD, 10) Then diffPart = diffPart - 1
    ioFromD = DateAdd(iInterval, diffPart, ioFromD)
End Function
 
'/**
' * Versucht aus einer Eingabe ein Datum zu erstellen
' * @param  Date/DateTime/String
' * @return Date
' */
Private Function getDate(ByRef iDate As Variant, Optional ByRef ioNanoSecond As Long = 0) As Date
    Select Case TypeName(iDate)
        Case "DateTime":    getDate = iDate.timestamp:                      ioNanoSecond = iDate.nanoSecond
        Case "Date":        getDate = iDate:                                ioNanoSecond = 0
        Case "String":      getDate = dateValue(iDate) + timeValue(iDate):  ioNanoSecond = 0
        Case "Null":        getDate = Now:                                  ioNanoSecond = 0   '//TODO
        Case Else:          Err.Raise 13, "DateInterval.getDate"          '13  Type mismatch
    End Select
End Function
 
'-------------------------------------------------------------------------------
' -- Private Properties
'-------------------------------------------------------------------------------
 
'/**
' * RegExp um ein intervalSpec zu zerlegen
' * P[n]Y[n]M[n]W[n]DT[n]H[n]M[n]F[n]S
' */
Private Property Get rxIntervalSpec1() As Object
    Static pRx As Object
    If pRx Is Nothing Then Set pRx = cRx("/^(-?)(?:P(?:(\d+)Y)?(?:(\d+)M)?(?:(\d+)W)?(?:(\d+)D)?)?(?:T(?:(\d+)H)?(?:(\d+)M)?(?:(\d+)S)?(?:(\d+)F)?)?$/i")
    Set rxIntervalSpec1 = pRx
End Property
 
 
'/**
' * RegExp um ein intervalSpec2 oder 3 zu zerlegen
' * IntervalSpec2: P[yyyy][mm][dd]T[hh][mm][ss]
' * IntervalSpec3: P[yyyy]-[mm]-[dd]T[hh]:[mm]:[ss].[fff]
' */
Private Property Get rxIntervalSpec23() As Object
    Static pRx As Object
    If pRx Is Nothing Then Set pRx = cRx("/^(-?)P(\d{4})(-?)(\d{2})\3(\d{2})T(\d{2})(:?)(\d{2})\7(\d{2})(\.?)(\d{1,3})$/i")
    Set rxIntervalSpec23 = pRx
End Property
 
'/**
' * regExp um die Part-Strings zu erkennen
' */
Private Property Get rxFormatParts() As Object
    Static pRx As Object
    If pRx Is Nothing Then Set pRx = cRx("/(r|yyyy|yy|y|xm+|mm|m|xd+|dd|d|xh+|xh|hh|h|xn+|xn|nn|n|xs+|xs|ss|s|f{1,9})(?!\\)/ig")
    Set rxFormatParts = pRx
End Property
 
'/**
' * regExp um die Part-Strings zu erkennen
' */
Private Property Get rxFormatParts2() As Object
    Static pRx As Object
    If pRx Is Nothing Then Set pRx = cRx("/\}" & rxFormatParts.pattern & "\$\{/ig")
    Set rxFormatParts2 = pRx
End Property
 
'/**
' * Erkennt Maskierte Patterns
' */
Private Property Get rxMasked() As Object
    Static pRx As Object
    If pRx Is Nothing Then Set pRx = cRx("/\\([rymdhns])/gi")
    Set rxMasked = pRx
End Property
'-------------------------------------------------------------------------------
' -- Private Events
'-------------------------------------------------------------------------------
Private Sub Class_Initialize()
    pSign = 1
End Sub
 
'-------------------------------------------------------------------------------
' -- Private Libraries
'-------------------------------------------------------------------------------
 
'/**
' * Dies ist die Minimalversion von cRegExp
' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/cregexp#abgespeckte_version
' * mgliche Delemiter: @&!/~#=\|
' * mgliche Modifiers: g (Global), i (IgnoreCode, m (Mulitline)
' *
' * @example    myRx = cRx("/([a]{2,})/i") 'Finde alle folgen von a. Flag:IgnoreCase
' * @version    2.1.0 (01.12.2014)
' * @param      String      Pattern mit Delimiter und Modifier analog zu PHP
' * @return     Object      RegExp-Object
' */
Private Function cRx(ByVal iPattern As String) As Object
    Static rxP As Object:       Set cRx = CreateObject("VBScript.RegExp")
    If rxP Is Nothing Then:     Set rxP = CreateObject("VBScript.RegExp"): rxP.pattern = "^([@&!/~#=\|])?(.*)\1(?:([Ii])|([Gg])|([Mm]))*$"
    Dim sm As Object:           Set sm = rxP.execute(iPattern)(0).subMatches
    cRx.pattern = sm(1):        cRx.IgnoreCase = Not isEmpty(sm(2)):       cRx.Global = Not isEmpty(sm(3)):     cRx.Multiline = Not isEmpty(sm(4))
End Function
 
'/**
' * Copyright mpl by ERB software | http://wiki.yaslaw.info
' *
' * Gibt den Grssten aus einer unbestimmten Menge von Werten zurck
' * @param  Keine Objekte
' * @return Grsster Wert
' * @example greatest("Hallo Welt", 42, "Mister-X") -> Mister-X
'*/
Private Function greatest(ParamArray itemS() As Variant) As Variant
    Dim item As Variant
    For Each item In itemS
        If item > greatest Then greatest = item
    Next item
End Function
 
'/**
' * Gibt den Kleinsten aus einer unbestimmten Menge von Werten zurck
' * @param  Keine Objekte
' * @return Grsster Wert
' * @example least("Hallo Welt", 42, "Mister-X") -> 42
'*/
Private Function least(ParamArray itemS() As Variant) As Variant
    least = itemS(LBound(itemS))
    Dim item As Variant: For Each item In itemS
        If NZ(item) < NZ(least) Then least = item
    Next item
End Function
 
'/**
' * Gibt den String iString zurck. Dieser wurde nach links mit dem String iPadString auf eine Lnge von iLen Zeichen aufgefllt.
' * Wenn iString lnger als iLen ist, wird der Rckgabewert auf iLen Zeichen gekrzt.
' * @param  String
' * @param  Integer     Neue Lnge
' * @param  String      Zeichen mit dem verlngert wird
' * @return Erweiterter oder gekrzter String
' */
Private Function lPad( _
        ByVal iString As String, _
        ByVal iLen As Integer, _
        Optional ByVal iPadString As String = " " _
) As String
    lPad = Left(iString, iLen)
    lPad = lPad & String(iLen - Len(lPad), iPadString)
End Function
 
#If Not isAccess Then
    '/**
    ' * Wandelt NULL in EMpty oder einen Defaultwert
    ' * @param  Variant
    ' * @param  Variant
    ' * @return Variant
    ' */
    Private Function NZ(ByRef iValue As Variant, Optional ByRef iDefault As Variant = Empty) As Variant
        If IsNull(iValue) Then
            NZ = iDefault
        Else
            NZ = iValue
        End If
    End Function
#End If
 
 
vba/classes/date/dateinterval/index.txt · Last modified: 28.06.2016 11:46:59 by yaslaw