Программирование на Delphi

FAQ VCL
Графика

:: Меню ::

:: На главную ::

:: FAQ ::

:: Заметки ::

:: Практика ::

:: Win API ::

:: Проекты ::

:: Скачать ::

:: Секреты ::

:: Ссылки ::

:: Сервис ::

:: Написать ::

:: MVP ::

:: RSS ::

Какой самый быстрый способ отчистить Canvas?


procedure TForm1.Button1Click(Sender: TObject);
begin
  PatBlt(Form1.Canvas.Handle, 0, 0, Form1.ClientWidth, Form1.ClientHeight, PATCOPY);
end;

Как преобразовать RGB-цвет в оттенки серого?


// Способ первый
function RgbToGray(RGBColor: TColor): TColor;
var
  Gray: Byte;
begin
  Gray := Round((0.30 * GetRValue(RGBColor)) +
                (0.59 * GetGValue(RGBColor)) +
                (0.11 * GetBValue(RGBColor)));
  Result := RGB(Gray, Gray, Gray);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  i, j: Integer;
begin
  for i := 0 to Image1.Width-1 do
    for j := 0 to Image1.Height-1 do
      Image1.Canvas.Pixels[i, j] := RgbToGray(Image1.Canvas.Pixels[i, j]);
end;

// Способ второй
function ColorToGray(AColor: TColor): TColor;
var
  Lum, rgb: Integer;
begin
  rgb := ColorToRGB(AColor);
  Lum := (GetRValue(rgb) * 77 +
          GetGValue(rgb) * 150 +
          GetBValue(rgb) * 29) shr 8; // div 256
  Result := Lum * $00010101;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  i, j: Integer;
begin
  for i := 0 to Image1.Width-1 do
    for j := 0 to Image1.Height-1 do
      Image1.Canvas.Pixels[i, j] := ColorToGray(Image1.Canvas.Pixels[i, j]);
end;

// Способ третий (с использованием FastDIB)
procedure TForm1.Button1Click(Sender: TObject);
var
  Bmp: TFastDIB;
  x, y, k: Integer;
  Line: PLine24;
  pc: PFColor;
begin
  Bmp := TFastDIB.Create;
  Bmp.LoadFromFile('c:\test.bmp');

  for y := 0 to Bmp.AbsHeight-1 do
  begin
    Line := Bmp.Scanlines[y];
    for x := 0 to Bmp.Width-1 do
    begin
      k := (76 * Line[x].r + 150 * Line[x].g + 30 * Line[x].b) div 256;
      Line[x].r := k;
      Line[x].g := k;
      Line[x].b := k;
    end;
  end;

  Bmp.SaveToFile('c:\test_g.bmp');
  Bmp.Free;
end;

Как изменить яркость RGB-цвета на N процентов?


// N находится в диапазоне от -100 до 100
function TForm1.SetLight(RGBColor: TColor; N: integer): TColor;
var
  R, G, B: integer;
begin
  R := Round(GetRValue(RGBColor) + N * 128 / 100);
  if R < 0 then
    R := 0;
  if R > 255 then
    R := 255;

  G := Round(GetGValue(RGBColor) + N * 128 / 100);
  if G < 0 then
    G := 0;
  if G > 255 then
    G := 255;

  B := Round(GetBValue(RGBColor) + N * 128 / 100);
  if B < 0 then
    B := 0;
  if B > 255 then
    B := 255;

  Result := RGB(R, G, B);
end;

Как конвертировать BMP в JPEG?


// Способ первый
uses
  {...,} JPEG;

procedure TForm1.Button1Click(Sender: TObject);
var
  MyJPEG: TJPEGImage;
  MyBMP: TBitmap;
begin
  MyBMP := TBitmap.Create;
  with MyBMP do
  try
    LoadFromFile('YourBmpHere.BMP');
    MyJPEG := TJPEGImage.Create;
    with MyJPEG do
    begin
      Assign(MyBMP);
      SaveToFile('YourJpegHere.JPEG');
      Free;
    end;
  finally
    Free;
  end;
end;

// Способ второй
uses
  {...,} JPEG;

procedure TForm1.Button1Click(Sender: TObject);
var
  MyBMP: TBitmap;
  MyJPEG: TJPEGImage;
begin
  MyBMP := TBitmap.Create;
  MyJPEG := TJPEGImage.Create;

  MyBMP.LoadFromFile('YourBmpHere.BMP');
  MyJPEG.Assign(MyBMP);
  MyJPEG.DIBNeeded;
  MyJPEG.CompressionQuality := 75;
  MyJPEG.Compress;
  MyJPEG.SaveToFile('YourJpegHere.JPEG');

  MyJPEG.Free;
  MyBMP.Free;
end;

Как конвертировать JPEG в BMP?


// Способ первый
uses
  {...,} JPEG;

procedure TForm1.Button1Click(Sender: TObject);
var
  MyJPEG: TJPEGImage;
  MyBMP: TBitmap;
begin
  MyJPEG := TJPEGImage.Create;
  with MyJPEG do
  begin
    LoadFromFile('YourJpegHere.JPEG');
    MyBMP := TBitmap.Create;
    with MyBMP do
    begin
      Width := MyJPEG.Width;
      Height := MyJPEG.Height;
      Canvas.Draw(0, 0, MyJPEG);
      SaveToFile('YourBmpHere.BMP');
      Free;
    end;
    Free;
  end;
end;

// Способ второй
uses
  {...,} JPEG;

procedure TForm1.Button1Click(Sender: TObject);
var
  MyBMP: TBitmap;
  MyJPEG: TJPEGImage;
