19 de abril de 2001

Limitar un campo memo

Para limitar la entrada de un campo memo a X lineas, simplemente hay que poner en el keypress lo siguiente:

LPARAMETERS nKeyCode, nShiftAltCtrl
IF nkeycode = 13
   IF OCCURS(chr(13),this.value) >=5
      NODEFAULT
   ENDIF
ENDIF

En este ejemplo se limita a 6 lineas.

Pablo Roca

18 de abril de 2001

Desconectar una unidad de red con WSH

Desconectar una unidad de red con Microsoft Windows Script Host

o = CREATEOBJECT('Wscript.Network')
* o.RemoveNetworkDrive(Unidad)
o.RemoveNetworkDrive("Z:")
Luis María Guayán

6 de abril de 2001

Seleccionar un numero aleatorio

Como saben tenemos la función del RAND() para obtener un resultado entre cero y uno, pero que pasa con aquellas personas que desean generar un numero aleatorio entre dos números dados?

Aquí tienen una pequeña muestra de como generar un numero aleatorio partiendo de dos números dados y usando la función RAND()

Ejemplo:
? damenumaleatorio(10,99)
*---------------------------
FUNCTION damenumaleatorio
   PARAMETERS primero, segundo
   RAND(-1)
   RETURN INT((segundo - primero + 1) ;
      * RAND() + primero)
ENDFUNC
*---------------------------

Nota del editor: Para que los valores retornados por la función RAND() sean lo mas aleatorio posible tener en cuenta la ayuda de la función en la documentación de Visual FoxPro:

Sintaxis:

RAND([nSeedValue])

Parámetros

nSeedValue: Especifica el valor Seed que determina la secuencia de valores que devuelve RAND().
RAND() devuelve la misma secuencia de números aleatorios si utiliza el mismo valor Seed para nSeedValue la primera vez que ejecuta la función RAND(), seguida de llamadas posteriores a la función RAND() sin nSeedValue.

Si nSeedValue es negativo la primera vez que ejecuta RAND(), se usará un valor Seed a partir del reloj del sistema. Para obtener la serie más aleatoria de números, utilice inicialmente RAND() con un argumento negativo y después, ejecute RAND() sin ningún argumento.

Si omite nSeedValue, RAND() utilizará de forma predeterminada el valor Seed 100.001.

5 de abril de 2001

Cargar en un array las palabras de una cadena

Podemos cortar una cadena en palabras y cargarlas en un array de "n" posiciones, donde "n" es el número de palabras contenidas en la cadena.
lc = "Bienvenidos a Visual FoxPro"
ln = ALINES(la, STRTRAN(ALLTRIM(lc), " ", chr(13)))
FOR i = 1 TO ln
    ? la(i)
ENDFOR
Luis María Guayán

3 de abril de 2001

Convertir una variable DATE() a caracter no ambiguo

Con la función DtoCNA() (Date to Caracter no ambiguo) podemos convertir una fecha a una cadena no ambigua para su lectura o impresión.

Ejemplo:
*--- Español en formato largo y Separador "-"
? DTOCNA({07/10/2000}, "E", "L", "-")
   -> 07-OCT-2000

*--- Alemán en formato corto y Separador "/"
? DTOCNA({07/10/2000}, "A", "C", "/")
   -> 07/OKT/00
