TEnhancedCtrl - erweiterte Einstellungen (überarbeitet)

galagher · Verfasst: Sa 23.10.04 13:04

Hallo!
Bin mit meiner TEnhancedCtrl (fast) fertig und dachte, vieleicht kann's ja noch jemand brauchen! Manches funktioniert nur, wenn Parent der Komponente ein Formular ist, zB. HideTitleBar. Ich poste sie mal hier:
//Edit: Siehe nächsten Beitrag!

Moderiert von Motzi: Topic aus CLX / Delphi Language (Object-Pascal) verschoben am Sa 23.10.2004 um 14:57

_________________
gedunstig war's - und fahle wornen zerschellten karsig im gestrock. oh graus, es gloomt der jabberwock - und die graisligen gulpen nurmen!

galagher · Verfasst: So 24.10.04 11:37

Hier nun die engültige Version, mehr fällt mir nicht ein! Soweit möglich, habe ich den Autor des Original-Source angeführt.
//Edit: Nochmal optimiert!

markieren

Delphi-Quelltext

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:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:
214:
215:
216:
217:
218:
219:
220:
221:
222:
223:
224:
225:
226:
227:
228:
229:
230:
231:
232:
233:
234:
235:
236:
237:
238:
239:
240:
241:
242:
243:
244:
245:
246:
247:
248:
249:
250:
251:
252:
253:
254:
255:
256:
257:
258:
259:
260:
261:
262:
263:
264:
265:
266:
267:
268:
269:
270:
271:
272:
273:
274:
275:
276:
277:
278:
279:
280:
281:
282:
283:
284:
285:
286:
287:
288:
289:
290:
291:
292:
293:
294:
295:
296:
297:
298:
299:
300:
301:
302:
303:
304:
305:
306:
307:
308:
309:
310:
311:
312:
313:
314:
315:
316:
317:
318:
319:
320:
321:
322:
323:
324:
325:
326:
327:
328:
329:
330:
331:
332:
333:
334:
335:
336:
337:
338:
339:
340:
341:
342:
343:
344:
345:
346:
347:
348:
349:
350:
351:
352:
353:
354:
355:
356:
357:
358:
359:
360:
361:
362:
363:
364:
365:
366:
367:
368:
369:
370:
371:
372:
373:
374:
375:
376:
377:
378:
379:
380:
381:
382:
383:
384:
385:
386:
387:
388:
389:
390:
391:
392:
393:
394:
395:
396:
397:
398:
399:
400:
401:
402:
403:
404:
405:
406:
407:
408:
409:
410:
411:
412:
413:
414:
415:
416:
417:
418:
419:
420:
421:
422:
423:
424:
425:
426:
427:
428:
429:
430:
431:
432:
433:
434:
435:
436:
437:
438:
439:
440:
441:
442:
443:
444:
445:
446:
447:
448:
449:
450:
451:
452:
453:
454:
455:
456:
457:
458:
459:
460:
461:
462:
463:
464:
465:
466:
467:
468:
469:
470:
471:
472:
473:
474:
475:
476:
477:
478:
479:
480:
481:
482:
483:
484:
485:
486:
487:
488:
489:
490:
491:
492:
493:
494:
495:
496:
497:
498:
499:
500:
501:
502:
503:
504:
505:
506:
507:
508:
509:
510:
511:
512:
513:
514:
515:
516:
517:
518:
519:
520:
521:
522:
523:
524:
525:
526:
527:
528:
529:
530:
531:
532:
533:
534:
535:
536:
537:
538:
539:
540:
541:
542:
543:
544:
545:
546:
547:
548:
549:
550:
551:
552:
553:
554:
555:
556:
557:
558:
559:
560:
561:
562:
563:
564:
565:
566:
567:
568:
569:
570:
571:
572:
573:
574:
575:
576:
577:
578:
579:
580:
581:
582:
583:
584:
585:
586:
587:
588:
589:
590:
591:
592:
593:
594:
595:
596:
597:
598:
599:
600:
601:
602:
603:
604:
605:
606:
607:
608:
609:
610:
611:
612:
613:
614:
615:
616:
617:
618:
619:
620:
621:
622:
623:
624:
625:
626:
627:
628:
629:
630:
631:
632:
633:
634:
635:
636:
637:
638:
639:
640:
641:
642:
643:
644:
645:
646:
647:
648:
649:
650:
651:
652:
653:
654:
655:
656:
657:
658:
659:
660:
661:
662:
663:
664:
665:
666:
667:
668:
669:
670:
671:
672:
673:
674:
675:
676:
677:
678:

