#PBFORMS Created
' Copyright 2002 Barry Erick, All Rights Reserved
' Requires PBWin 7.0 or above to compile.

' This program written by Barry Erick with help from USNavy
' on their meterological sites which have lots of documentation
' on Julian dates. We can't use system dates to get years
' earlier than 1980 or later than 2079, so julian dates
' are uses.
' Program inspired by the old Quick Pak Pro program, weekdays,
' which was DOS based, but had limited years. This does not have
' that limitation.
' A PB Win 7.0 program because of PBForms metastatements and the
' one CHOOSE$ function in Weekday function.
'--------------------------------------------------------------------------------
' The first line in this file is a PBForms metastatement.
' It should ALWAYS be the first line of the file. Other
' PBForms metastatements are placed at the beginning and
' ending of blocks of code that should be edited using
' PBForms only. Do not edit or delete these
' metastatements or PBForms will not be able to reread
' the file correctly. See the PBForms documentation for
' more information.
' Beginning blocks begin like this: #PBForms Begin ...
' Ending blocks begin like this:    #PBForms End ...
' Other PBForms metastatements such as:
'     #PBForms Declarations
' are used to tell PBForms where to insert additional
' code. Feel free to make changes anywhere else in the file.
'--------------------------------------------------------------------------------

#COMPILE EXE
#DIM ALL

'--------------------------------------------------------------------------------
'   ** Includes **
'--------------------------------------------------------------------------------
#PBFORMS Begin Includes
#IF NOT %DEF(%WINAPI)
    #INCLUDE "WIN32API.INC"
#ENDIF
#INCLUDE "PBForms.INC"
#PBFORMS End Includes
'--------------------------------------------------------------------------------
  GLOBAL ghdlg AS DWORD
'--------------------------------------------------------------------------------
'   ** Constants **
'--------------------------------------------------------------------------------
#PBFORMS Begin Constants
%IDD_DIALOG1    = 101
%IDC_TEXTBOX1   = 1001
%IDC_LABEL1     = 1002
%IDC_BUTTON1    = 1003
%IDC_TEXTBOX2   = 1004
%IDC_LABEL2     = 1006
#PBFORMS End Constants
'--------------------------------------------------------------------------------
TYPE PBDate
    Year AS DWORD
    Month AS DWORD
    Day AS DWORD
END TYPE
'--------------------------------------------------------------------------------
'   ** Declarations **
'--------------------------------------------------------------------------------
DECLARE CALLBACK FUNCTION ShowDIALOG1Proc()
DECLARE FUNCTION ShowDIALOG1(BYVAL hParent AS DWORD) AS LONG
DECLARE FUNCTION Weekday(dwJulianDate AS DWORD) AS STRING
DECLARE FUNCTION Date2Jul(pdate AS pbdate) AS DWORD



#PBFORMS Declarations
'--------------------------------------------------------------------------------
FUNCTION WeekdayWrapper () AS STRING
     DIM st AS PBDate
     DIM j AS STRING
     DIM i AS LONG
     CONTROL GET TEXT ghdlg, %IDC_TEXTBOX1 TO j
     ' get format of string... may have "/"'s in. If so it is 3/4/55 or 03/04/1955
     ' if not in a / form, it has to be in 030455 or 03041955
      IF TALLY(j,ANY "/-")=2 THEN
         'parse the / stuff
         ' make sure the characters are right
         i = INSTR(j$, ANY "/-")
         IF i = 3 THEN
             INCR i ' move past for next test
             ELSE
                 j$="0"+j$    'they sent in 2/2
                 INCR i ' move past found position
                 INCR i ' move past new position
         END IF
         i  = INSTR (i,j$,ANY"/-")
         IF i = 6 THEN
           ELSE
            j$ = LEFT$(j$,3)+"0"+MID$(j$,i-1)
         END IF
         ' we are ok to remove...
          j = REMOVE$(j$, ANY "/-")
      END IF
      ' they need 4 digits at end for year, unless looking for a early year
      'work on the only possible way
      st.month = VAL(LEFT$(j,2))
      st.day   = VAL(MID$(j,3,2))
      st.year  = VAL(MID$(j,5))
     FUNCTION  = Weekday(date2jul(st))
END FUNCTION

FUNCTION Weekday(dwJulianDate AS DWORD) AS STRING
    IF dwJulianDate = 0 THEN
        FUNCTION = "Illegal date"
    ELSE
        FUNCTION = CHOOSE$(dwJulianDate MOD 7 + 1, "Monday", "Tuesday", _
              "Wednesday", "Thursday", "Friday", "Saturday", "Sunday")
    END IF
END FUNCTION

