Convertir números Reales a Binarios

Algunas veces es necesario convertir números de punto flotante a binario, estas funciones que les presento me resulven este problema y las pongo a disposición de la comunidad para quien las pueda necesitar.

****************************************
*-- Conversión de números reales a binario
*-- Autor: Lic. Ramón Rodríguez Martínez
*-- País de procedencia México
*-- Forma de uso: X=FloatToBinary(nReal)
*-- Ejemplo: X=FloatToBinary(13.6876)
*-- Datestamp:17/12/2002
*-- Comentario:
*-- Los valores reprentativos son
*-- R(10Em)+R(10Em-1)+R(10Em-2)+..+R(10E0)+.+D(10E-1)+D(10E-2)..+D(10E-M)
*****************************************

CLEAR

?FloatToBinary(13.6875)

FUNCTION FloatToBinary(nValue)
  LOCAL pEntera, pDecimal
  *-- Tomamos primero la parte entera de la cantidad
  pEntera=INT(nValue)
  *-- Tomamos por separado la parte decimal
  pDecimal=ALLT(STR(nValue-pEntera,20,10)) &&margen de decimal
  *-- Y lo convierto a entero
  pDecimal=VAL(SUBSTR(pDecimal,AT('.',pDecimal)+1))
  *-- Finalmente regreso la cadena convertida a binario
  RETURN DecBin(pEntera)+"."+DecBinf(pDecimal)
ENDFUNC


FUNCTION DecBin(nDecimal)
  *------------------------------------------------
  * Transforma un número decimal a binario
  * 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

FUNCTION DecBinF(nDecimal)
  *------------------------------------------------
  * Transforma un número decimal a binario
  * RETORNA: Caracter
  *------------------------------------------------
  LOCAL lcBinario, Res
  lcBinario = ''
  lcDecimal=ALLT(STR(nDecimal))
  DO WHILE VAL(lcDecimal)>0
    Res=VAL('0.'+lcdecimal)*2
    lcBinario=LcBinario+ALLT(STR(INT(Res)))
    lcDecimal=ALLT(STR(Res,20,10))
    lcDecimal=SUBSTR(lcDecimal,AT('.',lcdecimal)+1)
    *-- protegemos para cuando los valores se repiten
    *-- y de esta manera evitar un ciclo infinito
    *-- en estos casos se toman exclusivamente los primero 4 bits
    IF (VAL(lcDecimal)=ndecimal) Then
      EXIT
    ENDIF
  ENDDO
  RETURN lcBinario
ENDFUNC

Saludos

 Ramón Rodríguez Martínez

Validar CIF (Código de Identificacion Fiscal) [Solo España]

Función para validar CIF (Código de Identificación Fiscal)

? ValCif("01234567D")

*----------------------------------------------------------------------
* Jose Maria Arrabal Alcañiz
* Funcion para validar CIF (Código de Identificacion Fiscal)
* Entrada: Cadena
* Salida : Cadena con CIF calculado
*----------------------------------------------------------------------
FUNCTION ValCIF
  PARAMETER cdni
  PRIVATE A
  LOCAL impar,par,simpar,SPAR
  A = UPPER(ALLTRIM(CHRTRAN(cdni,",.-","")))
  IF LEN(A) # 9
    WAIT WINDOW "Error en la longitud del CIF" TIME 3
    RETURN ""
  ENDIF
  cNumero = SUBSTR(A,2,7)
  IF PADL(VAL(cNumero),7,"0") # cNumero
    WAIT WINDOW "Error en la contrucción del CIF" TIME 3
    RETURN
  ENDIF
  cLetra = LEFT(A,1)
  *
  * Sumar cifras pares y las impares las multiplicamos por 2
  *
  SPAR = 0
  simpar = 0
  par = 0
  impar = 0
  FOR nI = 1 TO 7 STEP 2
    impar = VAL(SUBSTR(cNumero,nI,1))*2
    impar = INT(impar/10) + impar%10
    par = VAL(SUBSTR(cNumero,nI+1,1))
    simpar = simpar+impar
    SPAR = SPAR+par
  NEXT
  R = 10-(SPAR+simpar)%10
  cCif = cLetra+cNumero
  IF cLetra $ "ABCDEFGH"
    cCif = cCif+CHR(ASC('0')+R)
  ELSE
    cCif = cCif+SUBSTR("JABCDEFGHI",R+1,1)
  ENDIF
  IF A # cCif
    MESSAGEBOX("El CIF "+A+" introducido es incorrecto "+CHR(13)+;
      "El correcto sería "+cCif+CHR(13)+;
      "Compruebe que los datos son correctos",16)
  ENDIF
  RETURN cCif
