DATE$ function - Printable Version

Code: (Select All)
' some code to attempt to change the system date.

' returns error:

'   a required privilege is not held by the client.

DefLng A-Z



Type SYSTEMTIME

   wYear As Integer

   wMonth As Integer

   wDayOfWeek As Integer

   wDay As Integer

   wHour As Integer

   wMinute As Integer

   wSecond As Integer

   wMilliseconds As Integer

End Type



Declare Dynamic Library "kernel32"

   Function GetLocalTime& (lpSystemTime As SYSTEMTIME)

   Function SetLocalTime& (lpSystemTime As SYSTEMTIME)

   Function GetSystemTime& (lpSystemTime As SYSTEMTIME)

   Function SetSystemTime& (lpSystemTime As SYSTEMTIME)

   Function GetLastError& ()

   Function FormatMessageA& (ByVal f As Long, f$, Byval e As Long, Byval d As Long, g$, Byval s As Long, h$)

End Declare



Dim Shared SysTime As SYSTEMTIME

Dim Shared ErrorBuffer As String * 260



Print "Current date: "; Date$

Print "Enter date(mm-dd-yyyy)";

Input z$

z$ = LTrim$(RTrim$(z$))

If Len(z$) Then

   z = ValidDate(z$)

   If z Then

      ' mm-dd-yyyy

      x = GetLocalTime(SysTime)

      SysTime.wMonth = Int(Val(Left$(z$, 2)))

      SysTime.wDay = Int(Val(Mid$(z$, 4, 2)))

      SysTime.wYear = Int(Val(Right$(z$, 4)))

      x = SetLocalTime(SysTime)

      If x = 0 Then

         Print "Error Date reset: "; z$

         Print DisplayWinError$(x)

      Else

         Print "Date reset to: "; z$

      End If

   Else

      Print "Invalid date."

   End If

End If

End



Function ValidDate (Var$)

   ' mm-dd-yyyy

   Var$ = RTrim$(Var$)

   If Len(Var$) <> 10 Then

      ValidDate = False

      Exit Function

   End If

   For Var = 1 To 10

      V$ = Mid$(Var$, Var, 1)

      Select Case Var

         Case 1, 2, 4, 5, 7, 8, 9, 10

            If V$ >= "0" And V$ <= "9" Then

               Eat$ = ""

            Else

               ValidDate = False

               Exit Function

            End If

         Case Else

            If V$ <> "-" Then

               ValidDate = False

               Exit Function

            End If

      End Select

   Next

   M = Int(Val(Mid$(Var$, 1, 2)))

   D = Int(Val(Mid$(Var$, 4, 2)))

   Y = Int(Val(Mid$(Var$, 7, 4)))

   If M >= 1 And M <= 12 Then

      If D >= 1 And D <= 31 Then

         If Y >= 1980 And Y <= 2079 Then

            L = 0

            If Y / 4 = Y \ 4 Then

               L = -1

            End If

            If Y / 100 = Y \ 100 Then

               L = 0

            End If

            If Y / 400 = Y \ 400 Then

               L = -1

            End If

            Select Case M

               Case 1, 3, 5, 7, 8, 10, 12

                  If D <= 31 Then

                     ValidDate = -1

                     Exit Function

                  End If

               Case 4, 6, 9, 11

                  If D <= 30 Then

                     ValidDate = -1

                     Exit Function

                  End If

               Case 2

                  If L Then

                     If D <= 29 Then

                        ValidDate = -1

                        Exit Function

                     End If

                  End If

                  If D <= 28 Then

                     ValidDate = -1

                     Exit Function

                  End If

            End Select

         End If

      End If

   End If

   ValidDate = 0

End Function



' display windows error message

Function DisplayWinError$ (x)

   ' define error message value

   v& = GetLastError

   ' call windows error message routine

   x& = FormatMessageA&(&H1200, "", v&, 0, ErrorBuffer$, 260, "")

   If x& Then

      DisplayWinError$ = Left$(ErrorBuffer$, x& - 2)

   Else

      DisplayWinError$ = "Unknown error 0x" + Hex$(v&) + "."

   End If

   x = -1

End Function