Librería de Snippets para Delphi

(1/4) > >>

crack81:
¿Que es un Snippet?

*Es un extracto de código que suele contener una o varias Subrutinas con el propósito de realizar una tarea específica,
cuyo código es reusable por otras personas y fácil de integrar con sólamente copiar y pegar el contenido del Snippet.


Este post esta dedicado para publicar librerias o subrutinas del lenguaje Delphi/pascal,
ya que en mi punto de vista hay falta de material comparada a lenguajes estilo c++o visual basic, esto pueda ayudar a otros nuevos programadores a introducirse en este lenguaje.


*Informacion extraida del post de snippet de Elektro


Funcion para obtener el navegador prederterminado

Código
uses
 SysUtils,Registry,windows;
 
 
function getBrowser():string;
begin
with TRegistry.Create do
 try
   RootKey:=HKEY_CURRENT_USER;
   if openkey('\Software\Clients\StartMenuInternet',false) then
   begin
     result:=ReadString('');
     CloseKey;
   end
   else
     result:='Unknow';
 finally
  free;
 end;
end;
 
var
navegador:string;
begin
//uso de la funcion
 navegador:=getBrowser();
 writeln('Nuestro navegador es ',navegador);//en mi caso devolver mozilla firefox
 readln;
end.
 

Funcion delimitator que corta una cadena entre dos delimitadores

Código
uses
 SysUtils;
 
 
function Delimitador(cadena,delm1,delm2:string):string;
var
pos1,pos2:integer;
ext,sfinal:string;
begin
 sfinal:='';
 pos1:=AnsiPos(delm1,cadena);
 if pos1<>0 then
 begin
   ext:=copy(cadena,pos1+length(delm1),length(cadena)-length(delm1));
   pos2:=AnsiPos(delm2,ext);
   if pos2<>0 then
   begin
     sfinal:=copy(ext,1,pos2-1);
   end;
 end;
result:=sfinal;
end;
 
begin
//uso de la funcion
 writeln(delimitador('hola_mundo_como_estas','hola','estas'));
 {devolveria: _mundo_como_ }
 readln;
end.
 

Funcion para obtener el S.O que estamos utilizando

Código
uses
 SysUtils,windows;
 
 
function getOperatingSystem: string;
var
osVersionInfo:TOSVersionInfo;
majorVersion,minorVersion:dword;
begin
  Result:='Unknown';
  osVersionInfo.dwOSVersionInfoSize:=SizeOf(TOSVersionInfo);
 
  if GetVersionEx(osVersionInfo) then
  begin
 
    majorVersion:=osVersionInfo.dwMajorVersion;
    minorVersion:=osVersionInfo.dwMinorVersion;
 
    if (majorVersion=10) and (minorVersion=0) then Result:='Windows 10'
 
    else if (majorVersion=6) and (minorVersion=3) then Result:='Windows 8.1'
 
    else if (majorVersion=6) and (minorVersion=2) then Result:='Windows 8'
 
    else if (majorVersion=6) and (minorVersion=1) then Result:='Windows 7'
 
    else if (majorVersion=6) and (minorVersion=0) then Result:='Windows vista'
 
    else if (majorVersion=5) and (minorVersion=1) then Result:='Windows xp'
  end;
end;
 
var
SO:string;
begin
//uso de la funcion
SO:=getOperatingSystem;
writeln('Sistema operativo actual: ',SO);//Nos muestra el S.O
readln;
end.


Funcion para buscar la posicion de una cadena dentro de otra
Código
uses
 SysUtils;
 
 
function StringInStr(const Cadena,Buscar:string):integer;
var
i,pos,fin:integer;
begin
 pos:=1; fin:=-1;
 if length(Cadena)>=length(Buscar) then
 begin
   for i :=1  to length(Cadena) do
   begin
     if  Cadena[i]=Buscar[pos] then
     begin
 
       if pos=length(Buscar) then
       begin
          fin:=i-length(Buscar)+1;
          Break;
       end;
       inc(pos);
     end;
 
   end;
 end;
result:=fin;
end;
 
var
cadena:integer;
begin
//uso de la funcion
cadena:=StringInStr('lAHola mundo','la');
writeln('Posion de m en la cadena ',cadena);//Nos regresa la posion 5
readln;
end.
 


