Calcular fechas festivas

En muchos países existen fechas festivas como el "Día del Padre" que se celebra el "3° Domingo de Junio". La pregunta es ¿Qué fecha es exactamente el 3° Domingo de Junio?

Con esta función podemos saber que fecha es el 3° Domingo de Junio de 2003, o también por ejemplo saber que fecha es el 1° Viernes de Diciembre de 2005

FechaFestiva
Retorna la fecha de los días festivos del tipo "3° Domingo de Junio" ó "1° Viernes de Diciembre"

SINTAXIS:
FechaFestiva(tnOrdinal,tnDiaSem,tnMes,tnAnio)

PARAMETROS:
tnOrdinal: El ordinal que se busca (1°, 2°, 3°, ...)
tnDiaSem: El día de la semana (1=Dom, 2=Lun, ..., 7=Sáb)
tnMes: El número del mes (1=Ene, 2=Feb, ..., 12=Dic)
tnAnio: El año que se busca

RETORNA:
Fecha (DATE)

USO:

*-- 3° Domingo de Junio de 2003
? FechaFestiva(3,1,6,2003)

*-- 1° Viernes de Diciembre de 2005
? FechaFestiva(1,6,12,2005)

LA FUNCION:

FUNCTION FechaFestiva(tnOrdinal,tnDiaSem,tnMes,tnAnio)
   RETURN DATE(tnAnio,tnMes,1)+tnOrdinal*7- ;
      DOW(DATE(tnAnio,tnMes,1)+tnOrdinal*7-1,tnDiaSem)
ENDFUNC

Nota: Gracias a Ricardo Passians que publicó la fórmula en el Grupo de Noticias de Visual FoxPro en Español.

Luis María Guayán

Conocer la versión de MS-SQLServer 2000 desde VFP

No sabes que Versión de MS-SQLServer está ejecutandose?, deseas saber que Service Pack está instalado? aqui te decimos cómo saberlo.

Ha habido y considero seguirá habiendo una serie de virus que se aprovechan de las vulnerabilidades de este software de Microsoft, el último virus fue corregido por el SP3, tambien a veces algunas mejoras en el producto son introducidos (y quizás removidos) en diferentes versiones y service Packs, así que a veces es necesiario saber a que versión de SQLServer se está conectado para saber de la misma manera cuál fué su ultimo Service Pack instalado.

lcServerName = "MiServidor"
lnHandle =SQLStringConnect([server=]+lcServerName+[;driver={SQL Server};Trusted_Connection=Yes])
IF lnHandle > 0

lcQueryVersion=[SELECT 'SQL Server ' ]+;
                              [+ CAST(SERVERPROPERTY('productversion') AS VARCHAR) + ' - ' ]+;
                              [+ CAST(SERVERPROPERTY('productlevel') AS VARCHAR) + ' ('  ]+;
                              [+ CAST(SERVERPROPERTY('edition') AS VARCHAR) + ')']

   IF SQLEXEC(lnHandle,lcQueryVersion,"cRes") > 0
       Brow
   ELSE
       IF AERROR(laError) > 0
           Messagebox("No se pudo ejecutar la consulta"+chr(13)+;
                                "Causa:"+laError[2],16,"Error Msg")
       ENDIF
   ENDIF
   SQLDISCONNECT(lnHandle)
ELSE
   IF AERROR(laError) > 0
       Messagebox("No se pudo ejecutar la consulta"+chr(13)+;
                            "Causa:"+laError[2],16,"Error Msg")
   ENDIF
ENDIF

Las difentes cadenas resultantes pueden ser algunas de las siguientes :

Producto	Versión
RTM (Ready To Manufacture)	2000.80.194
SQL Server 2000 SP1	2000.80.384
SQL Server 2000 SP2	2000.80.534
SQL Server 2000 SP3	2000.80.760
SQL Server 2000 SP4	2000.80.2039

Mas información al respecto:

HOW TO: Identify Your SQL Server Service Pack Version and Edition

How do I know which version of SQL Server I'm running?

Espero les sea de utilidad.

Espartaco Palma Martínez

Conocer si la unidad existe

Siguiendo con los filesystem, muchas veces hemos querido saber si alguna unidad existe o no.

La rutina que a continuación les presento nos da la facilidad de saber si es que nuestra unidad existe, pasando como argumento la unidad como una sola letra o como prompt:

Ejemplos:

