Números Arábigos a Romanos

? NUM2ROMANO(1980)

FUNCTION Num2Romano(tnNum)
  DIMENSION laNum(13),laRom(13)
  LOCAL lnI, lcRom

  laNum(1) = 1
  laNum(2) = 4
  laNum(3) = 5
  laNum(4) = 9
  laNum(5) = 10
  laNum(6) = 40
  laNum(7) = 50
  laNum(8) = 90
  laNum(9) = 100
  laNum(10) = 400
  laNum(11) = 500
  laNum(12) = 900
  laNum(13) = 1000

  laRom(1) = "I"
  laRom(2) = "IV"
  laRom(3) = "V"
  laRom(4) = "IX"
  laRom(5) = "X"
  laRom(6) = "XL"
  laRom(7) = "L"
  laRom(8) = "XC"
  laRom(9) = "C"
  laRom(10) = "CD"
  laRom(11) = "D"
  laRom(12) = "CM"
  laRom(13) = "M"

  lcRom = ""

  FOR lnI = 13 TO 1 STEP -1
    DO WHILE tnNum >= laNum(lnI)
      tnNum = tnNum - laNum(lnI)
      lcRom = lcRom + laRom(lnI)
    ENDDO
  ENDFOR
  RETURN lcRom
ENDFUNC

Edad de una persona

Una (de tantas) funciones para calcular la edad de una persona.

* Ejemplo:
? Edad(DATE(1998,06,03))

*-----------------------------------------------------
* FUNCTION Edad(tdNac, tdHoy)
*-----------------------------------------------------
* tdNac = Fecha de nacimiento
* tdHoy = Fecha a la cual se calcula la edad (Por defecto toma la fecha actual)
*-----------------------------------------------------
FUNCTION Edad(tdNac, tdHoy)
  IF EMPTY(tdHoy)
    tdHoy = DATE()
  ENDIF
  RETURN FLOOR((VAL(DTOC(tdHoy,1)) - VAL(DTOC(tdNac,1))) / 10000)
ENDFUNC
*-----------------------------------------------------

Cetin Basoz, Izmir, Turkey
Publicado en www.foxite.com

Función PUTFILE() como se escribió originariamente (no en mayúsculas)

Artículo original: PUTFILE function as originally typed (not in uppercase)
http://vfpimaging.blogspot.com/2021/01/putfile-function-as-originally-typed.html
Autor: Cesar Ch.
Traducido por: Google Translate

---

Como ya se ha discutido en Fox.Wikis: "VFP siempre ha sido un poco más gracioso con los casos de nombres de archivo. Más específicamente, no está documentado cómo funciona con el caso de nombres de archivo. Se traducirá los nombres de archivo a minúsculas en algunos casos, a mayúsculas en otros, y dejarlo igual en otros."

PUTFILE() está en esa lista de funciones extrañas, siempre devolviendo los nombres de archivo en MAYÚSCULAS. Así que aquí hay una pequeña función que he estado usando que devuelve el nombre de archivo elegido de la forma en que el usuario lo escribió.

Los parámetros y el uso son exactamente los mismos que los de la función PUTFILE() original de Visual FoxPro:

FUNCTION XPUTFILE(tcCustomText, tcFileName, tcFileExt)

  * Usage:
  * ? PUTFILE("Save file as...", "MyFile.PDF", "PDF;TXT;*")

  #DEFINE COMMDLOG_DEFAULT_FLAG   0x00080000
  #DEFINE COMMDLOG_RO       4
  #DEFINE COMMDLOG_MULTFILES     512

  LOCAL lcSetDefa
  m.lcSetDefa = SET("Default") + CURDIR()

  LOCAL loDlgForm AS "Form"
  m.loDlgForm = CREATEOBJECT("Form")
  m.loDlgForm.ADDOBJECT("oleObject1", "oleComDialObject")

  LOCAL loDlg
  m.loDlg = m.loDlgForm.OleObject1

  LOCAL lcFilter, lcFileExt, lnExtCount, N
  IF NOT EMPTY(tcFileExt)
    lnExtCount = GETWORDCOUNT(m.tcFileExt, ";")
    lcFilter = ""
    FOR N = 1 TO lnExtCount
      lcFileExt = GETWORDNUM(m.tcFileExt, N, ";")
      IF lcFileExt = "*"
        lcFilter = lcFilter + "All files|*.*"
      ELSE
        lcFilter = lcFilter + lcFileExt + " files|*." + lcFileExt && EVL(tcFileExt, "All files|*.*")
      ENDIF
      IF N < lnExtCount
        lcFilter = lcFilter + "|"
      ENDIF
    ENDFOR
  ELSE
    lcFilter = "*.*|*.*" && EVL(tcFileExt, "All files|*.*")
  ENDIF

  m.loDlg.FILTER    = lcFilter
  m.loDlg.FileName  = EVL(m.tcFileName, "")
  m.loDlg.DialogTitle  = EVL(m.tcCustomText, "Save file as...")
  m.loDlg.FLAGS    = COMMDLOG_RO + COMMDLOG_DEFAULT_FLAG
  m.loDlg.MaxFileSize  = 256

  LOCAL lnResult AS INTEGER, lcFileName
  * lnResult = loDlg.ShowOpen()
  m.lnResult = m.loDlg.ShowSave()

  * Restore the original directory
  SET DEFAULT TO (m.lcSetDefa)

  IF EMPTY(m.loDlg.FileTitle) && Clicked 'Cancel'
    m.lcFileName = ""
  ELSE
    m.lcFileName = m.loDlg.FileName
  ENDIF
  m.loDlgForm = NULL
  RETURN m.lcFileName