begin
   MyBMP := TBitmap.Create;
   MyJPEG := TJPEGImage.Create;

   MyJPEG.LoadFromFile('YourJpegHere.JPEG');
   MyBMP.Assign(MyJPEG);
   MyBMP.SaveToFile('YourBmpHere.BMP');

   MyJPEG.Free;
   MyBMP.Free;
end;

Как конвертировать ICO в BMP?


procedure TForm1.Button1Click(Sender: TObject);
Var
  Icon: TIcon;
  Bitmap: TBitmap;
begin
  Icon := TIcon.Create;
  Bitmap := TBitmap.Create;
  Icon.LoadFromFile('YourIcoHere.ICO');
  Bitmap.Width := Icon.Width;
  Bitmap.Height := Icon.Height;
  Bitmap.Canvas.Draw(0, 0, Icon);
  Bitmap.SaveToFile('YourBmpHere.BMP');
  Icon.Free;
  Bitmap.Free;
end;

Как разместить прозрачную надпись на TBitmap?


// Способ первый
procedure TForm1.Button1Click(Sender: TObject);
var
  OldBkMode: Integer;
begin
  Image1.Picture.Bitmap.Canvas.Font.Color := clBlue;
  OldBkMode := SetBkMode(Image1.Picture.Bitmap.Canvas.Handle, TRANSPARENT);
  Image1.Picture.Bitmap.Canvas.TextOut(10, 10, 'Hello');
  SetBkMode(Image1.Picture.Bitmap.Canvas.Handle, OldBkMode);
end;

// Способ второй
procedure TForm1.Button1Click(Sender: TObject);
begin
  Image1.Canvas.Brush.Style := bsClear;
  Image1.Canvas.TextOut(10, 10, 'Hello');
end;

Как извлечь из цвета его составляющие (RGB)?


// Способ первый
procedure TForm1.Button1Click(Sender: TObject);
const
  MyColor = clRed;
var
  R, G, B: Byte;
begin
  R := Lo(MyColor);
  G := Lo(MyColor shr 8);
  B := Lo((MyColor shr 8) shr 8);
  Form1.Caption := Format('%.2d %.2d %.2d', [R, G, B]);
end;

// Способ второй
procedure TForm1.Button1Click(Sender: TObject);
const
  MyColor = clRed;
var
  R, G, B: Byte;
begin
  R := MyColor mod $100;
  G := MyColor div $100 mod $100;
  B := MyColor div $10000;
  Form1.Caption := Format('%.2d %.2d %.2d', [R, G, B]);
end;

// Способ третий
procedure TForm1.Button1Click(Sender: TObject);
const
  MyColor = clRed;
var
  R, G, B: Byte;
begin
  R := MyColor and $FF;
  G := (MyColor and $FF00) shr 8;
  B := (MyColor and $FF0000) shr 16;
  Form1.Caption := Format('%.2d %.2d %.2d', [R, G, B]);
end;

// Способ четвертый
procedure TForm1.Button1Click(Sender: TObject);
const
  MyColor = clRed;
var
  R, G, B: Byte;
begin
  R := GetRValue(ColorToRGB(MyColor));
  G := GetGValue(ColorToRGB(MyColor));
  B := GetBValue(ColorToRGB(MyColor));
  Form1.Caption := Format('%.2d %.2d %.2d', [R, G, B]);
end;

// Способ пятый
procedure TForm1.Button1Click(Sender: TObject);
const
  MyColor = clRed;
var
  R, G, B: Byte;
begin
  R := GetRValue(MyColor);
  G := GetGValue(MyColor);
  B := GetBValue(MyColor);
  Form1.Caption := Format('%.2d %.2d %.2d', [R, G, B]);
end;

Как узнать глубину цвета текущего видеорежима?


// Способ первый
procedure TForm1.Button1Click(Sender: TObject);
var
  DC: HDC;
  c: string;
begin
  DC := CreateDC('DISPLAY', nil, nil, nil);
  case GetDeviceCaps(DC, BITSPIXEL) of
    8: c := '256 цветов';
    15: c := 'Hi-Color / 32768 цветов';
    16: c := 'Hi-Color / 65536 цветов';
    24: c := 'True-Color / 16 млн. цветов';
    32: c := 'True-Color / 32 бит';
  end;
  Form1.Caption := c;
  DeleteDC(DC);
end;

// Способ второй
function GetColorsCount: DWord;
var
  DC: HDC;
begin
  DC := GetDC(0);
  Win32Check(DC <> 0);
  Result := GetDeviceCaps(DC, PLANES) * GetDeviceCaps(DC, BITSPIXEL);
  ReleaseDC(0, DC);
end;

// Способ третий
function GetColorsCount: LongInt;
var
  BPP: Integer;
  DC: HDC;
begin
  DC := CreateDC('DISPLAY', nil, nil, nil);
  if DC <> 0 then
  begin
    try
      BPP := GetDeviceCaps(DC, BITSPIXEL) * GetDeviceCaps(DC, PLANES);
    finally
      DeleteDC(DC);
    end;
    case BPP of
      1: Result := 2;
      4: Result := 16;
      8: Result := 256;
      15: Result := 32768;
      16: Result := 65536;
      24: Result := 16777216;
    end;
  end
  else
    Result := 0;
end;

Как плавно изменить цвет панели от черного к белому?


procedure TForm1.Button1Click(Sender: TObject);
var
  i: Integer;
begin
  for i := 0 to 255 do
  begin
    Panel1.Color := RGB(i, i, i);
    Sleep(10);
    Application.ProcessMessages;
  end;
end;

При использовании материала - ссылка на сайт обязательна