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:
1 2 3 |
SetMapMode(Canvas.Handle, MM_LOMETRIC); // "obraca" układ SetViewPortorgEx(canvas.handle, clientwidth div 2,clientheight div 2,nil); // przesuwa środek układu |
w funkcji setviewportorgex canvas.handle oznacza uchwyt do płótna na którym chcemy przestawić układ wsp.
clientwidth div 2, clientheight div 2 – współrzędne nowego układu
Kod sprawdzany pod d7 i win98 – działa 🙂
Mam nadzieje że się przyda
Pozdrawiam
DarkAndrew
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.
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 26 27 28 29 30 31 32 33 |
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; |
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 :
zielony : Pixels[x,Y]:=RGB(0,Nasycenie,0);
niebieski : Pixels[x,Y]:=RGB(0,0,Nasycenie);
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.
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 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 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 |
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
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.
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 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 52 53 54 55 56 57 |
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
Przedstawiony poniżej kod umożliwia stworzenie efektu rozmycia (blur) na dowolnym obrazie BMP. Format pikseli musi być 24 lub 32 bitowy.
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 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 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 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; end; end; Can.CopyRect(Rect(X,Y,Szerokosc,Wysokosc), Canvas, CurRect); end; finally TEMP.Free; end; end; |
Teraz wystarczy wywołać procedurę :
1 |
Rozmycie(image1.picture.Bitmap.Canvas,-10,-10,650,490); |
Autor: Nakiel
Na początku przypiszemy parametrowi BorderStyle utworzonego formularza wartość bsNone. Następnie wystarczy do źródła programu dodać poniższy kod:
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 26 27 |
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
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:
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 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 |
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; |
Wywołanie funkcji:
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 😉
Aby mieć możliwość rysowania po powierzchni paska tytułowego, musimy utworzyć nowy obiekt TCanvas, a następnie przypisać mu uchwyt naszego formularza.
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 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 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 |
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; |
Autor: Nakiel
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, aż w końcu dochodzimy do koloru końcowego.
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 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 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 |
procedure TForm1.Button1Click(Sender: TObject); var i , j : Integer ; x , y : Integer ; r , g , b : Real ; r2 , g2 , b2 : Real ; DodR , DodG , DodB : Real ; dr, dg , db : Integer ; dlugosc : Integer ; begin KolorPocz := PanelKolor1.Color ; KolorKonc := PanelKolor2.Color ; // składowe koloru początkowego r := GetRValue(KolorPocz) ; g := GetGValue(KolorPocz) ; b := GetBValue(KolorPocz) ; // składowe koloru końcowego r2 := GetRValue(KolorKonc) ; g2 := GetGValue(KolorKonc) ; b2 := GetBValue(KolorKonc) ; // różnice w składowych dr := Round(r2) - Round(r) ; dg := Round(g2) - Round(g) ; db := Round(b2) - Round(b) ; if Poziomo then begin dlugosc := PaintBox1.Width ; x := PaintBox1.Width - 1 ; y := PaintBox1.Height - 1 ; end else begin dlugosc := PaintBox1.Height ; y := PaintBox1.Width - 1 ; x := PaintBox1.Height - 1 ; end ; // obliczamy, o ile będziemy zmieniać poszczególne składowe if dr = 0 then DodR := 0 else DodR := dr / dlugosc ; if dg = 0 then DodG := 0 else DodG := dg / dlugosc ; if db = 0 then DodB := 0 else DodB := db / dlugosc ; for i := 0 to x do begin for j := 0 to y do begin if Poziomo then PaintBox1.Canvas.Pixels[i , j] := RGB(Round(r) , Round(g) , Round(b)) else PaintBox1.Canvas.Pixels[j , i] := RGB(Round(r) , Round(g) , Round(b)) ; end ; // zmieniamy składowe dopóki nie są identyczne z końcowymi if ((DodR > 0) and (r < r2)) or ((DodR < 0) and (r > r2)) then r := r + DodR ; if ((DodG > 0) and (g < g2)) or ((DodG < 0) and (g > g2)) then g := g + DodG ; if ((DodB > 0) and (b < b2)) or ((DodB < 0) and (b > b2)) then b := b + DodB ; end ; end; |
Autor: Iskar
Dla dwuwymiarowego układu:
1 2 3 4 5 6 7 8 |
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:
1 2 3 4 5 6 7 8 9 10 |
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
Skorzystaj z poniższej funkcji
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
function ColorToHtml(DColor:TColor):string; var tmpRGB : TColorRef; begin tmpRGB := ColorToRGB(DColor) ; Result:=Format('#%.2x%.2x%.2x', [GetRValue(tmpRGB), GetGValue(tmpRGB), GetBValue(tmpRGB)]) ; end; |
Autor: Nakiel
Możesz posłużyć się tym kodem :
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 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 |
function GetDesktopListViewHandle: THandle; var S: String; begin Result := FindWindow('ProgMan', nil); Result := GetWindow(Result, GW_CHILD); Result := GetWindow(Result, GW_CHILD); SetLength(S, 40); GetClassName(Result, PChar(S), 39); if PChar(S) <> 'SysListView32' then Result := 0; end; procedure TForm1.Button1Click(Sender: TObject); var uchwyt: HWND; dc: HDC; c: TCanvas; begin uchwyt := GetDesktopListViewHandle; dc := GetWindowDC(uchwyt); c := TCanvas.Create; c.Handle := dc; c.brush.color := clwhite; c.Rectangle(0,0,200,200); end; |
Użyj funkcji GetRValue, GetGValue oraz GetBValue, które zwracają kolejno natężenie barwy czerwonej, zielonej oraz niebieskiej:
1 2 3 4 5 6 |
var r , g , b : Byte ; begin r := GetRValue(jakis_kolor) ; g := GetGValue(jakis_kolor) ; b := GetBValue(jakis_kolor) ; |
Autor: Iskar
Użyj tego kodu:
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 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 |
function GetDesktopListViewHandle: THandle; var S: String; begin Result := FindWindow('ProgMan', nil); Result := GetWindow(Result, GW_CHILD); Result := GetWindow(Result, GW_CHILD); SetLength(S, 40); GetClassName(Result, PChar(S), 39); if PChar(S) <> 'SysListView32' then Result := 0; end; procedure TForm1.Timer1Timer(Sender: TObject); var uchwyt: HWND; dc: HDC; c: TCanvas; x,y,i:integer; begin uchwyt := GetDesktopListViewHandle; dc := GetWindowDC(uchwyt); c := TCanvas.Create; c.Handle := dc; ColorBox1.Color:=c.Pixels[Mouse.CursorPos.X,Mouse.CursorPos.Y]; end; |
Autor: Drazek
1 2 3 4 5 6 7 8 9 |
// funkcja zwraca *całkowitą* odleglosc 2 punktow od siebie function PointsDist(P1, P2: TPoint): Integer; begin Result := Round(Sqrt(Sqr(P1.X - P2.X) + Sqr(P1.Y - P2.Y))); end; |
Utwórz TImage, ustaw wielkość i nazwę (width 300,height=300, rys) i TButton, na który kliknij dwa razy.
Wpisz poniższy kod:
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 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 |
procedure TForm1.Button1Click(Sender: TObject); var x,y,srx,sry,a,b :integer; begin srx :=150; sry:= 150; //rysowanie układu Rys.Canvas.MoveTo(150,0); Rys.Canvas.LineTo(150,300); Rys.Canvas.MoveTo(0,150); Rys.Canvas.LineTo(300,150); //rysowanie lini for x:=-150 to 150 do begin a:=1; b:=0; y:=srx-(a*x+b); Rys.Canvas.MoveTo(x+srx,y); y:=srx-(a*(x+1)+b); Rys.Canvas.LineTo(x+srx,y); end; end; |
Autor: Spider100
Rozwiązanie jest bardzo proste – wystarczy dodać do uses Jpeg. Gotowe.
Autor: Iskar
Nowy kursor myszy dla tworzonego przez nas programu możemy wczytać w bardzo prosty sposób posługując się funkcją LoadImage oraz zwróconym w wyniku jej wywołania uchwytem. Oto kod całej procedury:
1 2 3 4 5 6 7 8 9 10 11 |
procedure TForm1.Button1Click(Sender: TObject); var h : THandle; begin h := LoadImage(0,'C:\program\Magic.ani', IMAGE_CURSOR, 0, 0, LR_LOADFROMFILE); if h = 0 then ShowMessage('Nie można wyświetlić kursora') else begin Screen.Cursors[1] := h; Form1.Cursor := 1; end; end; |