Es la la famosa clase de Juan Galvez TBmpGet, con algunas mejoras entre ellas :
Ahora con un click Derecho nos muestra un Calendario del cual podemos seleccionar una fecha, con la opción de ir recorriendo los meses del año
por medio de un boton.
Tambien estoy por incluir la calculadora con un funcionamiento similar al del calendario.
Saludos y espero le sirva
Joel Andujo
PD Uso FWh24, xHarbour Build 0.99.50 (SimpLex)
Code: Select all
************************************************************************
* *
* Clase : TBmpGet *
* Autor : Juan Gálvez - soporte@dsgsoftware.com *
* Fecha : 10-09-2001 *
* *
* Agiliza la implementación de la original idea de Jorge Mason Salinas *
* de insertar un bitmap en el interior de un get con el fin de evaluar *
* un bloque de código que nos permita seleccionar su valor. *
* *
* ----------- 31/10/2001 ---------- *
* -> Compatibilidad con uso de Spinner *
* -> Nueva variable de instancia ::oBmpCursor con el cursor del bitmap *
* *
* ----------- 20/01/2003 ---------- *
* -> Repintado del bitmap gris si el get está deshabilitado *
* -> Cursor HAND defecto en bitmap *
* *
* ----------- 16-Ene/2006 *
* -> Se Agrego un Método DatePick al pulsar el Botón Der. del Mouse *
* -> Joel Armando Andujo Medina (JAAM) *
*************************************************************************
#include 'FiveWin.ch'
#include 'BmpGet.ch'
#define GWL_STYLE -16
CLASS TBmpGet FROM TGet
CLASSDATA lFocusClr AS LOGICAL INIT .t.
DATA cResName, cBmpFile, bAction, bBmpAction, oBmp, oBmpCursor
DATA nClrPFoText , nClrPFoPane, nClrDef
DATA nClrFocusText, nClrFocusPane // added. There were erased from FW 2.2c JAAM
DATA nFireKey // key to start edition, defaults to VK_F11 JAAM
DATA dFecha // Fecha inicial del Calendario JAAM
DATA cTipoVar // Tipo de la Variable que estamos Leyendo JAAM
METHOD New( nRow, nCol, bSetGet, oWnd, nWidth, nHeight, cPict, bValid,;
nClrFore, nClrBack, oFont, lDesign, oCursor, lPixel,;
cMsg, lUpdate, bWhen, lCenter, lRight, bChanged,;
lReadOnly, lPassword, lNoBorder, nHelpId,;
lSpinner, bUp, bDown, bMin, bMax,;
cResName, cBmpFile, bAction, oBmpCursor ) CONSTRUCTOR
METHOD ReDefine( nId, bSetGet, oWnd, nHelpId, cPict, bValid,;
nClrFore, nClrBack, oFont, oCursor, cMsg,;
lUpdate, bWhen, bChanged, lReadOnly,;
lSpinner, bUp, bDown, bMin, bMax,;
cResName, cBmpFile, bAction, oBmpCursor ) CONSTRUCTOR
METHOD ClassName() INLINE Super:ClassName()
METHOD Default()
METHOD Initiate( hDlg ) INLINE Super:Initiate( hDlg ), ::Default()
METHOD SetIniClr()
METHOD KeyDown( nKey, nFlags )
METHOD SetBitmap( cResName, cBmpFile, bAction, oBmpCursor )
METHOD DelBitmap()
METHOD RemoveClr()
METHOD RButtonDown( nRow, nCol, nFlags ) // Jaam
METHOD Calendario() // Jaam
METHOD ShowMes(oDlgCald) // Jaam
METHOD SetVal() // Jaam
END CLASS
//----------------------------------------------------------------------------//
METHOD New( nRow, nCol, bSetGet, oWnd, nWidth, nHeight, cPict, bValid,;
nClrFore, nClrBack, oFont, lDesign, oCursor, lPixel,;
cMsg, lUpdate, bWhen, lCenter, lRight, bChanged,;
lReadOnly, lPassword, lNoBorder, nHelpId,;
lSpinner, bUp, bDown, bMin, bMax,;
cResName, cBmpFile, bAction, oBmpCursor ) CLASS TBmpGet
Super:New( nRow, nCol, bSetGet, oWnd, nWidth, nHeight, cPict, bValid,;
nClrFore, nClrBack, oFont, lDesign, oCursor, lPixel,;
cMsg, lUpdate, bWhen, lCenter, lRight, bChanged, ;
lReadOnly, lPassword, lNoBorder, nHelpId,;
lSpinner, bUp, bDown, bMin, bMax )
::cResName := cResName
::cBmpFile := cBmpFile
::bAction := bAction
::oBmpCursor := oBmpCursor
if ::lFocusClr
::SetIniClr()
endif
RETURN Self
//----------------------------------------------------------------------------//
METHOD ReDefine( nId, bSetGet, oWnd, nHelpId, cPict, bValid,;
nClrFore, nClrBack, oFont, oCursor, cMsg,;
lUpdate, bWhen, bChanged, lReadOnly,;
lSpinner, bUp, bDown, bMin, bMax,;
cResName, cBmpFile, bAction, oBmpCursor ) CLASS TBmpGet
Super:ReDefine( nId, bSetGet, oWnd, nHelpId, cPict, bValid,;
nClrFore, nClrBack, oFont, oCursor, cMsg,;
lUpdate, bWhen, bChanged, lReadOnly,;
lSpinner, bUp, bDown, bMin, bMax )
::cResName := cResName
::cBmpFile := cBmpFile
::bAction := bAction
::oBmpCursor := oBmpCursor
if ::lFocusClr
::SetIniClr()
endif
RETURN Self
//----------------------------------------------------------------------------//
METHOD Default() CLASS TBmpGet
LOCAL nStyle, nTop, nLeft
IF ! Empty( ::bAction ) .AND. (! Empty( ::cResName ) .OR. ! Empty( ::cBmpFile ))
// Leemos bitmap para fijar posición en función del tamaño y alineación
::oBmp := TBitmap():Define( ::cResName, ::cBmpFile, Self )
// Obtenemos estilo del get
nStyle := GetWindowLong( ::hWnd, GWL_STYLE )
// Determinamos Top del bitmap sobre el get
nTop := Min( 2, Int( (::nHeight - ::oBmp:nHeight) / 2 ) )
// Determinamos Left del bitmap sobre el get
IF lAnd( nStyle, ES_RIGHT )
nLeft := 2
ELSEIF ::nHeight > ::oWnd:nHeight - 5 // Edicion por linea de browse
nLeft := ::nWidth - ::oBmp:nWidth - 1
ELSEIF lAnd( nStyle, WS_VSCROLL )
nLeft := ::nWidth - ::oBmp:nWidth - 22
::bResized := {|| ::oBmp:nLeft := ::nWidth - ::oBmp:nWidth - 22 }
ELSE
nLeft := ::nWidth - ::oBmp:nWidth - 5
::bResized := {|| ::oBmp:nLeft := ::nWidth - ::oBmp:nWidth - 5 }
ENDIF
::oBmp:End()
// Si el VALID del objeto al que le quitamos el foco da .F., se lanza un nuevo
// SetFocus() sobre el que hay que procesar con SysRefresh para que las
// ::lFocused de los controles esten actualizadas
::bBmpAction := {|| ::SetFocus(), SysRefresh(), If( ::lFocused, Eval( ::bAction, Self ), ) }
DEFAULT ::oBmpCursor := TCursor():New( , 'HAND' )
::oBmp := TBitmap():New( nTop, nLeft,,, ::cResName, ::cBmpFile, .T., Self,;
::bBmpAction,,,, ::oBmpCursor,,,, .T. )
::oBmp:bPainted := {|| If( ::lActive, ,;
(DrawGray( ::GetDC(), ::oBmp:hBitmap, ::oBmp:nTop, ::oBmp:nLeft ),;
::ReleaseDC()) ) }
ENDIF
RETURN NIL
METHOD SetIniClr() CLASS TBmpGet
::nClrFocusText := nRGB(0,0,0)
::nClrFocusPane := nRGB(243,250,200) // Amarillito // nRGB(255,255,255)= Sin Color
::nClrPFoText := ::nClrText
::nClrPFoPane := ::nClrPane
//
::bGotFocus := {|| ::SetColor( ::nClrFocusText, ::nClrFocusPane) }
::bLostFocus := {|| ::SetColor( ::nClrPFoText , ::nClrPFoPane ) }
Return Self
METHOD RemoveClr() CLASS TBmpGet
::SetColor( ::nClrText, ::nClrPane )
::bGotFocus := nil
::bLostFocus := nil
Return Nil
//----------------------------------------------------------------------------//
METHOD KeyDown( nKey, nFlags ) CLASS TBmpGet
local nFireKey := ::nFireKey // JAAM
Default nFireKey := VK_F11 // JAAM
IF nKey == nFireKey .AND. ! Empty( ::bAction )
RETURN Eval( ::bAction, Self )
ENDIF
RETURN Super:KeyDown( nKey, nFlags )
//----------------------------------------------------------------------------//
METHOD SetBitmap( cResName, cBmpFile, bAction, oBmpCursor ) CLASS TBmpGet
IF ! Empty( ::oBmp )
::oBmp:End()
ENDIF
::cResName := cResName
::cBmpFile := cBmpFile
::bAction := bAction
::oBmpCursor := oBmpCursor
::Default()
::Refresh()
RETURN NIL
//----------------------------------------------------------------------------//
METHOD DelBitmap() CLASS TBmpGet
IF ! Empty( ::oBmp )
::oBmp:End()
ENDIF
::cResName := ''
::cBmpFile := ''
::bAction := NIL
::oBmpCursor := NIL
RETURN NIL
//----------------------------------------------------------------------------//
METHOD RButtonDown( nRow, nCol, nFlags ) CLASS TBmpGet
local oMenu, oClp
local nLo, nHi
local oThis := Self
::GetSelPos( @nLo, @nHi )
if GetFocus() != ::hWnd
::SetFocus()
SysRefresh() // In case there is a VALID somewhere
if GetFocus() != ::hWnd
return nil
endif
endif
::dFecha :=Date() // Fecha inicial del Calendario JAAM
::cTipoVar:=valtype(::oGet:Original) // Tipo de la Varialble que estamos Leyendo JAAM
if ::cTipoVar='D'
::Calendario()
retu nil
endi
DEFINE CLIPBOARD oClp OF Self FORMAT TEXT
MENU oMenu POPUP
MENUITEM 'Ca&lendario' ACTION ::Calendario()
MENUITEM 'Calc&uladora' ACTION ::UnDo()
if ::lReadOnly .or. ::GetText() == cValToChar( ::oGet:Original )
MENUITEM '&Deshacer' ACTION ::UnDo() disabled
else
MENUITEM '&Deshacer' ACTION ::UnDo()
endif
SEPARATOR
if ::lReadOnly .or. nLo == nHi
MENUITEM 'Cor&tar' ACTION ::Cut() disabled
else
MENUITEM 'Cor&tar' ACTION ::Cut()
endif
if nLo != nHi
MENUITEM '&Copiar' ACTION ::Copy()
else
MENUITEM '&Copiar' ACTION ::Copy() disabled
endif
if ! Empty( oClp:GetText() ) .and. !::lReadOnly
MENUITEM '&Pegar' ACTION ::Paste()
else
MENUITEM '&Pegar' ACTION ::Paste() DISABLED
endif
if ::lReadOnly .or. nLo == nHi
MENUITEM '&Borrar' action nil disabled
else
MENUITEM '&Borrar' ACTION If( nHi != nLo,;
( ::GetDelSel( nLo, nHi ), ::EditUpdate() ),)
endif
SEPARATOR
MENUITEM 'Selecionar &Todo' ACTION ::SelectAll()
ENDMENU
ACTIVATE POPUP oMenu AT nRow - 60, nCol OF Self
return 0 // Message already processed
*----------------------------*
METHOD Calendario() CLASS TBmpGet
local nRen, aCol, nNumDia:=0, lPVez:=.t.
DEFINE DIALOG oDlgCald FROM ::nTop+198,::nLeft+228 to ::nTop+373,::nLeft+413 TITLE Mes(::dFecha)+' DE '+str(year(::dFecha),4) PIXEL
*--// Dibujo los botones (Días del Mes)
nRen:=25
aCol:={05,17,29,41,53,65,77}
for i:=1 to 42
nNumDia++
@nRen,aCol[nNumDia] BUTTON strzero(i,2) SIZE 10,08 of oDlgCald ACTION msginfo() pixel update
if nNumDia=7
nRen+=10
nNumDia:=0
endi
next
@10,003 GROUP oGpo TO 021,90 of oDlgCald PIXEL
@15,004 SAY 'Dom Lun Mar Mie Jue Vie Sab' of oDlgCald SIZE 86,06 PIXEL
@01,005 BUTTONBMP PROMPT 'Mes &Anterior' SIZE 36,09 of oDlgCald ACTION ::ShowMes(-1, oDlgCald) PIXEL update
@01,052 BUTTONBMP PROMPT 'Mes &Siguiente' SIZE 36,09 of oDlgCald ACTION ::ShowMes(+1, oDlgCald) PIXEL update
ACTIVATE DIALOG oDlgCald ON PAINT if(lPVez,(::ShowMes(0, oDlgCald),lPVez:=.f.), )
retu nil
*----------------------------*
METHOD ShowMes(nAvance, oDlg) CLASS TBmpGet
local nMesAnt:=0 , nAnoAnt:=0 , nUltAnt:=0 , nDiaSem , nNumDia:=1, nDiaSigMes:=1,;
nMesAct:=month(::dFecha), nAnoAct:=year(::dFecha), nDiaAct:=day(::dFecha), nUltAct:=0, oFont2 ,;
oFont1:=oDlg:oFont
*--// Incremento o Disminuyo el Mes a Mostrar
nMesAct:=nMesAct+nAvance
if nMesAct<1
nMesAct:=12
nAnoAct--
endi
if nMesAct>12
nMesAct:=1
nAnoAct++
endi
oDlg:cTitle:=Mes(nMesAct)+' DE '+str(nAnoAct,4)
nUltAct:=UltDia(ctod('01/'+str(nMesAct)+'/'+str(nAnoAct)))
if (nDiaAct>nUltAct)
nDiaAct:=nUltAct
endi
::dFecha:=ctod('01/'+str(nMesAct)+'/'+str(nAnoAct))
*--// Día de la Semana del 1ro del Mes (Domingo=1, Lunes=2, Martes=3,...)
nDiaSem :=dow(::dFecha)
::dFecha:=ctod(str(nDiaAct)+'/'+str(nMesAct)+'/'+str(nAnoAct))
*--// Tomo el Último día del mes Aterior
nMesAnt:=nMesAct-1
nAnoAnt:=nAnoAct
if nMesAnt<1
nMesAnt:=12
nAnoAnt--
endi
if nMesAnt>12
nMesAnt:=1
nAnoAnt++
endi
nUltAnt:=UltDia(ctod('01/'+str(nMesAnt)+'/'+str(nAnoAnt)))
*--// Muestro los Botones (Días del Mes anterior, en proceso y Siguiente)
DEFINE Font oFont2 NAME 'COURIER NEW' SIZE 10, 14 BOLD
for i:=1 to 42
*--// Días en Proceso
if i>=nDiaSem .and. i<=(nUltAct+nDiaSem)-1
oDlg:aControls[i]:Enable()
*--// Día Actual o Domingos
if (nNumDia=nDiaAct).or.(i=1).or.(i=8).or.(i=15).or.(i=22).or.(i=29).or.(i=36)
oDlg:aControls[i]:SetFont(oFont2)
if (nNumDia=nDiaAct)
oDlg:aControls[i]:Setfocus()
endi
else
oDlg:aControls[i]:SetFont(oFont1)
endi
oDlg:aControls[i]:cTitle:=strzero(nNumDia++,2)
oDlg:aControls[i]:bAction:=GenBlock( oDlg, i, Self )
else
*--// Días del Siguiente Mes
if i>=(nUltAct+nDiaSem)
oDlg:aControls[i]:cTitle:=strzero(nDiaSigMes++,2)
else
*--// Días del Mes Anterior
oDlg:aControls[i]:cTitle:=str((nUltAnt-nDiaSem+1)+i,2)
endi
oDlg:aControls[i]:Disable()
endi
next
oDlg:refresh()
oFont1:end()
oFont2:end()
retu nil
*----------------------------*
METHOD SetVal(cDay) CLASS TBmpGet
local nMesAct:=month(::dFecha), nAnoAct:=year(::dFecha)
do case
case ::cTipoVar='D' ; ::cText:=ctod(cDay+'/'+strzero(nMesAct,2)+'/'+str(nAnoAct,4))
case ::cTipoVar$'CM'; ::cText:=left(cDay+'/'+strzero(nMesAct,2)+'/'+str(nAnoAct,4),len(::cText))
endc
::Refresh()
retu Nil
*----------------------------*
stat function GenBlock( oDlg, i, Self )
return {|nId| (::SetVal(oDlg:aControls[i]:cTitle), oDlg:end()) }
*----------------------------*
stat function Mes(uFecha)
local cMeses :='Enero Febrero Marzo Abril Mayo Junio '+;
'Julio Agosto SeptiembreOctubre Noviembre Diciembre '
if valtype(uFecha)='D'; retu(alltrim(subs(cMeses,month(uFecha)*10-9,10)))
else ; retu(alltrim(subs(cMeses,uFecha *10-9,10)))
endi
retu ''
*----------------------------*
stat function UltDia(dFec)
local nUltDia:=0, nAno:=year(dFec), nMes:=month(dFec), nDia:=0, dFecha:=''
Default dFec:=ctod('')
for nDia:=28 to 31
dFecha:=ctod(strzero(nDia,2)+'/'+strzero(nMes,2)+'/'+str(nAno,4))
if empty(dtos(dFecha))
exit
endi
nUltDia:=nDia
next
retu nUltDia