Librería de Snippets para Delphi

Páginas: (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.
--

--

Páginas: (1/4) > >>