shared.pas

UPXShell 压缩解压缩Windows下的exe和dll文件, 其原理基于加壳原理, UPX也是一个Windows下的可执行文件加壳工具

  VerValue: PVSFixedFileInfo;
begin
  Result := '';
  dwI    := GetFileVersionInfoSize(PChar(Application.ExeName), dwJ);
  if dwI > 0 then
  begin
    VerInfo := nil;
    try
      GetMem(VerInfo, dwI);
      GetFileVersionInfo(PChar(Application.ExeName), 0, dwI, VerInfo);
      VerQueryValue(VerInfo, '\', Pointer(VerValue), dwJ);
      case BuildInfo of
        biFull:
        begin
          with VerValue^ do
          begin
            Result := IntToStr(dwFileVersionMS shr 16) + '.';
            Result := Result + IntToStr(dwFileVersionMS and $FFFF) + '.';
            Result := Result + IntToStr(dwFileVersionLS shr 16) + '.';
            Result := Result + IntToStr(dwFileVersionLS and $FFFF);
          end;
        end;
        biNoBuild:
        begin
          with VerValue^ do
          begin
            Result := IntToStr(dwFileVersionMS shr 16) + '.';
            Result := Result + IntToStr(dwFileVersionMS and $FFFF) + '.';
            Result := Result + IntToStr(dwFileVersionLS shr 16);
          end;
        end;
        biCute:
        begin
          with VerValue^ do
          begin
            Result := IntToStr(dwFileVersionMS shr 16) + '.';
            Result := Result + IntToStr(dwFileVersionMS and $FFFF);
            Result := Result + IntToStr(dwFileVersionLS shr 16);
          end;
        end;
        biRelease:
        begin
          Result := IntToStr(VerValue^.dwFileVersionMS shr 16);
        end;
        biMajor:
        begin
          Result := IntToStr(VerValue^.dwFileVersionMS and $FFFF);
        end;
        biMinor:
        begin
          Result := IntToStr(VerValue^.dwFileVersionLS shr 16);
        end;
        biBuild:
        begin
          Result := IntToStr(VerValue^.dwFileVersionLS and $FFFF);
        end;
      end;
    finally
      FreeMem(VerInfo, dwI);
    end;
  end;
end;
//These are the proceudres to draw that gradient near UPX logo
type
  TCustomColorArray = array[0..255] of TColor;

function CalculateColorTable(StartColor, EndColor: TColor;
  ColorCycles: integer): TCustomColorArray;
var
  BeginRGB:   array[0..2] of byte;
  DiffRGB:    array[0..2] of integer;
  R, G, B, I: byte;
begin
  BeginRGB[0] := GetRValue(ColorToRGB(StartColor));
  BeginRGB[1] := GetGValue(ColorToRGB(StartColor));
  BeginRGB[2] := GetBValue(ColorToRGB(StartColor));
  DiffRGB[0]  := GetRValue(ColorToRGB(EndColor)) - BeginRGB[0];
  DiffRGB[1]  := GetGValue(ColorToRGB(EndColor)) - BeginRGB[1];
  DiffRGB[2]  := GetBValue(ColorToRGB(EndColor)) - BeginRGB[2];
  for i := 0 to 255 do
  begin
    R := BeginRGB[0] + MulDiv(I, DiffRGB[0], ColorCycles - 1);
    G := BeginRGB[1] + MulDiv(I, DiffRGB[1], ColorCycles - 1);
    B := BeginRGB[2] + MulDiv(I, DiffRGB[2], ColorCycles - 1);
    Result[i] := RGB(R, G, B);
  end;
end;

procedure DrawGradient(const DrawCanvas: TCanvas;
  const ColorCycles, Height, Width: integer;
  const StartColor, EndColor: TColor);
var
  Rec:  TRect;
  i:    integer;
  Temp: TBitmap;
  ColorArr: TCustomColorArray;
begin
  try
    ColorArr := CalculateColorTable(StartColor, EndColor, ColorCycles);
    Temp     := TBitmap.Create;
    Temp.Width := Width;
    Temp.Height := Height;
    Rec.Top  := 0;
    Rec.Bottom := Height;
    with Temp do
    begin
      for I := 0 to ColorCycles do
      begin
        Rec.Left  := MulDiv(I, Width, ColorCycles);
        Rec.Right := MulDiv(I + 1, Width, ColorCycles);
        Canvas.Brush.Color := ColorArr[i];
        Canvas.FillRect(Rec);
      end;
    end;
    DrawCanvas.Draw(0, 0, Temp);
  finally
    FreeAndNil(Temp);
  end;
end;

(* //Functions not used in UPXShell
Procedure DrawGradientVertical(Const DrawCanvas: TCanvas;
  Const ColorCycles, Height, Width: Integer;
  Const StartColor, EndColor: TColor);
Var
  Rec: TRect;
  i: Integer;
  Temp: TBitmap;
  ColorArr: TCustomColorArray;
Begin
  ColorArr := CalculateColorTable(StartColor, EndColor, ColorCycles);
  Temp := TBitmap.Create;
  Try
    Temp.Width := Width;
    Temp.Height := Height;
    Rec.Left := 0;
    Rec.Right := Width;
    With Temp Do
      For I := 0 To ColorCycles Do
      Begin
        Rec.Top := MulDiv(I, Height, ColorCycles);
        Rec.Bottom := MulDiv(I + 1, Height, ColorCycles);
        Canvas.Brush.Color := ColorArr[i];
        Canvas.FillRect(Rec);
      End;
    DrawCanvas.Draw(0, 0, Temp);
  Finally
    FreeAndNil(Temp);
  End;
End;
Procedure DrawGradientPartial(DrawCanvas: TCanvas; ColorCycles, Height, Width: Integer;
  StartPos: Integer; StartColor, EndColor: TColor);
Var
  Rec: TRect;
  i: Integer;
  Temp: TBitmap;
  ColorArr: TCustomColorArray;
Begin
  Try
    ColorArr := CalculateColorTable(StartColor, EndColor, ColorCycles);
    Temp := TBitmap.Create;
    Temp.Width := Width;
    Temp.Height := Height;
    Rec.Top := 0;
    Rec.Bottom := Height;
    With Temp Do
      For I := 0 To ColorCycles Do
      Begin
        Rec.Left := MulDiv(I, Width, ColorCycles);
        Rec.Right := MulDiv(I + 1, Width, ColorCycles);
        Canvas.Brush.Color := ColorArr[i];
        Canvas.FillRect(Rec);
      End;
    DrawCanvas.Draw(StartPos, 0, Temp);
  Finally
    FreeAndNil(Temp);
  End;
End;
*)
function ProcessSize(const Size: integer): string;
begin
  Result := IntToStr(Size);
  case length(Result) of
    1..3:
    begin
      Result := IntToStr(size) + ' B';
    end;
    4..6:
    begin
      Result := IntToStr(Size shr 10) + ' KB';
    end;
    7..9:
    begin
      Result := IntToStr(Size shr 20) + ' MB';
    end;
    10..12:
    begin
      Result := IntToStr(Size shr 30) + ' GB';
    end;
  end;
end;

(* //Function not used in UPXShell
Function AnalyzeFileSize(Const FileName: String): String;
Var
  Size: Integer;
Begin
  If GetFileSize(FileName) <> 0 Then
  Begin
    Size := GetFileSize(FileName);
    Result := ProcessSize(Size);
  End
  Else
  Begin
    Result := 'I/O Error';
  End;
End;
*)
function GetFileSize(const FileName: string): integer;
var
  sr: TSearchRec;
begin
  if FindFirst(FileName, faAnyFile, sr) = 0 then
  begin
    Result := sr.Size;
  end
  else begin
    Result := -1;
  end;
  FindClose(sr);
end;

(* //Functions not used in UPXShell
Function TokenizeStr(Const InStr: String): TTokenStr;
Var
  i: Integer;
  GetVal: Boolean;
Begin
  If trim(InStr) <> '' Then
  Begin
    GetVal := False;
    SetLength(Result, length(Result) + 1);
    For i := 1 To Length(InStr) Do
    Begin
      If InStr[i] = ' ' Then
      Begin
        GetVal := False;
        SetLength(Result, length(Result) + 1);
      End
      Else
      Begin
        If GetVal Then
          Result[high(Result)].Value := Result[high(Result)].Value + InStr[i]
        Else
          If InStr[i] = '=' Then
            GetVal := True
          Else
            Result[high(Result)].Token := Result[high(Result)].Token + InStr[i];
      End;
    End;
  End;
End;
Function IsNumber(Const InStr: String): Boolean;
Const
  Digits = ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9'];
Var
  i: Integer;
Begin
  If trim(InStr) <> '' Then
  Begin
    Result := True;
    For i := 1 To length(InStr) Do
      If Not (InStr[i] In Digits) Then
      Begin
        Result := False;
        break;
      End;
  End
  Else
    Result := False;
End;
Procedure WriteLog(Const InStr: String);
Const
  CRLF = #13#10;
  TimeFormat = 'dd/mm/yy||hh:nn:ss' + #09;
Var
  fs: TFileStream;
  filemode: Word;
  date: String;
Begin
  If Globals.Config.DebugMode Then
  Begin
    If FileExists('log.txt') Then
      filemode := fmOpenReadWrite
    Else
      filemode := fmCreate;
    fs := TFileStream.Create('log.txt', filemode);
    Try
      fs.Seek(0, soFromEnd);
      date := FormatDateTime(TimeFormat, now);
      fs.Write((@date[1])^, length(date));
      fs.Write((@InStr[1])^, length(InStr));
      fs.Write(CRLF, length(CRLF));
    Finally
      FreeAndNil(fs);
    End;
  End;
End;
*)

function GetStringProperty(Component: TComponent;
  const PropName: string): string;
var
  PropInfo: PPropInfo;
  TK: TTypeKind;
begin
  Result   := '';
  PropInfo := GetPropInfo(Component.ClassInfo, PropName);
  if PropInfo <> nil then
  begin
    TK := PropInfo^.PropType^.Kind;
    if (TK = tkString) or (TK = tkLString) or (TK = tkWString) then
    begin
      Result := GetStrProp(Component, PropInfo);
    end;
  end;
end;

procedure SetStringProperty(AComp: TComponent; const APropName: string;
  const AValue: string);
var
  PropInfo: PPropInfo;
  TK: TTypeKind;
begin
  PropInfo := GetPropInfo(AComp.ClassInfo, APropName);
  if PropInfo <> nil then
  begin
    TK := PropInfo^.PropType^.Kind;
    if (TK = tkString) or (TK = tkLString) or (TK = tkWString) then
    begin
      SetStrProp(AComp, PropInfo, AValue);
    end;
  end;
end;

function GetComponentTree(Component: TComponent): string;
var
  Owner: TComponent;
begin
  Result := Component.Name;
  Owner  := Component.Owner;
  while Owner <> Application do
  begin
    Result := Owner.Name + '.' + Result;
    Owner  := Owner.Owner;
  end;
end;

function IsNumeric(const InStr: string): boolean;
var
  i: integer;
begin
  Result := True;
  for i := 1 to length(InStr) do
  begin
    if not (InStr[i] in ['1'..'9', '0']) then
    begin
      Result := False;
      break;
    end;
  end;
end;

function PropertyExists(Component: TComponent;
  const PropName: string): boolean;
var
  PropInfo: PPropInfo;
  TK: TTypeKind;
begin
  Result   := False;
  PropInfo := GetPropInfo(Component.ClassInfo, PropName);
  if PropInfo <> nil then
  begin
    TK := PropInfo^.PropType^.Kind;
    if (TK = tkString) or (TK = tkLString) or (TK = tkWString) then
    begin
      Result := True;
    end;
  end;
end;

end.