11 de diciembre de 2012

Usando el Control Microsoft Date and Time Picker con valores de fecha y hora

Articulo original: "Using the Microsoft Date and Time Picker Control with Date and Time Values"
http://doughennig.blogspot.com/2008/06/using-microsoft-date-and-time-picker.html
Autor: Doug Hennig
Traducido por: Luis María Guayán

He usado el control ActiveX Microsoft Date and Time Picker (DTPicker). Ayer tropecé con un tema interesante. En primer lugar, algunos antecedentes.

El control tiene cuatro modos diferentes de ingreso de datos, a través de la propiedad Format: fecha corta, fecha larga, hora, y personalizado. Lo bueno de los tres primeros, es que utilizan automáticamente los ajustes de fecha y hora de la Configuración Regional en el Panel de control, por lo que no tiene que preocuparse por cuestiones de localización. La cuarta, se utiliza para los formatos personalizados.

El formato de hora está bien si sólo desea la hora, pero si quiere mostrar tanto la fecha y la hora, tiene que definir la propiedad Format a 3 para personalizarlo, luego, establezca la propiedad CustomFormat al formato deseado. Por ejemplo, "MM/dd/yyy HH:mm:ss" utiliza dos dígitos para la mayoría de los valores y los cuatro dígitos del año (sí, cuatro, aunque la cadena de formato utiliza tres). Sin embargo, aquí está la cuestión: ¿Cómo saber qué formato usar? El usuario puede estar utilizando MM/DD/AAAA, DD/MM/AAAA, o cualquier otra variedad de formatos.

Afortunadamente, VFP tiene varias funciones que retornan los formatos de fechas. SET("DATE") retorna valores como MDY o American para el formato MM/DD/AAAA, DMY o BRITISH para el formato DD/MM/AAAA, y así sucesivamente. SET("MARK") retorna el carácter que separa las partes de la fecha (como por ejemplo "/" o "-").

Tengo una subclase del control DTPicker llamada SFDatePicker (en realidad, es un contenedor que contiene un DTPicker) que ofrece funcionalidades adicionales, incluyendo el soporte a fechas vacías, datos obligatorios, como así también el control de formato. El control de formato se maneja a través de la propiedad personalizada lDateTime; el valor por omisión es .F. que significa que sólo la fecha aparece, mientras que .T. significa que se mostrará la fecha y la hora conjuntamente.

Suelte uno en un formulario, establezca la propiedad cControlSource a el control fuente que desea, configure lDateTime a .T. si desea la fecha y la hora, y listo.

El siguiente código en el método SetCustomFormat de SFDatePicker, que se llama en los métodos Init y Assiggn de lDateTime (en caso de que cambie la propiedad por programación), es necesario establecer CustomFormat:
with This  
  lcFormat = set('DATE')  
  if lcFormat <> 'SHORT' or .lDateTime  
    .oleDTPicker.Object.Format = 3  
    lcMark = set('MARK')  
    do case  
      case inlist(lcFormat, 'AMERICAN', 'MDY', 'USA', 'SHORT')  
        lcCustomFormat = 'MM' + lcMark + 'dd' + lcMark + 'yyy'  
      case inlist(lcFormat, 'BRITISH', 'DMY', 'FRENCH', ; 
        'GERMAN', 'ITALIAN')  
        lcCustomFormat = 'dd' + lcMark + 'MM' + lcMark + 'yyy'  
      case inlist(lcFormat, 'JAPAN', 'YMD', 'TAIWAN', 'ANSI')  
        lcCustomFormat = 'yyy' + lcMark + 'MM' + lcMark + 'dd'  
    endcase  
    if .lDateTime  
      lcCustomFormat = lcCustomFormat + ' HH:mm:ss'  
    endif .lDateTime  
    .oleDTPicker.CustomFormat = lcCustomFormat  
  endif lcFormat <> 'SHORT' ... 
endwith
Parece que este código se ocupa de los diferentes formatos de fecha adecuadamente, incluído el caracter de separación de la fecha, por lo que ¿cuál es el problema? Es muy sutil: Si utiliza SET SYSFORMATS ON, o sea que debe respetar la configuración regional del usuario, SET("DATE") retorna "SHORT". Este código asume que las fechas "cortas" son tratados como MDY.

Ahora el problema es cómo determinar cuál es el formato de fecha del usuario actual.Imaginé que una función de la API de Windows se ocuparía de esto, y encontré algunas posibilidades en MSDN, pero parece que estas funciones no pueden ser llamadas directamente desde VFP, ya que requieren funciones de llamada. Entonces, tomé el planteamiento de la fuerza bruta:
if lcFormat = 'SHORT' 
  ldDate = date(2008, 1, 3) 
  lcDate = dtoc(ldDate) 
  lnPos1 = at('8', lcDate) 
  lnPos2 = at('1', lcDate) 
  lnPos3 = at('3', lcDate) 
  do case 
    case lnPos1 < lnPos2 and lnPos2 < lnPos3 
      lcFormat = 'YMD' 
    case lnPos1 > lnPos2 and lnPos2 > lnPos3 
      lcFormat = 'DMY' 
    case lnPos1 > lnPos3 and lnPos3 > lnPos2 
      lcFormat = 'MDY' 
  endcase 
endif lcFormat = 'SHORT' 
Este código utiliza 01/03/2008 (en formato MDY) como una fecha, lo convierte en una cadena (que respeta la configuración regional de los usuarios), entonces de acuerdo al orden de los digitos para el mes, día y año, establecemos en consecuencia lcFormat.

Feo, sí, pero funciona, así que adelante con ella hasta que una solución más elegante esté disponible.

Actualización: Imaginé que había una forma mejor de hacer esto. Mientras miraba el código de la linda clase ctl32_datepicker de Carlos Alloatti, me encontré que el uso SET('DATE',1). Buscando en el archivo de ayuda de VFP, descubrí que esta era exactamente la función que yo necesito. No puedo creer que no conocia esto (o mas probable) que lo olvide. De esta manera ahrora el código es mas sencillo y limpio:
if lcFormat = 'SHORT' 
  lnDate = set('DATE', 1) 
  do case 
    case lnDate = 0 
      lcFormat = 'MDY' 
    case lnDate = 1 
      lcFormat = 'DMY' 
    otherwise 
      lcFormat = 'YMD' 
  endcase 
endif lcFormat = 'SHORT' 
Si eres curioso sobre cómo las otras características trabajan, aquí están los detalles.

Soporte a ControlSource: Como he mencionado anteriormente, cControlSource es una propiedad personalizada que contiene el nombre del ControlSource si así se desea. También hay una propiedad Value, por lo que el control puede estar ligado otros controles. Refresh actualiza Value desde el ControlSource:
if not empty(This.cControlSource) 
  This.Value = evaluate(This.cControlSource) 
endif not empty(This.cControlSource)
El evento Change del DTPicker, que se dispara cuando el usuario cambia la fecha y/u hora, plantea un evento personalizado DateChanged del contenedores. DateChanged actualiza el ControlSource, lo que podría ser un campo en un cursor u otra cosa, como una propiedad de un objeto:
with This 
  lcAlias = juststem(.cControlSource) 
  lcField = justext(.cControlSource) 
  do case 
      case empty(.cControlSource) 
      case used(lcAlias) 
        replace &lcField with .Value in (lcAlias) 
      otherwise 
        store .Value to (.cControlSource) 
  endcase 
endwith
Value_Access obtiene el valor desde DTPicker, cambiando a un Fecha, si una FechaHora no es necesario:
luValue = This.oleDTPicker.Object.Value 
if not This.lDateTime 
  luValue = ttod(luValue) 
endif not This.lDateTime 
return luValue
Soporte de Fecha en blanco: Si ha trabajado con el control DTPicker, sabe que no le gustan las fechas en blanco. Así, el código en Value_Assign utiliza la fecha y hora actual en ese caso. Además, ya que DTPicker espera que su propiedad Value tome un valor de fecha y hora, tenemos que manejar el paso a fecha:
lparameters tuValue 
local luValue 
with This 
  do case 
    case empty(tuValue) 
      luValue = datetime() 
    case vartype(tuValue) = 'D' 
      luValue = dtot(tuValue) 
    case vartype(tuValue) = 'T' 
      luValue = tuValue 
    otherwise 
      luValue = .NULL. 
  endcase 
  if not isnull(luValue) 
    try 
      .oleDTPicker.Object.Value = luValue 
      if not .CalledFromThisClass() 
        raiseevent(This, 'DateChanged') 
      endif not .CalledFromThisClass() 
    catch 
      endtry 
  endif not isnull(luValue) 
endwith

3 de diciembre de 2012

Programación Orientada a Objetos: Clonación


Para quienes estén acostumbrados a la Programación Orientada a Objetos les será común la expresión de que los objetos se manipulan por referencias a los mismos. La mejor manera de explicar este concepto es con un ejemplo sencillo.

Imaginemos el siguiente código:
obj1 = CREATEOBJECT("Custom")
obj2 = obj1
obj2.Comment = "Un valor cualquiera"
obj3 = obj2
? obj3.Comment
? obj1.Comment
¿Cuántos objetos de tipo (clase) Custom existen en memoria durante este fragmento de código?

¿Respondió 3: obj1, obj2 y obj3? Lo lamento. La respuesta es incorrecta. Existe solo un objeto Custom (el creado con CREATEOBJECT). Obj1, obj2 y obj3 son 3 referencias al mismo objeto Custom.

Por lo tanto, ¿cuál sería la salida por pantalla de este código? Se imprimirían 2 líneas con la cadena de caracteres "Un valor cualquiera". Si no me cree a esta altura, lo invito a que haga la prueba. Esto es así porque, como ya dijimos, el objeto es único. Se modificó el estado del objeto mediante la referencia obj2 (cuando se le asignó un valor a Comment). Luego, con cualquiera de las otras referencias, se verá el mismo valor, ya que apuntan al mismo objeto. El tema de las referencias es similar a utilizar apodos. La persona es única, pero puede responder a su nombre real o a alguno de sus apodos.

Por un lado, el manejo por referencia es útil: mejora el uso de memoria o facilita la modificación de un objeto compartido por varias funcionalidades. En otros casos, es un verdadero dolor de cabeza, porque se necesitaría, tal vez, copiar el objeto o duplicarlo. Algunos casos prácticos:
  • Imagine que cuenta con una clase Cliente y quiere modificar los datos de un cliente particular (objeto). Empieza a cambiar los valores y luego presiona sobre Cancelar. ¿Cómo vuelve atrás los cambios? Sería genial contar con una copia del original sin modificaciones.
  • Suponga ahora que quiere duplicar un objeto de tipo Factura, para no tener que cargar nuevamente todos los datos. ¿Cómo lo hacemos? Recuerde que Factura2 = Factura1 no genera un objeto nuevo y distinto.
Para casos como los anteriores es que se comenzaron a aplicar técnicas de clonación de objetos. ¿En qué se basan estas técnicas? Básicamente, en copiar, propiedad por propiedad, desde un objeto hacia otro. Pero cuidado, alguna de esas propiedades puede ser otro objeto, y volvemos con las referencias. Esto nos lleva a que hay dos tipos de clonaciones: una superficial, donde se genera un nuevo objeto y se le asignan los mismos valores que el objeto origen; y una profunda, donde se genera un nuevo objeto y, por cada propiedad, se analiza si se puede asignar (es un tipo primitivo) o si es necesario clonar también esa propiedad componente (es un tipo objeto dentro del objeto principal o un array).