? "El drive especificado " + IIF(DriverExist('c'), "", "no") + " existe."
? "La ruta especificada " + IIF(DriverExist('c:'), "", "no") + " existe."

Function DriverExist(lcDriveOrPathExist)
 Local Result as logic

 loFSO = CREATEOBJECT('Scripting.FileSystemObject')
 Result=loFSO.DriveExists(lcDriveOrPathExist)
 RELEASE loFSO
 Return Result

Endfunc

Ramón Rodríguez Martínez

Obtener Estadisticas de los paquetes ICMP

Este es un ejemplo de como podemos obtener por medio de apis estadistica de los paquetes icmp enviados y recibidos en la maquina.

Public oFrm
oFrm=Newobject("ICMP_Data")
oFrm.Show
Return

Define Class ICMP_Data As Form
 Height = 280
 Width = 500
 Desktop = .T.
 DoCreate = .T.
 AutoCenter = .T.
 BorderStyle = 0
 Caption = "Estadisticas ICMP"
 ControlBox = .T.
 Closable = .T.
 MaxButton = .F.
 MinButton = .F.
 ClipControls = .F.
 AlwaysOnTop = .F.
 BackColor = Rgb(203,230,241)
 Name = "ICMP_Data"

 Add Object lst_datos As ListBox With ;
  ColumnCount = 3, ;
  ColumnWidths = "250,100,100", ;
  Height = 271, ;
  Left = 6, ;
  Sorted = .F., ;
  Top = 2, ;
  Width = 483, ;
  DisabledItemBackColor = Rgb(102,130,200), ;
  DisabledItemForeColor = Rgb(255,255,0), ;
  DisabledForeColor = Rgb(255,0,0), ;
  Name = "lst_datos"
 Add Object timer1 As Timer With ;
  Top = 36, ;
  Left = 408, ;
  Height = 23, ;
  Width = 23, ;
  Interval = 560, ;
  Name = "Timer1"

 Procedure Estadisticas()
  Local ICMP, nCiclo
  ICMP = Space((13*4*2)+1)
  If GetIcmpStatistics(@ICMP) = 0
   With Thisform.lst_datos
    For nCiclo = 1 To 13
     .AddListItem(Alltrim(Str(.Parent.nRepStruct(ICMP,nCiclo))),nCiclo+1,2)
     .AddListItem(Alltrim(Str(.Parent.nRepStruct(ICMP,nCiclo+13))),nCiclo+1,3)
    Endfor
   Endwith
  Else
   Wait Window "Error al Obtener las Estadisticas"
  Endif
 Endproc

 Procedure nRepStruct
  Lparameters cEstructura, nValor
  Local cCadena, nEmp
  nEmp=((nValor-1)*4)+1
  cCadena = Substr(cEstructura,nEmp,4)
  Return  (Asc(Substr(cCadena, 1,1)) +;
   BitLShift(Asc(Substr(cCadena, 2,1)),  8)+;
   BitLShift(Asc(Substr(cCadena, 3,1)), 16)+;
   BitLShift(Asc(Substr(cCadena, 4,1)), 24))
 Endproc

 Procedure Load
  Declare Long GetIcmpStatistics In "iphlpapi" String @cEstructura
 Endproc

 Procedure lst_datos.Init
  With This
   .Clear()
   .AddListItem('Parametros',1,1)
   .AddListItem('Recibidos',1,2)
   .AddListItem('Enviados',1,3)
   .AddListItem('Mensajes',2,1)
   .AddListItem('Errores',3,1)
   .AddListItem('Destino inaccesible',4,1)
   .AddListItem('Tiempo agotado',5,1)
   .AddListItem('Problema de Parametros',6,1)
   .AddListItem('Paquetes de control de flujo',7,1)
   .AddListItem('Redirecciones',8,1)
   .AddListItem('Echos',9,1)
   .AddListItem('Respuestas de Eco',10,1)
   .AddListItem('Fechas',11,1)
   .AddListItem('Respuestas de fecha',12,1)
   .AddListItem('Máscaras de direcciones',13,1)
   .AddListItem('Máscaras de direcciones respondidas',14,1)
  Endwith
  Thisform.Estadisticas()
 Endproc

 Procedure timer1.Timer
  Thisform.Estadisticas()
 Endproc
Enddefine

Saludos

Jorge Mota, Guatemala

Partir un archivo en piezas más pequeñas

