Grafika - Unit1.pl - Programowanie

Zamiana układu współrzędnych w formie na układ kartezjański

Wielu z was denerwuje fakt iż początek układu współrzędnych na formie jest w lewym górnym rogu. Ostatnio podczas pisania programu bardzo mnie to irytowało i postanowiłem coś z tym zrobić. Zamiana na „tradycyjny” układ ze środkiem w środku formy, taki jak od podstawówki rysujemy w zeszycie 🙂 jest bardzo prosta: W TForm.Create dodajemy następujący kod: […]

Czytaj więcej →

Zabarwienie obrazka

Chciałbym przedstawić sposób na zabarwienie obrazka jednym kolorem. Procedura najpierw oblicza wartość nasycenia wybranego koloru, a następnie usuwa dwa pozostałe. Ze względu na powolne działanie, procedura sprawdza się bardzo dobrze jedynie przy obrazkach niewielkich rozmiarów.

procedure Zabarwianie(C:TCanvas);

var x, y: integer;

  Kolor: LongInt;

  R, G, B, Nasycenie: Byte;

begin

  with C do

    for x:= ClipRect.Left to ClipRect.Right do

      for y:= ClipRect.Top to ClipRect.bottom do

      begin

        Kolor:=ColorToRGB(Pixels[x,Y]);

        R := GetRValue(Kolor);

        G := GetGValue(Kolor);

        B := GetBValue(Kolor);

        Nasycenie := Trunc(B*0.11+G*0.59+R*0.3);

        Pixels[x,Y]:=RGB(Nasycenie,0,0);

      end;

end;

procedure Zabarwianie(C:TCanvas);

var x, y: integer;

Kolor: LongInt;

R, G, B, Nasycenie: Byte;

begin

with C do

for x:= ClipRect.Left to ClipRect.Right do

for y:= ClipRect.Top to ClipRect.bottom do

begin

Kolor:=ColorToRGB(Pixels[x,Y]);

R := GetRValue(Kolor);

G := GetGValue(Kolor);

B := GetBValue(Kolor);

Nasycenie := Trunc(B*0.11+G*0.59+R*0.3);

Pixels[x,Y]:=RGB(Nasycenie,0,0);

end;

W tej procedurze zabarwiamy rysunek na czerwony, aby wykonać to dla barwy zielonej lub niebieskiej wystarczy zmienić Pixels[x,Y]:=RGB(Nasycenie,0,0); na […]

Czytaj więcej →

Wykonanie zrzutu ekranu

Przedstawiona procedura wykonuje zrzut ekranu do obiektu TImage, a następnie zapisuje obraz na dysku jako plik capture.bmp w katalogu, z którego uruchomiliśmy program.

procedure TForm1.GetDesktopBitmap;

 Var

  DeskHWnd : Hwnd;

  dc: HDC;

  ScreenWidth, ScreenHeight: Integer;

  TheBmp : TBitmap;

  FName : String;

begin



{Pobieramy uchwyt pulpitu}

  DeskHWnd := GetDeskTopWindow;

  dc := GetDC(DeskHWnd);


{Pobieramy rozdzielczość ekranu}

  ScreenWidth := GetDeviceCaps(dc,HORZRES);

  ScreenHeight := GetDeviceCaps(dc,VERTRES);


{Tworzymy Bitmapę}

  TheBmp := TBitmap.Create;

  TheBmp.Width := ScreenWidth;

  TheBmp.Height := ScreenHeight;


{Rysujemy ekran}

  BitBlt(TheBmp.Canvas.Handle, 0,0,ScreenWidth,ScreenHeight,dc, 0,0,SRCCOPY);


{Wrzucamy bitmape do TImage}

  Image1.Picture.Bitmap := TheBmp;

  Application.ProcessMessages;


{Usuwamy z pamięci bitmapę}

  TheBmp.Free;


  ReleaseDC(DeskHWnd, dc);


{Zapisujemy jako plik}

  FName := ExtractFilePath(Application.Exename) + 'capture.bmp';


  Image1.Picture.Bitmap.SaveToFile(FName);

end;

procedure TForm1.GetDesktopBitmap;

Var

DeskHWnd : Hwnd;

dc: HDC;

ScreenWidth, ScreenHeight: Integer;