Es difícil plantear una clonación genérica porque no se puede violar el principio de ocultamiento de la Programación Orientada a Objetos. Es decir, un clonador genérico solamente puede utilizar las propiedades públicas de un objeto. De ser necesario, cada clase, que tiene acceso a sus atributos ocultos, podría implementar un método para clonarse, de la forma:
DEFINE CLASS UnaClase AS CUSTOM
  HIDDEN propiedad1
  HIDDEN propiedad2
  HIDDEN propiedad3

  PROCEDURE Clonar() AS OBJECT
    obj2 = CREATEOBJECT("UnaClase")
    obj2.setPropiedad1(THIS.propiedad1)
    obj2.setPropiedad2(THIS.propiedad2)
    obj2.setPropiedad3(THIS.propiedad3)
    RETURN obj2
  ENDPROC

  * Faltarían los PROCEDURES para setPropiedad1, setPropiedad2 y setPropiedad3
  
ENDDEFINE
Engorroso, ¿no? Imagine un objeto con muchas propiedades ocultas. Sin embargo, a veces, suele ser la única opción.



Clase Clonador

Volviendo al caso de los objetos con propiedades públicas, hace un tiempo desarrollé una clase para que funcione como clonador genérico. Obviamente, funciona solamente para las propiedades públicas de los objetos, pero muchas veces suele ser suficiente con esto. La clase se basa en el uso de macrosustitución y las funciones AMEMBERS, PEMSTATUS y EVALUATE. A continuación se ve un PRG con la clase Clonador más una clase llamada UnaClase, para hacer una prueba.
LOCAL obj1, obj2
obj1 = CREATEOBJECT("UnaClase")
clonador = CREATEOBJECT("Clonador")
obj2 = clonador.clonar(obj1)
obj2.propiedad = .NULL.

? obj1.propiedad
? obj2.propiedad

DEFINE CLASS UnaClase AS CUSTOM
  propiedad = ""
  PROCEDURE INIT()
    THIS.propiedad = CREATEOBJECT("Collection")
    THIS.propiedad.ADD(CREATEOBJECT("ClaseAuxiliar", "Hola"))
    THIS.propiedad.ADD(CREATEOBJECT("ClaseAuxiliar", "Chau"))
  ENDPROC
ENDDEFINE

DEFINE CLASS ClaseAuxiliar AS CUSTOM
  propiedadAux = ""
  PROCEDURE INIT(valor)
    THIS.propiedadAux = valor
  ENDPROC
ENDDEFINE

DEFINE CLASS Clonador AS CUSTOM

  PROCEDURE clonar(OBJREF AS OBJECT) AS OBJECT
    IF VARTYPE(OBJREF) <> "O"
      RETURN OBJREF
    ENDIF

    LOCAL ARRAY laMiembros(1,3)
    LOCAL i AS INTEGER, objRef2 AS OBJECT, lcPropiedad AS STRING, lcClaseBase AS STRING
    objRef2 = CREATEOBJECT(OBJREF.CLASS)

    FOR i = 1 TO AMEMBERS(laMiembros, OBJREF, 1, "G")
      IF ALLTRIM(UPPER(laMiembros[i,2])) == "PROPERTY"
        lcPropiedad = laMiembros[i,1]
        lcClaseBase = "objRef." + lcPropiedad + ".BaseClass"
        DO CASE
          CASE TYPE("objRef." + lcPropiedad) == "O" AND ALLTRIM(UPPER(EVALUATE(lcClaseBase))) == "COLLECTION"
            objRef2.&lcPropiedad = THIS.clonarColeccion(EVALUATE("objRef." + lcPropiedad))
          CASE TYPE("objRef." + lcPropiedad) == "O"
            objRef2.&lcPropiedad = THIS.clonar(EVALUATE("objRef." + lcPropiedad))
          CASE TYPE("objRef." + lcPropiedad, 1) == "A"
            THIS.clonarArray(OBJREF, lcPropiedad, objRef2, lcPropiedad)
          OTHERWISE
            IF NOT PEMSTATUS(objRef2, lcPropiedad, 1)  && No es de solo lectura.
              objRef2.&lcPropiedad = EVALUATE("objRef." + lcPropiedad)
            ENDIF
        ENDCASE
      ENDIF
    ENDFOR
    RETURN objRef2
  ENDPROC

  HIDDEN PROCEDURE clonarArray(objOrigen, cOrigen, objDestino, cDestino)
    LOCAL ARRAY aOrigen(1), aDestino(1)
    ACOPY(objOrigen.&cOrigen, aOrigen)
    LOCAL i AS INTEGER, j AS INTEGER
    IF ALEN(aOrigen, 2) == 0
      DIMENSION objDestino.&cDestino(ALEN(aOrigen, 1))
      FOR i = 1 TO ALEN(aOrigen, 1)
        objDestino.&cDestino[i] = THIS.clonar(aOrigen[i])
      ENDFOR
    ELSE
      DIMENSION objDestino.&cDestino(ALEN(aOrigen, 1), ALEN(aOrigen, 2))

      FOR i = 1 TO ALEN(aOrigen, 1)
        FOR j = 1 TO ALEN(aOrigen, 2)
          objDestino.&cDestino[i, j] = THIS.clonar(aOrigen[i, j])
        ENDFOR
      ENDFOR
    ENDIF
  ENDPROC

  HIDDEN PROCEDURE clonarColeccion(objCol AS COLLECTION) AS COLLECTION
    LOCAL oClon AS COLLECTION
    oClon = CREATEOBJECT("Collection")

    LOCAL obj AS OBJECT
    FOR EACH obj IN objCol
      oClon.ADD(THIS.clonar(obj))
    ENDFOR
    RETURN oClon
  ENDPROC
ENDDEFINE
Note que de esta forma se puede modificar el atributo propiedad de obj2 sin perjudicar al objeto apuntado por la referencia obj1. En este caso, existen dos instancias de la clase UnaClase: la apuntada por obj1, definida explícitamente, y la apuntada por obj2, creada por reflexión de código dentro del método clonar, en la línea objRef2 = CREATEOBJECT(objRef.Class).

Note también que los Arrays y los objetos de tipo Collection merecen un tratamiento especial. El ejemplo está armado a propósito con objetos de tipo Collection.

Espero que les sea útil.

Pablo Lissa

13 de noviembre de 2012

Migrar Vistas Remotas a CursorAdapter

Para los que hemos desarrollado aplicaciones Cliente-Servidor, con nuestro querido Zorro, el uso de la tecnología de Vistas Remotas ha sido sin duda la primera opción. Bajo esta suposición, puede que nos hayamos sentido a gusto desarrollando aplicaciones hasta la versión 7, de allí en adelante sin embargo, VFP incorporó otros cambios sustanciales y específicamente en la administración y gestión de datos y que podríamos usar como alternativa: La tecnología CursorAdapter. Ahora toca contarles por que decidí cambiarme a esta última.

Una de las mayores dificultades que encontré en la versión 8 y 9 al trabajar con Vistas Remotas , fue la pésima gestión que tiene VFP al momento de gestionar la concurrencia y las conexiones en el servidor, hablando un poco más claro: Me refiero a que la propiedad Shareconection de las vistas remotas. Esta propiedad controla la apertura de una nueva conexión cada que se abre una vista remota en una determinada sesión de datos. Es decir si esta propiedad se establece como verdadera (.T.) , nos aseguraremos de que al abrir el primer cursor o vista remota generaremos un numero de conexión determinado para ella, y las vistas que se abran posteriormente compartirán este mismo hilo de conexión (Siempre y cuando que estas tengan la propiedad Shareconecction establecida a TRUE) , de esta manera tendremos varias vistas abiertas con una sola conexión. Al hacer esto tenemos asegurado lo siguiente:
  • Manejo eficiente de las conexiones al servidor
  • Mejor manejo de las Transacciones, en especial al actualizar las vistas con las funciones TABLEUPDATE(), SQLCOMMIT() y SQLROLLBACK()
  • Mejor administración de código
La mala noticia es que en la versión 9, no respeta el valor de la propiedad ShareConection, por lo que se abrirán tantas conexiones como vistas se abran.

Por esta razón, decido cambiarme a la tecnología CursorAdapter , pero esto significa cambiar algunas cosas en el código de las aplicaciones que hayamos escrito anteriormente, y ese el principal motivo de este artículo. En primer lugar debemos de tener en cuenta que CursorAdapter Tiene las propiedades y comportamientos que cualquier cursor o vista remota y aun más todavía. De modo que si logramos abrir Cursores derivados de CursorAdapter con las mismas propiedades que nuestras vistas en el entorno de datos, no tendremos que cambiar nuestro código. Tendremos que preocuparnos entonces de crear y configurar los objetos CursorAdapter de tal manera que se comporten tal y como nuestras vistas remotas, el mejor lugar y el momento de hacerlo para cumplir el objetivo propuesto es sin dudas el evento BeforeOpenTables del Entorno de datos de nuestro formulario:

En primer lugar vamos a definir una clase heredada de la Clase CursorAdapter para inicializar algunas propiedades y agregar unos métodos a nuestra conveniencia. Lo podemos hacer dentro de una archivo Prg.
DEFINE CLASS CursorVista AS CURSORADAPTER

  && Estas 2 siguientes propiedades pueden establecerse
  && dinamicamente de acuerdo a las
  && Técnicas que el programador este usando

  DATASOURCETYPE="ODBC"
  DATASOURCE=SQLSTRINGCONNECT("DSN=PostgreSQL31W;DATABASE=guia;SERVER=localhost;PORT=5432;UID=miusuario;PWD=miclave" + ;
    ";CA=d;A6=;A7=100;A8=4096;B0=255;B1=8190;BI=0;C2=dd_;CX=1b502bb;A1=7.4-1")
  ALLOWDELETE = .T.
  ALLOWINSERT = .T.
  ALLOWUPDATE = .T.
  NODATA = .T.
  PREPARED = .T.
  SENDUPDATES = .T.
  WHERETYPE = 1

  && Este método toma como parámetro el nombre de la base de datos y el
  && nombre de la vista que está contenida en la misma, luego clona
  && todos las propiedades de la vista y las traslada al Objeto Cursor
  && Adapter Correspondiente

  PROCEDURE atrapavista
    LPARAMETERS Pnombredb,Pnombrevista
    && veriifcando que este abierta la base de datos
    IF OCCURS(ALLTRIM(UPPER(PnombreDB)) , ALLTRIM(UPPER(DBC()))) > 0 THEN
      THIS.ALIAS=Pnombrevista
      THIS.SELECTCMD=DBGETPROP(Pnombrevista,"VIEW","SQL")
      THIS.TABLES=DBGETPROP(Pnombrevista,"VIEW","Tables")
      DIMENSION papedazos(1)
      THIS.explotacadena(',',ALLTRIM(UPPER(STREXTRACT(THIS.SELECTCMD,'SELECT ',' FROM '))),@papedazos)
      FOR K=1 TO ALEN(papedazos)
        STORE THIS.aclaracampo(papedazos(k)) TO papedazos(k)
        THIS.CURSORSCHEMA=THIS.CURSORSCHEMA+papedazos(k)+SPACE(2)+DBGETPROP(Pnombrevista+'.'+papedazos(k),"FIELD","DataType")+ ','
        THIS.UPDATENAMELIST=THIS.UPDATENAMELIST+IIF(DBGETPROP(Pnombrevista+'.'+papedazos(k),"FIELD","Updatable"),papedazos(k)+ ;
          SPACE(2)+DBGETPROP(Pnombrevista+'.'+papedazos(k),"FIELD","Updatename")+',',"")
        THIS.UPDATABLEFIELDLIST=THIS.UPDATABLEFIELDLIST+IIF(DBGETPROP(Pnombrevista+'.'+Papedazos(k),"FIELD","Updatable"),Papedazos(k)+',',"")
        THIS.KEYFIELDLIST=THIS.KEYFIELDLIST+IIF(DBGETPROP(Pnombrevista+'.'+papedazos(k),"FIELD","KeyField"),Papedazos(k)+',',"")
      ENDFOR
      THIS.CURSORSCHEMA=SUBSTR( THIS.CURSORSCHEMA,1,LEN(THIS.CURSORSCHEMA)-1)
      THIS.UPDATABLEFIELDLIST=SUBSTR(THIS.UPDATABLEFIELDLIST,1,LEN(THIS.UPDATABLEFIELDLIST)-1)
      THIS.KEYFIELDLIST=SUBSTR(THIS.KEYFIELDLIST,1, LEN(THIS.KEYFIELDLIST)-1)
      RETURN 1
    ELSE
      MESSAGEBOX("No esta abierta la base de datos ","")
    ENDIF
  ENDPROC

  PROCEDURE explotacadena
    LPARAMETERS PCARACTER, PCADENA, apedazos
    PCARACTER=ALLTRIM(UPPER(PCARACTER))
    PCADENA=ALLTRIM(UPPER(PCADENA))
    LOCAL NCANTIDADEVECES

    NCANTIDADEVECES=OCCURS(PCARACTER,PCADENA)
    DIMENSION APEDAZOS  (ncantidadeveces+1)

    FOR I=1 TO NCANTIDADEVECES+1
      IF I=1
        pedazo=SUBSTR(PCADENA,1,AT(PCARACTER,PCADENA,I)-1)
      ELSE
        IF I=NCANTIDADEVECES +1
          pedazo=SUBSTR(PCADENA,RAT(PCARACTER,PCADENA,1)+1)
        ELSE
          pedazo=SUBSTR(PCADENA,AT(PCARACTER,PCADENA,I-1)+1,AT(PCARACTER,PCADENA,I)-AT(PCARACTER,PCADENA,I-1)-1)
        ENDIF
      ENDIF
      STORE pedazo TO Apedazos(i)
    ENDFOR
    RETURN @APEDAZOS
  ENDPROC

  PROTECTED PROCEDURE aclaracampo
    LPARAMETERS Pnombrecampo
    LOCAL auxcampo AS STRING
    PNOMBRECAMPO=ALLTRIM(UPPER(PNOMBRECAMPO))
    IF AT(' AS ',pnombrecampo) > 0 THEN
      IF AT(' AS ',pnombrecampo,2) > 0 THEN
        auxcampo=STREXTRACT(pnombrecampo,' AS ','',2)
      ELSE
        auxcampo=STREXTRACT(pnombrecampo,' AS ','')
      ENDIF
    ELSE
      IF AT('.',pnombrecampo) > 0 THEN
        auxcampo=STREXTRACT(pnombrecampo,'.','')
      ELSE
        auxcampo=pnombrecampo
      ENDIF
    ENDIF
    RETURN AUXCAMPO
  ENDPROC

