// Wer gern NonVCL programmiert, findet im ersten Beispiel den Code für
// einen Colordialog. Das zweite Beispiel erzeugt einen Farbdialog mit
// 256 Farben, den man beispielsweise verwenden kann um die Farbpalette
// eines Bitmaps mit 8 Bit Farbtiefe anzuzeigen.

// Getestet mit D4 unter WinME

// 1. Beispiel: TrueColor-Dialog

uses commdlg; 
 
function FarbDlg(h: THandle; cust: array of TColor; Auswahl: TColor; 
  geoeffnet: boolean; var Farbe: TColor): boolean; 
var 
  cc: tagCHOOSECOLORA; 
  ca: array[0..15] of TColor; 
  x: integer; 
begin 
  for x := 0 to high(cust) do ca[x] := colortorgb(cust[x]); 
  for x := high(cust) + 1 to 15 do ca[x] := colortorgb(clBtnFace); 
  cc.lStructSize := sizeof(cc); 
  cc.hwndOwner := h; 
  cc.hInstance := hinstance; 
  cc.rgbResult := colortorgb(Auswahl); 
  cc.lpCustColors := @ca; 
  cc.Flags := CC_RGBINIT or ord(geoeffnet) * CC_FULLOPEN; 
  result := choosecolor(cc); 
  Farbe := cc.rgbResult; 
end; 
 
// ---------- Beispielaufrufe --------------- 
 
// Klickt der Anwender auf ABBRECHEN, passiert nichts. 
// Klickt er auf OK, wird Form1 mit der ausgewählten Farbe eingefärbt. 
procedure TForm1.Button2Click(Sender: TObject); 
var 
  f: TColor; 
begin 
  if FarbDlg(handle, [$0FBC50, $FF05BC, $FFA757], $FF05BC, true, f) then 
    Form1.color := f; 
end; 
 
// Bei klicken auf OK, wird Panel1 mit der ausgewählten Farbe eingefärbt. 
// Bei ABBRECHEN erhält Panel1 die Farbe der Vorgabe. 
procedure TForm1.Button3Click(Sender: TObject); 
var 
  vorgabe: TColor; 
begin 
  vorgabe := clLime; 
  FarbDlg(handle, [], vorgabe, false, vorgabe); 
  panel1.color := vorgabe; 
end; 

 
// -------------------------------------------------------------------- 
 
// 2. Beispiel: Von Hand programmierter Dialog mit 256 Farben 
 
type 
  TForm1 = class(TForm) 
    ... 
      ... 
    private 
{ Private-Deklarationen} 
  public 
    procedure MDown(Sender: TObject; Button: TMouseButton; 
      Shift: TShiftState; X, Y: Integer); 
    procedure okClick(sender: tobject); 
    procedure iDblClick(sender: tobject); 
    procedure cancelClick(sender: tobject); 
  end; 
 
var 
  Form1: TForm1; 
 
implementation 
 
{$R *.DFM} 
 
uses Buttons, ExtCtrls; 
 
var 
  ok, da: boolean; 
  Farbe: TColor; 
  cdlg: TForm; 
  ti: TImage; 
  tl: TLabel; 
  tp: TPanel; 
  bu: array[0..1] of TSpeedButton; 
  mx, my, xx, yy: integer; 
 
const 
  breit = 17; 
  abstand = 3; 
