Function to Test a Date for BST (British Summer Time)

Category:

Dates and Math

Type:

Snippets

Difficulty:

Beginning

Author: Anonymous

Version Compatibility: Visual Basic 6, Visual Basic Script

More information:

This is a VBScript function that tests a date to determine whether it falls within BST (British Summer Time) or whether it is standard GMT. The function of interest is called "fb_dst( date )". The rest of the code was written to black box test the "fb_dst" function, and to also test some other functions that I need to use when handling "ctime" datetime numbers with Veritas/Symantec NetBackup.

Instructions: Copy the declarations and code below and paste directly into your VB project.

Declarations:
' (None)

Code:

Option Explicit

Const ci_for_reading		= 1
Const ci_for_writing		= 2

Const ci_temporary_folder	= 2

Const cs_script_version		= "v0.01"

Dim go_fso, go_wsh, go_net
Dim gs_script_spec, gs_script_path, gs_script_name, gs_script_title
Dim gs_temp_file, gs_temp_path, gs_temp_spec

Call s_init()
Call s_main1()
Call s_main2()

WScript.Quit

Sub s_init()
  Const cs_fac = "%s_init, "

Set go_fso = CreateObject( "Scripting.FileSystemObject"	)
  Set go_wsh = CreateObject( "WScript.Shell"			)
  Set go_net = CreateObject( "WScript.Network"			)

gs_script_spec  = Wscript.ScriptFullName
  gs_script_path  = go_fso.GetParentFolderName( gs_script_spec )
  gs_script_name  = go_fso.GetBaseName(         gs_script_spec )
  gs_script_title = gs_script_name & " (" & cs_script_version & ")"

gs_temp_file = go_fso.GetTempName
  gs_temp_path = go_fso.GetSpecialFolder( ci_temporary_folder )
  gs_temp_spec = gs_temp_path & "\" & gs_temp_file
End Sub

Sub s_main1()
  Const cs_fac = "%s_main1, "
  Dim ll_secs, ls_dt1, ls_dt2
  
  Call s_log( "" )
  Call s_log( cs_fac & "GMT to BST..." )
  For ll_secs = 922582740 To 922582740 + (121*60) Step (11*60)
    ls_dt1 = fs_ctime_to_dt( ll_secs )
    ls_dt2 = fs_secs_to_dt( ll_secs )
    Call s_log( "  ctime = `" & ll_secs & "`   bpdbm = `" & ls_dt1 & "`   fs = `" & ls_dt2 & "`" )
  Next

Call s_log( "" )
  Call s_log( cs_fac & "BST to GMT..." )
  For ll_secs = 941327940 To 941327940 + (121*60) Step (11*60)
    ls_dt1 = fs_ctime_to_dt( ll_secs )
    ls_dt2 = fs_secs_to_dt( ll_secs )
    Call s_log( "  ctime = `" & ll_secs & "`   bpdbm = `" & ls_dt1 & "`   fs = `" & ls_dt2 & "`" )
  Next
End Sub

Function fl_dt_to_secs( pd_dt )
  Const cs_fac = "%fl_dt_to_secs, "
  Dim ll_dt
  If Not IsDate( pd_dt ) Then Call s_abort( cs_fac & "Expected date as parameter..." )
  ll_dt = CLng( DateDiff( "s", "01/01/1970 00:00:00", pd_dt ) )
  If fb_bst( pd_dt ) Then ll_dt = ll_dt - 3600
  fl_dt_to_secs = ll_dt
End Function

Function fs_secs_to_dt( pl_seconds )
  Dim ld_dt, ls_dt
  ld_dt = DateAdd( "s", pl_seconds, "01/01/1970 00:00:00" )
  If fb_bst( ld_dt ) Then ld_dt = DateAdd( "h", 1, ld_dt )
  ls_dt = FormatDateTime( ld_dt, vbShortdate ) & " " & FormatDateTime( ld_dt, vbLongtime )
  fs_secs_to_dt = ls_dt
End Function

Function fs_secs_to_yyyymmdd( pl_seconds )
  Dim ld_dt, ls_dt
  If Not IsNumeric( pl_seconds ) Then Call s_abort( cs_fac & "Expected integer seconds as parameter..." )
  ld_dt = DateAdd( "s", pl_seconds, "01/01/1970 00:00:00" )
  ls_dt = fs_zeroes( Year( ld_dt ), 4 ) & fs_zeroes( Month( ld_dt ), 2 ) & fs_zeroes( Day( ld_dt ), 2 )
  fs_secs_to_yyyymmdd = ls_dt
