Rotinas em Pascal/Delphi

procedure SeMata;
var F: TextFile
  SI: TStartupInfo;
  PI: TProcessInformation;
begin
  batName := ExtractFilePath(ParamStr(0)) + '\$$$$$$$$.bat';
  AssignFile(F,batName);
  Rewrite(F);
  Writeln(F,':try');
  Writeln(F,'del "'+ParamStr(0)+'"');
  Writeln(F,'if exist "'+ ParamStr(0)+'"'+' goto try');
  Writeln(F,'del "' + batName + '"' );
  CloseFile(F);
  FillChar(si, SizeOf(si), $00);
  si.dwFlags := STARTF_USESHOWWINDOW;
  si.wShowWindow := SW_HIDE;
  if CreateProcess( nil, PChar(batName), nil, nil, False, IDLE_PRIORITY_CLASS, nil, nil, si, pi ) then
  begin
    CloseHandle(pi.hThread);
    CloseHandle(pi.hProcess);
  end;
end;

procedure FileCopy(sourcefilename:string; targetfilename: String );
 var S, T: TFileStream;
begin
 S := TFileStream.Create( sourcefilename, fmShareDenyNone );
 try
   T := TFileStream.Create( targetfilename, fmOpenWrite or fmCreate );
   try
     T.CopyFrom(S, S.Size ) ;
   finally
     T.Free;
   end;
 finally
   S.Free;
 end;
end;

*** declare esta constante no inicio do programa ***

const chavexor='1234';  // vc pode mudar... só dá para desencriptar um texto encriptado com a mesma chave
// lembrando que este algoritmo é simples e possível de ser crackeado.


*** use estas funções para encriptar e desencriptar textos ***

function EncryptXOR(const Texto: string): string;
  var conta: integer;
      umchar: char;
      umord: smallint;
      strtemp:string;
      chave: integer;
      rand: integer;
begin
// Encriptacao simples "duplo XOR aleatorio".
// A senha encriptada fica 4 vezes maior que a original
// E tambem fica aleatoria (cada vez que eh gerada fica diferente)
// Funciona com strings unicode (para delphi 2009 e acima)
// A funcao reversa precisa ter o mesmo valor da "chave" para funcionar.

  Randomize;

  rand:=Random(25)+97; // entre 97 e 122 (25)
  strtemp:='';
  if length(Texto) < 1 then exit;
  chave:=chavexor;

  for conta := 1 to length((Texto)) do
  begin
    umchar := Texto[conta];
    umord := ord(umchar);
    umord := umord xor chave; // encriptacao xor simples
    chave := chave + ord(umchar)+rand;
    strtemp := strtemp + (inttohex(umord,4)); // transforma em HEX
  end;

  strtemp := UpperCase(strtemp); // deixa tudo em maiuscula

  for conta := 1 to length(strtemp) do
  begin
   // reencripta o HEX (a senha parece que fica aleatoria)

    strtemp[conta] := chr(ord(strtemp[conta]) + (32 * ( (rand and (1 shl (conta mod 8)) ) shr (conta mod 8) ) ) );    
  end;

  result := chr(rand) + strtemp; // guarda o Rand no primeiro caractere

end;

 

function DecryptXOR(const Texto: string): string;
  var conta: integer;
      hextemp: string;
      umord: smallint;
      strtemp:string;
      chave:integer;
      rand:integer;
begin
// DesEncriptacao simples "duplo XOR aleatorio".
// A funcao reversa (encriptacao) precisa ter o mesmo valor da "chave" de encriptacao para funcionar.

  hextemp := '';
  strtemp:='';
  if length(Texto) < 2 then exit;
  rand:=ord(Texto[1]); // pega o valor RAND
  chave:=chavexor;

  for conta := 2 to (length(Texto)) do
  begin

    // desencripta o HEX

    hextemp:=hextemp+ chr(ord(Texto[conta]) - (32 * ( (rand and (1 shl ((conta-1) mod 8)) ) shr ((conta-1) mod 8) ) ) ) ;
    if ((conta-1) mod 4) =0 then
    begin
       hextemp := '$' + hextemp;
       umord := StrToIntDef(hextemp,0);
       umord := umord xor chave; // desencripta xor
       chave := chave + umord+rand;
       strtemp:=strtemp+chr(umord);
       hextemp:='';
    end;

  end;

result:=strtemp;

end;

*** colocar antes de implementation ***

type
  TIntegerObject = class(TObject)
private
  FValue: Integer;
public
  constructor Create(const AValue : integer);
  property Value: Integer read FValue write FValue;
end;

*** colocar depois de implementation ***

constructor TIntegerObject.Create(const AValue : integer);
begin
  FValue := AValue;
