|
:: MVP ::
|
|
|
:: RSS ::
|
|
|
Как перевести TColor в string и обратно?
// TColor в string
procedure TForm1.Button1Click(Sender: TObject);
var
MyColor: TColor;
begin
MyColor := RGB( 200, 178, 222 );
ShowMessage( ColorToString( MyColor ) );
end;
// string в TColor
procedure TForm1.Button2Click(Sender: TObject);
var
s: string;
Col: TColor;
begin
s := '$007BBAAD';
Col := StringToColor( s );
end;
|
Как нарисовать курсор мыши как обычную картинку?
procedure TForm1.FormCreate(Sender: TObject);
var
Ico: TIcon;
begin
Ico := TIcon.Create;
try
// Загрузка курсора в объект TIcon
Ico.Handle := LoadCursor( 0, PChar( IDC_WAIT ) );
Image1.Picture.Graphic := Ico;
finally
Ico.Free;
end;
end;
// Возможные варианты второго параметра функции LoadCursor
// IDC_ARROW, IDC_IBEAM, IDC_WAIT, IDC_CROSS, IDC_UPARROW,
// IDC_SIZE, IDC_ICON, IDC_SIZENWSE, IDC_SIZENESW, IDC_NO,
// IDC_SIZEWE, IDC_SIZENS, IDC_SIZEALL, IDC_HAND, IDC_HELP,
// IDC_APPSTARTING
|
Как показать иконку, ассоциированную с данным типом файла?
// Способ первый
uses
{...,} ShellAPI;
procedure TForm1.Button1Click(Sender: TObject);
var
Icon: hIcon;
IconIndex: word;
begin
IconIndex := 1;
Icon := ExtractAssociatedIcon( HInstance, PChar( Application.ExeName ), IconIndex );
DrawIcon( Form1.Canvas.Handle, 10, 10, Icon );
end;
// Способ второй
procedure TForm1.Button1Click(Sender: TObject);
begin
Image1.Picture.Icon.Assign( Application.Icon );
end;
// Способ третий
uses
{...,} ShellAPI, ImgList;
(* Для файла или директории, физически присутствующих на жестком диске *)
procedure TForm1.Button1Click(Sender: TObject);
var
SysImageList: UINT;
SFI: TSHFileInfo;
Images: TImageList;
begin
Images := TImageList.Create( Self );
Images.DrawingStyle := dsTransparent;
SysImageList := SHGetFileInfo( '', 0, SFI, SizeOf( TSHFileInfo ),
SHGFI_SYSICONINDEX or SHGFI_SMALLICON );
Images.Handle := SysImageList;
Images.ShareImages := true;
SHGetFileInfo( PChar( Application.ExeName ), 0, SFI, SizeOf( SFI ),
SHGFI_TYPENAME or SHGFI_SYSICONINDEX );
Images.Draw( Canvas, 10, 10, SFI.iIcon );
end;
(* Для файла, которого нет на жестком диске *)
procedure TForm1.Button1Click(Sender: TObject);
var
SysImageList: UINT;
SFI: TSHFileInfo;
Images: TImageList;
begin
Images := TImageList.Create( Self );
Images.DrawingStyle := dsTransparent;
SysImageList := SHGetFileInfo( '', 0, SFI, SizeOf( TSHFileInfo ),
SHGFI_SYSICONINDEX or SHGFI_SMALLICON );
Images.Handle := SysImageList;
Images.ShareImages := true;
SHGetFileInfo( PChar( '*.txt' ), FILE_ATTRIBUTE_NORMAL, SFI, SizeOf( SFI ),
SHGFI_USEFILEATTRIBUTES or SHGFI_SYSICONINDEX );
Images.Draw( Canvas, 10, 10, SFI.iIcon );
end;
(* Для директории, которой нет на жестком диске *)
procedure TForm1.Button1Click(Sender: TObject);
var
SysImageList: UINT;
SFI: TSHFileInfo;
Images: TImageList;
begin
Images := TImageList.Create( Self );
Images.DrawingStyle := dsTransparent;
SysImageList := SHGetFileInfo( '', 0, SFI, SizeOf( TSHFileInfo ),
SHGFI_SYSICONINDEX or SHGFI_SMALLICON );
Images.Handle := SysImageList;
Images.ShareImages := true;
SHGetFileInfo( PChar( 'nil' ), FILE_ATTRIBUTE_DIRECTORY, SFI, SizeOf( SFI ),
SHGFI_USEFILEATTRIBUTES or SHGFI_SYSICONINDEX );
Images.Draw( Canvas, 10, 10, SFI.iIcon );
end;
// При использовании флага SHGFI_USEFILEATTRIBUTES, поскольку не идет обращение к файлу на жестком диске,
// теряются некоторые возможности. Например, если расширение является файловым типом, у которого иконка изменяется
// в зависимости от содержимого файла (например - .exe или .ico), то тогда динамическая иконка не будет доступна,
// потому что у вас нет файла. Вы попросили функцию "притвориться", но, в конце концов, у выдуманного файла нет содержимого.
|
Как найти расстояние между двумя точками на экране?
function Distance( Pt1: TPoint; Pt2: TPoint ): Double;
var
dx, dy: LongInt;
begin
dx := pt1.x - pt2.x;
dy := pt1.y - pt2.y;
Result := Sqrt( Sqr( Dx ) + Sqr( Dy ) );
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage( Format( '%f', [Distance( Point( 10, 10 ), Point( 50, 50 ) )] ) );
end;
|
Как узнать число дескрипторов объектов графического интерфейса пользователя (GUI), используемых заданным процессом?
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(GetGuiResources(GetCurrentProcess, GR_USEROBJECTS).ToString);
end;
// или немного иначе
procedure TForm1.Button2Click(Sender: TObject);
var
ProcessId: Cardinal;
hProcess: NativeUInt;
LastError: Cardinal;
begin
GetWindowThreadProcessId(Handle, ProcessId);
hProcess := OpenProcess(PROCESS_QUERY_INFORMATION, False, ProcessId);
if hProcess > 0 then
begin
ShowMessage(GetGuiResources(hProcess, GR_GDIOBJECTS).ToString);
if GetLastError > 0 then
ShowMessage(SysErrorMessage(GetLastError));
CloseHandle(hProcess);
end;
end;
|
Как преобразовать CUR в BMP?
// Работает не совсем корректно, но другого способа я
// не знаю. Если вы знаете способ лучше, просьба поделиться.
procedure CurToBmp( CurPath, BmpPath: string );
var
hCursor: LongInt;
Bitmap: TBitmap;
begin
Bitmap := TBitmap.Create;
Bitmap.Width := 32;
Bitmap.Height := 32;
hCursor := LoadCursorFromFile( PChar( CurPath ) );
DrawIcon( Bitmap.Canvas.Handle, 0, 0, hCursor );
Bitmap.SaveToFile( BmpPath );
Bitmap.Free;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
CurToBmp( 'C:\WINNT\Cursors\wait_il.cur', 'C:\wait_il.bmp' );
end;
|
Как определить графический формат файла не используя расширение?
type
TGraphicFileFormat = (gffUnknown, gffBMP, gffTIFF, gffJPG, gffPNG, gffDCX,
gffPCX, gffEMF, gffTGA, gffICO, gffGIF);
function PhysicalResolveFileType(AStream: TStream): TGraphicFileFormat;
var
p: PAnsiChar;
begin
if not Assigned(AStream) then
Exit(gffUnknown);
GetMem(p, 12);
try
AStream.Position := 0;
AStream.Read(p[0], 12);
{bitmap format}
if (p[0] = #66) and (p[1] = #77) then
Result := gffBMP;
{tiff format}
if ((p[0] = #73) and (p[1] = #73) and (p[2] = #42) and (p[3] = #0)) or
((p[0] = #77) and (p[1] = #77) and (p[2] = #42) and (p[3] = #0)) then
Result := gffTIFF;
{jpg format}
// p[3] может быть = #219 ($DB), #224 ($E0), #225 ($E1),
// #226 ($E2), #227 ($E2), #239 ($FE)
if (p[0] = #255) and (p[1] = #216) and (p[2] = #255) then
Result := gffJPG;
{png format}
if (p[0] = #137) and (p[1] = #80) and (p[2] = #78) and (p[3] = #71) and
(p[4] = #13) and (p[5] = #10) and (p[6] = #26) and (p[7] = #10) then
Result := gffPNG;
{dcx format}
if (p[0] = #177) and (p[1] = #104) and (p[2] = #222) and (p[3] = #58) then
Result := gffDCX;
{pcx format}
if p[0] = #10 then
Result := gffPCX;
{emf format}
if ((p[0] = #215) and (p[1] = #205) and (p[2] = #198) and (p[3] = #154)) or
((p[0] = #1) and (p[1] = #0) and (p[2] = #0) and (p[3] = #0)) then
Result := gffEMF;
{tga format}
if (p[0] = #0) and (p[1] = #0) and (p[2] = #2) and (p[3] = #0) and
(p[4] = #0) and (p[5] = #0) and (p[6] = #0) and (p[7] = #0) and
(p[8] = #0) and (p[9] = #0) and (p[10] = #0) and (p[11] = #0) then
Result := gffTGA;
{ico format}
if (p[0] = #0) and (p[1] = #0) and (p[2] = #1) and (p[3] = #0) then
Result := gffICO;
{gif format}
if ((p[0] = #71) and (p[1] = #73) and (p[2] = #70) and (p[3] = #56) and (p[4] = #55)) or
((p[0] = #71) and (p[1] = #73) and (p[2] = #70) and (p[3] = #56) and (p[4] = #57)) then
Result := gffGIF;
finally
FreeMem(p);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
fs: TFileStream;
begin
fs := TFileStream.Create('C:\test.bmp', fmOpenRead);
try
case PhysicalResolveFileType(fs) of
gffBMP: Caption := 'BMP';
gffTIFF: Caption := 'TIFF';
gffJPG: Caption := 'JPG';
gffPNG: Caption := 'PNG';
gffDCX: Caption := 'DCX';
gffPCX: Caption := 'PCX';
gffEMF: Caption := 'EMF';
gffTGA: Caption := 'TGA';
gffICO: Caption := 'ICO';
gffGIF: Caption := 'GIF';
end;
finally
fs.Free;
end;
end;
|
Как получить негатив картинки?
procedure TForm1.Button1Click(Sender: TObject);
var
Line: pByteArray;
i, j: integer;
begin
// Считываем высоту картинки
for i := 0 to Image1.Picture.Bitmap.Height - 1 do
begin
// Сканируем по линиям рисунок
Line := Image1.Picture.Bitmap.ScanLine[i];
for j := 0 to Image1.Picture.Bitmap.Width * 3 - 1 do
// Меняем цвет на обратный исходя из RGB
Line^[j] := 255 - Line^[j];
end;
Image1.Refresh;
end;
|
Как сделать colorize?
var
bm: TBitmap;
function Colorize( RGB: Cardinal; Luma: byte ): Cardinal;
var
l, r, g, b: Single;
begin
Result := Luma;
if Luma = 0 then
Exit;
l := Luma / 255;
r := RGB and $FF * l;
g := RGB shr 8 and $FF * l;
b := RGB shr 16 and $FF * l;
Result := Round( b ) shl 16 or Round( g ) shl 8 or Round( r );
end;
procedure TForm1.Button1Click(Sender: TObject);
var
i, j: integer;
begin
for i := 0 to bm.Width-1 do
for j := 0 to bm.Height-1 do
bm.Canvas.Pixels[i,j] := Colorize( bm.Canvas.Pixels[i,j], 155 );
Image1.Canvas.Draw( 0, 0, bm );
end;
|
Как сделать Spray эффект?
procedure Spray( Canvas: TCanvas; x, y, r: Integer; Color: TColor );
var
rad, a: Single;
i: Integer;
begin
for i := 0 to 100 do
begin
a := Random * 2 * pi;
rad := Random * r;
Canvas.Pixels[x + Round( rad * Cos( a ) ), y + Round( rad * Sin( a ) )] := Color;
end;
end;
procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if ssLeft in Shift then
Spray( Image1.Canvas, x, y, 40, clRed );
end;
procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if ssLeft in Shift then
Spray( Image1.Canvas, x, y, 40, clRed );
end;
|
|
При использовании материала - ссылка на сайт обязательна
|
|
