Por Saiyine  el 2001-01-01 00:00:00 - Secciones:  DELPHI  - Enlace permanente: 432

procedure LineaMas(fichero,cadena : string);
var
f : textfile;
begin
assignfile(f,fichero);
if fileexists(fichero) then append(f) else rewrite(f) ;
writeln(f,cadena);
closefile(f);
end;

Facil ¿eh? Para llamarlo en tu programa podrias hacer algo por ejemplo:

...
LineaMas('estado del programa.log','Leyendo del CD rom');
...

Atencion, si el fichero no existe lo crea con esa linea, y si existe, añade la linea al final. Esto se debe a que si intentas añadir al final de un fichero que no existe, el programa da error.

Emmanuel BOUGEARD(03/04/2004, 15:41) if fileexists(fichero) then append(f) else rewrite(f) ; cuando hay un fichero, 'append', no lo contrario!

Saiyine(04/04/2004, 04:17) Mil disculpas, lo corrijo ahora mismo.

Por Saiyine  el 2001-01-01 00:00:00 - Secciones:  DELPHI  - Enlace permanente: 433

RichEdit1.Lines.Add('Una linea mas...');
RichEdit1.Perform( EM_SCROLL, SB_LINEDOWN, 0);

Creo que tambien sirve para memos y webbrowser, pero no lo he probado... Los otros comandos disponibles son:

SB_LINEDOWN
SB_LINEUP
SB_PAGEDOWN
SB_PAGEUP

Por Saiyine  el 2001-01-01 00:00:00 - Secciones:  DELPHI  - Enlace permanente: 435

function TraemeLineaConCadena(fichero,cadena : string; casesensitive : boolean) : string;
var
  fi : textfile;
  cad : string;
  hecho : boolean;
begin
  hecho:=false;
  assignfile(fi,fichero);
  reset(fi);
  if not casesensitive then cadena:=uppercase(cadena);
  while (not eof(fi)) and (not hecho) do
    begin
      readln(fi,cad);
      if not casesensitive then
        begin
          if pos(cadena,ucase(cad))>0 then
            begin
              result:=cad;
              hecho:=true;
            end;
        end
      else
      if pos(cadena,cad)>0 then
        begin
          result:=cad;
          hecho:=true;
        end;
    end;
  closefile(fi);
end;

Util pero mejorable claramente devolviendo una lista de cadenas que incluyan el texto... si a alguien le interesa, que lo diga y lo pongo.

GPSFOREVER (12/06/2005, 04:55) amigo cuado corro esta funcion no corre este valor "ucase" me podrias dar algun alcance o solucion.

Saiyine (12/06/2005, 21:28) Prueba a usar la función uppercase en su lugar.

Por Saiyine  el 2001-01-01 00:00:00 - Secciones:  DELPHI  - Enlace permanente: 436

procedure AbrirURL(cual : string);
var explorer: Variant;
begin
 explorer:=CreateOLEObject('InternetExplorer.Application');
 explorer.visible:=true;
 explorer.Navigate(cual);
end;

Añadir comobj al uses.

Por Saiyine  el 2001-01-01 00:00:00 - Secciones:  DELPHI  - Enlace permanente: 437

procedure TForm1.Button1Click(Sender: TObject);
var
  i: Integer;
begin
  for i := 1 to 20 do begin
    with TEdit(FindComponent('Edit' + IntToStr(i))) do
      begin
        Text:='Esto es una prueba';
      end;
end;

Este procedimiento busca edit con numero 20 o menor y les cambia el texto.

Por Saiyine  el 2001-01-01 00:00:00 - Secciones:  DELPHI  - Enlace permanente: 439

procedure ApagaMonitor(segundos : integer);
begin
  SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, 0);
  sleep(segundos*1000);
  SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, -1);
end;

Por Saiyine  el 2001-01-01 00:00:00 - Secciones:  DELPHI  - Enlace permanente: 440

{Hay que poner Uses Registry
Solo WIN95 o superior, probablemente problemas en los NT
ext : extension
nom : nombre del tipo de ficheros
pro : cadena con la direccion _completa_ del programa, yo suelo usar paramstr(0)
icoindice : indice de icono del ejecutable, dejalo a 0 si no sabes que significa.
  RegistrarExtension('.jpg','Imagen JPEG',paramstr(0),0);
  RegistrarExtension('.pelicula','c:\utilidades\cine.exe',0);
}
procedure RegistrarExtension(ext,nom,pro : string; icoindice : integer);
var
  reg: TRegistry;
begin
  reg := TRegistry.Create;
  with reg do
    begin
      RootKey := HKEY_CLASSES_ROOT;
      LazyWrite := false;
      OpenKey(ext, true);
      WriteString('',nom);
      CloseKey;
      OpenKey(nom, true);
      WriteString('',nom);
      CloseKey;
      OpenKey(nom+'\shell\open\command', true);
      WriteString('',pro+' "%1"');
      CloseKey;
      OpenKey(nom+'\DefaultIcon',true);
      WriteString('',pro+','+inttostr(icoindice));
      CloseKey;
      free;
    end;
end;

Por Saiyine  el 2001-01-01 00:00:00 - Secciones:  DELPHI  - Enlace permanente: 441

Teniendo un boton, el listbox o combobox, y un edit con el texto, meter esto en el onclick del boton:

listbox1.Items.Delete(listbox1.Items.IndexOf(edit1.text));

El metodo IndexOf(cadena) devuelve el numero de la linea que contiene esa cadena, asi os ahorrais ir mirando una a una :D

Por Saiyine  el 2001-01-01 00:00:00 - Secciones:  DELPHI  - Enlace permanente: 442

procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char);
begin
  ShowMessage('Tecla pulsada: '+inttostr(ord(key)));
end;

No olvidar poner la propiedad keypreview del form a true.

procedure TForm1.Button4Click(Sender: TObject);
var
  aux : char;
begin
  aux:=chr(VK_RETURN);
  FormKeyPress(sender,aux);
end;

VK_RETURN es el codigo del enter, para la lista completa, busca en la ayuda del Delphi.

Anonimo (02/08/2005, 21:16) ??????????

Por Saiyine  el 2001-01-01 00:00:00 - Secciones:  DELPHI  - Enlace permanente: 443

