Comunidad de Visual FoxPro en Español: marzo 2000

31 de marzo de 2000

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

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

*----------------------------------------
* EJEMPLO DE USO
*----------------------------------------
LOCAL loBar
loBar = CREATEOBJECT("SQLBar")

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

RELEASE loBar

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

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

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

*----------------------------------------
* Fin de la definición de la clase
*----------------------------------------

Luis María Guayán

Barra de progreso en la barra de estado (StatusBar)

Una barra de progreso en la barra de estado (StatusBar).

*----------------------------------------
* EJEMPLO DE USO
*----------------------------------------

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

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

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

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

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

Luis María Guayán

23 de marzo de 2000

Conversión de decimal a hexadecimal

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

Luis María Guayán

22 de marzo de 2000

Conversión de hexadecimal a decimal

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

Luis María Guayán

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

Rutina que convierte el valor numerico retornado por GETCOLOR() a formato RGB(,,).

*------------------------------------------------
FUNCTION _Col2RGB(tnColor)
*------------------------------------------------
* Pasa un número de color a formato RGB.
* USO: _Col2RGB(1547)
* RETORNA: Caracter - "RGB(nR, nG, nB)" 
*------------------------------------------------
  LOCAL lcRGB, ln 
  lcRGB="RGB(" 
  FOR ln=1 TO 3
    lcRGB=lcRGB+TRAN(tnColor%256,"999")+IIF(ln=3, "", ",")
    tnColor=INT(tnColor/256)
  ENDFOR
  lcRGB=lcRGB+")"
  RETURN lcRGB
ENDFUNC

Luis María Guayán

21 de marzo de 2000

Conversión de binario a decimal

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

Luis María Guayán

20 de marzo de 2000

Conversión de decimal a binario

Función que pasa un numero entero a binario.

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

Luis María Guayán

19 de marzo de 2000

Poner una imagen de fondo en la pantalla principal de VFP

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

_Screen.Picture = "C:\BITMAPS\MiImagen.BMP"

Luis María Guayán

18 de marzo de 2000

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

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

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

Luis María Guayán

14 de marzo de 2000

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

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

IF RIGHT(SYS(16,0),4) = ".EXE"
    WAIT WIND "Ejecutado desde un EXE"
ELSE
    WAIT WIND "Ejecutado desde desarrollo"
ENDIF

Luis María Guayán

13 de marzo de 2000

Cambiar el icono de la ventana principal de VFP

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

_Screen.Icon = "C:ICONSMiIcono.ICO"

10 de marzo de 2000

Como saber si la disquetera tiene un disquette disponible

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

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

Luis María Guayán

8 de marzo de 2000

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

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

Luis María Guayán

Saber si un año es bisiesto

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

Pablo Roca

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

Función que transforma una cantidad de segundos a formato HH:MM:SS.

*--------------------------------------------------------------------------
* FUNCTION _Seg2Hor(nSegundos)
*--------------------------------------------------------------------------
* Transforma segundos a formato hhHH:MM:SS
* USO: _Seg2Hor(nSegundos)
* EJEMPLO: _Seg2Hor(35000)
* RETORNA: Caracter 'HH:MM:SS'
*--------------------------------------------------------------------------
*FUNCTION _Seg2Hor(nSegundos)
lpara nSegundos
 LOCAL lnHoras, lnMinutos, lnSegundos
 lnHoras = INT(nSegundos/3600)
 lnMinutos = INT(((nSegundos-(lnHoras*3600))/60))
 lnSegundos = MOD(nSegundos,60)
 RETURN IiF(lnHoras<100,TRANSFORM(lnHoras,"@L 99"),TRANSFORM(lnHoras,"@L 9999")) +":"+ ;
  TRANSFORM(lnMinutos,"@L 99")+":"+ ;
  TRANSFORM(lnSegundos,"@L 99")
ENDFUNC

Luis María Guayán

Nombre del PC y del usuario

Sin utilizar la API, solo la función SYS(0) de VFP

Ejemplo:
? PC_USER(1)
? PC_USER(2)

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

  RETURN lc
ENDFUNC
*----------------------------

Luis María Guayán

Saber la resolución del monitor

? _Resolucion()

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

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

Verificar si una tabla está abierta en exclusiva.

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

Luis María Guayán

Calcular el último día del mes

Función que retorna el último día de un mes.

*------------------------------------------------
FUNCTION _EOM(dFecha)
*------------------------------------------------
* Retorna el último día del mes (EndOfMonth)
* USO: _EOM(DATE())
* RETORNA: Fecha
*------------------------------------------------
  LOCAL ld 
  ld = GOMONTH(dFecha,1)
  RETURN ld - day(ld)
ENDFUNC
*------------------------------------------------

Luis María Guayán

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

poExplorer = CreateObject("InternetExplorer.Application")
poExplorer.Navigate("http://www.microsoft.com")
poExplorer.Visible=.T.
Release poExplorer

Luis María Guayán

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

Si queremos saber el nombre y la ruta completa:

? SYS(16,0)

Si queremos saber solo el nombre:

? SYS(2014, SYS(16,0))

Luis María Guayán

Enviar un Email por Outlook

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

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

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

Pablo Roca

Como mostrar un mensaje de WAIT en la barra de tareas

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

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

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

RELEASE loBar

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

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

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

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

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

Luis María Guayán

7 de marzo de 2000

Controlar la posición del cursor con la API

¿Cómo se puede controlar la posición del cursor con la API?

*-----------------------------------------------
FUNCTION SetCurPos(lnX, lnY)
*-----------------------------------------------
* Posiciona el cursor en la posición especificada
* PARAMETROS: lnX = Posición de X
*             lnY = Posición de Y
*-----------------------------------------------
IF EMPTY(lnX)
  lnX = 0