{
  EnhancedCtrl - erweiterte Einstellungen für sichtbare Komponenten.

                                              galagher, Oktober 2004

  Zur Laufzeit:
     CursorRect       Beschränkt den Mauszeiger auf die Parent-Komponente
     MenuRight        MainMenu rechts, 0 = erstes Menü-Item
     ScreenShot       Bildschirm-Schnappschuss
     ToolTip          Tooltip ("Ballon") für die Parent-Komponente
}


unit EnhancedCtrl;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Menus,
  ComCtrls, StdCtrls, ShellAPI, CommCtrl, ExtCtrls, ClipBrd, Forms;

type
  TEnhancedCtrl = class(TGraphicControl)
  private
    { Private-Deklarationen }
     FMove, FSystemMenu, FFullConstraints, FTransparent,
      FHideTitleBar, FActive, Start: Boolean;
     FRoundCornerX, FRoundCornerY: Byte;
     FControl: TWinControl;
     FLeft, FTop, FRight, FBottom: Word;
     FLinkLabel: TLabel;
     FBackGrdColor1, FBackGrdColor2: TColor;
  protected
    { Protected-Deklarationen }
    procedure Paint; override;
    procedure SetMove(const Value: Boolean);
    procedure SetSystemMenu(const Value: Boolean);
    procedure SetFullConstraints(const Value: Boolean);
    procedure SetTransparent(const Value: Boolean);
    procedure SetHideTitleBar(const Value: Boolean);
    procedure SetActive(const Value: Boolean);
    procedure SetLinkLabel(Value: TLabel);
    procedure SetRoundCornerX(Value: Byte);
    procedure SetRoundCornerY(Value: Byte);
    procedure SetLeft(Value: Word);
    procedure SetTop(Value: Word);
    procedure SetRight(Value: Word);
    procedure SetBottom(Value: Word);
    procedure SetControl(Value: TWinControl);
    procedure SetBackGrdColor1(Value: TColor);
    procedure SetBackGrdColor2(Value: TColor);
    procedure DrawGradient(Canvas: TCanvas; Color1, Color2: TColor; Rect: TRect);
  public
    { Public-Deklarationen }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    { Published-Deklarationen }
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure ScreenShot;
    procedure ToolTip(hwnd: DWORD; IconType: Integer; Text, Title: String);
    procedure MenuRight(const Value: Byte);
    procedure CursorRect(Value: Boolean);
    property CanMove: Boolean read FMove write SetMove;
    property EnableSystemMenu: Boolean read FSystemMenu write SetSystemMenu;
    property FullConstraints: Boolean read FFullConstraints write SetFullConstraints;
    property Transparent: Boolean read FTransparent write SetTransparent;
    property HideTitleBar: Boolean read FHideTitleBar write SetHideTitleBar;
    property Active: Boolean read FActive write SetActive;
    property LinkLabel: TLabel read FLinkLabel write SetLinkLabel;
    property RoundCornerX: Byte read FRoundCornerX write SetRoundCornerX;
    property RoundCornerY: Byte read FRoundCornerY write SetRoundCornerY;
    property RoundWinLeft: Word read FLeft write SetLeft;
    property RoundWinTop: Word read FTop write SetTop;
    property RoundWinRight: Word read FRight write SetRight;
    property RoundWinBottom: Word read FBottom write SetBottom;
    property Control: TWinControl read FControl write SetControl;
    property BackGrdColor1: TColor read FBackGrdColor1 write SetBackGrdColor1;
    property BackGrdColor2: TColor read FBackGrdColor2 write SetBackGrdColor2;
    property Align;
    property OnClick;
    property OnDblClick;
    property OnResize;
    property ShowHint;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property Enabled;
    property PopupMenu;
  end;

procedure Register;

implementation

{Zeichnen}
procedure TEnhancedCtrl.Paint;
var
 region: HRgn;