procedure EscribePixel(x,y : integer; r,g,b : byte; var b : TBitmap);
var
  Pix : PByteArray;
begin
  Pix := b.ScanLine[y];
  Pix[x*3]:=b;
  Pix[x*3+1]:=g;
  Pix[x*3+2]:=r;
end;

function CrearBitmap(tamx,tamy : integer) : TBitmap;
begin
  result:=TBitmap.Create;
  result.Height:=tamy;
  result.Width:=tamx;
  result.PixelFormat := pf24Bit;
end;

Por Saiyine  el 2004-07-14 00:00:00 - Secciones:  DELPHI  - Enlace permanente: 444

function RGB2TColor(r,g,b : integer) : TColor;
begin
        Result:=b shl 16+g shl 8+r;
end;

procedure TColor2RGB(c : tcolor; var r : integer; var g : integer; var b : integer);
begin
        r:=c and $FF;
        g:=(c and $ff00) shr 8;
        b:=(c and $ff0000) shr 16;
end;

function TColor2R(c : Tcolor) : integer;
begin
        result:=c and$FF;
end;

function TColor2G(c : Tcolor) : integer;
begin
        result:=(c and $ff00) shr 8;
end;

function TColor2B(c : Tcolor) : integer;
begin
        result:=(c and $ff0000) shr 16;
end;

// Pset(bitmap1,200,200,RGB2Color(0,0,64));
// Dibujaria un punto azul oscuro en el punto 200,200 del bitmap1
procedure Pset(bitmap : TBitmap; X,Y : Integer; c : TColor);
var
pPixels : PByteArray;
begin
        pPixels:=Bitmap.ScanLine[Y];
        pPixels[X*3]:=TColor2B(c);
        pPixels[X*3+1]:=TColor2G(c);
        pPixels[X*3+2]:=TColor2R(c);
end;

function Preset(bitmap : TBitmap; X,Y : Integer) : TColor;
var
pPixels : PByteArray;
begin
        pPixels := Bitmap.ScanLine[Y];
        result:=RGB2TColor(pPixels[X*3+2],pPixels[X*3+1],pPixels[X*3]);
end;

He actualizado ligeramente las funciones de conversión de formatos de colores.

Por Saiyine  el 2001-01-01 00:00:00 - Secciones:  DELPHI  - Enlace permanente: 445

library EjemploDLL;

uses
SysUtils,
Classes,
dialogs;

procedure Hola; stdcall; export;
begin
        ShowMessage('Holaaaaaaaa');
end;

exports Hola;
end.

Este es un ejemplo de DLL muy simple, que solo contiene el procedimiento Hola. Como podeis ver hay al menos tres diferencias con un programa normal:

1/ library EjemploDLL; ---> Para indicar al compilador que es una libreria

2/ procedure Hola; stdcall; export; ---> Con esas dos palabras indicamos que ese procedimiento se puede usar por otro programa.

3/ exports Hola; ---> Dejamos claro que es lo que queremos exportar.

Luego, para usarla solo tenemos que hacer: (haz un programa con dos botones para el ejemplo)

procedure Hola; external 'EjemploDLL.dll';

procedure TForm1.Button1Click(Sender: TObject);
begin
        Hola;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
hMod : THandle;
HelloWorld : procedure;
begin
        hMod := LoadLibrary('EjemploDLL.dll');
        if (hMod = 0) then Exit;
        @Hola := GetProcAddress(hMod, 'Hola');
        if @Hola  nil then Hola;
        FreeLibrary(hMod);
end;

El segundo metodo es bastante mas complicadillo, pero permite mucho mas control en plan dar un error si el DLL no se encuentra y cosas asi.

Por cierto, los DLL se pueden ejecutar (lease, 'el windows los encuentra') cuando estan en:

1/ El mismo directorio que el ejecutable

2/ En el directorio de windows (C:\windows normalmente)

3/ En el directorio de sistema de windows (C:\windows\system normalmente)

4/ En los directorios señalados por la variable de sistema PATH

Deberia haber una tercera forma para llamar a las funciones de un dll, en realidad es una variante de la segunda, que es guardar el dll dentro de los resources del ejecutable y luego leerlo en tiempo de ejecucion, pero no consigo hacerlo sin pasar por el disco (en el momento en que el dll se escribiese en el disco estariamos haciendo la version dos de la llamada)... esto que puede parecer un rollo tiene su utilidad, con esto podrias hacer programas que practicamente no dieran problemas de pantallazos azules.

Por Saiyine  el 0000-00-00 00:00:00 - Secciones:  DELPHI  - Enlace permanente: 466

Añadiendo printers al uses, puedes usar un codigo semejante al siguiente para imprimir texto por la impresora, es facil...

var x, y: Integer;
begin
  Printer.BeginDoc;         
  with Printer.Canvas do
  begin
    x := Printer.PageHeight div 50;                 
    y := Printer.PageWidth div 15;            
    Font.Name:= 'tahoma';
    Font.Height:= x*2;                 
    Font.Color:= clblack;                 
    TextOut (x,y * 3, 'Teeeeexxxxtttoooooo');                
    Printer.EndDoc;         
  end; 
end; 

Julio Caldas (04/03/2005, 16:38) Este codigo esta bueno, hasta es compatible con el edit, pero con listbox o un memo, no, usted puede hacerme llegar como puedo imprimir los datos que tengo en un listbox, memo o imprimir todo un stringgrid, puede ser, cualquier informacion mi mail jcaldas1986@yahoo.com. Sin mas se despide Julio.

Por Saiyine  el 0000-00-00 00:00:00 - Secciones:  DELPHI  - Enlace permanente: 467

function GetUserName : String;
var
pcUser   : PChar;
dwUSize : DWORD;
begin
        dwUSize := 21;
        GetMem( pcUser, dwUSize );
        try
        if Windows.GetUserName( pcUser, dwUSize ) then
        Result := pcUser
        finally
        FreeMem( pcUser );
end;
end;

Por Saiyine  el 0000-00-00 00:00:00 - Secciones:  DELPHI  - Enlace permanente: 468

Mmm no hay mucho que decir, aprovecha el indice de las cadenas para definir el caracter que corresponde a segun que base.

