VBA中的夏令时计算

Question

这是我第一次在 Stackoverflow 上发帖。我试图找到我的问题的答案，虽然这个问题似乎已经针对其他语言得到解决，但我没有看到任何 VBA 特定的解决方案，所以我认为我在这里发布。如果我的尽职调查不够，我深表歉意，我感谢任何帮助。

基本上，我想知道在用户表单上输入的给定日期是否在夏令时生效。我希望代码评估 dst 是否有效，如果有效，则在第二个文本框中填充一条消息，显示“夏令时”或其他内容

这是我想出的代码

Private Sub dtefrm_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)

Dim dte
Dim dstdte As Boolean


Let dte = CDate(Me.dtefrm.Value)


Select Case dte
    Case dte > CDate("3/9/2008") And dte < CDate("11/2/2008")
        dstdte = True
        Me.dayconf.Value = "Daylight Savings"

    End Select


End Sub

在此代码中，dtefrm 是用户表单上用户输入日期的文本框的名称，而 dayconf 是如果输入的日期是 DST 日期，我想在其上显示消息的文本框。

感谢您提供的任何帮助。

Answer 1

我推荐一种无需管理的更持久的解决方案。因此，如果 DST 规则发生变化，您应该被覆盖。

第 1 步 - 创建一个 VB.NET DLL，它将为您调用 IsDaylightSavingsTime。它足够聪明，可以处理您的代码不会考虑的大量信息。

代码应该是这样的。

将 DLL DateTimeDstChecker 命名为 DateTimeDstChecker.dll

<Serializable(), ClassInterface(ClassInterfaceType.AutoDual), ComVisible(True)>
Public Class DateTimeDstChecker

    Public Function IsDst(ByVal checkDate As DateTime) As Boolean
        Return TimeZoneInfo.Local.IsDaylightSavingTime(thisTime)
    End Function
End Class

第 2 步 - 添加引用

Once you compile your assembly, you should be able to include a reference to it within VBA by going to "Tools > References" and find DateTimeDstChecker

第 3 步 - 编写 VBA 代码

' Define the Variable
Dim checker As DateTimeDstChecker

' Instantiate the Var
Set checker = New DateTimeDstChecker

' Get the Information
isDst = checker.IsDst(CDate(Me.dtefrm.Value))

Answer 2

    Function IsDST(DateCheck As Date, StartMonth As Integer, StartWeek As Integer, EndMonth As Integer, EndWeek As Integer, DOW_EN As String) As Boolean
    'DO NOT REMOVE
    'It takes nothing away from what you do
    'Gives me credit for creating an International Daylight Saving Time Routine
    '
    'Michel Sabourin (c)2018
    'mpsabourin@gmail.com
    '
    'Will be true if DST is active on specified date given the DST rules for your State/Country
    '
        Dim Param As Boolean, StartDateDST As Date, EndDateDST As Date
        Param = True
        If Not IsDate(DateCheck) Then Param = False
        If StartMonth < 1 Or StartMonth > 12 Then Param = False
        If StartWeek < 1 Or StartWeek > 5 Then Param = False
        If EndMonth < 1 Or EndMonth > 12 Then Param = False
        If EndWeek < 1 Or EndWeek > 5 Then Param = False
        DOW_EN = UCase(DOW_EN)
        If DOW_EN <> "SATURDAY" And DOW_EN <> "SUNDAY" Then Param = False
        If Not Param Then
            MsgBox "IsDST(DateCheck As Date, StartMonth As Integer, StartWeek As Integer, EndMonth As Integer, EndWeek As Integer, DOW_EN As String) As Boolean" _
            & Chr(10) & "DateCheck = Today's date or Date being checked" _
            & Chr(10) & "StartMonth & EndMonth = Whole number (1 - 12) start of DST and end of DST" _
            & Chr(10) & "StartWeek & EndWeek = Whole number (1 - 5) = 1st, 2nd, 3rd, 4th or 5= LAST" _
            & Chr(10) & "Changeover Day of Week = ""Saturday"" or ""Sunday""" _
            , vbOKOnly, "USAGE"
            IsDST = Null
        Else
            StartDateDST = NextDOW(DateSerial(Year(DateCheck), StartMonth, FirstPotentialDate(Year(DateCheck), StartMonth, StartWeek)), DOW_EN)
            EndDateDST = NextDOW(DateSerial(Year(DateCheck), EndMonth, FirstPotentialDate(Year(DateCheck), EndMonth, EndWeek)), DOW_EN)
            IsDST = DateCheck >= StartDateDST And DateCheck < EndDateDST
        End If
    End Function

    Function NextDOW(MyPotentialDate As Date, DOW_EN As String) As Date
    'DO NOT REMOVE
    'It takes nothing away from what you do
    'Gives me credit for creating an International Daylight Saving Time Routine
    '
    'Michel Sabourin (c)2018
    'mpsabourin@gmail.com
    '
        'Next Date from Potential start for that particular date
        Dim MyWeekDay As Integer
        DOW_EN = UCase(DOW_EN)
        If Not IsDate(MyPotentialDate) Then DOW_EN = ""
        Select Case DOW_EN
        Case "SUNDAY"
            NextDOW = MyPotentialDate + 7 - Weekday(MyPotentialDate, vbMonday)
        Case "SATURDAY"
            NextDOW = MyPotentialDate + 7 - Weekday(MyPotentialDate, vbSunday)
        Case Else
            MsgBox "NextDOW(MyDate As Date, DOW_EN As String) As Date" _
            & Chr(10) & "MyDate = First Potential Date" _
            & Chr(10) & """Saturday"" or ""Sunday""" _
            , vbOKOnly, "USAGE"
            NextDOW = Null
        End Select
    End Function

    Function FirstPotentialDate(MyYear As Integer, MyMonth As Integer, MyWeek As Integer) As Integer
    'DO NOT REMOVE
    'It takes nothing away from what you do
    'Gives me credit for creating an International Daylight Saving Time Routine
    '
    'Michel Sabourin (c)2018
    'mpsabourin@gmail.com
    '
        If MyWeek < 5 Then
            FirstPotentialDate = 1 + 7 * (MyWeek - 1)
        Else
            FirstPotentialDate = Day(DateSerial(MyYear, (MyMonth \ 12) + 1, 1) - 7)
        End If
    End Function