// die Fläche der Farbquadrate wird (breit-abstand)*(breit-abstand), 
// hier alse 14 x 14 
  buttonheight = 23; 
  buttonwidth = 75; 
  f256: array[0..255] of TColor = ( 
    $000000, $808080, $C0C0C0, $FFFFFF, $000080, $0000FF, $008000, $00FF00, 
    $800000, $FF0000, $800080, $FF00FF, $008080, $00FFFF, $808000, $FFFF00, 
    $F0CAA6, $A4A0A0, $C0DCC0, $F0FBFF, $405C40, $58745D, $708C7A, $88A497, 
    $A0BCB4, $B8D4D1, $704A26, $8C6844, $A88662, $C4A480, $E0C29E, $FCE0BC, 
    $0F0F0F, $1E1E1E, $2D2D2D, $3C3C3C, $4B4B4B, $5A5A5A, $696969, $787878, 
    $878787, $969696, $A5A5A5, $B4B4B4, $C3C3C3, $D2D2D2, $E1E1E1, $F0F0F0, 
    $0D3F6C, $183A67, $244673, $2F517E, $3B5D8A, $466895, $5274A1, $5D7FAC, 
    $6A8CB5, $7799BE, $84A6C7, $91B3D0, $9EC0D9, $ABCDE2, $B8DAEB, $C5E7F4, 
    $000F8F, $001F9F, $002FAF, $003FBF, $004FCF, $005FDF, $006FEF, $007FFF, 
    $0F7FFF, $268FFF, $3D9FFF, $54AFFF, $6BBFFF, $82CFFF, $99CFFF, $B0DFFF, 
    $00005F, $00006F, $00007F, $00009F, $0000AF, $0000CF, $0000DF, $0000FE, 
    $1C1CFF, $3838FF, $5454FF, $7070FF, $8C8CFF, $A8A8FF, $C4C4FF, $E0E0FF, 
    $10005F, $20008F, $30009F, $4000AF, $5000BF, $6000CF, $7000DF, $8000EF, 
    $8F0FEF, $8F27F1, $9F3FF3, $AF57F5, $BF6FF7, $CF87FA, $CF9FFC, $DFB7FE, 
    $4F004F, $6F006F, $7F007F, $9F009F, $AF00AF, $CF00CF, $DF00DF, $FB00FB, 
    $FF1CFF, $FF38FF, $FF54FF, $FF70FF, $FF8CFF, $FFA8FF, $FFC4FF, $FFE0FF, 
    $4F0020, $680030, $810040, $9A0050, $B30050, $CD0060, $E60070, $FF0080, 
    $FF0F8F, $FF1F9C, $FF3FA9, $FF5FB6, $FF7FC3, $FF9FD0, $FFBFDD, $FFCFEA, 
    $4F0000, $6F0000, $7F0000, $9F0000, $AF0000, $CF0000, $DF0000, $FF0303, 
    $FF1C1C, $FF3838, $FF5454, $FF7070, $FF8C8C, $FFA8A8, $FFC4C4, $FFE0E0, 
    $7F1700, $8F2700, $9F3700, $AF4700, $BF6700, $CF7700, $DF8700, $EFA700, 
    $EFB700, $F1BF19, $F3C732, $F5CF4B, $F8D764, $FADF7D, $FCE796, $FFEFAF, 
    $4F4F00, $6F6F00, $7F7F00, $9F9F00, $AFAF00, $CFCF00, $DFDF00, $FBFB00, 
    $FFFF1C, $FFFF38, $FFFF54, $FFFF70, $FFFF8C, $FFFFA8, $FFFFC4, $FFFFE0, 
    $204000, $356000, $4A7000, $5F9000, $74B000, $89C000, $9EE000, $B3F000, 
    $B5F000, $B8F210, $BBF430, $BEF650, $C1F870, $C4FB90, $C7FDA0, $CAFFC0, 
    $004F00, $006F00, $007F00, $009F00, $00AF00, $00CF00, $00DF00, $00FF06, 
    $1CFF1C, $38FF38, $54FF54, $70FF70, $8CFF8C, $A8FFA8, $C4FFC4, $E0FFE0, 
    $002E10, $003E20, $005E40, $007E50, $009E70, $00BE80, $00DEA0, $00FEB0, 
    $0FFFC0, $1FFFC0, $3FFFC0, $5FFFD0, $7FFFD0, $8FFFE0, $AFFFE0, $CFFFF0, 
    $004F4F, $006F6F, $007F7F, $009F9F, $00AFAF, $00CFCF, $00DFDF, $00FBFB, 
    $1CFFFF, $38FFFF, $54FFFF, $70FFFF, $8CFFFF, $A8FFFF, $C4FFFF, $E0FFFF); 
 
procedure Gitter; 
var 
  x, y: integer; 
begin 
  with ti.canvas do begin 
    brush.color := clbtnface; 
    fillrect(cliprect); 
    for y := 0 to 15 do 
      for x := 0 to 15 do begin 
        pen.color := clbtnshadow; 
        moveto(x * breit, y * breit + breit - abstand); 
        lineto(x * breit, y * breit); 
        lineto(x * breit + breit - abstand, y * breit); 
        pen.color := clbtnhighlight; 
        lineto(x * breit + breit - abstand, y * breit + breit - abstand); 
        lineto(x * breit, y * breit + breit - abstand); 
        brush.color := f256[y * 16 + x]; 
        fillrect(rect(x * breit + 1, y * breit + 1, x * breit + breit - 
          abstand, 
          y * breit + breit - abstand)); 
      end; 
  end; 
end; 
 
procedure rahmen; 
begin 
  ti.canvas.rectangle(mx, my, mx + breit - abstand, my + breit - abstand); 
end; 
 
procedure kennzeichnen; 
var 
  sr, sg, sb: string[3]; 
begin 
  sr := inttostr(getrvalue(Farbe)); 
  sg := inttostr(getgvalue(Farbe)); 
  sb := inttostr(getbvalue(Farbe)); 
  tl.caption := 'Rot:'#9 + sr + #13'Grün:'#9 + sg + #13'Blau:'#9 + sb; 
  bu[0].enabled := true; 
  tp.color := Farbe; 
  da := true; 
