**************************************************
*-- Class: aasdatepicker (c:\source\aas.vcx)
*-- ParentClass: olecontrol
*-- BaseClass: olecontrol
*-- Time Stamp: 03/08/01 08:18:00 PM
*-- OLEObject = C:\WINNT\system32\MSCOMCT2.OCX
*
DEFINE CLASS aasdatepicker AS olecontrol
Height = 22
Width = 188
Visible = .T.
afhoffset = 0
atoffset = 0
aloffset = 0
ahoffset = 0
awoffset = 0
autoresizetop = .T.
autoresizeleft = .T.
autoresizewidth = .T.
autoresizeheight = .T.
afteststr = "''"
autoresizefont = .T.
lformanychange = .T.
vfpcontrolsource = ('')
realforecolor = 0
afwoffset = 0
Name = "aasdatepicker"
*-- Pass-Through to THIS.OBJECT.Font.Size
fontsize = .F.
*-- FontName -- C -- Pass through to THIS.Object.Font.Name
fontname = .F.
*-- FontBold -- L -- Pass through to THIS.Object.Font.Bold
fontbold = .F.
*-- FontItalic -- C -- Pass through to THIS.Object.Font.Italic
fontitalic = .F.
*-- FontUnderline -- C -- Pass through to THIS.Object.Font.Underline
fontunderline = .F.
PROCEDURE anychange
if THIS.lFormAnyChange
THISFORM.AnyChange
endif
RETURN
ENDPROC
PROTECTED PROCEDURE fontsize_access
RETURN val(str(THIS.Object.Font.Size,10,5))
ENDPROC
PROTECTED PROCEDURE fontsize_assign
LPARAMETERS vNewVal
THIS.FontSize = m.vNewVal
THIS.Object.Font.Size = m.vNewVal
ENDPROC
PROTECTED PROCEDURE fontname_access
RETURN THIS.Object.Font.Name
ENDPROC
PROTECTED PROCEDURE fontname_assign
LPARAMETERS vNewVal
THIS.FontName = m.vNewVal
THIS.Object.Font.Name = m.vNewVal
ENDPROC
PROTECTED PROCEDURE fontbold_access
RETURN THIS.Object.Font.Bold
ENDPROC
PROTECTED PROCEDURE fontbold_assign
LPARAMETERS vNewVal
THIS.FontBold = m.vNewVal
THIS.Object.Font.Bold = m.vNewVal
ENDPROC
PROTECTED PROCEDURE fontitalic_access
RETURN THIS.Object.Font.Italic
ENDPROC
PROTECTED PROCEDURE fontitalic_assign
LPARAMETERS vNewVal
THIS.FontItalic = m.vNewVal
THIS.Object.Font.Italic = m.vNewVal
ENDPROC
PROTECTED PROCEDURE fontunderline_access
RETURN THIS.Object.Font.Underline
ENDPROC
PROTECTED PROCEDURE fontunderline_assign
LPARAMETERS vNewVal
THIS.FontUnderline = m.vNewVal
THIS.Object.Font.Underline = m.vNewVal
ENDPROC
PROCEDURE KeyPress
*** ActiveX Control Event ***
LPARAMETERS KeyAscii
LOCAL ldNewDate, lnDay, lnMon, lnYr, ldDate, nKeyCode
nKeyCode = KeyAscii
ldDate = THIS.Object.Value
if VarType(ldDate)='T'
ldDate = TTOD(ldDate)
endif
WAIT WINDOW NOWAIT str(nKeyCode)
do case
case InList(nKeyCode,43,61) && +,=
KeyAscii = 0
NODEFAULT
THIS.object.Value = iif( empty(ldDate), Date(), ldDate+1 )
THIS.Change()
THIS.Refresh()
case inList(nKeyCode,95,45) && -
KeyAscii = 0
NODEFAULT
THIS.object.Value = iif( empty(ldDate), Date(), ldDate-1 )
THIS.Change()
THIS.Refresh()
* Inc/Dec by Month
case Inlist(nKeyCode,91,123,93,125) && [ and ] key
KeyAscii = 0
NODEFAULT
if empty(ldDate) or isNull(ldDate)
ldNewDate = Date()
else
lnDay = Day( ldDate )
lnMon = Month( ldDate )
lnYr = Year( ldDate )
if inList(nKeyCode,93,125) && ] key
if lnMon=12
lnMon = 1
lnYr = lnYr+1
else
lnMon = lnMon + 1
endif
else && nKeyCode=91,123 && [ key
if lnMon=1
lnMon = 12
lnYr = lnYr-1
else
lnMon = lnMon - 1
endif
endif
* Take care of days # 29,30,31 for months that are shorter
do while (lnDay > 28) ;
and Date(lnYr,lnMon,lnDay)={}
lnDay = lnDay - 1
enddo
ldNewDate = Date(lnYr,lnMon,lnDay)
endif
if type('ldNewDate')='D' and ldNewDate<>{}
THIS.object.Value = ldNewDate
endif
THIS.Change()
THIS.Refresh()
* Inc/Dec by Year
case nKeyCode=123 ;
or nKeyCode=125 && { and } key
KeyAscii = 0
NODEFAULT
if empty(ldDate) or Isnull(ldDate)
ldNewDate = Date()
else
lnDay = Day( ldDate )
lnMon = Month( ldDate )
lnYr = Year( ldDate )
if nKeyCode=125 && } key
lnYr = lnYr+1
else && nKeyCode=123 && { key
lnYr = lnYr-1
endif
* Take care of days # 29,30,31 for months that are shorter
do while (lnDay > 28) ;
and Date(lnYr,lnMon,lnDay)={}
lnDay = lnDay - 1
enddo
ldNewDate = Date(lnYr,lnMon,lnDay)
endif
if type('ldNewDate')='D' and ldNewDate<>{}
THIS.object.Value = ldNewDate
endif
THIS.Refresh()
THIS.Change()
endcase
RETURN
ENDPROC
PROCEDURE Init
THIS.RealForeColor = THIS.CalendarForeColor
RETURN
ENDPROC
PROCEDURE Refresh
*** ActiveX Control Method ***
if type(THIS.vfpControlSource)='D'
if eval(THIS.vfpControlSource)={}
THIS.Object.Value = DATE() && GTWv9.34.5 wgcs
THIS.Object.Value = .NULL.
else
THIS.Object.Value = eval(THIS.vfpControlSource)
endif
endif
ENDPROC
PROCEDURE Change
*** ActiveX Control Event ***
if IsNull(THIS.Object.Value)
THISFORM.UpdateValue(THIS.vfpControlSource,{},THIS)
THIS.CalendarForeColor = THIS.CalendarBackColor
else
*v9.34 THISFORM.UpdateValue(THIS.vfpControlSource,THIS.Object.Value,THIS)
*GTv9.34..Make sure we return a DATE type
THISFORM.UpdateValue(THIS.vfpControlSource,TToD(THIS.Object.Value),THIS)
THIS.CalendarForeColor = THIS.RealForeColor
endif
THIS.AnyChange
RETURN
*TTv9.34 LOCAL lcVar, llMem
*TTv9.34 lcVar = Upper(THIS.vfpControlSource)
*TTv9.34 if type(lcVar)='D'
*TTv9.34 if not '.' $ lcVar or ;
*TTv9.34 Left(lcVar,2)='M.' or ;
*TTv9.34 Left(lcVar,5)='THIS.' or ;
*TTv9.34 Left(lcVar,9)='THISFORM.'
*TTv9.34 llMem = .T.
*TTv9.34 else
*TTv9.34 llMem = .F.
*TTv9.34 endif
*TTv9.34 if IsNull(THIS.Object.Value)
*TTv9.34 if llMem
*TTv9.34 &lcVar = {}
*TTv9.34 else
*TTv9.34 REPLACE &lcVar with {}
*TTv9.34 endif
*TTv9.34 THIS.CalendarForeColor = THIS.CalendarBackColor
*TTv9.34 else
*TTv9.34 if llMem
*TTv9.34 &lcVar = THIS.Object.Value
*TTv9.34 else
*TTv9.34 REPLACE &lcVar with THIS.Object.Value
*TTv9.34 endif
*TTv9.34 THIS.CalendarForeColor = THIS.RealForeColor
*TTv9.34 endif
*TTv9.34 endif
*TTv9.34 THIS.AnyChange
*TTv9.34 RETURN
ENDPROC
PROCEDURE Error
LPARAMETERS nError, cMethod, nLine
if nError=1429
* IGNORE
*v9.24w if THIS.CheckBox
*v9.24w THIS.Object.Value = .Null.
*v9.24w endif
RETURN
else
PRIVATE pcClassError
pcClassError = 'ERROR'
lcErr = upper(On('ERROR'))
lcErr = StrTran(lcErr, 'ERROR()', 'nError')
lcErr = StrTran(lcErr, 'LINE()', 'nLine')
&lcErr
do case
case pcClassError='RETRY'
RETRY
case pcClassError='IGNORE'
RETURN
endcase
RETURN
endif
ENDPROC
ENDDEFINE
*
*-- EndDefine: aasdatepicker
**************************************************