Unit para cifrar y descifrar una cadena el autor es Scorpio pero la hizo en autoit
asi que yo le hice la traduccion a Delphi


Código
unit sAlakran;
 
interface
uses StrUtils,SysUtils;
 
function sCipher(text,key:string):string;
function sUnCipher(text,key:string):string;
 
implementation
 
function asc(letras:string):integer;
begin
  if length(letras)>=1 then
     result:=ord(letras[1])
  else
    result:=0;
end;
 
function sCipher(text,key:string):string;
var
i,j,seed:integer;
sfinal:String;
begin
  sfinal:=''; seed:=0;
 
  for i :=1  to  length(key) do
  begin
    seed:=(seed+asc(key)) * length(key);
    key:=AnsiMidStr(key,2,length(key)-1);
  end;
 
  for j:=1 to length(text) do
  begin
    sfinal:=sfinal+IntToStr((ord(text[1])+seed));
    text:= AnsiMidStr(text,2,length(text));
  end;
 
  result:=sfinal;
end;
 
 
function sUnCipher(text,key:string):string;
var
seed,step,tamano,i,j:integer;
sfinal:string;
begin
  seed:=0; sfinal:='';
 
  for i :=1  to length(key) do
  begin
    seed:=(seed+asc(key))*length(key);
    key:=AnsiMidStr(key,2,length(key)-1);
  end;
 
  step:=length(inttostr(seed));
  j:=step;
  tamano:=length(text);
 
  while(j<=tamano) do
  begin
     sfinal:=sfinal+chr(strtoint(AnsiLeftStr(text,step))-seed);
     text:= AnsiMidStr(text,step+1,length(text));
     j:=j+step;
  end;
  result:=sfinal;
end;
 
end.
 

uso:
Código
uses
 SysUtils,
 sAlakran in 'sAlakran.pas';
 
var
cadena:string;
begin
//uso de la funcion
cadena:=sCipher('hola mundo45','12');
writeln('la cadena cifrada es  ',cadena);//Nos regresa la posion 5
cadena:=sUnCipher(cadena,'12');
writeln('la cadena descifrada es ',cadena);
readln;
end.
 

crack81:
Funcion hecha en delphi para hacer operaciones matematicas como la suma,resta,multiplciacion y potencia
utilizando string

Ejemplo tenemos la operacion ---------->(5*3)+(2^4)-(2*-3) en vez de estar realizando la operacion paso por paso la metemos dentro de un string y la evaluamos directamente
con nuestra funcion y dara el resultado correcto

al utilizar la funcion es necesario especificar los operadores aritmeticos porque sino dara error
abajo les dejo un ejemplo de su uso


Código
program Project2;
{$APPTYPE CONSOLE}
{$WriteableConst On}//esta directiva es necearia para modificar constantes
 
uses
 SysUtils,Math;
 
 
// Grammar:
       // expression = term | expression `+` term | expression `-` term
       // term = factor | term `*` factor | term `/` factor | term brackets
       // factor = brackets | number | factor `^` factor
       // brackets = `(` expression `)`
 
//Esta funcion utliza recursividad mutua
 
 
function EvaluarString(const str:string):double;
const
pos:integer=0;//inicia en cero para despues convertirse en 1
var
c:integer;
procedure eatChar; //va obteniendo caracter por caracter excepto los vacios
begin
 inc(pos);
 if pos<=length(str) then c:=ord(str[pos])
 else c:=0;
end;
procedure eatSpace; //come los espacions en blanco
begin
 while c=32 do eatChar;
end;
function parseExpresion:double; forward; //prototipo de la funcion
function parseTerm:double; forward;  //prototipo de la funcion
function parseFactor:double; forward;  //prototipo de la funcion
function parse:double;
var
v:double;
begin
 eatChar();
 v:=parseExpresion();
 
 if c<>0 then
 begin
   writeln('Error en el simbolo ',char(c));
   Result:=0.0;
   Exit;
 end;
 Result:=v;
