DBR Delphi-Ecke

// Getestet mit D4 unter Win98

Beispiel 1

// Wenn man bei MDI-Anwendungen von einem Child aus die Hintergrundfarbe
// der Mainform ändern will, erreicht man meist nur, dass die Farbe unter
// dem Child geändert wird und der Rest die alte Farbe behält (bis zu Resize,
// Minimize oder Überdecken mit einem anderen Fenster).
// Mit einem Trick kann man diesen Mangel beheben.

...
private
procedure CreateMDIChild(const Name: string);
procedure Farbe(sender: tobject);
public
{ Public declarations }
end;

var
MainForm: TMainForm;

const
hintergrundfarbe: TColor = clred;

implementation

{$R *.DFM}

uses ChildWin, About;

// Diese Prozedur kann von einem Child aus aufgerufen werden

procedure TMainform.farbe(sender: tobject); 
var 
  cnv: Tcanvas; 
begin 
  cnv := tcanvas.create; 
  try 
    cnv.handle := getdc(mainform.clienthandle); 
    cnv.brush.color := hintergrundfarbe; 
    cnv.pen.style := psclear; 
    cnv.rectangle(0, 0, mainform.clientwidth, mainform.clientheight); 
    mainform.color := hintergrundfarbe; 
  finally 
    releasedc(mainform.clienthandle, cnv.handle); 
    cnv.free; 
  end; 
end;

// ---------------------------------------------------------------------------

Beispiel 2

// um den Hintergrund der Mainform mit einem Bild auszukleiden, geht man
// folgendermaßen vor:
// (siehe dazu auch den Fensterhintergrund mit einem Bild ausfüllen )

...
var
MainForm: TMainForm;
bm: TBitmap;

implementation

{$R *.DFM}

uses ChildWin, About;

procedure TMainForm.FormCreate(Sender: TObject); 
begin 
  bm := TBitmap.create; 
  bm.loadfromfile('c:\dbr\i0.bmp'); 
  mainform.brush.bitmap := bm; 
  bm.dormant; 
end; 
procedure TMainForm.FormDestroy(Sender: TObject); 
begin 
  bm.free; 
end;

// ----------------------------------------------------------------------------

Beispiel 3

// Wenn man die beiden obigen Prinzipien verbindet, kann man einen
// Wechsel des Hintergrundbildes erreichen:

...
private
{ Private declarations }
procedure CreateMDIChild(const Name: string);
public
procedure wechsel(bild:TFileName);
end;

var
MainForm: TMainForm;

implementation

{$R *.DFM}

uses ChildWin, About;

var bmp:TBitmap;

procedure TMainForm.CreateMDIChild(const Name: string); 
var 
  Child: TMDIChild; 
begin 
{ create a new MDI child window } 
  Child := TMDIChild.Create(Application); 
  Child.Caption := Name; 
  if FileExists(Name) then Child.Memo1.Lines.LoadFromFile(Name); 
end; 
 
procedure TMainForm.FileNew1Execute(Sender: TObject); 
begin 
  CreateMDIChild('NONAME' + IntToStr(MDIChildCount + 1)); 
end; 
 
procedure TMainForm.FileOpen1Execute(Sender: TObject); 
begin 
  if OpenDialog.Execute then 
    CreateMDIChild(OpenDialog.FileName); 
end; 
 
procedure TMainForm.HelpAbout1Execute(Sender: TObject); 
begin 
  AboutBox.ShowModal; 
end; 
 
procedure TMainForm.FileExit1Execute(Sender: TObject); 
begin 
  Close; 
end; 
 
procedure TMainForm.FormCreate(Sender: TObject); 
begin 
  bmp := TBitmap.create; 
  bmp.loadfromfile('d:\dbr\frau.bmp'); 
  mainform.Brush.bitmap := bmp; 
end; 
 
procedure TMainForm.wechsel(bild: TFileName); 
var 
  hb: HBrush; 
  dc: hdc; 
begin 
  dc := getdc(mainform.clienthandle); 
  mainform.Brush.bitmap := nil; 
  bmp.loadfromfile(bild); 
  mainform.Brush.bitmap := bmp; 
  hb := createpatternbrush(bmp.handle); 
  selectobject(dc, hb); 
  patblt(dc, 0, 0, clientwidth, clientheight, patcopy); 
  deleteobject(hb); 
  releasedc(mainform.clienthandle, dc); 
end; 
 
procedure TMainForm.FormDestroy(Sender: TObject); 
begin 
  bmp.free; 
end; 
 
// In der Unit Childwin kann das beispielsweise so aufgerufen werden: 
procedure TMDIChild.Memo1MouseDown(Sender: TObject; Button: TMouseButton; 
  Shift: TShiftState; X, Y: Integer); 
begin 
  mainform.wechsel('d:\dbr\exo.bmp'); 
end;

// ----------------------------------------------------------------------------

Beispiel 4

// Auf eine Anfrage hin, hab ich das Ganze noch weiter getrieben. Das Bild
// kann jetzt nicht nur gekachelt, sondern auch zentriert oder gedehnt
// ausgegeben werden. Allerdings kommt es bei Größenänderung der Mainform
// (speziell beim Dehnen) zu Flackererscheinungen am Rand.