end; 
 
procedure testen; 
var 
  x, y: integer; 
begin 
  for x := 0 to 15 do 
    for y := 0 to 15 do begin 
      if Farbe = f256[x + y * 16] then begin 
        kennzeichnen; 
        mx := x * breit + 1; 
        my := y * breit + 1; 
        rahmen; 
        exit; 
      end; 
    end; 
end; 
 
function drin(x, y: integer): boolean; 
begin 
  result := ((x mod breit) in [1..breit - abstand - 1]) 
    and ((y mod breit) in [1..breit - abstand - 1]); 
end; 
 
procedure TForm1.MDown(Sender: TObject; Button: TMouseButton; 
  Shift: TShiftState; X, Y: Integer); 
begin 
  xx := x; 
  yy := y; 
  if drin(x, y) then begin 
    if da then rahmen; 
    Farbe := ti.canvas.pixels[x, y]; 
    kennzeichnen; 
    mx := (x div breit) * breit + 1; 
    my := (y div breit) * breit + 1; 
    rahmen; 
  end; 
end; 
 
procedure TForm1.okClick(sender: tobject); 
begin 
  ok := true; 
  cdlg.close; 
end; 
 
procedure TForm1.iDblClick(sender: tobject); 
begin 
  if drin(xx, yy) then okClick(sender); 
end; 
 
procedure TForm1.cancelClick(sender: tobject); 
begin 
  cdlg.close; 
end; 
 
procedure Dlg256(Startfarbe: TColor; bmp: TBitmap); 
var x: integer; 
begin 
  cdlg := TForm.create(application); 
  cdlg.borderstyle := bsDialog; 
  cdlg.caption := '256 Farben'; 
  cdlg.position := poScreenCenter; 
  cdlg.clientwidth := breit * 16 + abstand; 
  cdlg.clientheight := breit * 16 + abstand * 4 + buttonheight * 2; 
  ti := TImage.create(cdlg); 
  ti.parent := cdlg; 
  ti.setbounds(abstand, abstand, breit * 16 + abstand, breit * 16 + abstand); 
  ti.onmousedown := Form1.MDown; 
  ti.onDblclick := Form1.iDblClick; 
  if (bmp <> nil) then begin 
    if bmp.pixelformat <> pf8bit then 
      bmp.pixelformat := pf8bit; 
    getpaletteentries(bmp.palette, 0, 256, f256); 
  end; 
  gitter; 
  ti.canvas.pen.mode := pmnotxor; 
  ti.canvas.pen.width := 4; 
  ti.canvas.brush.style := bsclear; 
  ti.canvas.pen.color := clblack; 
  tl := TLabel.create(cdlg); 
  tl.left := abstand + 15 + buttonwidth; 
  tl.parent := cdlg; 
  for x := 0 to 1 do begin 
    bu[x] := TSpeedButton.create(cdlg); 
    bu[x].top := breit * 16 + abstand * 2 + (buttonheight + abstand) * x; 
    bu[x].height := buttonheight; 
    bu[x].width := buttonwidth; 
    bu[x].left := abstand; 
    bu[x].parent := cdlg; 
  end; 
  bu[0].caption := 'OK'; 
  bu[0].onClick := Form1.okClick; 
  bu[0].enabled := false; 
  bu[1].caption := 'Abbrechen'; 
  bu[1].onClick := Form1.cancelClick; 
  tl.top := bu[0].top + (buttonheight * 2 + abstand - tl.height * 2) div 2; 
  tp := Tpanel.create(cdlg); 
  tp.parent := cdlg; 
  tp.height := abstand + buttonheight * 2; 
  tp.width := tp.height; 
  tp.top := bu[0].top; 
  tp.left := cdlg.clientwidth - abstand - tp.width; 
  tp.bevelouter := bvlowered; 
  da := false; 
  ok := false; 
  Farbe := Startfarbe; 
  testen; 
  cdlg.showmodal; 
  ti.free; 
  tl.free; 
  for x := 0 to 1 do bu[x].free; 
  tp.free; 
  cdlg.free; 
end; 
 
// ------- Beispielaufrufe ---------- 
 
// Farbdialog öffnen und bei klick auf OK die Form einfärben 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  dlg256(clfuchsia, nil); 
  if ok then color := farbe; 
end; 
 
// Palette eines Bitmaps mit 256 Farben anzeigen 
procedure TForm1.Button2Click(Sender: TObject); 
var 
  b: TBitmap; 
begin 
  b := TBitmap.create; 
  b.loadfromfile('d:\bilder\corel256.bmp'); 
  dlg256(clblack, b); 
  b.free; 
end;


 

Zugriffe seit 6.9.2001 auf Delphi-Ecke