*-----------------------------------------------------------------
* FUNCTION DTOCNA(tdFecha, tcLeng, tcLong, tcSep)
*-----------------------------------------------------------------
* Date TO Caracter No Ambiguo
* PARAMETROS:
*  tdFecha: Fecha a convertir. Default = DATE()
*  tcLeng:
*    [E]spañol [I]nglés [F]rancés [A]lemán
*    i[T]aliano [P]ortugués
*  tcLong:
*    [L]argo: 12 ENE 2000 ó [C]orto: 01 ENE 00
*  tcSep:
*    Caracter separador del dia-mes-año. Default = " "
*    Si tcSep = .NULL. no tiene separador
* RETORNO: Caracter
* USO: ? DTOCNA({01/01/1999}, "I", "C", "-") -> 01-JAN-99
* AUTOR: LMG - 2000/06/15
*-----------------------------------------------------------------
FUNCTION DTOCNA(tdFecha, tcLeng, tcLong, tcSep)
  LOCAL lcMes, lnI
  IF EMPTY(tdFecha) OR NOT VARTYPE(tdFecha) $ "DT"
    tdFecha = DATE()
  ENDIF
  IF EMPTY(tcLeng) OR NOT UPPER(tcLeng) $ "EIFATP"
    tcLeng = "E"
  ELSE
    tcLeng = UPPER(tcLeng)
  ENDIF
  IF EMPTY(tcLong) OR NOT UPPER(tcLong) $ "CL"
    tcLong = "L"
  ELSE
    tcLong = UPPER(tcLong)
  ENDIF
  IF EMPTY(tcSep)
    tcSep = " "
  ELSE
    IF ISNULL(tcSep)
      tcSep = ""
    ENDIF
  ENDIF
  lnI = (MONTH(tdFecha)* 3) - 2
  DO CASE
    CASE tcLeng = "E"
      lcMes = SUBS("ENEFEBMARABRMAYJUNJULAGOSETOCTNOVDIC", lnI, 3)
    CASE tcLeng = "I"
      lcMes = SUBS("JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC", lnI, 3)
    CASE tcLeng = "F"
      lcMes = SUBS("JANFEVMARAVRMAIJUNJULAOUSEPOCTNOVDEC", lnI, 3)
    CASE tcLeng = "A"
      lcMes = SUBS("JANFEBMARAPRMAIJUNJULAUGSEPOKTNOVDEZ", lnI, 3)
    CASE tcLeng = "T"
      lcMes = SUBS("GENFEBMARAPRMAGGIULUGAGOSETOTTNOVDIC", lnI, 3)
    CASE tcLeng = "P"
      lcMes = SUBS("JANFEVMARABRMAIJUNJULAGOSETOUTNOVDEZ", lnI, 3)
  ENDCASE
  RETURN TRAN(DAY(tdFecha), "@L 99") + tcSep + lcMes + tcSep + ;
    IIF(tcLong = "L", TRAN(YEAR(tdFecha), "@L 9999"), ;
    TRAN(YEAR(tdFecha) % 100, "@L 99"))
ENDFUNC

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

Diferencia en días, horas, minutos y segundos de dos variables DATETIME()

Rutina para calcular la diferencia entre dos variables DATETIME() y retornar una cadena en DIAS, HORAS, MINUTOS y SEGUNDOS.
*-----------------------------
* FUNCTION Dif_DHMS(ttIni,ttFin)
*-----------------------------
* Calcula la diferencia de dos variables
* DATETIME y retorna en formato
* ### Días, ## Horas, ## Minutos, ## Segundos
*-----------------------------
FUNCTION Dif_DHMS(ttIni,ttFin)
  LOCAL ln, lnDia, lnHor, lnMin, lnSeg
  IF EMPTY(ttFin)
    ttFin = DATETIME()
  ENDIF
  ln = ttFin - ttIni
  lnSeg = MOD(ln,60)
  ln = INT(ln/60)
  lnMin = MOD(ln,60)
  ln = INT(ln/60)
  lnHor = MOD(ln,24)
  lnDia = INT(ln/24)
  RETURN ALLTRIM(STR(lnDia))+ " Días, "+ ;
    TRAN(lnHor, "@L 99")+ " Horas, "+ ;
    TRAN(lnMin, "@L 99")+ " Minutos, "+ ;
    TRAN(lnSeg, "@L 99")+ " Segundos"
ENDFUNC
*-----------------------------
Luis María Guayán

Ventana de LOGIN

Con la clase Login podemos tener facilmente un control de acceso a nuestras aplicaciones.

Ejemplo

IF _Login(1)
  MESSAGEBOX("Usuario autenticado OK.",64,"Login")
ELSE
   *-- Usuario no válido
   RETURN
ENDIF

* ----------------------------------------
* Function _Login( lnNivel, lnNivelSup)
* ----------------------------------------
* Funcion que muestra el form de LOGIN
* Parámetros:
*     lnNivel [opc] - Nivel autorizado.
*     si se omite permite cualquier 
*     usuario registrado
* ----------------------------------------
FUNCTION _Login( lnNivel, lnNivelSup)
  LOCAL llRet
  IF PARAMETERS() < 1
    lnNivel = 0
  ENDIF
  IF PARAMETERS() < 2
    lnNivelSup = 10
  ENDIF
  loForm = CREATEOBJECT("Login", lnNivel, lnNivelSup)
  loForm.SHOW()
  llRet = loForm.lRetorno
  RELEASE loForm
  loForm = .NULL.
  RETURN llRet
