1 de diciembre de 2000

La función SYS(2015) y su inversa

Autor: Luis María Guayán

La función SYS(2015)

En Visual FoxPro, con la función SYS(2015), podemos devolver una cadena "única" de 10 caracteres que puede ser utilizada como nombre de procedimiento, función o archivo. Esta cadena comienza con un guión bajo "_" y continua con una combinación de 9 caracteres de números y letras, y se crea a partir de la fecha y de la hora del sistema. Si llamamos repetidamente a la función SYS(2015) devolverá una cadena de caracteres única por cada intervalo de milisegundos.

El formato de la cadena devuelta por SYS(2015) es el siguiente:

_DDDSSSSSS

en donde:

_: Caracter de guión bajo con el que comienza la cadena.

DDD: Es el número de días transcurridos desde el "01/01/00".La función SYS(2015) tiene dos curiosas caracteristicas:a. No tiene en cuenta la centuria, o sea que solo toma años entre 00 y 99. Toma a todos los años de 367 días, o sea que para:1 de Enero del '00 = 12 de Enero del '00 = 2...1 de Enero del '01 = 368... etc.

SSSSSS: Es el número de segundos (con las milésimas, y sin la coma decimal) pasados desde la medianoche.

Por ejemplo si la función SYS(2015) nos devuelve la cadena "_08G12H0PC", esto corresponde a:

_: Caracter de guión bajo con el que comienza la cadena.

08G: Es el número de días transcurridos desde el "01/01/00" en años de "367 días"

12H0PC: Es el número de segundos pasados desde la medianoche, con las milésimas, y sin la coma decimal.

Pero como vemos, los valores devueltos no están en el sistema decimal (base 10) que todos conocemos. Estos valores están en un sistema de base 36, que toma los 10 dígitos numéricos y las 26 letras del alfabeto, o sea los 36 caracteres incluidos en los intervalos [0..9] y [A..Z].

La inversa de SYS(2015)

Para conocer entonces la inversa de la función SYS(2015), debemos cortar la cadena devuelta, transformar los valores en base 36 a base 10, calcular la fecha según el año y los días del año transcurridos desde el "01/01/xx" - 1, y calcular la hora según los segundos y milésimas devueltos.

Si cortamos y transformamos la cadena devuelta en el ejemplo "_08G12H0PC" al sistema decimal, el resultado es el siguiente:

08G -> 304 días transcurridos desde el "01/01/00"
Año = INT(304 / 367)
Días transcurridos del "Año"= MOD(304, 367)
12H0PC -> 64619,472 segundos -> 17:56:59,472

Con esto sabemos que la función SYS(2015) retornó el valor "_08G12H0PC" el día 30 de Octubre del '00 a las 17:56:59,472 horas.

La función en código VFP

A continuación se muestra el código de la función que retorna la inversa de SYS(2015). La función se llama Inv2015() e invoca a las funciones:

B36TOB10(): Convierte un valor en el sistema numérico de base 36, a un valor en el sistema numérico de base 10.

S2HMSm(): Convierte los segundos y milésimas pasados desde la medianoche a un formato HH:MM:SS,mmm.
*-------------------------------
* FUNCTION Inv2015(tcCadena)
*-------------------------------
* Función que invierte el retorno de SYS(2015)
* USO: Inv2015("_0AB0123AB")
* RETORNA: Caracter "DD/MM/AAAA HH:MM:SS.mmm"
*-------------------------------
FUNCTION Inv2015(tcCadena)
  LOCAL lnDia, lnAnio
  lnDia = B36TOB10(SUBS(tcCadena, 2, 3))
  lnAnio = INT(lnDia / 367)
  lnDia = MOD(lnDia, 367)
  SET STRICTDATE TO 0
  RETURN DTOC(EVAL("{^"+STR(lnAnio,2)+"/01/01}") ;
    + lnDia - 1) + " " ;
    + S2HMSm(B36TOB10(SUBS(tcCadena, 5, 6))/1000)
ENDFUNC

*-------------------------------
* FUNCTION B36TOB10(tcN36)
*-------------------------------
* Función que pasa un número de base 36 a base 10
* Usada por Inv2015()
* RETORNA: Numérico
*-------------------------------
FUNCTION B36TOB10(tcN36)
  LOCAL lnN10, lcChr, lnLen, lnI, lnAux
  tcN36 = ALLTRIM(UPPER(tcN36))
  lnLen = LEN(tcN36)

  lnN10 = 0
  lnI = 1
  FOR lnI = 1 TO lnLen
    lcChr = SUBS(tcN36, lnI, 1)
    lnAux = ASC(lcChr)-IIF(lcChr < 'A', 48, 55)
    lnN10 = lnN10 + lnAux * 36^(lnLen-lnI)
  ENDFOR
  RETURN INT(lnN10)
ENDFUNC

*-------------------------------
* FUNCTION S2HMSm(tnSeg)
*-------------------------------
* Transforma segundos a formato HH:MM:SS.mmm
* Usada por Inv2015()
* RETORNA: Caracter 'HH:MM:SS.mmm'
*-------------------------------
FUNCTION S2HMSm(tnSeg)
  LOCAL lnHor, lnMin, lnSeg, lnMil
  lnHor = INT(tnSeg/3600)
  lnMin = INT(((tnSeg - (lnHor*3600))/60))
  lnSeg = MOD(tnSeg, 60)
  lnMil = (tnSeg - INT(tnSeg))*1000
  RETURN TRANSFORM(lnHor, "@L 99") + ":" + ;
    TRANSFORM(lnMin, "@L 99") + ":" + ;
    TRANSFORM(lnSeg, "@L 99") + "." + ;
    TRANSFORM(lnMil, "@L 999")
ENDFUNC

*-------------------------------
Notas finales

Conocer la inversa de la función SYS(2015), nos puede ser útil cuando guardamos la cadena retornada en un campo de una tabla al grabar o modificar un registro, o para saber cuando se creó un archivo que almacenamos con el nombre devuelto con SYS(2015).

El único problema de conocer la inversa de la función SYS(2015) es que no conocemos la centuria. La función Inv2015() tomará los valores actuales de SET CENTURY y ROLLOVER de VFP, para evaluar por ejemplo: {^00/01/01} ó {^99/01/01}.

30 de noviembre de 2000

Inversa de la función SYS(2015)

Una función para conocer la inversa de la función SYS(2015).

Ejemplo:
lc = SYS(2015)
? Inv2015(lc)
*-------------------------------
* FUNCTION Inv2015(tcCadena)
*-------------------------------
* Función que invierte el retorno de SYS(2015)
* USO: Inv2015("_0AB0123AB")
* RETORNA: Caracter "DD/MM/AAAA HH:MM:SS.mmm"
*-------------------------------
FUNCTION Inv2015(tcCadena)
  LOCAL lnDia, lnAnio
  lnDia = B36TOB10(SUBS(tcCadena, 2, 3))
  lnAnio = INT(lnDia / 367)
  lnDia = MOD(lnDia, 367)
 SET STRICTDATE TO 0
  RETURN DTOC(EVAL("{^"+STR(lnAnio,2)+"/01/01}") ;
    + lnDia - 1) + " " ;
    + S2HMSm(B36TOB10(SUBS(tcCadena, 5, 6))/1000)
ENDFUNC


*-------------------------------
* FUNCTION B36TOB10(tcN36)
*-------------------------------
* Función que pasa un número de base 36 a base 10
* Usada por Inv2015()
* RETORNA: Numérico
*-------------------------------
FUNCTION B36TOB10(tcN36)
  LOCAL lnN10, lcChr, lnLen, lnI, lnAux
  tcN36 = ALLTRIM(UPPER(tcN36))
  lnLen = LEN(tcN36)

  lnN10 = 0
  lnI = 1
  FOR lnI = 1 TO lnLen
    lcChr = SUBS(tcN36, lnI, 1)
    lnAux = ASC(lcChr)-IIF(lcChr < 'A', 48, 55)
    lnN10 = lnN10 + lnAux * 36^(lnLen-lnI)
  ENDFOR
  RETURN INT(lnN10)
ENDFUNC