end;
function parseExpresion:double;
var
v:double;
begin
  v:=parseTerm();
 
  while(true)do
  begin
 
    eatSpace();
 
    if c=ord('+') then //suma
    begin
      eatChar();
      v:=v+parseTerm();
    end
    else if c=ord('-') then  //resta
    begin
      eatChar();
      v:=v-parseTerm();
    end
    else
    begin
      Result:=v;
      break;//necesario si no entra en un bucle sin fin
    end;
  end;
end;
function parseTerm:double;
var
v:double;
begin
 v:=parseFactor();
 while True do
 begin
   eatSpace();
 
   if c=ord('/') then
   begin
     eatChar;
     v:=v/parseFactor;
   end
   else if((c=ord('*')) or (c=ord('('))) then  //multiplicacion
   begin
      if c=ord('*') then eatChar;
      v:=v*parseFactor();
   end
   else
   begin
     Result:=v;
     break;//necesario si no entra en un bucle sin fin
   end;
 end;
end;
function parseFactor:double;
var
v:double;
negate:boolean;
sb:string;
begin
 negate:=false;
 eatSpace;
 
 if c=ord('(') then
 begin
   eatChar;
   v:=parseExpresion;
 
   if c=ord(')') then eatChar;
 end
 else   //numeros
 begin
   if ((c=ord('+')) or (c=ord('-'))) then  //simbolos unarios positivo y negativo
   begin
     negate:=c=ord('-');
     eatChar;
     eatSpace;
   end;
 
   sb:='';
   while (((c>=ord('0'))and (c<=ord('9'))) or (c=ord('.'))) do
   begin
     sb:=sb+chr(c);
     eatChar;
   end;
 
 
   if length(sb)=0 then
   begin
     writeln('Error no existen caracterese en sb');
     result:=0.0;
     Exit;
   end;
 
   v:=strtofloat(sb);
 end;
 eatSpace;
 if c=ord('^') then  //exponente
 begin
   eatChar;
   v:=Math.Power(v,parseFactor);
 end;
 
 if negate then v:=-v;
 result:=v;
end;
begin
 result:=parse();//retorna la operacion
end;
 
 
var
e:double;
begin
 //Ejemplo de uso
 e:=EvaluarString('(5*3)+(5^2)');  //evaluar expresion
 writeln(e:0:2);//resultado 40
 readln;
end.

crack81:
Funcion para convetir  de string a hexadecimal y viceversa

Código
uses
 SysUtils;
 
function stringToHex(const data:string):string;
var
i:integer;
sfinal:String;
begin
 sfinal:='';
 
 for i:=0 to length(data) do
 begin
   sfinal:=sfinal+IntToHex(ord(data[i]),2);
 end;
 result:=sfinal;
end;
 
 
function hexTostring(const data:string):string;
var
i:integer;
sfinal:String;
begin
 i:=1;
 sfinal:='';
 
 if(length(data)mod 2<>0)then
 begin
   Result:='';
   Exit;
 end;
 
 while(i<=length(data))do
 begin
   sfinal:=sfinal+chr(strtoint('$'+(Copy(data,i,2))));
   i:=i+2;
 end;
 result:=sfinal;
end;
 
var
str,normal:String;
begin
str:=stringToHex('hola mundo');
writeln('En hexadecimal es ',str);
normal:=hexTostring(str);
writeln('lo regresamos a la normalidad ',normal);
readln;
end.
 

Funcion renombrar archivos el autor original es Elektro yo solo le hice la traduccion

Código
function renameFile(_File:string;NewFilename:string;NewFileExtension:string=''):boolean;
begin
 if FileExists(_File) then
 begin
   try
     if NewFileExtension='' then
       MoveFile(pchar(_File),pchar(ExtractFilePath(_File)+NewFilename+ExtractFileExt(_File)))
     else
       MoveFile(pchar(_File),pchar(ExtractFilePath(_File)+NewFilename+'.'+NewFileExtension));
   except
     on E:Exception do
       result:=False;
   end;
 end
 else
   Result:=False;
end;
 

crack81:
Funcion para obtener la arquitectura del sistema operativo

Código
function getArchitecture:string;
var
sysInfo:SYSTEM_INFO;
begin
  GetSystemInfo(sysInfo);
  case sysInfo.wProcessorArchitecture of
    0:result:='x86';
    9:result:='x64';
    else result:='unknown';
  end;
