Busca un nombre de campo en una tabla

Buscar un nombre de campo en una tabla y retorna .T. si tuvo exito.

*--------------------------------------------------------
* FUNCTION FindField(lcCampo, lcAlias)
*--------------------------------------------------------
* Busca un nombre de campo en una tabla y retorna .T. si tuvo exito.
* USO: ? FindField("MiCampo", "MiAlias")
*      ? FindField("MiCampo") && Busca en el alias corriente
*--------------------------------------------------------
FUNCTION FindField(lcCampo, lcAlias)
  LOCAL ln
  IF EMPTY(lcAlias)
    lcAlias = ALIAS()
  ENDIF
  IF USED(lcAlias)
    ln = AFIELDS(MiArray, lcAlias)
    IF ln > 0
      ln = ASCAN(MiArray, UPPER(lcCampo))
    ENDIF
  ELSE
    ln = 0
    MESSAGEBOX("El alias no existe.",16)
  ENDIF
  RETURN ln 
ENDFUNC

Luis María Guayán

Calcular el domingo de pascua de un año

Con esta función podemos conocer la fecha del Domingo de Pascua de cualquier año.

*---------------------------------------------------------------
* FUNCTION _Pascua(tnAnio)
*---------------------------------------------------------------
* USE: _Pascua(1999)
* PARAMETRO: Año a calcular
* RETORNO: Fecha del Domingo de Pascua
*---------------------------------------------------------------
FUNCTION _Pascua(tnAnio)
  LOCAL lnCentena, lnAux, lnNroAureo, lnDomingo, lnEpactaJul, ;
    lnCorrSolar, lnCorrLunar, lnEpactaGreg, lnDiasLunaP, ;
    lnDiasLuna15, lnDiasPascua, ldFecIni, ldFecPascua

  IF NOT BETWEEN(tnAnio,1000,9999)
    MESSAGEBOX("Rango inválido [1000..9999]")
    RETURN {//}
  ENDIF

  lnCentena = INT(tnAnio / 100)
  lnAux = (tnAnio + 1) % 19
  lnNroAureo = lnAux + (19 * INT((19 - lnAux) / 19))
  lnDomingo = 7 + (1 - tnAnio - INT(tnAnio / 4) + lnCentena - INT(lnCentena / 4)) % 7
  lnEpactaJul = ((11 * lnNroAureo) - 10) % 30
  lnCorrSolar = - (lnCentena - 16) + INT((lnCentena- 16) / 4)
  lnCorrLunar = INT((lnCentena - 15 - INT((lnCentena - 17) / 25)) / 3)
  lnEpactaGreg = (30 + lnEpactaJul + lnCorrSolar + lnCorrLunar) % 30
  lnDiasLunaP = 24 - lnEpactaGreg + (30 * INT(lnEpactaGreg / 24))
  lnDiasLuna15 = (27 - lnEpactaGreg + (30 * INT(lnEpactaGreg / 24))) % 7
  lnDiasPascua = lnDiasLunaP + (7 + lnDomingo - lnDiasLuna15) % 7
  ldFecIni = DATE(tnAnio, 03, 21)
  ldFecPascua = ldFecIni + lnDiasPascua
  RETURN ldFecPascua
ENDFUNC

En que metodo pongo formatos especiales condicionados

En que metodo pongo formatos especiales condicionados, por ejemplo colores en funcion de su Value.

Trabajando con los textbox puede surgir la necesidad de ponerle un formato especial en función de que su valor (por ejemplo ponerlos en rojo, cuando su valor sea negativo).

Surge la duda de en que metodos poner el codigo para colorearlos, Valid, Refresh, ... ¿se me quedo alguno? ¿Como lo hago todo mas sencillo? ¿Tengo que repetir todo esto es cada texbox?

Bueno, lo primero pensar que deberiamos tener redefinida la clase estandard texbox (o aun mejor todas las clases visuales), y nuestros texbox hacerlos que dependieran de nuestras nuevas clases redefinidas, de tal manera que cuando hagamos un cambio en la clase cs_textbox (mi ejemplo), este se realice en todos los que usemos.

Trabajando con VFP6 + SP3, se podria estar tentado en utilizar el metodo value_assign, que es ejecutado cada vex que el valor de un textbox cambia, pero el metodo assign todavia tiene diversos bugs y problemas, como mas gordo citar que si se pone codigo en un value_assign (a nivel de clase), cualquier textbox de esa clase que usemos nos va a decir que se han realizado cambios en el (GETFLDSTATE), por tanto descartado el assign.

Los metodos a modificar son los siguientes:

• InteractiveChange - Se modifica el valor con el raton
• ProgrammaticChange - Se modifica el valor por codigo
• Refresh - Se actualiza un textbox vinculado a datos (p.ejemplo con un SKIP)

En el ejemplo que estamos tratando, tambien creo un metodo a nivel de la clase texbox, por ejemplo llamado AnyChange y desde los tres metodos anteriores llamo a este AnyChange.

El codigo del AnyChange es:

IF VARTYPE(this.value)="N"
  this.forecolor = IIF(this.value < 0, RGB(255,0,0),0)
  this.disabledforecolor = IIF(this.value < 0,RGB(255,0,0),0)
ENDIF

Es decir si el valor es numerico y negativo lo pone en rojo.

Pablo Roca

Calcular la diferencia entre dos fechas en años, meses y días

Función para calcular la cantidad de años, meses y días entre dos variables tipo Date.

*-----------------------------------------------------
* FUNCTION Dif_AMD(tdIni, tdFin)
*-----------------------------------------------------
* Calcula la diferencia entre dos fechas en:
* años, meses y días
* Usa la función DiasDelMes()
*-----------------------------------------------------
FUNCTION Dif_AMD(tdIni, tdFin)
  LOCAL ldAux, lnAnio, lnMes, lnDia, lcRet
  *--- Fecha inicial siempre menor
  IF tdIni>tdFin
    ldAux = tdIni
    tdIni = tdFin
    tdFin = ldAux
  ENDIF
  lnAnio = YEAR(tdFin) - YEAR(tdIni)
  ldAux = GOMONTH(tdIni, 12 * lnAnio)
  *--- No cumplio el año aun
  IF ldAux > tdFin
    lnAnio = lnAnio - 1
  ENDIF
  lnMes = MONTH(tdFin) - MONTH(tdIni)
  IF lnMes < 0
    lnMes = lnMes + 12
  ENDIF
  lnDia = DAY(tdFin) - DAY(tdIni)
  IF lnDia < 0
    lnDia = lnDia + DiasDelMes(tdIni)
  ENDIF
  *--- Si el dia es mayor, no cumplio el mes
  IF (DAY(tdFin) < DAY(tdIni))
    IF lnMes = 0
      lnMes = 11
    ELSE
      lnMes = lnMes - 1
    ENDIF
  ENDIF
  lcRet = ALLTRIM(STR(lnAnio))+ " AÑOS, " + ;
    ALLTRIM(STR(lnMes))+ " MESES Y " + ;
    ALLTRIM(STR(lnDia))+ " DIAS."
  RETURN lcRet
ENDFUNC
*-----------------------------------------------------
* FUNCTION DiasDelMes(dFecha)
*------------------------------------------------
* Retorna los días de un mes. Usada por Dif_AMD
*------------------------------------------------
FUNCTION DiasDelMes(dFecha)
  LOCAL ld
  ld = GOMONTH(dFecha,1)
  RETURN DAY(ld - DAY(ld))
ENDFUNC

Luis María Guayán

Proteger y ocultar el codigo fuente de las clases

Haz una copia de los archivos VCX y VCT

COMPILE CLASSLIB libreriadeclases
USE libreriadeclases.vcx EXCLUSIVE
REPLACE ALL Methods WITH ""
USE

Esto eliminara todo el codigo fuente de un VCX. Si alguien intenta modificar un procedimiento entonces todas las clases dejarn de funcionar, ya que no hay codigo fuente a compilar.

Pablo Roca

Crear un fichero de Log que nunca se llena

No se llena pero tiene un tamaño máximo, guarda lo mas nuevo

**********************************************************************
*
* Funcion: LOG_GRAB
*
* Graba una linea en el log (en raizLOG.TXT)
*
* Parametros:
*
*  tcTexto   - texto a grabar
*
* Ejemplos:
*
*   ret = LOG_GRAB("Inicio de Programa")
*
* Retorno:
*
*        .T.    Grabacion correcta
*        .F. Error en la grabacion
*
* Nota:
*
**********************************************************************

FUNCTION LOG_GRAB

PARAMETERS tcTexto
LOCAL plRet, pnFich, pnFichn, pnFtama, pnTammax, pnLongAc
LOCAL pcChar, pnPos
plRet    = .T.
pnLongAc = 0
pnTammax = 30000  && tamaño maximo
pnFtama = 0

IF FILE(SYS(5)+SYS(2003)+'log.txt')    && ¿Existe el archivo? 
 pnFich = FOPEN(SYS(5)+SYS(2003)+'log.txt',12) && Sí: abrir lect./escrit.
 pnFtama=FSEEK(pnFich, 0, 2)      && Mueve el puntero a EOF
             && y devuelve el tamaño
ELSE
 pnFich = FCREATE(SYS(5)+SYS(2003)+'log.txt') && Si no, crearlo
ENDIF
IF pnFich < 0          && Comprobar el error
             && abriendo el archivo
 plRet = .F.
 WAIT 'No puedo abrir o crear el archivo de salida (fich)' WINDOW NOWAIT
ELSE             && Si no hay error, 
             && escribir en el archivo
 IF pnFtama > pnTammax       && Si el tamaño es mayor que el max
  pnFichn = FCREATE(SYS(5)+SYS(2003)+'logn.txt')  && Crear nuevo log
  IF pnFichn < 0
   WAIT 'No puedo abrir o crear el archivo de salida (fichn)' WINDOW NOWAIT
  ELSE
   pnPos = FSEEK(pnFich, -(pnTammax - 256), 1)
   pcChar = FREAD(pnFich, 1)
   DO WHILE pcChar <> CHR(10)
    pcChar = FREAD(pnFich, 1)
   ENDDO
   pnPos = FSEEK(pnFich, 0, 1)
   DO WHILE NOT(FEOF(pnFich))
    = FPUTS(pnFichn,FGETS(pnFich))
   ENDDO
   =FCLOSE(pnFich)
   =FCLOSE(pnFichn)
   DELETE FILE SYS(5)+SYS(2003)+'log.txt'
   RENAME SYS(5)+SYS(2003)+'logn.txt' TO SYS(5)+SYS(2003)+'log.txt'
   pnFich = FOPEN(SYS(5)+SYS(2003)+'log.txt',12)
   pnFtama=FSEEK(pnFich, 0, 2)
  ENDIF
 ENDIF
 =FWRITE(pnFich, DTOC(DATE())+CHR(9))
 =FWRITE(pnFich, TIME()+CHR(9))
 =FWRITE(pnFich, tcTexto+CHR(13)+CHR(10))
ENDIF
=FCLOSE(pnFich)          && Cerrar archivo

RETURN plRet

Pablo Roca

Función API me retorna el directorio de archivos temporales de Windows

Función que retorna la carpeta de archivos temporales de Windows.

*--------------------------------------------
FUNCTION _TempPath
*--------------------------------------------
* Retorna la ruta de los archivos temporales
* con "" al final ("C:\TEMP")
*--------------------------------------------
LOCAL lcPath, lnRet
lcPath = SPACE(255)
lnSize = 255
DECLARE INTEGER GetTempPath IN WIN32API ;
   INTEGER nBufSize, ;
   STRING @cPathName
lnRet = GetTempPath(lnSize, @lcPath)
IF lnRet <= 0
   lcPath = ""
ELSE
   lcPath = SUBSTR(lcPath, 1, lnRet)
ENDIF
RETURN lcPath
ENDFUNC

Luis María Guayán

Parámetros del MESSAGEBOX() no documentados

Existen dos parámetros no documentados de la función MESSAGEBOX(), estos son:

MB_SYSTEMMODAL = 4096
MB_TASKMODAL = 8192

*-- Ejemplo:
inkey(10)
*-- Cambia a cualquier otra ventana
? MESSAGEBOX("AL TOP", 0 + 16 + MB_SYSTEMMODAL, "Aplicación de VFP")

Añadiendo estos valores a los otros que controlan el ícono y estilo de botones, afectaran al modo modal y al ambito del diálogo. Mientras que MB_SYSTEMMODAL tiene muy poco efecto visible sobre el diálogo (sin embargo, hay diferencias internas), MB_TASKMODAL provocará que el diálogo aparezca no solo encima de las ventanas de la aplicación activa, sino que también sobre cualquier ventana de cualquier aplicación.

Ejecutar el sonido predeterminado del sistema

Cómo ejecutar el sonido predeterminado del sistema.

*--------------------------------------------
FUNCTION _MessageBeep(tnSound)
*--------------------------------------------
* Ejecuta el sonido del sistema
* USO: _MessageBeep()
*--------------------------------------------
IF EMPTY(tnSound) OR TYPE("tnSound")    tnSound = 1
ENDIF
DECLARE INTEGER MessageBeep IN WIN32API ;
   INTEGER nSound
=MessageBeep(tnSound)
RETURN
ENDFUNC

Luis María Guayán

Numero de colores soportados

Para poder determinar el numero de colores disponibles, son necesarias tres llamadas a la API de windows: GetDC(), GetDeviceCaps(), and ReleaseDC().

A continuación se muestran las funciones capaces de devolver este valor. Nota: En la version de FoxPro de Windows se debe cargar FOXTOOLS.FLL antes de llamar a la función.

FUNCTION NumColors
* version de 32 bit para uso con
* VFP bajo Win 95 y superiores,
* y Windows NT 3.51 y superiores

DECLARE INTEGER GetDC IN Win32API;
  INTEGER hWnd
DECLARE INTEGER GetDeviceCaps IN Win32API;
  INTEGER hDC, INTEGER nIndex
DECLARE INTEGER ReleaseDC IN Win32API;
  INTEGER hWnd, INTEGER hDC
LOCAL lnresult, lnhDC, lnplanes, lnpixels
lnresult = 0
lnhDC = GetDC(0)
IF lnhDC > 0
  * Get the number of color planes
  lnplanes = GetDeviceCaps(lnhDC, 14)
  * Get the number of bits per pixel
  lnpixels = GetDeviceCaps(lnhDC, 12)
  * Calculate the return value
  lnresult = 2 ^ (lnplanes * lnpixels)
  = ReleaseDC(0, lnhDC)
ENDIF
RETURN lnresult

FUNCTION NumColors
* Para usar con FPW 2.5 y superiores
* y VFP bajo Windows 3.1

PRIVATE m.result, m.getdc, m.getdevcaps,;
  m.releasedc, m.hdc, m.planes, m.pixels
m.result = 0
m.getdc = RegFN('GetDC', 'I', 'I')
m.getdevcaps = RegFN('GetDeviceCaps', 'II', 'I')
m.releasedc = RegFN('ReleaseDC', 'II', 'I')
m.hdc = CallFN(m.getdc, 0)
IF m.hdc > 0
  * Get the number of color planes
  m.planes = CallFN(m.getdevcaps, m.hdc, 14)
  * Get the number of bits per pixel
  m.pixels = CallFN(m.getdevcaps, m.hdc, 12)
  * Calculate the return value
  m.result = 2 ^ (m.planes * m.pixels)
  = CallFN(m.releasedc, 0, m.hdc)
ENDIF
RETURN m.result

Primer día del mes de un día de la semana

Hay algunas ocasiones en las que es útil saber el primer día del mes en el que cae un día de la semana. Por ejemplo en los Estados Unidos el primer lunes de septiembre es vacaciones.

La siguiente función dado un mes y un año devuelve la fecha en la que cae un día de la semana 1 = Domingo, 2 = Lunes,...

* FUNCTION: FirstDay.prg

LPARAMETERS pnmonth, pnyear, pndow

* Parameter list description
* pnmonth numero del mes (1-12)
* pnyear numero del año (en formato cuatro digitos)
* pndow dia de la semana a investigar (Domingo = 1, Lunes = 2, etc.)

LOCAL ldresult, lddate, lndow
lddate = DATE(pnyear, pnmonth, 1)
ldresult = lddate
* Fuerza a VFP 5.0/6.0 a usar el Domingo
* como primer dia de la semana
* Versiones anteriores deberan borrar el parametro
lnfirstday = DOW(lddate, 1)
IF lnfirstday   IF lnfirstday < pndow
    ldresult = lddate + (pndow - lnfirstday)
  ELSE
    ldresult = lddate + (7 + pndow) - lnfirstday
  ENDIF
ENDIF
RETURN ldresult

Ejemplo:
* Saber el primer Lunes de septiembre del año actual.

ldSeptMon = FirstDay(9, YEAR(DATE()), 2)