DEFINE CLASS oleComDialObject AS OLECONTROL
  OLECLASS ="MSComDlg.CommonDialog.1"
ENDDEFINE

Separar párrafos en líneas de "n" caracteres

La función recursiva CortarParrafo() prepara una cadena para luego separarla con la función ALINES() en varias lineas de "n" o menos caracteres

Ejemplo:

lcCadena = "SON PESOS: TRES MILLONES NOVECIENTOS CINCUENTA Y CUATRO MIL " + ;
  "TRESCIENTOS OCHENTA Y NUEVE CON SETENTA Y CINCO CENTAVOS."

FOR ln = 1 TO ALINES(la,CortarParrafo(lcCadena,40))
  ? la(ln)
ENDFOR

FUNCTION CortarParrafo(tc,tn)
  LOCAL lc, ln
  tc = ALLTRIM(tc) + " "
  lc = SUBSTR(tc,1,tn)
  ln = RAT(" ",lc)
  lc = SUBSTR(lc,1,ln-1)
  RETURN IIF(EMPTY(lc),lc, lc + CHR(13) + CortarParrafo(SUBSTR(tc,ln+1),tn))
ENDFUNC

Comprobar si una DLL ya está cargada

El programa IsAPIFunction.PRG en una pequeña función que puede hacer mas rápido algún código, comprobando si una función API específica ha sido ya declarada, antes de preocuparse en declararla de nuevo.

*
*  IsAPIFunction.PRG
*  RETURN un valor lógico indicando si el nombre de la función pasada 
*  como parámetro en una función API de Windows (en una Windows .DLL)
*  que está actualmente cargada por el comando DECLARE
*
*  Author:  Drew Speedie
*
*  Esta función usa:
*  1- La función ADLLS() introducida en VFP 7.0
*  2- El sexto parámetro opcional agregado a la 
*     función ASCAN() en VFP 7.0
*
*  Ejemplos:
*!*  IF NOT X7ISAPIF("MessageBeep")
*!*    DECLARE Long MessageBeep IN USER32.DLL Long uType
*!*  ENDIF
*!*  MessageBeep(0)
*
*!*  IF NOT X7ISAPIF("MessageBeepWithAlias")
*!*    DECLARE Long MessageBeep IN USER32.DLL AS MessageBeepWithAlias Long uType
*!*  ENDIF
*!*  MessageBeep(0)
*
*!*  IF NOT X7ISAPIF("MessageBeepWithAlias","MessageBeep")
*!*    DECLARE Long MessageBeep IN USER32.DLL AS MessageBeepWithAlias Long uType
*!*  ENDIF
*!*  MessageBeep(0)
*
*
*  lParameters
*    tcFunctionAlias: El alias de la función API
*                     Por omisión, el alias es el mismo que el
*                     nombre de la función pero se puede hacer:
*                     DECLARE DLL .. AS 
*    tcFunctionName:  Si pasa tcFunctionAlias y necesita estar seguro
*                     que esta función solo retorna .T. cuando
*                     tcFunctionAlias es el alias para una declaración
*                     para un nombre de función específico, pase el 
*                     nombre de la fucnción en este parámetro
*
LPARAMETERS tcFunctionAlias, tcFunctionName
LOCAL laDLLs[1], lnRow
IF ADLLS(m.laDLLs) = 0
  RETURN .F.
ENDIF
lnRow = ASCAN(laDLLs,m.tcFunctionAlias,1,-1,2,15)
IF m.lnRow = 0
  RETURN .F.
ENDIF
IF PCOUNT() = 1 ;
    OR NOT VARTYPE(m.tcFunctionName) = "C" ;
    OR EMPTY(m.tcFunctionName)
  RETURN .T.
ENDIF
*
*  tcFunctionName fue pasado
*
RETURN UPPER(ALLTRIM(m.laDLLs[m.lnRow,1])) == UPPER(ALLTRIM(m.tcFunctionName))

Por favor note que el programa IsAPIFunction.PRG requiere VFP 7.0 o superior para ejecutarse, pero puede ser modificado para correr en la versión anterior de VFP, modificando al lógica de ASCAN(), para no para usar el ASCAN() con los parámetros agregados en VFP 7.0.

VFP Tips & Tricks - Drew Speedie

Agregar registro IFND en IntelliSense

El programa IFND_FoxCode.PRG agrega un registro "IFND" a nuestra tabla IntelliSense record que expandira en en un control IF Not Default().

En el editor de métodos o programa ingrese:

IFND{SPACE}

y este registro IntelliSense expadirá esto a:

IF NOT DODEFAULT()
   RETURN .F.
ENDIF

*
*  IFND_FoxCode.PRG
*  Agrega un registro "IFND" a nuestra tabla IntelliSense table para
*  que cuando ingrese:
*    IFND{SPACE}
*  esto se expanda a:
*    IF NOT DODEFAULT()
*      RETURN .F.
*    ENDIF
*
CLEAR ALL
CLOSE ALL
CLEAR
USE (_FOXCODE) IN 0 AGAIN ALIAS UpdateFoxCode
SELECT UpdateFoxCode
**************************************************
LOCATE FOR UPPER(ALLTRIM(Abbrev)) == "IFND"
**************************************************
IF NOT FOUND()
  APPEND BLANK
  REPLACE TYPE WITH "U", ;
    Abbrev WITH "IFND",;
    CASE WITH "U", ;
    SAVE WITH .T., ;
    Cmd WITH "{}", ;
    USER WITH "Mi registro IFND"
  ACTIVATE SCREEN
  ? PROGRAM() + " acaba de agregar el registro 'IFND'"