function DecimalABaseN(num : integer; base : byte) : string;
var
aux : string;
begin
        // Solo hasta la 'o' = como máximo base 20... suficiente ¿no?
        aux:='0123456789ABCDEFGHIO';
        result:='';
        while num>0 do
        begin
                result:=aux[(num mod base)+1]+result;
                num:=num div base;
        end;
end;

Por Saiyine  el 0000-00-00 00:00:00 - Secciones:  DELPHI  - Enlace permanente: 469

function SuperVal(cadena : string) : int64;
var
i : integer;
begin
        result:=0;
        for i:=1 to length(cadena) do
        if cadena[i] in ['0'..'9'] then result:=result*10+ord(cadena[i])-48;
end;

Por Saiyine  el 0000-00-00 00:00:00 - Secciones:  DELPHI  - Enlace permanente: 470

procedure TForm1.miClick(Sender: TObject);
begin
        ShowMessage('El nuevo boton ha sido pulsado');
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
        with TButton.Create(self) do begin
                Left := 50;
                Top := 50;
                Width := 120;
                Height := 40;
                Name := 'Boton nuevo';
                Caption := 'Un boton';
                OnClick :=  miClick;
                Parent := Form1;
        end;
end;

Por Saiyine  el 0000-00-00 00:00:00 - Secciones:  DELPHI  - Enlace permanente: 471

Se le pasa el contenido de una lista de cadenas, por ejemplo las lines de un memo

//  GrabarJPG('resultado.jpg',sumar_jpg_de_lado(memo1.lines));
function sumar_jpg_de_lado(nombres : tstrings) : TBitmap;
var
b : array [0..10] of tbitmap;  // limite de JPGs laterales, subir si hace falta
c,x,y,i,j,k : integer;
begin
        c:=nombres.count;
        for i:=0 to c-1 do b[i]:=LeerJPG(nombres[i]);
        //  ATENCION: Es para n JPGs de dimesiones identicas
        x:=b[0].width;
        y:=b[0].height;
        result:=CrearBitmap(x*c,y);
        for i:=0 to x-1 do
        for j:=0 to y-1 do
        for k:=0 to c-1 do
        result.canvas.Pixels[i+k*x,j]:=b[k].canvas.pixels[i,j];
end;

A partir de esto, crear combinaciones de JPGs en cualquier direccion os deberia resultar trivial.

Las funciones LeerJPG y CrearBitmap las podeis encontrar en esta misma web.

No olvideis añadir jpeg al uses de la unidad en que useis este procedimiento.

Por Saiyine  el 0000-00-00 00:00:00 - Secciones:  DELPHI  - Enlace permanente: 472

Esto es muy especifico, lo pidio sul__ en #delphi , pero lo he puesto por si a alguien le interesa...

// PartirCadenasAMemo('hola&soy!pepe',' &!',Memo1);
procedure PartirCadenasAMemo(cadena,malos : string; salida : Tmemo);
var
i : integer;
aux : string;
begin
        aux:='';
        for i:=1 to length(cadena) do
        if pos(cadena[i],malos)>0 then
        begin
                salida.Lines.Add(aux);
                aux:='';
        end else aux:=aux+cadena[i];
        salida.Lines.Add(aux);
end;

Una utilidad interesante seria cambiar el tipo de salida por una lista de cadenas y usarlo para para representar dinamicamente en memoria bases de datos del disco.

Por Saiyine  el 2005-11-10 16:42:00 - Secciones:  DELPHI  - Enlace permanente: 594

function Distancia(a,b : integer) : integer;
begin
        result:=abs(a-b);
end;

Lógico, ¿verdad?

Por Saiyine  el 0000-00-00 00:00:00 - Secciones:  DELPHI  - Enlace permanente: 473

procedure TForm1.PuntosDeMiles(Sender: TObject);
var
i : integer;
aux,aux2,cad : string;
begin
        cad:='0123456789';
        aux2:='';
        with (Sender as TEdit) do
        begin
                aux:=text;
                if aux[1]='0' then delete(aux,1,1);
                for i:=1 to length(aux) do
                begin
                        if pos(aux[i],cad)>0 then aux2:=aux2+aux[i];
                end;
                i:=1;
                repeat
                        if (i mod 4=0) then Insert('.',aux2,length(aux2)-i+2);
                        inc(i);
                until (i>length(aux2));
                text:=aux2;
                SelStart:=length(aux2);
        end;
end;

Asigna el onchange del edit al que quieras aplicar lo de los puntos de miles. RECUERDA que al meter los caracteres de '.' en la cadena, el procedimiento strtoint dejara de funcionar correctamente ya que no tendras una cadena con un numero, sino una cadena normal y corriente.

Otra cosa: no olvides inicializar el edit con un '0' como valor de text.

PD Puedes encontrar un procedimiento para pasar de cadena a entero mucho mas robusto que el strtoint en estas paginas, que es capaz de pasar de cadena de numeros con puntos de miles al numero correcto.

Por Saiyine  el 2005-12-29 23:54:00 - Secciones:  DELPHI  - Enlace permanente: 474

// EncriptaXOR('esta es la frase de ejemplo','claveXXX')
function EncriptaXOR(cadena,clave : string) : string;
var
i : integer;
begin
        result:='';
        for i:=1 to length(cadena) do
        result:=result+chr(ord(cadena[i]) xor ord(clave[(i mod length(clave))+1]));
end;

La encriptacion con XOR es un clasico entre los clasicos... antes se usaba mucho, por ejemplo, en los virus para hacerlos mas dificiles de encontrar (¿os suena 'virus polimorficos'?). El XOR tiene la propiedad de que si le haces a un numero la operacion XOR dos veces con el mismo numero, obtienes de nuevo el primer numero...

A ver si lo se explicar:

23 xor 6 = 17

17 xor 6 = 23

Por eso no hace falta una rutina desencriptadora, con pasar dos veces la rutina de encriptacion con la misma clave obtienes la cadena original.

cadenaencriptada:=EncriptaXOR('mmm rosquillas','homer');
// mostrara la cadena 'mmm rosquillas'
ShowMessage(EncriptaXOR(cadenaencriptada,'homer'));