*-------------------------------
* FUNCTION S2HMSm(tnSeg)
*-------------------------------
* Transforma segundos a formato HH:MM:SS.mmm
* Usada por Inv2015()
* RETORNA: Caracter 'HH:MM:SS.mmm'
*-------------------------------
FUNCTION S2HMSm(tnSeg)
  LOCAL lnHor, lnMin, lnSeg, lnMil
  lnHor = INT(tnSeg/3600)
  lnMin = INT(((tnSeg - (lnHor*3600))/60))
  lnSeg = MOD(tnSeg, 60)
  lnMil = (tnSeg - INT(tnSeg))*1000
  RETURN TRANSFORM(lnHor, "@L 99") + ":" + ;
    TRANSFORM(lnMin, "@L 99") + ":" + ;
    TRANSFORM(lnSeg, "@L 99") + "." + ;
    TRANSFORM(lnMil, "@L 999")
ENDFUNC

*-------------------------------
Luis María Guayán

14 de octubre de 2000

Oculta la barra de tareas de windows

*!* Oculta la barra de tareas de windows
*!* Sintaxis: HideTaskBar()
*!* Valor devuelto:
*!* Argumentos:
FUNCTION HideTaskBar

*!* Constantes para ocultar o mostrar la barra de tareas de windows
* Sgte linea notificada por Hugo Ranea 20/06/2001
    #DEFINE TOGGLE_HIDEWINDOW    128
    LOCAL lnHwnd
    *!* Valores
    lnHwnd = 0
    *!* Instrucciones DECLARE DLL para manipular la barra de tareas
    DECLARE INTEGER FindWindowA IN Win32API STRING lpClassName,;
    STRING lpWindowName
    DECLARE INTEGER SetWindowPos IN Win32API INTEGER hwnd,;
    INTEGER hwndInsertAfter, INTEGER x, INTEGER y, INTEGER cx,;
    INTEGER cy, INTEGER wFlags
    *!* Valores
    lnHwnd = FindWindowA('Shell_traywnd', '')
    *!* Ocultar la barra de tareas
    IF lnHwnd <> 0
        SetWindowPos(lnHwnd, 0, 0, 0, 0, 0, TOGGLE_HIDEWINDOW)
    ENDIF
ENDFUNC
Pablo Roca

Muestra la barra de tareas de Windows

*!* Muestra la barra de tareas de windows
*!* Sintaxis: ShowTaskBar()
*!* Valor devuelto:
*!* Argumentos:FUNCTION ShowTaskBar
*!* Constantes para ocultar o mostrar la barra de tareas de windows
* Sgte linea notificada por Hugo Ranea 20/06/2001
    #DEFINE TOGGLE_UNHIDEWINDOW    64
    LOCAL lnHwnd
    *!* Valores
    lnHwnd = 0
    *!* Instrucciones DECLARE DLL para manipular la barra de tareas
    DECLARE INTEGER FindWindowA IN Win32API STRING lpClassName,STRING lpWindowName
    DECLARE INTEGER SetWindowPos IN Win32API INTEGER hwnd,;
    INTEGER hwndInsertAfter, INTEGER x, INTEGER y, INTEGER cx,;
    INTEGER cy, INTEGER wFlags
    *!* Valores
    lnHwnd = FindWindowA('Shell_traywnd', '')
    *!* Mostrar la barra de tareas
    IF lnHwnd <> 0
        SetWindowPos(lnHwnd, 0, 0, 0, 0, 0, TOGGLE_UNHIDEWINDOW)
    ENDIF
ENDFUNC
Pablo Roca

23 de septiembre de 2000

Como introducir datos en un editbox en mayusculas

Normalmente en los texbox para introducir los datos, se hace poniéndole en la propiedad format el símbolo !, esto no funciona en los editbox, por lo que se propone aquí dos posibles soluciones para conseguir esto.

Vamos a aprovechar la propiedad format y por tanto solo se pondrá en mayúsculas, si hemos puesto el símbolo ! en el format, para así hacerlo igual que en los texbox.

Solución 1

Poner en el metodo Keypress del editbox:
LPARAMETERS nKeyCode, nShiftAltCtrl
*Brett Hobs & John Koziol
* convierte de a..z, y la ñ
IF '!' $ THIS.FORMAT AND (BETWEEN(nKeyCode,97,122) OR nKeyCode=241)
 nKeyCode=nKeyCode-32
 NODEFAULT
 KEYBOARD CHR(nKeyCode)
ENDIF
Solución 2

Poner en el método InteractiveChange del editbox:
* Mike Helland
local lnSelStart
IF '!' $ THIS.FORMAT
 lnSelStart = this.SelStart
 this.value = UPPER(this.value)
 this.SelStart = lnSelStart
ENDIF

Pablo Roca

24 de mayo de 2000

Convertir los métodos de un formulario en un archivo de procedimientos (.PRG)

Rutina que convierte todos los métodos de un formulario en un archivo de procedimientos .PRG.
*-----------------------------------------------------------
* FUNCTION SCX2PRG(tcForm, tcFile)
*-----------------------------------------------------------
* Pasa todos los métodos de un formulario y sus controles a
* un archivo de procedimientos.
* PARAMETROS:javascript:void(0);
*    tcForm: Ruta y nombre del formulario (.SCX)
*    tcFile: Ruta y nombre del archivo a generar (.PRG)
* AUTOR: LMG
* USO: SCX2PRG("C:\FORMS\FORM1.SCX", "C:\PRGS\METODOS.PRG")
*-----------------------------------------------------------
FUNCTION SCX2PRG(tcForm, tcFile)
  tcForm = FORCEEXT(tcForm, "SCX")
  IF NOT FILE(tcForm)
        MESSAGEBOX("El archivo" + CR + tcForm ;
      + CR + "no existe.", 16, "Aviso")
    RETURN .F.
  ENDIF
  IF EMPTY(tcFile)
    *--- Por defecto genera un PRG  con el
    *--- mismo nombre que el formulario
    tcFile = tcForm
  ENDIF
  tcFile = FORCEEXT(tcFile, "PRG")
  SET TEXTMERGE TO (tcFile) NOSHOW
  SET TEXTMERGE ON
  USE (tcForm) ALIAS MiScx
  \***********************************
  \*** METODOS DEL FORMULARIO
  \*** <<UPPER(tcForm)>>
  \***********************************
  SCAN ALL
    IF NOT EMPTY(MiScx.methods)
      \*-----------------------------------------------
      \*-- <<MiScx.objname>> -- (<<MiScx.Baseclass>>)
      \*------------------------------------------------
      \<<MiScx.methods>>
    ENDIF
  ENDSCAN
  USE IN MiScx
  \***********************************
  \*** FINAL DEL ARCHIVO
  \***********************************
  SET TEXTMERGE OFF
  SET TEXTMERGE TO
  RETURN .T.
ENDFUNC
Luis María Guayán

9 de mayo de 2000

¿Cómo verificar si una tabla está abierta en exclusiva?

Verificar si una tabla está abierta en exclusiva.
*--------------------------------------------------
FUNCTION _Exclusivo(tcTabla)
*--------------------------------------------------
* Verifica si una tabla esta abierta en  EXCLUSIVO
* USO: _Exclusivo("C:\VFP\MiTabla.DBF")
* PARAMETRO:
*    tcTabla = Ruta completa del archivo .DBF
* RETORNO: .T. si se puede abrir en exclusivo
*--------------------------------------------------
LOCAL lnHandle, llRet
lnHandle = FOPEN(tcTabla)
IF lnHandle = -1
   llRet = .F.
ELSE
   llRet = .T.
   =FCLOSE(lnHandle)
ENDIF
RETURN llRet
ENDFUNC
Luis María Guayán

Como hacer un cursor modificable II

Funciín para hacer un cursor modificable
*--------------------------------------------------
FUNCTION _Actualizable(tcAlias)
*--------------------------------------------------
* Hace actualizable un cursor
* USO: _Actualizable("MiCursor")
* PARAMETRO:
*    tcAlias = Alias del cursor
*--------------------------------------------------
 LOCAL lcAliasTmp, lcAliasAnt
 lcAliasAnt = ALIAS()
 IF EMPTY(tcAlias) OR NOT USED(tcAlias)
    WAIT WINDOW NOWAIT " No existe el alias "
    RETURN
 ENDIF
 lcAliasTmp = SYS(2015)
 USE DBF(tcAlias) IN 0 SHARE AGAIN ALIAS (lcAliasTmp)
 USE DBF(lcAliasTmp) IN (tcAlias) SHARE AGAIN ALIAS (tcAlias)
 USE IN (lcAliasTmp)
 IF NOT EMPTY(lcAliasAnt)
    SELECT (lcAliasAnt)
 ENDIF
 RETURN