FUNCTION Date2Jul(pdate AS pbdate) AS DWORD
     LOCAL dwJulianDays AS DWORD
     IF pdate.month < 3 THEN
         pdate.month = pdate.month + 12
         DECR pdate.year
     END IF
     ' for exact julian number, we need time of day..
     ' but just to find the day of week we can skip
     ' day 1 of julian is 1/1/-4712 and there are 365.25 days per year
     dwJulianDays = INT((pdate.year + 4712) * 365.25) 'years since day 1 of julian
     dwJulianDays = dwJulianDays - (pdate.year \100) 'leapday fudge for centuries
     dwJulianDays = dwJulianDays + (pdate.year \ 400) ' each 400 years it isn't
     dwJulianDays = dwJulianDays + INT(30.6*(pdate.month-1)+.2)'do the month fudge
     FUNCTION = dwJulianDays + pdate.day
END FUNCTION



'--------------------------------------------------------------------------------
FUNCTION PBMAIN()
    ShowDIALOG1 %HWND_DESKTOP
END FUNCTION
'--------------------------------------------------------------------------------

'--------------------------------------------------------------------------------
'   ** CallBacks **
'--------------------------------------------------------------------------------
CALLBACK FUNCTION ShowDIALOG1Proc()

    SELECT CASE CBMSG
        CASE %WM_COMMAND
            SELECT CASE CBCTL
                CASE %IDC_BUTTON1
                    IF CBCTLMSG = %BN_CLICKED OR CBCTLMSG = 1 THEN
                        CONTROL SET TEXT ghdlg, %IDC_LABEL1,_
                        "That's a " & weekdaywrapper
                    END IF
            END SELECT
    END SELECT

END FUNCTION
'--------------------------------------------------------------------------------
'--------------------------------------------------------------------------------
'   ** Dialogs **
'--------------------------------------------------------------------------------
FUNCTION ShowDIALOG1(BYVAL hParent AS DWORD) AS LONG
    LOCAL lRslt AS LONG
#PBFORMS Begin Dialog %IDD_DIALOG1->->
    LOCAL hDlg AS DWORD
    LOCAL hFont1 AS DWORD
    LOCAL hFont2 AS DWORD



    DIALOG NEW hParent, "Weekday", 151, 79, 195, 106, %WS_POPUP OR %WS_BORDER OR _
        %WS_DLGFRAME OR %WS_SYSMENU OR %WS_MINIMIZEBOX OR %WS_MAXIMIZEBOX OR _
        %WS_CLIPSIBLINGS OR %WS_VISIBLE OR %DS_MODALFRAME OR %DS_3DLOOK OR _
        %DS_NOFAILCREATE OR %DS_SETFONT, %WS_EX_WINDOWEDGE OR _
        %WS_EX_CONTROLPARENT OR %WS_EX_LEFT OR %WS_EX_LTRREADING OR _
        %WS_EX_RIGHTSCROLLBAR, TO hDlg
    CONTROL ADD LABEL, hDlg, %IDC_LABEL1, "", 45, 55, 115, 15, %WS_CHILD OR _
        %WS_VISIBLE OR %SS_CENTER, %WS_EX_LEFT OR %WS_EX_LTRREADING
    CONTROL ADD BUTTON, hDlg, %IDC_BUTTON1, "Get Weekday", 70, 75, 65, 20, _
        %WS_CHILD OR %WS_VISIBLE OR %WS_TABSTOP OR %BS_TEXT OR %BS_PUSHBUTTON _
        OR %BS_DEFPUSHBUTTON OR %BS_CENTER OR %BS_VCENTER, %WS_EX_LEFT OR _
        %WS_EX_LTRREADING
    CONTROL ADD TEXTBOX, hDlg, %IDC_TEXTBOX1, "TEXTBOX1", 95, 35, 60, 12
    CONTROL ADD LABEL, hDlg, %IDC_LABEL2, "Enter Date using full year", 40, 35, _
        45, 20, %WS_CHILD OR %WS_VISIBLE OR %SS_CENTER, %WS_EX_LEFT OR _
        %WS_EX_LTRREADING

    hFont1 = PBFormsMakeFont("Courier New", 10, 700, %FALSE, %FALSE, %FALSE, %ANSI_CHARSET)
    hFont2 = PBFormsMakeFont("Times New Roman", 8, 400, %FALSE, %FALSE, %FALSE, %ANSI_CHARSET)

    CONTROL SEND hDlg, %IDC_LABEL1, %WM_SETFONT, hFont1, 0
    CONTROL SEND hDlg, %IDC_LABEL2, %WM_SETFONT, hFont2, 0

#PBFORMS End Dialog
    ghdlg = hdlg
    CONTROL SET TEXT hdlg,%IDC_TEXTBOX1, DATE$
    DIALOG SHOW MODAL hDlg, CALL ShowDIALOG1Proc TO lRslt

    DeleteObject hFont1

    FUNCTION = lRslt
END FUNCTION
'--------------------------------------------------------------------------------