ENDFUNC

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

Jose Maria Arrabal Alcañiz

Obtener Fecha y Hora del Servidor

Si desea saber la hora del servidor sin importar el sistema operativo que use, aquí tenemos, basándonos en las recomendaciones de Alex Feldstein (MS MVP), una función para obtener la fecha y hora del servidor (tipo DateTime) que funcionará si usa Novell Netware, Microsoft Windows (cualquier versión), incluso Linux (si activa el demonio SAMBA).

Lo único que se necesita es tener derechos de escritura en la carpeta, folder o recurso compartido del servidor.
ltFecha = ServerTime("F:/")
Pasandole de Parametro un recurso compartido:

ltFecha = ServerTime("//SERVIDOR/VALUACION")

Si no se pasan parametros, tomara por default la fecha del equipo donde se ejecute el programa:

ltFecha = ServerTime()

Espero que les sea de utilidad.

Espartaco Palma Martínez

******************************************************************
* ---- Server DateTime ----- Fecha y Hora del Servidor
* ---- Espartaco Palma Martinez esparta@NO_SPAMsofthome.net
* ---- FUNCTION: ServerTime   
* ---- RETURNS: Server DateTime, NULL if cannot get DateTime
* ---- RETORNA: Fecha y Hora Server, NULL si no puede obtenerlo 
* ---- PARAMETERS: tcPath - TYPE: Character 
* ---- Basandose en las recomendaciones de Alex Feldstein (MS MVP)
* ---- sobre como obtener la fecha y hora del servidor.
* ---- DATE: 03/DIC/2002 For Use in Visual FoxPro.
* ---- Sample:
* ---- ltFecha = FechaHora("F:/")
* ---- ltFecha = FechaHora("//SERVER/VALUACION/")
* ---- NOTE: If you are using minor versions of VFP7, use FoxTools
* ---- NOTA: Si esta usando versiones menores a VFP7, use FoxTools
******************************************************************
FUNCTION ServerTime (tcPath)
LOCAL ltFileTime
tcPath = IIF(TYPE('tcPath') # 'C', SPACE(0),ADDBS(tcPath))
lcFile = tcPath+SUBSTR(SYS(2015), 4) +".tmp"
IF STRTOFILE("Getting Hour/Obteniendo la Hora",lcFile) > 0
   ltFileTime = FDATE(lcFile,1)
   ERASE (lcFile)
   RETURN ltFileTime
ENDIF 
RETURN NULL
******************************************************************

Formulario Triangular

Muchos de nosotros estamos cansados de los tipicos formularios rectangulares, ahora podemos hacer un formulario triangular de una manera simple ...

Coloca un formulario y escribe en el INIT:

#DEFINE C_ALTERNATE 1
#DEFINE C_WINDING 2

declare integer CreatePolygonRgn in gdi32 ;
   string@ ppoints, integer npoints, integer nfillmode
declare integer SetWindowRgn in user32 ;
   integer hWnd, integer hRgn , integer bRedraw

cPoints = num2dword(0)+num2dword(0);
   +num2dword(THIS.Width+(sysmetric(13)*1));
   +num2dword(THIS.Height+sysmetric(9)+(sysmetric(12)*2));
   +num2dword(0)+num2dword(THIS.Height+sysmetric(9)+(sysmetric(12)*2))

set library to foxtools.fll

lnw = _WFindTitl(THIS.Caption)
lnh = _WhToHWnd(lnw)
lnr = CreatePolygonRgn(@cPoints, 3, C_WINDING)

SetWindowRgn(lnh, lnr, 1)
return

Luego, crea un .PRG llamado num2dword y coloca lo siguiente:

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
else
   * no es un numero valido para DWORD
endif
return lcresult

Mauricio Henao Romero

Impedir el cambio de dimension de una columna en un grid

Es muy fácil impedir la re-dimension de una columna de un grid, solo basta con:

THISFORM.Grid1.SetAll("Resizable", .F., "Column")

Mauricio Henao Romero