End Function

Function fb_bst( pd_dt )
  Const cs_fac = "%fb_bst, "
  Dim ls_eom
  If Not IsDate( pd_dt ) Then Call s_abort( cs_fac & "Expected date as parameter..." )
  Select Case Month( pd_dt )
  Case 4, 5, 6, 7, 8, 9
    fb_bst = True
  Case 1, 2, 11, 12
    fb_bst = False
  Case 3
    fb_bst = False
    If Day( pd_dt ) < 25 Then Exit Function
    ls_eom = "31/03/" & Year( pd_dt )
    If WeekDay( pd_dt ) - WeekDay( ls_eom ) > 0 Then Exit Function
    If Hour( pd_dt ) < 1 Then Exit Function
    fb_bst = True
  Case 10
    fb_bst = True
    If Day( pd_dt ) < 25 Then Exit Function
    ls_eom = "31/10/" & Year( pd_dt )
    If WeekDay( pd_dt ) - WeekDay( ls_eom ) > 0 Then Exit Function
    If Hour( pd_dt ) < 1 Then Exit Function
    fb_bst = False
  Case Else
    Call s_abort( cs_fac & "Unexpected month in date..." )
  End Select
End Function

Sub s_main2()
  Const cs_fac = "%s_main2, "
  Dim ll_year, ls_date, ld_date, lb_done

For ll_year = 1999 To 2007
    Call s_log( String( 80, "*" ) )
    Call s_log( cs_fac & "Testing year `" & ll_year & "`..." )

ls_date = "24-MAR-" & CStr( ll_year )
    ld_date = CDate( ls_date )
    lb_done = False
    Do
      ld_date = DateAdd( "d", 1, ld_date )
      If WeekDayName( WeekDay( ld_date ), True ) = "Sun" Then
        If Month( ld_date ) <> Month( DateAdd( "d", 7, ld_date ) ) Then
          Call s_test2( ld_date )
          lb_done = True
        End If
      End If
    Loop Until lb_done

ls_date = "24-OCT-" & CStr( ll_year )
    ld_date = CDate( ls_date )
    lb_done = False
    Do
      ld_date = DateAdd( "d", 1, ld_date )
      If WeekDayName( WeekDay( ld_date ), True ) = "Sun" Then
        If Month( ld_date ) <> Month( DateAdd( "d", 7, ld_date ) ) Then
          Call s_test2( ld_date )
          lb_done = True
        End If
      End If
    Loop Until lb_done
  Next
End Sub

Sub s_test2( pd_date )
  Const cs_fac = "%s_test2, "
  Dim ll_mins, ld_dt
  Dim ls_dt1, ll_dt2, ls_dt3, ls_dt4

Call s_log( "" )

For ll_mins = 59 To 183 Step 31
    ld_dt = DateAdd( "n", ll_mins, pd_date )

ls_dt1 = FormatDateTime( ld_dt, vbShortdate ) & " " & FormatDateTime( ld_dt, vbLongtime )
    ll_dt2 = fl_dt_to_secs(  ls_dt1 )
    ls_dt3 = fs_ctime_to_dt( ll_dt2 )
    ls_dt4 = fs_secs_to_dt(  ll_dt2 )

Call s_log( cs_fac & "  input = `" & ls_dt1 & "`   fl_dt_to_secs = `" & ll_dt2 & "`   bpdbm = `" & ls_dt3 & "`   fs_secs_to_dt  = `" & ls_dt4 & "`" )
  Next

End Sub