begin
 inherited Paint;

 Control := Parent;

 try  {Wenn Parent kein Formular ist, gibt's sonst}
  FLeft := RoundWinLeft;            {einen Fehler!}
  FTop := RoundWinTop;
  FRight := RoundWinRight;
  FBottom := RoundWinBottom;

 if not (csDesigning in ComponentState) then
  with Owner as TForm do
  begin
   Region := CreateEllipticRgn(FLeft,FTop,FRight,FBottom);
   SetWindowRgn(Handle, region, True);
  end;
 except ; end;

 {Wenn die in FBackGrdColor1 und FBackGrdColor2 gesetzten}
        {Farben von der Farbe des Hintergrunds abweichen,}
              {muss der Hintergrund neu gezeichnet werden}
 if not (FBackGrdColor1 = Parent.Brush.Color) or not
  (FBackGrdColor2 = Parent.Brush.Color) then
   if not (csDesigning in ComponentState) then
    DrawGradient(Canvas, FBackGrdColor1, FBackGrdColor2, ClientRect);

 Canvas.Brush.Color := Color;
 Canvas.Pen.Color := clBlack;

 with Canvas do
 begin
  Pen.Style := psDash;
  Brush.Style := bsClear;
  if csDesigning in ComponentState then
   Rectangle(0, 0, Width, Height)
  else
   FillRect(ClipRect);
 end;

 if FTransparent then SetTransparent(FTransparent);
end;

{------------------------------------------------------------------------------}

{Einstellen, ob das übergeordnete Element verschoben werden kann}
procedure TEnhancedCtrl.SetMove(const Value: Boolean);
begin
 if Value then
  if not (LinkLabel = nil) then SetLinkLabel(nil);
 FMove := Value;
end;

{------------------------------------------------------------------------------}

{Wenn True, steht das Systemmenü auch zur Verfügung,}
        {wenn das Formular BorderStyle := bsNone ist}
procedure TEnhancedCtrl.SetSystemMenu(const Value: Boolean);
begin
 FSystemMenu := Value;
 if Value then PopupMenu := nil;
end;

{------------------------------------------------------------------------------}

{Parent-Komponente grössenveränderlich oder nicht}
procedure TEnhancedCtrl.SetFullConstraints(const Value: Boolean);
begin
 FFullConstraints := Value;

 if not Value then SetTransparent(False);

 if not FFullConstraints or not FActive then exit;

 FHideTitleBar := HideTitleBar;

 with Owner as TForm do
  try
   Constraints.MaxHeight := Height;
   Constraints.MinHeight := Height;
   Constraints.MaxWidth  := Width;
   Constraints.MinWidth  := Width;
  except ; end;
end;

{------------------------------------------------------------------------------}

{Formular transparent machen oder nicht}
procedure TEnhancedCtrl.SetTransparent(const Value: Boolean);
var
  Margin, X, Y, CtlX, CtlY: Integer;
  ClientRgn, FullRgn, CtlRgn: HRGN;
begin
 if not ((Owner as TForm).Menu = nil) and Value then
  if Parent is TForm then
   (Owner as TForm).Menu := nil;

 FTransparent := Value;

 if Value then SetFullConstraints(True);

 if (csDesigning in ComponentState) or not FActive then exit;

 try
  if not FTransparent then
  begin
   with Parent do
   begin
    FullRgn := CreateRectRgn(0, 0, Width, Height);
    CombineRgn(FullRgn, FullRgn, FullRgn, RGN_COPY);
    SetWindowRgn(Handle, FullRgn, True);
   end;
   exit;
  end;
 except exit; end;

 try
  with Parent do
  begin
   Margin    := (Width - ClientWidth) div 2;
   FullRgn   := CreateRectRgn(0, 0, Width, Height);
   X         := Margin;
   Y         := Height - ClientHeight - Margin;
   ClientRgn := CreateRectRgn(X, Y, X + ClientWidth, Y + ClientHeight);
   CombineRgn(FullRgn, FullRgn, ClientRgn, RGN_DIFF);

   CtlX   := X + Left+Width;
   CtlY   := Y + Top+Height;
   CtlRgn := CreateRectRgn(CtlX, CtlY, CtlX + Width, CtlY + Height);
   CombineRgn(FullRgn, FullRgn, CtlRgn, RGN_OR);
   SetWindowRgn(Handle, FullRgn, True);
  end;
 except ; end;
end;

{------------------------------------------------------------------------------}

{Titelzeile Ja/Nein}
procedure TEnhancedCtrl.SetHideTitleBar(const Value: Boolean);
var
  Style: Longint;
begin
 FHideTitleBar := Value;
 if (csDesigning in ComponentState) or not FActive then exit;

 try
  if not FHideTitleBar then
  begin
   with Owner as TForm do
   begin
    if BorderStyle = bsNone then Exit;
    Style := GetWindowLong(Handle, GWL_STYLE);
    if (Style and WS_CAPTION) <> WS_CAPTION then
    begin
     case BorderStyle of
       bsSingle,
       bsSizeable: SetWindowLong(Handle, GWL_STYLE, Style or WS_CAPTION or
           WS_BORDER);
       bsDialog: SetWindowLong(Handle, GWL_STYLE,
           Style or WS_CAPTION or DS_MODALFRAME or WS_DLGFRAME);
     end;
     Height := Height + GetSystemMetrics(SM_CYCAPTION);
     Refresh;
    end;
    exit;
   end;
  end;
 except exit; end;

 try
  with Owner as TForm do
  begin
   if BorderStyle = bsNone then Exit;
   Style := GetWindowLong(Handle, GWL_STYLE);
   if (Style and WS_CAPTION) = WS_CAPTION then
   begin
     case BorderStyle of
       bsSingle,
       bsSizeable: SetWindowLong(Handle, GWL_STYLE, Style and
           (not (WS_CAPTION)) or WS_BORDER);
       bsDialog: SetWindowLong(Handle, GWL_STYLE, Style and
           (not (WS_CAPTION)) or DS_MODALFRAME or WS_DLGFRAME);
     end;
     Height := Height - GetSystemMetrics(SM_CYCAPTION);
     Refresh;
   end;
  end;
 except ; end;
end;

{------------------------------------------------------------------------------}

{Angeben, ob die EnhancedCtrl-Komponente aktiv ist oder nicht}
procedure TEnhancedCtrl.SetActive(const Value: Boolean);
begin
 FActive := Value;
end;

{------------------------------------------------------------------------------}

{Ein Label als Link definieren - in Prozedur MouseMove und MouseUp}
{wird ausgewertet, ob sich der Mauszeiger über dem LinkLabel befindet}
procedure TEnhancedCtrl.SetLinkLabel(Value: TLabel);
begin
 if not Active then exit;

 if not (Value = nil) then
 begin
  SetMove(False);
  FLinkLabel := Value;
  FLinkLabel.SendToBack;
  FLinkLabel.Font.Color := clBlue;
  FLinkLabel.Font.Style := FLinkLabel.Font.Style+[fsUnderline];
 end
 else
  FLinkLabel := nil; 
end;

{------------------------------------------------------------------------------}

{Screen-Schnappschuss - Original-Source von Marco Lange, geändert von galagher}
procedure TEnhancedCtrl.ScreenShot;
var
  DeskWnd: HWnd;
  DeskDC: HDC;
  DeskCv: TCanvas;
  R: TRect;
  W, H: Integer;
  Bmp: TBitmap;
begin
 if not FActive then exit;

 Bmp := TBitmap.Create;
 DeskWnd := GetDesktopWindow;
 DeskDC := GetWindowDC(DeskWnd);
 DeskCv := TCanvas.Create;
 DeskCv.Handle := DeskDC;
 W := Screen.Width;
 H := Screen.Height;
 R := Bounds(0, 0, W, H);
 try
   Bmp.HandleType := bmDIB;
   Bmp.PixelFormat := pf24Bit;
   Bmp.Width := W;
   Bmp.Height := H;
   Bmp.Canvas.CopyMode := cmSrcCopy;
   Bmp.Canvas.CopyRect(R, DeskCv, R);
 finally
   DeskCv.Free;
   ReleaseDC(DeskWnd, DeskDC);
 end;

 ClipBoard.Assign(Bmp);
 Bmp.Free;
end;

{------------------------------------------------------------------------------}

{ToolTip zeigen - hwnd:     Komponente, für die der ToolTip bestimmt ist
                  IconType: 1 = "i" (Information)
                            2 = "!" (Warnung)
                            3 = "x" (Stop)
                  Text:     Text des ToolTips
                  Title:    Titel des ToolTips}
procedure TEnhancedCtrl.ToolTip(hwnd: DWORD; IconType: Integer; Text, Title: String);
var
  Item: THandle;
  Rect: TRect;
  lpti: PToolInfo;
  hTooltip: Cardinal;
  ti: TToolInfo;
  buffer : array[0..255] of char;
const
  TTS_BALLOON    = $40;
  TTM_SETTITLE = (WM_USER + 32);
begin
 if not FActive then exit;

  hToolTip := CreateWindowEx(0, 'Tooltips_Class32', nil, TTS_ALWAYSTIP or TTS_BALLOON,
    Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT),
    Integer(CW_USEDEFAULT), Application.Handle, 0, hInstance, nil);
  if hToolTip <> 0 then
  begin
    SetWindowPos(hToolTip, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or
      SWP_NOSIZE or SWP_NOACTIVATE);
    ti.cbSize := SizeOf(TToolInfo);
    ti.uFlags := TTF_SUBCLASS;
    ti.hInst  := hInstance;
  end;

  Item := hWnd;
  if (Item <> 0) and (Windows.GetClientRect(Item, Rect)) then
  begin
    lpti := @ti;
    lpti.hwnd := Item;
    lpti.Rect := Rect;
    lpti.lpszText := PChar(Text);
    SendMessage(hToolTip, TTM_ADDTOOL, 0, Integer(lpti));
    FillChar(buffer, SizeOf(buffer), #0);
    lstrcpy(buffer, PChar(Title));
    if (IconType > 3) or (IconType < 0) then IconType := 0;
    SendMessage(hToolTip, TTM_SETTITLE, IconType, Integer(@buffer));
  end;
end;

{------------------------------------------------------------------------------}

{Prüfen, ob sich der Mauszeiger über dem LinkLabel befindet, wenn ja,}
{das zugehörige Programm starten, zB. den Internet-Explorer}
procedure TEnhancedCtrl.MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer);
begin
 inherited;

 if not Active or (FLinkLabel = nil) then exit;

 try
  if ((X >= LinkLabel.Left) and (X < LinkLabel.Left+LinkLabel.Width)) and
   ((Y >= LinkLabel.Top) and (Y < LinkLabel.Top+LinkLabel.Height)) then
   ShellExecute(Application.Handle, 'open',
    PChar(LinkLabel.Caption), nil, nil, SW_ShowNormal);
 except ; end;

 FLinkLabel.BringToFront;