ENDFUNC
* ----------------------------------------
*-- Class:        Login
*-- Ingreso de password
* ----------------------------------------
DEFINE CLASS Login AS FORM
  HEIGHT = 110
  WIDTH = 220
  DOCREATE = .T.
  AUTOCENTER = .T.
  BORDERSTYLE = 2
  CAPTION = "Ingrese usuario y contraseña"
  CONTROLBOX = .F.
  CLOSABLE = .F.
  MAXBUTTON = .F.
  MINBUTTON = .F.
  WINDOWTYPE = 1
  *-- Nivel inferior de acceso
  nNivelInf = -1
  *-- Nivel superior de acceso
  nNivelSup = -1
  *-- Numero de intentos de validacion
  nIntentos = -1
  NAME = "Login"
  *-- retorna .T. si el usuario y contraseña son correctos
  lRetorno = .F.
  ADD OBJECT cmdaceptar AS COMMANDBUTTON WITH ;
    TOP = 72, LEFT = 48, HEIGHT = 25, WIDTH = 72, ;
    FONTNAME = "MS Sans Serif", FONTSIZE = 8, ;
    CAPTION = "Aceptar", DEFAULT = .T., ;
    TABINDEX = 5, NAME = "cmdAceptar"
  ADD OBJECT cmdcancelar AS COMMANDBUTTON WITH ;
    TOP = 72, LEFT = 133, HEIGHT = 25, WIDTH = 72, ;
    FONTNAME = "MS Sans Serif", ;
    FONTSIZE = 8, CANCEL = .T., ;
    CAPTION = "Cancelar", ;
    TABINDEX = 6, NAME = "cmdCancelar"
  ADD OBJECT lblusuario AS LABEL WITH ;
    FONTNAME = "MS Sans Serif", FONTSIZE = 8, ;
    ALIGNMENT = 1, BACKSTYLE = 0, CAPTION = "Usuario", ;
    HEIGHT = 15, LEFT = 12, TOP = 16, WIDTH = 60, ;
    TABINDEX = 2, NAME = "lblUsuario"
  ADD OBJECT lblcontrasena AS LABEL WITH ;
    FONTNAME = "MS Sans Serif", FONTSIZE = 8, ;
    ALIGNMENT = 1, BACKSTYLE = 0, CAPTION = "Contraseña", ;
    HEIGHT = 15, LEFT = 12, TOP = 40, WIDTH = 60, ;
    TABINDEX = 4, NAME = "lblContrasena"
  ADD OBJECT txtusuario AS TEXTBOX WITH ;
    FONTNAME = "MS Sans Serif", FONTSIZE = 8, ;
    FORMAT = "k", HEIGHT = 21, ;
    LEFT = 85, MAXLENGTH = 15, ;
    TABINDEX = 1, TOP = 12, ;
    WIDTH = 120, NAME = "txtUsuario"
  ADD OBJECT txtcontrasena AS TEXTBOX WITH ;
    FONTNAME = "MS Sans Serif", FONTSIZE = 8, ;
    FORMAT = "k", HEIGHT = 21, ;
    LEFT = 85, MAXLENGTH = 15, ;
    TABINDEX = 3, TOP = 36, ;
    WIDTH = 120, PASSWORDCHAR = "*", ;
    NAME = "txtContrasena"
  PROCEDURE validausuario
    LPARAMETERS tcUsuario, tcContrasena, tnNivelInf, tnNivelSup
    LOCAL lcUser, lcPass, lnNivel
    *--- pasa usuario a mayuscula
    tcUsuario = ALLTRIM(UPPER(tcUsuario))
    tcContrasena = ALLTRIM(tcContrasena)
    *-----------------------------
    *--- Aqui busco los datos del usuario
    *--- en la tabla de Usuarios
    *-----------------------------
    lcUser = "LUIS"
    lcPass = "siul"
    lnNivel = 5
    *-----------------------------
    *--- valido usuario y contraseña
    IF NOT (tcUsuario == lcUser ;
        AND tcContrasena == lcPass)
      *--- No existe usuario o Contraseña no válida
      =MESSAGEBOX('Usuario o contraseña inválida',48,'Advertencia')
      RETURN .F.
    ENDI
    IF NOT BETWEEN(lnNivel, tnNivelInf, tnNivelSup)
      *--- Nivel no autorizado
      =MESSAGEBOX('Usuario no autorizado para este módulo',48,'Advertencia')
      RETURN .F.
    ENDI
    *--- Todo correcto
    RETURN .T.
  ENDPROC
  PROCEDURE UNLOAD
    RETURN THISFORM.lRetorno
  ENDPROC
  PROCEDURE INIT
    LPARAMETERS tnNivelInf, tnNivelSup
    IF PARAMETERS() < 0
      tnNivelInf = 0
    ENDIF
    IF PARAMETERS() < 1
      tnNivelSup = 10
    ENDIF
    THISFORM.nIntentos = 0
    THISFORM.nNivelInf = tnNivelInf
    THISFORM.nNivelSup = tnNivelSup
    THISFORM.txtUsuario.SETFOCUS
    THISFORM.cmdAceptar.DEFAULT = .T.   && porque lo pierde en el SetFocus
  ENDPROC
  PROCEDURE cmdaceptar.CLICK
    THISFORM.nIntentos=THISFORM.nIntentos+1
    THISFORM.lRetorno=THISFORM.ValidaUsuario( ;
      THISFORM.txtUsuario.VALUE, ;
      THISFORM.txtContrasena.VALUE, ;
      THISFORM.nNivelInf, THISFORM.nNivelSup)
    IF THISFORM.lRetorno
      THISFORM.HIDE
    ELSE
      IF THISFORM.nIntentos < 3 
        IF EMPTY(THISFORM.txtUsuario.VALUE)
          THISFORM.txtUsuario.SETFOCUS
        ELSE
          THISFORM.txtContrasena.SETFOCUS
        ENDI
      ELSE
        =MESSAGEBOX('Acceso denegado',16,'Advertencia')
        THISFORM.HIDE
      ENDI
    ENDI
  ENDPROC
  PROCEDURE cmdcancelar.CLICK
    THISFORM.lRetorno=.F.
    THISFORM.HIDE
  ENDPROC