...
private
{ Private declarations }
procedure CreateMDIChild(const Name: string);
public
procedure darstellen;
procedure wechseln(bild: TFileName);
end;

var
MainForm: TMainForm;

type
AnzeigeArt = (kacheln, zentrieren, dehnen);

const
anzeige: AnzeigeArt = kacheln;

implementation

{$R *.DFM}

uses ChildWin, About;

var
bmp:TBitmap;
abzug:integer;

const
ende:boolean=false;

procedure TMainForm.CreateMDIChild(const Name: string); 
var 
  Child: TMDIChild; 
begin 
{ create a new MDI child window } 
  Child := TMDIChild.Create(Application); 
  Child.Caption := Name; 
  if FileExists(Name) then Child.Memo1.Lines.LoadFromFile(Name); 
end; 
 
procedure TMainForm.FileNew1Execute(Sender: TObject); 
begin 
  CreateMDIChild('NONAME' + IntToStr(MDIChildCount + 1)); 
end; 
 
procedure TMainForm.FileOpen1Execute(Sender: TObject); 
begin 
  if OpenDialog.Execute then 
    CreateMDIChild(OpenDialog.FileName); 
end; 
 
procedure TMainForm.HelpAbout1Execute(Sender: TObject); 
begin 
  AboutBox.ShowModal; 
end; 
 
procedure TMainForm.FileExit1Execute(Sender: TObject); 
begin 
  Close; 
end; 
 
procedure TMainForm.darstellen; 
var 
  hb: HBrush; 
  rec: TRect; 
  dc: hdc; 
  cnv: TCanvas; 
  procedure zeichnen(c: TCanvas); 
  var links, oben, rechts, unten: integer; 
  begin 
    links := (clientwidth - bmp.width) div 2; 
    oben := (clientheight - bmp.height - abzug) div 2; 
    rechts := links + bmp.width; 
    unten := oben + bmp.height; 
    c.brush.color := clAppWorkSpace; 
    if links > 0 then begin 
      c.fillrect(rect(0, 0, links, clientheight)); 
      c.fillrect(rect(rechts, 0, clientwidth, clientheight)); 
    end; 
    if oben > 0 then begin 
      c.fillrect(rect(links, 0, rechts, oben)); 
      c.fillrect(rect(links, unten, rechts, clientheight)); 
    end; 
    c.draw(links, oben, bmp); 
  end; 
begin 
  Brush.bitmap.free; 
  if not ende then begin 
    dc := getdc(clienthandle); 
    cnv := TCanvas.create; 
    cnv.handle := dc; 
    Brush.bitmap := TBitmap.create; 
    case anzeige of 
      kacheln: 
        begin 
          Brush.bitmap.assign(bmp); 
          hb := createpatternbrush(bmp.handle); 
          selectobject(dc, hb); 
          patblt(dc, 0, 0, clientwidth, clientheight, patcopy); 
          deleteobject(hb); 
        end; 
      dehnen: 
        begin 
          Brush.bitmap.width := clientwidth; 
          Brush.bitmap.height := clientheight - abzug; 
          rec := clientrect; 
          rec.bottom := rec.bottom - abzug; 
          Brush.bitmap.canvas.stretchdraw(rec, bmp); 
          cnv.stretchdraw(rec, bmp); 
        end; 
      zentrieren: 
        begin 
          Brush.bitmap.width := clientwidth; 
          Brush.bitmap.height := clientheight - abzug; 
          zeichnen(Brush.bitmap.canvas); 
          zeichnen(cnv); 
        end; 
    end; 
    cnv.free; 
    releasedc(clienthandle, dc); 
  end; 
end; 
 
procedure TMainForm.wechseln(bild: TFileName); 
begin 
  bmp.loadfromfile(bild); 
  darstellen; 
end; 
 
procedure TMainForm.FormCreate(Sender: TObject); 
begin 
  abzug := ToolBar2.height + statusbar.height; // bei Bedarf 
  bmp := TBitmap.create; 
  wechseln('d:\dbr\frau.bmp'); 
end; 
 
procedure TMainForm.FormDestroy(Sender: TObject); 
begin 
  bmp.free; 
end; 
 
procedure TMainForm.FormCloseQuery(Sender: TObject; var CanClose: Boolean); 
begin 
  ende := canclose; 
end; 
 
procedure TMainForm.FormResize(Sender: TObject); 
begin 
  darstellen; 
end; 
 
// ----- Beispielaufrufe von einem Child aus ------------ 
 
// Beim Klick auf ein Memo wird die Anzeigeart umgeschaltet 
procedure TMDIChild.Memo1MouseDown(Sender: TObject; Button: TMouseButton; 
  Shift: TShiftState; X, Y: Integer); 
begin 
  case anzeige of 
    dehnen: anzeige := zentrieren; 
    kacheln: anzeige := dehnen; 
  else anzeige := kacheln; 
  end; 
  mainform.formresize(sender); // nicht etwa "darstellung" aufrufen 
end; 
 
// Wenn ein zweites Child geöffnet wird, wechselt das Hintergrundbild 
procedure TMDIChild.FormDeactivate(Sender: TObject); 
begin 
  mainform.wechseln('d:\dbr\exo.bmp'); 
end;