ENDDEFINE
Nuestro formulario de ejemplo simula una guía de remisión electrónica, con datos del encabezado y una grilla con el detalle de los ítems del documento usaba originalmente 4 vistas remotas de las cuales:

Vw_guia: Vista con los datos del encabezado, con campos de varias tablas remotas, es actualizable y esta parametrizada, almacenamiento de optimista de fila. (Buffering=3)
VW_detgui: Detalle del documento, actualizable y parametrizada, almacenamiento optimista de tabla (Buffering=5)
Vw_embarcaciones: Vista no parametrizada y abre datos maestros de una tabla remota. No es actualizable
vw_documentos_correo: Vista parametrizada que contiene datos maestros de una tabla remota, no es actualizable.

Luego en el evento BeforeOpenTables del entorno de datos del formulario, debemos de crear los objetos y agregarlos como cursores miembros, de la siguiente manera según las características de cada vista:
&& Objeto que clona a la vista vw_guia
guia=CREATEOBJECT("CursorVista")
THIS.ADDOBJECT("guia","CursorVista")
THIS.guia.atrapavista("geus","vw_guia")
THIS.guia.ALIAS="vw_guia"
THIS.guia.NODATA=.T.
IF !THIS.guia.CURSORFILL()
  AERROR(nn)
  MESSAGEBOX(nn(1,2),"")
ELSE
  * this.guia.cursorrefresh()
ENDIF

&& Objeto que clona a la vista vw_detgui
detalle=CREATEOBJECT("CursorVista")
THIS.ADDOBJECT("detalle","CursorVista")
THIS.detalle.NODATA=.T.
THIS.detalle.atrapavista("geus","vw_detgui")
THIS.detalle.ALIAS="vw_detgui"
THIS.DETALLE.BUFFERMODEOVERRIDE=5 &&Almacenamiento de tabla
IF !THIS.detalle.CURSORFILL()
  AERROR(nn)
  MESSAGEBOX(nn(1,2),"")
ELSE
  *this.detalle.cursorrefresh()
ENDIF

&& Objeto que clona a la vista vw_embarcaciones
embarcaciones=CREATEOBJECT("CursorVista")
THIS.ADDOBJECT("embarcaciones","CursorVista")
THIS.embarcaciones.NODATA=.F. &&No esta parametrizada, cargar los datos sin mas
THIS.embarcaciones.atrapavista("geus","vw_embarcaciones")
THIS.embarcaciones.ALIAS="vw_embarcaciones"
IF !THIS.embarcaciones.CURSORFILL()
  AERROR(nn)
  MESSAGEBOX(nn(1,2),"")
ELSE
  THIS.embarcaciones.CURSORREFRESH() &&Cargar los datos sin mas
ENDIF

&& Objeto que clona a la vista vw_documentos_correo
documentos_correo=CREATEOBJECT("CursorVista")
THIS.ADDOBJECT("documentos_correo","CursorVista")
THIS.documentos_correo.atrapavista("geus","vw_documentos_correo")
THIS.documentos_correo.ALIAS="vw_documentos_correo"
IF !THIS.documentos_correo.CURSORFILL()
  AERROR(nn)
  MESSAGEBOX(nn(1,2),"")
ELSE
  THIS.documentos_correo.NODATA=.T.
  *this.documentos_correo.cursorrefresh()
ENDIF
En los dos primeros casos como ambos Objetos se derivan de vistas parametrizadas, se configura la propiedad NoData a FALSE con lo que nos aseguramos que el método CursorFill() no desencadene el cuadro de dialogo solicitando el valor del parámetro, en el tercer caso a diferencia de los anteriores al tratarse de una vista sin parámetros se cargan los datos sin restricciones, en el cuarto caso al igual que los dos primeros el método CursosFill() solo abrirá el cursor vacio en la sesión, quedando a nuestra cuenta invocar a los datos posteriormente con el método CursorRefresh(), esto puede hacerse en el evento Init o load del formulario en cuestión suministrando para ello el valor del parámetro que filtrara los datos.

A partir de entonces ya se puede trabajar con los Cursores CursorAdapter como si se trataran de Vistas Remotas, y lo mejor de todo esto es que solo se ha abierto un solo hilo de conexión.

Julián [HIPOGEA]

9 de noviembre de 2012

BLOQUEOS VIRTUALES EN MySQL

De todos es bien sabido la imposibilidad de bloquear registros individuales en MySQL u otras bases de datos de arquitectura Cliente-Servidor. Pero en MySQL, con un poco de imaginación, es posible realizar un bloqueo "virtual"simulando un bloqueo de registro...

BLOQUEOS "VIRTUALES" CON MySQL

De todos es bien sabido la imposibilidad de bloquear registros individuales en MySQL u otras bases de datos de arquitectura Cliente-Servidor. No existe la función RLOCK() como la conocemos para tablas DBF, que permite bloquear un registro o varios en el area de trabajo que le designamos, o que estamos posicionados en ese momento.

Pero en MySQL, con un poco de imaginación, Si es posible realizar un bloqueo "virtual", simulando un bloqueo de registro. Ahora vamos a ver como.

Para ello se utilizan tres funciones propias de la base de datos MySQL:

GET_LOCK(str,timeout)

Intenta obtener un bloqueo con el nombre dado por la cadena str, con un tiempo límite de timeout segundos.  Devuelve 1 si se ha obtenido el bloqueo, 0 si no se ha obtenido en el tiempo indicado (por ejemplo, porque otro cliente ha bloqueado ya el nombre), o NULL si ha habido un error (como falta de memoria o si el hilo fue matado por mysqladmin kill). Un bloqueo se libera cuando se ejecuta la función , se ejecuta un nuevo GET_LOCK() o el hilo termina (ya sea normal o anormalmente). Esta función se puede usar para implementar bloqueos de aplicación o para simular bloqueos de registro. Los nombres se bloquean en bases del servidor. Si un nombre ha sido bloqueado por un cliente, GET_LOCK() bloquea cualquier petición de otro cliente para bloquear el mismo nombre. Esto permite que clientes que se ponen de acuerdo para bloquear un nombre dado usar el mismo nombre para realizar un bloqueo coordinado.

IS_FREE_LOCK(str)

Verifica si el nombre de bloqueo str está libre para usarse (es decir, no está bloqueado). Devuelve 1 si el bloqueo está libre (nadie está usando el bloqueo), 0 si el bloqueo está en uso y NULL si hay errores (como argumentos incorrectos).

RELEASE_LOCK(str)

Libera el bloqueo con el nombre str que se obtuvo mediante. Devuelve 1 si el bloqueo fue liberado, 0 si no fue bloqueado por este hilo (en cuyo caso no fue liberado), y NULL si el nombre de bloqueo no existe. (El bloqueo no existirá si nunca fue obtenido por una llamada a o si ya ha sido liberado.) Es conveniente usar la sentencia con RELEASE_LOCK().

Vamos a ver un ejemplo de su utilización con VFP y a través de SQL Pass Through.
El ejemplo va a consistir en el bloqueo de un código determinado, es indiferente que sea un código de Cliente, de Proveedor, de un Artículo, o un número de Factura. Para el ejemplo vamos a seguir tres pasos:
  • Conectarnos a la base de datos MySQL
  • Realizar un bloqueo virtual a un código determinado (LOCK)
  • Liberar dicho bloqueo (UNLOCK)
Conexión a una base de datos MySQL.
cSQL=  "DRIVER={MySQL ODBC 5.1 Driver};" + ;
       "SERVER=localhost" + ;
       "PORT=3306" + ;
       "UID=xxxx" + ;
       "PWD=xxxx" + ;
       "DATABASE=MyBaseDatos" + ;
       "OPTION=2049"
 
SQLSETPROP(00,"Transactions", 1) 
SQLSETPROP(00,"DispLogin", 3)          
 
NH = SQLSTRINGCONNECT(""+cSQL, .T.)
IF NH < 0
MESSAGEBOX("Error de CONEXIÓN : " + ALLT(STR(NH)),48,"Atencion")
ENDIF

Realizar un bloqueo virtual 

El ejemplo muestra el intento de bloqueo de un código almacenado en la variable cKey . La función GET_LOCK reintenta automáticamente el bloqueo durante 10 segundos. Si consigue el bloqueo exitosamente devuelve el valor ‘1’, y salimos del bucle DO WHILE. Si al cabo de 10 segundos no es así, el valor devuelto será ‘0’ o Nulo con lo cual mostraremos un mensaje indicando que el código ya se encuentra bloqueado, o que su bloqueo es imposible.

También se puede utilizar la función IS_FREE_LOCK, para comprobar si el código en cuestión se encuentra bloqueado.
cKey="000001" && Código a Bloquear

DO WHILE .T.

     cSQL="SELECT IFNULL(GET_LOCK('"+cKey+"',10),'0') AS cRESULT"   
     SQLEXEC(NH,""+cSQL,"CURSOR")
     SELECT CURSOR
     GO TOP
     IF ALLTRIM(CURVAL(""+FIELD(1),"CURSOR"))="1"
          EXIT     && Código Bloqueado
     ENDIF

     OPB=MESSAGEBOX("Error de BLOQUEO   Reintentar",5+48+0,"Atencion")
     IF OPB <> 04
          EXIT
     ENDIF

ENDDO

Liberar Bloqueo


11 de octubre de 2012

Liberar memoria de una aplicación VFP

Código del australiano Bernard Bout que permite liberar la memoria en las aplicaciones de Visual FoxPro en ejecución, reduciendo la memoria consumida por una aplicación VFP.