Partir un archivo en n bytes con fox. Esto es parte de utilidades de backups. (Les envio el programa para volver a unir las piezas en la proxima noticia)

*- JARSoft Argentina
*- Prog. Alberto Rodiriguez - jarargentina@hotmail.com
*- Ultima modificacion: Abr. 2003
*-
*- Partir el archivo en piezas de n bytes
*- ADVERTENCIA.!! todos los archivos de extencion nnn de tcDestino se eliminan.!!
*- Parámetros:
Lparameters tcArchivo, tnBytes, tcDestino
*- Devuelve el nro de pedazos en que se partio el archivo o cero
*- si no se pudo completar la operacion o -1 si hubo algun error.

*- Ej. de uso:
*- nPedazos = partirarchivo_01('c:tmpRespaldos.zip', 1457664, 'c:tmp')
*- Este ejemplo divide respaldos.zip en 1.40 Mg para que las partes quepan en
*- disquetes y las pone en c:tmp

If PCOUNT() # 3 Or Vartype(tcArchivo) # 'C' Or Vartype(tnBytes) # 'N' Or ;
  tnBytes < 1 Or Vartype(tcDestino) # 'C' Or !Directory(tcDestino)
 Messagebox('Error de llamada.',16,'')
 Return -1
Endif

If Val(Left(Version(4),2)) < 7
 Messagebox('Debe modificar (y verificar) este programa para que corra en esta '+;
  'version',16,'Version no soportada')
 Return -1
Endif

tcDestino = Lower(Addbs(tcDestino))

Local x, nDevolver, nTamanio, nBytesEscritos, nMan, nManParte, nNroDisco As Integer
Local cAux, cCadenaleida, cAntesSafe, cFlog As String
Local lOk As Boolean

*--------------------------------------------------------------------------
*- como el programa parte en extenciones de 00n no se permiten partir
*- archivos con estas extenciones.
cAux = Justext(tcArchivo)
If Len(cAux) = 3  && si es # 3 no hay problema, pueden convivir.
 For x = 1 To Len(cAux)
  If !Isdigit(Substr(cAux, x, 1))
   lOk = .T.
   Exit
  Endif
 NEXT
ELSE
 lOk = .T.
Endif
*- continuar si la extencion no tiene solo numeros.
If !lOk
 Messagebox('No se permiten partir archivos con extenciones iguales a las '+;
  'que se usará en las partes.',16,'Excepción')
 Return -1
Endif
*--------------------------------------------------------------------------

cFlog = Sys(3)+'.log'

cAntesSafe = Set("Safety")
nDevolver = 0
If !File(tcArchivo)
 Messagebox(tcArchivo+' no existe.',16,'No existe el archivo')
 Return -1
Endif
tcArchivo = Lower(Locfile(tcArchivo))
*- verificar que el tamaño sea mayor que tnBytes
If Adir(aInfoFilePartir1, tcArchivo)#1
 Return -1
Endif
nTamanio = aInfoFilePartir1[1,2]  && tamaño total del archivo a partir
If nTamanio <= tnBytes
 Messagebox('No se puede partir en menos de 2 partes',16,'Parámetros incorrectos')
 Return -1
Endif