TheBmp : TBitmap;

FName : String;

begin

{Pobieramy uchwyt pulpitu}

DeskHWnd := GetDeskTopWindow;

dc := GetDC(DeskHWnd);

{Pobieramy rozdzielczość ekranu}

ScreenWidth := GetDeviceCaps(dc,HORZRES);

ScreenHeight := GetDeviceCaps(dc,VERTRES);

{Tworzymy Bitmapę}

TheBmp := TBitmap.Create;

TheBmp.Width := ScreenWidth;

TheBmp.Height := ScreenHeight;

{Rysujemy ekran}

BitBlt(TheBmp.Canvas.Handle, 0,0,ScreenWidth,ScreenHeight,dc, 0,0,SRCCOPY);

{Wrzucamy bitmape do TImage}

Image1.Picture.Bitmap := TheBmp;

Application.ProcessMessages;

{Usuwamy z pamięci bitmapę}

TheBmp.Free;

ReleaseDC(DeskHWnd, dc);

{Zapisujemy jako plik}

FName := ExtractFilePath(Application.Exename) + 'capture.bmp';

Image1.Picture.Bitmap.SaveToFile(FName);

end;

Autor: Nakiel

Czytaj więcej →

Tekst pod dowolnym kątem

Tym razem wykonamy procedurę wyświetlającą tekst pod określonym kątem. Najpierw ustawiamy parametry początkowe, następnie tworzymy nowy obiekt czcionki i przypisujemy mu uchwyt (handle) naszego formularza.

procedure TForm1.Button1Click(Sender: TObject);

var

  Hfont: Thandle;

  logfont:TLogFont;

  font: Thandle;

  count: integer;

begin

       LogFont.lfheight:=30;

       logfont.lfwidth:=10;

       logfont.lfweight:=900;

       LogFont.lfEscapement:=900; // kąt

       logfont.lfcharset:=1;

       logfont.lfoutprecision:=out_tt_precis;

       logfont.lfquality:=draft_quality;

       logfont.lfpitchandfamily:=FF_Modern;


       font:=createfontindirect(logfont);


       Selectobject(Form1.canvas.handle,font);


       SetTextColor(Form1.canvas.handle,rgb(0,0,200));

       SetBKmode(Form1.canvas.handle,transparent);


  // Rysuje sto napisów pod różnym kątem

  for count:=1 to 100 do begin

    canvas.textout(Random(form1.width),Random(form1.height) ,'Rotated');

    SetTextColor(form1.canvas.handle,rgb(Random(255), Random(255),Random(255)));

  end;


  deleteobject(font);


end;

procedure TForm1.Button1Click(Sender: TObject);

var

Hfont: Thandle;

logfont:TLogFont;

font: Thandle;

count: integer;

begin

LogFont.lfheight:=30;

logfont.lfwidth:=10;

logfont.lfweight:=900;

LogFont.lfEscapement:=900; // kąt

logfont.lfcharset:=1;

logfont.lfoutprecision:=out_tt_precis;

logfont.lfquality:=draft_quality;

logfont.lfpitchandfamily:=FF_Modern;

font:=createfontindirect(logfont);

Selectobject(Form1.canvas.handle,font);

SetTextColor(Form1.canvas.handle,rgb(0,0,200));

SetBKmode(Form1.canvas.handle,transparent);

// Rysuje sto napisów pod różnym kątem

for count:=1 to 100 do begin

canvas.textout(Random(form1.width),Random(form1.height) ,'Rotated');

SetTextColor(form1.canvas.handle,rgb(Random(255), Random(255),Random(255)));

end;

deleteobject(font);

end;

Autor: Nakiel

Czytaj więcej →

Rozmycie obrazu

Przedstawiony poniżej kod umożliwia stworzenie efektu rozmycia (blur) na dowolnym obrazie BMP. Format pikseli musi być 24 lub 32 bitowy.

procedure Rozmycie( Can: TCanvas; X, Y, Szerokosc, Wysokosc : Integer);

var

  cx, cy: Smallint;

  r, g, b: Byte;

  Row1: pRGBTripleArray;

  Row2: pRGBTripleArray;

  Row3: pRGBTripleArray;

  TEMP: TBitmap;

  CurRect: TRect;