Por Saiyine  el 0000-00-00 00:00:00 - Secciones:  DELPHI  - Enlace permanente: 475

procedure TextOutAngle(x,y,aAngle,aSize: integer; fuente,txt: string; C : TCanvas);
var hFont, Fontold: integer;
DC: hdc;
Fontname: string;
begin
        if length(txt)= 0 then
        EXIT;
        DC:= c.handle;
        SetBkMode(DC, transparent);
        hFont:= CreateFont(-aSize,0, aAngle*10,0, fw_bold,0, 0,
        0,1,4,\$10,2,4,PChar(fuente));
        Fontold:= SelectObject(DC, hFont);
        TextOut(DC,x,y,PChar(txt), length(txt));
        SelectObject(DC, Fontold);
        DeleteObject(hFont);
end;

Por Saiyine  el 0000-00-00 00:00:00 - Secciones:  DELPHI  - Enlace permanente: 476

function Delay(tiempo : integer);
var
aa : integer;
begin
        aa:=GetTickCount;
        while GetTickCount-aa<2000 do;
end;

" title="MrRidk">MrRidk (14/01/2005, 18:31) Que pasa saiyine, pues te informo de que para hacer eso existe un API de windows que hace eso: Se llama Sleep y bastaría con pasarle como parametro el nº de milisegundos que queires dormir tu app. En este caso seria algo asi como ... Sleep(2000); Aparte de la comodidad de usar un API, consigues que durante ese tiempo, el proceso no coma recursos de la CPU... Un saludo...MrRidk

" title="Saiyine">Saiyine (15/01/2005, 00:30) ¡Buenas! Cierto, cierto, mucho mejor con un sleep, que es una instrucción que poseen casi todos los lenguajes, que raro que usase el bucle este. Pero claro, hace tanto tiempo que a saber... ¡Otro saludo para ti!

Por Saiyine  el 0000-00-00 00:00:00 - Secciones:  DELPHI  - Enlace permanente: 477

procedure TForm1.IntercambiaEdit(Sender: TObject);
var
i,j : integer;
aux,cad1,cad2 : string;
begin
        cad1:='aeiou';   // Los caracteres de esta cadena seran sustituidos
        cad2:='AEIOU';   // por los equivalentes en esta...
        with (Sender as TEdit) do
        begin
                aux:=text;
                for i:=1 to length(aux) do
                for j:=1 to length(cad1) do
                if aux[i]=cad1[j] then aux[i]:=cad2[j];
                text:=aux;
                SelStart:=length(aux);
        end;
end;

Usar este procedimiento como onchange del edit en cuestion. En el ejemplo, como hacer un edit que solo acepte las vocales en mayusculas.

Por Saiyine  el 0000-00-00 00:00:00 - Secciones:  DELPHI  - Enlace permanente: 478

procedure TForm1.FiltroEdit(Sender: TObject);
var
i : integer;
aux,aux2,cad : string;
begin
        cad:='0123456789abcdefABCDEF';   // Solo se admiten estos caracteres
        aux2:='';
        with (Sender as TEdit) do
        begin
                aux:=text;
                for i:=1 to length(aux) do
                if pos(aux[i],cad)>0 then aux2:=aux2+aux[i];
                text:=aux2;
                SelStart:=length(aux2);
        end;
end;

Asigna el onchange del edit a este procedimiento y elige los caracteres que puede aceptar poniendolos en la cadena cad. En el ejemplo, como hacer un edit que solo acepte como entrada numeros en hexadecimal.

Por Saiyine  el 0000-00-00 00:00:00 - Secciones:  DELPHI  - Enlace permanente: 479

procedure TForm1.ClickGeneral(Sender : TObject);
var
numbot : integer;
begin
        with Sender as TButton do
        begin
                numbot:=SuperVal(Name);
                Self.Caption := 'Has pulsado el boton nº' + inttostr(numbot);
        end;
end;

Crea un form, crea cuatro o cinco botones y asocia el onclick de cada uno a ClickGeneral.

Por Saiyine  el 0000-00-00 00:00:00 - Secciones:  DELPHI  - Enlace permanente: 480

procedure TForm1.IntercambiaEdit(Sender: TObject);
var
i,j : integer;
aux,cad1,cad2 : string;
begin
        cad1:='aeiou';   // Los caracteres de esta cadena seran sustituidos
        cad2:='AEIOU';   // por los equivalentes en esta...
        with (Sender as TEdit) do
        begin
                aux:=text;
                for i:=1 to length(aux) do
                for j:=1 to length(cad1) do
                if aux[i]=cad1[j] then aux[i]:=cad2[j];
                text:=aux;
                SelStart:=length(aux);
        end;
end;

Usar este procedimiento como onchange del edit en cuestion. En el ejemplo, como hacer un edit que solo acepte las vocales en mayusculas.

Por Saiyine  el 2006-02-21 20:07:00 - Secciones:  DELPHI  - Enlace permanente: 481

procedure Justifica(cadenas : tstrings; fuente : TFont; ancho : integer);
var
i : integer;
aux : string;
begin
  for i:=0 to cadenas.count-1 do
  while Distancia(LargoTexto(cadenas[i],fuente),ancho)>10 do
  begin
    aux:=cadenas[i];
    Insert(' ',aux,MenorEspacioEntrePalabras(aux));
    cadenas[i]:=aux;
  end;
end;

Este procedimiento se podria usar asi:

procedure TForm1.Button1Click(Sender: TObject);
begin
  Justifica(ListBox1.Items,ListBox1.font,ListBox1.width);
end;

Y llama a las siguientes funciones:

function MenorEspacioEntrePalabras(cad : string) : integer;
var
menor,actual,i : integer;
enespacio : boolean;
begin
  actual:=0;
  menor:=50;
  result:=0;
  enespacio:=false;
  for i:=1 to length(cad) do
  begin
    if cad[i]=' ' then
    begin
      if enespacio
      then actual:=actual+1
      else
      begin
        enespacio:=true;
        actual:=1;
      end;
    end
    else
    if enespacio then
    begin
      enespacio:=false;
      if actual<menor then
      begin
        menor:=actual;
        result:=i-actual;
        actual:=0;
      end;
    end;
  end;
end;