Este consumo aumenta por la caché que mantiene Fox para algunas sentencias SELECTs, los cursores en la memoria, la carga de imágenes, etc.

Lo curioso, es que si uno minimiza la aplicación, el consumo de memoria disminuye, porque Windows maneja esta caché y libera la memoria. Esto también es válido para otras aplicaciones, no solo para VFP.

Aquí Bernard nos provee la siguiente función que reduce el consumo de memoria (sin la necesidad de minimizar la aplicación) y la podemos ejecutar desde nuestra aplicación VFP en cualquier momento.
***********************************************
* Function....:  ReduceMemory()
* Author......:  Bernard Bout
* Date........:  05/12/2007 3:03:15 PM
* Returns.....:
* Parameters..:
* Notes.......:  reduces memory usage for vfp
***********************************************
FUNCTION ReduceMemory()
  DECLARE INTEGER SetProcessWorkingSetSize ;
    IN kernel32 AS SetProcessWorkingSetSize ;
    INTEGER hProcess , ;
    INTEGER dwMinimumWorkingSetSize , ;
    INTEGER dwMaximumWorkingSetSize
  DECLARE INTEGER GetCurrentProcess ;
    IN kernel32 AS GetCurrentProcess
  nProc = GetCurrentProcess()
  bb = SetProcessWorkingSetSize(nProc,-1,-1)
ENDFUNC
***********************************************
Fuente: http://www.foxite.com/faq/default.aspx?id=55

10 de octubre de 2012

Grilla con porcentajes gráficos