ENDFUNC
Luis María Guayán

30 de abril de 2000

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

29 de abril de 2000

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

23 de abril de 2000

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

18 de abril de 2000

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

14 de abril de 2000

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

9 de abril de 2000

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

7 de abril de 2000

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

5 de abril de 2000

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.

4 de abril de 2000

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

1 de abril de 2000

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)

31 de marzo de 2000

Mostrar el porcentaje de ejecución de un comando SELECT o USE VIEW

Muestra el porcentaje de ejecución de un comando SELECT o USE VIEW.
*----------------------------------------
* EJEMPLO DE USO
*----------------------------------------
LOCAL loBar
loBar = CREATEOBJECT("SQLBar")

*-- Consulta no optimizada que retorna mas 
*-- de 1.000.000 de registros solo para prueba
SELECT * ;
  FROM (HOME(2)+"Tastrade\Data\Orders") T1, ;
  (HOME(2)+"Tastrade\Data\Orders") T2

RELEASE loBar

*----------------------------------------
* Inicio de la definición de la clase
*----------------------------------------
DEFINE CLASS SQLBar AS CUSTOM
  PROTECTED lSetTalk, lWindows
  lSetTalk = ""
  lWindow = ""
  NAME = "SQLBar"

  PROCEDURE INIT
    THIS.lSetTalk = SET("TALK")
    THIS.lWindow = SYS(2015)
    DEFINE WINDOW (THIS.lWindow) FROM 0,0 TO 1,1
    SET TALK WINDOW (THIS.lWindow)
    SET TALK ON
  ENDPROC

  PROCEDURE DESTROY
    LOCAL lThisSetTalk
    lThisSetTalk = THIS.lSetTalk
    SET TALK &lThisSetTalk
    RELEASE WINDOW (THIS.lWindow)
  ENDPROC
ENDDEFINE

*----------------------------------------
* Fin de la definición de la clase
*----------------------------------------
Luis María Guayán

Barra de progreso en la barra de estado (StatusBar)

Una barra de progreso en la barra de estado (StatusBar).
*----------------------------------------
* EJEMPLO DE USO
*----------------------------------------

LOCAL loBar, lnI
loBar = CREATEOBJECT("ProgressBarInStatusBar")
FOR lnI = 1 TO 100
  loBar.Grafica(lnI)
  INKEY(.01)
ENDFOR
RELEASE loBar

*----------------------------------------
* Comienzo la definición de la calse
*----------------------------------------
DEFINE CLASS ProgressBarInStatusBar AS CUSTOM
  PROTECTED lcSetStatusBar
  lcSetStatusBar=""
  Name = "ProgressBarInStatusBar"

  PROCEDURE INIT
    THIS.lcSetStatusBar = SET("STATUS BAR")
    SET STATUS BAR ON
    SET MESSAGE TO
    RETURN ""
  ENDPROC

  PROCEDURE DESTROY
    LOCAL lcStatusBar
    lcStatusBar = THIS.lcSetStatusBar
    SET MESSAGE TO
    SET STATUS BAR &lcStatusBar
    RETURN ""
  ENDPROC

  PROCEDURE Grafica(lnPorcentaje)
    IF EMPTY(lnPorcentaje)
      lnPorcentaje = 0
    ENDIF
    IF lnPorcentaje > 100
      lnPorcentaje = 100
    ENDIF
    SET MESSAGE TO REPLICATE(CHR(124), 160*lnPorcentaje/100) ;
      + STR(INT(lnPorcentaje),4) + "%"
    RETURN ""
  ENDPROC
ENDDEFINE
Luis María Guayán

23 de marzo de 2000

Conversión de decimal a hexadecimal

Conversión de decimal a hexadecimal
*------------------------------------------------
FUNCTION _Dec2Hex(nDecimal)
*------------------------------------------------
* Transforma un número decimal a hexadecimal
* USO: _Dec2Hex(nDecimal)
* RETORNA: Caracter
*------------------------------------------------
  LOCAL lcHexa, lcChr, lnResto
  lcHexa=''
  DO WHILE nDecimal > 0
    lnResto = MOD(nDecimal,16)
    nDecimal = INT(nDecimal / 16)
    lcChr = IIF(lnResto < 10,STR(lnResto,1),CHR(lnResto + 55))
    lcHexa = lcChr + lcHexa
  ENDDO
  RETURN lcHexa
ENDFUNC

Luis María Guayán

22 de marzo de 2000

Conversión de hexadecimal a decimal

Conversión de hexadecimal a decimal
*------------------------------------------------
FUNCTION _Hex2Dec(cHexa)
*------------------------------------------------
* Transforma un número hexadecimal a decimal
* USO: _Hex2Dec(cHexadecimal)
* RETORNA: Numérico
*------------------------------------------------
  LOCAL lnFinal, lnDecimal, lnI, lnPeso, lnAsc
  cHexa = UPPER(ALLTRIM(cHexa))
  lnFinal = LEN(cHexa)
  lnDecimal = 0
  FOR lnI = lnFinal TO 1 STEP -1
    lnAsc = ASC(SUBS(cHexa,lnI,1))
    lnPeso = IIF(BETWEEN(lnAsc,48,57),lnAsc-48,lnAsc-55)
    lnDecimal = lnDecimal + lnPeso * 16^(lnFinal - lnI)
  ENDFOR
  RETURN lnDecimal
ENDFUNC

Luis María Guayán

Convertir un número de color devuelto por GetColor() a formato RGB(nR,nG,nB)

Rutina que convierte el valor numerico retornado por GETCOLOR() a formato RGB(,,).
*------------------------------------------------
FUNCTION _Col2RGB(tnColor)
*------------------------------------------------
* Pasa un número de color a formato RGB.
* USO: _Col2RGB(1547)
* RETORNA: Caracter - "RGB(nR, nG, nB)" 
*------------------------------------------------
  LOCAL lcRGB, ln 
  lcRGB="RGB(" 
  FOR ln=1 TO 3
    lcRGB=lcRGB+TRAN(tnColor%256,"999")+IIF(ln=3, "", ",")
    tnColor=INT(tnColor/256)
  ENDFOR
  lcRGB=lcRGB+")"
  RETURN lcRGB
ENDFUNC
Luis María Guayán

21 de marzo de 2000

Conversión de binario a decimal

Conversión de binario a decimal

*------------------------------------------------
FUNCTION _Bin2Dec(cBinario)
*------------------------------------------------
* Transforma un número binario a decimal
* USO: _Bin2Dec(cBinario)
* solo "1's" y "0's"
* RETORNA: Numérico
*------------------------------------------------
  LOCAL lnFinal, lnDecimal, lnI
  cBinario = ALLTRIM(cBinario)
  lnFinal = LEN(cBinario)
  lnDecimal = 0
  FOR lnI = lnFinal TO 1 STEP -1
    lnDecimal = lnDecimal + ;
      VAL(SUBS(cBinario,lnI,1)) * 2^(lnFinal - lnI)
  ENDFOR
  RETURN lnDecimal
ENDFUNC

Luis María Guayán

20 de marzo de 2000

Conversión de decimal a binario

Función que pasa un numero entero a binario.

*------------------------------------------------
FUNCTION _Dec2Bin(nDecimal)
*------------------------------------------------
* Transforma un número decimal a binario
* USO: _Dec2Bin(nDecimal)
* RETORNA: Caracter
*------------------------------------------------
  LOCAL lcBinario, lnResto
  lcBinario = ''
  DO WHILE nDecimal > 0
    lnResto = MOD(nDecimal,2)
    nDecimal = INT(nDecimal / 2)
    lcBinario = STR(lnResto,1) + lcBinario
  ENDDO
  RETURN lcBinario
ENDFUNC

Luis María Guayán

19 de marzo de 2000

Poner una imagen de fondo en la pantalla principal de VFP

Por ejemplo si queremos poner como fondo de la pantalla principal el archivo "MiImagen.BMP" que esta en C:\BITMAPS\ ejecutamos:

