Delphi World - это проект, являющийся сборником статей и малодокументированных возможностей  по программированию в среде Delphi. Здесь вы найдёте работы по следующим категориям: delphi, delfi, borland, bds, дельфи, делфи, дэльфи, дэлфи, programming, example, программирование, исходные коды, code, исходники, source, sources, сорцы, сорсы, soft, programs, программы, and, how, delphiworld, базы данных, графика, игры, интернет, сети, компоненты, классы, мультимедиа, ос, железо, программа, интерфейс, рабочий стол, синтаксис, технологии, файловая система...
Фон MDI-окон

Привожу код, который может оказаться полезным. Он позволяет в обычной или MDI-форме создать графический tile-фон или градиентную заливку.

(Tile - "секция, плитка" - непрерывное заполнение определенной области немасштабируемым изображением слева-направо сверху вниз - В.О.)

Самая сложная часть кода осуществляет обработку системного сообщения, адресуемого дескриптору окна (ClientHandle), осуществляющему управление дочерними формами. Происходит это в момент вывода изображений в MDI-форме. Все что вам необходимо сделать - в режиме проектирования загрузить в imgTile необходимые изображения и перенести в свою программу следующий код:


unit UMain;

interface

uses
  Windows, Messages, Classes, SysUtils, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, Menus;