Código del turco Cetin Basoz publicado en el Foro de Foxite.com (http://www.foxite.com/forum)



oForm = CREATEOBJECT("myForm")
oForm.SHOW(1)

DEFINE CLASS myForm AS FORM
  AUTOCENTER = .T.
  CAPTION = "Ejemplo de Grid con barras de porcentajes"
  ADD OBJECT myGrid AS GRID

  PROCEDURE LOAD
    CREATE CURSOR myProcess (percent i, NAME c(10))
    RAND(-1)
    FOR ix = 1 TO 100
      INSERT INTO myProcess VALUES (INT(RAND()*100), SYS(2015))
    ENDFOR
    LOCATE
  ENDPROC

  PROCEDURE INIT
    WITH THIS.myGrid
      .ADDCOLUMN(.COLUMNCOUNT+1)
      .COLUMNS(.COLUMNCOUNT).CONTROLSOURCE = "myProcess.Percent"
      .COLUMNS(.COLUMNCOUNT).DYNAMICFONTBOLD = "!(thisform.UpdateContainer(this.columns(1).myPercent))"
      .COLUMNS(.COLUMNCOUNT).Header1.CAPTION = "Porcentaje"

      .WIDTH = THISFORM.WIDTH
      .HEIGHT = THISFORM.HEIGHT
      .ANCHOR = 15
    ENDWITH

    WITH THIS.myGrid.COLUMNS(1)
      .ADDOBJECT("myPercent","myContainer")
      .myPercent.WIDTH = .WIDTH
      .myPercent.lblPercent.WIDTH = .WIDTH
      .myPercent.VISIBLE = .T.
      .DYNAMICFONTBOLD = "Thisform.UpdateContainer(this.columns(1).myPercent)"
      .CURRENTCONTROL = "myPercent"
      .SPARSE = .F.
    ENDWITH

    THIS.myGrid.COLUMNS(1).ENABLED = .F.
  ENDPROC

  PROCEDURE UpdateContainer(toContainer)
    WITH toContainer
      .shpPercent.BACKCOLOR = IIF(percent > 90, 0xFF, IIF(percent > 70, 0x00FFFF, 0x00FF00))
      .shpPercent.WIDTH = toContainer.PARENT.WIDTH * percent/100
      .lblPercent.CAPTION = TRANSFORM(percent) + "%"
    ENDWITH
  ENDPROC
ENDDEFINE

DEFINE CLASS myContainer AS CONTAINER
  BACKCOLOR = 0xFFFFFF
  BORDERWIDTH = 0
  ADD OBJECT shpPercent AS SHAPE WITH BORDERSTYLE = 0
  ADD OBJECT lblPercent AS LABEL WITH ALIGNMENT = 2 ,BACKSTYLE=0
ENDDEFINE

8 de septiembre de 2012

Chequear el estado de un sitio de Internet

En una consulta en el foro de la Comunidad de Visual FoxPro en Español, Daniel preguntaba cómo chequear si un sitio específico de Internet daba error (por ejemplo 404).

Esto podría hacerse usando un request HTTP con Microsoft.XMLHTTP, a continuación un ejemplo simple:
#define HTTP_OK        200
CLEAR 
LOCAL oIE as InternetExplorer.Application

sUrl = "http://www.moogle.com.ar"

nStatus = CheckHttpConnection(sUrl)
IF nStatus==HTTP_OK
    oIE = CREATEOBJECT ("InternetExplorer.Application")
    WITH oIE
        .Visible = .T.
        .Navigate (sUrl)
        DO WHILE .Busy
            DOEVENTS 
        ENDDO

        * .Quit()
    ENDWITH
ELSE 
    ? sUrl, "error", nStatus
ENDIF 
RETURN 

FUNCTION CheckHttpConnection(sUrl)
LOCAL oHTTP AS Microsoft.XMLHTTP

oHTTP = CREATEOBJECT("Microsoft.XMLHTTP")
oHTTP.Open("GET", sUrl, .F.)
oHTTP.Send()
RETURN oHTTP.Status

Espero les sea de utilidad.

Saludos,

Mario Lopez

17 de agosto de 2012

Validar DNI Peruano

Aquí les dejo una rutina para validar el DNI Peruano ya sea los antiguos o los nuevos:

? CheckDni("011637057")

*/-- Verificador y Generador de DNI peruano: Antiguos y Nuevos
Function CheckDNI
LParameters tcDni, tlGenera, tlNumero
Local luResult, lnTotal, lnIndex, lnFactor, lnDigito, lnPosicion, lnNumero, lcNumeros, lcLetra, lcLetras

    tlGenera = Iif(Vartype(tlGenera) == "L", tlGenera, .F.)
    tlNumero = Iif(Vartype(tlNumero) == "L", tlNumero, .F.)
    
    If !tlGenera And Len(tcDni) != 9
       Return .T.
    EndIf
   
    lcLetras  = "KABCIEFGHI" && Antiguo DNI
    lcNumeros = "6789011234" && Nuevo DNI
    
    lnTotal   = 0
    For lnIndex = 1 To 8
        lnFactor = Int(Val(Substr("32765432", lnIndex, 1)))
        lnDigito = Int(Val(Substr(tcDni, lnIndex, 1)))
        lnTotal  = lnTotal + (lnFactor * lnDigito)
    EndFor
    lnPosicion = 11 - Mod(lnTotal, 11)
    If lnPosicion = 11
       lnPosicion = 0
     Else
       If lnPosicion = 10
          lnPosicion = 1
       EndIf
    EndIf
    lnNumero = Int(Val(Substr(lcNumeros, lnPosicion + 1, 1)))
    lcLetra  = Substr(lcLetras, lnPosicion + 1, 1)
    If tlGenera
       If tlNumero
          luResult = lnNumero
        Else
          luResult = lcLetra
       EndIf
     Else
       luCheck = Right(tcDni, 1)
       If IsAlpha(luCheck)
          luResult = luCheck == lcLetra
        Else
          luCheck  = Int(Val(luCheck))
          luResult = luCheck == lnNumero
       EndIf
    EndIf
Return (luResult)
Saludos.

Roberto Reategui Kanashiro

30 de julio de 2012

Códigos de Barras QR sin utilizar la API de Google.

Que tal Compañeros. Navegando por la web, encontré una dll para la generación de códigos de barra de dos dimensiones QR.

Esta Dll tiene una función llamada GenerateFile con la que de una manera simple, podemos generar el Código QR sin tantas complicaciones.

Código para generar un archivo QR:
*--------------------------------------
DECLARE INTEGER GenerateFile ;
	  IN BarCodeLibrary.dll ;
	  STRING cData, ;
	  STRING cFileName

*- GenerateFile(Texto a codificar, Archivo a generar)
GenerateFile("http://www.portalfox.com","potalfoxQR.bmp")

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

Nota del editor:

La librería tiene también otra función que permite configurar el tamaño del código y el tipo de la imagen generada. Puede no invocarse, pero si desea cambiar los valores por omisión debe invocarla antes que la función GenerateFile
*--------------------------------------
DECLARE INTEGER SetConfiguration ;
	  IN BarCodeLibrary.dll ;
	  INTEGER nSize, ;           && [2..12] (Default 4)
	  INTEGER nImageType         && 0=BMP, 1=JPG, 2=PNG (Default 0)

*- SetConfiguration(Tamaño, Tipo de imagen)
SetConfiguration(6,2)

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

El archivo dll y un código de ejemplo lo pueden descargar desde aquí

Solo basta recordarles que existe otro artículo sobre el tema de QR:


Hasta la próxima!!

Baltazar Moreno, Guadalajara, Jalisco, México

24 de julio de 2012

Arrastrar, soltar y conservar las posiciones - Parte II - Columnas de una cuadricula

Artículo original: Drag, Drop and Retain It Part II - Grid Columns
http://sandstorm36.blogspot.com.ar/2012/07/drag-drop-and-retain-it-part-ii-grid.html
Autor: Jun Tangunan
Traducido por: Luis Maria Guayán


Arrastrar, soltar y conservar las posiciones - Parte II - Columnas de una cuadricula



Debido al ejemplo de "Arrastrar, soltar y conservar posiciones" que publiqué anteriormente, una nueva solicitud se hizo dentro del foro (Nota del Traductor: Foxite Forum) y esta vez se trata de reordenar las columnas de una cuadrícula sobre la marcha y guardar esa configuración.

Yo pensaba llamar esto "Trucos de cuadrícula # 6" porque se trata de trucos de cuadrícula, pero al final me decidí a hacer esta la parte 2 parte 2 de "Arrastrar, soltar y conservar las posiciones".

De todos modos, aquí está cómo hacerlo. Siempre se debe tener algo primero para guardar la configuración y luego para recuperar, una tabla es mi mejor opción. Esto es simple y solo para que sirva de guía. Puede ser necesario que usted tenga que guardar el nombre del formulario y el nombre de la cuadrícula para algo mas completo

Aquí está el código de ejemplo, si estás interesado:
LOCAL oForm
oForm = NEWOBJECT("Form1")
oForm.SHOW
READ EVENTS
RETURN

DEFINE CLASS Form1 AS FORM
  HEIGHT = 390
  WIDTH = 500
  AUTOCENTER = .T.
  CAPTION = 'Reordenar las columnas y conservarlas'
  SHOWTIPS = .T.

  ADD OBJECT label1 AS LABEL WITH ;
    CAPTION = 'Arrastre y suelte para reordenar columnas. Luego cierre y ' + ;
    'vuelva a abrir formulario para ver si la disposición está guardada', ;
    TOP = 10, LEFT = 10, WIDTH = 480, HEIGHT = 40, WORDWRAP = .T.

  ADD OBJECT grid1 AS GRID WITH ;
    COLUMNCOUNT = 3,;
    HEIGHT = 328, LEFT = 10, TOP = 50, WIDTH = 480,;
    GRIDLINES = 3, DELETEMARK = .F.,;
    GRIDLINECOLOR = RGB(192,192,192),;
    GRIDLINES = 0, FONTNAME = 'Tahoma', FONTSIZE = 8,;
    ANCHOR = 15, ALLOWCELLSELECTION = .F.,;
    TOOLTIPTEXT = 'Drag Column to Rearrange'

  PROCEDURE LOAD
    SET TALK OFF
    SET SAFETY OFF
    CLOSE DATABASES ALL
    SELECT  company, contact, TITLE FROM (HOME(2)+"data\customer") WHERE RECNO() < 50 INTO CURSOR junk
    USE IN SELECT('customer')

    * Create/use a table to store grid column settings
    IF !FILE("gridcolumns.dbf")
      CREATE TABLE gridcolumns (ColName c(10), ColOrder I)
    ELSE
      USE gridcolumns IN 0 SHARED
    ENDIF
  ENDPROC

  PROCEDURE INIT
    IF RECCOUNT("gridcolumns") == 0
      * First run? Save the current order of the columns
      LOCAL lnloop
      WITH THISFORM.grid1
        FOR lnloop = 1 TO .COLUMNCOUNT
          lcColName =  .COLUMNS(m.lnloop).NAME
          lnOrder = .COLUMNS(m.lnloop).COLUMNORDER
          INSERT INTO gridcolumns VALUES (m.lcColName, m.lnOrder)
        NEXT
      ENDWITH
    ENDIF
    THIS._getorder()
  ENDPROC

  PROCEDURE grid1.INIT
    WITH THIS
      .RECORDSOURCETYPE = 6
      .RECORDSOURCE = 'junk'
      .Column1.Header1.CAPTION = 'Column1'
      .Column2.Header1.CAPTION = 'Column2'
      .Column3.Header1.CAPTION = 'Column3'
      .SETALL('Width',150,'Column')

      * Bind Move Events
      FOR lnloop = 1 TO .COLUMNCOUNT
        BINDEVENT(.COLUMNS(m.lnloop),'Moved',THISFORM,'_Moved')
      NEXT
    ENDWITH
  ENDPROC

  PROCEDURE _Moved
    * Save new column orders
    LOCAL lnloop
    WITH THISFORM.grid1
      FOR lnloop = 1 TO .COLUMNCOUNT
        lcColName =  ALLTRIM(.COLUMNS(m.lnloop).NAME)
        lnOrder = .COLUMNS(m.lnloop).COLUMNORDER
        REPLACE ColOrder WITH m.lnOrder FOR ALLTRIM(ColName) = m.lcColName IN gridcolumns
      NEXT
    ENDWITH
  ENDPROC

  PROCEDURE _getorder
    * Fetch Column Orderings
    SELECT gridcolumns
    LOCAL lnloop
    WITH THISFORM.grid1
      FOR lnloop = 1 TO .COLUMNCOUNT
        lcColName =  .COLUMNS(m.lnloop).NAME
        LOCATE FOR ColName = m.lcColName
        .COLUMNS(m.lnloop).COLUMNORDER = ColOrder
      NEXT
      .REFRESH
    ENDWITH
  ENDPROC

  PROCEDURE DESTROY
    CLOSE DATABASES ALL
    CLEAR EVENTS
  ENDPROC

ENDDEFINE

21 de julio de 2012

Arrastrar, soltar y conservar posiciones

Artículo original: Drag, Drop and Retain Positions
http://sandstorm36.blogspot.com/2012/07/drag-drop-and-retain-positions.html
Autor: Jun Tangunan
Traducido por: Luis Maria Guayán


Arrastrar, soltar y conservar posiciones

Aquí otro ejemplo moviendo objetos a su alrededor y conservando las posiciones en la siguiente ejecución del formulario. Esto es sólo una simple demostración de cómo podemos hacer lo siguiente:



Mientras que la parte de arrastrar y soltar parece ser fácil, además de conservar y recuperar esos valores posteriormente, lo que me llevó más tiempo de averiguar es cómo el reordenamiento de estos objetos que afectan las propiedades tabIndex de cada objeto dentro del contenedor. De todos modos, esto no está perfecto aun, pero al menos usted tendrá algo con que empezar y perfeccionar.

Copie y pegue el código a un .PRG, ejecute y tilde "Permitir mover", a continuación, arrastre los botones alrededor. Después de eso, cierre el formulario y a continuación, ejecutelo de nuevo. Vea si se mantiene las últimas posiciones cuando se cerró el formulario y si el tabindex es el adecuado.
Aquí el código del ejemplo si le interesa:
LOCAL oForm AS FORM
oForm = CREATEOBJECT('TestForm')
oForm.SHOW(1)
RETURN

DEFINE CLASS TestForm AS FORM
  AUTOCENTER = .T.
  WIDTH = 300
  HEIGHT = 440
  MINWIDTH = 200
  MINHEIGHT = 100
  CAPTION = 'Drag, Drop & Retain Positions'

  ADD OBJECT chkMove AS CHECKBOX WITH CAPTION = 'Permitir mover los objetos',;
    TOP = 400, LEFT = 5, AUTOSIZE = .T., VALUE = .F., ANCHOR = 6
  ADD OBJECT Command1 AS MyButton WITH CAPTION='One', TOP = 5, LEFT = 5
  ADD OBJECT Command2 AS MyButton WITH CAPTION='Two', TOP = 70, LEFT = 5
  ADD OBJECT Command3 AS MyButton WITH CAPTION='Three', TOP =135, LEFT = 5
  ADD OBJECT Command4 AS MyButton WITH CAPTION='Four', TOP = 200, LEFT = 5
  ADD OBJECT Command5 AS MyButton WITH CAPTION='Five', TOP = 265, LEFT = 5
  ADD OBJECT Command6 AS MyButton WITH CAPTION='Six', TOP = 330, LEFT = 5

  PROCEDURE LOAD
    CLOSE DATABASES ALL
    * Check if table is there for preserving/restoring values
    IF !FILE('DragDrops.dbf')
      CREATE TABLE dragdrops FREE (ObjectName c(40),xTop I,xLeft I,xTabIndex I)
      INDEX ON xTop+xLeft TAG xTabIndex
    ELSE
      USE dragdrops ORDER xTabIndex
    ENDIF
  ENDPROC

  PROCEDURE INIT
    * Check if first run or not, if first run, make an entry in the table
    IF RECCOUNT() == 0
      FOR EACH loCtrl IN THISFORM.CONTROLS FOXOBJECT
        INSERT INTO dragdrops VALUES (loCtrl.NAME,loCtrl.TOP,loCtrl.LEFT,0)
      NEXT
    ENDIF
    THIS._reorder()
  ENDPROC

  PROCEDURE _TabIndex
    * recreate tab indexes
    LOCAL lnTab
    lnTab = 1
    SCAN
      REPLACE xTabIndex WITH m.lnTab IN dragdrops
      lnTab = m.lnTab + 1
    ENDSCAN
  ENDPROC

  PROCEDURE _reorder
    * Reorder Tab Index
    FOR EACH loCtrl IN THISFORM.CONTROLS FOXOBJECT
      SELECT dragdrops
      LOCATE FOR UPPER(loCtrl.NAME) = UPPER(ObjectName)
      loCtrl.TABINDEX = dragdrops.xTabIndex
    NEXT
  ENDPROC

ENDDEFINE

DEFINE CLASS MyButton AS COMMANDBUTTON
  HEIGHT = 60
  WIDTH = 100

  PROCEDURE INIT
    * Get previous positions
    SELECT dragdrops
    LOCATE FOR UPPER(THIS.NAME) = UPPER(ObjectName)
    THIS.TOP = dragdrops.xTop
    THIS.LEFT = dragdrops.xLeft
  ENDPROC

  PROCEDURE MOUSEMOVE
    LPARAMETERS nButton, nShift, nXCoord, nYCoord
    IF m.nButton = 1 AND THISFORM.chkMove.VALUE = .T.
      THIS.MOVE(m.nXCoord, m.nYCoord)
      * update new coordinates
      REPLACE xTop WITH m.nYCoord, xLeft WITH m.nXCoord FOR;
        UPPER(THIS.NAME) = UPPER(ObjectName) IN dragdrops
      THISFORM._TabIndex()
    ENDIF
  ENDPROC

  PROCEDURE CLICK
    MESSAGEBOX("You've clicked "+THIS.NAME+CHR(13)+;
      "Tab Index: "+TRANSFORM(THIS.TABINDEX))
  ENDPROC

ENDDEFINE

14 de julio de 2012

Cambiar la resolución del monitor desde VFP

Una excelente función del turco Cetin Basoz que nos permite cambiar la resolución de la pantalla desde Visual FoxPro.

? SetScreenresolution(1024,768)

FUNCTION SetScreenresolution(tnWidth,tnHeight,tnFrequency)

  #DEFINE ENUM_CURRENT_SETTINGS -1
  #DEFINE CDS_UPDATEREGISTRY = 0x01
  #DEFINE CDS_TEST 0x02
  #DEFINE DISP_CHANGE_SUCCESSFUL 0
  #DEFINE DISP_CHANGE_RESTART 1
  #DEFINE DISP_CHANGE_FAILED -1
  #DEFINE DM_PELSWIDTH 0x00080000
  #DEFINE DM_PELSHEIGHT 0x00100000
  #DEFINE DM_DISPLAYFREQUENCY 0x00400000

  LOCAL lpDevMode,result
  DECLARE INTEGER EnumDisplaySettings IN win32API ;
    STRING deviceName,;
    INTEGER modeNum, ;
    STRING @ lpdevMode

  DECLARE LONG ChangeDisplaySettings IN win32API ;
    STRING lpDevMode, ;
    INTEGER dwflags

  lpdevMode = REPLICATE(CHR(0),512)

  EnumDisplaySettings(0,ENUM_CURRENT_SETTINGS,@lpdevMode)

  *!*    ? "Current settings are:",;
  *!*        CTOBIN(Substr(m.lpdevMode,109,4),"4RS"),;
  *!*        CTOBIN(Substr(m.lpdevMode,113,4),"4RS")

  * Width and Height
  lpdevMode = STUFF(m.lpdevMode,109,4,Int2DWord(m.tnWidth))
  lpdevMode = STUFF(m.lpdevMode,113,4,Int2DWord(m.tnHeight))

  IF !EMPTY(m.tnFrequency)
    lpdevMode = STUFF(m.lpdevMode,121,4,Int2DWord(m.tnFrequency)) && Frequency
    lpdevMode = STUFF(m.lpdevMode,41,4,;
      Int2DWord(BITOR(DM_PELSWIDTH,DM_PELSHEIGHT,DM_DISPLAYFREQUENCY))) && dmFields
  ELSE
    lpdevMode = STUFF(m.lpdevMode,41,4,;
      Int2DWord(BITOR(DM_PELSWIDTH,DM_PELSHEIGHT))) && dmFields
  ENDIF

  result = ChangeDisplaySettings(m.lpdevMode,CDS_TEST)

  IF !( result = DISP_CHANGE_SUCCESSFUL )
    MESSAGEBOX("Mode is not supported",0+48,'Monitor settings')
  ELSE
    ChangeDisplaySettings(m.lpdevMode,0)
    TEXT to m.lcSetting noshow
La resolución de su pantalla ha sido cambiada.
Presione [Si] para confirmar el cambio.
Se restablecerá automáticamente la resolución en 30 segundos.
    ENDTEXT

    IF MESSAGEBOX(m.lcSetting,4+64,'Monitor settings',30000) != 6
      ChangeDisplaySettings(0,0) && restore
    ENDIF

  ENDIF
ENDFUNC

FUNCTION Int2DWord(tInt)
  LOCAL lcDWord,ix
  lcDWord = ''
  FOR ix=1 TO 4
    lcDword = m.lcDword + CHR( INT(m.tInt / 256^(m.ix-1)) % 256 )
  ENDFOR
  RETURN m.lcDword
ENDFUNC

23 de junio de 2012

Implementación de Aspell desde Visual FoxPro (corrector ortográfico)

Que es Aspell

GNU Aspell, generalmente llamado simplemente Aspell es un corrector ortográfico de software libre diseñado para reemplazar Ispell. Es el corrector ortográfico estándar para el sistema de software GNU. También compila para otros sistemas operativos tipo Unix y Windows. El programa principal está licenciado bajo la GNU Lesser General Public License (GNU LGPL), la documentación bajo la GNU Free Documentation License (GNU FDL). Diccionarios para que estén disponibles para alrededor de 70 idiomas. El mantenedor principal es Kevin Atkinson. (Fuente Wikipedia)

Donde puedo descargar Aspell para windows

En los siguientes links se puede descargar el paquete para Windows con sus respectivos diccionarios en varios idiomas

Implementacion de Aspell en Visual FoxPro

Después de mucho navegar e investigar por toda la web fue imposible encontrar una implementación de Aspell en Visual FoxPro, así que realice la tarea de implementarlo, para esto fue necesario el análisis de distintas implementaciones es lenguajes como C++, Pascal, Delphi entre otros. Debemos tener claro que estamos usando una librería dinámica externa propia de Aspell compilada para Windows, así que como prerrequisitos tenemos:
Con estos elementos instalados aclaremos, la librería dinámica a usar es ASPELL-15.DLL la cual se encuentra en C:\PROGRAM FILES\ASPELL\BIN\, la ruta puede variar dependiendo el sistema operativo como por ejemplo en equipos con SO de 64Bits seria C:\PROGRAM FILES (X86)\ASPELL\BIN\.

Ejemplo basico de Aspell desde Visual FoxPro

*!* Ubicación de la DLL
#DEFINE ASPELL_DLL "C:\PROGRAM FILES\ASPELL\BIN\ASPELL-15.DLL"
#DEFINE ASPELL_LANG "es"

*!* Funciones de la DLL
IF FILE(ASPELL_DLL)==.t.
 DECLARE INTEGER new_aspell_config IN (ASPELL_DLL)
 DECLARE INTEGER aspell_config_replace IN (ASPELL_DLL) INTEGER, STRING, STRING
 DECLARE INTEGER new_aspell_speller IN (ASPELL_DLL) INTEGER
 DECLARE INTEGER aspell_error_number IN (ASPELL_DLL) INTEGER
 DECLARE INTEGER to_aspell_speller IN (ASPELL_DLL) INTEGER
 DECLARE INTEGER aspell_speller_check IN (ASPELL_DLL) INTEGER, STRING, INTEGER
 DECLARE INTEGER aspell_speller_suggest IN (ASPELL_DLL) INTEGER, STRING, INTEGER
 DECLARE INTEGER aspell_word_list_elements IN (ASPELL_DLL) INTEGER
 DECLARE INTEGER delete_aspell_string_manag IN (ASPELL_DLL) INTEGER
 DECLARE STRING aspell_string_enumeration_next IN (ASPELL_DLL) INTEGER
 DECLARE STRING aspell_error_message IN (ASPELL_DLL) INTEGER
ELSE
 =MESSAGEBOX("La libreria de Aspell no fue encontrada, descarguela e instalela desde:"+CHR(13)+;
    "http://aspell.net"+CHR(13)+;
    "http://aspell.net/win32/dicts",0+64+256,"Libreria no instalada")
 RETURN .f.
ENDIF 

*!* Variables
LOCAL lnSpellConfig, ;
   lnPossibleErr, ;
   lnSpellChecker, ;
   lcPalabra, ;
   lnPalabra, ;
   lcSuggestions, ;
   lnElements, ;
   lcSugerencias, ;
   llSalir

*!* Iniciando instancia
lnSpellConfig = new_aspell_config()

*!* Cargando diccionario ESPAÑOL (es)
IF aspell_config_replace(lnSpellConfig, "lang", ASPELL_LANG)==1
 
 lnPossibleErr = new_aspell_speller(lnSpellConfig)
 lnSpellChecker = 0

 *!* Comprobando Inicio
 IF aspell_error_number(lnPossibleErr) != 0
  =MESSAGEBOX(aspell_error_message(lnPossibleErr),0+16+256+4096,"Error Aspell")
  RETURN .f.
 ELSE 
  lnSpellChecker = to_aspell_speller(lnPossibleErr)
 ENDIF

 *!* Palabra a comprobar
 lcFrase=INPUTBOX("Ingrese la frase a comprobrar","Frase","",0,"","")
 
 *!* Recorriendo palabras
 FOR lnItem=1 TO GETWORDCOUNT(lcFrase,' ')
  lcPalabra=GETWORDNUM(lcFrase,lnItem,' ')
  lnPalabra=LEN(lcPalabra)


  IF aspell_speller_check(lnSpellChecker,lcPalabra,lnPalabra)==0
   lcSuggestions =aspell_speller_suggest(lnSpellChecker,lcPalabra,lnPalabra)
   lnElements = aspell_word_list_elements(lcSuggestions)
   lcSugerencias=''
   llSalir=.f.

   DO WHILE llSalir==.f.
    TRY 
     lcSugerencias=lcSugerencias+aspell_string_enumeration_next(lnElements)+CHR(13)
    CATCH TO loError
     llSalir=.t.
    ENDTRY 
   ENDDO 
   =MESSAGEBOX("Incorrecta, sugerencias para "+lcPalabra+CHR(13)+lcSugerencias,0+512+4096,"Incorrectar")
  ELSE
   =MESSAGEBOX("Correcta, "+lcPalabra,0+512+4096,"Correctar")
  ENDIF 
 ENDFOR 
ELSE
 =MESSAGEBOX("Imposible iniciar la configuracion de Aspell",0+16+256+4096,"Fallo configuración")
ENDIF 

Jose Guillermo Ortiz Hernandez

Clase para corregir la ortografia en un EditBox o TextBox

Esta clase implemente la libreria Aspell (spell checker) en un objeto de clase EditBox, tambien puede ser usar en un TextBox. Al implementar Aspell (GNU) no requiere que el cliente tenga instalado MS Word.

QUE ES ASPELL

GNU Aspell, generalmente llamado simplemente Aspell es un corrector ortográfico de software libre diseñado para reemplazar Ispell. Es el corrector ortográfico estándar para el sistema de software GNU. También compila para otros sistemas operativos tipo Unix y Windows. El programa principal está licenciado bajo la GNU Lesser General Public License (GNU LGPL), la documentación bajo la GNU Free Documentation License (GNU FDL). Diccionarios para que estén disponibles para alrededor de 70 idiomas. El mantenedor principal es Kevin Atkinson. (Fuente Wikipedia)

DONDE PUEDO DESCARGAR ASPELL PARA WINDOWS

En los siguientes links se puede descargar el paquete para Windows con sus respectivos diccionarios en varios idiomas

IMPLEMENTACION DE ASPELL EN VISUAL FOXPRO

Después de mucho navegar e investigar por toda la web fue imposible encontrar una implementación de Aspell en Visual FoxPro, así que realice la tarea de implementarlo, para esto fue necesario el análisis de distintas implementaciones es lenguajes como C++, Pascal, Delphi entre otros. Debemos tener claro que estamos usando una librería dinámica externa propia de Aspell compilada para Windows, así que como prerrequisitos tenemos:

CARACTERISTICAS

  1. Interface Nativa en VFP
  2. Incluye las caracteristicas de busqueda http://jgohortiz.blogspot.com/search/label/editbox

DESCARGAR

Descargue la clase desde este enlace

SCREENSHOT



Jose Guillermo Ortiz Hernandez

3 de junio de 2012

Nueva versión 1.10 de Foxbarcode

FoxBarcode es una clase 100% Visual FoxPro que ofrece una herramienta para la generación de imágenes con distintas simbologías de códigos de barras, para ser usadas en informes y formularios de VFP, o exportadas a otras aplicaciones. Su uso y distribución es libre para toda la Comunidad de Visual FoxPro.

FoxBarcode soporta las simbologías: Código 128, Código 39, Código 39 Extendido (Full ASCII), Código 93, Código 93 Extendido (Full ASCII), Standard 2 de 5, Interleaved 2 de 5, EAN-8, EAN-13, UPC-A, UPC-E (EAN y UPC con suplementos de 2 y 5 dígitos), ITF-14, GS1/EAN/UCC-128, Codabar, Código 11, MSI / Plessey, Telepen, PostNet, RM4SCC, KIX-Code, One Track Pharmacode y Two Track Pharmacode.

FoxBarcode soporta los tipos de imagenes: JPG, BMP, GIF, PNG y TIFF

Pueden descargar la nueva versión desde la página de FoxBarcode:
http://sites.google.com/site/foxbarcode

¿Que hay de nuevo?
  • Nuevo lenguaje: ITALIANO por Roberto Saccomanno
  • Cambio en la propiedad nImageWidth: Ahora se puede configurar el ancho de la imagen
  • Nueva propiedad nAlignBarcode: Permite alinear el código de barras a la izquierda, centro o derecha de la imagen.
  • Corrección de pequeños errores.

21 de mayo de 2012

Colorear las filas de un Grid de acuerdo al valor de un campo

Un práctico ejemplo del turco Cetin Basoz de como colorear con un mismo color las filas de un control Grid de acuerdo al mismo valor de un campo.

En este caso las filas tomarán el mismo color para el mismo valor de identificación de empleado (campo Emp_Id)
loForm = CREATEOBJECT("MiForm")
loForm.SHOW(1)

DEFINE CLASS MiForm AS FORM
  DATASESSION = 2

  ADD OBJECT MiGrid AS GRID WITH ;
    RECORDSOURCE = "Orders",  HEIGHT = 400,  WIDTH = 400, ANCHOR = 15, ;
    READONLY = .T., FONTSIZE = 12, ROWHEIGHT = 24

  PROCEDURE LOAD
    USE (HOME(2) + "Data\Orders")
  ENDPROC

  PROCEDURE INIT
    THIS.MiGrid.SETALL("DynamicBackColor", "(ThisForm.ColorMe(Orders.Emp_Id, .F.))")
    THIS.MiGrid.SETALL("DynamicForeColor", "(ThisForm.ColorMe(Orders.Emp_Id, .T.))")
    THIS.WINDOWSTATE = 2
  ENDPROC

  PROCEDURE ColorMe(tcValue, tlForeColor)
    LOCAL lnBackColor, lnForeColor
    lnBackColor = BITAND(VAL(SYS(2007,m.tcValue,1,1)), 0x00FFFFFF)
    IF NOT m.tlForeColor
      RETURN m.lnBackColor
    ENDIF

    LOCAL lnRed, lnGreen, lnBlue,lnAlpha
    lnRed = BITAND(BITRSHIFT(m.lnBackColor,0), 0xFF)
    lnGreen = BITAND(BITRSHIFT(m.lnBackColor,8), 0xFF)
    lnBlue = BITAND(BITRSHIFT(m.lnBackColor,16), 0xFF)
    lnAlpha = (MAX(m.lnRed,m.lnGreen,m.lnBlue) + MIN(m.lnRed,m.lnGreen,m.lnBlue)) / 2

    RETURN IIF(m.lnAlpha < 0x80, 0xFFFFFF, 0)
  ENDPROC
ENDDEFINE

Fuente: Foxite Forum (http://www.foxite.com/forum)

14 de mayo de 2012

Consumir datos de VFP desde .NET de 64 bits utilizando un servidor vinculado

Un enlace a un reciente artículo del blog del profesor Carlos A. Perez que nos muestra como integrar datos de Visual Foxpro (32 bits) en un entorno de IIS de 64 bits a traves de un Servidor Vinculado SQL Server Express (64 bits).

Para leer el artículo "Cómo consumir datos de Visual FoxPro en sistemas .NET de 64 bits utilizando un servidor vinculado" de Carlos Perez haga clic aquí

Carlos A. Perez: Nacido en 1965 en Resistencia, Chaco, Argentina. Actualmente es profesor en la Universidad Tecnológica Nacional (Argentina) enseñando cinco materias, cuatro de Ingenieria en Sistemas y una en Ingenieria Electromecánica. Fundador del GIANTIC, grupo de investigación sobre nuevas tecnologias de comunicación. Ganador en 2002 de un Microsoft Research RFP para Argentina. Desde 2004 es Microsoft Most-Valuable Professional. Consultor e instructor de tecnologías .NET. Vocal de la Comision Directiva del Microsoft Users Group de Argentina. Ex-Presidente del Polo Tecnológico Chaco. Titular de la consultora Logica10 I.A. especializada en desarrollos .NET y de movilidad. Actualmente cursando un doctorado en sistemas de información y computación con la Universidad de Málaga.


10 de mayo de 2012

Desplazarse por imagenes en un formulario

Un par de muy buenos ejemplos prácticos del turco Cetin Basoz de como se puede mostrar y desplazarse por imágenes en un formulario.

Estos dos ejemplos surgieron como respuesta de Cetin a una pregunta en el foro de Foxite.com y me parecieron muy buenos por su simpleza.

Ejemplo UNO

* Author: Cetin Basoz (Turkey)

SET SAFETY OFF
PUBLIC oForm
oForm = CREATEOBJECT("MyForm")
oForm.SHOW()

DEFINE CLASS myForm AS FORM
  HEIGHT = 600
  WIDTH = 800

  ADD OBJECT myGrid AS GRID WITH ;
    HEIGHT = 600, WIDTH = 800, ANCHOR = 15

  PROCEDURE LOAD
    CREATE CURSOR images (imageName c(100), img w)
    LOCAL ix, lcFile, lcDirImg
    
    lcDirImg = "C:\Archivos de programa\Microsoft Visual FoxPro 9\Samples\Data\Graphics"
    
    FOR ix = 1 TO ADIR(laImages, ADDBS(lcDirImg) + "*.*")
      lcFile = ADDBS(lcDirImg) + laImages[m.ix,1]
      INSERT INTO images VALUES (m.lcFile, FILETOSTR(m.lcFile))
    ENDFOR
    LOCATE
  ENDPROC

  PROCEDURE INIT
    THIS.myGrid.ROWHEIGHT = 64
    WITH THIS.myGrid.COLUMNS(2)
      .ADDOBJECT( "myImage", "imageControl" )
      .CURRENTCONTROL = "myImage"
      .SPARSE = .F.
      .myImage.STRETCH = 1
      .myImage.VISIBLE = .T.
      .WIDTH = 64
      .DYNAMICFONTBOLD = "(thisform.SetImage(this.columns(2).myImage, images.img))"
    ENDWITH
  ENDPROC

  PROCEDURE SetImage(toControl, tcBlob)
    toControl.PICTUREVAL = m.tcBlob
  ENDPROC

  PROCEDURE myGrid.BEFOREROWCOLCHANGE(tnIndex)
    THISFORM.LOCKSCREEN = .T.
  ENDPROC

  PROCEDURE myGrid.AFTERROWCOLCHANGE(tnIndex)
    THISFORM.LOCKSCREEN = .F.
  ENDPROC
ENDDEFINE

DEFINE CLASS imagecontrol AS IMAGE
  HEIGHT = 17
  WIDTH = 100
  NAME = "imagecontrol"

  PROCEDURE pictureval_assign
    LPARAMETERS vNewVal
    IF VAL(OS(3)) < 6
      THIS.PICTUREVAL = m.vNewVal
    ELSE
      THIS.PICTURE = ""
      IF EMPTY(THIS.TAG)
        THIS.TAG = FORCEPATH(SYS(2015) + ".pic", SYS(2023))
      ENDIF
      STRTOFILE(m.vNewVal, THIS.TAG)
      THIS.PICTURE = THIS.TAG
    ENDIF
  ENDPROC

  PROCEDURE DESTROY
    THIS.PICTURE = ""
    IF !EMPTY(THIS.TAG)
      TRY
        ERASE (THIS.TAG)
      ENDTRY
    ENDIF
  ENDPROC

ENDDEFINE

Ejemplo DOS

* Author: Cetin Basoz (Turkey)

PUBLIC oForm
oForm = CREATEOBJECT("form1")
oForm.SHOW()

DEFINE CLASS form1 AS FORM
  TOP = 0
  LEFT = 0
  HEIGHT = 480
  WIDTH = 750
  CAPTION = "HTML sample"

  * This is IE control - you'd use webbrowser4 from gallery instead
  * just because it already has some checks, extra pem. ie: wouldn't need readystate part
  * for the sake of keeping code short here I directly use olecontrol itself
  ADD OBJECT htmlviewer AS OLECONTROL WITH ;
    TOP = 0, LEFT = 0, HEIGHT = 400, WIDTH = 750, ;
    OLECLASS = "Shell.Explorer"

  ADD OBJECT text1 AS TEXTBOX WITH ;
    HEIGHT = 25, LEFT = 12, TOP = 432, WIDTH = 60, ;
    NAME = "Text1"

  ADD OBJECT text2 AS TEXTBOX WITH ;
    HEIGHT = 23, LEFT = 84, TOP = 432, WIDTH = 300, ;
    NAME = "Text2"

  ADD OBJECT text3 AS TEXTBOX WITH ;
    HEIGHT = 23, LEFT = 390, TOP = 432, WIDTH = 125, ;
    NAME = "Text3"

  ADD OBJECT text4 AS TEXTBOX WITH ;
    HEIGHT = 23, LEFT = 520, TOP = 432, WIDTH = 125, ;
    NAME = "Text4"

  PROCEDURE INIT
    LOCAL lnImages, lnPerrow, lnCurrent, lcDirImg

    lcDirImg = "C:\Archivos de programa\Microsoft Visual FoxPro 9\Samples\Data\Graphics"

    lnImages = ADIR(arrImages,ADDBS(lcDirImg) + "*.*")
    *You'd use a table let's simulate it
    CREATE CURSOR myImages (ImagePath m,FirstName c(12), LastName c(12))

    FOR ix=1 TO lnImages
      INSERT INTO myImages VALUES ;
        (ADDBS(lcDirImg) + arrImages[m.ix,1],"FirstName"+TRANS(ix),"LastName"+TRANS(m.ix))
    ENDFOR
    *Now we have a test table - create HTML
    lnPerRow = 2 && How many would we show on a line
    lnCurrent = 0 && Do not use recno() thinking it might be ordered on an index

    SET TEXTMERGE ON
    SET TEXTMERGE TO MEMVAR lcHtml NOSHOW
    * Initialize lcHTML
 \
    SELECT myImages
    SCAN
      lnCurrent = lnCurrent+1
      IF (lnCurrent-1)%lnPerRow=0
        IF lnCurrent > 1
 \
        ENDIF
 \
      ENDIF
 \<A href="<< trans(recno())>>_TEXT">
 \ << JustStem(ImagePath)>></A>
 \<A href="<< trans(recno())>>">
 \    <img border="0" height="60" width="80" src="<< trim(chrtran(ImagePath,'\','/'))>>"></A>

    ENDSCAN
 \
 \
    SET TEXTMERGE TO
    SET TEXTMERGE OFF
    *!*     Modify Command (this.HTMLFile) && If you ever wonder created HTML
    WITH THISFORM.htmlviewer
      .Navigate2('about:blank')
      DO WHILE .ReadyState # 4 && Wait for ready state
      ENDDO
      .DOCUMENT.WRITE( m.lcHTML )
    ENDWITH
  ENDPROC

  PROCEDURE htmlviewer.BeforeNavigate2
    *** ActiveX Control Event ***
    LPARAMETERS pdisp, url, FLAGS, targetframename, postdata, headers, CANCEL
    CANCEL = .T.  && do not navigate to anywhere
    WITH THISFORM && with webbrowser4 also this.oHost is the form itself or container
      LOCAL lcRecNo
      lcRecNo = STRTRAN(LOWER(m.url), "about:","")
      .text1.VALUE = m.lcRecNo
      lnRecno = STREXTRACT(m.lcRecNo, "", "_TEXT", 1, 1+2)
      GO VAL(m.lcRecNo) IN "myImages"
      IF (ATC("_TEXT", m.lcRecNo) > 0)
        .text2.VALUE = "TextCLICK" + myImages.ImagePath
      ELSE
        .text2.VALUE = myImages.ImagePath
      ENDIF
      .text3.VALUE = myImages.FirstName
      .text4.VALUE = myImages.LastName
    ENDWITH
  ENDPROC

ENDDEFINE

Fuente: Foxite Forum (http://www.foxite.com/forum)


17 de abril de 2012

Generar un GUID (Globally Unique IDentifier)

Dos funciones que se expusieron el el Foro de la Comunidad VFP en Español. La primera mediante API y la segunda mediante WSH. La función con la API de Windows es 3 veces mas rápida que la que utiliza WSH.

Con API

? GenerateGUID()

FUNCTION GenerateGUID()
  *-- Con la API de Windows
  LOCAL lcRetval, lcStruc_GUID, lcGUID, lnSize
  DECLARE INTEGER CoCreateGuid IN "ole32.dll" STRING @lcGUIDStruc
  DECLARE INTEGER StringFromGUID2 IN "ole32.dll" STRING cGUIDStruc, STRING @cGUID, LONG nSize
  lcStruc_GUID = REPLICATE(" ",16)
  lcGUID = REPLICATE(" ",80)
  lnSize = LEN(lcGUID) / 2
  IF CoCreateGuid(@lcStruc_GUID) <> 0
    RETURN ""
  ENDIF
  IF StringFromGUID2(lcStruc_GUID,@lcGuid,lnSize) = 0
    RETURN ""
  ENDIF
  RETURN STREXTR(STRCONV(lcGUID,6),"{","}") && >= VFP7
  *RETURN SUBSTR(STRCONV(lcGUID,6),2,36) && < VFP7
ENDFUNC

Con WSH

? GenerateGUID()

FUNCTION GenerateGUID
  *-- Con WSH (Windows Script Host)
  LOCAL loObj
  loObj = CREATEOBJECT("Scriptlet.TypeLib")
  RETURN STREXTRACT(loObj.GUID, "{", "}") && >= VFP7
  *RETURN SUBSTR(loObj.GUID,2,36) && < VFP7
ENDFUNC

15 de abril de 2012

Función Traductor Ingles-Español con Google Translator

Función que traduce texto del ingles al español recibe como parámetro el texto en ingles y lo devuelve en español, utilizando para esto el motor de traducción de Google.

Esta funcion utiliza automatizacion de un objeto IE (Internet Explorer) y extrae el codigo HTML y depura el texto traducido.
? TraducirIE("Nothing runs like a fox")

FUNCTION TraducirIE
  LPARAMETERS ATRA
  LOCAL cUrl, Texto, oIE, cResul, oDoc,XPI,XPF,TRA,X
  IF TYPE("oIE")#'O'
    oIE = CREATEOBJECT("internetexplorer.application")
  ENDIF
  oIE.Navigate2("about:blank")
  cUrl=LOWER('http://translate.google.com.mx/?hl=es&tab=TT#en|es|'+ALLTRIM(ATRA))
  oIE.navigate2(cUrl)
  Texto ='Traduciendo.'
  DO WHILE oIE.busy OR oIE.readystate!=4
    WAIT WINDOW Texto TIMEOUT 0.1
    Texto=Texto+'.'
    IF OCCURS('.',Texto)>3
      Texto ='Traduciendo.'
    ENDIF
  ENDDO
  WAIT WINDOW 'Terminado' TIMEOUT 1
  oDoc = oIE.DOCUMENT
  Texto = TYPE('oDoc.body')
  cResul = oDoc.body.innerHTML()
  oDoc = .NULL.
  RELEASE oDoc
  oIE.QUIT
  RELEASE oIE
  XPI = AT('',cResul)+32
  cResul = SUBSTR(cResul,XPI)
  XPF = AT('',cResul)-1
  cResul = SUBSTR(cResul,1,XPF)
  X=OCCURS('<',cResul)
  TRA=''
  DO WHILE X>0
    XPI=0
    XPF=0
    XPI=AT('<',cResul)-1
    XPF=AT('>',cResul)+1
    TRA=TRA+SUBSTR(cResul,1,XPI)
    cResul=SUBSTR(cResul,XPF)
    X=OCCURS('<',cResul)
  ENDDO
  TRA=TRA+cResul
  RETURN TRA
ENDFUNC
Erick J. Mireles Riojas

10 de abril de 2012

Interfaces en VFP

Como todos sabemos, VFP no ofrece una forma nativa de declarar ni aplicar interfaces, mas alla de la interaccion con objetos OLE.

La clase InterfaceHelper (http://www.victorespina.com.ve/wiki/index.php?title=Implementacion_de_interfaces_en_VFP) ofrece una forma sencilla (aunque limitada) de lograr los beneficios del uso de interfaces en VFP.

Su uso es muy sencillo:

1) Se declara una variable publica que almacene una instanca de interfaceHelper:
PUBLIC goInterfaces   && Puede ser cualquier nombre
goInterfaces = CREATE("interfaceHelper")

2) Se declaran las interfaces como clases derivadas de la clase Interface:
DEFINE CLASS IEnumerable AS Interface
  Count = 0
  DIMEN Items[1]
ENDDEFINE

3) Se publica la interfaz en el helper de interfaces:
goInterfaces.Declare("IEnumerable")

4) Se usa el metodo Implements del helper para determinar si un cierto objeto implementa una interfaz publicada:
IF goInterfaces.Implements(oData, "IEnumerable")
  FOR i = 1 TO oData.Count
  ...
  ENDFOR