function LargoTexto(texto : string; f : TFont) : integer;
var
aux : TFont;
begin
  aux:=Screen.ActiveForm.Canvas.font;
  Screen.ActiveForm.Canvas.font:=f;
  result:=Screen.ActiveForm.Canvas.textwidth(texto);
  Screen.ActiveForm.Canvas.font:=aux;
end;

function Distancia(a,b : integer) : integer;
begin
  result:=abs(a-b);
end;

Por Saiyine  el 0000-00-00 00:00:00 - Secciones:  DELPHI  - Enlace permanente: 482

function LargoTexto(texto : string; f : TFont) : integer;
var
aux : TFont;
begin
        aux:=Screen.ActiveForm.Canvas.font;
        Screen.ActiveForm.Canvas.font:=f;
        result:=Screen.ActiveForm.Canvas.textwidth(texto);
        Screen.ActiveForm.Canvas.font:=aux;
end;

Por ejemplo, se haria LargoTexto('Delphi es bastante mejor que el visual basic',fuente), siendo fuente una variable TFont definida en arial, negrita, 5 puntos, etc

Por Saiyine  el 0000-00-00 00:00:00 - Secciones:  DELPHI  - Enlace permanente: 483

A peticion de Manulon, ahi va una unidad para lectura rapida de ficheros... forma parte de un viejo proyecto, de cuando salieron los mp3, tenia curiosidad por ver cual era el mejor compresor e hice un comparador de wavs, quizas algun dia haga una version 'para todos los publicos' para que saqueis vuestras propias conclusiones...

La unidad debe llamarse UCacheLecturaSecuencial.pas para evitar problemas (los nombres largos del windows hay que aprovecharlos ).

unit UCacheLecturaSecuencial;

interface

type
        Fichero_CLS = class
        private
        f : file;
        buf : array[0..1999] of byte;
        status,puntero,punterototal,maximo : integer;
        procedure Actualizar;
        public
        constructor Crear(fichero : string);
        destructor Cerrar;
        function LeerByte : byte;
        function LeerInteger : Integer;
        function LeerLongint : Longint;
        function ComprobarEstado : Integer;
end;

implementation

procedure Fichero_CLS.Actualizar;
begin
        blockread(f,buf,sizeof(buf),maximo);
        puntero:=0;
        if maximo>0
        then status:=0
        else status:=1;
end;

constructor Fichero_CLS.Crear(fichero : string);
begin
        assignfile(f,fichero);
        reset(f,1);
        Actualizar;
        punterototal:=0;
end;

destructor Fichero_CLS.Cerrar;
begin
        closefile(f);
end;

function Fichero_CLS.LeerByte : byte;
begin
        result:=buf[puntero];
        inc(puntero);
        inc(punterototal);
        if puntero>=maximo then Actualizar;
end;

function Fichero_CLS.LeerInteger : Integer;
var
aux : integer;
begin
        aux:=LeerByte;
        aux:=aux*$FF+LeerByte;
        result:=aux;
end;

function Fichero_CLS.LeerLongint : Longint;
var
aux : Longint;
begin
        aux:=LeerByte;
        aux:=aux*\$FF+LeerByte;
        aux:=aux*\$FF+LeerByte;
        aux:=aux*\$FF+LeerByte;
        result:=aux;
end;

function Fichero_CLS.ComprobarEstado : Integer;
begin
        result:=status;
end;

end.

Para usarla basta añadir UCacheLecturaSecuencial.pas al directorio del programa o a un directorio especifico para librerias y meter UCacheLecturaSecuencial en el uses de la unidad que lo use. Un ejemplo de uso seria este:

procedure TForm1.Button1Click(Sender: TObject);
var
fich : Fichero_CLS;
begin
        fich:=Fichero_CLS.Crear('y:\gadda_CD.wav');
        while fich.ComprobarEstado=0 do
        Caption:='Primer entero: '+ inttostr(fich.LeerByte);
        fich.Cerrar;
end;

Jose Luis (27/01/2005, 19:22) Hola Saiyine. Te escribo interesado en la informacion que tienes sobre la lectura rapida de un fichero (byte a byte). Yo tengo que hacerlo pero en C++ y escribia a ver si me puedes echar una mano. La verdad es que no entiendo muy bien lo que haces con ese codigo (supongo que tendra que ver que yo no tengo ni idea de delphi) y me preguntaba si me podrías explicar que es lo que haces exactamente. Mi problema es que tengo que leer (solo leer) datos de tamaño fijo desde un archivo binario que ya esta creado. Se que utilizando la API de Windows hay una manera de hacerlo de forma rapida (utilizando las funciones createfile, creo que virtualalloc...) siempre que antes prepares el sistema adecuadamente, si no el programa es igual de lento que haciendo un read. Si puedes explicarme como va tu codigo tal vez me ayude en mi proyecto. Gracias de antemano y un saludo Joste

Saiyine (28/01/2005,01:19) Hola, Joste. Procuro no acercarme a nada que huela a C, salvo cuando no hay más remedio, y cuando no lo hay procuro limpiar mi mente enseguida, así que no te sabria decir lineas de código de lo que tienes que hacer. Lo que si puedo decirte que con createfile, por el nombre de la función, no vas bien para leer de un fichero. La función read que mencionas imagino que será la misma que poseen todos los lenguajes para leer de un fichero, salvo que me esté confundiendo, con que le subas el tamaño del buffer de lectura bastará para que obtengas un gran aumento de velocidad de lectura. Mi código, que por cierto lleva ya casi cuatro escrito así que lo tengo algo olvidado, simula un "read" de byte en byte, que normalmente seria lentisimo, pero usando internamente lectura en bloques mucho más grandes, que forman una cache que acelera mucho el proceso. Es decir, el usuario lee el fichero byte a byte, mientras que el programa lee bloques según sea necesario. Vaya, una caché de lectura de toda la vida. En esta página parece que hacen algo similar en C++.

