25 de febrero de 2002

Saber si existe una tabla o vista en una DBC

VFP tiene al menos dos funciones que podemos utilizar para saber si existe una tabla o vista en una DBC:

1. Con INDBC():
IF NOT DBUSE("MiDbc")
  OPEN DATABASE C:MiDbc
ENDIF
SET DATABASE MiDbc

*-- Saber si existe la tabla "MiTabla"
IF INDBC("MiTabla", "TABLE")
  MESSAGEBOX("Si existe la tabla")
ELSE
  MESSAGEBOX("No existe la tabla")
ENDIF

*-- Saber si existe la vista "MiVista"
IF INDBC("MiVista", "VIEW")
  MESSAGEBOX("Si existe la vista")
ELSE
  MESSAGEBOX("No existe la vista")
ENDIF
2. Con ADBOBJECTS():
IF NOT DBUSE("MiDbc")
  OPEN DATABASE C:MiDbc
ENDIF
SET DATABASE MiDbc

*-- Saber si existe la tabla "MiTabla"
ln = ADBOBJECTS(laArray, "TABLE")
IF ln > 0 AND 0 # ASCAN(laArray, UPPER("MiTabla"))
  MESSAGEBOX("Si existe la tabla")
ELSE
  MESSAGEBOX("No existe la tabla")
ENDIF

*-- Saber si existe la vista "MiVista"
ln = ADBOBJECTS(laArray, "VIEW")
IF ln > 0 AND 0 # ASCAN(laArray, UPPER("MiVista"))
  MESSAGEBOX("Si existe la vista")
ELSE
  MESSAGEBOX("No existe la vista")
ENDIF
Luis María Guayán

24 de febrero de 2002

Cantidad de días de un mes

Función para calcular la cantidad de días de un mes, pasando como parámetro una fecha correspondiente a dicho mes.

Ejemplo:
? DiasDelMes(DATE(2014,10,07))
? DiasDelMes(DATE())

*------------------------------------------------
* FUNCTION DiasDelMes(dFecha)
*------------------------------------------------
* Retorna los días de un mes.
*------------------------------------------------
FUNCTION DiasDelMes(dFecha)
  LOCAL ld
  ld = GOMONTH(dFecha,1)
  RETURN DAY(ld - DAY(ld))
ENDFUNC
*------------------------------------------------
Luis María Guayán

18 de febrero de 2002

Expandir un combo automáticamente

Un truco para expandir un combo automáticamente cuando este toma el foco.

En el método GotFocus del Combo poner el siguiente código:
KEYBOARD "{x41A0}"
Gracias a Carlos Yohn Zubiria por el truco.

Uso de la función ADIR()

Un ejemplo de la función ADIR()

*!* Ejemplificacion de la funcion ADIR()
*!* Ultima revisión: 20/09/2002
*!* Alberto Rodriguez - JARSoft - Argentina
*!* jarargentina@hotmail.com
*!* --------------------------------------------
*!* Uso de adir en el rastreo de archivos y directorios de un disco
*!* o carpeta (ej 4)
*!* Determinar la profundidad de los subdirectorios encontrados. (ej 2)
*!* --------------------------------------------
*!* --------------------------------------------
If Val(Left(Version(4),2)) < 7
 Messagebox("Escrito para la version 7.00 o superior. "+;
  "Analizar el codigo antes de correr.",16,"")
 Return
Endif

Set Talk Off
Set Escape On
Set Notify On
Close All
Clear All
Clear

Local cFontAntes
cFontAntes = _Screen.FontName
_Screen.FontName="FOXPRO WINDOWS FONT"
?

Private cDir

Wait Window Nowait ;
 'Seleccione un directorio (o unidad)'+Chr(13)+Chr(10)+;
 '(sugiero una unidad o un directorio que tenga varios '+;
 'subdirectorios y archivos .TXT...)'

cDir = Getenv('windir')
If !Directory(cDir)
 cDir = 'C:\Archivos de programa'
 If !Directory(cDir)
  cDir = Sys(5)+'\'
 Endif
Endif
cDir = Getdir(cDir)