ENDIF
REPLACE DATA WITH ;
  "*  IF NOT DODEFAULT(), RETURN .F., ENDIF" + CHR(13) + CHR(10) + ;
  "LPARAMETERS oFoxcode" + CHR(13) + CHR(10) + ;
  "IF NOT oFoxcode.Location = 10" + CHR(13) + CHR(10) + ;
  [   RETURN "IFND"] + CHR(13) + CHR(10) + ;
  "ENDIF" + CHR(13) + CHR(10) + ;
  [oFoxcode.ValueType = "V"] + CHR(13) + CHR(10) + ;
  "TEXT TO myvar TEXTMERGE NOSHOW" + CHR(13) + CHR(10) + ;
  "IF NOT DODEFAULT()" + CHR(13) + CHR(10) + ;
  "  RETURN .F." + CHR(13) + CHR(10) + ;
  "ENDIF" + CHR(13) + CHR(10) + ;
  "ENDTEXT" + CHR(13) + CHR(10) + ;
  "RETURN myvar + chr(13) + [~]"
USE IN UpdateFoxCode
RETURN

VFP Tips & Tricks - Drew Speedie

Añadiendo funcionalidad al Dataexplorer.App

Script que inserta en un formulario en tiempo de diseño un control label y textbox mediante técnica de arrastrar y soltar desde una columna de una base de datos remota usando la aplicación Dataexplorer.app

Hace poco me puse a investigar el Dataexplorer.App y descubrí que se puede configurar algunas características a fin de hacer mas rápido el desarrollo de aplicaciones, en mi caso particular, cuando trabajo con base de datos remota como SQL Server.

Por defecto el Dataexplorer.app al arrastrar desde una columna de la base de datos remota hacia un Form te inserta un control grid junto con el cursoradapter respectivo. En mi caso particular no me sirve ya que en mis desarrollos tengo clases que me crean el entorno de datos para mis formularios. Me sería mas útil que inserte la columna como un control Textbox y su control Label respectivo. Así es que revisando el código fuente del Script que realiza esa funcionalidad, descubrí que se podía modificar, así es que he creado un script que hace lo que necesito.

Aquí les presento el código:

*  <oParameter> = parameter object
*  oParameter members:
*   DropText - populate this with the text to drop
*   Cancel - set to .T. to cancel the drag/drop operation
*   Continue - set to .F. to stop processing additional add-ins
*   oDataExplorerEngine
*   TreeNode
*   RootNode
*   MouseXPos
*   MouseYPos
*   NodeData
*   CurrentNode
*   ParentNode
*   ControlName
*   ClassName
*   ClassLocation
*   PropertyList
*   Caption
*
LPARAMETERS oParameter

LOCAL lcInc, lcName, loSource, laObjs, lcInitCode, lcAutoOpenCode
LOCAL cConnString, oConn, lcTable, lcAlias, lcSelectStr, lcName2,loForm

DIMENSION laObjs[1]
loForm=SYS(1270)

* Check for DE. Only support for forms
lnCount=ASELOBJ(laObjs,2)  && check for DE
IF lnCount = 0 OR TYPE("loForm") <> 'O'
  oParameter.Continue = .T.
  RETURN
ENDIF

* Get Column Name
DO CASE
  
CASE oParameter.CurrentNode.NodeData.Type == "Column"
  * Handle dragdrop from field node in table/view
  lcTable = oParameter.ParentNode.NodeData.Name
  lcTable = IIF(ATC(" ",lcTable)>0,"["+lcTable+"]", lcTable)
  lcAlias = oParameter.ParentNode.NodeData.Name

ENDCASE


IF UPPER(loForm.Baseclass)=="FORM"
  LOCAL iTop as Integer, iLeft as Integer
  iTop  = MROW(0,3)
  iLeft = MCOL(0,3)

  * Control TextBox
  lcInc = ""
             lcName2 = oParameter.ControlName
  lcName2 = CHRTRAN(lcName2," ","_")
  DO WHILE TYPE("loForm." + m.lcName2 + m.lcInc)#"U"
    m.lcInc = ALLTRIM(STR(VAL(m.lcInc)+1))
  ENDDO
  lcName2 = m.lcName2 + m.lcInc
      loForm.NewObject(lcName2, oParameter.ClassName, oParameter.ClassLocation)
      IF PEMSTATUS(loForm.&lcName2, "ControlSource", 5)
      WITH loForm.&lcName2
         .ControlSource = ALLTRIM(lcTable)+"."+ALLTRIM(oParameter.CurrentNode.NodeData.Name)  
         .Top = iTop
         .Left = iLeft + 100
         .Name = left(LOWER(.Name),3)+PROPER(SUBSTR(.Name,4,50))
      ENDWITH
   ENDIF

  * Control Label
  lcIncLbl=""
  lcNameLabel="lbl"+ALLTRIM(oParameter.CurrentNode.NodeData.Name)
  DO WHILE TYPE("loForm." + m.lcNameLabel + m.lcIncLbl)#"U"
    m.lcIncLbl = ALLTRIM(STR(VAL(m.lcIncLbl)+1))
  ENDDO
  lcNameLabel = m.lcNameLabel + m.lcIncLbl
   loForm.addObject(lcNameLabel, "Label")
   IF PEMSTATUS(loForm.&lcNameLabel, "Caption", 5)
      WITH loForm.&lcNameLabel
         .Name = left(LOWER(.Name),3)+PROPER(SUBSTR(.Name,4,50))
         .Top = iTop
         .Left = iLeft
         .Caption = ALLTRIM(oParameter.CurrentNode.NodeData.Name)
         .Autosize = .t.
      ENDWITH
   ENDIF