ENDIF

En el caso de versiones de VFP anterior a la 9, no es posible declarar las interfaces mediante subclases de Interface, pero aun asi puede hacerse manualmente:
goInterfaces.Declare("IEnumerable","count,items")

Saludos

Victor Espina

9 de abril de 2012

FoxRibbon versión 0.10 Beta

FoxRibbon es una biblioteca de clases VCX 100% Visual FoxPro que ofrece una serie de herramientas para mejorar el aspecto visual de nuestras aplicaciones. Su uso y distribución es libre para toda la Comunidad de Visual FoxPro.

FoxRibbon fue desarrollada por Guillermo Carrero (Barcelona, España)

Pueden descargar y probar esta nueva clase desde:
http://sites.google.com/site/foxribbonclass



29 de marzo de 2012

Clase que encapsula funciones de javascript para URLs

Esta clase encapsula las funciones de javascript necesarias para trabajar con Urls.

Utiliza el msscript control. Fácilmente puedes extenderla para incluir cualquier otra funcion de javascript que necesites.

*----------------------------------------------------------------
* Clase: UrlEncDec
* Autor: Marco Plaza, 28/03/2012
* Eencapsula las siguientes funciones de javascript via MsScriptcontrol:
* Escape/Unescape
* EncodeUriComponent/DecodeUriComponent
* EncodeUri/DecodeUri
*
* referencia de las funciones:http://msdn.microsoft.com/en-us/library/ht8a077w%28v=vs.94%29.aspx
*
* fácilmente extensible a otras funciones de javascript
*
*-----------------------------------------------------------------
* uso:
* o = create('urlEncDec')
* ? o.decodeuri('http://msdn.microsoft.com/en-us/library/ht8a077w%28v=vs.94%29.aspx')
* ? o.oResult
*
*------------------------------------------------------------------