If !Empty(cDir) And Directory(cDir)
 Wait Window Nowait "Buscando en: "+cDir+", espere..."
 ?"Buscando en: "+cDir

 *!* --------------------------------------------
 *- Ejemplo nro 1
 ListarDirectorios()
 ?
 Wait Wind

 *!* --------------------------------------------
 *- Ejemplo nro 2
 Wait Window Nowait Noclear "Buscando en: "+cDir+", espere..."
 ListarSubCarpetas(cDir)
 ?
 Wait 'SubCarpetas del directorio elegido (o unidad)'

 *!* --------------------------------------------
 *- ejemplo 3
 Wait Window Nowait Noclear 'Escriba un nombre de archivo a buscar...'
 cNombFileaBuscar = Inputbox("nombre del archivo a buscar", "", "readme.txt")
 If !Empty(cNombFileaBuscar)
  nnnn = BuscarArchivoExacto(cDir, cNombFileaBuscar, .F.)
  ?"Archivos encontrados: ", nnnn
  ?
 Else
  Return
 Endif
 Wait 'Archivo encontrado en...'

 *!* --------------------------------------------
 *- ejemplo 4
 cExtencionaB = Inputbox("Ingrese EXTENCION a buscar", "", "TXT")
 nnnn = BuscarExtenciondeArchivo(cDir, cExtencionaB)
 ?"Archivos encontrados: ", nnnn
 ?
 ?
 Wait "Fin del ejemplo, ..."
 ?
Endif

_Screen.FontName = cFontAntes
*- fin.



Procedure ListarDirectorios
 *- listar directorios del primer nivel un disco
 *- o  subdirectorios de una carpeta
 Local x, nSon, nListados
 nListados = 0
 Wait Window Nowait ;
  'Listar directorios del primer nivel de un disco o '+;
  'subdirectorios de una carpeta'
 nSon = Adir(aArchivos, cDir+"*.*", "D")
 If nSon > 0
  =Asort(aArchivos,1)
  For x=1 To nSon
   If !("D"$aArchivos[x,5]) Or ;
     aArchivos[x,1] == "." Or aArchivos[x,1] == ".."
    Loop
   Endif
   ?"Nombre: ", Lower(aArchivos[x,1])
   ??"  Tamaño:   ", aArchivos[x,2]
   ??"  Fecha:    ", aArchivos[x,3]
   ??"  Hora:     ", aArchivos[x,4]
   ??"  Atributo: ", aArchivos[x,5]
   nListados = nListados + 1
  Next
 Else
  *- Esta opcion no deberia ejecutarse nunca ya que siempre hay
  *- al menos dos . y .. aunque no haya archivos.
  ?"No hay Directorios en "+cDir
 Endif
 If nListados > 0
  ?nListados, 'directorios del primer nivel listados.'
  *- a partir de ahroa si se quiere acceder a la ruta completa
  *- de algún directorio no hay mas que sumar: addbs(cDir + '\' +aArchivos[n,1])
 Else
  ?"No hay Directorios en "+cDir
 Endif
 Release aArchivos
Endproc


Procedure ListarSubCarpetas
 Lparameters lpcDirectorio, lplNoMostrarResultados
 *- listar todos los niveles de subcarpetas
 *- si elijio el disco raiz listará todos los subdirectorios del disco con
 *- todos los subdirectorios contenidos en ellos.
 *- (o sea recorrerá el disco completo -esto puede llevar tiempo en un disco
 *- grande-)
 *- Este procedimiento requiere recursividad.
 Local x, nSon, nNivel

 nNivel = 0
 Dimension aTodaslasCarpertas[1,2]
 BuscarSubDir(lpcDirectorio, @aTodaslasCarpertas, @nNivel)
 nSon = Alen(aTodaslasCarpertas, 1)
 Wait Clear

 If !lplNoMostrarResultados
  *- Nota: Esto es un ejemplo, no es la mejor forma de scan de directorios
  *- en este ejemplo, primero se recorre y luego se muestra, dividiendo las
  *- tareas... Lento!! como compilador de dos pasadas... :))))
  *- Pero el objetivo es mostrar el uso de Adir.
  For x=2 To nSon
   ?"Nombre: ", Displaypath(aTodaslasCarpertas[x,1], 60)
   ??"   ,Nivel:    ", aTodaslasCarpertas[x,2]
   If x > 50
    ?
    ?'Bueno, listo, para muestra basta un boton..., hay ',nSon,' para listar.'
    Exit
   Endif
  Next
 Endif
Endproc


Procedure BuscarSubDir
 Parameters lpcDir, aResultDir, vnNivel
 *- procedimiento recursivo
 vnNivel = vnNivel + 1
 Local x, nSon
 Private aArchivos
 nSon = Adir(aArchivos, lpcDir+"*.*", "D")
 For x=1 To nSon
  If "D"$aArchivos[x,5]
   If aArchivos[x,1] == "." Or aArchivos[x,1] == ".."
    Loop
   Endif
   Dimension aResultDir[ALEN(aResultDir,1)+1,2]
   aResultDir[ALEN(aResultDir,1),1] = Addbs(lpcDir+aArchivos[x,1])
   aResultDir[ALEN(aResultDir,1),2] = vnNivel
   BuscarSubDir(Addbs(lpcDir+aArchivos[x,1]), @aResultDir, vnNivel)
  Endif
 Next