Set Safety Off
If !Empty(Sys(2000, tcDestino + Juststem(tcArchivo)+'.*'))
 *- hay que consultar asi y no erase dir*.*, porque el archivo original
 *- (de igual nombre y con otra extencion podria encontrarse en el mismo
 *- directorio destino)
 For x=0 To 999
  cAux = tcDestino + Juststem(tcArchivo)+'.'+Transform(x,@L 999')
  If File(cAux)
   Erase (cAux) recycle
  Endif
 Next
Endif

*- partir el archivo original:
nNroDisco = 1
nMan = Fopen(tcArchivo)
If nMan < 0
 Messagebox('No se puede abrir '+tcArchivo,16,'Operación cancelada')
 Return -1
Endif

Do While nTamanio > 0
 If nNroDisco > 999
  nDevolver = -1
  Messagebox('Demasiados archivos',16,'')
  Exit
 Endif

 cFileDestino = tcDestino + ;
  Forceext(Justfname(tcArchivo), Transform(nNroDisco, @L 999'))
 nManParte = Fcreate(cFileDestino)
 If nManParte < 0
  nDevolver = -1
  Messagebox('No se puede crear '+cFileDestino,16,'Operación cancelada')
  Exit
 Endif

 nEspacio = tnBytes
 Do While nEspacio > 0 And nTamanio > 0
  cCadenaleida = Fread(nMan, Min(10240, nEspacio))
  nBytesEscritos = Fwrite(nManParte, cCadenaleida) && escribir lo real leido
  If nBytesEscritos = 0
   nDevolver = -1
   Messagebox('No se puede escribir',16,'Operación cancelada')
   Exit
  Endif

  nEspacio = nEspacio - nBytesEscritos
  nTamanio = nTamanio - nBytesEscritos
 Enddo

 Fclose(nManParte)
 nDevolver = nNroDisco
 If nTamanio <= 0
  Exit
 Endif
 nNroDisco = nNroDisco + 1
Enddo
Fclose(nMan)
*- fin partir

Release aInfoFilePartir1
Set Safety &cAntesSafe

Return nDevolver
*- Par volver a unir las partes en el archivo original,
*- usar: unirarchivo_01.prg
*- JARSoft Argentina

Alberto Rodriguez

Aplicaciones MultiIdioma en VFP

En repetidas ocasiones, he comprobado que la realización de aplicaciones que puedan ejecutarse en diferentes idiomas ha sido uno de los puntos en los que más desarrolladores han expresado sus dudas.

En este artículo pretendo explicar una forma sencilla, pero que a su vez resulta muy potente para realizar aplicaciones Multi-Lenguaje en Visual Fox Pro.

La base de este desarrollo, será la creación de una tabla en donde se almacenen todos los textos que se mostrarán posteriormente en pantalla. Su formato será el siguiente:

ETIQUETAS Idioma01 C(200) Idioma02 C(200) (ambos campos con índice)

Como podemos imaginar, debemos de crear un campo por cada uno de los lenguajes a utilizar en nuestra aplicación.

Luego, simplemente añadiremos en esta tabla los textos que se correspondan a los distintos idiomas.

Ejemplo: Idioma01 Idioma02
Hola Hello

Para utilizarlo correctamente, debemos de cargar en el inicio de nuestra aplicación, una variable que indicará cual es el idioma activo (por ejemplo leyéndolo desde un fichero de configuración) y seleccionar el índice correcto.

Posteriormente, en nuestra clase base de aquellos controles que muestren texto, debemos de realizar algo parecido a lo siguiente:

Ejemplo para una label:

1) Creamos una variable global G_Idioma == "01".
2) Creamos una clase labelbase.
3) En el evento INIT, incluimos el siguiente código:

With This
   If !Empty(.Caption)
      This.Caption = Traducir(.Caption)
   endiF
Endwith

4) Creamos la funcion Traducir

Function Traducir
   Lparameters pTexto
   Local cTexto, cCampo

   cTexto = PADR(Alltrim(pTexto), 200)
   cCampo = "Idioma" + G_Idioma

   If SeeK(cTexto, "Etiquetas", cCampo)
      cTraducido = Alltrim(Eval("Etiquetas." + cCampo))
          Else 
              Append Blank In Etiquetas
  Replace I01 With pTexto In Etiquetas

  cTraducido = pTexto
   EndIf
Return cTraducido

Con la función Traducir podemos realizar la traducción de absolutamente todos los textos de la aplicación. Por supuesto, hay determinadas condiciones para que esto funcione: que la longitud del texto no supere el tamaño del campo, que tengamos un idioma de referencia (en el ejemplo es 01), etc.

Angel Casas

eBook Gratuito: SQL: A Practical Introduction

Libro que no debe faltar dentro de la biblioteca de desarrolladores de VFP, ademas... Gratuito.

CONTENIDO Capitulo 1: Introduccion Capitulo 2: Una guia hacia SQL Capitulo 3: Creando y manejando Tablas Capitulo 4: Consultando Tablas SQL. Capitulo 5: Agregando y Actualizando Tablas Capitulo 6: Integridad de Datos Capitulo 7: Vistas Capitulo 8: Seguridad de Base de Datos Capitulo 9: Procesando Transacciones Capitulo 10: Catalogos del Sistema de Base de Datos Capitulo 11: Usando SQL con un el lenguaje del anfitrion Apendice A: Tipos de datos estándares de ANSI/ISO Apendice B: Base de Datos de Ejemplo