end;

{------------------------------------------------------------------------------}

{Prüfen, ob sich der Mauszeiger über dem LinkLabel befindet,}
{wenn ja, den Mauscursor als Hand zeigen}
procedure TEnhancedCtrl.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
 inherited;

 if not Active or (FLinkLabel = nil) then exit;

 if ((X >= LinkLabel.Left) and (X < LinkLabel.Left+LinkLabel.Width)) and
  ((Y >= LinkLabel.Top) and (Y < LinkLabel.Top+LinkLabel.Height)) then
  SetCursor(LoadCursor(0, IDC_HAND));
end;

{------------------------------------------------------------------------------}

{MouseDown - Verschieben, wenn FMove = True}
procedure TEnhancedCtrl.MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer);
const sc_dragmove = $f012;
const WM_POPUPSYSTEMMENU = $313;  {Undocument message ID}
begin
 inherited;

 if not FActive then exit;

 if FSystemMenu then
  if ssRight in Shift then
   SendMessage({Handle}Application.Handle, WM_POPUPSYSTEMMENU, 0,
    MakeLong(Mouse.CursorPos.X, Mouse.CursorPos.Y));

 if FMove then if ssLeft in Shift then
 begin
  ReleaseCapture;
  Parent.Perform(wm_syscommand,sc_dragmove, 0);
 end;