Endproc


Procedure BuscarArchivoExacto
 *- podemos usar estas funciones para buscar un archivo en disco.
 Lparameters lpcDir, lpcNombre, lplDetenerSiEncuentra
 *- lpcDir: carpeta o drive en donde buscar
 *- lpcNombre: nombre del archivo con su extencion si la tuviera
 *- lplDetenerSiEncuentra: buscar todos los archivos repetidos o el primero que encuentre.
 *- Esta funcion devuelve la cantidad de archivos encontrados. ...
 Local nSon, x, nEncontrados, Y, nArch

 Local omostrar
 omostrar = Createobject("MostrarResultados")
 If Type("omostrar") # "O"
  Messagebox("ups!",16,"")
  Cancel
 Endif
 omostrar.Show()

 nEncontrados = 0
 lpcNombre = Upper(Alltrim(lpcNombre))
 Dimension aTodaslasCarpertas[1,2]

 ListarSubCarpetas(lpcDir, .T.)
 *- este directorio
 aTodaslasCarpertas[1,1] = lpcDir
 aTodaslasCarpertas[1,2] = 0

 nSon = Alen(aTodaslasCarpertas, 1)

 *- buscar en los directorios
 For x=1 To nSon

  omostrar.label1.Caption = "Buscando ahora en: "+;
   DISPLAYPATH(aTodaslasCarpertas[x,1],60)+"..."

  nArch = Adir(aFiles, aTodaslasCarpertas[x,1]+"*.*", "AHRSD")
  For Y=1 To nArch
   If "D"$aFiles[y,5] Or aFiles[y,1] == "." Or aFiles[y,1] == ".."
    Loop
   Endif
   If Upper(aFiles[y,1]) == lpcNombre
    nEncontrados = nEncontrados + 1

    omostrar.list1.AddItem("Encontrado en: "+;
     Displaypath(aTodaslasCarpertas[x,1]+ aFiles[y,1], 60))

    If lplDetenerSiEncuentra
     Exit
    Endif
   Endif
  Next

  If nEncontrados > 0 And lplDetenerSiEncuentra
   Exit
  Endif
 Next
 Clear Typeahead
 Wait Clear
 Wait Wind
 Return nEncontrados
Endproc



Procedure BuscarExtenciondeArchivo
 *- podemos usar estas funciones para buscar un archivo en disco.
 *- buscar todos los archivos cuya extencion sea igual a ...
 Lparameters lpcDir, lpcExtencion
 *- lpcDir: carpeta o drive en donde buscar
 *- lpcExtencion: Extencion de archivo (sin el punto)
 *- Esta funcion devuelve la cantidad de archivos encontrados. ...
 Local nSon, x, nEncontrados, Y, nArch

 Local omostrar
 omostrar = Createobject("MostrarResultados")
 If Type("omostrar") # "O"
  Messagebox("ups!",16,"")
  Cancel
 Endif
 omostrar.Show()

 nEncontrados = 0
 lpcExtencion = Upper(Alltrim(lpcExtencion))
 Dimension aTodaslasCarpertas[1,2]

 Wait Window Nowait Noclear 'Espere...'
 ListarSubCarpetas(lpcDir, .T.)
 *- este directorio
 aTodaslasCarpertas[1,1] = lpcDir
 aTodaslasCarpertas[1,2] = 0

 nSon = Alen(aTodaslasCarpertas, 1)

 *- buscar en los directorios
 For x=1 To nSon

  omostrar.label1.Caption = "Buscando ahora en: "+;
   DISPLAYPATH(aTodaslasCarpertas[x,1],60)+"..."

  nArch = Adir(aFiles, aTodaslasCarpertas[x,1]+"*.*", "AHRSD")
  For Y=1 To nArch
   If "D"$aFiles[y,5] Or aFiles[y,1] == "." Or aFiles[y,1] == ".."
    Loop
   Endif
   If Upper(Justext(aFiles[y,1])) == lpcExtencion
    nEncontrados = nEncontrados + 1
    omostrar.list1.AddItem("Encontrado en: "+;
     DISPLAYPATH(aTodaslasCarpertas[x,1] + aFiles[y,1],60))
   Endif
  Next

 Next
 Wait Clear
 Clear Typeahead
 Wait Wind
 Return nEncontrados