Function fs_ctime_to_dt( pl_secs )
  Exit Function
  Const cs_fac = "%fs_ctime_to_dt, "
  Dim ls_output, ls_old, ls_parts, ls_dt, ld_dt
  ls_output = fs_run_command( "bpdbm -ctime " & CStr( pl_secs ) )
  Do
    ls_old = ls_output
    ls_output = Replace( ls_output, "  ", " " )
    ls_output = Replace( ls_output, vbTab, " " )
    ls_output = Replace( ls_output, vbCrlf, " " )
    ls_output = Trim( ls_output )
  Loop Until ls_output = ls_old
  ls_parts = Split( ls_output, " " )
  If UBound( ls_parts ) <> 6 Then Call s_abort( cs_fac & "Expected 7 fields from bpdbm..." )
  If ls_parts( 0 ) <> Cstr( pl_secs ) Then Call s_abort( cs_fac & "Seconds not same as passed..." )
  If ls_parts( 1 ) <> "=" Then Call s_abort( cs_fac & "Expected `=` sign at field 1..." )
  Select Case ls_parts( 2 )
  Case "Mon", "Tue", "Wed", "Thu", "Fri", "Sat", "Sun"
  Case Else
    Call s_abort( cs_fac & "Expected day name at field 2..." )
  End Select
  Select Case ls_parts( 3 )
  Case "Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"
  Case Else
    Call s_abort( cs_fac & "Expected month name at field 3..." )
  End Select
  If Len( ls_parts( 4 ) ) <> 2 Then Call s_abort( cs_fac & "Expected a two byte day number at field 4..." )
  If Not IsNumeric( ls_parts( 4 ) ) Then Call s_abort( cs_fac & "Expected a two byte day number at field 4..." )
  If Len( ls_parts( 5 ) ) <> 8 Then Call s_abort( cs_fac & "Expected an eight byte time string at field 5..." )
  If Mid( ls_parts( 5 ), 3, 1 ) <> ":" Then Call s_abort( cs_fac & "Expected an eight byte time string at field 5..." )
  If Mid( ls_parts( 5 ), 6, 1 ) <> ":" Then Call s_abort( cs_fac & "Expected an eight byte time string at field 5..." )
  If Len( ls_parts( 6 ) ) <> 4 Then Call s_abort( cs_fac & "Expected a four byte year number at field 4..." )
  If Not IsNumeric( ls_parts( 6 ) ) Then Call s_abort( cs_fac & "Expected a four byte year number at field 4..." )
  fs_ctime_to_dt = ls_parts( 4 ) & "-" & ls_parts( 3 ) & "-" & ls_parts( 6 ) & " " & ls_parts( 5 )
End Function

Function fs_run_command( ps_command )
  Const cs_fac = "%fs_run_command, "
  Dim ls_output, ls_text, ll_status, lo_file, lo_chan

fs_run_command = ""
  
  ls_text = "Failed to run command `" & ps_command & "`."

On Error Resume Next
  ll_status = go_wsh.Run( "%comspec% /c " & ps_command & " >""" & gs_temp_spec & """", 0, True )
  If Err.Number <> 0 Then Call s_error( cs_fac & ls_text )
  On Error Goto 0

Set lo_file = go_fso.GetFile( gs_temp_spec )
  If lo_file.Size = 0 Then Exit Function

Set lo_chan = go_fso.OpenTextFile( gs_temp_spec, ci_for_reading )
  ls_output = lo_chan.ReadAll
  lo_chan.Close
  go_fso.DeleteFile gs_temp_spec

ls_text = ls_text & vbCrlf & vbTab & "Status:  " & ll_status & vbCrlf & vbTab & "Output:  " & ls_output
  If ll_status <> 0 Then Call s_error( cs_fac & ls_text )

fs_run_command = ls_output
End Function

Sub s_error( ps_message )
  Dim ls_error, ls_message
  ls_error =                     "  error:"		& vbTab & Err.Number
  ls_error = ls_error & vbCrlf & "  text:"		& vbTab & Err.Description
  ls_error = ls_error & vbCrlf & "  source:"		& vbTab & Err.Source
  ls_message = "Script has encountered an error, and will now stop..."
  ls_message = ls_message & vbCrlf & "  at:"		& vbTab & fs_datetime( Now )
  ls_message = ls_message & vbCrlf & "  reason:"	& vbTab & ps_message
  ls_message = ls_message & vbCrlf & ls_error
  Call s_quit( ls_message )
End Sub

Sub s_abort( ps_message )
  Dim ls_message
  ls_message = "Script is aborting, and will now stop..."
  ls_message = ls_message & vbCrlf & "  at:"		& vbTab & fs_datetime( Now )
  ls_message = ls_message & vbCrlf & "  reason:"	& vbTab & ps_message
  Call s_quit( ls_message )
End Sub

Sub s_quit( ps_message )
  Call s_log( ps_message & vbCrlf & vbCrlf & "Script will now quit immediately..." )
  WScript.Quit(1)
End Sub

Sub s_log( ps_text )
  WScript.Echo ps_text
End Sub

Function fs_datetime( pd_datetime )
  Dim ld_datetime, ls_result
  ld_datetime = pd_datetime
  ls_result = WeekDayName( WeekDay( ld_datetime ), False, 1 )
  ls_result = ls_result & " " & FormatDateTime( ld_datetime, vbLongdate )
  ls_result = ls_result & " " & FormatDateTime( ld_datetime, vbLongtime )
  fs_datetime = ls_result
End Function