end;

{------------------------------------------------------------------------------}

{Abgerundete Ecke X}
procedure TEnhancedCtrl.SetRoundCornerX(Value: Byte);
var
  Rgn : HRGN;
begin
 if not FActive then exit;

 if FRoundCornerY <= 0 then FRoundCornerY := FRoundCornerX;
 FRoundCornerX := Value;
 if Value <= 0 then exit;

 with Parent do
 begin
  Rgn := CreateRoundRectRgn(0,0,Width,Height,FRoundCornerX,FRoundCornerY);
  SetWindowRgn(Handle, Rgn, True);
 end;
end;

{------------------------------------------------------------------------------}

{Abgerundete Ecke Y}
procedure TEnhancedCtrl.SetRoundCornerY(Value: Byte);
var
  Rgn : HRGN;
begin
 if not FActive then exit;

 if FRoundCornerX <= 0 then FRoundCornerX := FRoundCornerY;
 FRoundCornerY := Value;
 if Value <= 0 then exit;

 with Parent do
 begin
  Rgn := CreateRoundRectRgn(0,0,Width,Height,FRoundCornerX,FRoundCornerY);
  SetWindowRgn(Handle, Rgn, True);
 end;
end;

{------------------------------------------------------------------------------}

procedure TEnhancedCtrl.SetLeft(Value: Word);
begin
 FLeft := Value;