Endproc


*- alguna interface sencilla para mostrar resultados
Define Class MostrarResultados As Form
 AutoCenter = .T.
 Width = 640
 Height = 380

 Add Object label1 As Label With ;
  AutoSize = .T., ;
  Left = 5, ;
  Top = 10, ;
  TabIndex = 1

 Add Object list1 As ListBox With ;
  Left = 5, ;
  Top = 30, ;
  width = 630, ;
  height = 300, ;
  ItemTips = .T.,;
  TabIndex = 2

Enddefine

Alberto Rodriguez

9 de febrero de 2002

Obtener IP, MAC address y GUID

Aquí les dejo las rutinas para obtener: las IP's, las direcciones MAC y obtener un Global Unique IDentifier.

Rutinas para obtener:
  • Las IPs (todas de todas las LAN) de una máquina.
  • Las direcciones MAC (de todas las LAN) de una máquina. (esta vez directamente desde VFP sin crear una FLL como publique anteriomente)
  • Obtener un Global Unique IDentifier
CLEAR
?
? 'Enjoy it, by Alexandre Hedreville'

?
? 'MAC Address'
? '-----------'
? MACAddress()

?
? 'IP Address'
? '-----------'
? IPAddress()

?
? 'GUID'
? '-----------'
? GetGuid()

*!* Windows Sockets
#DEFINE WS_VERSION_REQD        257
#DEFINE WS_VERSION_MAJOR    1
#DEFINE WS_VERSION_MINOR    1
#DEFINE MIN_SOCKETS_REQD    1
#DEFINE SOCKET_ERROR        -1
#DEFINE WSADESCRIPTION_LEN     256
#DEFINE WSASYS_STATUS_LEN     128

*!* Windows NetBIOS
#DEFINE NCBENUM                     55
#DEFINE NCBASTAT                    51
#DEFINE NCBNAMSZ                    16
#DEFINE HEAP_ZERO_MEMORY            8
#DEFINE HEAP_GENERATE_EXCEPTIONS    4
#DEFINE NCBRESET                    50

*!* Devuelve las direcciones MAC
*!* Sintaxis: MACAddress()
*!* Valor devuelto: lcRetVal
*!* lcRetVal viene expresado como una cadena con el formato: 00-04-76-A4-73-3A, 00-04-76-A4-72-13, ...
FUNCTION MACAddress
  LOCAL lcNBC, lcAdapter, lnAdapter, lcSource, lnSource, lcRetVal, lnLength, lnLEnum, lcLEnum
  *!* Instrucciones DECLARE DLL para manipular NetBIOS
  DECLARE INTEGER GetProcessHeap IN Win32API
  DECLARE INTEGER Netbios IN Netapi32.DLL STRING @lpNBC
  DECLARE INTEGER HeapFree IN Win32API INTEGER hHeap, INTEGER dwFlags, STRING @lpMem
  DECLARE INTEGER HeapAlloc IN Win32API INTEGER hHeap, INTEGER dwFlags, INTEGER dwBytes
  DECLARE INTEGER RtlMoveMemory IN Win32API STRING @lpDestination, INTEGER nSource, INTEGER nBytes
  *!* Valores
  lcRetVal  = ''
  lcNBC     = REPLICATE(CHR(0), 64)
  lcLEnum   = REPLICATE(CHR(0), 256)
  lcAdapter = REPLICATE(CHR(0), 600)
  *!* Reservar buffer memoria
  lnLEnum = HeapAlloc(GetProcessHeap(), BITOR(HEAP_GENERATE_EXCEPTIONS, HEAP_ZERO_MEMORY), 256)
  IF lnLEnum <> 0
    *!* Valores
    lcNBC = CHR(NCBENUM) + REPLICATE(CHR(0), 3) + LongToStr(lnLEnum) + ;
      IntToStr(256) + SUBSTR(lcNBC, 11, 544)
    *!* Enum LAN´s
    IF Netbios(@lcNBC) = 0
      *!* Leer buffer memoria
      lnSource = lnLEnum
      RtlMoveMemory(@lcLEnum, lnSource, 256)
      *!* Valores
      lnLength = ASC(SUBSTR(lcLEnum, 1, 1))
      *!* Examinar LAN`s
      FOR lnCnt = 1 TO lnLength
        *!* Valores
        lcAdapter = REPLICATE(CHR(0), 600)
        lcNBC     = CHR(NCBRESET) + REPLICATE(CHR(0), 47) +  ;
          SUBSTR(lcLEnum, lnCnt+1, 1) + REPLICATE(CHR(0), 15)
        *!* Reset LAN
        IF Netbios(@lcNBC) = 0
          *!* Reservar buffer memoria
          lnAdapter = HeapAlloc(GetProcessHeap(), ;
            BITOR(HEAP_GENERATE_EXCEPTIONS, HEAP_ZERO_MEMORY), 600)
          IF lnAdapter <> 0
            *!* Valores
            lcNBC = CHR(NCBASTAT) + REPLICATE(CHR(0), 3) + LongToStr(lnAdapter) + ;
              IntToStr(600) + '*               ' + REPLICATE(CHR(0), 22) + ;
              SUBSTR(lcLEnum, lnCnt+1, 1) + REPLICATE(CHR(0), 15)
            *!* Status LAN
            IF Netbios(@lcNBC)  = 0
              *!* Leer buffer memoria
              lnSource = lnAdapter
              RtlMoveMemory(@lcAdapter, lnSource, 600)
              *!* Componer cadena MAC con guiones y separar multiples MAC`s con comas
              lcRetVal = lcRetVal + RIGHT(DecToHex(ASC(SUBSTR(lcAdapter, 1, 1))), 2) + ;
                '-' + RIGHT(DecToHex(ASC(SUBSTR(lcAdapter, 2, 1))), 2) + ;
                '-' + RIGHT(DecToHex(ASC(SUBSTR(lcAdapter, 3, 1))), 2) + ;
                '-' + RIGHT(DecToHex(ASC(SUBSTR(lcAdapter, 4, 1))), 2) + ;
                '-' + RIGHT(DecToHex(ASC(SUBSTR(lcAdapter, 5, 1))), 2) + ;
                '-' + RIGHT(DecToHex(ASC(SUBSTR(lcAdapter, 6, 1))), 2) + ;
                IIF(lnCnt = lnLength, '', ',')
            ENDIF
            *!* Liberar buffer memoria
            lcSource = LongToStr(lnAdapter)
            HeapFree(GetProcessHeap(), 0, @lcSource)
          ENDIF
        ENDIF
      ENDFOR
    ENDIF
    *!* Liberar buffer memoria
    lcSource = LongToStr(lnLEnum)
    HeapFree(GetProcessHeap(), 0, @lcSource)
  ENDIF
  *!* Retorno
  RETURN lcRetVal