_Screen.Picture = "C:\BITMAPS\MiImagen.BMP"
Luis María Guayán

18 de marzo de 2000

Buscar el nombre de todos los archivos de un directorio y sus subdirectorios

Función recursiva que retorna el nombre de todos los archivos de un directorio (pasado como parámetro) y de todos sus subdirectorios. Retorna la Ruta y Nombre de Archivo completos.

*-----------------------------------------------------------------
* FUNCTION ASubDir(taArray, tcRoot)
*-----------------------------------------------------------------
* Devuelve en un array pasado por referencia todos los nombres de 
* archivos del directorio "tcRoot" y de todos sus subdirectorios. 
* Los nombres son de la forma: [Unidad]:[Directorio][Archivo]
* RETORNO: Cantidad de archivos en el array. Si no encontró ningún
*    archivo o el directorio "tcRoot" no existe, retorna 0 (cero)
* EJEMPLO DE USO: 
*    DIMENSION laMiArray[1]
*    lnC = ASubDir(@laMiArray, "C:\Mis Documentos\")
*    FOR lnI = 1 to lnC
*       ? laMiArray[lnI]
*    ENDFOR
*-----------------------------------------------------------------
FUNCTION ASubDir(taArray, tcRoot)
  IF EMPTY(tcRoot)
    tcRoot = SYS(5) + CURDIR()
  ENDIF
  DIMENSION taArray[1]
  =ARecur(@taArray, tcRoot)
  IF ALEN(taArray) > 1
    DIMENSION taArray[ALEN(taArray) - 1]
    RETURN ALEN(taArray)
  ELSE
    RETURN 0 
  ENDIF
ENDFUNC
*-----------------------------------------------------------------
* FUNCTION ARecur(taArray, tcRoot)
*-----------------------------------------------------------------
* Funcion recursiva llamada por ASubDir
*-----------------------------------------------------------------
FUNCTION ARecur(taArray, tcRoot)
  PRIVATE lnI, lnCant, laAux
  tcRoot = ADDBS(tcRoot)
  lnCant = ADIR(laAux, tcRoot+"*.*", "D")
  FOR lnI = 1 TO lnCant
    IF "D" $ laAux[lnI, 5]
      IF laAux[lnI, 1] == "." OR laAux[lnI, 1] == ".."
        LOOP
      ELSE
        lcSubDir = tcRoot + laAux[lnI, 1]
        =ARecur(@taArray, lcSubDir)
        LOOP
      ENDIF
    ENDIF
    taArray[ALEN(taArray)] = tcRoot + laAux[lnI, 1]
    DIMENSION taArray[ALEN(taArray) + 1]
  ENDFOR
  RETURN
ENDFUNC

Luis María Guayán

14 de marzo de 2000

Saber si el programa que se ejecuta es un .EXE o .PRG

Como saber si el programa que se ejecuta es un .EXE o .PRG.
IF RIGHT(SYS(16,0),4) = ".EXE"
    WAIT WIND "Ejecutado desde un EXE"
ELSE
    WAIT WIND "Ejecutado desde desarrollo"
ENDIF
Luis María Guayán

13 de marzo de 2000

Cambiar el icono de la ventana principal de VFP

Por ejemplo si queremos cambiar el ícono de la ventana principal por archivo "MiIcono.ICO" que esta en C:ICONS ejecutamos:

_Screen.Icon = "C:ICONSMiIcono.ICO"

10 de marzo de 2000

Como saber si la disquetera tiene un disquette disponible

Como saber si la disquetera tiene un disquette disponible ...

ln = DISKSPACE("A:")
IF ln > 0
   *--- EXISTE UN DISCO EN "A:"
ELSE
   *--- NO EXISTE UN DISCO EN "A:"
   WAIT WINDOW "NO EXISTE UN DISCO EN A:"
ENDIF

Luis María Guayán

8 de marzo de 2000

Saber si un tipo de letra (fuente) está instalado

*-------------------------------------------
* Retorna .T. si la fuente esta instalada 
* Ejemplo: ? _ExistFont("Algerian")
*-------------------------------------------
FUNCTION _ExistFont(tcFont)
*-------------------------------------------
 LOCAL laArray(1), lnI, llRet
 llRet = .F.
 IF AFONT(laArray)
  tcFont = UPPER(tcFont)
  FOR lnI = 1 TO ALEN(laArray)
   IF UPPER(laArray(lnI)) == tcFont
    llRet = .T.
    EXIT
   ENDIF
  ENDFOR
 ELSE
  MESSAGEBOX('La fuente no esta instalada!!!')
 ENDIF
 RETURN llRet
ENDFUNC
Luis María Guayán

Saber si un año es bisiesto

************************************************************
*
* Clase: ESBISIESTO
*
* Indica si el año es bisiesto
*
* Parametros:
*
*  tnano - año a investigar
*
* Ejemplos:
*
* GoCsApp.esbisiaesto(2000)
*
* Retorno
*
* .T.  el año es bisiesto
* .F.  el año NO es bisiesto
*
* Nota
*
* Creación           : 23/02/2000 DCB
* Ultima Modificacion: 23/02/2000 DCB
*
************************************************************
PARAMETERS tnano
RETURN (MOD(tnano,4)=0 AND MOD(tnano,100)<>0) OR MOD(tnano,400)=0
Pablo Roca

Transformar una cantidad n de segundos a HH:MM:SS

Función que transforma una cantidad de segundos a formato HH:MM:SS.
*--------------------------------------------------------------------------
* FUNCTION _Seg2Hor(nSegundos)
*--------------------------------------------------------------------------
* Transforma segundos a formato hhHH:MM:SS
* USO: _Seg2Hor(nSegundos)
* EJEMPLO: _Seg2Hor(35000)
* RETORNA: Caracter 'HH:MM:SS'
*--------------------------------------------------------------------------
*FUNCTION _Seg2Hor(nSegundos)
lpara nSegundos
 LOCAL lnHoras, lnMinutos, lnSegundos
 lnHoras = INT(nSegundos/3600)
 lnMinutos = INT(((nSegundos-(lnHoras*3600))/60))
 lnSegundos = MOD(nSegundos,60)
 RETURN IiF(lnHoras<100,TRANSFORM(lnHoras,"@L 99"),TRANSFORM(lnHoras,"@L 9999")) +":"+ ;
  TRANSFORM(lnMinutos,"@L 99")+":"+ ;
  TRANSFORM(lnSegundos,"@L 99")
ENDFUNC
Luis María Guayán

Nombre del PC y del usuario

Sin utilizar la API, solo la función SYS(0) de VFP
Ejemplo:
? PC_USER(1)
? PC_USER(2)

*----------------------------
FUNCTION PC_USER(tn)
*----------------------------
* Retorna en nombre de la PC o el nombre del usuario
* Parametros: tn = 1 - Retorna el nombre de PC
*             tn = 2 - Retorna el nombre de usuario
*----------------------------
LOCAL lc, ln
  lc = SYS(0)
  ln = AT('#',lc)
  tn = IIF(EMPTY(tn) or type('tn')#'N',1,tn)
  IF tn = 1
    lc = LEFT(lc,ln-1)
  ELSE
    lc = SUBS(lc,ln+2)
  ENDIF

  RETURN lc
ENDFUNC
*----------------------------
Luis María Guayán

Saber la resolución del monitor

? _Resolucion()

*-------------------------------------------
* Retorna la resolucion del monitor 
* Ejemplo: ? _Resolucion() -> "1024x768"
*-------------------------------------------
FUNCTION _Resolucion()
 RETURN TRANSFORM(SYSMETRIC(1))+"x"+TRANSFORM(SYSMETRIC(2))
ENDFUNC

¿Cómo verificar si una tabla está abierta en exclusiva?

Verificar si una tabla está abierta en exclusiva.
*--------------------------------------------------
FUNCTION _Exclusivo(tcTabla)
*--------------------------------------------------
* Verifica si una tabla esta abierta en  EXCLUSIVO
* USO: _Exclusivo("C:\VFP\MiTabla.DBF")
* PARAMETRO:
*    tcTabla = Ruta completa del archivo .DBF
* RETORNO: .T. si se puede abrir en exclusivo
*--------------------------------------------------
LOCAL lnHandle, llRet
lnHandle = FOPEN(tcTabla)
IF lnHandle = -1
   llRet = .F.
ELSE
   llRet = .T.
   =FCLOSE(lnHandle)
ENDIF
RETURN llRet
ENDFUNC
Luis María Guayán

Calcular el último día del mes

Función que retorna el último día de un mes.
*------------------------------------------------
FUNCTION _EOM(dFecha)
*------------------------------------------------
* Retorna el último día del mes (EndOfMonth)
* USO: _EOM(DATE())
* RETORNA: Fecha
*------------------------------------------------
  LOCAL ld 
  ld = GOMONTH(dFecha,1)
  RETURN ld - day(ld)
ENDFUNC
*------------------------------------------------
Luis María Guayán

Arrancar el Internet Explorer e ir a una página Web

poExplorer = CreateObject("InternetExplorer.Application")
poExplorer.Navigate("http://www.microsoft.com")
poExplorer.Visible=.T.
Release poExplorer
Luis María Guayán

Como saber el nombre del programa principal (master) que se esta ejecutando

Si queremos saber el nombre y la ruta completa:

? SYS(16,0)

Si queremos saber solo el nombre:

? SYS(2014, SYS(16,0))
Luis María Guayán

Enviar un Email por Outlook

strProfile = "nombredeusuarioperfil"
strPassword = "passwordperfil"
strRecipient = "aquien@dominio.com"
strSubject = "Asunto"
strBody = "Este es el mensaje..."

theApp = CreateObject("Outlook.Application")
theNameSpace = theApp.GetNameSpace("MAPI")
theNameSpace.Logon(strProfile , strPassword)
theMailItem = theApp.CreateItem(0)

theMailItem.Recipients.Add( strRecipient )
theMailItem.Subject = strSubject
theMailItem.Body = strBody
theMailItem.Send
theNameSpace.Logoff

Pablo Roca

Como mostrar un mensaje de WAIT en la barra de tareas

*----------------------------------------
* Ejemplo de uso
*----------------------------------------
LOCAL loBar, lcTexto

lcTexto = " Este texto aparece en la BARRA !!! "
loBar = CREATEOBJECT("WaitStatusBar", lcTexto)
=INKEY(0)

lcTexto = " Ahora aparece este !!! "
loBar.SetWaitText(lcTexto)
=INKEY(0)

RELEASE loBar

*----------------------------------------
* Comienzo la definición de la calse
*----------------------------------------
DEFINE CLASS WaitStatusBar AS CUSTOM
 PROTECTED lcSetStatusBar
 lcSetStatusBar=""
 NAME = "WaitStatusBar"

 PROCEDURE INIT(lcTexto)
  IF EMPTY(lcTexto)
   lcTexto = "..."
  ENDIF
  THIS.lcSetStatusBar = SET("STATUS BAR")
  SET STATUS BAR ON
  SET MESSAGE TO lcTexto
  RETURN ""
 ENDPROC

 PROCEDURE DESTROY
  LOCAL lcStatusBar
  lcStatusBar = THIS.lcSetStatusBar
  SET MESSAGE TO
  SET STATUS BAR &lcStatusBar
  RETURN ""
 ENDPROC

 PROCEDURE SetWaitText(lcTexto)
  IF EMPTY(lcTexto)
   lcTexto = "..."
  ENDIF
  SET MESSAGE TO lcTexto
  RETURN ""
 ENDPROC

ENDDEFINE
*----------------------------------------
* Final la definición de la clase

Luis María Guayán

7 de marzo de 2000

Controlar la posición del cursor con la API

¿Cómo se puede controlar la posición del cursor con la API?
*-----------------------------------------------
FUNCTION SetCurPos(lnX, lnY)
*-----------------------------------------------
* Posiciona el cursor en la posición especificada
* PARAMETROS: lnX = Posición de X
*             lnY = Posición de Y
*-----------------------------------------------
IF EMPTY(lnX)
  lnX = 0
ENDIF
IF EMPTY(lnY)
  lnY = 0
ENDIF
DECLARE INTEGER SetCursorPos IN WIN32API ;
  INTEGER, ;
  INTEGER
=SetCursorPos(lnX, lnY)
RETURN ""
ENDFUNC
Luis María Guayán

Ver las aplicaciones que se están ejecutando en Windows

=ListApp()

*--------------------------------------------
FUNCTION ListApp
*--------------------------------------------
* Nuestra información de las aplicaciones que
* estan corriendo en Windows
* USO: ListApp()
*-----------------------------------------------
LOCAL laApp, lnHandle, lnCount, lcTitle, lnI, lnHFox
DIMENSION laApp[1]
lnHFox=0
DECLARE INTEGER FindWindow ;
  IN win32api ;
  INTEGER nullpointer, ;
  STRING cwindow_name
DECLARE INTEGER GetWindow ;
  IN win32api ;
  INTEGER ncurr_window_handle, ;
  INTEGER ndirection
DECLARE INTEGER GetWindowText ;
  IN win32api ;
  INTEGER n_win_handle, ;
  STRING @ cwindow_title, ;
  INTEGER ntitle_length
lnHFox = FindWindow(0,_SCREEN.CAPTION)
lnHandle = lnHFox && GetWindow(lnHFox,0)
lnCount = 0
DO WHILE lnHandle > 0
  lcTitle=SPACE(255)
  lnI=GetWindowText(lnHandle, @lcTitle,LEN(lcTitle))
  IF lnI>0
    lcTitle=STRTRAN(TRIM(lcTitle),CHR(0),"")
  ELSE
    lcTitle=""
  ENDIF
  IF lnHandle > 0 .AND. !EMPTY(lcTitle)
    lnCount=lnCount+1
    DIMENSION laApp(lnCount)
    laApp[lnCount]=lcTitle
  ENDIF
  lnHandle = GetWindow(lnHandle,2)
ENDDO

IF ALEN(laApp,1)>0
  lcString = "Las siguientes aplicaciones estan ejecutandose:" + CHR(13) + CHR(13)
  FOR i=1 TO ALEN(laApp,1)
    lcString = lcString + laApp[i]+CHR(13)
  NEXT
ELSE
  lcString = "No hay aplicaciones ejecutandose"
ENDIF
=MESSAGEBOX(lcString, "Lista de aplicaciones")
RETURN ""
ENDFUNC
Luis María Guayán

Función que retorna información sobre el disco (Nombre volumen, Número de serie)

*-----------------------------------------------
FUNCTION GetVol(lpRoot)
*-----------------------------------------------
* Nuestra información del volumen
* USO: GetVol("C:")
* PARAMETRO: lpRoot = LetraDrive + ":"
*-----------------------------------------------
LOCAL lnRet, lcString, lpVolName, ;
  nVolSize, lpVolNumber, ;
  lpMaxComp, lpFlags, ;
  lpFSName, nFSSize

IF EMPTY(lpRoot)
  lpRoot = "d:"
ENDIF
lpVolName = SPACE(256)
nVolSize = 256
lpVolNumber = 0
lpMaxComp = 256
lpFlags = 0
lpFSName = SPACE(256)
nFSSize = 256

DECLARE INTEGER GetVolumeInformation IN Win32API AS GetVolInfo ;
  STRING  @lpRoot, ;
  STRING  @lpVolName, ;
  INTEGER nVolSize, ;
  INTEGER @lpVolNumber, ;
  INTEGER @lpMaxComp, ;
  INTEGER @lpFlags, ;
  STRING  @lpFSName, ;
  INTEGER nFSSize

lnRet=GetVolInfo(@lpRoot, @lpVolName, ;
  nVolSize, @lpVolNumber, ;
  @lpMaxComp, @lpFlags, ;
  @lpFSName, nFSSize)

IF lnRet > 0
  lcString = "Drive name: " + ;
    ALLT(lpRoot)+CHR(13)+ ;
    "Vol name: " + ;
    LEFT(ALLT(lpVolName),LEN(ALLT(lpVolName))-1)+CHR(13)+ ;
    "Max: " + ;
     ALLT(STR(nVolSize))+CHR(13)+ ;
    "Vol Serial: " + ;
     ALLT(STR(lpVolNumber))+CHR(13)+ ;
    "Max: " + ;
     ALLT(STR(lpMaxComp))+CHR(13)+ ;
    "File Sys Flags: " + ;
    ALLT(STR(lpFlags))+CHR(13)+ ;
    "File Sys type: " + ;
    LEFT(ALLT(lpFSName),LEN(ALLT(lpFSName))-1)+CHR(13)+ ;
    "File Sys Name Size: " + ;
    ALLT(STR(nFSSize))
ELSE
  lcString = "No se pudo ver información"
ENDIF
=MESSAGEBOX(lcString, "Información del volumen")
RETURN ""
ENDFUNC
Luis María Guayán

Función API que retorna el nombre de la computadora

Función API que retorna el nombre de la computadora.

*--------------------------------------------
FUNCTION _ComputerName
*--------------------------------------------
* Retorna el nombre de la computadora
*--------------------------------------------
LOCAL lcComputer, lnSize
lcComputer = SPACE(80)
lnSize = 80
DECLARE INTEGER GetComputerName IN WIN32API ;
   STRING @cComputerName, ;
   INTEGER @nSize
=GetComputername(@lcComputer, @lnSize)
IF lnSize < 2
   lcComputer = ""
ELSE
   lcComputer = SUBSTR(lcComputer, 1, lnSize)
ENDIF
RETURN lcComputer
ENDFUNC

Luis María Guayán

Desconectar una unidad de red

Como desconectar una unidad de red.
* ------------------------------------------------------
FUNCTION _UnmapDrive( tcDrive)
* ------------------------------------------------------
* Desconecta un drive de red
* USO: ? _UnmapDrive("Z:")
* ------------------------------------------------------
 LOCAL lnRet
 DECLARE INTEGER WNetCancelConnection IN WIN32API;
  STRING @lpzLocalName, INTEGER nForce
 lnRet = WNetCancelConnection( @tcDrive, 0)
 IF lnRet   RETURN "Error "+ALLT(STR(lnRet))+" al desconectar el drive "+tcDrive
 ENDIF
 RETURN ""
ENDFUNC
Luis María Guayán

Conectar una unidad de red a un recurso compartido

Como conectar una unidad de red a un recurso compartido.
*------------------------------------------------------
FUNCTION _MapDrive( tcDrive, tcResource, tcPassword)
*------------------------------------------------------
* Conecta un recurso compartido al drive tcDrive
* USO: ? _MapDrive("Z:","\\PC_RemotaRecurso")
*------------------------------------------------------
 LOCAL lnRet
 DECLARE INTEGER WNetAddConnection IN WIN32API;
  STRING @lpzRemoteName, STRING @lpzPassword,;
  STRING @lpzLocalName
 IF PARAMETERS() < 3
  lnRet = WNetAddConnection( @tcResource, 0, @tcDrive)
 ELSE
  lnRet = WNetAddConnection( @tcResource, @tcPassword, @tcDrive)
 ENDIF
 IF lnRet   RETURN "Error "+ALLT(STR(lnRet))+" al conectar el drive "+tcDrive
 ENDIF
 RETURN ""
ENDFUNC
Luis María Guayán

Saber el nombre del PC y el recurso compartido de una conexión de red

Como saber el nombre del PC y el recurso compartido de una conexión de red.

*-----------------------------------------
FUNCTION _GetConnec(lcDrive)
*-----------------------------------------
* Retorna el nombre de la PC y recurso compartido
* de una coneccion de red
* PARAMETROS: lcDrive 
* USO: _GetConnec("K:")
*-----------------------------------------
 DECLARE INTEGER WNetGetConnection IN WIN32API ;
  STRING lpLocalName, ;
  STRING @lpRemoteName, ;
  INTEGER @lpnLength
 LOCAL cRemoteName, nLength, lcRet, llRet
 cRemoteName=SPACE(100)
 nLength=100
 llRet = WNetGetConnection(lcDrive,@cRemoteName,@nLength)
 lcRet = LEFT(cRemoteName,AT(CHR(0),cRemoteName)-1)
 RETURN lcRet
ENDFUNC
Luis María Guayán

Leer y escribir la hora del sistema desde VFP

Con estas funciones, podemos cambiar la hora de la PC desde VFP.

Para LEER la fecha-hora del sistema
? ReadLocalTime()
Para ESCRIBIR la fecha-hora del sistema
? WriteLocalTime(DATETIME(1998,10,07,18,00,00))


NOTA: Deben estar juntas las cuatro funciones: ReadLocalTime(), WriteLocalTime(), _256to10(), _10to256()

*========================
FUNCTION ReadLocalTime()
*========================
* Lee mediante API el GetLocalTime
* Retorno: DATETIME o .NULL. si existe error
* Autor: LMG - 1998.09.14
*========================
LOCAL lcAuxi, ltDateTime, ;
   lcSetDate, lcSetHours, lcSetCentury, ;
   lcSetSysformats, lcSetMark

lcSetSysformats = SET("SYSFORMATS")
lcSetCentury = SET("CENTURY")
lcSetDate = SET("DATE")
lcSetHours = SET("HOURS")
lcSetMark = SET("MARK")

SET SYSFORMATS OFF
SET CENTURY ON
SET DATE YMD
SET HOURS TO 24
SET MARK TO "/"

DECLARE GetLocalTime IN win32api ;
   STRING @lcAuxi

lcAuxi=SPAC(32)

IF GetLocalTime(@lcAuxi)
   ltDateTime = CTOT( _256to10(SUBS(lcAuxi,1,2), 4) + "/" + ;
      _256to10(SUBS(lcAuxi,3,2), 2) + "/" + ;
      _256to10(SUBS(lcAuxi,7,2), 2) + " " + ;
      _256to10(SUBS(lcAuxi,9,2), 2) +  ":" + ;
      _256to10(SUBS(lcAuxi,11,2), 2) + ":" + ;
      _256to10(SUBS(lcAuxi,13,2), 2) )
ELSE
  ltDateTime = .NULL.
ENDIF

SET MARK TO &lcSetMark
SET HOURS TO &lcSetHours
SET DATE &lcSetDate
SET CENTURY &lcSetCentury
SET SYSFORMATS &lcSetSysformats

RETURN ltDateTime
ENDFUNC

*========================
FUNCTION WriteLocalTime(ltDateTime)
*========================
* Escribe mediante API el GetLocalTime
* Parametro: Debe pasarse una variable del tipo DateTime
* Retorno: .T. si pudo cambiar fecha y hora
*          .F. envio un parámetro no válido o error
* Autor: LMG - 1998.09.14
*========================
IF TYPE("ltDateTime") # "T"
   RETURN .F.
ENDIF

LOCAL lcCadena

lcCadena = _10to256(YEAR(ltDateTime),2) + ;
   _10to256(MONTH(ltDateTime),2) + ;
   _10to256(DOW(ltDateTime),2) + ;
   _10to256(DAY(ltDateTime),2) + ;
   _10to256(HOUR(ltDateTime),2) + ;
   _10to256(MINUTE(ltDateTime),2) + ;
   _10to256(SEC(ltDateTime),2) + ;
   _10to256(000,2) + SPAC(24)

DECLARE SetLocalTime IN win32api ;
   STRING lcCadena

RETURN SetLocalTime(lcCadena)
ENDFUNC

*========================
FUNCTION _256to10(lcPar, lnCant)
*========================
* Toma un par de caracteres en base 256 y lo
* convierte en "lnCant" caracteres en base 10
* Usada por: ReadLocalTime()
* Autor: LMG - 1998.09.14
*========================
RETURN PADL(ALLTRIM(STR(ASC(SUBSTR(lcPar,2)) * 256 + ;
   ASC(SUBSTR(lcPar,1)))), lnCant, "0")
ENDFUNC

*========================
FUNCTION _10to256(lnNumero, lnCant)
*========================
* Toma número en base 10 y lo convierte 
* en "lnCant" caracteres en base 256
* Usada por: WriteLocalTime()
* Autor: LMG - 1998.09.14
*========================
LOCAL lcRetorno, lnAscii

lcRetorno=''
DO WHILE lnNumero >= 256
   lnAscii=MOD(lnNumero,256)
   lcRetorno=lcRetorno + CHR(lnAscii)
   lnNumero=INT(lnNumero / 256)
ENDDO
lnAscii=lnNumero
lcRetorno=lcRetorno + CHR(lnAscii)
RETURN PADR(lcRetorno, lnCant, CHR(0))
ENDFUNC
*========================
Luis María Guayán

Función API que retorna el directorio de sistemas de Windows

Función API que retorna el directorio de sistemas de Windows.
*--------------------------------------------
FUNCTION _SystemDir
*--------------------------------------------
* Retorna el directorio SYSTEM de Windows
* sin "" al final ("C:WINNTSYSTEM32")
*--------------------------------------------
LOCAL lcPath, lnSize
lcPath = SPACE(255)
lnsize = 255
DECLARE INTEGER GetSystemDirectory IN Win32API ;
   STRING  @pszSysPath,;
   INTEGER cchSysPath
lnSize = GetSystemDirectory(@lcPath, lnSize)
IF lnSize <= 0
   lcPath = ""
ELSE
   lcPath =  SUBSTR(lcPath, 1, lnSize)
ENDIF
RETURN lcPath
ENDFUNC
Luis María Guayán

Escribir y leer un valor de un archivo INI

Podemos escribir y leer valores de un archivo .INI mediante la API de Windows.
*----------------------------------------------------
FUNCTION WriteFileIni(tcFileName,tcSection,tcEntry,tcValue)
*----------------------------------------------------
* Escribe un valor de un archivo INI.
* Si no existe el archivo, la sección o la entrada, la crea.
* Retorna .T. si tuvo éxito
* PARAMETROS:
*  tcFileName = Nombre y ruta completa del archivo.INI
*  tcSection = Sección del archivo.INI
*  tcEntry = Entrada del archivo.INI
*  tcValue = Valor de la entrada
* USO: WriteFileIni("C:MiArchivo.ini","Default","Port","2")
* RETORNO: Logico
*----------------------------------------------------
DECLARE INTEGER WritePrivateProfileString ;
 IN WIN32API ;
 STRING cSection,STRING cEntry,STRING cEntry,;
 STRING cFileName

RETURN IIF(WritePrivateProfileString(tcSection,tcEntry,tcValue,tcFileName)=1, .T., .F.)
ENDFUNC

*----------------------------------------------------
FUNCTION ReadFileIni(tcFileName,tcSection,tcEntry)
*----------------------------------------------------
* Lee un valor de un archivo INI.
* Si no existe el archivo, la sección o la entrada, retorna .NULL.
* PARAMETROS:
*  tcFileName = Nombre y ruta completa del archivo.INI
*  tcSection = Sección del archivo.INI
*  tcEntry = Entrada del archivo.INI
* USO: ReadFileIni("C:MiArchivo.ini","Default","Port")
* RETORNO: Caracter
*----------------------------------------------------
LOCAL lcIniValue, lnResult, lnBufferSize
DECLARE INTEGER GetPrivateProfileString ;
   IN WIN32API ;
   STRING cSection,;
   STRING cEntry,;
   STRING cDefault,;
   STRING @cRetVal,;
   INTEGER nSize,;
   STRING cFileName
lnBufferSize = 255
lcIniValue = spac(lnBufferSize)
lnResult=GetPrivateProfileString(tcSection,tcEntry,"*NULL*",;
   @lcIniValue,lnBufferSize,tcFileName)
lcIniValue=SUBSTR(lcIniValue,1,lnResult)
IF lcIniValue="*NULL*"
   lcIniValue=.NULL.
ENDIF
RETURN lcIniValue
ENDFUNC
Luis María Guayán

Saber si una aplicación ya está activa

Como saber si una aplicación ya está activa.
? _EstaActiva('Calculadora')

* NOTA: Como parámetro debo enviar el caption de la aplicación
* que quiero verificar si está activa.

*-----------------------------------------------
Function _EstaActiva(tcCaption)
*-----------------------------------------------
* Verifica si una aplicación ya está activa
* USO: _EstaActiva()
* RETORNA: .T. Si la aplicación está activa
*-----------------------------------------------
DECLARE INTEGER FindWindow in WIN32API ;
  STRING cNULL, ;
  STRING cWinName

return FindWindow(0, tcCaption) EndFunc
Luis María Guayán

Función de espera de la API similar a INKEY() sin interfase

Función _Sleep de la API de Windows.
*------------------------------------------------
FUNCTION _Sleep(lnMiliSeg)
*------------------------------------------------
* Función que "para" la ejecución de un programa
* durante "n" milisegundos
* Mejor que INKEY() ya que no tiene interfase con el teclado.
* USO: _Sleep()
*------------------------------------------------
lnMiliSeg = IIF(TYPE("lnMiliSeg") = "N", lnMiliSeg, 1000)
DECLARE Sleep ;
  IN WIN32API ;
  INTEGER nMillisecs
RETURN Sleep(lnMiliSeg)
ENDFUNC
Luis María Guayán

Ejecutar un archivo .WAV desde VFP mediante API

Ejecutar un archivo .WAV desde VFP mediante API.
*------------------------------------------------
FUNCTION _PlayWave(lcWaveFile,lnPlayType)
*------------------------------------------------
* Ejecuta un archivo .WAV
* USO: _PlayWave( [,])
*     Arch_WAV = Ruta completa del archivo .WAV
*     Tipo_Ejecucion = 1 - Ejecución en background (default)
*                      0 - La aplicación espera la ejecución
*                      2 - Si el archivo no existe, no ejecuta el default
*                      4 - Apaga el sonido que se está ejecutando 
*                      8 - Continuado  
* RETORNA: .T. Si el sonido fue ejecutado
*------------------------------------------------
lnPlayType = IIF(TYPE("lnPlayType")="N",lnPlayType,1)
DECLARE INTEGER PlaySound ;
   IN WINMM.dll  ;
   STRING cWave, ;
   INTEGER nModule, ;
   INTEGER nType
RETURN IIF(PlaySound(lcWaveFile,0,lnPlayType) = 1, .T., .F.)
ENDFUNC
Luis María Guayán

Copiar un archivo mediante API y retornar .T. si lo pudo copiar

Copiar un archivo mediante API.
*------------------------------------------------
FUNCTION _CopyFile( lcOrigen, lcDestino, lnFlag)
*------------------------------------------------
* Copia un archivo mediante API
* USO: _CopyFile(,  [,])
* RETORNA: .T. Si lo pudo copiar
*------------------------------------------------
lnFlag = IIF(TYPE("lnFlag") = "N", lnFlag, 0)
DECLARE INTEGER CopyFile ;
   IN WIN32API ;
   STRING @cSource,;
   STRING @cTarget,;
   INTEGER nFlag
RETURN IIF(CopyFile(@lcOrigen,@lcDestino,lnFlag) = 0, .F., .T.)
ENDFUNC
Luis María Guayán

6 de marzo de 2000

Calcular el útimo día del mes

Rutina para calcular el útimo día del mes.
GOMONTH(CTOD("01/"+STR(MONTH(tdfecha),2)+"/"+STR(YEAR(tdfecha),4)),1)-1
Se puede implementar en una rutina de la siguiente manera:
FUNCTION ultiames
PARAMETERS tdfecha
LOCAL ldret
ldret = GOMONTH(CTOD("01/"+STR(MONTH(tdfecha),2)+"/"+STR(YEAR(tdfecha),4)),1)-1
RETURN ldret 
 
Pablo Roca

Conocer el número de paginas totales de un informe

Como conocer el número de paginas totales de un informe
************************************************************
*
* Clase: report_contarpaginas
*
* Devuelve el número de paginas de un report
*
* Parametros:
*
* Nombre del report
*
* Ejemplos:
*
* lntotpaginas = report_contapaginas("minforme") 
*
* Retorno
*
* El numero de paginas del informe.
*
* Nota
*
*
* Creación           : 08/09/1999 PRR
* Ultima Modificación: 14/04/2000 RAPY Rafael Angel Ponce Yllanes
*
************************************************************
PARAMETERS lc_report
LOCAL nPaginas
nPaginas = 0

DEFINE WINDOW x FROM 1,1 TO 2,2
ACTIVATE WINDOW x NOSHOW
REPORT FORM (lc_report) NOCONSOLE
nPaginas = _PAGENO
RELEASE WINDOW x
RETURN npaginas
NOTA: gracias a Jose Luis Santana Blasco y a Rafael Angel Ponce Yllanes por la aclaración del NOCONSOLE, con esto se mejora mucho la velocidad.

Pablo Roca

Hacer un cursor de SELECT SQL modificable

Como hacer un cursor de SELECT SQL modificable.
**********************************************************************
*
* Función: hazmodificable
*
* Hace modificable un cursor creado con SELECT SQL
*
* Sintaxis:
*
* =goCSApp.hazmodificable(cursor)
*
* Parametros:
*
* cursor
*
* Ejemplos:
*
* = hazmodificable(ALIAS())
* = hazmodificable("query1")
*
* Retorno:
*
* nada
*
* Nota: No debe haber ningun alias xxTemp abierto
* **********************************************************************
FUNCTION hazmodificable
  LPARAMETERS tcalias
  USE DBF(tcalias) IN 0 AGAIN alias xxTemp
  USE DBF("xxTemp") IN (tcalias) AGAIN ALIAS (tcalias)
  USE IN xxTemp
ENDFUNC
Pablo Roca

1 de marzo de 2000

Pasar un importe de numero a letras

Función para pasar un importe de numero a letras para imprimir en una factura, recibo o cheque.

? Num2Let(115.11) -> "CIENTO QUINCE CON ONCE CENTAVOS"

*--------------------------------------------------------------------------
* FUNCTION Num2Let(tnNumero)
*--------------------------------------------------------------------------
* Devuelve un número en letras con centavos
* USO: ? Num2Let(15.11) -> QUINCE CON ONCE CENTAVOS
* RETORNA: Caracter
* AUTOR: LMG
*--------------------------------------------------------------------------
FUNCTION Num2Let(tnNumero)
   LOCAL lnEntero, lnFraccion
   *-- Elegir si se REDONDEA o TRUNCA
   * tnNumero = ROUND(tnNumero, 2)  && Redondeo a 2 decimales
   tnNumero = INT(tnNumero*100)/100 && Trunco a dos decimales
   lnEntero = INT(tnNumero)
   lnFraccion = INT((tnNumero - lnEntero) * 100)
   RETURN N2L(lnEntero, 0) + 'CON ' + ;
      N2L(lnFraccion, 1) + 'CENTAVOS.'
ENDFUNC

*--------------------------------------------------------------------------
* FUNCTION N2L(tnNro, tnFlag)
*--------------------------------------------------------------------------
* Devuelve un número entero en letras
* Usada por Let2Num (deben estar ambas)
* USO: ? N2L(32) -> TREINTA Y DOS
* RETORNA: Caracter
* AUTOR: LMG
*--------------------------------------------------------------------------
FUNCTION N2L(tnNro, tnFlag)
   IF EMPTY(tnFlag)
      tnFlag = 0
   ENDIF
   LOCAL lnEntero, lcRetorno, lnTerna, lcMiles, ;
      lcCadena, lnUnidades, lnDecenas, lnCentenas
   lnEntero = INT(tnNro)
   lcRetorno = ''
   lnTerna = 1
   DO WHILE lnEntero > 0
      lcCadena = ''
      lnUnidades = MOD(lnEntero, 10)
      lnEntero = INT(lnEntero / 10)
      lnDecenas = MOD(lnEntero, 10)
      lnEntero = INT(lnEntero / 10)
      lnCentenas = MOD(lnEntero, 10)
      lnEntero = INT(lnEntero / 10)

      *--- Analizo la terna
      DO CASE
         CASE lnTerna = 1
            lcMiles = ''
         CASE lnTerna = 2 AND (lnUnidades + lnDecenas + lnCentenas # 0)
            lcMiles = 'MIL '
         CASE lnTerna = 3 AND (lnUnidades + lnDecenas + lnCentenas # 0)
            lcMiles = IIF(lnUnidades = 1 AND lnDecenas = 0 AND ;
               lnCentenas = 0, 'MILLON ', 'MILLONES ')
         CASE lnTerna = 4 AND (lnUnidades + lnDecenas + lnCentenas # 0)
            lcMiles = 'MIL MILLONES '
         CASE lnTerna = 5 AND (lnUnidades + lnDecenas + lnCentenas # 0)
            lcMiles = IIF(lnUnidades = 1 AND lnDecenas = 0 AND ;
               lnCentenas = 0, 'BILLON ', 'BILLONES ')
         CASE lnTerna > 5
            lcRetorno = ' ERROR: NUMERO DEMASIADO GRANDE '
            EXIT
      ENDCASE

      *--- Analizo las unidades
      DO CASE
         CASE lnUnidades = 1
            lcCadena = IIF(lnTerna = 1 AND tnFlag = 0, 'UNO ', 'UN ')
         CASE lnUnidades = 2
            lcCadena = 'DOS '
         CASE lnUnidades = 3
            lcCadena = 'TRES '
         CASE lnUnidades = 4
            lcCadena = 'CUATRO '
         CASE lnUnidades = 5
            lcCadena = 'CINCO '
         CASE lnUnidades = 6
            lcCadena = 'SEIS '
         CASE lnUnidades = 7
            lcCadena = 'SIETE '
         CASE lnUnidades = 8
            lcCadena = 'OCHO '
         CASE lnUnidades = 9
            lcCadena = 'NUEVE '
      ENDCASE

      *--- Analizo las decenas
      DO CASE
         CASE lnDecenas = 1
            DO CASE
               CASE lnUnidades = 0
                  lcCadena = 'DIEZ '
               CASE lnUnidades = 1
                  lcCadena = 'ONCE '
               CASE lnUnidades = 2
                  lcCadena = 'DOCE '
               CASE lnUnidades = 3
                  lcCadena = 'TRECE '
               CASE lnUnidades = 4
                  lcCadena = 'CATORCE '
               CASE lnUnidades = 5
                  lcCadena = 'QUINCE '
               OTHER
                  lcCadena = 'DIECI' + lcCadena
            ENDCASE
         CASE lnDecenas = 2
            lcCadena = IIF(lnUnidades = 0, 'VEINTE ', 'VEINTI') + lcCadena
         CASE lnDecenas = 3
            lcCadena = 'TREINTA ' + IIF(lnUnidades = 0, '', 'Y ') + lcCadena
         CASE lnDecenas = 4
            lcCadena = 'CUARENTA ' + IIF(lnUnidades = 0, '', 'Y ') + lcCadena
         CASE lnDecenas = 5
            lcCadena = 'CINCUENTA ' + IIF(lnUnidades = 0, '', 'Y ') + lcCadena
         CASE lnDecenas = 6
            lcCadena = 'SESENTA ' + IIF(lnUnidades = 0, '', 'Y ') + lcCadena
         CASE lnDecenas = 7
            lcCadena = 'SETENTA ' + IIF(lnUnidades = 0, '', 'Y ') + lcCadena
         CASE lnDecenas = 8
            lcCadena = 'OCHENTA ' + IIF(lnUnidades = 0, '', 'Y ') + lcCadena
         CASE lnDecenas = 9
            lcCadena = 'NOVENTA ' + IIF(lnUnidades = 0, '', 'Y ') + lcCadena
      ENDCASE

      *--- Analizo las centenas
      DO CASE
         CASE lnCentenas = 1
            lcCadena = IIF(lnUnidades = 0 AND lnDecenas = 0, ;
               'CIEN ', 'CIENTO ') + lcCadena
         CASE lnCentenas = 2
            lcCadena = 'DOSCIENTOS ' + lcCadena
         CASE lnCentenas = 3
            lcCadena = 'TRESCIENTOS ' + lcCadena
         CASE lnCentenas = 4
            lcCadena = 'CUATROCIENTOS ' + lcCadena
         CASE lnCentenas = 5
            lcCadena = 'QUINIENTOS ' + lcCadena
         CASE lnCentenas = 6
            lcCadena = 'SEISCIENTOS ' + lcCadena
         CASE lnCentenas = 7
            lcCadena = 'SETECIENTOS ' + lcCadena
         CASE lnCentenas = 8
            lcCadena = 'OCHOCIENTOS ' + lcCadena
         CASE lnCentenas = 9
            lcCadena = 'NOVECIENTOS ' + lcCadena
      ENDCASE

      *--- Armo el retorno terna a terna
      lcRetorno = lcCadena + lcMiles + lcRetorno
      lnTerna = lnTerna + 1
   ENDDO
   IF lnTerna = 1
      lcRetorno = 'CERO '
   ENDIF
   RETURN lcRetorno
ENDFUNC

*--------------------------------------------------------------------------