end;

{------------------------------------------------------------------------------}

{Rundes Formular - Top}
procedure TEnhancedCtrl.SetTop(Value: Word);
begin
 FTop := Value;
end;

{------------------------------------------------------------------------------}

{Rundes Formular - Right}
procedure TEnhancedCtrl.SetRight(Value: Word);
begin
 FRight := Value;
end;

{------------------------------------------------------------------------------}

{Rundes Formular - Bottom}
procedure TEnhancedCtrl.SetBottom(Value: Word);
begin
 FBottom := Value;
end;

{------------------------------------------------------------------------------}

{Das übergeordnete Element ändern}
procedure TEnhancedCtrl.SetControl(Value: TWinControl);
begin
 if Value = nil then Value := Parent;
 FControl := Value;
 Parent := FControl;

 if not ((Owner as TForm).Menu = nil) and FTransParent then
  if Parent is TForm then
   (Owner as TForm).Menu := nil;

 if Start then  {Parent.Brush.Color nur 1x zuweisen!}
 begin
  Start := False;
  FBackGrdColor1 := Parent.Brush.Color;
  FBackGrdColor2 := Parent.Brush.Color;
 end;
end;

{------------------------------------------------------------------------------}

{Einen Farbverlauf zeichen - Sourcecode von Pascal Enz}
procedure TEnhancedCtrl.DrawGradient(Canvas: TCanvas; Color1, Color2: TColor; Rect: TRect);
var
  Y, R, G, B: Integer;
begin
 for Y := Rect.Top to Rect.Bottom do
 begin
  R := Round(GetRValue(Color1) + ((GetRValue(Color2) - GetRValue(Color1)) * Y / (Rect.Bottom - Rect.Top)));
  G := Round(GetGValue(Color1) + ((GetGValue(Color2) - GetGValue(Color1)) * Y / (Rect.Bottom - Rect.Top)));
  B := Round(GetBValue(Color1) + ((GetBValue(Color2) - GetBValue(Color1)) * Y / (Rect.Bottom - Rect.Top)));

  Canvas.Pen.Color := RGB(R, G, B);
  Canvas.Pen.Width := 2;
  Canvas.Pen.Style := psInsideFrame;

  Canvas.MoveTo(Rect.Left, Y);
  Canvas.LineTo(Rect.Right, Y);
 end;
end;

{------------------------------------------------------------------------------}

{Erste der beiden Farben für den Farbverlauf setzen}
procedure TEnhancedCtrl.SetBackGrdColor1(Value: TColor);
begin
 FBackGrdColor1 := Value;
 if csDesigning in ComponentState then exit;
 DrawGradient(Canvas, FBackGrdColor1, FBackGrdColor2, ClientRect);
end;

{------------------------------------------------------------------------------}

{Zweite der beiden Farben für den Farbverlauf setzen}
procedure TEnhancedCtrl.SetBackGrdColor2(Value: TColor);
begin
 FBackGrdColor2 := Value;
 if csDesigning in ComponentState then exit;
 DrawGradient(Canvas, FBackGrdColor1, FBackGrdColor2, ClientRect);
end;

{------------------------------------------------------------------------------}

{MainMenu rechts anzeigen - Original-Source von Mario Müller}
{Value gibt an, ab welchem Menu-Item rechts}
{angezeigt werden soll, 0 ist ab dem ersten}
procedure TEnhancedCtrl.MenuRight(const Value: Byte);
var
  m: TMenuItemInfo;
  h: hMenu;
  s: String;
begin
 with Owner as TForm do
 begin
  h := GetMenu(Handle);
  m.cbSize := SizeOf(m);
  m.cch := SizeOf(s);
  m.dwTypeData := PChar(@s[1]);
  m.fMask := MIIM_TYPE;

  GetMenuItemInfo(h,Value,true,m);
  m.ftype := m.ftype or MFT_RIGHTJUSTIFY;
  SetMenuItemInfo(h,Value,true,m);
  Refresh;
 end;
end;

{------------------------------------------------------------------------------}