Este libro es excelente, trata desde los principios básicos del Lenguaje de Consultas Estructurado (Structured Query Language -SQL-), además revisa de forma adecuada las diferentes partes que abarca SQL como lo son el DML (Lenguaje de Manipulacion de Datos, Data Manipulation Language), DDL (Lenguage de Definición de Datos, Data Definition Language), seguridad, transacciones, catálogos de sistemas y un largo etcétera.

En esta edición no se revisa un manejador de base de datos específico, pues trata el SQL como un nivel más general, el cual podría ser implementado por cualquier DBMS. Está ampliamente recomendado para su lectura.

Para descargarlo pueden hacerlo desde esta dirección:

http://www.managedtime.com/freesqlbook.php3

Deberás antes llenar un pequeño formulario en el darás tu correo electrónico válido, esto es importante ya que la descarga es un .ZIP que viene con una contraseña, y se te mandará un correo electrónico indicandote la clave con la cual podrás descomprimirlo correctamente.

Espero lo disfruten...

Espartaco Palma Martínez

Listar Las Dlls Cargadas por Nuestro Programa

Este codigo nos permitira mostrar las dll's que han sido cargadas por nuestro programa, ya sea directa o indirectamente, por ejemplo si declaramos una funcion contenida en una Dll esta dll sera cargada por nuestro programa

Public oForm
oForm=Newobject("Lst_Dep")
oForm.Show
Return

Define Class Lst_Dep As Form
 Autocenter = .t.
 Height = 204
 Width = 702
 DoCreate = .T.
 Caption = "Dependecias"
 Name = "Frm_Lst_Dep"

 Add Object command1 As CommandButton With ;
  Top = 173, ;
  Left = 554, ;
  Height = 27, ;
  Width = 144, ;
  Caption = "Listar Dependencias", ;
  Name = "Command1"
 Add Object list1 As ListBox With ;
  ColumnCount = 2, ;
  ColumnWidths = "120,510", ;
  RowSourceType = 1, ;
  RowSource = "", ;
  FirstElement = 1, ;
  Height = 169, ;
  Left = 0, ;
  NumberOfElements = 0, ;
  Top = 1, ;
  Width = 696, ;
  Name = "List1"

 Procedure num2dword
  Lparameter tnNum
  Local c0,c1,c2,c3
  lcresult = Chr(0)+Chr(0)+Chr(0)+Chr(0)
  If tnNum < (2^31 - 1) then
   c3 = Chr(Int(tnNum/(256^3)))
   tnNum = Mod(tnNum,256^3)
   c2 = Chr(Int(tnNum/(256^2)))
   tnNum = Mod(tnNum,256^2)
   c1 = Chr(Int(tnNum/256))
   c0 = Chr(Mod(tnNum,256))
   lcresult = c0+c1+c2+c3
  Endif
  Return lcresult
 Endproc
 Procedure Load
  Declare Long GetCurrentProcessId In "kernel32"
  Declare Long CreateToolhelp32Snapshot In "kernel32" Long lFlags, Long lProcessID
  Declare Long Module32First In "kernel32" Long hSnapshot, String @cProc
  Declare Long Module32Next In "kernel32" Long hSnapshot, String @cProc
 Endproc
 Procedure command1.Click
  Local cProc As String, nLogico As Long, cCadena As String
  cProc =Space(549)
  lProcessID = GetCurrentProcessId()
  hSnapshot = CreateToolhelp32Snapshot(8, 0)
  With Thisform
   .LockScreen = .t. 
   .list1.Clear()
   cProc = .num2dword(548)+.num2dword(0)+.num2dword(0)+;
    +.num2dword(0)+.num2dword(0)+.num2dword(0)+.num2dword(0)+;
    +.num2dword(0)+Space(256)+Space(260)
   nLogico = Module32First(hSnapshot, @cProc)
   cCadena =Space(255)
   nCiclo =0
   Do While nLogico <>0
    nCiclo = nCiclo +1
    cCadena=Substr(cProc,33,255)
    .list1.AddListItem(Substr(cCadena,1,At(Chr(0),cCadena)-1),nCiclo,1)
    cCadena=Substr(cProc,290,259)
    .list1.AddListItem(Substr(cCadena,1,At(Chr(0),cCadena)-1),nCiclo,2)
    nLogico = Module32Next(hSnapshot, @cProc)
   Enddo
   .Caption = "Total Encontrados: " +Alltrim(Str(nCiclo))
   .LockScreen = .F. 
  Endwith
 Endproc
Enddefine

Saludos

Jorge Mota, Guatemala