Jose Luis (31/01/2005, 18:50) Hola otra vez!! Asi que c++ te da urticaria, jeje. Yo ahora me estoy iniciando en java, pero hasta que lo domine mejor sigo con c++ Bueno, para empezar gracias por la ayuda, aunque me temo que mis investigaciones no van por ese camino aunque voy a mirar un poco sobre la cache de lectura... me ha gustado. El link que me has puesto trata sobre escritura y lectura estandar de archivos. No es lo que busco. Por otro lado, la funcion CreateFile de la API de windows si que sirve para abrir archivos, aunque si no existe el mismo lo crea. La idea que tengo en mente es reservar un espacio de memoria virtual (creo que con virtualalloc de la api tambien), abrir un archivo y luego copiar todo lo necesario a toda pastilla. A ver si lo consigo. Lo que pensaba era hacerlo con un puntero, despues de haber reservado la zona de memoria virtual y teniendo la posición de memoria de los datos, recorrer con un puntero los datos y copiarlo, pero estoy seguro de que hay una forma mas rapida de conseguirlo mediante bloques de memoria. Lo que no se es que funcion utilizar y como utilizarla. Bueno sigo investigando, y gracias otra vez. Por cierto, me ha entrado curiosidad con esto de delphi, igual me miro algo... Un saludo

Por Saiyine  el 0000-00-00 00:00:00 - Secciones:  DELPHI  - Enlace permanente: 484

function LeerJPG(n : string) : TBitmap;
Var
jpeg: TJPEGImage;
Begin
        jpeg:= TJPEGImage.Create;
        try
        jpeg.LoadFromFile(n);
        result:= TBitmap.Create;
        try
        result.Assign( jpeg );
        finally
end;
finally
jpeg.free
end;
end;

procedure GrabarJPG(n : string; d : TBitmap);
Var
jpeg: TJPEGImage;
Begin
        jpeg:= TJPEGImage.Create;
        jpeg.Assign( d );
        jpeg.savetofile(n);
        jpeg.free
end;

Por Saiyine  el 0000-00-00 00:00:00 - Secciones:  DELPHI  - Enlace permanente: 485

procedure TextoAPortapapeles(cad : string);
begin
        ClipBoard.SetTextBuf(pchar(cad));
end;

function TextoDesdePortapapeles : string;
begin
        result:='';
        if Clipboard.HasFormat(CF_TEXT) then result:=Clipboard.AsText;
end;

Añadiendo ClipBrd al uses.

Por Saiyine  el 0000-00-00 00:00:00 - Secciones:  DELPHI  - Enlace permanente: 486

function DirWindows : string;
var
Win : array[0..79] of char;
begin
        GetWindowsDirectory(Win, sizeof(Win));
        Result:=Win;
end;

Por Saiyine  el 0000-00-00 00:00:00 - Secciones:  DELPHI  - Enlace permanente: 487

function TamFichero(n : string) : longint;
var
f: file of Byte;
begin
        AssignFile(f, n);
        Reset(f);
        TamFichero := FileSize(f);
        CloseFile(f);
end;

Por Saiyine  el 0000-00-00 00:00:00 - Secciones:  DELPHI  - Enlace permanente: 488

function LeadingZero(n : string;zeroes : byte) : string;
begin
        while length(n)<zeroes do n:='0'+n;
        LeadingZero:=n;
end;

function damefecha : string;
var
meses : string;
Present: TDateTime;
Year, Month, Day : Word;
const Dias : array [1..7] of string = (
'domingo','lunes',
'martes','miercoles',
'jueves','viernes','sabado');
begin
        meses:='ENEFEBMARABRMAYJUNJULAGOSEPOCTNOVDIC';
        Present:= Now;
        DecodeDate(Present, Year, Month, Day);
        result:=Dias[DayOfWeek(Present)]+','+LeadingZero(inttostr(Day),2)+'/'+
        meses[(month-1)*3+1]+
        meses[(month-1)*3+2]+
        meses[(month-1)*3+3]+'/'
        +LeadingZero(inttostr(Year),4);
end;

La funcion LeadingZero es un clasico rescatado de la ayuda del turbo pascal, dado un numero devuelve una cadena con el numero formateado con 0. Es decir si tenemos el numero 256 y queremos mostrarlo con 6 numeros, LeadingZero(256,6) nos dara la cadena '000256'.

Por Saiyine  el 0000-00-00 00:00:00 - Secciones:  DELPHI  - Enlace permanente: 489

function GetWindowsVersion : string;
var
OsVinfo   : TOSVERSIONINFO;
HelpStr   : array[0..50] of char;
begin
        ZeroMemory(@OsVinfo,sizeOf(OsVinfo));
        OsVinfo.dwOSVersionInfoSize := sizeof(TOSVERSIONINFO);
        if GetVersionEx(OsVinfo) then
        begin
                if OsVinfo.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS then
                begin
                        if (OsVinfo.dwMajorVersion = 4) and (OsVinfo.dwMinorVersion > 0) then
                        StrFmt(HelpStr, 'Windows 98 - Version %d.%.2d.%d',
                        [OsVinfo.dwMajorVersion, OsVinfo.dwMinorVersion,
                        OsVinfo.dwBuildNumber and $FFFF])
                        else
                        StrFmt(HelpStr, 'Windows 95 - Version %d.%d Build %d',
                        [OsVinfo.dwMajorVersion, OsVinfo.dwMinorVersion,
                        OsVinfo.dwBuildNumber and $FFFF]);
                end;
                if OsVinfo.dwPlatformId = VER_PLATFORM_WIN32_NT then
                StrFmt(HelpStr, 'Microsoft Windows NT Version %d.%.2d.%d',
                [OsVinfo.dwMajorVersion, OsVinfo.dwMinorVersion,
                OsVinfo.dwBuildNumber and $FFFF]);
        end
        else
        StrCopy(HelpStr, 'GetversionEx() Error');
        Result := string(HelpStr);
end;

function GetWindowsVersionShort : string;
var
OsVinfo   : TOSVERSIONINFO;
begin
        ZeroMemory(@OsVinfo,sizeOf(OsVinfo));
        OsVinfo.dwOSVersionInfoSize := sizeof(TOSVERSIONINFO);
        if GetVersionEx(OsVinfo) then
        begin
                if OsVinfo.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS then Result:='9X';
                if OsVinfo.dwPlatformId = VER_PLATFORM_WIN32_NT then Result:='NT';
        end
        else
        Result := 'Er';
end;

Yo personalmente uso mucho la segunda version, la mas corta, en mis programas.