ENDFUNC

8 de febrero de 2002

Pasar de hexadecimal a decimal

Una forma fácil de pasar números del sistema hexadecimal al sistema decimal y viceversa.

A partir de VFP 6 podemos pasar un número hexadecimal a decimal de una forma directa. Por ejemplo queremos convertir el número hexadecimal "FFFF" al sistema decimal:

? 0xFFFF

De la misma manera podemos pasar un número decimal al sistema hexadecimal utilizando la función TRANSFORM()

lnDec = 123
? TRANSFORM(lnDec,"@0")

A partir de esto, creamos las correspondientes funciones definidas por el usuario, que nos permiten la conversión de números de un sistema a otro:
*--------------------------------------------
FUNCTION Hex2Dec(tcHex)
  RETURN EVALUATE("0x"+ALLTRIM(tcHex))
ENDFUNC
*--------------------------------------------
FUNCTION Dec2Hex(tnDec)
  RETURN SUBSTR(TRANSFORM(tnDec,"@0"),3)
ENDFUNC
*--------------------------------------------

Luis María Guayán

Ventana sin caption

Es sencillo pero se pregunta muchas veces, aquí teneis como lo hace Carlos Yohn Zubiria ... En las propiedades del formulario, hay que poner:
caption = ""
controlbox = .F.
maxbutton = .F.
minbutton = .F.
movable = .F.

Pablo Roca

7 de febrero de 2002

Extraer la parte numérica de una cadena

Rutina para extraer la parte numérica de una cadena de caracteres.

Extraer la parte numérica, es decir solo devolver los dígitos numéricos del [0]..[9], sin letras ni simbolos especiales.

Ejemplo:

? ExtraerNumeros("AA45BB111C%")

*-------------------------------------
* FUNCTION ExtraerNumeros(tcCadena)
*-------------------------------------
* Extraer la parte numerica de una cadena
* RETORNA: Caracter
* USO: ? ExtraerNumeros("A125FC023")
*-------------------------------------
FUNCTION ExtraerNumeros(tcCadena)
 RETURN CHRTRAN(tcCadena,CHRTRAN(tcCadena,"1234567890",""),"")
ENDFUNC
*-------------------------------------
Luis María Guayán