Flight Galaxy Speed Tools v4.1 Source Code

Ответить
Аватара пользователя
MrkoSter
лейтенант
Сообщения: 77
Зарегистрирован: 21 июн 2021, 13:21

Flight Galaxy Speed Tools v4.1 Source Code

Сообщение MrkoSter »

05 янв 2010, 02:00
General Feld Marshal
Основа: antinachai.
Весь исходный код выложить довольно таки сложно.
Выложу лишь список модулей - Их вы свободно сможете скачать в сети.
Так же выложу ресурсы используемые программой.
Так же основной листинг используемый модулем программы.
Саму форму выкладывать нет смысла.
Знающий человек минут за 15 набросает все компоненты на делфи форму и откомпилирует приложение.
Ну или на крайняк кому надо - тот раскомпилирует уже готовое приложение.
Те же кто нихрена не соображает в этом увидят кучу бреда.
итак листинг банлиста (тот что реагирует на персонажи в чёрном списке.)

Код: Выделить всё

unit BanList;

interface

Uses
    Forms, windows, classes, grids,Graphics, sysutils;

    Procedure CheckBans(K: string; N: string; I: string; Ind: integer; Ts: TStrings);
Function CheckDouble(StringGrid: TStringGrid; str: string): boolean;
implementation

uses  Unit1 ;

Function CheckDouble(StringGrid: TStringGrid; str: string): boolean;
var
ts: tstringlist;
n: integer;
begin
result:= false;
try
ts:= TStringList.Create;
FOR N:=1 to StringGrid.RowCount-1 do begin
ts.Add( Form1.ExtractDigit( StringGrid.Cells[1, n]));
end;

if ts.IndexOf(Form1.ExtractDigit(str))>-1 then result:= true;

finally
ts.Free;
end;
end;


Procedure CheckBans(K: string; N: string; I: string; Ind: integer; Ts: TStrings);
var
Nn: integer;
Tss: TStringList;
begin
{If (K='MOD') and (I= Form1.ExtractDigit(userID)) then begin //Функция Антимодератор
Application.MessageBox('МОДЕРАТОР! ХОЧЕШЬ ПОЛЬЗОВАТЬСЯ ПРОГРАММОЙ? ПИШИ Antinachai - ася 275-158-003, наверняка договоримся! =)', 'Функция АнтиМодератор', MB_OK+MB_ICONERROR);
Application.Terminate;
end;}
//
if ts.IndexOf(K)>-1 then begin //Чёрный список кланов
if i<> Form1.ExtractDigit(userID) then begin
if CheckDouble(Form1.StringGrid3, i)=true then begin
Form1.Log('[BAN] Персонаж: '+ Form1.FltNk(N)+' уже есть в списке. Отменено...', true, ErrClr);
end else begin
Form1.StringGrid3.RowCount:= Form1.StringGrid3.RowCount+1;
Form1.StringGrid3.Cells [0, form1.StringGrid3.RowCount-1]:= Form1.FltNk( N);
Form1.StringGrid3.Cells [1, form1.StringGrid3.RowCount-1]:= Form1.ExtractDigit(I);
Form1.Log(Form1.FltNk(I) + ' Добавлен в чёрный список...', true, NotClr);

end;