ENDIF
oParameter.ClassName = ""  
oParameter.Continue = .F.

Con este Script logro insertar en mi formulario en tiempo de diseño un control Textbox junto con su respectivo control label. En el control textbox se configuran la propiedad ControlSource con el nombre de la Tabla y el nombre de la columna (TableName.ColumnName). La propiedad Name se define anteponiendo la palabra "txt" seguido del nombre de la columna de la tabla (txtColumnName). En el caso del control Label la propiedad Caption se define con el nombre de la columna y su propiedad Name se define anteponiendo la palabra "lbl" mas el nombre de la columna de la tabla.

CONFIGURACION

Llamar al Dataexplorer.App desde la ventana de comandos con DO HOME() + "dataexplorer.app"

Hacer Click en el Boton Options y entrar a Manage Drag/Drop. Seleccionar la opción Drag/Drop to Designe Surface e Insertar un nuevo registro haciendo Click en el Boton New.

En la pestaña General poner en el campo Caption una descripción o etiqueta para el script, por ejemplo "SQL/ADO Fields" sin las comillas. Ir a la pestaña Script to Run y poner en el campo Execute Only for the following Nodes (comma - separated) lo siguiente: "ADOColumnNode,SQLColumnNode" sin las comillas y en el campo Code to Execute upon Drop copiar el script mostrado arriba. Grabar haciendo click en el botón Save o Apply.

Ahora lo único que falta es desactivar la funcionalidad que viene por defecto a fin de que se ejecute nuestro nuevo script. Para hacer esto seleccionar de la lista el registro SQL/ADO Tables, Views and Fields. Ir a la pestaña Script to Run y eliminar del campo Execute Only for the following Nodes (comma - separated) las siguientes etiquetas: ADOColumnNode y SQLColumnNode y grabar con Save o Apply.

Espero este Scrip pueda serle útil a la gran comunidad fox.

Saludos.

Miguel Herbias
Lima - Peru

Decodificar la marca de tiempo en bibliotecas de clases y formularios

Visual Foxpro coloca una marca de tiempo en muchos registros de la tabla que representa un formulario o una biblioteca de clases. Históricamente, este campo se usaba para hacer coincidir los registros en las plataformas compatibles: DOS, Mac, Unix, Windows.

La variable reservada de VFP "_Screen" es una referencia de objeto a la instancia de Form que representa el escritorio de VFP. Debido a que es una instancia de formulario, puede guardarlo como una clase utilizando el método SaveAsClass . Esto hará que se cree un registro de marca de tiempo que podamos usar para ejecutar el código de muestra. El código de muestra demora 3 segundos, crea una subclase del formulario, agrega un botón y luego muestra las marcas de tiempo de los elementos en la biblioteca de clases.

La marca de tiempo está en un formato estándar

ERASE T.vcx
_SCREEN.ADDOBJECT("btn","commandbutton")        && add a button to the desktop
_SCREEN.SAVEASCLASS("t.vcx","myform")           && create class myform in a target file t.vcx
INKEY(3)                                        && delay 3 seconds
MODIFY CLASS xx OF T.vcx AS myform FROM T.vcx NOWAIT  && create a subclass of myform in the same file
ASELOBJ(aArray,1)                               && get an object reference to the class in the designer
aArray[1].ADDOBJECT("btn2","commandbutton")     && and btn2 to the class
aArray[1].btn2.TOP=200                          && move it down so it doesn't hide btn
KEYBOARD "Y"                                    && a "y" in the "Do you want to save changes")
RELEASE WINDOWS "Class designer"                && close the designer
USE T.vcx                                       && open the table

SCAN FOR TIMESTAMP!=0                           && look for timestamps
  ?TIMESTAMP,DecodeTimeStamp(TIMESTAMP),objname+" "+CLASS
ENDSCAN

PROCEDURE DecodeTimeStamp(nTimestamp AS NUMBER) AS DATETIME
  *** See http://msdn.microsoft.com/library/default.asp?url=/library/en-us/sysinfo/base/filetimetodosdatetime.asp
  nDate=BITRSHIFT(nTimestamp,16)
  nTime=BITAND(nTimestamp,2^16-1)

  nYear=BITAND(BITRSHIFT(nDate,9),2^8-1)+1980
  nMonth=BITAND(BITRSHIFT(nDate,5),2^4-1)
  nDay=BITAND(nDate,2^5-1)

  nHr=BITAND(BITRSHIFT(nTime,11),2^5-1)
  nMin=BITAND(BITRSHIFT(nTime,5),2^6-1)
  nSec=BITAND(nTime,2^5-1)

  RETURN DATETIME(nYear,nMonth,nDay,nHr,nMin,nSec)
ENDPROC 

Calvin Hsia

Artículo original: Decoding the timestamp in class libararies and forms

Detectar si una impresora es de matriz de puntos

Con esta función pueden averiguar si una impresora es de matriz de puntos.

CLEAR
DIMENSION asPrn[1]
FOR nPrn = 1 TO APRINTERS(asPrn)
  sPrn = asPrn[nPrn, 1]
  ? PADR(sPrn,50), " ", IIF(IsDotPrinter (sPrn), "Matriz", "")
NEXT
RETURN