ENDDEFINE
* ----------------------------------------
*-- EndDefine: Login
* ----------------------------------------
Luis María Guayán

Buscar si Word o Excel están instalados

Con estas dos funciones podemos saber si Word ® o Excel ® están instalados en la PC.

*----------------------------------------------------
* FUNCTION BuscaWord
* Busca si MS Word está instalado en la PC
*----------------------------------------------------
FUNCTION BuscaWord
  LOCAL lcErrorAnt, loApp, CR
  CR = CHR(13)
  lcErrorAnt = ON("ERROR")
  ON ERROR DO _MiError
  loApp = CREATEOBJECT("Word.Application")
  IF VARTYPE(loApp) = "O"
    MESSAGEBOX("Nombre: " + loApp.NAME + CR + ;
      "Versión: " + loApp.VERSION + CR + ;
      "Build: " + TRANSFORM(loApp.BUILD), 64 )
    RELEASE loApp
  ELSE
    MESSAGEBOX("Word no está instalado", 16)
  ENDIF
  ON ERROR &lcErrorAnt
  RETURN
ENDFUNC

*----------------------------------------------------
* FUNCTION BuscaExcel
* Busca si MS Excel está instalado en la PC
*----------------------------------------------------
FUNCTION BuscaExcel
  LOCAL lcErrorAnt, loApp, CR
  CR = CHR(13)
  lcErrorAnt = ON("ERROR")
  ON ERROR DO _MiError
  loApp = CREATEOBJECT("Excel.Application")
  IF VARTYPE(loApp) = "O"
    MESSAGEBOX("Nombre: " + loApp.NAME + CR + ;
      "Versión: " + loApp.VERSION + CR + ;
      "Build: " + TRANSFORM(loApp.BUILD), 64 )
    RELEASE loApp
  ELSE
    MESSAGEBOX("Word no está instalado", 16)
  ENDIF
  ON ERROR &lcErrorAnt
  RETURN
ENDFUNC

*----------------------------------------------------
* PROCEDURE _MiError
* Usado por BuscaWord y BuscaExcel
*----------------------------------------------------
PROCEDURE _MiError
  RETURN
ENDPROC
*----------------------------------------------------

Luis María Guayán