ENDIF
IF EMPTY(lnY)
  lnY = 0
ENDIF
DECLARE INTEGER SetCursorPos IN WIN32API ;
  INTEGER, ;
  INTEGER
=SetCursorPos(lnX, lnY)
RETURN ""
ENDFUNC

Luis María Guayán

Ver las aplicaciones que se están ejecutando en Windows

=ListApp()

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

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

Luis María Guayán

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

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

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

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

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

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

Luis María Guayán

Función API que retorna el nombre de la computadora

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

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

Luis María Guayán

Desconectar una unidad de red

Como desconectar una unidad de red.

* ------------------------------------------------------
FUNCTION _UnmapDrive( tcDrive)
* ------------------------------------------------------
* Desconecta un drive de red
* USO: ? _UnmapDrive("Z:")
* ------------------------------------------------------
 LOCAL lnRet
 DECLARE INTEGER WNetCancelConnection IN WIN32API;
  STRING @lpzLocalName, INTEGER nForce
 lnRet = WNetCancelConnection( @tcDrive, 0)
 IF lnRet   RETURN "Error "+ALLT(STR(lnRet))+" al desconectar el drive "+tcDrive
 ENDIF
 RETURN ""
ENDFUNC

Luis María Guayán

Conectar una unidad de red a un recurso compartido

Como conectar una unidad de red a un recurso compartido.

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

Luis María Guayán

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

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

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

Luis María Guayán

Leer y escribir la hora del sistema desde VFP

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

Para LEER la fecha-hora del sistema

? ReadLocalTime()

Para ESCRIBIR la fecha-hora del sistema

? WriteLocalTime(DATETIME(1998,10,07,18,00,00))

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

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

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

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

DECLARE GetLocalTime IN win32api ;
   STRING @lcAuxi

lcAuxi=SPAC(32)

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

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

RETURN ltDateTime
ENDFUNC

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

LOCAL lcCadena

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

DECLARE SetLocalTime IN win32api ;
   STRING lcCadena

RETURN SetLocalTime(lcCadena)
ENDFUNC

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

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

lcRetorno=''
DO WHILE lnNumero >= 256
   lnAscii=MOD(lnNumero,256)
   lcRetorno=lcRetorno + CHR(lnAscii)
   lnNumero=INT(lnNumero / 256)
ENDDO
lnAscii=lnNumero
lcRetorno=lcRetorno + CHR(lnAscii)
RETURN PADR(lcRetorno, lnCant, CHR(0))
ENDFUNC
*========================

Luis María Guayán

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

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

*--------------------------------------------
FUNCTION _SystemDir
*--------------------------------------------
* Retorna el directorio SYSTEM de Windows
* sin "" al final ("C:WINNTSYSTEM32")
*--------------------------------------------
LOCAL lcPath, lnSize
lcPath = SPACE(255)
lnsize = 255
DECLARE INTEGER GetSystemDirectory IN Win32API ;
   STRING  @pszSysPath,;
   INTEGER cchSysPath
lnSize = GetSystemDirectory(@lcPath, lnSize)
IF lnSize <= 0
   lcPath = ""
ELSE
   lcPath =  SUBSTR(lcPath, 1, lnSize)
ENDIF
RETURN lcPath
ENDFUNC

Luis María Guayán

Escribir y leer un valor de un archivo INI

Podemos escribir y leer valores de un archivo .INI mediante la API de Windows.

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

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

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

Luis María Guayán

Saber si una aplicación ya está activa

Como saber si una aplicación ya está activa.

? _EstaActiva('Calculadora')

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

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

return FindWindow(0, tcCaption) EndFunc

Luis María Guayán

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

Función _Sleep de la API de Windows.

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

Luis María Guayán

Ejecutar un archivo .WAV desde VFP mediante API

Ejecutar un archivo .WAV desde VFP mediante API.

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

Luis María Guayán

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

Copiar un archivo mediante API.

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

Luis María Guayán

6 de marzo de 2000

Calcular el útimo día del mes

Rutina para calcular el útimo día del mes.

GOMONTH(CTOD("01/"+STR(MONTH(tdfecha),2)+"/"+STR(YEAR(tdfecha),4)),1)-1

Se puede implementar en una rutina de la siguiente manera:

FUNCTION ultiames
PARAMETERS tdfecha
LOCAL ldret
ldret = GOMONTH(CTOD("01/"+STR(MONTH(tdfecha),2)+"/"+STR(YEAR(tdfecha),4)),1)-1
RETURN ldret

Pablo Roca

Conocer el número de paginas totales de un informe

Como conocer el número de paginas totales de un informe

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

DEFINE WINDOW x FROM 1,1 TO 2,2
ACTIVATE WINDOW x NOSHOW
REPORT FORM (lc_report) NOCONSOLE
nPaginas = _PAGENO
RELEASE WINDOW x
RETURN npaginas

NOTA: gracias a Jose Luis Santana Blasco y a Rafael Angel Ponce Yllanes por la aclaración del NOCONSOLE, con esto se mejora mucho la velocidad.

Pablo Roca

Hacer un cursor de SELECT SQL modificable

Como hacer un cursor de SELECT SQL modificable.

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

Pablo Roca

1 de marzo de 2000

Pasar un importe de numero a letras

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


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

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

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

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

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

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

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

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

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

Suscribirse a: Comentarios ( Atom )

Menu

31 de marzo de 2000

23 de marzo de 2000

22 de marzo de 2000

21 de marzo de 2000

20 de marzo de 2000

19 de marzo de 2000

18 de marzo de 2000

14 de marzo de 2000

13 de marzo de 2000

10 de marzo de 2000

8 de marzo de 2000

7 de marzo de 2000

6 de marzo de 2000

1 de marzo de 2000