PureBasic Forums - English

Code: Select all

;xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
;The program is used to determine the term that comes for a given number of days..
;This may be the date of the medical examination, laboratory testing date,  
;or the date of anything else. The default: Starting day = Today     Interval = 84 
;Written and compiled in PureBasic 5.00
;Standard PureBasic functions AddDate and DayOfWeek are not use in this program,
;alternative solution from old DOS times is presented.
;;xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
;                                       START
;xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx

Dim W.s (11)
W(0)= Chr(169) + "  Copyright: Luboš Svoboda 2013"
W(1)= "Next Date 2.0" +Space(18)+ "ESTIMATING  OF  NEXT  DATE    (1. 1. 1900 - 31. 12. 2100) "
W(2)="Interval"
W(3)="Resulting day"
W(4)="Starting day"
W(5)="Licence"
W(6)="Calculation"
W(7)="  GO  "
W(8)="  QUIT  "
W(9)=" Today's date"
W(10) ="Starting year is out of limit." 
W(11) ="Number of days is out of limit."

;*********************************************************************
;---------------------------------------------------------------------
Procedure.s DayWeek (D, M, R)

Dt = Int((5 * R - Int(1.2 - 0.1 * M)) / 4) + Val(Mid("033614625035", M, 1)) + D + 5
Dt = Dt - 7 * Int(Dt / 7)
Dweek$ = Mid("Sunday   Monday   Tuesday  WednesdayThursday Friday   Saturday ", 9 * Dt + 1, 9)
ProcedureReturn Dweek$

EndProcedure
;---------------------------------------------------------------------
Procedure NumberDays (D, M, R)
  
  If M<3
    Q= -1
  Else
    Q=0
  EndIf

  R = R - 2000 + Q
  M = M + 1 - 12 * Q
  Ndays = Int(R * 365.25) - Int(R / 100) + Int(R / 400) + Int(M * 30.6001) + D + 36462
  ProcedureReturn Ndays
 
EndProcedure
;---------------------------------------------------------------------

Macro DMR

  D= Val(Mid(Datum$, 1,2))
  M=Val(Mid(Datum$,5,2))
  R=Val(Mid(Datum$, 9,4))
  
EndMacro  
;---------------------------------------------------------------------

;**********************************************************************
#WindowWidth  = 640
#WindowHeight = 240
GadgetHeight = 24

If OpenWindow(0, 100, 200, #WindowWidth, #WindowHeight, " "+ W(1), #PB_Window_MinimizeGadget)
  
  Datum$ = FormatDate("%dd. %mm. %yyyy", Date())
  
  DMR
 
  Dweek$ =  DayWeek (D,M,R)
  Frame3DGadget(#PB_Any, 20, 10, 175, 50, W(9))
  StringGadget(11, 25, 30, 160, GadgetHeight, Datum$+ "   "+Dweek$)
  TextGadget  (9, 20, #WindowHeight-30, 350, 24, W(0))
  ButtonGadget(8, 640-140, 240-32, 80, 24, W(8)); Quit

  ;************************************************************************************

  PanelGadget(3, 20, 85, #WindowWidth-50, #WindowHeight-125)
  OpenGadgetList(3)

  AddGadgetItem(3, 1, W(6))

  TextGadget(#PB_Any,  230, 15, 200, 24, W(2))

  SpinGadget(13, 230, 30, 50,24, 1, 73414,#PB_Spin_ReadOnly   )
  SetGadgetState (13, 84) : SetGadgetText(13, "84")   ; Set initial value

  TextGadget(17,  25, 15, 100, GadgetHeight, W(4))
  DateGadget(14, 25, 30, 90, GadgetHeight, "%dd. %mm. %yyyy")

  TextGadget (19, 300, 15, 150, GadgetHeight, W(3))
  StringGadget(18, 300, 30, 150, 24, Result$)
  
  StringGadget(20, 130, 30, 90, GadgetHeight, "  "+Dweek$)

  ButtonGadget(16, 475, 30, 80, 24, W(7)); Go

  ;***********************************************************************************

  AddGadgetItem(3, 2, W(5))
  ListViewGadget(15, 10, 10, 565, 75)
  
  AddGadgetItem(15, -1,"Program Next Date 2.0 is a freeware.")
  AddGadgetItem(15, -1,"Use it freely at home and at work.")  
  AddGadgetItem(15, -1,"The program does not contain any hidden malicious code.")
  AddGadgetItem(15, -1,"Correct function of the program is not  guaranteed.")
  AddGadgetItem(15, -1,"Use of the program is on your risk.")
  
 ;***********************************************************************************

  CloseGadgetList()

  ;00000000000000000000000000000000000000000000000000000000000000000000000000000000000
  
  Repeat
    EventID = WaitWindowEvent()
    If EventID = #PB_Event_Gadget

      Select EventGadget()

      Case 8 ; Quit...
        EventID = #PB_Event_CloseWindow
        End

      Case 13 ; Spingadget

        SetGadgetText(13,Str(GetGadgetState(13)))
        SetGadgetText(18,"")

      Case 14  ;DateGadget
                
        SetGadgetText(18,"")
        
        Datum$= GetGadgetText(14)
        
        DMR
                
        Dweek$ =  DayWeek (D,M,R)
        SetGadgetText(20, " "+Dweek$)   

      Case 16; Go
        
        Datum$= GetGadgetText(14)
        
        DMR
       
        Interval=GetGadgetState(13)
        Ndays =  NumberDays(D, M, R)
        Target = Ndays + Interval
        
        If R < 1900 Or R > 2100
          Result$= W(10)
          Goto Report
        EndIf
        
        If Target > 73414
          Result$ = W(11)
          Goto Report
        EndIf            
        
        M = 1
        D = 1
        Repeat
          R = R + 1
          Ndays = NumberDays(D, M, R)
        Until Target  < Ndays

        R = R - 1
        M = 0
        Repeat
          M = M + 1
          Ndays = NumberDays(D, M, R)
        Until Target < Ndays

        M = M - 1
        D = 0
        Repeat
          D = D + 1
          Ndays = NumberDays(D, M, R)
        Until Target = Ndays

        Dweek$ = DayWeek(D, M, R)
        Result$=  Str(D) + ". " + Str(M) + ". " + Str(R) + "    " + Dweek$
        
        Report:
        SetGadgetText(18,Result$)

            EndSelect
    EndIf

  Until EventID = #PB_Event_CloseWindow

  ; 000000000000000000000000000000000000000000000000000000000000000000000000000000000000

EndIf

End

;xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
;                                    FINISH
;xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
;xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx

Code: Select all

  M = Memom
  R = Memor