// ********************************************************************** // Use Dates.utl // Date manipulation for VDF and DF3.2 // // by Sture Andersen (sa1@vd.dk) // // The file contains a number of global functions for manipulating // dates. The package may be used with DataFlex 3.1 and Visual DataFlex. // This package is public domain. // // The package file is accompanied by a Word document (dfutil.doc) // listing the functions and their use. // // // Create: Fri 06-06-1997 - Merger of s_utl020, 021, 022, 023, 024, 025. // Update: Thu 26-06-1997 - Fixes for strange behavior when date4_state is set. // - Addition of popup_calendar to VDF. // Sun 29-06-1997 - Character mode popup calender. // Fri 04-07-1997 - Function WeekToDate added. // Thu 10-07-1997 - Fixes. // Mon 11-08-1997 - WeekToDate fixed. // Sun 24-08-1997 - Character mode popup calender finished. // Mon 15-12-1997 - Procedure Request_Popup_Calendar added. // Mon 29-12-1997 - Procedures ItemYear2to4, ItemDate2to4 and // ItemSysdate added. // Mon 29-12-1997 - Procedures FieldYear2to4, FieldDate2to4 and // FieldSysdate added. // Sun 01-02-1998 - Functions Module_Compile_Date and // Module_Compile_Time added. // Wed 25-02-1998 - Request_Popup in calendar object now only // responds if entry_state of the calling object // is true (VDF version). (No apparent effect) // Sat 28-03-1998 - Added the following functions: // TS_SysTime TS_ExtractDate // TS_ExtractTime TS_ConvertToString // Tue 26-05-1998 - Procedure TS_UI_Update added // Sat 01-08-1998 - mask_date_window taken into account // Mon 10-08-1998 - Functions Module_Start_Date and // Module_Start_Time added. // Wed 02-09-1998 - Parameter for Module_Start_Date removed // Mon 12-10-1998 - Portuguese added // Wed 04-11-1998 - TS_TimeEstimator class added // Tue 29-12-1998 - Function DateAsString added // Wed 13-01-1999 - Function DateWeekNumber changed according to // Kjetil Johanson // Mon 18-01-1999 - Function DateWeekNumber changed according to // Kjetil Johanson (again) // Tue 19-01-1999 - Changed procedure names in TS_TimeEstimator // class (Continue->TS_Continue and Pause-> // TS_Pause) // Thu 21-01-1999 - Procedures DateFormatAsString and DateFormatName // added. // - Procedures DateCurrentSeparator and // DateCurrentFormat added. // Tue 13-04-1999 - Julian constants added: Jan1st1900, Jan1st2000 // Jan1st1000 and Jan1st100 // Mon 26-04-1999 - Changed procedure FieldYear2to4 and ItemYear2to4 // to trap 3 digit years. // Wed 27-04-1999 - Changed Dutch abbriviated day names (to 2 characters) // Sun 02-05-1999 - Added function TS_Compose2 // - Fixed error in TS_ConvertToString // Tue 01-06-1999 - Added procedure popup_no_export to calendar. // Thu 15-06-1999 - Fixed Date4to2 function and exporting dates // from the calendar to forms with no form_margin. // Tue 07-09-1999 - Added function DateAsText // Wed 27-10-1999 - Temporary fix for Module_Compile_Date function // in combination with y2k. // Wed 19-12-1999 - Function StringToDate added. // - Existing function DateAsString renamed to // DateToString. // Mon 03-01-2000 - Fix for VDF4. Popup calendar on empty date field // would result in seeding the calendar on year 100. // This error was caused by the fact that VDF 4 // ignores SYSDATE4_STATE such that the sysdate // command returns 03-01-100 // Wed 01-02-2000 - Define instead of #REPLACE // Wed 23-08-2000 - Function TS_Module_Compile_Time added // Sat 04-08-2001 - Function StringToDate in Dates.nui fixed by Paul // Cooling // Sat 30-08-2003 - Odd date thing fixed by Wil van Antwherpen. (Search: **WvA:) // // NOTE: There is language dependent string constants in this file. // Currently there are sections for dutch, english, danish, swedish, // norwegian, spanish, german and portuguese // // These sections may be identified by searching the symbol LNG_DEFAULT // // *********************************************************************** Use Dates.nui // Date routines (No User Interface) Use ErrorHnd.nui // cErrorHandlerRedirector class and oErrorHandlerQuiet object (No User Interface) define DATES_INCLUDE_POPUP for 1 // If set to 0 the popup calendar will not be included procedure ItemSysdate for desktop integer liItm local date ldDate get value item liItm to ldDate if ldDate eq 0 begin sysdate4 ldDate set changed_value item liItm to ldDate end end_procedure procedure ItemDate2to4 for desktop integer liItm local integer liYear local date ldDate ldNewDate send ErrorHnd_Quiet_Activate get value item liItm to ldDate send ErrorHnd_Quiet_Deactivate move (DateSegment(ldDate,DS_YEAR)) to liYear if (liYear=0 and ldDate<>0) move (DateIncrement(ldDate,3,iSysYear())) to ldNewDate else move ldDate to ldNewDate move (Date2to4(ldNewDate)) to ldNewDate move (DateSegment(ldNewDate,3)) to liYear if (liYear>99 and liYear<1000) begin error 15 // Illegal entry in this window procedure_return 1 end if ldNewDate ne ldDate set value item liItm to ldNewDate end_procedure procedure ItemYear2to4 for desktop integer liItm local integer liYear liNewYear get value item liItm to liYear if (liYear>99 and liYear<1000) begin error 15 // Illegal entry in this window procedure_return 1 end move (Year2to4(liYear)) to liNewYear if liNewYear ne liYear set value item liItm to liNewYear end_procedure #IF DATES_INCLUDE_POPUP register_procedure NotifyPopupCalendarChange date ldDate register_procedure NotifyPopupCalendarSelect date ldDate #IFDEF IS$WINDOWS use DFAllent class calendar.textbox is a textbox procedure construct_object forward send construct_object Set Auto_Size_State To DFFALSE Set Justification_Mode To (JMODE_VCENTER+JMODE_CENTER) end_procedure end_class register_object oBtn1 register_object oBtn6 class calendar.button is a button procedure construct_object forward send construct_object set size to 15 18 on_key kleftarrow send prev_day on_key krightarrow send next_day on_key kuparrow send prev_week on_key kdownarrow send next_week property date pdAssignedDate public 0 end_procedure procedure switch // This makes all 42 buttons act as if they are one focus send activate to (oBtn1(self)) end_procedure procedure switch_back send activate to (oBtn6(self)) end_procedure procedure mouse_down local integer lhSelf forward send mouse_down move self to lhSelf delegate set pdCurrentDate to (pdAssignedDate(lhSelf)) end_procedure end_class desktop_section object popup_calendar is a ModalPanel // Visual DataFlex 14.0 Client Size Adjuster, modified May 7, 2008: 13:11:33 // set size to 160 250 Set Size to 145 246 property date pdCurrentDate public 0 property integer p_current_year public -1 property integer p_current_month public -1 property integer pExportState public 1 on_key key_ctrl+key_pgup send prev_year on_key key_ctrl+key_pgdn send next_year on_key key_pgup send prev_month on_key key_pgdn send next_month on_key key_ctrl+key_d send go_today on_key kcancel send cancel object oCont3d is a container3d set location to 5 5 set size to 120 237 object oTextboxYear is a calendar.textbox set location to 5 5 set size to 15 30 set border_style to BORDER_STATICEDGE procedure display set value to (p_current_year(self)) end_procedure end_object object oDaynameHeader is a container3d set location to 5 39 set size to 15 126 set border_style to BORDER_STATICEDGE procedure initialize local integer liItm for liItm from 0 to 6 #PUSH !Zb // Compiler trick (non static number of objects) #SET ZB$ -1 object oTxt is a calendar.textbox set size to 12 17 set location to 0 (liItm*17.6+1) #IF LNG_DEFAULT=LNG_DUTCH // The dutch only wants the first 2 letters of the weekday set value to (left(DayName(liItm+1),2)) #ELSE set value to (left(DayName(liItm+1),3)) #ENDIF end_object #POP ZB$ // End trick loop end_procedure send initialize end_object object oWeekNumberHeader is a container3d set location to 24 5 set size to 89 30 set border_style to BORDER_STATICEDGE object oObjIdArray is an array end_object procedure initialize local integer liItm lhObj move (oObjIdArray(self)) to lhObj for liItm from 0 to 5 #PUSH !Zb // Compiler trick. Non static number #SET ZB$ -1 // of child objects. object oTxt is a textbox set size to 15 30 set location to (liItm*15+1) 1 set value of lhObj item (item_count(lhObj)) to self end_object #POP ZB$ // End trick loop end_procedure procedure display local integer liItm lhObj local date ldDate ldLastDate move (oObjIdArray(self)) to lhObj get pdCurrentDate to ldDate move (FirstDayInMonth(ldDate)) to ldDate move (LastDayInMonth(ldDate)) to ldLastDate move (ldDate-DateDayNumber(ldDate)+1) to ldDate for liItm from 0 to 5 if (liItm*7+ldDate) le ldLastDate ; set value of (integer(value(lhObj,liItm))) to (t.calendar.week*string(DateWeekNumber(liItm*7+ldDate))) else set value of (integer(value(lhObj,liItm))) to "" loop end_procedure send initialize end_object object oDaysGrid is a container3d set location to 23 39 set size to 100 127 set border_style to BORDER_NONE object oBtnArray is an array end_object procedure initialize local integer liRow liCol lhBtnArray move (oBtnArray(self)) to lhBtnArray for liRow from 0 to 5 for liCol from 0 to 6 #PUSH !Zb #SET ZB$ -1 object oBtn is a calendar.button set location to (liRow*15) (liCol*18) set value of lhBtnArray item (item_count(lhBtnArray)) to self on_item "" send move_value_out_ok end_object #POP ZB$ loop loop end_procedure send initialize procedure display.iii integer liItm integer liDay integer lbActivate local integer lhObj liCurrentDay move (integer(value(oBtnArray(self),liItm))) to lhObj move (DateSegment(pdCurrentDate(self),DS_DAY)) to liCurrentDay if lbActivate begin if liDay eq liCurrentDay send activate to lhObj end else begin if liDay begin set value of lhObj to liDay set visible_state of lhObj to DFTRUE set pdAssignedDate of lhObj to (DateCompose(liDay,p_current_month(self),p_current_year(self))) end else set visible_state of lhObj to DFFALSE end end_procedure procedure display integer lbActivate local integer liFirstItem liLastItem liItm liDay liDate get pdCurrentDate to liDate move (FirstDayInMonth(liDate)) to liDate move (DateDayNumber(liDate)-1) to liFirstItem // **WvA: 27-08-2003 VDF9.1 Needs the integer datevalue to be casted to // a date before the expression can be evaluated. move (LastDayInMonth(liDate)-date(liDate)+liFirstItem) to liLastItem // ** ifnot lbActivate begin for liItm from 0 to (liFirstItem-1) send display.iii liItm 0 0 loop end move 1 to liDay for liItm from liFirstItem to liLastItem send display.iii liItm liDay lbActivate increment liDay loop ifnot lbActivate begin for liItm from (liLastItem+1) to 41 send display.iii liItm 0 0 loop end end_procedure end_object object oTxtMonth is a calendar.textbox set size to 12 27 set location to 25 185 set value to t.calendar.month end_object object oBtn1 is a button set size to 12 12 set location to 40 185 on_item "" send prev_month set bitmap to "prev.bmp" procedure switch_back send display_main end_procedure end_object object oBtn2 is a button set size to 12 12 set location to 40 200 on_item "" send next_month set bitmap to "next.bmp" end_object object oTxtYear is a calendar.textbox set size to 12 27 set location to 70 185 set value to t.calendar.year end_object object oBtn3 is a button set size to 12 12 set location to 85 185 on_item "" send prev_year set bitmap to "prev.bmp" end_object object oBtn4 is a button set size to 12 12 set location to 85 200 on_item "" send next_year set bitmap to "next.bmp" end_object end_object object oBtn5 is a button set size to 14 60 set location to 129 115 on_item t.calendar.ok send move_value_out_ok end_object object oBtn6 is a button set size to 14 60 set location to 129 182 on_item t.calendar.cancel send cancel procedure switch send display_main end_procedure end_object procedure next_year set pdCurrentDate to (DateIncrement(pdCurrentDate(self),DS_YEAR,1)) send display_main end_procedure procedure prev_year set pdCurrentDate to (DateIncrement(pdCurrentDate(self),DS_YEAR,-1)) send display_main end_procedure procedure next_month set pdCurrentDate to (DateIncrement(pdCurrentDate(self),DS_MONTH,1)) send display_main end_procedure procedure prev_month set pdCurrentDate to (DateIncrement(pdCurrentDate(self),DS_MONTH,-1)) send display_main end_procedure procedure next_week set pdCurrentDate to (DateIncrement(pdCurrentDate(self),DS_WEEK,1)) send display_main end_procedure procedure prev_week set pdCurrentDate to (DateIncrement(pdCurrentDate(self),DS_WEEK,-1)) send display_main end_procedure procedure next_day set pdCurrentDate to (DateIncrement(pdCurrentDate(self),DS_DAY,1)) send display_main end_procedure procedure prev_day set pdCurrentDate to (DateIncrement(pdCurrentDate(self),DS_DAY,-1)) send display_main end_procedure procedure go_today local date ldDate sysdate4 ldDate set pdCurrentDate to ldDate send display_main end_procedure property integer invoking_object_id public 0 procedure OnChange date ldDate local integer lhFocus lbDelegationMode get invoking_object_id to lhFocus if lhFocus gt desktop begin get delegation_mode of lhFocus to lbDelegationMode set delegation_mode of lhFocus to no_delegate_or_error send NotifyPopupCalendarChange to lhFocus ldDate set delegation_mode of lhFocus to lbDelegationMode end end_procedure procedure display local integer liDate liMonth liYear get pdCurrentDate to liDate send OnChange liDate move (DateSegment(liDate,DS_YEAR)) to liYear move (DateSegment(liDate,DS_MONTH)) to liMonth if (p_current_year(self)<>liYear or p_current_month(self)<>liMonth) begin set p_current_year to liYear set p_current_month to liMonth set value to (t.calendar.calendar_popup+", "+MonthName(liMonth)) send display to (oTextboxYear(oCont3d(self))) send display to (oWeekNumberHeader(oCont3d(self))) send display to (oDaysGrid(oCont3d(self))) 0 end end_procedure procedure display_main send display send display to (oDaysGrid(oCont3d(self))) 1 end_procedure procedure popup_no_export set pExportState to DFFALSE send popup set pExportState to DFTRUE end_procedure procedure popup_group local integer lhFocus local date ldDate move (focus(desktop)) to lhFocus set invoking_object_id to lhFocus get value of lhFocus item current to ldDate ifnot (integer(ldDate)) move (dSysdate()) to ldDate move (Date2to4(ldDate)) to ldDate set pdCurrentDate to ldDate send display forward send popup_group send display to (oDaysGrid(oCont3d(self))) 1 end_procedure procedure move_value_out local integer lhFocus lbDelegationMode liMargin liDataType // if (pExportState(self)) begin get invoking_object_id to lhFocus if lhFocus gt desktop begin get delegation_mode of lhFocus to lbDelegationMode set delegation_mode of lhFocus to no_delegate_or_error send NotifyPopupCalendarSelect to lhFocus (pdCurrentDate(self)) get form_margin of lhFocus item current to liMargin get form_datatype of lhFocus item current to liDataType set delegation_mode of lhFocus to lbDelegationMode if (pExportState(self)) begin if (liMargin>=10 or liDataType=mask_date_window or liDataType=date_window) set value of lhFocus item current to (pdCurrentDate(self)) else set value of lhFocus item current to (Date4to2(pdCurrentDate(self))) set item_changed_state of lhFocus item current to DFTRUE end end // end end_procedure procedure move_value_out_ok send move_value_out send deactivate end_procedure procedure request_popup local integer lhFocus liType lbDelegationMode move (focus(desktop)) to lhFocus if lhFocus gt desktop begin get delegation_mode of lhFocus to lbDelegationMode set delegation_mode of lhFocus to no_delegate_or_error get form_datatype of lhFocus item current to liType if (liType=date_window or liType=mask_date_window) send popup set delegation_mode of lhFocus to lbDelegationMode end end_procedure end_object end_desktop_section // If the procedure below was not defined "for BaseClass" its symbolic // substitute would become negative (because located on the desktop). This // would result in the toolbar object not being able to handle it. Therefore: procedure request_popup_calendar for BaseClass send request_popup to (popup_calendar(self)) end_procedure procedure popup_calendar_no_export send popup_no_export to (popup_calendar(self)) end_procedure register_procedure Add_Toolbar_Button_Bitmap string lsBmp string lsTip string lsStatusHelp integer liMsg integer lhObj procedure Add_Calendar_tbButton integer lhToolButton send Add_Toolbar_Button_Bitmap to lhToolButton "DfCalend.bmp" t.calendar.calendar_popup t.calendar.Activate msg_request_popup_calendar end_procedure #ELSE // Character mode define color.button for 112 // Black on grey define color.button_highlight for 122 // Green on grey /popup_calendar.hdr ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ» /popup_calendar.btn1 º _ ____ _ _ ___________ _ º /popup_calendar.wkday ºÄÄÄÄÂÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄĺ º____³___ ___ ___ ___ ___ ___ ___ º /popup_calendar.wknumber º _. ³ º _. ³ º _. ³ º _. ³ º _. ³ º _. ³ /popup_calendar.days _. _. _. _. _. _. _. º _. _. _. _. _. _. _. º _. _. _. _. _. _. _. º _. _. _. _. _. _. _. º _. _. _. _. _. _. _. º _. _. _. _. _. _. _. º /popup_calendar.btn2 º º º ____________ ____________ º ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ /* use Allentry class MovableClient is a client procedure construct_object integer liImage forward send construct_object liImage send Define_Movable_Client_Support send Define_Auto_Locate set auto_locate_state to DFTRUE set allow_move_state to DFTRUE end_procedure import_class_protocol Movable_Client_Mixin import_class_protocol Auto_Locate_Mixin end_class object popup_calendar is a MovableClient popup_calendar.hdr set popup_state to DFTRUE set scope_state to DFTRUE set block_mouse_state to DFTRUE property date pdCurrentDate public 0 property integer p_current_year public -1 property integer p_current_month public -1 property integer pExportState public 1 on_key key_ctrl+key_pgup send prev_year on_key key_ctrl+key_pgdn send next_year on_key key_pgup send prev_month on_key key_pgdn send next_month on_key key_ctrl+key_d send go_today on_key kcancel send close_calendar on_key ksave_record send move_value_out_ok object oBtn1 is a button popup_calendar.btn1 set location to 1 0 relative set focus_mode to pointer_only item_list on_item "" send prev_year on_item "" send none on_item "" send next_year on_item "" send prev_month on_item "" send none on_item "" send next_month end_item_list set center_state item 1 to DFTRUE set center_state item 4 to DFTRUE set shadow_state item 1 to DFTRUE set shadow_state item 4 to DFTRUE procedure display_date local date ldDate get pdCurrentDate to ldDate set value item 1 to (DateSegment(ldDate,DS_YEAR)) set value item 4 to (MonthName(DateSegment(ldDate,DS_MONTH))) end_procedure end_object object oWkDay is a button popup_calendar.wkday set location to 2 0 relative set focus_mode to pointer_only item_list repeat_item 8 times "" send none end_item_list procedure initialize local integer liDay set value item 0 to t.calendar.week set shadow_state item 0 to DFTRUE for liDay from 1 to 7 set value item liDay to (DayName(liDay)) set shadow_state item liDay to DFTRUE loop end_procedure send initialize end_object object oWkNumber is a button popup_calendar.wknumber set location to 4 0 relative set focus_mode to pointer_only item_list repeat_item 6 times "" send none end_item_list procedure display_date local integer liItm local date ldDate ldLastDate get pdCurrentDate to ldDate move (FirstDayInMonth(ldDate)) to ldDate move (LastDayInMonth(ldDate)) to ldLastDate move (ldDate-DateDayNumber(ldDate)+1) to ldDate for liItm from 0 to 5 if (liItm*7+ldDate) le ldLastDate ; set value item liItm to (DateWeekNumber(liItm*7+ldDate)) else set value item liItm to "" set shadow_state item liItm to DFTRUE loop end_procedure end_object object oDays is a button popup_calendar.days set auto_top_item_state to DFFALSE set location to 4 6 relative on_key knext_item send switch on_key kprevious_item send switch_back on_key kuparrow send prev_week on_key kdownarrow send next_week on_key kleftarrow send prev_day on_key krightarrow send next_day on_key kenter send move_value_out_ok procedure set item end_procedure item_list repeat_item 42 times "" send none end_item_list procedure fill_list local integer liItm liWeekDay liFirstItm liLastItm local date ldDate ldAux get pdCurrentDate to ldDate move (FirstDayInMonth(ldDate)) to ldAux move (DateDayNumber(ldAux)) to liWeekDay move (liWeekDay-1) to liFirstItm move (LastDayInMonth(ldDate)-ldAux+liFirstItm) to liLastItm for liItm from 0 to 41 if (liItmliLastItm) set value item liItm to "" else set value item liItm to (liItm-liFirstItm+1) loop end_procedure procedure display_date local integer liWeekDay local date ldDate ldFirstDate get pdCurrentDate to ldDate move (FirstDayInMonth(ldDate)) to ldFirstDate move (DateDayNumber(ldFirstDate)) to liWeekDay set current_item to (ldDate-ldFirstDate+liWeekDay-1) end_procedure // Prevent navigation to non existing dates: procedure item_change integer liFrom integer liTo returns integer local integer liDay get value item liTo to liDay if liDay eq 0 procedure_return liFrom set pdCurrentDate to (DateCompose(liDay,p_current_month(self),p_current_year(self))) set window_color item liFrom to 1 procedure_return liTo end_function procedure set highlight_state integer lbSelectCursorOn local integer liItm forward set highlight_state to lbSelectCursorOn get current_item to liItm set window_color item liItm to (if(lbSelectCursorOn,color.button_highlight,1)) end_procedure procedure exiting set window_color item (current_item(self)) to color.button end_procedure end_object object oBtn2 is a button popup_calendar.btn2 set location to 10 0 relative item_list on_item t.calendar.ok send move_value_out_ok on_item t.calendar.cancel send close_calendar end_item_list set center_state item 0 to DFTRUE set center_state item 1 to DFTRUE set window_color item 0 to color.button set window_color item 1 to color.button procedure set highlight_state integer lbSelectCursorOn local integer liCurrentItem forward set highlight_state to lbSelectCursorOn get current_item to liCurrentItem set window_color item liCurrentItem to (if(lbSelectCursorOn,color.button_highlight,color.button)) end_procedure end_object procedure display_main local integer liDate liMonth liYear lhFocus lbDelegationMode get pdCurrentDate to liDate move (DateSegment(liDate,DS_YEAR)) to liYear move (DateSegment(liDate,DS_MONTH)) to liMonth if (p_current_year(self)<>liYear or p_current_month(self)<>liMonth) begin set p_current_year to liYear set p_current_month to liMonth send fill_list to (oDays(self)) end send display_date to (oBtn1(self)) send display_date to (oWkNumber(self)) send display_date to (oDays(self)) get invoking_object_id to lhFocus if lhFocus gt desktop begin get delegation_mode of lhFocus to lbDelegationMode set delegation_mode of lhFocus to no_delegate_or_error send NotifyPopupCalendarChange to lhFocus liDate set delegation_mode of lhFocus to lbDelegationMode end end_procedure procedure next_year set pdCurrentDate to (DateIncrement(pdCurrentDate(self),DS_YEAR,1)) send display_main end_procedure procedure prev_year set pdCurrentDate to (DateIncrement(pdCurrentDate(self),DS_YEAR,-1)) send display_main end_procedure procedure next_month set pdCurrentDate to (DateIncrement(pdCurrentDate(self),DS_MONTH,1)) send display_main end_procedure procedure prev_month set pdCurrentDate to (DateIncrement(pdCurrentDate(self),DS_MONTH,-1)) send display_main end_procedure procedure next_week set pdCurrentDate to (DateIncrement(pdCurrentDate(self),DS_WEEK,1)) send display_main end_procedure procedure prev_week set pdCurrentDate to (DateIncrement(pdCurrentDate(self),DS_WEEK,-1)) send display_main end_procedure procedure next_day set pdCurrentDate to (DateIncrement(pdCurrentDate(self),DS_DAY,1)) send display_main end_procedure procedure prev_day set pdCurrentDate to (DateIncrement(pdCurrentDate(self),DS_DAY,-1)) send display_main end_procedure procedure go_today local date ldDate sysdate4 ldDate set pdCurrentDate to ldDate send display_main end_procedure property integer invoking_object_id public 0 procedure move_value_out local integer lhFocus lbDelegationMode // if (pExportState(self)) begin get invoking_object_id to lhFocus if lhFocus gt desktop begin get delegation_mode of lhFocus to lbDelegationMode set delegation_mode of lhFocus to no_delegate_or_error send NotifyPopupCalendarSelect to lhFocus (pdCurrentDate(self)) set delegation_mode of lhFocus to lbDelegationMode if (pExportState(self)) begin set value of lhFocus item CURRENT to (pdCurrentDate(self)) set item_changed_state of lhFocus item CURRENT to DFTRUE end end // end end_procedure procedure move_value_out_ok send move_value_out send deactivate end_procedure procedure popup_no_export set pExportState to DFFALSE send popup set pExportState to DFTRUE end_procedure procedure popup local integer lhFocus local date ldDate move (focus(desktop)) to lhFocus send Auto_Locate lhFocus set invoking_object_id to lhFocus get value of lhFocus item current to ldDate ifnot (integer(ldDate)) move (dSysdate()) to ldDate set pdCurrentDate to ldDate send display_main forward send popup end_procedure procedure request_popup local integer lhFocus liType lbDelegationMode liFile liField liItm lbEntryState move (focus(desktop)) to lhFocus if lhFocus gt desktop begin get delegation_mode of lhFocus to lbDelegationMode set delegation_mode of lhFocus to no_delegate_or_error get current_item of lhFocus to liItm get data_file of lhFocus item liItm to liFile get data_field of lhFocus item liItm to liField get entry_state of lhFocus item liItm to lbEntryState // Does not work! set delegation_mode of lhFocus to lbDelegationMode if (liFile and liField and lbEntryState) begin get_attribute df_field_type of liFile liField to liType if liType eq df_date send popup end end end_procedure procedure close_calendar send deactivate end_procedure end_object procedure request_popup_calendar send request_popup to (popup_calendar(self)) end_procedure procedure popup_calendar_no_export send popup_no_export to (popup_calendar(self)) end_procedure #ENDIF // Character-mode function s.calendar returns integer // Backwards compatible!! function_return (popup_calendar(self)) end_function #ENDIF // DATES_INCLUDE_POPUP // Karl, // Structure is as follows, // // //put this code in the top portion of the view code or in the program // code. // // Type SystemTime // field SystemTime.iYear As Word // field SystemTime.iMonth As Word // field SystemTime.iDayOfWeek As Word // field SystemTime.iDay As Word // field SystemTime.iHour As Word // field SystemTime.iMinute As Word // field SystemTime.iSecond As Word // field SystemTime.iMilliseconds As Word // End_Type // // external_function GetSystemTime "GetSystemTime" kernel32.dll Pointer lpGST Returns VOID_TYPE // // //put this code in an onClick or wherever // procedure onclick // local integer iRetVal // local string TimeData // local pointer GST // // ZeroType SystemTime to TimeData // getAddress from TimeData to GST // // move (GetSystemTime(GST)) to iRetVal // end_procedure // // To extract the data from the Structure after calling the function use // the getbuff command as follows: // // getbuff from TimeData as SystemTime.IVAL to var // // where IVAL is one of the vars such as iYear or iDay, etc. // // OLIVER NELSON // //