*************************************
DEFINE CLASS URLENCDEC AS CUSTOM

  oJs = ''
  oResult=''

  *---------------------------
  PROCEDURE INIT

    WITH THIS
      .oJs=CREATEOBJECT('MSScriptcontrol.scriptcontrol.1')
      .oResult=CREATEOBJECT('EMPTY')
      ADDPROPERTY(.oResult,'ResultadoJs')
      .oJs.LANGUAGE =[JavaScript]
      .oJs.ADDOBJECT('oResult',.oResult)

    ENDWITH
  ENDPROC

  *------------------------------------------
  FUNCTION ESCAPE(lcCadena AS STRING ) AS STRING
    RETURN THIS.ejecutar('escape',lcCadena)
  ENDFUNC

  *------------------------------------------
  FUNCTION encodeURI(lcCadena AS STRING ) AS STRING
    RETURN THIS.ejecutar('encodeURI',lcCadena)
  ENDFUNC

  *--------------------------------------------
  FUNCTION decodeURIComponent(lcCadena AS STRING ) AS STRING
    RETURN THIS.ejecutar('decodeURIComponent',lcCadena)
  ENDFUNC

  *------------------------------------------
  FUNCTION encodeURIComponent(lcCadena AS STRING ) AS STRING
    RETURN THIS.ejecutar('encodeURIComponent',lcCadena)
  ENDFUNC

  *------------------------------------------
  FUNCTION unescape(lcCadena AS STRING ) AS STRING
    RETURN THIS.ejecutar('unescape',lcCadena)
  ENDFUNC

  *------------------------------------------
  FUNCTION decodeURI(lcCadena AS STRING ) AS STRING
    RETURN THIS.ejecutar('decodeURI',lcCadena)
  ENDFUNC

  *------------------------------------------
  FUNCTION ejecutar(lcComando,lcCadena AS STRING ) AS STRING
    THIS.oJs.ExecuteStatement( [oResult.ResultadoJs=]+lcComando+[(']+lcCadena+[')] )
    RETURN THIS.oResult.resultadoJs
  ENDFUNC