begin

  TEMP := TBitmap.Create;

  try

    with TEMP do begin

      Width := Szerokosc;

      Height := Wysokosc;

      CurRect := Rect(0, 0, Szerokosc, Wysokosc);

      PixelFormat := pf24Bit;

      Canvas.CopyRect(CurRect, Can, Rect(X,Y,Szerokosc, Wysokosc));

      with Canvas do begin

        for cy := 1 to (Height - 2) do begin

          Row1 := ScanLine[cy - 1];

          Row2 := ScanLine[cy];

          Row3 := ScanLine[cy + 1];


          for cx := 1 to (Width - 2) do begin

            r := (Row1[cx - 1].rgbtRed+Row1[cx].rgbtRed+

            Row1[cx + 1].rgbtRed+

            Row2[cx - 1].rgbtRed+

            Row2[cx + 1].rgbtRed+

            Row2[cx - 1].rgbtRed+

            Row3[cx].rgbtRed+

            Row3[cx + 1].rgbtRed+

            Row3[cx].rgbtRed) div 9;


            g := (Row1[cx - 1].rgbtGreen+

            Row1[cx].rgbtGreen+

            Row1[cx + 1].rgbtGreen+

            Row2[cx - 1].rgbtGreen+

            Row2[cx + 1].rgbtGreen+

            Row2[cx - 1].rgbtGreen+

            Row3[cx].rgbtGreen+

            Row3[cx + 1].rgbtGreen+

            Row3[cx].rgbtGreen) div 9;


            b := (Row1[cx - 1].rgbtBlue+

            Row1[cx].rgbtBlue+

            Row1[cx + 1].rgbtBlue+

            Row2[cx - 1].rgbtBlue+

            Row2[cx + 1].rgbtBlue+

            Row2[cx - 1].rgbtBlue+

            Row3[cx].rgbtBlue+

            Row3[cx + 1].rgbtBlue+

            Row3[cx].rgbtBlue) div 9;


            Row2[cx].rgbtBlue := b;

            Row2[cx].rgbtGreen := g;

            Row2[cx].rgbtRed := r;

          end;

        end;

      end;

      Can.CopyRect(Rect(X,Y,Szerokosc,Wysokosc), Canvas, CurRect);

    end;

  finally

    TEMP.Free;

  end;

end;

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

procedure Rozmycie( Can: TCanvas; X, Y, Szerokosc, Wysokosc : Integer);

var

cx, cy: Smallint;

r, g, b: Byte;

Row1: pRGBTripleArray;

Row2: pRGBTripleArray;

Row3: pRGBTripleArray;

TEMP: TBitmap;

CurRect: TRect;

begin

TEMP := TBitmap.Create;

try

with TEMP do begin

Width := Szerokosc;

Height := Wysokosc;

CurRect := Rect(0, 0, Szerokosc, Wysokosc);

PixelFormat := pf24Bit;

Canvas.CopyRect(CurRect, Can, Rect(X,Y,Szerokosc, Wysokosc));

with Canvas do begin

for cy := 1 to (Height - 2) do begin

Row1 := ScanLine[cy - 1];

Row2 := ScanLine[cy];

Row3 := ScanLine[cy + 1];

for cx := 1 to (Width - 2) do begin

r := (Row1[cx - 1].rgbtRed+Row1[cx].rgbtRed+

Row1[cx + 1].rgbtRed+

Row2[cx - 1].rgbtRed+

Row2[cx + 1].rgbtRed+

Row2[cx - 1].rgbtRed+

Row3[cx].rgbtRed+

Row3[cx + 1].rgbtRed+

Row3[cx].rgbtRed) div 9;

g := (Row1[cx - 1].rgbtGreen+

Row1[cx].rgbtGreen+

Row1[cx + 1].rgbtGreen+

Row2[cx - 1].rgbtGreen+

Row2[cx + 1].rgbtGreen+

Row2[cx - 1].rgbtGreen+

Row3[cx].rgbtGreen+

Row3[cx + 1].rgbtGreen+

Row3[cx].rgbtGreen) div 9;