end;

Funcion para obtener el numero de procesadores

Código
function numberOfProcessors:Dword;
var
sysInfo:SYSTEM_INFO;
begin
  GetSystemInfo(sysInfo);
  result:=sysInfo.dwNumberOfProcessors;
end;


Funcion para obtener el tipo de procesador

Código
function ProcessorType:string;
var
sysInfo:SYSTEM_INFO;
begin
  GetSystemInfo(sysInfo);
  case sysInfo.dwProcessorType of
    220:result:='PROCESSOR_INTEL_IA64';
    386:result:='PROCESSOR_INTEL_386';
    486:result:='PROCESSOR_INTEL_486';
    586:result:='PROCESSOR_INTEL_PENTIUM_586';
    8664:result:='PROCESSOR_AMD_X8664';
    else result:='Unknown';
  end;
end;

Esta ultima funcion segun microsoft deberia estar obsoleta
no olviden añadir el use windows para poder usar las funciones

ejemplo de uso

Código
begin
  writeln('Arquitectura de la computadora ',getArchitecture()); //en mi caso x86
  writeln('Numero de procesadores ',numberOfProcessors());
  writeln('Tipo de procesador ', ProcessorType());//esta funcion deberia estar obsoleta
  readln;
end.
 

crack81:
Funcion para saber si un numero esta en un rango entre dos numeros,
si es cierto retorna true sino retorna false

Código
function numberIsInRange(const number,min,max:integer):boolean;
begin
result:=((min<=number) and (number<=max));
end;
 
begin
   writeln(numberIsInRange(5,1,100);  //muestra true
   writeln(numberIsInRange(0,55,98);  //muestra false
   writeln(numberIsInRange(25,55,98); //muestra true
   Readln;
end.
 

Funcion que muestra los tamaños maximos de los diferentes tipos de entero
en Delphi, el enfoque principal son las funciones low y High que son las
encargadas de retornarnos ese valor, esto solo es valido con numeros enteros
y no con reales

Código
procedure sizeMaxOfDataType;
begin
 writeln('Byte    -> ',low(Byte),' to ',high(Byte));
 writeln('Integer -> ',low(integer),' to ',high(integer));
 writeln('Int64   -> ',low(Int64),' to ',high(Int64));
 writeln('LongInt -> ',low(LongInt),' to ',high(LongInt));
 writeln('Longword -> ',low(Longword),' to ',high(Longword));
 writeln('Word -> ',low(Word),' to ',high(Word));
end;


Funciones una para leer archivos .exe y almacenarlo como string y la otra para poder convertir strings a .exe
utilizando la clase Tfilestream

Código
uses
 SysUtils,classes;
 
{
Funcion que lee un fichero y lo convierte a string el caso mas comun es
cuando necesitas leer un exe y hacer alguna modifcacion como cifrarlo o
alterar su informacion la funcion necesita el use classes para poder llamar a
la clase Tfilestream
 
}
function binaryToString(const path:string):String;
var
_File:TFileStream;
size:Int64;
begin
 if FileExists(path) then
 begin
   _File:=TFileStream.Create(path,fmOpenRead);
   try
     size:=_File.Size;
     SetLength(result,size);
     _File.Read(result[1],size);
   finally
     _File.Free;
   end;
 end
 else result:='';
end;
 
 
{Funcion para crear un fichero en base a un string que le pasemos, esta
 funcion se usa en conjunto con la anterior ya que despues de leer y modificar
 un fichero necesitamos volver a regresarlo a un estado de fichero  por eso la
 necesidad de esta funcion.
}
function stringToBinary(const nameExe,source:string):Boolean;
var
_File:TFileStream;
begin
 result:=false;
 _File:=TFileStream.Create(nameExe,fmCreate);
 try
   _File.Write(source[1],length(source));
 finally
   _File.Free;
 end;
 
 result:=true;
end;
 
var
source:string;
begin
   source:=binaryToString('C:\archivo.exe');
   stringToBinary('C:\nuevoArchivo.exe',source);
   writeln('listo');
   Readln;
end.
 

Navegación

[0] Índice de Mensajes

[#] Página Siguiente