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.Листинг данной функции Вы найдёте в соседней теме.
Данная функция генерирует ответ авторизации (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.