b := (Row1[cx - 1].rgbtBlue+

Row1[cx].rgbtBlue+

Row1[cx + 1].rgbtBlue+

Row2[cx - 1].rgbtBlue+

Row2[cx + 1].rgbtBlue+

Row2[cx - 1].rgbtBlue+

Row3[cx].rgbtBlue+

Row3[cx + 1].rgbtBlue+

Row3[cx].rgbtBlue) div 9;

Row2[cx].rgbtBlue := b;

Row2[cx].rgbtGreen := g;

Row2[cx].rgbtRed := r;

end;

Can.CopyRect(Rect(X,Y,Szerokosc,Wysokosc), Canvas, CurRect);

end;

finally

TEMP.Free;

end;

Teraz wystarczy wywołać procedurę :

Rozmycie(image1.picture.Bitmap.Canvas,-10,-10,650,490);

1	Rozmycie(image1.picture.Bitmap.Canvas,-10,-10,650,490);

Autor: Nakiel

Czytaj więcej →

Przezroczysty formularz

Na początku przypiszemy parametrowi BorderStyle utworzonego formularza wartość bsNone. Następnie wystarczy do źródła programu dodać poniższy kod:

type

  TForm1 = class(TForm)

  private

    { Private declarations }

  public

    procedure CreateParams(var Params: TCreateParams); override;

  end;


...


procedure TForm1.CreateParams(var Params: TCreateParams);

begin

  inherited CreateParams(Params);

  Params.ExStyle := Params.ExStyle or WS_EX_TRANSPARENT;

end;

type

TForm1 = class(TForm)

private

{ Private declarations }

public

procedure CreateParams(var Params: TCreateParams); override;

end;

...

procedure TForm1.CreateParams(var Params: TCreateParams);

begin

inherited CreateParams(Params);

Params.ExStyle := Params.ExStyle or WS_EX_TRANSPARENT;

end;

Autor: Nakiel

Czytaj więcej →

Porównywanie obrazków

Stwórzmy funkcję, która będzie porównywać dwa obrazki w formacie BMP, a następnie zwróci w ilu procentach są ze sobą identyczne. Oto jej kod:

function Porownaj(Image1, Image2: TImage) : integer;

var x, y: integer;

  liczba: LongInt;

  punkt1, punkt2: PByteArray;

  procent: double;


const max_roznica=5;


begin

  liczba:=0;

  for y:=0 to image1.Picture.Bitmap.height-1 do begin

    punkt1:=image1.Picture.Bitmap.scanline[y];

    punkt2:=image2.Picture.Bitmap.scanline[y];

    for x:=0 to image1.Picture.Bitmap.width-1 do

      if abs(punkt1[x]-punkt2[x])>max_roznica then 

        inc(liczba);

    if image1.Picture.Bitmap.height*image1.Picture.Bitmap.width>0 then 

      procent:=100*(liczba/(image1.Picture.Bitmap.height*

      image1.Picture.Bitmap.width))

    else

      procent:=0;

    Result := 100-round(procent);

  end;

end;

function Porownaj(Image1, Image2: TImage) : integer;

var x, y: integer;

liczba: LongInt;

punkt1, punkt2: PByteArray;

procent: double;

const max_roznica=5;

begin

liczba:=0;

for y:=0 to image1.Picture.Bitmap.height-1 do begin

punkt1:=image1.Picture.Bitmap.scanline[y];

punkt2:=image2.Picture.Bitmap.scanline[y];

for x:=0 to image1.Picture.Bitmap.width-1 do

if abs(punkt1[x]-punkt2[x])>max_roznica then

inc(liczba);

if image1.Picture.Bitmap.height*image1.Picture.Bitmap.width>0 then

procent:=100*(liczba/(image1.Picture.Bitmap.height*

image1.Picture.Bitmap.width))

else

procent:=0;

Result := 100-round(procent);

end;

Wywołanie funkcji:

Label1.Caption:= 'Podobieństwo w '+ IntToStr(Porownaj(Image1,Image2))+' procentach';

1	Label1.Caption:= 'Podobieństwo w '+ IntToStr(Porownaj(Image1,Image2))+' procentach';

Image1 i Image2 to obiekty klasy TImage zawierające obrazy w formacie BMP. Miłego testowania 😉 Autor: Nakiel

Czytaj więcej →

Operacje graficzne na pasku tytułowym programu