FUNCTION IsDotPrinter (sPrn)
  LOCAL nBins, sBuff
  #DEFINE DC_BINS 6
  #DEFINE DMBIN_TRACTOR 8
  
  DECLARE LONG DeviceCapabilities IN WinSpool.drv ;
    STRING @ sPrinter, STRING @ sPort, ;
    INTEGER nCapability, STRING @ sReturn, STRING @ pDevMode
  sBuff = SPACE(512)
  * Lista de words de bandejas
  nBins = DeviceCapabilities (sPrn, NULL, DC_BINS, @sBuff, NULL)
  IF nBins > 0
    sBuff = PADR(sBuff, nBins)
  ENDIF
  CLEAR DLLS DeviceCapabilities
  RETURN CHR(DMBIN_TRACTOR) $ sBuff
ENDFUNC

Mario Lopez

Una funcion ADIR() Extendida que devuelve los nombres de los archivos con la ruta completa

Retorna en un vector la ruta y nombre de de todos los archivos que concuerden con lo especificado en "tcWild".

*--------------------------------------------------------
* FUNCTION ADIRX() - ADIR Extendido
*--------------------------------------------------------
* Devuelve en un array "taArray" pasado por referencia
* el listado de archivos especificado en "tcWild" con 
* la ruta completa. Ej: "D:\WORD\DOCUMENTO.DOC"
* PARAMETROS:
*    taArray: Array pasado por referencia
*    tcWild: Tipos de archivo. Ej: *.DBF
*    tcRoot: Directorio donde busca los archivos
* RETORNA: Numerico = Cantidad de archivos
* USO:
*    DIMENSION MiArray[1]
*    ? ADIRX(@MiArray, "*.PRG", "C:\PROGRAMAS\")
*--------------------------------------------------------
FUNCTION ADIRX(taArray, tcWild, tcRoot)
  IF EMPTY(tcWild)
    *--- Por defecto "*.*"
    tcWild = "*.*"
  ENDIF
  IF EMPTY(tcRoot)
    *--- Por defecto directorio actual
    tcRoot = SYS(5) + CURDIR()
  ENDIF
  tcRoot = ADDBS(tcRoot)
  DIMENSION taArray[1]
  lnCant = ADIR(taAux, tcRoot + tcWild)
  FOR lnI = 1 TO lnCant
    taArray[lnI] = tcRoot + taAux[lnI, 1]
    DIMENSION taArray[ALEN(taArray) + 1]
  ENDFOR
  IF ALEN(taArray) > 1
    DIMENSION taArray[ALEN(taArray) - 1]
    RETURN ALEN(taArray)
  ELSE
    RETURN 0
  ENDIF
ENDFUNC

Luis María Guayán
Yerba Buena, Tucumán

Vaciar el contenido de un directorio (archivos y carpetas)

Como podemos vaciar una carpeta y todo su contenido (Modificado)

*-----------------------------------------------------------------
* FUNCTION EmptyDir(tcRoot, tlNotAsk)
*-----------------------------------------------------------------
* Vacia todo el contenido (archivos y carpetas) del directorio
* "tcRoot" pasado como parámetro
* PARAMETROS:
*   tcRoot = Directorio a vaciar
*   tlNotAsk = .T. - No pregunta antes de vaciar el directorio
* USO:
*   =EmptyDir("C:TEMP", .F.)
*-----------------------------------------------------------------
FUNCTION EmptyDir(tcRoot, tlNotAsk)
  PRIVATE lnI, lnCant, laAux, lcSubDir
  tcRoot = ADDBS(tcRoot)
  IF NOT tlNotAsk
    IF 1 <> MESSAGEBOX("¿Esta Ud. seguro de borrar " + ;
        "todos los archivos y carpetas de" +CHR(13) + ;
        tcRoot + "?", 1+32+256, "Atención")
      RETURN
    ENDIF
  ENDIF

  ********************************
  **** Agregado por Leonel Ortega ***
  ********************************
  miComm = "attrib -r -h "+(tcRoot + "*.*")+" /S /D"
  =wScript(miComm,2)
  ********************************

  DELETE FILE (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 = ADDBS(tcRoot + laAux[lnI, 1])
        =EmptyDir(lcSubDir, .T.)
        RMDIR (lcSubDir)
      ENDIF
    ENDIF
  ENDFOR
  RETURN
ENDFUNC

********************************
**** Agregado por Leonel Ortega ***
********************************
FUNCTION wScript
 LPARAMETER eComm, eWindowType
 IF pCount()=0
  WAIT WINDOW 'Faltan parametros en WScript' TIMEOUT 2
 ENDIF

 IF pCount()=1
  eWindowType = 1
 ENDIF

 LOCAL loWshShell
 loWshShell = CREATEOBJECT("WScript.shell")
 loWshShell.RUN( eComm ,eWindowType,.T.)  && el 2 es minimizado, 1 es Normal

ENDFUNC
********************************

Engancharse a los Eventos de Un Objeto Cualquiera

Este código permite por ejemplo ejecutar código en el evento Moved del _Screen y en el evento Resize... ... también permite "Engancharse" cualquier otro objeto de VFP, siempre y cuando sea nativo de Visual FoxPro. Al querer colgarme al evento Activate del _Screen, a veces da Error.

Para colgarse a un cuadro de texto podemos definir

OBJETO = 'THISFORM.TEXTO1'

Y podríamos sobreescribir el evento Valid.

OBJETO = '_SCREEN'
_SCREEN.ADDOBJECT('HOOK_1', '_GANCHO')

DEFINE CLASS _GANCHO AS CUSTOM
 OBJEVALUADO = EVAL(OBJETO)

 PROCEDURE OBJEVALUADO.MOVED
  IF THIS.WINDOWSTATE = 0
   IF (THIS.LEFT < 0) OR (THIS.TOP < 0)
    THIS.AUTOCENTER=.T.
   ENDIF
  ENDIF  
 ENDPROC
 
 PROCEDURE OBJEVALUADO.RESIZE
  ACTIVATE SCREEN
  IF THIS.WINDOWSTATE = 1
   THIS.CAPTION = 'Minimizado'
  ENDIF
  IF THIS.WINDOWSTATE = 2
   THIS.CAPTION = 'Microsoft Visual FoxPro'
  ENDIF
  IF THIS.WINDOWSTATE = 0
   THIS.CAPTION = 'Normal'
   THIS.AUTOCENTER = .T.
  ENDIF
 ENDPROC

ENDDEFINE

Jorge Mota

Función ATAGINFO()

VFP 7.0 agregó una la nueva función ATAGINFO() para llenar un Array con la información sobre las etiquetas contenidas en un archivo de indice CDX.

use <AlgunaTabla> in 0<
ataginfo(laTemp,"","AlgunaTabla")
display memory like laTemp

[035] VFP Tips & Tricks - Drew Speedie

Obtener todos los objetos de un formulario

Una Clase para obtener todos los objetos de un formulario y retornarlos dentro de un objeto Collection (VFP8 en adelante) mejorando por tanto la manera de acceder a ellos por clave.

******** CODIGO DE EJEMPLO *******
_SCREEN.ADDOBJECT('txtFldA', 'TextBox')
_SCREEN.ADDOBJECT('txtFldB', 'TextBox')
_SCREEN.ADDOBJECT('txtFldC', 'TextBox')
_SCREEN.ADDOBJECT('txtFldD', 'TextBox')
LOCAL loCol AS Collection
loCol = CREATEOBJECT('collection')
? COBJECTS(loCol, _SCREEN)
? loCol(3).NAME
? loCol(3).VISIBLE
loCol('txtFldC').TOP   = 100
loCol('txtFldC').VALUE = 'Prueba'
loCol('txtFldC').VISIBLE = .T.
*!* Nota: Es conveniente que la vida de la coleccion sea la mas corta posible
*!*       con el fin de evitar errores de garbaje o de collecion de basura ya que
*!*       la coleccion guarda refrencias a muchos objetos cuya vida no se asegura
RELEASE loCol
RETURN
**********************************
*!* Devuelve todos los objetos contenidos en contenedor
*!* Sintaxis:   COBJECTS(toCol, toCnt)
*!* Retorno:    lnRetVal
*!* Argumentos: toCol especifica la coleccion de retorno con los objetos contenidos
*!*             debe declararse en el programa que invoca la funcion y pasarse 
*!*             por referencia toCnt especifica el objeto contenedor que se va a examinar
*!*
*!* Nota:       Como la funcion es recursiva para darle mas rapidez no hacemos 
*!*             comprobaciones sobre la validez de los parametros enviados
*!*             por lo que confiamos que toCol se haya declarado, pasado por 
*!*             referencia y que toCnt realmente sea un objeto contenedor
FUNCTION COBJECTS
  LPARAMETERS toCol AS Collection, toCnt AS OBJECT
  LOCAL loCtrl AS OBJECT, loPage AS OBJECT, loColu AS OBJECT, lcClass AS CHARACTER, ;
  lnKey AS INTEGER, lcKey AS CHARACTER, lnRetVal AS INTEGER

  FOR EACH loCtrl IN toCnt.CONTROLS
    *!* Valores
    lcClass = UPPER(loCtrl.BASECLASS)
    *!* Buscar una key valida
    FOR lnKey = 0 TO 32767
      lcKey = loCtrl.NAME + ALLTRIM(TRANSFORM(lnKey, @Z'))
      IF toCol.GetKey(lcKey) = 0
        EXIT
      ENDIF
    ENDFOR
    *!* Agregar control a la coleccion
    toCol.ADD(loCtrl, lcKey)
    *!* Recursivo
    DO CASE
      CASE  lcClass = 'PAGEFRAME'
        *!* Recorrer las paginas
        FOR EACH loPage IN loCtrl.PAGES
          COBJECTS(toCol, loPage)
        ENDFOR
      CASE lcClass = 'GRID'
        *!* Recorrer las columnas
        FOR EACH loColu IN loCtrl.COLUMNS
          COBJECTS(toCol, loColu)
        ENDFOR
      CASE lcClass = 'CONTROL'
        *!* El un objeto control no puede ser recorrido
        *!* aunque tenga la propiedad ControlCount
      CASE PEMSTATUS(loCtrl, 'ControlCount', 5)
        *!* Recorre objeto contenedor
        COBJECTS(toCol, loCtrl)
      CASE PEMSTATUS(loCtrl, 'ButtonCount', 5)
        *!* Recorre botones
        FOR EACH loCtrl IN loCtrl.BUTTONS
          *!* Buscar una key valida
          FOR lnKey = 0 TO 32767
            lcKey = loCtrl.NAME + ALLTRIM(TRANSFORM(lnKey, @Z'))
            IF toCol.GetKey(lcKey) = 0
              EXIT
            ENDIF
          ENDFOR
          *!* Agregar control a la coleccion
          toCol.ADD(loCtrl, lcKey)
        ENDFOR
    ENDCASE
  ENDFOR
  *!* Valor retorno
  lnRetVal = toCol.COUNT
  *!* Retorno
  RETURN lnRetVal
ENDFUNC
**********************************

Enjoy It...

Alexandre Hedreville

Enter vertical en un Grid

Esta es una solución planteada por mi compañero de trabajo Pedro Valle para lograr un Enter vertical en un Grid de modo mas eficiente.

He visto soluciones anteriores pero el foco lo obtenía siempre la siguiente columna después de haberse movido el puntero a la siguiente fila y el código estaba dado en el evento Keypress. Necesitábamos que después del Enter el foco se mantuviera en la misma columna.

En esta nueva solución el código lo insertamos en el evento GotFocus de la columna siguiente a la que se le hizo el Enter. En el caso de que la columna en la que se hizo el Enter sea la ultima del Grid, la columna siguiente será la primera.

Llamaremos ColumnX a la columna donde se hará el Enter.

IF LASTKEY() = 13
  CLEAR TYPEAHEAD
  KEYBOARD '#' CLEAR
  SKIP
  Thisform.Grid1.Refresh()
  Thisform.Grid1.ColumnX.SetFocus()
ENDIF

Saludos.

Alex Moreno Candiotty

Calcular el dígito de verificación para Rapipago y Pagofacil (Argentina)

En Argentina existen al menos dos redes de cobranzas extrabancarias (Rapipago y Pagofacil) que permiten el pago de facturas, servicios, etc. a través de formularios con códigos de barras que se emiten con una estructura particular para cada caso.

En primer lugar, a la cadena a codificar se le deben agregan 1 ó 2 dígitos de verificación al final. El algoritmo (en código VFP) para la generación de estos dígitos es el siguiente:

CLEAR 

lc = "1234567890123456789012345678901234567890"
? "Sin dígito de verificación...: " + lc
? "Con 1 dígito de verificación.: " + GenerarDigitoVerificador(lc, 1)
? "Con 2 dígitos de verificación: " + GenerarDigitoVerificador(lc, 2)

FUNCTION GenerarDigitoVerificador(tcCadena, tn)
  *---
  * Parámetros
  *   tcCadena = Cadena a generar el/los dígito/s de verificación
  *   tn = Cantidad de dígito/s de verificación (1 ó 2)
  * Retorno:
  *   Caracter: La cadena mas el/los dígito/s de verificación
  *---

  IF EMPTY(tn) OR NOT INLIST(tn, 1, 2)
    tn = 1
  ENDIF

  tcCadena = ALLTRIM(tcCadena)

  LOCAL lnLen, lnIni, lnSum, lcSeq, lcRet
  lnLen = LEN(tcCadena)
  lcSeq = "1" + REPLICATE("3579", CEILING(lnLen/4))
  lnSum = 0
  FOR lnIni = 1 TO lnLen
    lnSum = lnSum + VAL(SUBSTR(tcCadena, lnIni, 1)) * VAL(SUBSTR(lcSeq, lnIni, 1))
  ENDFOR
  lcRet = tcCadena + TRANSFORM(MOD(INT(lnSum / 2), 10))
  IF tn = 2
    tcCadena = ALLTRIM(lcRet)
    lnLen = LEN(tcCadena)
    lcSeq = "1" + REPLICATE("3579", CEILING(lnLen/4))
    lnSum = 0
    FOR lnIni = 1 TO lnLen
      lnSum = lnSum + VAL(SUBSTR(tcCadena, lnIni, 1)) * VAL(SUBSTR(lcSeq, lnIni, 1))
    ENDFOR
    lcRet = tcCadena + TRANSFORM(MOD(INT(lnSum / 2), 10))
  ENDIF
  RETURN lcRet
ENDFUNC

Luego de añadir los dígitos de verificación, ya se puede generar el código de barra Interleved 2 of 5 (I2of5) o Código 128 C, que son los que utilizan ambas empresas.

Si desean realizar toda la tarea con Visual FoxPro, pueden utilizar la clase FoxBarcode que soporta ambas simbologías de códigos de barra. Si utilizan el código I2of5 se debe configurar la propiedad lAddCheckDigit que no genere el dígito de control: (lAddCheckDigit = .F.)

Luis María Guayán

Dígito verificador CURP (México)

Rutina para calcular el dígito verificador de la CURP (México) a partir de los 17 caracteres iniciales de la misma.

* Dígito Verificador CURP

Function _Curp(cCurp)

  cCaracteres='0123456789ABCDEFGHIJKLMNÑOPQRSTUVWXYZ'
  nFactor=19
  nSuma=0

  FOR nIndice=1 TO LEN(cCaracteres)

    cCaracter=SUBSTR(cCurp,nIndice,1)
    nPos=AT(cCaracter,cCaracteres)
    nFactor=nFactor-1
    nSuma=nSuma+nPos*nFactor
 
  ENDFOR 

  nDigito=10-MOD(nSuma,10)
  nDigito=IIF(nDigito=10,0,nDigito)
  cCurp=cCurp+TRANSFORM(nDigito)

  RETURN cCurp
ENDFUNC

Jesus Caro V

Conversor de divisas utilizando la API de Google

? ConvertirDivisa(1, "USD", "ARS")  && 1 US Dolar -> Peso de Argentina 
? ConvertirDivisa(10, "EUR", "ARS")  && 10 Euros -> Peso de Argentina
? ConvertirDivisa(100, "ARS", "USD") && 100 Pesos de Argentina -> US Dolar

FUNCTION ConvertirDivisa(pnMonto, plFrom, plTo)
  LOCAL lc, lcUrl, la(1)
  DECLARE LONG URLDownloadToFile IN URLMON.DLL ;
    LONG, STRING, STRING, LONG, LONG
  ERASE "cambio.txt"
  lcURL = "https://www.google.com/finance/converter?a="+TRANSFORM(pnMonto)+"&from="+ plFROM +"&to=" + plTO
  IF 0 = URLDownloadToFile(0, lcURL, "cambio.txt", 0, 0)
    TRY
      INKEY(1)
      lc = FILETOSTR("cambio.txt")
      ALINES(la,lc,1,"<div id=currency_converter_result>")
      lc=la(2)
      ALINES(la,lc,1,"</span>")
      lc = STRTRAN(la(1),"<span class=bld>", "")
    CATCH
      lc =  "Error de divisas"
    ENDTRY
  ELSE
    lc =  "No hay conexion"
  ENDIF
  RETURN lc
ENDFUNC

Los códigos válidos de las distintas divisas están en la siguiente tabla:

Quitar los acentos

Con esta simple rutina podemos quitar y reemplazar todos los acentos de una cadena

Ejemplo:

? QuitarAcentos("José María SÁNCHEZ")

*-------------------------------------
* FUNCTION QuitarAcentos(tcCadena)
*-------------------------------------
* Quita los acentos de una cadena
* RETORNA: Caracter
* USO: QuitarAcentos("Mamá")
*-------------------------------------
FUNCTION QuitarAcentos(tcCadena)
 RETURN CHRTRAN(tcCadena, "áéíóúÁÉÍÓÚ","aeiouAEIOU")
ENDFUNC
*-------------------------------------

Utilizando la función CHRTRAN() también podemos crear otras rutinas para quitar y/o reemplazar caracteres especiales de una cadena de texto.

Luis María Guayán

Convertir imágenes a distintos tipos de archivo

Una función que permite convertir imágenes a distintos formatos y calidad utilizando WIA (Windows Image Acquisition Automation Layer).

En este ejemplo solo utiliza el filtro de Conversión (Formato y Calidad). Pueden ver mas ejemplos de los distintos usos de filtros en la siguiente página: How to Use Filters.

* Ejemplo:
lcFile = GETPICT()
lcFileJPG = ConvertImageType(lcFile, "JPG", 90)
lcFileBMP = ConvertImageType(lcFile, "BMP")
lcFileGIF = ConvertImageType(lcFile, "GIF")
lcFilePNG = ConvertImageType(lcFile, "PNG")
lcFileTIF = ConvertImageType(lcFile, "TIF")

FUNCTION ConvertImageType(tcFileName, tcImageType, tnQuality)
  IF EMPTY(tcFileName) OR ;
      VARTYPE(tcFileName) <> "C" OR ;
      NOT FILE(tcFileName)
    RETURN .F.
  ENDIF

  IF EMPTY(tcImageType) OR ;
      VARTYPE(tcImageType) <> "C"
    tcImageType = "JPG"
  ENDIF

  IF EMPTY(tnQuality) OR ;
      VARTYPE(tnQuality) <> "N" OR ;
      BETWEEN(tnQuality,0,100)
    tnQuality = 100
  ENDIF

  LOCAL loImgFile, loImgProcess
  loImgFile = CREATEOBJECT("WIA.ImageFile")
  loImgProcess = CREATEOBJECT("WIA.ImageProcess")

  * Cargo la imagen a convertir
  loImgFile.LoadFile(tcFilename)

  * Agrego filtros
  loImgProcess.Filters.ADD(loImgProcess.FilterInfos("Convert").FilterID)

  * Nuevo tipo de archivo
  LOCAL lcFormatId
  DO CASE
    CASE tcImageType = "JPG"
      lcFormatID = "{B96B3CAE-0728-11D3-9D7B-0000F81EF32E}"
    CASE tcImageType = "BMP"
      lcFormatID = "{B96B3CAB-0728-11D3-9D7B-0000F81EF32E}"
    CASE tcImageType = "GIF"
      lcFormatID = "{B96B3CB0-0728-11D3-9D7B-0000F81EF32E}"
    CASE tcImageType = "PNG"
      lcFormatID = "{B96B3CAF-0728-11D3-9D7B-0000F81EF32E}"
    CASE tcImageType = "TIF"
      lcFormatID = "{B96B3CB1-0728-11D3-9D7B-0000F81EF32E}"
    OTHERWISE
      tcImageType = "JPG"
      lcFormatID = "{B96B3CAE-0728-11D3-9D7B-0000F81EF32E}"
  ENDCASE
  loImgProcess.Filters(1).Properties("FormatID").VALUE = lcFormatId

  * Calidad
  loImgProcess.Filters(1).Properties("Quality").VALUE = tnQuality && Calidad

  * Aplico filtros
  loImgFile  = loImgProcess.APPLY(loImgFile)

  LOCAL lcNewFileName
  lcNewFileName =   FORCEEXT(JUSTSTEM(tcFileName), tcImageType)

  * Que no exista el nombre de archivo
  LOCAL lnCount
  lnCount = 1
  DO WHILE FILE(lcNewFileName)
    lcNewFileName = FORCEEXT(JUSTSTEM(tcFileName) + TRANSFORM(lnCount), tcImageType)
    lnCount = lnCount + 1
  ENDDO

  * Guardo imagen procesada
  loImgFile.SaveFile(lcNewFileName)

  STORE NULL TO loImgFile, loImgProcess
  
  *Retorno el nuevo nombre de archivo convertido
  RETURN lcNewFileName
ENDFUNC

Luis María Guayán

Nota: Un reconocimiento al Blog de Jose Guillermo Ortiz Hernandez del cual tome información que me ayudo en la elaboración de esta función que cubre mis necesidades.