Por Saiyine  el 0000-00-00 00:00:00 - Secciones:  DELPHI  - Enlace permanente: 490

function existe(fichero : string) : boolean;
var  fich : file of byte;
begin
        ASSIGN(fich,fichero);
        \{\$I-}
        RESET(fich);
        close(fich);
        \{\$I+}
        existe := ioresult = 0;
end;

Function Temp(Name,Ext : string) : string;
var
TCa : Word;
s : string;
Begin
        TCa:=0;
        repeat
                s:=LeadingZero(TCa,4);
                s:=Name+s+'.'+ext;
                inc(TCa);
        Until not existe(s);
        Temp:=s;
End;

Por Saiyine  el 0000-00-00 00:00:00 - Secciones:  DELPHI  - Enlace permanente: 491

// Si el caracter c es mayuscula, es cierto
function esmayuscula(c : char) : boolean;
begin
        if (c>#64) and (c<#91)
        then result:=true
        else result:=false;
end;

// Si el caracter c es minuscula, es cierto
function esminuscula(c : char) : boolean;
begin
        if (c>#96) and (c<#123)
        then result:=true
        else result:=false;
end;

// Si el caracter c es un numero, es cierto
function EsUnNumero(c : char) : boolean;
begin
        if (c>#47) and (c<#58)
        then result:=true
        else result:=false;
end;

// Convierte a mayusculas una cadena
// ucase('Hola')='HOLA'
function ucase(s : string) : string;
var  i : integer;
begin
        for i:=1 to length(s) do
        if esminuscula(s[i]) then s[i]:=chr(ord(s[i])-32);
        result:=s;
end;

// Convierte a minusculas una cadena
// ucase('Hola')='hola'
function dcase(s : string) : string;
var  i : integer;
begin
        for i:=1 to length(s) do
        if esmayuscula(s[i]) then s[i]:=chr(ord(s[i])+32);
        result:=s;
end;

// EliminaEspaciosDelPrincipio('   digo')='digo'
function EliminaEspaciosDelPrincipio(cad : string) : string;
begin
        while cad[1]=#32 do cad:=copy(cad,2,length(cad));
        result:=cad;
end;

// EliminaEspaciosDelFinal('digo ')='digo'
function EliminaEspaciosDelFinal(cad : string) : string;
begin
        while cad[length(cad)]=#32 do cad:=copy(cad,1,length(cad)-1);
        result:=cad;
end;

// EliminaEspaciosDeLosExtremos('   digo ')='digo'
function EliminaEspaciosDeLosExtremos(cad : string) : string;
begin
        result:=EliminaEspaciosDelPrincipio(EliminaEspaciosDelFinal(cad));
end;

// EliminaSubcadena('Hola amigo','HOLA',false)=' amigo'
// EliminaSubcadena('Hola amigo','HOLA',true)='Hola amigo'
function EliminarSubcadena(sub,cad : string; casesensitive : boolean) : string;
var
aux : string;
begin
        if casesensitive then
        begin
                while pos(sub,cad)>0 do  delete(cad,pos(sub,cad),length(sub));
        end else
        begin
                aux:=ucase(cad);
                sub:=ucase(sub);
                while pos(sub,aux)>0 do
                begin
                        delete(cad,pos(sub,aux),length(sub));
                        delete(aux,pos(sub,aux),length(sub));
                end;
        end;
        result:=cad;
end;

// IntercambiaCadenas('Hola amigo','Hola','Adios')='Adios amigo';
function IntercambiaCadenas(sp,s1,s2 : string) : string;
var
i,j : integer;
aux : string;
begin
        if pos(s1,sp)=0 then IntercambiaCadenas:=sp
        else
        begin
                aux:='';
                i:=pos(s1,sp);
                for j:=1 to i-1 do aux:=aux+sp[j];
                for j:=1 to length(s2) do aux:=aux+s2[j];
                for j:=i+length(s1) to length(sp) do aux:=aux+sp[j];
                IntercambiaCadenas:=IntercambiaCadenas(aux,s1,s2);
                // Esa recurrente y relamida recursividad...
        end;
end;

Por Saiyine  el 0000-00-00 00:00:00 - Secciones:  DELPHI  - Enlace permanente: 492

function CambiarByte(fichero : string; posicion : longint; viejo,nuevo : byte) : boolean;
var
f : file of byte;
aux : byte;
begin
        result:=true;
        assignfile(f,fichero);
        reset(f);
        seek(f,posicion);
        read(f,aux);
        if auxviejo
        then result:=false // Error!!!!
        else
        begin
                seek(f,posicion);
                write(f,nuevo);
        end;
        closefile(f);
end;

Asi si queremos cambiar el byte 800 del fichero 'prueba.bin' que es 75 cuando deberia ser 27 hacemos la llamada:

if CambiarByte('prueba.bin',800,75,27)
then perfecto
else el byte a cambiar no era el que deberia

Anonimo (25/02/2005, 17:24) Hola Saiyine, Me ha gustado mucho tu página, sobre todo porque ofreces soluciones rápidas y prácticas. No soy muy ducho en la programación, apenas la uso como herramienta para solucionar algunos problemas, de modo que apenas domino funciones elementales, lo que me ha impedido solucionar el problema que te comento a contiuación, que tiene cierta relación con este que ofreces en tu página (estoy usando delphi 5.0). Yo necesito trabajar con un archivo, para leer un byte, por ejemplo. Cuando el archivo está en el HD no hay problemas, el reset para abrirlo funciona OK, pero cuando el archivo está en un CD, da error. La verdad es que no he encontrado como solucionar este problema. Te agradeceré si me das una ayuda o guia para abordarlo. Y gracias de antemanos, geovannis

Saiyine (27/02/2005, 12:57) ¡Hola! Normal que no lo hayas encontrado, la solución está bastante escondida: mete entre el assignfile y el reset la linea FileMode := 0;, que le indica al delphi que tiene que abrir el fichero en solo lectura. ¡Perdón por la tardanza en responder!

Por Saiyine  el 0000-00-00 00:00:00 - Secciones:  DELPHI  - Enlace permanente: 493

function BaseNADec(num : string; n : byte) : integer;
var
i : integer;
aux : string;
begin
        // Solo hasta la 'o' = como máximo base 20... suficiente ¿no?
        aux:='0123456789ABCDEFGHIO';
        result:=0;
        for i:=1 to length(num) do result:=result*n+pos(upcase(num[i]),aux)-1;
end;

// De base 16 (hexadecimal) a base 10 (decimal)
function HexADec(num : string) : integer;
begin
        result:=BaseNADec(num,16);
end;

// De base 2 (binario) a base 10 (decimal)
function BinADec(num : string) : integer;
begin
        result:=BaseNADec(num,2);
end;

// De base 8 (octal) a base 10 (decimal)
function OctADec(num : string) : integer;
begin
        result:=BaseNADec(num,8);
end;

Por Saiyine  el 0000-00-00 00:00:00 - Secciones:  DELPHI  - Enlace permanente: 494

function CompararFicheros(const a : string; const b : string) : boolean;
var
f,g : file;
buf1,buf2 : array[1..2000] of byte;
i,leidof,leidog : integer;
todobien : boolean;
begin
        result:=true;
        assignfile(f,a);
        reset(f,1);
        assignfile(g,b);
        reset(g,1);
        if filesize(f)filesize(g)
        then result:=false
        else
        begin
                todobien:=true;
                leidof:=0;
                leidog:=0;
                while todobien do
                begin
                        blockread(f,buf1,sizeof(buf1),leidof);
                        blockread(g,buf2,sizeof(buf2),leidog);
                        if (leidof=0) or (leidog=0) or (leidofleidog)
                        then todobien:=false
                        else
                        for i:=1 to leidof do
                        if buf1[i]buf2[i] then
                        begin
                                result:=false;
                                todobien:=false;
                        end;
                end;
        end;
        closefile(g);
        closefile(f);
end;

Subiendo el valor que define el tamaño de los buffers de lectura se puede acelerar el proceso, pero prefiero dejarlo asi para ahorrar memoria... pero claro todo va en gustos, para los que tengan prisa, subid el valor :D .

El codigo en si no tiene gran cosa, es abrir dos ficheros simultaneamente y leerlos en bloques de tamaño igual al tamaño de los buffers. Primero comparo el tamaño para asegurar que son iguales, ya que si no es asi, no tiene sentido compararlos: seran diferentes.

A destacar un par de cosas: no tiene chequeo de si los ficheros existen o no, y que a efectos de comparacion solo usa el contenido de los ficheros, pero no las fechas,atributos, etc

Por Saiyine  el 0000-00-00 00:00:00 - Secciones:  DELPHI  - Enlace permanente: 495

// Burbuja(memo.lines);
// Burbuja(listbox.lines);
// etc
procedure burbuja(conjunto : tstrings);
var
i,j : integer;
begin
        for i:=0 to conjunto.count-2 do
        for j:=i+1 to conjunto.count-1 do
        if lowercase(conjunto[i])>lowercase(conjunto[j]) then
        conjunto.Move(i,j);
end;

Por Saiyine  el 0000-00-00 00:00:00 - Secciones:  DELPHI  - Enlace permanente: 496

var X:integer;
begin
        for x:=0 to form1.controlcount -1 do
        if (form1.controls[x] is tpanel) then
        tPanel(form1.controls[x]).onclick:=panel1.OnClick;
end;

Por Saiyine  el 0000-00-00 00:00:00 - Secciones:  DELPHI  - Enlace permanente: 497

function Apariciones(sub,cad : string;casesensitive : boolean) : integer;
begin
        if casesensitive then
        begin
                sub:=uppercase(sub);
                cad:=uppercase(cad);
        end;
        result:=0;
        while pos(sub,cad)>0 do
        begin
                result:=result+1;
                delete(cad,pos(sub,cad),length(sub));
        end;
end;

Se podria usar, por ejemplo, para buscar la palabra hola en un memo:

Apariciones('hola',memo1.lines.text,FALSE)

Por Saiyine  el 0000-00-00 00:00:00 - Secciones:  DELPHI  - Enlace permanente: 498

function LimDec(num : real; limite : integer) : string;
begin;
result:=floattostr(round(num*power(10,limite)) / power(10,limite));;
end;

Recuerda añadir la unidad math al uses, aunque otra opcion seria hacerte tu propia funcion power, no tiene mucha historia.

Por Saiyine  el 0000-00-00 00:00:00 - Secciones:  DELPHI  - Enlace permanente: 499

procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
        case MessageDlg('¿Grabar cambios en el texto?', mtWarning, [mbYes, mbNo, mbCancel], 0) of
        6 : GrabarEntrada;
        7 : Canclose:=true;
        2 : Canclose:=false;
end;
end;

En vez del procedimiento GrabarEntrada, hay que poner el codigo para grabar si hay algo que grabar o lo que quieras.

rc (19/05/2004, 15:39) Como puedo cambiar el texto de los botones de la funcion MessageDlg a espanol. Gracias

Saiyine (19/05/2004, 22:49) Cambiarle el texto a los botones de los messagedlg tiene truco, y es que estos dialogos no son tales sino forms normales y corrientes que el delphi crea dinamicamente cuando son necesarios, así que hay que decirle de alguna manera que cuando cree el siguiente, lo haga con los botones que nosotros queramos. No tengo ningun código que haga tal cosa ahora mismo por aqui, así que he mirado en el google y he cogido un par, a ver si te sirven. El primero es una función bastante bien documentada que encapsula el dialogo y le puedes pasar los nombres de los botones que tu quieras (en el ejemplo, 1 y 2), y el segundo es algo mas complejo, pero tambien cumple su función. De nada :D

Por Saiyine  el 0000-00-00 00:00:00 - Secciones:  DELPHI  - Enlace permanente: 500

program Copia;
\{\$APPTYPE CONSOLE}
uses
SysUtils;

procedure FileCopy(const FromFile, ToFile: string);
var
FromF, ToF: file;
NumRead, NumWritten: integer;
Buf: array[1..2048] of Char;
begin
        AssignFile(FromF, FromFile);
        Reset(FromF, 1);		{ Record size = 1 }
        AssignFile(ToF, ToFile);	{ Open output file }
        Rewrite(ToF, 1);