Aby mieć możliwość rysowania po powierzchni paska tytułowego, musimy utworzyć nowy obiekt TCanvas, a następnie przypisać mu uchwyt naszego formularza.

type 

  TForm1 = class(TForm) 

  private 

    procedure WMNCPaint(var Msg: TWMNCPaint); message WM_NCPAINT; 

  public 

  end; 


var 

  Form1: TForm1; 


implementation 


{$r *.dfm} 


procedure TForm1.WMNCPaint(var Msg: TWMNCPaint); 

var 

  ACanvas: TCanvas; 

begin 

  inherited; 

  ACanvas := TCanvas.Create; 

  try 

    ACanvas.Handle := GetWindowDC(Form1.Handle); 

    with ACanvas do  

    begin 

      Brush.Color := clActiveCaption; 

      Font.Name := 'Tahoma'; 

      Font.Size := 8; 

      Font.Color := clred; 

      Font.Style := [fsItalic, fsBold]; 

      TextOut(GetSystemMetrics(SM_CYMENU) + GetSystemMetrics(SM_CXBORDER), 

        Round((GetSystemMetrics(SM_CYCAPTION) - Abs(Font.Height)) / 2) + 1, ' Taki tam tekst'); 

    end; 

  finally 

    ReleaseDC(Form1.Handle, ACanvas.Handle); 

    ACanvas.Free; 

  end; 

end;

type

TForm1 = class(TForm)

private

procedure WMNCPaint(var Msg: TWMNCPaint); message WM_NCPAINT;

public

end;

var

Form1: TForm1;

implementation

{$r *.dfm}

procedure TForm1.WMNCPaint(var Msg: TWMNCPaint);

var

ACanvas: TCanvas;

begin

inherited;

ACanvas := TCanvas.Create;

try

ACanvas.Handle := GetWindowDC(Form1.Handle);

with ACanvas do

begin

Brush.Color := clActiveCaption;

Font.Name := 'Tahoma';

Font.Size := 8;

Font.Color := clred;

Font.Style := [fsItalic, fsBold];

TextOut(GetSystemMetrics(SM_CYMENU) + GetSystemMetrics(SM_CXBORDER),

Round((GetSystemMetrics(SM_CYCAPTION) - Abs(Font.Height)) / 2) + 1, ' Taki tam tekst');

end;

finally

ReleaseDC(Form1.Handle, ACanvas.Handle);

ACanvas.Free;

end;

Autor: Nakiel

Czytaj więcej →

Jak zrobić gradient?

Na czym polega robienie gradientu? W zmiennych przechowamy sobie składowe wartość r, g i b koloru pierwszego oraz w r2, g2 i b2 koloru drugiego. Następnie obliczamy różnicę pomiędzmy tymi składowymi. Następnie dzielimy wynik przez długośc (lub wysokość), aby wiedzieć, o ile musimy zwiększać poszególne składowe w każdym obiegu pętli. Następnie, w pętli zmieniamy składowe, […]

Czytaj więcej →

Jak znaleźć współrzędne punktu znajdującego się w odległości r od danego punktu?

Dla dwuwymiarowego układu:

alfa - kąt ustawienia wzroku 

r - odległość jaka nas interesuje 


x' = x + Cos(DegToRad(alfa)) * r ; 

y' = y + Sin(DegToRad(alfa)) * r ;

alfa - kąt ustawienia wzroku

r - odległość jaka nas interesuje

x' = x + Cos(DegToRad(alfa)) * r ;

y' = y + Sin(DegToRad(alfa)) * r ;

Dla trójwymiarowego układu:

alfa, beta - kąty: poziomy i pionowy 

r - odległość


x' = x+Cos(DegToRad(alfa))*Cos(DegToRad(beta))*r 

y' = y+Sin(DegToRad(alfa))*Cos(DegToRad(beta))*r 

z' = z+Sin(DegToRad(beta))*r

alfa, beta - kąty: poziomy i pionowy

r - odległość

x' = x+Cos(DegToRad(alfa))*Cos(DegToRad(beta))*r

y' = y+Sin(DegToRad(alfa))*Cos(DegToRad(beta))*r

z' = z+Sin(DegToRad(beta))*r

Musisz dodać do uses Math. Autor: Toster

Czytaj więcej →