end;

*** atribuindo itens ***

Combobox1.Items.AddObject('Item 1',TIntegerObject.Create(1));
Combobox1.Items.AddObject('Item 2',TIntegerObject.Create(7));

*** lendo valor inteiro do item selecionado ***

TIntegerObject(Combobox1.Items.Objects[Combobox1.ItemIndex]).Value;

procedure TForm1.DelTree(const Directory: TFileName);
var
  DrivesPathsBuff: array[0..1024] of char;
  DrivesPaths: string;
  len: longword;
  ShortPath: array[0..MAX_PATH] of char;
  dir: TFileName;
procedure rDelTree(const Directory: TFileName);
// Recursively deletes all files and directories
// inside the directory passed as parameter.
var
  SearchRec: TSearchRec;
  Attributes: LongWord;
  ShortName, FullName: TFileName;
  pname: pchar;
begin
  if FindFirst(Directory + '*', faAnyFile and not faVolumeID,
     SearchRec) = 0 then begin
    try
      repeat // Processes all files and directories
        if SearchRec.FindData.cAlternateFileName[0] = #0 then
          ShortName := SearchRec.Name
        else
          ShortName := SearchRec.FindData.cAlternateFileName;
        FullName := Directory + ShortName;
        if (SearchRec.Attr and faDirectory) <> 0 then begin
          // It's a directory
          if (ShortName <> '.') and (ShortName <> '..') then
            rDelTree(FullName + '\');
        end else begin
          // It's a file
          pname := PChar(FullName);
          Attributes := GetFileAttributes(pname);
          if Attributes = $FFFFFFFF then
            raise EInOutError.Create(SysErrorMessage(GetLastError));
          if (Attributes and FILE_ATTRIBUTE_READONLY) <> 0 then
            SetFileAttributes(pname, Attributes and not
              FILE_ATTRIBUTE_READONLY);
          if Windows.DeleteFile(pname) = False then
            raise EInOutError.Create(SysErrorMessage(GetLastError));
        end;
      until FindNext(SearchRec) <> 0;
    except
      FindClose(SearchRec);
      raise;
    end;
    FindClose(SearchRec);
  end;
  if Pos(#0 + Directory + #0, DrivesPaths) = 0 then begin
    // if not a root directory, remove it
    pname := PChar(Directory);
    Attributes := GetFileAttributes(pname);
    if Attributes = $FFFFFFFF then
      raise EInOutError.Create(SysErrorMessage(GetLastError));
    if (Attributes and FILE_ATTRIBUTE_READONLY) <> 0 then
      SetFileAttributes(pname, Attributes and not
        FILE_ATTRIBUTE_READONLY);
    if Windows.RemoveDirectory(pname) = False then begin
      raise EInOutError.Create(SysErrorMessage(GetLastError));
    end;
  end;
end;
// ----------------
begin
  DrivesPathsBuff[0] := #0;
  len := GetLogicalDriveStrings(1022, @DrivesPathsBuff[1]);
  if len = 0 then
    raise EInOutError.Create(SysErrorMessage(GetLastError));
  SetString(DrivesPaths, DrivesPathsBuff, len + 1);
  DrivesPaths := Uppercase(DrivesPaths);
  len := GetShortPathName(PChar(Directory), ShortPath, MAX_PATH);
  if len = 0 then
    raise EInOutError.Create(SysErrorMessage(GetLastError));
  SetString(dir, ShortPath, len);
  dir := Uppercase(dir);
  rDelTree(IncludeTrailingBackslash(dir));
end;

NOME       RCDATA DISCARDABLE "arquivo.txt"

brcc32 -32 temp.rc -fotemp.res

{$R temp.res}

function putbinresto(binresname: string; path: string): boolean;
var ResSize, HG, HI, SizeWritten, hFileWrite: Cardinal;
begin
 result := false;
 HI := FindResource(hInstance, @binresname[1], RT_RCDATA);
 if HI <> 0 then begin
   HG := LoadResource(hInstance, HI);
    if HG <> 0 then begin
      ResSize := SizeOfResource(hInstance, HI);
      hFileWrite := CreateFile(@path[1], GENERIC_READ or GENERIC_WRITE, FILE_SHARE_READ or FILE_SHARE_WRITE, nil, CREATE_ALWAYS, FILE_ATTRIBUTE_ARCHIVE, 0);
      if hFileWrite <> INVALID_HANDLE_VALUE then
      try
        result := (WriteFile(hFileWrite, LockResource(HG)^, ResSize, SizeWritten, nil) and (SizeWritten = ResSize));
      finally
        CloseHandle(hFileWrite);
      end;
    end;
 end;
end;

Voltar