ENDDEFINE
*---------------------------------
Marco Plaza

24 de febrero de 2012

Obtener Propiedades/Atributos extendidos de archivos

Muy buen código del turco Cetin Basoz para ver las propiedades extendidas de diferentes tipos de archivos.
Clear
lcFile = GETFILE("MP3") && Ejemplo con archivos MP3
loShell = Createobject("Shell.Application")
loFolder = loShell.Namespace(JUSTPATH(m.lcFile))
loItem = loFolder.ParseName(JUSTFNAME(m.lcFile))
If !Isnull(loItem)
  IF loItem.IsLink
    objLink = loItem.GetLink()
    ? "Link properties of shortcut:"
    ? "-------------------------------------"
    ? "Description:", objLink.Description
    ? "Path:", objLink.Path
    ? "Arguments:", objLink.Arguments
    ? "WorkingDirectory:", objLink.WorkingDirectory
    ? "-------------------------------------"
  else
    For ix= 0 To 34 && version based. win 7: 0 to 266. Property order differs too.
      ? "Column "+Str(m.ix,2)+": "+ ;
        loFolder.GetDetailsOf(loItem, m.ix)
    Endfor
  endif
Else
  ? "File doesn't exist"
Endif
Return
Para ver la información de las columnas:
http://technet.microsoft.com/en-us/library/ee176615.aspx

Para ver la información de las columnas (para mas versiones de Windows):
http://www.kixtart.org/forums/ubbthreads.php?ubb=showflat&Number=160880&page=1

15 de febrero de 2012

Como quemar Discos Ópticos desde VFP

Estuve buscando la forma de quemar un Disco Óptico (CD o DVD) desde VFP y no encontré nada "elegante". Por esta razón tuve que buscar una solución mediante el uso de un programa externo que hiciera este trabajo.

La solución fue descargar el programa Command Burner.

Command Burner lo descargué del sitio www.commandburner.com. Claramente dice en los "Términos de Uso" que el programa se puede usar y distribuir libremente.

El programa solamente requiere que los siguientes 3 archivos estén incluídos en su aplicación:
  • CMDBurn.CHM
  • CMDBurn.EXE
  • MCDB.OCX
La forma en que lo invoqué desde VFP fue la siguiente
   #DEFINE SW_SHOW_INVISIBLE 0
   oShell = createobject("WScript.Shell")
   oShell.Run("CMDBURN.EXE burn /d d:\sistema /l BACKUP /eject /hide", SW_SHOW_INVISIBLE, .T. )
   #UNDEF SW_SHOW_INVISIBLE
   RELEASE oShell
La constante #DEFINE SW_SHOW_INVISIBLE 0 la utilicé para que no se abrá una ventana mostrando la ejecución del programa. De todos modos, el programa incluye el parámetro /hide para ocultar la interface propia del Command Burner.

La línea de comando es esta:
  CMDBURN.EXE burn /d d:\sistema /l BACKUP /eject /hide 

Parámetros:
  • /d d:\sistema - Quiero quemar el directorio (o carpeta) d:\sistema y TODO su contenido
  • /l BACKUP - La etiqueta del Disco a quemar será la palabra BACKUP
  • /eject - Expulsar el disco al terminar de quemar
  • /hide - Ocultar la interface del programa CommandBurner. Si no se incluye este parámetro, se verá una interface mostrando el progreso de "quemado" del disco.
Espero que le sea de utilidad a alguien.

Edgar Acevedo

31 de enero de 2012

Función MessageBox() Extendida - Revisada

Artículo original: Extended Messagebox() function reviewed
http://weblogs.foxite.com/vfpimaging/2012/01/30/extended-messagebox-function-reviewed/
Autor: VFPIMAGING
Traducido por: Luis Maria Guayán

Versión actualizada - ahora sin la necesidad de FLL externa

Esto es sólo una actualización para el artículo original. Inicialmente esta función necesitaba la libria VFPEX.FLL de Craig Boyd para poder de actualizar el cuadro de diálogo del MESSAGEBOX(). En esta nueva versión, estoy usando la función BINDEVENTS de VFP9, para enlazar directamenta a los eventos de Windows.

MSGBOXEX() es una función sencilla que nos permite personalizar los textos de los botones del MESSAGEBOX(), la ventana de diálogo, como en las imágenes se muestra a continuación:
lnOption = MsgboxEx( ;
   "You have entered a wrong password for 5 times." + chr(13) + ;
   "For security reasons this login was suspended.", ; && main message
   0, ; && default icon info
   "Password incorrect", ; && title bar caption
   "\&Retry,&Exit,Get &new pwd", ; && new button captions
   "41.ico") && icon file







lnOption = MsgboxEx(;
   "An unexpected error has occurred and the system needs to be restarted." + ;
   chr(13) + chr(13) + "What do you want to do ?", ;
   "X", ;
   "MsgboxEx sample", ;
   "Restart &Now,Restart &later,&Never restart")



lnOption = MsgboxEx( ;
   "Could not find the file 'Import.csv' in the selected folder.", ;
   0, ;
   "File not found", ;
   "&Abort,\&Retry,Change folder", ;
   "17.ico")



Función: MsgboxEx.prg


30 de enero de 2012

Saber si una impresora esta en linea

Aquí les dejo un código que modifique para saber si una impresora esta en linea.
LOCAL NomImpresora

strComputer = "."
objWMIService = GETOBJECT("winmgmts:"+ "{impersonationLevel=impersonate}!\\" + strComputer + "\root\cimv2")
colInstalledPrinters = objWMIService.ExecQuery("SELECT * FROM Win32_Printer")

*** impresora predeterminada
NomImpresora = UPPER(SET("Printer",2))

FOR EACH objPrinter IN colInstalledPrinters
  IF ALLTRIM(UPPER(objPrinter.NAME)) = NomImpresora
    IF (objPrinter.PrinterStatus = 3 OR objPrinter.PrinterStatus = 2) AND objPrinter.workoffline
      WAIT WIND "Impresora Apagada"
      RETURN
    ENDIF
  ENDIF
NEXT
Jose Luis Sayago Baez

28 de enero de 2012

Controladores ODBC de 32 bits en SO de 64 bits

Como acceder a los controladores de orígenes de datos de 32 bits en los sistemas operativos de 64 bits.

Muchas veces vimos la pregunta de que en los sistemas operativos de 64 bits no se pueden acceder a los controladores de datos ODBC de 32 bits desde el "Administrador de orígenes de datos ODBC"

La solución a este problema es abrir la ventana "Ejecutar" (con la combinación de teclas "Windows" + "R"), tipear

"%systemdrive%\Windows\SysWoW64\odbcad32.exe"

y darle al botón "Aceptar".

Para tener simpre a mano, deberían crear un "Nuevo acceso directo" y tipear

"%systemdrive%\Windows\SysWoW64\odbcad32.exe"

en el cuadro de texto "Ubicación del elemento" y darle el nombre "Administrador de orígenes de datos ODBC de 32 bits".