[Deplhi][Unit] Farbverläufe Zeichnen

      [Deplhi][Unit] Farbverläufe Zeichnen

      Heyho Delphi Fans,

      hier habt ihr eine Unit mit der ihr Farbverläufe in euren Applikationen erstellen könnt.

      Virustotal Check
      Downloadlink@DepositFiles

      Direkter Source Zugriff:

      Spoiler anzeigen

      Quellcode

      1. {------------------------------------------------------------------------------}
      2. { }
      3. { TGradient v2.71 }
      4. { by Kambiz R. Khojasteh }
      5. { }
      6. { kambiz@delphiarea.com }
      7. { http://www.delphiarea.com }
      8. { }
      9. {------------------------------------------------------------------------------}
      10. {$I DELPHIAREA.INC}
      11. unit Gradient;
      12. interface
      13. uses
      14. Windows, Messages, Classes, Graphics, Controls, ExtCtrls;
      15. type
      16. PRGBQuadArray = ^TRGBQuadArray;
      17. TRGBQuadArray = array[0..1024] of TRGBQuad;
      18. TGradientColors = array[0..255] of TRGBQuad;
      19. TGradientShift = -100..100;
      20. TGradientRotation = -100..100;
      21. {$IFNDEF COMPILER4_UP}
      22. TBorderWidth = 0..MaxInt;
      23. {$ENDIF}
      24. TGradientStyle = (gsCustom, gsRadialC, gsRadialT, gsRadialB, gsRadialL,
      25. gsRadialR, gsRadialTL, gsRadialTR, gsRadialBL, gsRadialBR, gsLinearH,
      26. gsLinearV, gsReflectedH, gsReflectedV, gsDiagonalLF, gsDiagonalLB,
      27. gsDiagonalRF, gsDiagonalRB, gsArrowL, gsArrowR, gsArrowU, gsArrowD,
      28. gsDiamond, gsButterfly, gsRadialRect);
      29. TCustomGradientEvent = procedure(Sender: TObject;
      30. const Colors: TGradientColors; Pattern: TBitmap) of object;
      31. TGradient = class(TGraphicControl)
      32. private
      33. fColorBegin: TColor;
      34. fColorEnd: TColor;
      35. fUseSysColors: Boolean;
      36. fStyle: TGradientStyle;
      37. fShift: TGradientShift;
      38. fRotation: TGradientRotation;
      39. fShape: TShapeType;
      40. fReverse: Boolean;
      41. fPattern: TBitmap;
      42. fBorderColor: TColor;
      43. fBorderWidth: TBorderWidth;
      44. fOnCustom: TCustomGradientEvent;
      45. fOnMouseEnter: TNotifyEvent;
      46. fOnMouseLeave: TNotifyEvent;
      47. UpdateCount: Integer;
      48. PatternReady: Boolean;
      49. procedure SetColorBegin(Value: TColor);
      50. procedure SetColorEnd(Value: TColor);
      51. procedure SetUseSysColors(Value: Boolean);
      52. procedure SetStyle(Value: TGradientStyle);
      53. procedure SetShift(Value: TGradientShift);
      54. procedure SetRotation(Value: TGradientRotation);
      55. procedure SetShape(Value: TShapeType);
      56. procedure SetReverse(Value: Boolean);
      57. procedure SetBorderColor(Value: TColor);
      58. procedure SetBorderWidth(Value: TBorderWidth);
      59. function IsColorBeginSaved: Boolean;
      60. function IsColorEndSaved: Boolean;
      61. procedure WMSettingChange(var Message: TMessage); message WM_SETTINGCHANGE;
      62. procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
      63. procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
      64. protected
      65. procedure Paint; override;
      66. procedure Loaded; override;
      67. procedure UpdatePattern; virtual;
      68. procedure UpdateSysColors; virtual;
      69. property Pattern: TBitmap read fPattern;
      70. public
      71. constructor Create(AOwner: TComponent); override;
      72. destructor Destroy; override;
      73. function CopyPatternTo(Bitmap: TBitmap): Boolean;
      74. procedure InvalidatePattern;
      75. procedure BeginUpdate;
      76. procedure EndUpdate;
      77. published
      78. property Align;
      79. {$IFDEF COMPILER4_UP}
      80. property Anchors;
      81. {$ENDIF}
      82. property BorderColor: TColor read fBorderColor write SetBorderColor default clActiveBorder;
      83. property BorderWidth: TBorderWidth read fBorderWidth write SetBorderWidth default 0;
      84. property ColorBegin: TColor read fColorBegin write SetColorBegin stored IsColorBeginSaved;
      85. property ColorEnd: TColor read fColorEnd write SetColorEnd stored IsColorEndSaved;
      86. {$IFDEF COMPILER4_UP}
      87. property Constraints;
      88. {$ENDIF}
      89. property DragCursor;
      90. {$IFDEF COMPILER4_UP}
      91. property DragKind;
      92. {$ENDIF}
      93. property DragMode;
      94. property Enabled;
      95. property Height default 100;
      96. property ParentShowHint;
      97. property PopupMenu;
      98. property Reverse: Boolean read fReverse write SetReverse default False;
      99. property Rotation: TGradientRotation read fRotation write SetRotation default 0;
      100. property Shape: TShapeType read fShape write SetShape default stRectangle;
      101. property Shift: TGradientShift read fShift write SetShift default 0;
      102. property ShowHint;
      103. property Style: TGradientStyle read fStyle write SetStyle default gsRadialC;
      104. property UseSysColors: Boolean read fUseSysColors write SetUseSysColors default False;
      105. property Visible;
      106. property Width default 100;
      107. property OnClick;
      108. property OnCustom: TCustomGradientEvent read fOnCustom write fOnCustom;
      109. property OnDblClick;
      110. property OnDragDrop;
      111. property OnDragOver;
      112. {$IFDEF COMPILER4_UP}
      113. property OnEndDock;
      114. {$ENDIF}
      115. property OnEndDrag;
      116. property OnMouseDown;
      117. property OnMouseEnter: TNotifyEvent read fOnMouseEnter write fOnMouseEnter;
      118. property OnMouseLeave: TNotifyEvent read fOnMouseLeave write fOnMouseLeave;
      119. property OnMouseMove;
      120. property OnMouseUp;
      121. {$IFDEF COMPILER4_UP}
      122. property OnStartDock;
      123. {$ENDIF}
      124. property OnStartDrag;
      125. end;
      126. procedure Register;
      127. implementation
      128. procedure RadialRect(const Colors: TGradientColors; Pattern: TBitmap);
      129. var
      130. X, Y: Integer;
      131. pRGB: PRGBQuad;
      132. Row1, Row2: PRGBQuadArray;
      133. begin
      134. Pattern.Width := 512;
      135. Pattern.Height := 512;
      136. for Y := 0 to 255 do
      137. begin
      138. // Top & Bottom
      139. Row1 := PRGBQuadArray(Pattern.ScanLine[Y]);
      140. Row2 := PRGBQuadArray(Pattern.ScanLine[511-Y]);
      141. pRGB := @Colors[y];
      142. for x:=Y to 511-y do
      143. begin
      144. Row1[X] := pRGB^;
      145. Row2[X] := pRGB^;
      146. end;
      147. for x:=0 to y do
      148. begin
      149. pRGB := @Colors[x];
      150. Row1[X] := pRGB^; // Left
      151. Row2[X] := pRGB^;
      152. Row1[511-X] := pRGB^; // Right
      153. Row2[511-X] := pRGB^;
      154. end
      155. end;
      156. end;
      157. procedure RadialCentral(const Colors: TGradientColors; Pattern: TBitmap);
      158. var
      159. X, Y, rX: Integer;
      160. pRGB: PRGBQuad;
      161. Row1, Row2: PRGBQuadArray;
      162. PreCalcXs: array[0..180] of Integer;
      163. begin
      164. Pattern.Width := 362;
      165. Pattern.Height := 362;
      166. rX := 0;
      167. for X := 180 downto 0 do
      168. begin
      169. PreCalcXs[rX] := X * X;
      170. Inc(rX);
      171. end;
      172. for Y := 180 downto 0 do
      173. begin
      174. Row1 := PRGBQuadArray(Pattern.ScanLine[Y]);
      175. Row2 := PRGBQuadArray(Pattern.ScanLine[361-Y]);
      176. for X := 180 downto 0 do
      177. begin
      178. rX := 361 - X;
      179. pRGB := @Colors[Round(Sqrt(PreCalcXs[X] + PreCalcXs[Y]))];
      180. Row1[X] := pRGB^;
      181. Row1[rX] := pRGB^;
      182. Row2[X] := pRGB^;
      183. Row2[rX] := pRGB^;
      184. end;
      185. end;
      186. { Not optimized code
      187. for Y := 0 to 361 do
      188. begin
      189. Row := PRGBQuadArray(Pattern.ScanLine[Y]);
      190. for X := 0 to 180 do
      191. Row[X] := Colors[Round(Sqrt(Sqr(180 - X) + Sqr(180 - Y)))];
      192. for X := 181 to 361 do
      193. Row[X] := Colors[Round(Sqrt(Sqr(X - 181) + Sqr(180 - Y)))];
      194. end;
      195. }
      196. end;
      197. procedure RadialTop(const Colors: TGradientColors; Pattern: TBitmap);
      198. var
      199. X, Y, rX, rY: Integer;
      200. pRGB: PRGBQuad;
      201. Row: PRGBQuadArray;
      202. PreCalcY: Integer;
      203. PreCalcXs: array[0..180] of Integer;
      204. begin
      205. Pattern.Width := 362;
      206. Pattern.Height := 181;
      207. rX := 0;
      208. for X := 180 downto 0 do
      209. begin
      210. PreCalcXs[rX] := X * X;
      211. Inc(rX);
      212. end;
      213. rY := 0;
      214. for Y := 180 downto 0 do
      215. begin
      216. Row := PRGBQuadArray(Pattern.ScanLine[Y]);
      217. PreCalcY := PreCalcXs[rY];
      218. rX := 181;
      219. for X := 180 downto 0 do
      220. begin
      221. pRGB := @Colors[Round(Sqrt(PreCalcXs[X] + PreCalcY))];
      222. Row[X] := pRGB^;
      223. Row[rX] := pRGB^;
      224. Inc(rX);
      225. end;
      226. Inc(rY);
      227. end;
      228. { Not optimized code
      229. for Y := 0 to 180 do
      230. begin
      231. Row := PRGBQuadArray(Pattern.ScanLine[Y]);
      232. for X := 0 to 180 do
      233. Row[X] := Colors[Round(Sqrt(Sqr(180 - X) + Sqr(Y)))];
      234. for X := 181 to 361 do
      235. Row[X] := Colors[Round(Sqrt(Sqr(X - 181) + Sqr(Y)))];
      236. end;
      237. }
      238. end;
      239. procedure RadialBottom(const Colors: TGradientColors; Pattern: TBitmap);
      240. var
      241. X, Y, rX: Integer;
      242. pRGB: PRGBQuad;
      243. Row: PRGBQuadArray;
      244. PreCalcY: Integer;
      245. PreCalcXs: array[0..180] of Integer;
      246. begin
      247. Pattern.Width := 362;
      248. Pattern.Height := 181;
      249. rX := 0;
      250. for X := 180 downto 0 do
      251. begin
      252. PreCalcXs[rX] := X * X;
      253. Inc(rX);
      254. end;
      255. for Y := 180 downto 0 do
      256. begin
      257. Row := PRGBQuadArray(Pattern.ScanLine[Y]);
      258. PreCalcY := PreCalcXs[Y];
      259. rX := 181;
      260. for X := 180 downto 0 do
      261. begin
      262. pRGB := @Colors[Round(Sqrt(PreCalcXs[X] + PreCalcY))];
      263. Row[X] := pRGB^;
      264. Row[rX]:= pRGB^;
      265. Inc(rX);
      266. end;
      267. end;
      268. { Not optimized code
      269. for Y := 0 to 180 do
      270. begin
      271. Row := PRGBQuadArray(Pattern.ScanLine[Y]);
      272. for X := 0 to 180 do
      273. Row[X] := Colors[Round(Sqrt(Sqr(180 - X) + Sqr(180 - Y)))];
      274. for X := 181 to 361 do
      275. Row[X] := Colors[Round(Sqrt(Sqr(X - 181) + Sqr(180 - Y)))];
      276. end;
      277. }
      278. end;
      279. procedure RadialLeft(const Colors: TGradientColors; Pattern: TBitmap);
      280. var
      281. X, Y, rY: Integer;
      282. pRGB: PRGBQuad;
      283. Row1, Row2: PRGBQuadArray;
      284. PreCalcY: Integer;
      285. PreCalcXs: array[0..180] of Integer;
      286. begin
      287. Pattern.Width := 181;
      288. Pattern.Height := 362;
      289. for X := 180 downto 0 do
      290. PreCalcXs[X] := X * X;
      291. rY := 180;
      292. for Y := 0 to 180 do
      293. begin
      294. Row1 := PRGBQuadArray(Pattern.ScanLine[Y]);
      295. Row2 := PRGBQuadArray(Pattern.ScanLine[361-Y]);
      296. PreCalcY := PreCalcXs[rY];
      297. for X := 0 to 180 do
      298. begin
      299. pRGB := @Colors[Round(Sqrt(PreCalcXs[X] + PreCalcY))];
      300. Row1[X] := pRGB^;
      301. Row2[X] := pRGB^;
      302. end;
      303. Dec(rY);
      304. end;
      305. { Not optimized code
      306. for Y := 0 to 180 do
      307. begin
      308. Row := PRGBQuadArray(Pattern.ScanLine[Y]);
      309. for X := 0 to 180 do
      310. Row[X] := Colors[Round(Sqrt(Sqr(X) + Sqr(180 - Y)))];
      311. end;
      312. for Y := 181 to 361 do
      313. begin
      314. Row := PRGBQuadArray(Pattern.ScanLine[Y]);
      315. for X := 0 to 180 do
      316. Row[X] := Colors[Round(Sqrt(Sqr(X) + Sqr(Y - 181)))];
      317. end;
      318. }
      319. end;
      320. procedure RadialRight(const Colors: TGradientColors; Pattern: TBitmap);
      321. var
      322. X, Y, rX: Integer;
      323. pRGB: PRGBQuad;
      324. Row1, Row2: PRGBQuadArray;
      325. PreCalcXs: array[0..180] of Integer;
      326. begin
      327. Pattern.Width := 181;
      328. Pattern.Height := 362;
      329. rX := 0;
      330. for X := 180 downto 0 do
      331. begin
      332. PreCalcXs[rX] := X * X;
      333. Inc(rX);
      334. end;
      335. for Y := 0 to 180 do
      336. begin
      337. Row1 := PRGBQuadArray(Pattern.ScanLine[Y]);
      338. Row2 := PRGBQuadArray(Pattern.ScanLine[361-Y]);
      339. for X := 0 to 180 do
      340. begin
      341. pRGB := @Colors[Round(Sqrt(PreCalcXs[X] + PreCalcXs[Y]))];
      342. Row1[X] := pRGB^;
      343. Row2[X] := pRGB^;
      344. end;
      345. end;
      346. { Not optimized code
      347. for Y := 0 to 180 do
      348. begin
      349. Row := PRGBQuadArray(Pattern.ScanLine[Y]);
      350. for X := 0 to 180 do
      351. Row[X] := Colors[Round(Sqrt(Sqr(180 - X) + Sqr(180 - Y)))];
      352. end;
      353. for Y := 181 to 361 do
      354. begin
      355. Row := PRGBQuadArray(Pattern.ScanLine[Y]);
      356. for X := 0 to 180 do
      357. Row[X] := Colors[Round(Sqrt(Sqr(180 - X) + Sqr(Y - 181)))];
      358. end;
      359. }
      360. end;
      361. procedure RadialTopLeft(const Colors: TGradientColors; Pattern: TBitmap);
      362. var
      363. X, Y: Integer;
      364. Row: PRGBQuadArray;
      365. PreCalcY: Integer;
      366. PreCalcXs: array[0..180] of Integer;
      367. begin
      368. Pattern.Width := 181;
      369. Pattern.Height := 181;
      370. for X := 180 downto 0 do
      371. PreCalcXs[X] := X * X;
      372. for Y := 0 to 180 do
      373. begin
      374. Row := PRGBQuadArray(Pattern.ScanLine[Y]);
      375. PreCalcY := PreCalcXs[Y];
      376. for X := 0 to 180 do
      377. Row[X] := Colors[Round(Sqrt(PreCalcXs[X] + PreCalcY))];
      378. end;
      379. { Not optimized code
      380. for Y := 0 to 180 do
      381. begin
      382. Row := PRGBQuadArray(Pattern.ScanLine[Y]);
      383. for X := 0 to 180 do
      384. Row[X] := Colors[Round(Sqrt(Sqr(X) + Sqr(Y)))];
      385. end;
      386. }
      387. end;
      388. procedure RadialTopRight(const Colors: TGradientColors; Pattern: TBitmap);
      389. var
      390. X, Y, rX, rY: Integer;
      391. Row: PRGBQuadArray;
      392. PreCalcY: Integer;
      393. PreCalcXs: array[0..180] of Integer;
      394. begin
      395. Pattern.Width := 181;
      396. Pattern.Height := 181;
      397. rX :=0;
      398. for X := 180 downto 0 do
      399. begin
      400. PreCalcXs[rX] := X * X;
      401. Inc(rX);
      402. end;
      403. rY := 180;
      404. for Y := 0 to 180 do
      405. begin
      406. Row := PRGBQuadArray(Pattern.ScanLine[Y]);
      407. PreCalcY := PreCalcXs[rY];
      408. for X := 0 to 180 do
      409. Row[X] := Colors[Round(Sqrt(PreCalcXs[X] + PreCalcY))];
      410. Dec(rY);
      411. end;
      412. { Not optimized code
      413. for Y := 0 to 180 do
      414. begin
      415. Row := PRGBQuadArray(Pattern.ScanLine[Y]);
      416. for X := 0 to 180 do
      417. Row[X] := Colors[Round(Sqrt(Sqr(180 - X) + Sqr(Y)))];
      418. end;
      419. }
      420. end;
      421. procedure RadialBottomLeft(const Colors: TGradientColors; Pattern: TBitmap);
      422. var
      423. X, Y, rY: Integer;
      424. Row: PRGBQuadArray;
      425. PreCalcY: Integer;
      426. PreCalcXs: array[0..180] of Integer;
      427. begin
      428. Pattern.Width := 181;
      429. Pattern.Height := 181;
      430. for X := 180 downto 0 do
      431. PreCalcXs[X] := X * X;
      432. rY := 180;
      433. for Y := 0 to 180 do
      434. begin
      435. Row := PRGBQuadArray(Pattern.ScanLine[Y]);
      436. PreCalcY := PreCalcXs[rY];
      437. for X := 0 to 180 do
      438. Row[X] := Colors[Round(Sqrt(PreCalcXs[X] + PreCalcY))];
      439. Dec(rY);
      440. end;
      441. { Not optimized code
      442. for Y := 0 to 180 do
      443. begin
      444. Row := PRGBQuadArray(Pattern.ScanLine[Y]);
      445. for X := 0 to 180 do
      446. Row[X] := Colors[Round(Sqrt(Sqr(X) + Sqr(180 - Y)))];
      447. end;
      448. }
      449. end;
      450. procedure RadialBottomRight(const Colors: TGradientColors; Pattern: TBitmap);
      451. var
      452. X, Y, rX: Integer;
      453. Row: PRGBQuadArray;
      454. PreCalcY: Integer;
      455. PreCalcXs: array[0..180] of Integer;
      456. begin
      457. Pattern.Width := 181;
      458. Pattern.Height := 181;
      459. rX := 0;
      460. for X := 180 downto 0 do
      461. begin
      462. PreCalcXs[rX] := X * X;
      463. Inc(rX);
      464. end;
      465. for Y := 0 to 180 do
      466. begin
      467. Row := PRGBQuadArray(Pattern.ScanLine[Y]);
      468. PreCalcY := PreCalcXs[Y];
      469. for X := 0 to 180 do
      470. Row[X] := Colors[Round(Sqrt(PreCalcXs[X] + PreCalcY))];
      471. end;
      472. { Not optimized code
      473. for Y := 0 to 180 do
      474. begin
      475. Row := PRGBQuadArray(Pattern.ScanLine[Y]);
      476. for X := 0 to 180 do
      477. Row[X] := Colors[Round(Sqrt(Sqr(180 - X) + Sqr(180 - Y)))];
      478. end;
      479. }
      480. end;
      481. procedure LinearHorizontal(const Colors: TGradientColors; Pattern: TBitmap);
      482. var
      483. X: Integer;
      484. Row: PRGBQuadArray;
      485. begin
      486. Pattern.Width := 256;
      487. Pattern.Height := 1;
      488. Row := PRGBQuadArray(Pattern.ScanLine[0]);
      489. for X := 0 to 255 do
      490. Row[X] := Colors[X];
      491. end;
      492. procedure LinearVertical(const Colors: TGradientColors; Pattern: TBitmap);
      493. var
      494. Y: Integer;
      495. Row: PRGBQuadArray;
      496. begin
      497. Pattern.Width := 1;
      498. Pattern.Height := 256;
      499. for Y := 0 to 255 do
      500. begin
      501. Row := PRGBQuadArray(Pattern.ScanLine[Y]);
      502. Row[0] := Colors[Y];
      503. end;
      504. end;
      505. procedure ReflectedHorizontal(const Colors: TGradientColors; Pattern: TBitmap);
      506. var
      507. Y: Integer;
      508. Row: PRGBQuadArray;
      509. begin
      510. Pattern.Width := 1;
      511. Pattern.Height := 512;
      512. for Y := 0 to 255 do
      513. begin
      514. Row := PRGBQuadArray(Pattern.ScanLine[Y]);
      515. Row[0] := Colors[255 - Y];
      516. Row := PRGBQuadArray(Pattern.ScanLine[511 - Y]);
      517. Row[0] := Colors[255 - Y];
      518. end;
      519. end;
      520. procedure ReflectedVertical(const Colors: TGradientColors; Pattern: TBitmap);
      521. var
      522. X: Integer;
      523. Row: PRGBQuadArray;
      524. begin
      525. Pattern.Width := 512;
      526. Pattern.Height := 1;
      527. Row := PRGBQuadArray(Pattern.ScanLine[0]);
      528. for X := 0 to 255 do
      529. begin
      530. Row[X] := Colors[255 - X];
      531. Row[511 - X] := Colors[255 - X];
      532. end;
      533. end;
      534. procedure DiagonalLinearForward(const Colors: TGradientColors; Pattern: TBitmap);
      535. var
      536. X, Y: Integer;
      537. Row: PRGBQuadArray;
      538. begin
      539. Pattern.Width := 128;
      540. Pattern.Height := 129;
      541. for Y := 0 to 128 do
      542. begin
      543. Row := PRGBQuadArray(Pattern.ScanLine[Y]);
      544. for X := 0 to 127 do
      545. Row[X] := Colors[X + Y];
      546. end;
      547. end;
      548. procedure DiagonalLinearBackward(const Colors: TGradientColors; Pattern: TBitmap);
      549. var
      550. X, Y: Integer;
      551. Row: PRGBQuadArray;
      552. begin
      553. Pattern.Width := 128;
      554. Pattern.Height := 129;
      555. for Y := 0 to 128 do
      556. begin
      557. Row := PRGBQuadArray(Pattern.ScanLine[Y]);
      558. for X := 0 to 127 do
      559. Row[X] := Colors[127 + (Y - X)];
      560. end;
      561. end;
      562. procedure DiagonalReflectedForward(const Colors: TGradientColors; Pattern: TBitmap);
      563. var
      564. X, Y: Integer;
      565. Row: PRGBQuadArray;
      566. begin
      567. Pattern.Width := 256;
      568. Pattern.Height := 256;
      569. for Y := 0 to 255 do
      570. begin
      571. Row := PRGBQuadArray(Pattern.ScanLine[Y]);
      572. for X := 0 to 255 do
      573. if X + Y < 255 then
      574. Row[X] := Colors[255 - (X + Y)]
      575. else
      576. Row[X] := Colors[(Y + X) - 255];
      577. end;
      578. end;
      579. procedure DiagonalReflectedBackward(const Colors: TGradientColors; Pattern: TBitmap);
      580. var
      581. X, Y: Integer;
      582. Row: PRGBQuadArray;
      583. begin
      584. Pattern.Width := 256;
      585. Pattern.Height := 256;
      586. for Y := 0 to 255 do
      587. begin
      588. Row := PRGBQuadArray(Pattern.ScanLine[Y]);
      589. for X := 0 to 255 do
      590. if X > Y then
      591. Row[X] := Colors[X - Y]
      592. else
      593. Row[X] := Colors[Y - X];
      594. end;
      595. end;
      596. procedure ArrowLeft(const Colors: TGradientColors; Pattern: TBitmap);
      597. var
      598. X, Y: Integer;
      599. Row: PRGBQuadArray;
      600. begin
      601. Pattern.Width := 129;
      602. Pattern.Height := 256;
      603. for Y := 0 to 127 do
      604. begin
      605. Row := PRGBQuadArray(Pattern.ScanLine[Y]);
      606. for X := 0 to 128 do
      607. Row[X] := Colors[255 - (X + Y)];
      608. end;
      609. for Y := 128 to 255 do
      610. begin
      611. Row := PRGBQuadArray(Pattern.ScanLine[Y]);
      612. for X := 0 to 128 do
      613. Row[X] := Colors[Y - X];
      614. end;
      615. end;
      616. procedure ArrowRight(const Colors: TGradientColors; Pattern: TBitmap);
      617. var
      618. X, Y: Integer;
      619. Row: PRGBQuadArray;
      620. begin
      621. Pattern.Width := 129;
      622. Pattern.Height := 256;
      623. for Y := 0 to 127 do
      624. begin
      625. Row := PRGBQuadArray(Pattern.ScanLine[Y]);
      626. for X := 0 to 128 do
      627. Row[X] := Colors[(X - Y) + 127];
      628. end;
      629. for Y := 128 to 255 do
      630. begin
      631. Row := PRGBQuadArray(Pattern.ScanLine[Y]);
      632. for X := 0 to 128 do
      633. Row[X] := Colors[(X + Y) - 128];
      634. end;
      635. end;
      636. procedure ArrowUp(const Colors: TGradientColors; Pattern: TBitmap);
      637. var
      638. X, Y: Integer;
      639. Row: PRGBQuadArray;
      640. begin
      641. Pattern.Width := 256;
      642. Pattern.Height := 129;
      643. for Y := 0 to 128 do
      644. begin
      645. Row := PRGBQuadArray(Pattern.ScanLine[Y]);
      646. for X := 0 to 127 do
      647. Row[X] := Colors[255 - (X + Y)];
      648. for X := 128 to 255 do
      649. Row[X] := Colors[X - Y];
      650. end;
      651. end;
      652. procedure ArrowDown(const Colors: TGradientColors; Pattern: TBitmap);
      653. var
      654. X, Y: Integer;
      655. Row: PRGBQuadArray;
      656. begin
      657. Pattern.Width := 256;
      658. Pattern.Height := 129;
      659. for Y := 0 to 128 do
      660. begin
      661. Row := PRGBQuadArray(Pattern.ScanLine[Y]);
      662. for X := 0 to 127 do
      663. Row[X] := Colors[127 + (Y - X)];
      664. for X := 128 to 255 do
      665. Row[X] := Colors[(X + Y) - 128];
      666. end;
      667. end;
      668. procedure Diamond(const Colors: TGradientColors; Pattern: TBitmap);
      669. var
      670. X, Y: Integer;
      671. Row: PRGBQuadArray;
      672. begin
      673. Pattern.Width := 256;
      674. Pattern.Height := 256;
      675. for Y := 0 to 127 do
      676. begin
      677. Row := PRGBQuadArray(Pattern.ScanLine[Y]);
      678. for X := 0 to 127 do
      679. Row[X] := Colors[255 - (X + Y)];
      680. for X := 128 to 255 do
      681. Row[X] := Colors[X - Y];
      682. end;
      683. for Y := 128 to 255 do
      684. begin
      685. Row := PRGBQuadArray(Pattern.ScanLine[Y]);
      686. for X := 0 to 127 do
      687. Row[X] := Colors[Y - X];
      688. for X := 128 to 255 do
      689. Row[X] := Colors[(X + Y) - 255];
      690. end;
      691. end;
      692. procedure Butterfly(const Colors: TGradientColors; Pattern: TBitmap);
      693. var
      694. X, Y: Integer;
      695. Row: PRGBQuadArray;
      696. begin
      697. Pattern.Width := 256;
      698. Pattern.Height := 256;
      699. for Y := 0 to 127 do
      700. begin
      701. Row := PRGBQuadArray(Pattern.ScanLine[Y]);
      702. for X := 0 to 127 do
      703. Row[X] := Colors[(X - Y) + 128];
      704. for X := 128 to 255 do
      705. Row[X] := Colors[383 - (X + Y)];
      706. end;
      707. for Y := 128 to 255 do
      708. begin
      709. Row := PRGBQuadArray(Pattern.ScanLine[Y]);
      710. for X := 0 to 127 do
      711. Row[X] := Colors[(X + Y) - 128];
      712. for X := 128 to 255 do
      713. Row[X] := Colors[128 + (Y - X)];
      714. end;
      715. end;
      716. { TGradient }
      717. type
      718. TPatternBuilder = procedure(const Colors: TGradientColors; Pattern: TBitmap);
      719. const
      720. PatternBuilder: array[TGradientStyle] of TPatternBuilder = (nil,
      721. RadialCentral, RadialTop, RadialBottom, RadialLeft, RadialRight,
      722. RadialTopLeft, RadialTopRight, RadialBottomLeft, RadialBottomRight,
      723. LinearHorizontal, LinearVertical, ReflectedHorizontal, ReflectedVertical,
      724. DiagonalLinearForward, DiagonalLinearBackward, DiagonalReflectedForward,
      725. DiagonalReflectedBackward, ArrowLeft, ArrowRight, ArrowUp, ArrowDown,
      726. Diamond, Butterfly, RadialRect);
      727. constructor TGradient.Create(AOwner: TComponent);
      728. begin
      729. inherited Create(AOwner);
      730. ControlStyle := ControlStyle + [csOpaque];
      731. Width := 100;
      732. Height := 100;
      733. fColorBegin := clWhite;
      734. fColorEnd := clBtnFace;
      735. fStyle := gsRadialC;
      736. fBorderColor := clActiveBorder;
      737. fBorderWidth := 0;
      738. fShift := 0;
      739. fRotation := 0;
      740. fShape := stRectangle;
      741. fReverse := False;
      742. fUseSysColors := False;
      743. fPattern := TBitmap.Create;
      744. fPattern.PixelFormat := pf32bit;
      745. UpdatePattern;
      746. end;
      747. destructor TGradient.Destroy;
      748. begin
      749. fPattern.Free;
      750. inherited Destroy;
      751. end;
      752. procedure TGradient.Loaded;
      753. begin
      754. inherited Loaded;
      755. UpdatePattern;
      756. end;
      757. procedure TGradient.Paint;
      758. var
      759. X, Y, W, H, S: Integer;
      760. Rgn: THandle;
      761. Org: TPoint;
      762. begin
      763. if not PatternReady then
      764. Exit;
      765. if (BorderWidth = 0) and (csOpaque in ControlStyle) then
      766. begin
      767. Canvas.StretchDraw(ClientRect, Pattern);
      768. Exit;
      769. end;
      770. X := BorderWidth div 2;
      771. Y := X;
      772. W := Width - BorderWidth + Ord(BorderWidth <> 0);
      773. H := Height - BorderWidth + Ord(BorderWidth <> 0);
      774. if W < H then S := W else S := H;
      775. if Shape in [stSquare, stCircle, stRoundSquare] then
      776. begin
      777. Inc(X, (W - S) div 2);
      778. Inc(Y, (H - S) div 2);
      779. W := S;
      780. H := S;
      781. end;
      782. if not (csOpaque in ControlStyle) then
      783. begin
      784. Rgn := 0;
      785. case Shape of
      786. stRectangle, stSquare:
      787. Rgn := CreateRectRgn(X, Y, X + W, Y + H);
      788. stEllipse, stCircle:
      789. Rgn := CreateEllipticRgn(X, Y, X + W, Y + H);
      790. stRoundRect, stRoundSquare:
      791. Rgn := CreateRoundRectRgn(X, Y, X + W, Y + H, S div 4, S div 4);
      792. end;
      793. GetWindowOrgEx(Canvas.Handle, Org);
      794. OffsetRgn(Rgn, -Org.X, -Org.Y);
      795. SelectClipRgn(Canvas.Handle, Rgn);
      796. Canvas.StretchDraw(Rect(X, Y, X + W, Y + H), Pattern);
      797. SelectClipRgn(Canvas.Handle, 0);
      798. DeleteObject(Rgn);
      799. end
      800. else
      801. Canvas.StretchDraw(Rect(X, Y, X + W, Y + H), Pattern);
      802. if BorderWidth > 0 then
      803. begin
      804. Canvas.Pen.Width := BorderWidth;
      805. Canvas.Pen.Color := BorderColor;
      806. Canvas.Brush.Style := bsClear;
      807. case Shape of
      808. stRectangle, stSquare:
      809. Canvas.Rectangle(X, Y, X + W, Y + H);
      810. stEllipse, stCircle:
      811. Canvas.Ellipse(X, Y, X + W, Y + H);
      812. stRoundRect, stRoundSquare:
      813. Canvas.RoundRect(X, Y, X + W, Y + H, S div 4, S div 4);
      814. end;
      815. end;
      816. end;
      817. procedure TGradient.BeginUpdate;
      818. begin
      819. Inc(UpdateCount);
      820. end;
      821. procedure TGradient.EndUpdate;
      822. begin
      823. Dec(UpdateCount);
      824. if (UpdateCount = 0) and not PatternReady then
      825. UpdatePattern;
      826. end;
      827. function TGradient.CopyPatternTo(Bitmap: TBitmap): Boolean;
      828. begin
      829. Result := False;
      830. if PatternReady and (UpdateCount = 0) and Assigned(Bitmap) then
      831. begin
      832. Bitmap.Assign(Pattern);
      833. Result := True;
      834. end;
      835. end;
      836. procedure TGradient.InvalidatePattern;
      837. begin
      838. UpdatePattern;
      839. end;
      840. procedure TGradient.WMSettingChange(var Message: TMessage);
      841. begin
      842. inherited;
      843. if UseSysColors then
      844. UpdateSysColors;
      845. end;
      846. procedure TGradient.CMMouseEnter(var Message: TMessage);
      847. begin
      848. inherited;
      849. if Assigned(fOnMouseEnter) then
      850. fOnMouseEnter(Self);
      851. end;
      852. procedure TGradient.CMMouseLeave(var Message: TMessage);
      853. begin
      854. inherited;
      855. if Assigned(fOnMouseLeave) then
      856. fOnMouseLeave(Self);
      857. end;
      858. procedure TGradient.SetColorBegin(Value: TColor);
      859. begin
      860. if fColorBegin <> Value then
      861. begin
      862. fColorBegin := Value;
      863. fUseSysColors := False;
      864. UpdatePattern;
      865. end;
      866. end;
      867. procedure TGradient.SetColorEnd(Value: TColor);
      868. begin
      869. if fColorEnd <> Value then
      870. begin
      871. fColorEnd := Value;
      872. fUseSysColors := False;
      873. UpdatePattern;
      874. end;
      875. end;
      876. procedure TGradient.SetBorderColor(Value: TColor);
      877. begin
      878. if fBorderColor <> Value then
      879. begin
      880. fBorderColor := Value;
      881. Invalidate;
      882. end;
      883. end;
      884. procedure TGradient.SetBorderWidth(Value: TBorderWidth);
      885. begin
      886. if fBorderWidth <> Value then
      887. begin
      888. fBorderWidth := Value;
      889. Invalidate;
      890. end;
      891. end;
      892. procedure TGradient.SetUseSysColors(Value: Boolean);
      893. begin
      894. if fUseSysColors <> Value then
      895. begin
      896. fUseSysColors := Value;
      897. if fUseSysColors then
      898. UpdateSysColors;
      899. end;
      900. end;
      901. procedure TGradient.SetStyle(Value: TGradientStyle);
      902. begin
      903. if fStyle <> Value then
      904. begin
      905. fStyle := Value;
      906. UpdatePattern;
      907. end;
      908. end;
      909. procedure TGradient.SetShift(Value: TGradientShift);
      910. begin
      911. if Value < Low(TGradientShift) then
      912. Value := Low(TGradientShift)
      913. else if Value > High(TGradientShift) then
      914. Value := High(TGradientShift);
      915. if fShift <> Value then
      916. begin
      917. fShift := Value;
      918. UpdatePattern;
      919. end;
      920. end;
      921. procedure TGradient.SetRotation(Value: TGradientRotation);
      922. begin
      923. if Value < Low(TGradientRotation) then
      924. Value := Low(TGradientRotation)
      925. else if Value > High(TGradientRotation) then
      926. Value := High(TGradientRotation);
      927. if fRotation <> Value then
      928. begin
      929. fRotation := Value;
      930. UpdatePattern;
      931. end;
      932. end;
      933. procedure TGradient.SetReverse(Value: Boolean);
      934. begin
      935. if fReverse <> Value then
      936. begin
      937. fReverse := Value;
      938. UpdatePattern;
      939. end;
      940. end;
      941. procedure TGradient.SetShape(Value: TShapeType);
      942. begin
      943. if fShape <> Value then
      944. begin
      945. fShape := Value;
      946. if fShape = stRectangle then
      947. ControlStyle := ControlStyle + [csOpaque]
      948. else
      949. ControlStyle := ControlStyle - [csOpaque];
      950. Invalidate;
      951. end;
      952. end;
      953. function TGradient.IsColorBeginSaved: Boolean;
      954. begin
      955. Result := not UseSysColors and (ColorBegin <> clWhite);
      956. end;
      957. function TGradient.IsColorEndSaved: Boolean;
      958. begin
      959. Result := not UseSysColors and (ColorEnd <> clBtnFace);
      960. end;
      961. procedure TGradient.UpdateSysColors;
      962. {$IFNDEF COMPILER4_UP}
      963. const
      964. COLOR_GRADIENTACTIVECAPTION = 27;
      965. {$ENDIF}
      966. begin
      967. BeginUpdate;
      968. try
      969. ColorBegin := GetSysColor(COLOR_ACTIVECAPTION);
      970. try
      971. ColorEnd := GetSysColor(COLOR_GRADIENTACTIVECAPTION);
      972. fUseSysColors := True;
      973. except
      974. // This version of Widnows doesn't support gradient colors...
      975. ColorEnd := ColorBegin;
      976. fUseSysColors := False;
      977. end;
      978. finally
      979. EndUpdate;
      980. end;
      981. end;
      982. procedure TGradient.UpdatePattern;
      983. var
      984. Colors: TGradientColors;
      985. dRed, dGreen, dBlue: Integer;
      986. RGBColor1, RGBColor2: TColor;
      987. RGB1, RGB2: TRGBQuad;
      988. UpdatedRect: TRect;
      989. Index, rIndex: Integer;
      990. M, rM: Integer;
      991. begin
      992. PatternReady := False;
      993. if (csLoading in ComponentState) or (UpdateCount <> 0) then Exit;
      994. if Reverse then
      995. begin
      996. RGBColor1 := ColorToRGB(ColorEnd);
      997. RGBColor2 := ColorToRGB(ColorBegin);
      998. end
      999. else
      1000. begin
      1001. RGBColor1 := ColorToRGB(ColorBegin);
      1002. RGBColor2 := ColorToRGB(ColorEnd);
      1003. end;
      1004. RGB1.rgbRed := GetRValue(RGBColor1);
      1005. RGB1.rgbGreen := GetGValue(RGBColor1);
      1006. RGB1.rgbBlue := GetBValue(RGBColor1);
      1007. RGB1.rgbReserved := 0;
      1008. RGB2.rgbRed := GetRValue(RGBColor2);
      1009. RGB2.rgbGreen := GetGValue(RGBColor2);
      1010. RGB2.rgbBlue := GetBValue(RGBColor2);
      1011. RGB2.rgbReserved := 0;
      1012. if Shift > 0 then
      1013. begin
      1014. RGB1.rgbRed := Byte(RGB1.rgbRed + MulDiv(RGB2.rgbRed - RGB1.rgbRed, Shift, 100));
      1015. RGB1.rgbGreen := Byte(RGB1.rgbGreen + MulDiv(RGB2.rgbGreen - RGB1.rgbGreen, Shift, 100));
      1016. RGB1.rgbBlue := Byte(RGB1.rgbBlue + MulDiv(RGB2.rgbBlue - RGB1.rgbBlue, Shift, 100));
      1017. end
      1018. else if Shift < 0 then
      1019. begin
      1020. RGB2.rgbRed := Byte(RGB2.rgbRed + MulDiv(RGB2.rgbRed - RGB1.rgbRed, Shift, 100));
      1021. RGB2.rgbGreen := Byte(RGB2.rgbGreen + MulDiv(RGB2.rgbGreen - RGB1.rgbGreen, Shift, 100));
      1022. RGB2.rgbBlue := Byte(RGB2.rgbBlue + MulDiv(RGB2.rgbBlue - RGB1.rgbBlue, Shift, 100));
      1023. end;
      1024. dRed := RGB2.rgbRed - RGB1.rgbRed;
      1025. dGreen := RGB2.rgbGreen - RGB1.rgbGreen;
      1026. dBlue := RGB2.rgbBlue - RGB1.rgbBlue;
      1027. M := MulDiv(255, Rotation, 100);
      1028. if M = 0 then
      1029. for Index := 0 to 255 do
      1030. with Colors[Index] do
      1031. begin
      1032. rgbRed := RGB1.rgbRed + (Index * dRed) div 255;
      1033. rgbGreen := RGB1.rgbGreen + (Index * dGreen) div 255;
      1034. rgbBlue := RGB1.rgbBlue + (Index * dBlue) div 255;
      1035. end
      1036. else if M > 0 then
      1037. begin
      1038. M := 255 - M;
      1039. for Index := 0 to M - 1 do
      1040. with Colors[Index] do
      1041. begin
      1042. rgbRed := RGB1.rgbRed + (Index * dRed) div M;
      1043. rgbGreen := RGB1.rgbGreen + (Index * dGreen) div M;
      1044. rgbBlue := RGB1.rgbBlue + (Index * dBlue) div M;
      1045. end;
      1046. for Index := M to 255 do
      1047. with Colors[Index] do
      1048. begin
      1049. rIndex := 255 - Index;
      1050. rM := 255 - M;
      1051. rgbRed := RGB1.rgbRed + ((rIndex) * dRed) div (rM);
      1052. rgbGreen := RGB1.rgbGreen + ((rIndex) * dGreen) div (rM);
      1053. rgbBlue := RGB1.rgbBlue + ((rIndex) * dBlue) div (rM);
      1054. end;
      1055. end
      1056. else if M < 0 then
      1057. begin
      1058. M := -M;
      1059. for Index := 0 to M do
      1060. with Colors[Index] do
      1061. begin
      1062. rgbRed := RGB2.rgbRed - (Index * dRed) div M;
      1063. rgbGreen := RGB2.rgbGreen - (Index * dGreen) div M;
      1064. rgbBlue := RGB2.rgbBlue - (Index * dBlue) div M;
      1065. end;
      1066. for Index := M + 1 to 255 do
      1067. with Colors[Index] do
      1068. begin
      1069. rIndex := 255 - Index;
      1070. rM := 255 - M;
      1071. rgbRed := RGB2.rgbRed - ((rIndex) * dRed) div (rM);
      1072. rgbGreen := RGB2.rgbGreen - ((rIndex) * dGreen) div (rM);
      1073. rgbBlue := RGB2.rgbBlue - ((rIndex) * dBlue) div (rM);
      1074. end;
      1075. end;
      1076. if @PatternBuilder[Style] <> nil then
      1077. PatternBuilder[Style](Colors, Pattern)
      1078. else if Assigned(fOnCustom) then
      1079. fOnCustom(Self, Colors, Pattern)
      1080. else
      1081. begin
      1082. Pattern.Width := 2;
      1083. Pattern.Height := 2;
      1084. Pattern.Canvas.Pixels[0, 0] := RGBColor1;
      1085. Pattern.Canvas.Pixels[0, 1] := RGBColor2;
      1086. Pattern.Canvas.Pixels[1, 0] := RGBColor2;
      1087. Pattern.Canvas.Pixels[1, 1] := RGBColor1;
      1088. end;
      1089. PatternReady := True;
      1090. if (Parent <> nil) and Parent.HandleAllocated then
      1091. begin
      1092. UpdatedRect := BoundsRect;
      1093. InvalidateRect(Parent.Handle, @UpdatedRect, False);
      1094. if csDesigning in ComponentState then Parent.Update;
      1095. end
      1096. else
      1097. Invalidate;
      1098. end;
      1099. procedure Register;
      1100. begin
      1101. RegisterComponents('Delphi Area', [TGradient]);
      1102. end;
      1103. end.



      Screenshot:


      Benötigt:
      TPaintBox

      Beispiel:
      Form Ereigniss@OnPaint


      Quellcode

      1. uses UnitName;
      2. procedure TForm3.FormPaint(Sender: TObject);
      3. begin
      4. GradVertical(PaintBox1.Canvas, PaintBox1.ClientRect, clCream, clSkyBlue) ;
      5. end;



      Dieser Befehl würde wenn eure Form erstellt wurde, in der PaintBox einen Vertikalen Farbverlauf einzeichnen.
      Es gibt auch die Funktion GradHorizontal um einen Horizontalen Farbverlauf einzuzeichnen.




      Malibu
      [progressbar=2]Fulcrum[/progressbar]
      Also entweder hat er ne Glühbirne im Arsch oder sein Darm hat ne gute Idee

      Dieser Beitrag wurde bereits 2 mal editiert, zuletzt von „Malibu“ ()

      Ich mag Delphi auch wenn ich nicht mehr drin programmiere... es ist einfach sauber weil es noch schön trennt und strukturiert... beispiel definition und deklarataion :)

      @derpy hooves: virustotal war etwas überflüssig :D ist ja nur die source-datei xD
      habe aber mal pascal mit in die attachments genommen, jetzt kann man auch direkt als anhang hochladen :)
      @malibu:
      wenn du sourcecode veröffentlichst, wäre es ganz schön, wenn du ihn auch posten würdest (also [spoiler][code]der sourcecode[/code][/spoiler]), das würde den 60sekunden umweg über deposit sparen :D

      die file ist echt nice, sieht auch sehr sauber programmiert aus, sogar mit kommentaren :thumbsup:
      Working on some serious shit