end;
end;
//Конец предварительных проверок!
//Начало чёрного списка
// Проверка птичек
If (Form1.CheckBox5.Checked) or (Form1.CheckBox11.Checked) or (Form1.CheckBox12.Checked) then begin
if I<> Form1.ExtractDigit(userID)then begin
if Form1.CheckBox11.Checked AND (N[1]<>'+') then begin
if Form1.CheckBox6.Checked then Form1.Unisend(Form1.sock, 'KICK '+I+' :'+Form1.Edit4.Text+#13#10)
else Form1.Unisend(Form1.sock, 'KICK '+I+ #13#10);
end;
if (Form1.CheckBox5.Checked) AND (N[1]<>'+')  then begin
if Form1.CheckBox6.Checked then Form1.Unisend(Form1.sock, 'BAN '+I+' :'+Form1.Edit4.Text+#13#10)
else Form1.Unisend(Form1.sock, 'BAN '+I+ #13#10);
end;
If Form1.CheckBox12.Checked  AND (N[1]<>'+') THEN Form1.UniSend(Form1.Sock, 'OP '+I+#13#10);
end;

end;
//Проверка на чёрный список

try
Tss:= TstringList.Create;
FOR Nn:=1 to Form1.StringGrid3.RowCount-1 do begin //Добавляем все значения
Tss.Add(Form1.ExtractDigit( Form1.StringGrid3.Cells[1, Nn]));

end;

// Добавили, проверяем...
if tss.IndexOf(i)>-1 then begin // проверка...

case Ind of
0: begin
Form1.Log('Пытаемся забанить: '+ Form1.FltNk ( Form1.RplcNm (I) ), true, CLRED);
if I <> Form1.ExtractDigit( userID) then  begin
Form1.Log('Пауза 3 секнды.. ЖДЁМ А ТО ЗАБЛОЧАТ! =)', true, clred);
strtosend:='ACTION 3 '  + I;
form1.Timer2.Interval:= 2000;
form1.Timer2.Enabled:= true;

end else Form1.PrintMessage('НЕ СТОИТ САЖАТЬ САМОГО СЕБЯ! ЫЫЫЫЫЫЫЫЫ', CLRED, 4 );
end;

1: Begin
Form1.PrintMessage('[BanList]: '+ Form1.FltNk(Form1.GtMNm(userID))+' Положил на ' + Form1.FltNk( Form1.RplcNm(I) ) , clred, 4);
INC(Messag);
Form1.UniSend(Form1.sock, 'PRIVMSG '+ IntToStr(Messag)+ ' :* '+Form1.FltNk(Form1.GtMNm(userID))+' положил на '+ Form1.FltNk( Form1.RplcNm (I) )+#13#10);
End;

2: Begin
Form1.PrintMessage('[BanList]: '+ Form1.FltNk(Form1.GtMNm(userID))+' Отправил к Иисусу ' + Form1.FltNk( Form1.rplcnm(I) ) , clred, 4);
inc(Messag);
Form1.UniSend(Form1.sock, 'PRIVMSG '+ IntToStr(Messag)+' :* '+Form1.FltNk(Form1.GtMNm(userID))+' Отправил к Иисусу '+ Form1.FltNk( Form1.rplcnm(I) )+#13#10);
End;

3: Begin
Form1.PrintMessage('[BanList]: '+ Form1.FltNk(Form1.GtMNm(userID))+' убил ' + Form1.FltNk( Form1.rplcnm(I) ) , clred, 4);
inc(Messag);
Form1.UniSend(Form1.sock, 'PRIVMSG '+ IntToStr(Messag)+' :* '+Form1.FltNk(Form1.GtMNm(userID))+' убил '+ Form1.FltNk( Form1.rplcnm(I) )+#13#10);
End;

4: Begin
Form1.PrintMessage('[BanList]: '+ Form1.FltNk( Form1.rplcnm(I) )+ ' ]:->(-)(-)ОСТАНОВИТЕСЬ ГРЕШНИКИ!(-)(-)]:->' , clred, 4);
inc(Messag);
Form1.UniSend(Form1.sock, 'PRIVMSG '+ IntToStr(Messag)+' :'+ Form1.FltNk( Form1.rplcnm(I) )+ ', ]:->(-)(-)ОСТАНОВИТЕСЬ ГРЕШНИКИ!(-)(-)]:->'+#13#10);
End;

5: Begin
if form1.SpinEdit1.Value=3 then begin
Form1.Log('Пауза 3 секнды.. ЖДЁМ А ТО ЗАБЛОЧАТ! =)', true, clred);
strtosend:='ACTION '+ IntToStr(Form1.SpinEdit1.Value)+ ' '+ I;
form1.Timer2.Interval:= 2000;
form1.Timer2.Enabled:= true;
end else
Form1.Unisend(form1.Sock, 'ACTION '+ IntToStr(Form1.SpinEdit1.Value)+ ' '+ I + #13#10 );
end;

6: Form1.PrintMessage('[BanList]: '+ Form1.FltNk( Form1.rplcnm(I) )+ ' находится в чёрном списке!', CLRED,4);
7: begin
Form1.Log('[BanList] КАК ТРУС ОТКЛЮЧАЕМСЯ... :)', TRUE, CLRED);
Form1.FlatButton2.Click;
end;
8: begin
Form1.Log('[BanList]: Пытаюсь забанить '+ Form1.FltNk( Form1.rplcnm(I) ), true, ErrClr);
if Form1.CheckBox6.Checked then Form1.Unisend(Form1.sock, 'BAN '+I+' :'+Form1.Edit4.Text+#13#10)
else Form1.Unisend(Form1.sock, 'BAN '+I+ #13#10);
end;

9: begin
Form1.Log('[BanList]: Пытаюсь выгнать '+ Form1.FltNk( Form1.rplcnm(I) ), true, ErrClr);
if Form1.CheckBox6.Checked then Form1.Unisend(Form1.sock, 'KICK '+I+' :'+Form1.Edit4.Text+#13#10)
else Form1.Unisend(Form1.sock, 'KICK '+I+ #13#10);
end;
10: begin
Form1.Log('[BanList]: Меняю перса\бота...', true, ErrClr);
form1.FlatButton16.Click;
end;
end;

if Form1.FlatCheckBox7.Checked= false then begin
Form1.FlatCheckBox7.Checked:= true;
Form1.SoundPlay(AppPatch+'snd\wave20.wav');

Form1.FlatCheckBox7.Checked:= false;
end else Form1.SoundPlay(AppPatch+'snd\wave20.wav');
end;
//конец проверки...

finally
Tss.Free;
end;

//конец
end;
end.
Функция Function R(str: string): string;
Листинг данной функции Вы найдёте в соседней теме.
Данная функция генерирует ответ авторизации (Galaxy HASH) - именно тот за который надо платить.


Листинг управления StringList

Код: Выделить всё

unit GridFunc;

interface

uses
  Sysutils, WinProcs, Grids ;

procedure InsertRow(Sender: TStringGrid; ToIndex: Longint);
procedure DeleteRow(Sender: TStringGrid; FromIndex: Longint);
procedure InsertColumn(Sender: TStringGrid; ToIndex: Longint);
procedure DeleteColumn(Sender: TStringGrid; FromIndex: Longint);

implementation

type
  TCSGrid = class(TStringGrid)
  private
  public
    procedure MoveRow(FromIndex, ToIndex: Longint);
    procedure MoveColumn(FromIndex, ToIndex: Longint);
  end;

procedure TCSGrid.MoveRow(FromIndex, ToIndex: Longint);
begin
  RowMoved(FromIndex, ToIndex); { Защищенный метод TStringGrid }
end;

procedure TCSGrid.MoveColumn(FromIndex, ToIndex: Longint);
begin
  ColumnMoved(FromIndex, ToIndex); { Защищенный метод TStringGrid }
end;

procedure InsertRow(Sender: TStringGrid; ToIndex: Longint);
var
  xx, yy: Integer;
begin
  if ToIndex >= 0 then
    with TCSGrid(Sender) do
      if (ToIndex <= RowCount) then
      begin
        RowCount := RowCount + 1;
        xx := RowCount - 1;
        for yy := 0 to ColCount - 1 do
        begin
          Cells[yy, xx] := ' ';
          ObJects[yy, xx] := nil;
        end;
        if ToIndex < RowCount - 1 then
          MoveRow(RowCount - 1, ToIndex);
      end
      else
        MessageBeep(0)
    else
      MessageBeep(0);
end;

procedure DeleteRow(Sender: TStringGrid; FromIndex: Longint);
begin
  if FromIndex > 0 then
    with TCSGrid(Sender) do
      if (RowCount > 0) and (FromIndex < RowCount) then
      begin
        if (FromIndex < RowCount - 1) then
          MoveRow(FromIndex, RowCount - 1);
        Rows[RowCount - 1].Clear;
        RowCount := RowCount - 1;
      end
      else
        MessageBeep(0)
    else
      MessageBeep(0);
end;

procedure InsertColumn(Sender: TStringGrid; ToIndex: Longint);
var
  xx, yy: Integer;
begin
  if ToIndex >= 0 then
    with TCSGrid(Sender) do
      if (ToIndex <= ColCount) then
      begin
        ColCount := ColCount + 1;
        xx := ColCount - 1;
        Cols[xx].BeginUpdate;
        for yy := 0 to RowCount - 1 do
        begin
          Cells[xx, yy] := ' ';
          ObJects[xx, yy] := nil;
        end;
        Cols[xx].EndUpdate;
        if ToIndex < ColCount - 1 then
          MoveColumn(ColCount - 1, ToIndex);
      end
      else
        MessageBeep(0)
    else
      MessageBeep(0);
end;

procedure DeleteColumn(Sender: TStringGrid; FromIndex: Longint);
begin
  if FromIndex >= 0 then
    with TCSGrid(Sender) do
      if (ColCount > 0) and (FromIndex < ColCount) then
      begin
        if (FromIndex < ColCount - 1) then
          MoveColumn(FromIndex, ColCount - 1);
        Cols[ColCount - 1].Clear;
        ColCount := ColCount - 1;
      end
      else
        MessageBeep(0)
    else
      MessageBeep(0);
end;

end.

Листинг арифметических функций (ядро)

Код: Выделить всё

unit MatFunc;
interface
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, Menus, StdCtrls, ComCtrls,UnlimitedFloat, funlib, CoreClass;

  function CalcFunc(str: string; CoProcessor: boolean): string;
implementation

function ResultType(B:boolean) :byte;


begin
  if b then
    Result:=rtCoProcessor
  else
    Result:=rtHighPrec;
end;

function CalcFunc(str: string; CoProcessor: boolean): string;
var
   Res:TUnlimitedFloat;
   PolskaRecord:String;
   HighPrecCore:THighPrecCore;
   Cursor:TCursor;
begin
Result:='';
   try
    HighPrecCore:=THighPrecCore.Create;
    try
      HighPrecCore.Expression:=str;
//      HighPrecCore.ResultType:=rtCoProcessor;
//      HighPrecCore.ResultType:=rtHighPrec;
      HighPrecCore.ResultType:= ResultType(CoProcessor);
//      HighPrecCore.DecimalPrecision:=1000;
      HighPrecCore.DecimalPrecision:= 100;
      HighPrecCore.ResultBase:= 10;
      HighPrecCore.ResultDMS:= FALSE;
      result:=HighPrecCore.ResultValue;
    //  ShowMessage(IntToStr(HighPrecCore.ErrorPosition));
    finally
//      ErrorPosition:=HighPrecCore.ErrorPosition;
      HighPrecCore.Free;
    end;
    //ExpressionBuffer.AddExpression(ExpressionMemo);
  finally

  end;
end;

end.

Модуль системных функций

Код: Выделить всё

unit RQUtil;


interface
uses
   Windows, Graphics, Classes, ExtCtrls,

  {$IFDEF NOT_USE_GDIPLUS}

  {$ELSE USE_GDIPLUS}


  {$ENDIF NOT_USE_GDIPLUS}
      Forms;

type

  Thls=record h,l,s:double; end;
  function  findInStrings(s:string;ss:Tstrings):integer; overload;
  function  findInStrings(s:string;ss:array of string):integer; overload;
  function  findInStrings(s,ss,separator:string):integer; overload;

function  chop(i:integer; var s:string):string; overload;
function  chop(i,l:integer; var s:string):string; overload;
function  chop(ss:string; var s:string):string; overload;

function  isSupportedPicFile(fn:string):boolean;
function  getSupPicExts:String;
procedure  StretchPic(var bmp:TBitmap; maxH, maxW : Integer); overload;
function   DestRect(W, H, cw, ch :Integer): TRect;
function  createBitmap(dx,dy:integer):Tbitmap; overload;
function  createBitmap(cnv:Tcanvas):Tbitmap; overload;
function  isOnlyDigits(s:string):boolean;
  function  chopline(var s:string):string;
  function  UnDelimiter(s : String) :String;
  function  BetterStr(s : String): String;
{$EXTERNALSYM IsEqualGUID}
function IsEqualGUID(const guid1, guid2: TGUID): Boolean; stdcall;
  function  str2color(s:string):Tcolor;
  function ABCD_ADCB(d:dword):dword; assembler;
  function  color2str(color:Tcolor):string;
  function gpColorFromAlphaColor(Alpha: Byte; Color: TColor): Cardinal;
  function  color2hls(clr:Tcolor):Thls;
  function  hls2color(hls:Thls):Tcolor;
  function  addLuminosity(clr:Tcolor; q:real):Tcolor;


  function pic2ico(pic:Tbitmap):Ticon;
  function bmp2ico(bitmap:Tbitmap):Ticon;

  function str2valor(s:string):integer;
  function hex2Str(s:string):String;
  function str2hex(s: String) : String;
  function  str2fontstyle(s:string):Tfontstyles;
  function  fontstyle2str(fs:Tfontstyles):string;
  function  int2str(i:integer):string;
  function  int2str64(i:Int64):string;
  function  dt2str(dt:Tdatetime):string;
  function  hexToInt(s:string):integer;
  function  strings2str(split:string; ss:Tstrings):string; overload;
  function  strings2str(split:string; ss:array of string):string; overload;
  procedure str2strings(split, src:string; var ss:Tstrings);
  function  hexDump(data:string):string;
  function  bmp2wbmp(bmp : TBitmap) : String;
  procedure wbmp2bmp(Stream: TStream; var pic : TBitmap);
  function  Rgb2Gray(RGBColor : TColor) : byte;
function  saveFile(fn:string; data:string; needSafe : Boolean = false):boolean;
  function  fileIsWritible(fn: String): boolean;
  function  sizeOfFile(fn:string):integer;
function  partDeleteFile(fn:string; from,length:integer):boolean;
function absPath(fn:string):boolean;
procedure showForm(frm:Tform); overload;
procedure applyTaskButton(frm:Tform);
function unUTF(s : String) : String;
function StrToUTF8(Value: String): String;
function UTF8toStr(Value: String): String;
function StrToUnicode(Value: String): String;
function TxtFromInt(Int: Integer {3 digits}): String;

const
  ole32    = 'ole32.dll';
  CRLF=#13#10;
//var
//  msgs :array of Tmsg;

implementation
uses
  sysutils, StrUtils,  math,

//  GraphicStrings,
{$IFDEF RNQ_PLAYER}
  BASSplayer,
{$ELSE RNQ_PLAYER}

{$ENDIF RNQ_PLAYER}
  {$IFDEF NOT_USE_GDIPLUS}
   {$IFDEF RNQ_FULL}
    ShockwaveFlashObjects_TLB,
   {$ENDIF RNQ_FULL}
  {$ELSE USE_GDIPLUS}

  {$ENDIF NOT_USE_GDIPLUS}
  MMSystem,
{$IFDEF USE_ZIP}
  KAZip,
//  SXZipUtils,
//   VCLUnZip,
//  SciZipFile,
{$ENDIF USE_ZIP}
{$IFDEF USE_RAR}
   ztvUnRar,
{$ENDIF USE_RAR}
   Types;

//var
// Soundhndl : HCHANNEL;

var
supExts : array[0..9] of string = ('bmp', 'wbmp', 'wbm', 'gif', 'ico','icon',
                 'png', 'jpg', 'jpe', 'jpeg');//, 'tif', 'dll')

{$EXTERNALSYM IsEqualGUID}
function IsEqualGUID;                   external ole32 name 'IsEqualGUID';

function absPath(fn:string):boolean;
begin
  result:=(length(fn)>2) and ((fn[2]=':') or (fn[1]='\') and (fn[2]='\'))
end;

function findInStrings(s:string;ss:Tstrings):integer;
begin
result:=0;
while result < ss.count do
  if ss[result] = s then
    exit
  else
    inc(result);
result:=-1;
end; // findInStrings

function findInStrings(s:string;ss:array of string):integer;
begin
result:=0;
while result < length(ss) do
  if ss[result] = s then
    exit
  else
    inc(result);
result:=-1;
end; // findInStrings

function findInStrings(s,ss,separator:string):integer;
begin
result:=0;
while ss>'' do
  if chop(separator,ss) = s then
    exit
  else
    inc(result);
result:=-1;
end; // findInStrings

function chop(ss:string; var s:string):string;
begin result:=chop(pos(ss,s),length(ss),s) end;

function chop(i:integer; var s:string):string;
begin result:=chop(i,1,s) end;

function chop(i,l:integer; var s:string):string;
begin
if i=0 then
  begin
  result:=s;
  s:='';
  exit;
  end;
result:=copy(s,1,i-1);
delete(s,1,i-1+l);
end; // chop

function bmp2ico(bitmap:Tbitmap):Ticon;
var
  iconX, iconY : integer;
  IconInfo: TIconInfo;
  IconBitmap, MaskBitmap: TBitmap;
  dx,dy,x,y: Integer;
  tc: TColor;
begin
if bitmap=NIL then
  begin
  result:=NIL;
  exit;
  end;
iconX := GetSystemMetrics(SM_CXICON);
iconY := GetSystemMetrics(SM_CYICON);
IconBitmap:= TBitmap.Create;
IconBitmap.Width:= iconX;
IconBitmap.Height:= iconY;
IconBitmap.TransparentColor:=Bitmap.TransparentColor;
tc:=Bitmap.TransparentColor and $FFFFFF;
Bitmap.transparent:=FALSE;
with IconBitmap.Canvas do
  begin
  dx:=bitmap.width*2;
  dy:=bitmap.height*2;
  if (dx < iconX) and (dy < iconY) then
    begin
    brush.color:=tc;
    fillrect(clipRect);
    x:=(iconX-dx) div 2;
    y:=(iconY-dy) div 2;
    StretchDraw(Rect(x,y,x+dx,y+dy), Bitmap);
    end
  else
    IconBitmap.Canvas.StretchDraw(Rect(0, 0, iconX, iconY), Bitmap);
  end;
MaskBitmap:= TBitmap.Create;
MaskBitmap.Assign(IconBitmap);
Bitmap.transparent:=TRUE;
with IconBitmap.Canvas do
  for y:= 0 to iconY - 1 do
    for x:= 0 to iconX - 1 do
      if Pixels[x, y]=tc then
        Pixels[x, y]:=clBlack;
IconInfo.fIcon:= True;
IconInfo.hbmMask:= MaskBitmap.MaskHandle;
IconInfo.hbmColor:= IconBitmap.Handle;
Result:= TIcon.Create;
Result.Handle:= CreateIconIndirect(IconInfo);
MaskBitmap.Free;
IconBitmap.Free;
end; // bmp2ico

function pic2ico(pic:Tbitmap):Ticon;
begin result:=bmp2ico(pic) end;

function hexToInt(s:string):integer;
var
  i,v,c:integer;
begin
result:=0;
c:=0;
i:=length(s);
while i > 0 do
  begin
  if s[i] >= 'a' then v:=byte(s[i])-byte('a')+10 else
    if s[i] >= 'A' then v:=byte(s[i])-byte('A')+10 else
      v:=byte(s[i])-byte('0');
  inc(result, v shl c);
  inc(c,4);
  dec(i);
  end;
end; // hexToInt
function str2valor(s:string):integer;
begin
if s = '' then
  result:=-1
else
  if s[length(s)]='h' then
    result:=hexToInt(copy(s,1,length(s)-1))
  else
    try
      result:=strToInt(s)
    except
      result:=0
    end
end; // str2valor
function hex2Str(s:string):String;
var
  i:integer;
begin
result:='';
//c:=0;
//i:=length(s);
i := 1;
while i < length(s) do
  begin
    result := result + Chr(hexToInt(copy(s,i,2)));
{  if s[i] >= 'a' then v:=byte(s[i])-byte('a')+10 else
    if s[i] >= 'A' then v:=byte(s[i])-byte('A')+10 else
      v:=byte(s[i])-byte('0');
  result := result + IntToStr(v);
//  inc(result, v shl c);
//  inc(c,4);
  dec(i); }
   inc(i, 2);
  end;
end; // hexToInt

function str2hex(s:string):string;
var
//  ofs,
  i:integer;
//  s2:string;
begin
  result:='';
//  ofs:=0;
  for i:=1 to length(s) do
    begin
      result:=result+intToHex(ord(s[i]),2);
//      result:=result+' ';
    end;
end; // Str2hex
function strings2str(split:string; ss:Tstrings):string;
var
  i:integer;
begin
  result:='';
  if ss = nil then
   exit;
  i:=0;
  while i < ss.count-1 do
    begin
    result:=result+ss[i]+split;
    inc(i);
    end;
  // the last one without split
  if ss.count > 0 then
    result:=result+ss[ss.count-1]
end; // strings2str

function strings2str(split:string; ss:array of string):string;
var
  i:integer;
begin
result:='';
if length(ss)=0 then exit;
for i:=0 to length(ss)-2 do
  result:=result+ss[i]+split;
result:=result+ss[length(ss)-1];
end;

procedure str2strings(split, src:string; var ss:Tstrings);
var
  i:integer;
begin
ss.clear;
while src > '' do
  begin
  i:=pos(split,src);
  if i=0 then i:=length(src)+1;
  ss.add( copy(src,1,i-1) );
  delete(src, 1, i+length(split)-1);
  end;
end; // strings2str

function hexDump(data:string):string;
const
  cols=16;
var
  ofs,i:integer;
  s,s2:string;
begin
result:='';
ofs:=0;
while ofs < length(data) do
  begin
  s:='';
  s2:='';
  for i:=1 to cols do
    if ofs+i <= length(data) then
      begin
      s:=s+intToHex(ord(data[ofs+i]),2);
      if i=8 then s:=s+'  '
      else s:=s+' ';
      if data[ofs+i] < #32 then s2:=s2+'.'
      else s2:=s2+data[ofs+i];
      end;
  s:=s+stringOfChar(' ',cols*3+4-length(s));
  result:=result+s+s2+CRLF;
  inc(ofs,cols);
  end;
end; // hexDump

function isSupportedPicFile(fn:string):boolean;
//var
//  Extensions: TStringList;
//  i : Integer;
begin
//  result:=true;
  result:=false;
  fn:=lowercase(ExtractFileExt(fn));
  if fn <> '' then
  begin
    fn := Copy(fn, 2, Length(fn)-1);
    if (fn = 'bmp')or(fn = 'wbmp')or(fn = 'wbm')or(fn = 'gif')or
        (fn = 'ico')or(fn = 'icon')or(fn='png')or(fn='jpg')or(fn='jpeg')or
        (fn='tif')or(fn='dll') then
     begin
      result := true;
      exit;
     end
{   try
    Extensions := TStringList.Create;
    FileFormatList.GetExtensionList(Extensions);
    i := Extensions.IndexOf(fn);
    if i>=0 then
     result:=true
    else
     result:=false
   finally
    Extensions.Free;
   end;
  end}
  else
     result:=false;
  end;
end; // isSupportedPicFile

procedure  StretchPic(var bmp:TBitmap; maxH, maxW : Integer);
var
  bmp1 : TBitmap;
begin
  if (bmp.Width > maxW )
   or (bmp.Height > maxH) then
  begin
   bmp1 := TBitmap.Create;
   if bmp.Width * maxH < bmp.Height * maxW then
     begin
      {$IFDEF DELPHI_9_UP}
       bmp1.SetSize(maxH*bmp.Width div bmp.Height, maxH);
      {$ELSE DELPHI_9_down}
       bmp1.Width := maxH*bmp.Width div bmp.Height;
       bmp1.Height := maxH;
      {$ENDIF DELPHI_9_UP}
     end
    else
     begin
      {$IFDEF DELPHI_9_UP}
     bmp1.SetSize(maxW, maxW*bmp.Height div bmp.Width);
      {$ELSE DELPHI_9_down}
       bmp1.Width := maxW;
       bmp1.Height := maxW*bmp.Height div bmp.Width;
      {$ENDIF DELPHI_9_UP}
     end;
   bmp1.Canvas.StretchDraw(Rect(0, 0, bmp1.Width, bmp1.Height), bmp);
   FreeAndNil(bmp);
   bmp := bmp1;
//   bmp1 := nil;
end;
end;

function ABCD_ADCB(d:dword):dword; assembler;
asm
mov EAX, d
ror EAX, 16
ror AX, 8
rol EAX, 16
ror AX, 8
rol EAX, 8
end; // ABCD_ADCB

function color2str(color:Tcolor):string;
begin
//color:=ABCD_ADCB(ColorToRGB(color));
  if not ColorToIdent(Color, Result) then
    begin
      color:=ABCD_ADCB(ColorToRGB(color));
      result:=intToHex(color,6);
    end;
end; // color2str

function str2color(s:string):Tcolor;
begin
if length(s) = 0 then
  result:=-1
else
  if s[1]='$' then
    result:=ABCD_ADCB(stringToColor(s))
  else
    if (length(s) > 2) and (upcase(s[1])='C') and (upcase(s[2])='L') then
      result:=stringToColor(s)
    else
      result:=ABCD_ADCB(stringToColor('$'+s))
end; // str2color

function gpColorFromAlphaColor (Alpha: Byte; Color: TColor): Cardinal;
begin
    Result := (Alpha shl 24) or (ABCD_ADCB(
              ColorToRGB(Color)) and $ffffff);
end;

function color2hls(clr:Tcolor):Thls;
var
  r,g,b,a,z,d:double;
begin
clr:=colorToRGB(clr);
r:=GetRvalue(clr)/255;
g:=GetGvalue(clr)/255;
b:=GetBvalue(clr)/255;
a:=min(min(r,g),b);
z:=max(max(r,g),b);
d:=z-a;
with result do
  begin
  l:=z;
  if d=0 then
    begin
    h:=0;
    s:=0;
    exit;
    end;
  //if l < 0.5 then s:=d/(z+a) else s:=d/(2-z-a);
  if z=0 then s:=0 else result.s:=d/z;
  if r=z then h:=(g-b)/d;
  if g=z then h:=2+(b-r)/d;
  if b=z then h:=4+(r-g)/d;
  end;
end; // color2hls

function hls2color(hls:Thls):Tcolor;
var
  r,g,b, p,q,t:double;
begin
with hls do
  if s = 0 then
    begin
    r:=l;
    g:=l;
    b:=l;
    end
  else
    begin
    p:=l*(1.0-s);
    q:=l*(1.0-(s*frac(h)));
    t:=l*(1.0-(s*(1.0-frac(h))));

    case trunc(h) of
      0:begin r:=l; g:=t; b:=p end;
      1:begin r:=q; g:=l; b:=p end;
      2:begin r:=p; g:=l; b:=t end;
      3:begin r:=p; g:=q; b:=l end;
      4:begin r:=t; g:=p; b:=l end;
      else begin r:=l; g:=p; b:=q end;
      end;
    end;
result:=round(r*255)+round(g*255) shl 8+round(b*255) shl 16;
end; // hls2color

function addLuminosity(clr:Tcolor; q:real):Tcolor;
var
  hls:Thls;
begin
hls:=color2hls(clr);
with hls do
  begin
  l:=l+q;
  if l<0 then l:=0;
  if l>1 then l:=1;
  end;
result:=hls2color(hls);
end; // addLuminosity


function isOnlyDigits(s:string):boolean;
var
  i:integer;
begin
result:=FALSE;
i:=1;
while i <= length(s) do
  if s[i] in ['0'..'9'] then
    inc(i)
  else
    exit;
if i > 1 then result:=TRUE;
end; // isOnlyDigits

function str2fontstyle(s:string):Tfontstyles;
begin
result:=[];
if ansipos('b',s) > 0 then include(result, fsBold);
if ansipos('i',s) > 0 then include(result, fsItalic);
if ansipos('u',s) > 0 then include(result, fsUnderline);
end; // str2fontstyle

function fontstyle2str(fs:Tfontstyles):string;
begin
result:='';
if fsBold in fs then result:=result+'b';
if fsItalic in fs then result:=result+'i';
if fsUnderline in fs then result:=result+'u';
end; // str2fontstyle

function int2str(i:integer):string;
begin
setLength(result, 4);
move(i, result[1], 4);
end;

function int2str64(i:Int64):string;
begin
setLength(result, 8);
move(i, result[1], 8);
end;

function dt2str(dt:Tdatetime):string;
begin
  setLength(result, 8);
  move(dt, result[1], 8);
end;

function saveFile(fn:string; data:string; needSafe : Boolean = false):boolean;
{var
  f:file;
begin
result:=FALSE;
if fn='' then exit;
IOresult;
assignFile(f,fn);
rewrite(f,1);
if IOresult <> 0 then exit;
blockWrite(f, data[1], length(data));
if IOresult <> 0 then exit;
closeFile(f);
result:=TRUE;}
var
fs : TFileStream;
md : Word;
MakeBakups: boolean;
// ff, bs : PAnsiChar;
ff, bs : String;
begin
  result := false;
  if fn = '' then
   exit;
//  if FileExists(fn) then
//    md := fmOpenReadWrite
//   else
  md := fmCreate;
  fs := NIL;
  try
    if needSafe and MakeBakups then
     try
       ff := fn + #0;
       bs := fn + '.bak'#0;
//      StrPCopy(ff, fn);
//      StrPCopy(bs, fn + '.bak');
      CopyFile(PAnsiChar(@ff[1]), PAnsiChar(@bs[1]), false);
//      StrDispose(ff);
//      StrDispose(bs);
     except
     end;
    fs := NIL;
    fs := TFileStream.Create(fn, md);
//    fs.Seek(0, soFromEnd);
    fs.Write(data[1], length(data));
    result := True;
    if Assigned(fs) then
     FreeAndNil(fs);
  except
    if Assigned(fs) then
     FreeAndNil(fs);
    result := false;
  end;
end; // saveFile

function fileIsWritible(fn: String): boolean;
var
fs : TFileStream;
begin
  if not FileExists(fn) then
   result := True
  else
  try
    fs := TFileStream.Create(fn, fmOpenReadWrite);
    result := True;
    fs.Free;
  except
    result := False;
  end;
end;

function partDeleteFile(fn:string; from,length:integer):boolean;
const
  bufdim=64*1024;
var
  f:file;
  buf:string;
  dim,i,left:integer;
begin
result:=FALSE;
IOresult;
assignFile(f,fn);
reset(f,1);
if IOresult<>0 then exit;
i:=from;
if length<0 then
  seek(f,from)
else
  begin
  left:=fileSize(f)-from-length;
  setLength(buf, bufdim);
  while left > 0 do
    begin
    seek(f,i+length);
    blockRead(f, buf[1], bufdim, dim);
    seek(f,i);
    blockWrite(f, buf[1], dim);
    inc(i, dim);
    dec(left, dim);
    if IOresult<>0 then exit;
    end;
  if from+length < filesize(f) then
    seek(f,filesize(f)-length)
  else
    seek(f,from);
  end;
truncate(f);
closeFile(f);
result:=IOresult=0;
end; // partDeleteFile

function sizeOfFile(fn:string):integer;
var
  f:file;
  bak:integer;
//  ff : Cardinal;
begin
//  ff := OpenFile(fn, )
//  size := GetFileSize(ff, 0);
//  CloseHandle(ff);
  IOresult;
  assignFile(f,fn);
  bak:=fileMode;
  filemode:=0;
  {$I-}
  reset(f,1);
  filemode:=bak;
  result:=filesize(f);
  closeFile(f);
  if IOresult<>0 then result:=-1;
end; // sizeOfFile

function chopline(var s:string):string;
var
  i:integer;
begin
for i:=1 to length(s) do
  case s[i] of
    #10:
      begin
      result:=chop(i,s);
      exit;
      end;
    #13:
      begin
      if (i < length(s)) and (s[i+1]=#10) then result:=chop(i,2,s)
      else result:= chop(i,s);
      exit;
      end;
    end;
result:=chop(0,0,s);
end; // chopline

function  UnDelimiter(s : String) :String;
var
  i : Integer;
begin
  result := '';
  for I := 1 to length(s) do
    if (s[i] in ['a'..'z','A'..'Z','1'..'9','0']) then
      result := result + s[i];
end;

function BetterStr(s : String): String;
var
  i : Integer;
begin
  SetLength(Result, Length(s));
  for i := 1 to length(s) do
   if s[i] < #32 then
    Result[i]:= '.'
   else
    Result[i]:= s[i];
end;

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
function Base64Decode(Input : String) : String;
const
    Base64In: array[0..127] of Byte = (
        255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255,
        255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255,
        255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255,
        255, 255, 255, 255,  62, 255, 255, 255,  63,  52,  53,  54,  55,
         56,  57,  58,  59,  60,  61, 255, 255, 255,  64, 255, 255, 255,
          0,   1,   2,   3,   4,   5,   6,   7,   8,   9,  10,  11,  12,
         13,  14,  15,  16,  17,  18,  19,  20,  21,  22,  23,  24,  25,
        255, 255, 255, 255, 255, 255,  26,  27,  28,  29,  30,  31,  32,
         33,  34,  35,  36,  37,  38,  39,  40,  41,  42,  43,  44,  45,
         46,  47,  48,  49,  50,  51, 255, 255, 255, 255, 255
    );
var
    Final   : String;
    Count   : Integer;
    Len     : Integer;
    DataIn0 : Byte;
    DataIn1 : Byte;
    DataIn2 : Byte;
    DataIn3 : Byte;
begin
    Final := '';
    Count := 1;
    Len := Length(Input);
    while Count <= Len do begin
        DataIn0 := Base64In[Byte(Input[Count])];
        DataIn1 := Base64In[Byte(Input[Count+1])];
        DataIn2 := Base64In[Byte(Input[Count+2])];
        DataIn3 := Base64In[Byte(Input[Count+3])];

        Final := Final + Char(((DataIn0 and $3F) shl 2) +
                              ((DataIn1 and $30) shr 4));
        if DataIn2 <> $40 then begin
            Final := Final + Char(((DataIn1 and $0F) shl 4) +
                                  ((DataIn2 and $3C) shr 2));
            if DataIn3 <> $40 then
                Final := Final + Char(((DataIn2 and $03) shl 6) +
                                      (DataIn3 and $3F));
        end;
        Count := Count + 4;
    end;
    Result := Final;
end;}

procedure applyTaskButton(frm:Tform);
var
  i:integer;
begin
//setParent(frm.handle, 0);   this seems to work not, ugh
  setwindowlong(frm.handle, GWL_HWNDPARENT, 0);
  i:=getWindowLong(frm.handle, GWL_EXSTYLE);
  setWindowLong(frm.handle, GWL_EXSTYLE, i or WS_EX_APPWINDOW);
end;

procedure showForm(frm:Tform);
begin
  if frm=NIL then exit;
{
if frm = mainFrm then
  begin
  if not formvisible(mainfrm) then mainfrm.toggleVisible;
  exit;
  end;}
  frm.show;
//  ShowWindow(application.handle,SW_HIDE)
end;

{Convert string from UTF-8 format into ASCII}
function UTF8ToStr(Value: String): String;
var
  buffer: Pointer;
  BufLen: LongWord;
begin
  BufLen := Length(Value) + 4;
  GetMem(buffer, BufLen);
  FillChar(buffer^, BufLen, 0);
  MultiByteToWideChar(CP_UTF8, 0, @Value[1], BufLen - 4, buffer, BufLen);
  Result := WideCharToString(buffer);
  FreeMem(buffer, BufLen);
end;

{Convert string from UTF-8 format mixed with standart ASCII symbols($00..$7f)}
function UTF8ToStrSmart(Value: String): String;
var
  Digit: String;
  i: Word;
  HByte: Byte;
  Len: Byte;
begin
  Result := '';
  Len := 0;
  If UTF8Decode(Value)='' Then
   Begin
    Result:=Value;
    Exit
   End;
  if Value = '' then Exit;
  for i := 1 to Length(Value) do
  begin
    if Len > 0 then
    begin
      Digit := Digit + Value[i];
      Dec(Len);
      if Len = 0 then
        if UTF8ToStr(Digit) > '' then
          Result := Result + UTF8ToStr(Digit)
        else
          Result := Result + Digit;
    end else
    begin
      HByte := Ord(Value[i]);
      if HByte in [$00..$7f] then       //Standart ASCII chars
        Result := Result + Value[i]
      else begin
        //Get length of UTF-8 char
        if HByte and $FC = $FC then
          Len := 6
        else if HByte and $F8 = $F8 then
          Len := 5
        else if HByte and $F0 = $F0 then
          Len := 4
        else if HByte and $E0 = $E0 then
          Len := 3
        else if HByte and $C0 = $C0 then
          Len := 2
        else begin
          Result := Result + Value[i];
          Continue;
        end;
        Dec(Len);
        Digit := Value[i];
      end;
    end;
  end;
end;

//procedure wbmp2bmp(s: String; pic : TBitmap);
procedure wbmp2bmp(Stream: TStream; var pic : TBitmap);
var
  Bts : Integer;
  w, h : Integer;
  l, i, k, j : Word;
  b : Byte;
var
  Pal: TMaxLogPalette;
begin
//  if not FileExists('pic00.wbmp') then
//    appendFile('pic00.wbmp', s);
//  Bts := 4;
  l := 5;
  stream.position := 2;
  Stream.Read(B, SizeOf(Byte));
  w := 0;
  h := 0;

try
  if b = 128 then
   begin
     Stream.Read(w, SizeOf(Byte));
//     ACols := Ord(s[4]);
     inc(l, 2);
     Stream.Read(b, SizeOf(Byte));
//     ARows := Ord(s[4+2]);
     Stream.Read(h, SizeOf(Byte));
   end
  else
   begin
     w := b;
//     ARows := Ord(s[4]);
     Stream.Read(h, SizeOf(Byte));
   end;
  Bts := w div 8;
  if w mod 8 > 0 then inc(Bts);
  if (w = 0) or (h = 0) then
   exit;
  if not Assigned(pic) then
    pic := createBitmap(w, h)
   else
    begin
     pic.Width  := w;
     pic.Height := h;
    end;

//  pic.Monochrome := True;
  pic.Transparent := false;

        FillChar(Pal, SizeOf(Pal), 0);
        Pal.palVersion := $300;
        Pal.palNumEntries := 2;
        Pal.palPalEntry[1].peRed := $FF;
        Pal.palPalEntry[1].peGreen := $FF;
        Pal.palPalEntry[1].peBlue := $FF;
        pic.Palette := CreatePalette(PLogPalette(@Pal)^);
        pic.PixelFormat := pf1bit;
        for i := 0 to H - 1 do
          Stream.Read(pic.ScanLine[i]^, Bts);

{  for i := 0 to ARows-1 do
   begin
    For k := 0 to Bts-1 do
     for j := 0 to 7 do
      begin
       if (7 - j + 8 * k) < Acols then
       if (Ord(s[l+k]) and (1 shl j)) = 0 then
        pic.Canvas.Pixels[7 - j + 8 * k, i] := clBlack
       else
        pic.Canvas.Pixels[7 - j + 8 * k, i] := clWhite;
      end;
    inc(l, Bts)
   end;}
except
  if Assigned(pic) then
   begin
    pic.Height := 1;
    pic.Width := 1;
    pic.Canvas.Pixels[1, 1] := clBlack
   end;
end;
end;
{
procedure wbmp2bmp(Stream: TStream; var pic : TBitmap);
const
  WBMP_TYPE_BW_NOCOMPRESSION = 0;
  WBMP_DATA_MASK = $7F;
  WBMP_DATA_SHIFT = 7;
  WBMP_CONTINUE_MASK = $80;
  WBMP_FIXEDHEADERFIELD_EXT_MASK = $60;
  WBMP_FIXEDHEADERFIELD_EXT_00 = $00;
  WBMP_FIXEDHEADERFIELD_EXT_01 = $20;
  WBMP_FIXEDHEADERFIELD_EXT_10 = $40;
  WBMP_FIXEDHEADERFIELD_EXT_11 = $60;
  WBMP_FIXEDHEADERFIELD_EXT_11_IDENT_MASK = $70;
  WBMP_FIXEDHEADERFIELD_EXT_11_IDENT_SHIFT = 4;
  WBMP_FIXEDHEADERFIELD_EXT_11_VALUE_MASK = $0F;
  WBMP_FIXEDHEADERFIELD_EXT_11_VALUE_SHIFT = 0;
var
    FTypeField: Byte;
    FFixHeaderField: Byte;
    width, height : Integer;
  B: Byte;
  BytesPerRow: Integer;
  i: Integer;
  SId: string[8];
  SVal: string[16];

  function ReadNum: Integer;
  var
    B: Integer;
  begin
    Result := 0;
    b := 0;
    repeat
//      B := 0;
      Stream.Read(B, SizeOf(Byte));
      Result := (Result shl WBMP_DATA_SHIFT) or (B and WBMP_DATA_MASK);
    until (B and WBMP_CONTINUE_MASK) = 0;
  end;

var
  Pal: TMaxLogPalette;
begin
  if not Assigned(stream) then
    Exit;
  stream.position := 0;
  Stream.Read(B, SizeOf(Byte));
  fTypeField := B;
  case fTypeField of
    WBMP_TYPE_BW_NOCOMPRESSION:
      begin
//        FixImage;
        Stream.Read(B, SizeOf(Byte));
        fFixHeaderField := B;
//        ExtHeaders.Clear;
        if (fFixHeaderField and WBMP_CONTINUE_MASK) <> 0 then
          case fFixHeaderField and WBMP_FIXEDHEADERFIELD_EXT_MASK of
            WBMP_FIXEDHEADERFIELD_EXT_00: // Not Implemented
              begin
//                raise Exception.Create(sNotImplemented);
              end;
            WBMP_FIXEDHEADERFIELD_EXT_01, WBMP_FIXEDHEADERFIELD_EXT_10: // Reserved
              begin
//                raise Exception.Create(sReservedExtHeaderType);
              end;
            WBMP_FIXEDHEADERFIELD_EXT_11:
              begin
                repeat
                  Stream.Read(B, SizeOf(Byte));
                  SetLength(SId, (B and WBMP_FIXEDHEADERFIELD_EXT_11_IDENT_MASK) shr WBMP_FIXEDHEADERFIELD_EXT_11_IDENT_SHIFT);
                  SetLength(SVal, (B and WBMP_FIXEDHEADERFIELD_EXT_11_VALUE_MASK) shr WBMP_FIXEDHEADERFIELD_EXT_11_VALUE_SHIFT);
                  Stream.Read(SId[1], Length(SId));
                  Stream.Read(SVal[1], Length(SVal));
//                  ExtHeaders.Values[SId] := SVal;
                until (B and WBMP_CONTINUE_MASK) = 0;
              end;
          end;
        Width := ReadNum;
        Height := ReadNum;
        if not Assigned(pic) then
          pic := createBitmap(width, height)
         else
          begin
           pic.Width  := width;
           pic.Height := height;
          end;
        FillChar(Pal, SizeOf(Pal), 0);
        Pal.palVersion := $300;
        Pal.palNumEntries := 2;
        Pal.palPalEntry[1].peRed := $FF;
        Pal.palPalEntry[1].peGreen := $FF;
        Pal.palPalEntry[1].peBlue := $FF;
        pic.Palette := CreatePalette(PLogPalette(@Pal)^);
        pic.PixelFormat := pf1bit;
        BytesPerRow := Width div 8;
        for i := 0 to Height - 1 do
          Stream.Read(pic.ScanLine[i]^, BytesPerRow);
//        Changed(Self);
      end;
//  else
//    raise Exception.Create(sUnsuportedWBMPType);
  end;
end;
}

function bmp2wbmp(bmp : TBitmap) : String;
var
  Bts : Byte;
  ACols, ARows : word;
  i, j, k, l : word;
//  clr : TColor;
//Chs : Array[0..15] of Char;
begin
  ACols := bmp.Width;
  ARows := bmp.Height;
  Bts := ACols div 8;
  if ACols mod 8 > 0 then inc(Bts);

//  for i := 1 to Bmp.Height do
//    for j := 1 to Bmp.Width do
//      if Bmp.Canvas.Pixels[j, i] = clBlack then
//        SEPic[i, j] := true;
  result := #0#0 + Chr(ACols) + Chr(ARows);
  SetLength(result, ARows*bts+4);
  l := 5;
  if (ACols=0) or (ARows=0) then exit; 
  for i := 0 to ARows-1 do
   begin
    For k := 0 to Bts-1 do
    begin
     result[l+k] := #255;
     for j := 0 to 7 do
      begin
      if (Rgb2Gray(Bmp.Canvas.Pixels[7 - j + 8 * k, i]) < 128) or
//        if SEPic[i, 7 - j + 8 * k] or
           ((7 - j + 8 * k) > Acols) then
         result[l+k] := Chr(ord(result[l+k]) AND not (1 shl j));
//         if (7 - j + 8 * k) < Acols then
      end;
    end;
    inc(l, bts);
   end;
end;

function  getSupPicExts:String;
var
  I: Integer;
  s: String;
//var
//  l : TStrings;
begin
//  FileFormatList.GetExtensionList(l);
s := '';
for I := low(supExts) to High(supExts) do
  s := S + '*.' + supExts[i] + '; ';
  result := 'All images' + '|' + s;// + '|';
//  result := FileFormatList.GetGraphicFilter([], fstDescription,
//            [foCompact, foIncludeAll, foIncludeExtension], nil);
// !!!!!!!!!!!!!!!!!         ADDD       WBMP, GIF         !!!!!!!!!!!!!
end;

function Rgb2Gray(RGBColor : TColor) : byte;
// var
//   Gray : byte;
begin
   Result := Round((0.30 * GetRValue(RGBColor)) +
                 (0.59 * GetGValue(RGBColor)) +
                 (0.11 * GetBValue(RGBColor )));
//   Result := RGB(Gray, Gray, Gray);
end;

procedure StrSwapByteOrder(Str: PWideChar);
// exchanges in each character of the given string the low order and high order
// byte to go from LSB to MSB and vice versa.
// EAX contains address of string
asm
       PUSH    ESI
       PUSH    EDI
       MOV     ESI, EAX
       MOV     EDI, ESI
       XOR     EAX, EAX // clear high order byte to be able to use 32bit operand below
@@1:
       LODSW
       OR      EAX, EAX
       JZ      @@2
       XCHG    AL, AH
       STOSW
       JMP     @@1
@@2:
       POP     EDI
       POP     ESI
end;

function UnWideStr(s : String) : String;
begin
  result := s;
  if (result > '') and (result[1] < #5)and not odd(Length(result)) then
   begin
     StrSwapByteOrder(PWideChar(result));
//     result := #255#254 + result;
//     result := StringToWideStringEx(ws, CP_ACP);
//     result := utf8ToAnsi(result);
     result := WideCharToString(PWidechar(result));
//   result := ws;
//     UnicodeToUtf8(Pchar(Result), Length(result), PWideChar(result), Length(result));
//     result :=WideStringToStringEx(#255#254+result, CP_UTF8);
//     result := WideStringToStringEx(#255#254+result, CP_ACP);
//       result := TranslateString(result, CP_UTF8, CP_ACP);
//     result := Utf8ToAnsi(#255#254+result);
     //UTF8ToStrSmart(WideStringToUTF8(#255#254+result));
//     UTF8ToWideString(result);
   end;
end;

function UnUTF(s : String) : String;
begin
  result := UTF8ToStrSmart(UnWideStr(s));
end;

{Convert string to UTF8 format}
function StrToUTF8(Value: String): String;
var
  buffer: Pointer;
  BufLen: LongWord;
  lpBuf: Pointer;
begin
  BufLen := Length(Value) * 2 + 4;
  GetMem(buffer, BufLen); FillChar(buffer^, BufLen, 0);
  GetMem(lpBuf, BufLen); FillChar(lpBuf^, BufLen, 0);
  StringToWideChar(Value, buffer, BufLen);
  WideCharToMultiByte(CP_UTF8, 0, buffer, -1, lpBuf, BufLen, nil, nil);
  FreeMem(buffer, BufLen);
  Result := PChar(lpBuf);
  FreeMem(lpBuf, BufLen);
end;

{Convert string to Unicode format}
function StrToUnicode(Value: String): String;
var
  buffer: Pointer;
  BufLen: LongWord;
//  lpBuf: Pointer;
begin
  BufLen := Length(Value) * 2 + 4;
  SetLength(Result, BufLen);
//  GetMem(buffer, BufLen);
  buffer := @result[1];
  FillChar(buffer^, BufLen, 0);
//  GetMem(lpBuf, BufLen); FillChar(lpBuf^, BufLen, 0);
  StringToWideChar(Value, buffer, BufLen);
//  WideCharToMultiByte(CP_UTF8, 0, buffer, -1, lpBuf, BufLen, nil, nil);
//  SetLength(Result, BufLen);
//  Result := Copy(PChar(buffer), 0, BufLen);
  StrSwapByteOrder(PWideChar(result));
//  FreeMem(buffer, BufLen);
//  Result := PChar(lpBuf);
//  FreeMem(lpBuf, BufLen);
end;

function createBitmap(dx,dy:integer):Tbitmap;
begin
result:=Tbitmap.create;
Result.PixelFormat := pf24bit;
result.width:=dx;
result.height:=dy;
end;

function createBitmap(cnv:Tcanvas):Tbitmap;
begin
  with cnv.cliprect do
   result:=createBitmap(right-left+1, bottom-top+1);
end;

function transpColor(cl : TColor; alpha : Byte): TColor;
var
dw : Cardinal;
cf : Double;
begin
  dw := ColorToRGB(cl);
  cf := alpha / $FF;
  result := round((dw shr 16 and $FF) * cf)shl 16 + round((dw shr 8 and $FF) * cf) shl 8 + round((dw and $FF) * cf);
end;

type
TMatrix = array[0..6,0..3] of Byte;

var
  abc: array[0..9] of TMatrix =
  (
  ((0,1,1,0),(1,0,0,1),(1,0,0,1),(1,0,0,1),(1,0,0,1),(1,0,0,1),(0,1,1,0)),
  ((0,0,1,0),(0,1,1,0),(1,0,1,0),(0,0,1,0),(0,0,1,0),(0,0,1,0),(1,1,1,1)),
  ((0,1,1,0),(1,0,0,1),(0,0,0,1),(0,0,1,0),(0,1,0,0),(1,0,0,0),(1,1,1,1)),
  ((0,1,1,0),(1,0,0,1),(0,0,0,1),(0,1,1,0),(0,0,0,1),(1,0,0,1),(0,1,1,0)),
  ((1,0,0,1),(1,0,0,1),(1,0,0,1),(1,1,1,1),(0,0,0,1),(0,0,0,1),(0,0,0,1)),
  ((1,1,1,1),(1,0,0,0),(1,1,1,0),(0,0,0,1),(0,0,0,1),(1,0,0,1),(0,1,1,0)),
  ((0,1,1,0),(1,0,0,1),(1,0,0,0),(1,1,1,0),(1,0,0,1),(1,0,0,1),(0,1,1,0)),
  ((1,1,1,1),(0,0,0,1),(0,0,0,1),(0,0,1,0),(0,1,0,0),(0,1,0,0),(0,1,0,0)),
  ((0,1,1,0),(1,0,0,1),(1,0,0,1),(0,1,1,0),(1,0,0,1),(1,0,0,1),(0,1,1,0)),
  ((0,1,1,0),(1,0,0,1),(1,0,0,1),(0,1,1,1),(0,0,0,1),(1,0,0,1),(0,1,1,0))
  );

function GetRow(sym, row: integer): string;
var
line: string;
i: integer;
begin
line:='';
for i:=0 to 3 do
  begin
    if abc[sym][row,i]=1 then
     line:=line+'#'
    else
     line:=line+'_';
  end;
  result:=line;
end;

function TxtFromInt(Int: Integer {3 digits}): String;
var
iArr:array[1..3] of Integer;
res, line: String;
i,k: Integer;
begin
// Randomize;
if (Int<100)or(Int>999) then
  begin
    result:='PLUGIN ERROR: Invalid input parameters'+CRLF;
    exit;
  end;
iArr[1]:= Int div 100;
iArr[2]:= (Int - iArr[1]*100) div 10;
iArr[3]:= (Int - iArr[1]*100 - iArr[2]*10);
for i:=0 to 6 do
  begin
    line:='';
    for k:=1 to 3 do
    begin
     line:=line+'_'+GetRow(iArr[k],i);
    end;
   res:=res+CRLF+line;
  end;
  result:=res;
end;
{
  procedure LoadFileFromZip(ZipFile: TZipFile; FileName: String);
  var
    FileList: TStringList;
//    Section: TRQsection;
    i, j: Integer;
    Line, Param, par: String;
    k,v, prefix: String;
    parsed: Boolean;
    ZipStream: TMemoryStream;
  begin
//    Section:= _null;

    FileList:= TStringList.Create;
    ZipStream.Clear;

    ZipFile.CentralDirectory
    ZipFile.WriteFileToStream(ZipStream, FileName);
    loadPic(ZipStream, )
    ZipStream.Position:= 0;

    FileList.LoadFromStream(ZipStream);
    
    Log('Анализ файла: '+FileName);
    CurFileNamePath:= ExtractFilePath(FileName);
    //Log('cur: '+CurFileNamePath);

    CurFileName:= FileName;

    For i:= 0 to FileList.Count-1 do
    try
      Line:= FileList[i];
      Line:= Trim(Chop('#',Line));

      if (Line='')or((Line[1]=';') and (Section <> _smiles)) then Continue;

     if (Line[1]='[') and (Line[Length(Line)]=']') then
      begin
        Param := LowerCase(Copy(Line,2, Length(Line)-2));
        j:= findInStrings(Param, RQsectionLabels);
        if j >= 0 then
          Section:= TRQsection(j)
        else
          if Param = 'desc' then
            for J:= I+1 to FileList.Count-1 do
            begin
              Line:= FileList[J];
              Line:= Trim(Chop('#',Line));
              if Length(Line) > 2 then
                if (Line[1]='[') and (Line[Length(Line)]=']') then Break;
              Description:= Description +#13#10+ Line;
            end
          else
            Section:=_null;
        Continue;
      end;

      v:= Line;
      k:= Trim(Chop('=',v));
      v:= Trim(v);
      if k='include' then
      begin
        Log('Найден файл: '+ fullpath(v));
        LoadScriptFromZip(ZipFile, fullpath(v));
      end
      else
      if k='title' then
        Title:= v;

      if Section in [_icons, _ico, _pics] then
      begin
         ParsePicture(k, v);
      end;

      if Section in [_null] then
      begin
        parsed:= False;

        if Pos('.pic', k) > 0 then
        begin
          prefix := copy(k,1,Pos('.pic', k)-1);
          if prefix = '' then par := param
          else par := param+'.'+prefix;

          ParseImage(param, prefix, v);
          parsed := True;
        end;

        if Pos('font', k) > 0 then
        begin
          prefix := copy(k,1,Pos('font', k)-2);
          if prefix = '' then
            par := param
          else
          if param = '' then
            par := prefix
          else
            par := param+'.'+prefix;

          if prefix = '' then
            parsed := ParseFont(par, 'font', k, v)
          else
            parsed := ParseFont(par, prefix + '.font', k, v);
        end;

        if not parsed then
        if Pos('color', k) > 0 then
        begin
          prefix := copy(k,1,Pos('color', k)-2) + copy(k,Pos('color', k)+5, length(k));
          ParseColor(param, prefix, v);
        end;
        
      end;

    except
      Log('[PARSING ERROR] '+FileName);
    end;
    FileList.Clear;
    FreeAndNil(FileList);
  end;
}

function DestRect(W, H, cw, ch :Integer): TRect;
const
  Stretch = false;
  Proportional = True;
  Center  = True;  
var
//  w, h, cw, ch: Integer;
  xyaspect: Double;
begin
//  w := Picture.GetWidth;
//  h := Picture.GetHeight;
//  cw := ClientWidth;
//  ch := ClientHeight;
  if Stretch or (Proportional and ((w > cw) or (h > ch))) then
  begin
    if Proportional and (w > 0) and (h > 0) then
    begin
      xyaspect := w / h;
      if w > h then
      begin
        w := cw;
        h := Trunc(cw / xyaspect);
        if h > ch then  // woops, too big
        begin
          h := ch;
          w := Trunc(ch * xyaspect);
        end;
      end
      else
      begin
        h := ch;
        w := Trunc(ch * xyaspect);
        if w > cw then  // woops, too big
        begin
          w := cw;
          h := Trunc(cw / xyaspect);
        end;
      end;
    end
    else
    begin
      w := cw;
      h := ch;
    end;
  end;

  with Result do
  begin
    Left := 0;
    Top := 0;
    Right := w;
    Bottom := h;
  end;

  if Center then
    OffsetRect(Result, (cw - w) div 2, (ch - h) div 2);
end;

end.
Ответить