type
  TfrmMain = class(TForm)
    mnuMain: TMainMenu;
    mnuFile: TMenuItem;
    mnuExit: TMenuItem;
    imgTile: TImage;
    mnuOptions: TMenuItem;
    mnuBitmap: TMenuItem;
    mnuGradient: TMenuItem;
    procedure mnuExitClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure mnuBitmapClick(Sender: TObject);
    procedure mnuGradientClick(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure FormResize(Sender: TObject);
    procedure FormPaint(Sender: TObject);
  private
    { Private declarations }
    MDIDefProc: pointer;
    MDIInstance: TFarProc;
    procedure MDIWndProc(var prmMsg: TMessage);
    procedure CreateWnd; override;
    procedure ShowBitmap(prmDC: hDC);
    procedure ShowGradient(prmDC: hDC; prmRed, prmGreen, prmBlue: byte);
  public
    { Public declarations }
  end;

var

  frmMain: TfrmMain;
  glbImgWidth: integer;
  glbImgHeight: integer;

implementation

{$R *.DFM}

procedure TfrmMain.FormCreate(Sender: TObject);
begin

  glbImgHeight := imgTile.Picture.Height;
  glbImgWidth := imgTile.Picture.Width;
end;

procedure TfrmMain.FormResize(Sender: TObject);
begin

  FormPaint(Sender);
end;

procedure TfrmMain.MDIWndProc(var prmMsg: TMessage);
begin

  with prmMsg do
  begin
    if Msg = WM_ERASEBKGND then
    begin
      if mnuBitmap.Checked then
        ShowBitmap(wParam)
      else
        ShowGradient(wParam, 255, 0, 0);
      Result := 1;
    end
    else
      Result := CallWindowProc(MDIDefProc, ClientHandle, Msg, wParam, lParam);
  end;
end;

procedure TfrmMain.CreateWnd;
begin

  inherited CreateWnd;
  MDIInstance := MakeObjectInstance(MDIWndProc); { создаем ObjectInstance }
  MDIDefProc := pointer(SetWindowLong(ClientHandle, GWL_WNDPROC,
    longint(MDIInstance)));
end;

procedure TfrmMain.FormCloseQuery(Sender: TObject; var CanClose:
  Boolean);
begin

  { восстанавоиваем proc окна по умолчанию }
  SetWindowLong(ClientHandle, GWL_WNDPROC, longint(MDIDefProc));
  { избавляемся от ObjectInstance }
  FreeObjectInstance(MDIInstance);
end;

procedure TfrmMain.mnuExitClick(Sender: TObject);
begin

  close;
end;

procedure TfrmMain.mnuBitmapClick(Sender: TObject);

var
  wrkDC: hDC;
begin

  wrkDC := GetDC(ClientHandle);
  ShowBitmap(wrkDC);
  ReleaseDC(ClientHandle, wrkDC);
  mnuBitmap.Checked := true;
  mnuGradient.Checked := false;
end;

procedure TfrmMain.mnuGradientClick(Sender: TObject);
var
  wrkDC: hDC;
begin
  wrkDC := GetDC(ClientHandle);
  ShowGradient(wrkDC, 0, 0, 255);
  ReleaseDC(ClientHandle, wrkDC);
  mnuGradient.Checked := true;
  mnuBitMap.Checked := false;
end;

procedure TfrmMain.ShowBitmap(prmDC: hDC);
var
  wrkSource: TRect;
  wrkTarget: TRect;
  wrkX: integer;
  wrkY: integer;
begin
  { заполняем (tile) окно изображением }
  if FormStyle = fsNormal then
  begin
    wrkY := 0;
    while wrkY < ClientHeight do { заполняем сверху вниз.. }
    begin
      wrkX := 0;
      while wrkX < ClientWidth do { ..и слева направо. }
      begin
        Canvas.Draw(wrkX, wrkY, imgTile.Picture.Bitmap);
        Inc(wrkX, glbImgWidth);
      end;
      Inc(wrkY, glbImgHeight);
    end;
  end
  else if FormStyle = fsMDIForm then
  begin
    Windows.GetClientRect(ClientHandle, wrkTarget);
    wrkY := 0;
    while wrkY < wrkTarget.Bottom do
    begin
      wrkX := 0;
      while wrkX < wrkTarget.Right do
      begin
        BitBlt(longint(prmDC), wrkX, wrkY, imgTile.Width, imgTile.Height,
          imgTile.Canvas.Handle, 0, 0, SRCCOPY);
        Inc(wrkX, glbImgWidth);
      end;
      Inc(wrkY, glbImgHeight);
    end;
  end;
end;

procedure TfrmMain.ShowGradient(prmDC: hDC; prmRed, prmGreen, prmBlue: byte);
var
  wrkBrushNew: hBrush;
  wrkBrushOld: hBrush;
  wrkColor: TColor;
  wrkCount: integer;
  wrkDelta: integer;
  wrkRect: TRect;
  wrkSize: integer;
  wrkY: integer;
begin
  { процедура заполнения градиентной заливкой }
  wrkDelta := 255 div (1 + ClientHeight); { желаемое количество оттенков }
  if wrkDelta = 0 then
    wrkDelta := 1; { да, обычно 1 }
  wrkSize := ClientHeight div 240; { размер смешанных баров }
  if wrkSize = 0 then
    wrkSize := 1;
  for wrkY := 0 to 1 + (ClientHeight div wrkSize) do
  begin
    wrkColor := RGB(prmRed, prmGreen, prmBlue);
    wrkRect := Rect(0, wrkY * wrkSize, ClientWidth, (wrkY + 1) * wrkSize);
    if FormStyle = fsNormal then
    begin
      Canvas.Brush.Color := wrkColor;
      Canvas.FillRect(wrkRect);
    end
    else if FormStyle = fsMDIForm then
    begin
      wrkBrushNew := CreateSolidBrush(wrkColor);
      wrkBrushOld := SelectObject(prmDC, wrkBrushNew);
      FillRect(prmDC, wrkRect, wrkBrushNew);
      SelectObject(prmDC, wrkBrushOld);
      DeleteObject(wrkBrushNew);
    end;
    if prmRed > wrkDelta then
      Dec(prmRed, wrkDelta);
    if prmGreen > wrkDelta then
      Dec(prmGreen, wrkDelta);
    if prmBlue > wrkDelta then
      Dec(prmBlue, wrkDelta);
  end;
end;

procedure TfrmMain.FormPaint(Sender: TObject);
begin
  if FormStyle = fsNormal then
    if mnuBitMap.Checked then
      mnuBitMapClick(Sender)
    else
      mnuGradientClick(Sender);
end;

end.

Проект Delphi World © Выпуск 2002 - 2024
Автор проекта: USU Software
Вы можете выкупить этот проект.