{Beschränkt den Mauszeiger auf die Parent-Komponente}
procedure TEnhancedCtrl.CursorRect(Value: Boolean);
var
  MouseRect: TRect;
begin
 try
  with Parent as TForm do
  begin
   if Value then
   begin
    MouseRect :=
//    Rect(Left,Top,Left+Width*4,Height);
     Rect(Left,Top,Left+Width,Top+Height);
    ClipCursor(@MouseRect);
   end
   else
    ClipCursor(nil);
  end;
 except ; end;
end;

{------------------------------------------------------------------------------}

constructor TEnhancedCtrl.Create(AOwner: TComponent);
begin
 inherited;
 Align := alClient;
 Enabled := True;
 FActive := True;
 Active := True;
 Start := True;
end;

{------------------------------------------------------------------------------}

destructor TEnhancedCtrl.Destroy;
begin
 inherited Destroy;
end;

{------------------------------------------------------------------------------}

procedure Register;
begin
 RegisterComponents('Samples', [TEnhancedCtrl]);
end;

end.

Auf eigene Verantwortung: Versucht mal, die auskommentiere Anweisung zu aktiverien, macht also aus:

markieren

Delphi-Quelltext

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:

procedure TEnhancedCtrl.CursorRect(Value: Boolean);
var
  MouseRect: TRect;
begin
 try
  with Parent as TForm do
  begin
   if Value then
   begin
    MouseRect :=
//    Rect(Left,Top,Left+Width*4,Height);
     Rect(Left,Top,Left+Width,Top+Height);
    ClipCursor(@MouseRect);
   end
   else
    ClipCursor(nil);
  end;
 except ; end;
end;

das hier:

markieren

Delphi-Quelltext

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:

procedure TEnhancedCtrl.CursorRect(Value: Boolean);
var
  MouseRect: TRect;
begin
 try
  with Parent as TForm do
  begin
   if Value then
   begin
    MouseRect :=
    Rect(Left,Top,Left+Width*4,Height);
//     Rect(Left,Top,Left+Width,Top+Height);
    ClipCursor(@MouseRect);
   end
   else
    ClipCursor(nil);
  end;
 except ; end;
end;

... und schreibt folgenden Code:

markieren

Delphi-Quelltext

1:
2:
3:
4:
5:
6:

procedure TForm1.Button1Click(Sender: TObject);
begin
 EnhancedCtrl1.CursorRect(True);
 Sleep(5000);
 EnhancedCtrl1.CursorRect(False);
end;

Nicht erschrecken! Ist harmlos (bei mir jedenfalls)!

Was haltet ihr so insgesamt von der Komponente?

//Edit: Prozedur CursorRect korrigiert - funktioniert nur, wenn Parent ein Formular ist.

_________________
gedunstig war's - und fahle wornen zerschellten karsig im gestrock. oh graus, es gloomt der jabberwock - und die graisligen gulpen nurmen!

mirage228 · Verfasst: So 24.10.04 16:21

Hi,

hast Du eventuell einen Screenshot Deiner Komponente parat?

Möchte nämlich erst wissen, was das eigentlich genau ist, was ich mir runterlade *g*

mfG
mirage228

_________________
May the source be with you, stranger.

galagher · Verfasst: So 24.10.04 17:06

mirage228 hat folgendes geschrieben:

hast Du eventuell einen Screenshot Deiner Komponente parat?

Hallo! Die Komponente selbst ist "unsichtbar", legt sich praktisch über das Formular oder Panel oder so. Leider hab' ich keine Ahnung, wie man einen Screenshot hier postet :oops:

Du kannst damit genau das machen, was in den Kommentaren steht, zB. ein Fomular ohne Titelleiste anzeigen, das du trotzdem verschieben kannst. Oder einen Farbverlauf erzeugen.
Ich habe den Code optimiert, es schalten sich jetzt Einstellungen, die miteinander nicht gut funktionieren, automatisch aus.

Jedenfalls kann der Code keine Systemeinstellungen verändern, falls du das meinst. Die Effekte, zB. das MainMenu rechts anzeigen, bleiben auch nicht im Projekt zur Entwurfszeit.

_________________
gedunstig war's - und fahle wornen zerschellten karsig im gestrock. oh graus, es gloomt der jabberwock - und die graisligen gulpen nurmen!

	Mitgliederliste
	Gruppen
	Das Team
	Richtlinien
	Synonyme