|
:: 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;
try
Bitmap.Width := 32;
Bitmap.Height := 32;
hCursor := LoadCursorFromFile(PChar(CurPath));
DrawIcon(Bitmap.Canvas.Handle, 0, 0, hCursor);
Bitmap.SaveToFile(BmpPath);
finally
Bitmap.Free;
end;
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;
|
|
При использовании материала - ссылка на сайт обязательна
|
|
