{ Этот модуль заполняет фон формы рисунком bor6.bmp (256 цветов)
  и меняет его палитру при нажатии кнопки }
unit bmpformu;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;
type
  TBmpForm=class(TForm)
    Button1: TButton;
    procedure FormDestroy(Sender: TObject);
    procedure FormPaint(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    Bitmap: TBitmap;
    procedure ScrambleBitmap;
    procedure WMEraseBkgnd(var m: TWMEraseBkgnd); message WM_ERASEBKGND;
end;
var
  BmpForm: TBmpForm;
implementation
{$R *.DFM}
procedure TBmpForm.FormCreate(Sender: TObject);
begin
  Bitmap :=TBitmap.Create;
  Bitmap.LoadFromFile('bor6.bmp');
end;
procedure TBmpForm.FormDestroy(Sender: TObject);
begin
  Bitmap.Free;
end;
// since we're going to be painting the whole form, handling this
// message will suppress the uneccessary repainting of the background
// which can result in flicker.
procedure TBmpform.WMEraseBkgnd(var m : TWMEraseBkgnd);
begin
  m.Result :=LRESULT(False);
end;
procedure TBmpForm.FormPaint(Sender: TObject);
var x, y: Integer;
begin
  y :=0;
  while y < Height do begin
    x :=0;
    while x < Width do begin
      Canvas.Draw(x, y, Bitmap);
      x :=x + Bitmap.Width;
    end;
    y :=y + Bitmap.Height;
  end;
end;
procedure TBmpForm.Button1Click(Sender: TObject);
begin
  ScrambleBitmap; Invalidate;
end;
// scrambling the bitmap is easy when it's has 256 colors:
// we just need to change each of the color in the palette
// to some other value.
procedure TBmpForm.ScrambleBitmap;
var
  pal: PLogPalette;
  hpal: HPALETTE;
  i: Integer;
begin
  pal :=nil;
  try
    GetMem(pal, sizeof(TLogPalette) + sizeof(TPaletteEntry) * 255);
    pal.palVersion :=$300;
    pal.palNumEntries :=256;
    for i :=0 to 255 do
    begin
      pal.palPalEntry[i].peRed :=Random(255);
      pal.palPalEntry[i].peGreen :=Random(255);
      pal.palPalEntry[i].peBlue :=Random(255);
    end;
    hpal :=CreatePalette(pal^);
    if hpal <> 0 then
      Bitmap.Palette :=hpal;
  finally
    FreeMem(pal);
  end;
end;
end.

Пример:
Рисуются изображения размером 32*16 (размер стандартного глифа для Delphi). Очень полезно при поиске нужного изображения для кнопок!
Установить в инспекторе объектов для ListBox поле ItemHeight=19, а поле Color=clBtnFace.

{ Загрузить список файлов в ListBox1 при нажатии на кнопку Load (например)}
procedure TForm1.bLoadClick(Sender: TObject);
i S : String; 
begin 
  ListBox1.Clear; {чистим список}
  S :='*.bmp'#0; {задаем шаблон}
  ListBox1.Perform(LB_DIR, DDL_ReadWrite, Longint(@S[1])); {заполняем список} 
end; 
          ............ 
{Отобразить изображения и имена файлов в ListBox}
procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer; 
          Rect: TRect; State: DrawState); 
VAR 
  Bitmap : TBitmap;
  Offset : Integer; 
  BMPRect: TRect; 
begin 
  WITH (Control AS TListBox).Canvas DO BEGIN 
    FillRect(Rect); 
    Bitmap :=TBitmap.Create;
    Bitmap.LoadFromFile(ListBox1.Items[Index]); 
    Offset :=0; 
    IF Bitmap <> NIL THEN BEGIN 
      BMPRect :=Bounds(Rect.Left+2, Rect.Top+2, 
                        (Rect.Bottom-Rect.Top-2)*2, Rect.Bottom-Rect.Top-2); 
      {StretchDraw(BMPRect, Bitmap); Можно просто нарисовать, но лучше сначала убрать фон} 
      BrushCopy(BMPRect,Bitmap, Bounds(0, 0, Bitmap.Width, Bitmap.Height),
                Bitmap.Canvas.Pixels[0, Bitmap.Height-1]); 
      Offset :=(Rect.Bottom-Rect.Top+1)*2; 
    END; 
    TextOut(Rect.Left+Offset, Rect.Top, ListBox1.Items[Index]); 
    Bitmap.Free; 
  END; 
end;

Данный пример работает медленно, но оптимизация, для ускорения, вызвала бы трудность в понимании общего принципа его работы.


---

Можно ли из Delphi рисовать в любой части экрана или в чужом окне?
Для этого надо воспользоваться функциями API. Получить контекст чужого окна, либо всего экрана:
function GetDC(Wnd: HWnd): HDC;
где Wnd - указатель на нужное окно, или 0 для получения контекста всего экрана.
И далее, пользуясь функциями API, нарисовать все что надо.
Пример:

PROCEDURE DrawOnScreen; 
i ScreenDC: hDC; 
BEGIN 
  ScreenDC :=GetDC(0); {получить контекст экрана} 
  Ellipse(ScreenDC, 0, 0, 200, 200); {нарисовать} 
  ReleaseDC(0,ScreenDC); {освободить контекст} 
END;

Не забывайте после своих манипуляций посылать пострадавшим (или всем) окнам сообщение о необходимости перерисовки, для восстановления их первоначального вида.


---


 
 



Написание текста под углом




{ Эта процедура устанавливает угол вывода текста для указанного Canvas, угол в градусах }
{ Шрифт должен быть TrueType ! }
procedure CanvasSetTextAngle(c: TCanvas; d: single);
var  LogRec: TLOGFONT;    { Информация о шрифте }
begin
 {Читаем текущюю инф. о шрифте }
 GetObject(c.Font.Handle,SizeOf(LogRec) ,Addr(LogRec) );
 { Изменяем угол }
 LogRec.lfEscapement :=round(d*10);
 { Устанавливаем новые параметры }
 c.Font.Handle :=CreateFontIndirect(LogRec);
end;

---

Преобразование цвета RGBуHLS




{ Максимальные значения }
Const
 HLSMAX=240;
 RGBMAX=255;
 UNDEFINED=(HLSMAX*2) div 3;
i
 H, L, S  : integer; { H-оттенок, L-яркость, S-насыщенность }
 R, G, B  : integer; { цвета }
procedure RGBtoHLS;
i
 cMax,cMin  : integer;
 Rdelta,Gdelta,Bdelta : single;
Begin
  cMax :=max( max(R,G), B);
  cMin :=min( min(R,G), B);
  L :=round( ( ((cMax+cMin)*HLSMAX) + RGBMAX )/(2*RGBMAX) );
  if (cMax=cMin) then begin
      S :=0; H :=UNDEFINED;
  end else begin
      if (L <=(HLSMAX/2)) then
        S :=round( ( ((cMax-cMin)*HLSMAX) + ((cMax+cMin)/2) ) / (cMax+cMin) )
      else
        S :=round( ( ((cMax-cMin)*HLSMAX) + ((2*RGBMAX-cMax-cMin)/2) )
            / (2*RGBMAX-cMax-cMin) );
      Rdelta :=( ((cMax-R)*(HLSMAX/6)) + ((cMax-cMin)/2) ) / (cMax-cMin);
      Gdelta :=( ((cMax-G)*(HLSMAX/6)) + ((cMax-cMin)/2) ) / (cMax-cMin);
      Bdelta :=( ((cMax-B)*(HLSMAX/6)) + ((cMax-cMin)/2) ) / (cMax-cMin);
      if (R=cMax) then H :=round(Bdelta - Gdelta)
      else if (G=cMax) then H :=round( (HLSMAX/3) + Rdelta - Bdelta)
      else H :=round( ((2*HLSMAX)/3) + Gdelta - Rdelta );
      if (H < 0) then H:=H + HLSMAX;
      if (H> HLSMAX) then H:=H - HLSMAX;
  end;
  if S<0 then S:=0; if S>HLSMAX then S:=HLSMAX;
  if L<0 then L:=0; if L>HLSMAX then L:=HLSMAX;
end;
procedure HLStoRGB;
i
 Magic1,Magic2 : single;
  function HueToRGB(n1,n2,hue : single) : single;
  begin
    if (hue < 0) then hue :=hue+HLSMAX;
    if (hue> HLSMAX) then hue:=hue -HLSMAX;
    if (hue < (HLSMAX/6)) then
        result:=( n1 + (((n2-n1)*hue+(HLSMAX/12))/(HLSMAX/6)) )
    else
    if (hue < (HLSMAX/2)) then result:=n2 else
    if (hue < ((HLSMAX*2)/3)) then
        result:=( n1 + (((n2-n1)*(((HLSMAX*2)/3)-hue)+(HLSMAX/12))/(HLSMAX/6)))
    else result:=( n1 );
  end;
begin
  if (S=0) then begin
      B:=round( (L*RGBMAX)/HLSMAX ); R:=B; G:=B;
  end else begin
      if (L <=(HLSMAX/2)) then Magic2 :=(L*(HLSMAX + S) + (HLSMAX/2))/HLSMAX
      else Magic2 :=L + S - ((L*S) + (HLSMAX/2))/HLSMAX;
      Magic1 :=2*L-Magic2;
      R :=round( (HueToRGB(Magic1,Magic2,H+(HLSMAX/3))*RGBMAX + (HLSMAX/2))/HLSMAX );
      G :=round( (HueToRGB(Magic1,Magic2,H)*RGBMAX + (HLSMAX/2)) / HLSMAX );
      B :=round( (HueToRGB(Magic1,Magic2,H-(HLSMAX/3))*RGBMAX + (HLSMAX/2))/HLSMAX );
  end;
  if R<0 then R:=0; if R>RGBMAX then R:=RGBMAX;
  if G<0 then G:=0; if G>RGBMAX then G:=RGBMAX;
  if B<0 then B:=0; if B>RGBMAX then B:=RGBMAX;
end;

---

Число цветов (цветовая палитра) у данного компьютера
Эта функция возвращает число бит на точку у данного компьютера. Так, например, 8 - 256 цветов, 4 - 16 цветов ...

function GetDisplayColors : integer;
i tHDC  : hdc;
begin
 tHDC:=GetDC(0);
 result:=GetDeviceCaps(tHDC, 12)* GetDeviceCaps(tHDC, 14);
 ReleaseDC(0, tHDC);
end;

---

Копирование экрана




unit ScrnCap;
interface
uses WinTypes, WinProcs, Forms, Classes, Graphics, Controls;
 { Копирует прямоугольную область экрана }
function CaptureScreenRect(ARect : TRect) : TBitmap;
 { Копирование всего экрана }
function CaptureScreen : TBitmap;
 { Копирование клиентской области формы или элемента }
function CaptureClientImage(Control : TControl) : TBitmap;
 { Копирование всей формы элемента }
function CaptureControlImage(Control : TControl) : TBitmap;
{===============================================================}
implementation
function GetSystemPalette : HPalette;
i
 PaletteSize  : integer;
 LogSize      : integer;
 LogPalette  : PLogPalette;
 DC          : HDC;
 Focus        : HWND;
begin
 result:=0;
 Focus:=GetFocus;
 DC:=GetDC(Focus);
 try
  PaletteSize:=GetDeviceCaps(DC, SIZEPALETTE);
  LogSize:=SizeOf(TLogPalette)+(PaletteSize-1)*SizeOf(TPaletteEntry);
  GetMem(LogPalette, LogSize);
  try
    with LogPalette^ do
    begin
      palVersion:=$0300;
      palNumEntries:=PaletteSize;
      GetSystemPaletteEntries(DC, 0, PaletteSize, palPalEntry);
    end;
    result:=CreatePalette(LogPalette^);
  finally
    FreeMem(LogPalette, LogSize);
  end;
 finally
  ReleaseDC(Focus, DC);
 end;
end;
function CaptureScreenRect(ARect : TRect) : TBitmap;
i
 ScreenDC : HDC;
begin
 Result:=TBitmap.Create;
 with result, ARect do begin
  Width:=Right-Left;
  Height:=Bottom-Top;
  ScreenDC:=GetDC(0);
  try
    BitBlt(Canvas.Handle, 0,0,Width,Height,ScreenDC, Left, Top, SRCCOPY );
  finally
    ReleaseDC(0, ScreenDC);
  end;
  Palette:=GetSystemPalette;
 end;
end;
function CaptureScreen : TBitmap;
begin
 with Screen do
  Result:=CaptureScreenRect(Rect(0,0,Width,Height));
end;
function CaptureClientImage(Control : TControl) : TBitmap;
begin
 with Control, Control.ClientOrigin do
  result:=CaptureScreenRect(Bounds(X,Y,ClientWidth,ClientHeight));
end;
function CaptureControlImage(Control : TControl) : TBitmap;
begin
 with Control do
  if Parent=Nil then
    result:=CaptureScreenRect(Bounds(Left,Top,Width,Height))
  else
  with Parent.ClientToScreen(Point(Left, Top)) do
    result:=CaptureScreenRect(Bounds(X,Y,Width,Height));
end;
end.

---

Draw disable text




{************************ Draw Disabled Text **************
 ***** This function draws text in "disabled" style.  *****
 ***** i.e. the text is grayed .                      *****
 **********************************************************}
function DrawDisabledText (Canvas : tCanvas; Str: PChar; Count: Integer;
                          i Rect: TRect;  Format: Word): Integer;
begin
  SetBkMode(Canvas.Handle, TRANSPARENT);
  OffsetRect(Rect, 1, 1);
  Canvas.Font.color:=ClbtnHighlight;
  DrawText (Canvas.Handle, Str, Count, Rect,Format);
  Canvas.Font.Color:=ClbtnShadow;
  OffsetRect(Rect, -1, -1);
  DrawText (Canvas.Handle, Str, Count, Rect, Format);
end;

---

Как менять разрешение экрана по ходу выполнения программы




function SetFullscreenMode:Boolean;
i DeviceMode : TDevMode;
begin
 with DeviceMode do begin
  dmSize:=SizeOf(DeviceMode);
  dmBitsPerPel:=16;
  dmPelsWidth:=640;
  dmPelsHeight:=480;
  dmFields:=DM_BITSPERPEL or DM_PELSWIDTH or DM_PELSHEIGHT;
  result:=False;
  if ChangeDisplaySettings(DeviceMode,CDS_TEST or CDS_FULLSCREEN) <> DISP_CHANGE_SUCCESSFUL 
  then Exit;
  Result:=ChangeDisplaySettings(DeviceMode,CDS_FULLSCREEN)=DISP_CHANGE_SUCCESSFUL;
 end;
end;
procedure RestoreDefaultMode;
i T : TDevMode absolute 0;
begin
 ChangeDisplaySettings(T,CDS_FULLSCREEN);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
 if setFullScreenMode then begin
  sleep(7000);
  RestoreDefaultMode;
 end;
end;

---

Как поместить картинку из базы данных, например MsSQL, в компонент TIMAGE ?




1) Предполагается, что поле BLOB (например, Pict)
2) в запросе Query.SQL пишется что-то вроде
'select Pict from sometable where somefield=somevalue'
3) запрос открывается
4) делается "присваивание":
Image1.Picture.Assing(TBlobField(Query.FieldByName('Pict'))
или, если известно, что эта картинка - Bitmap, то можно
Image1.Picture.Bitmap.Assing(TBlobField(Query.FieldByName('Pict'))

А можно воспользоваться компонентом TDBImage.


---

Извлечение иконки из Exe - файла и рисование ее в TImages.




Каким образом извлечь иконку из EXE- и DLL-файлов (ExtractAssociatedIcon) и отобразить ее на компоненте Timage или небольшой области на форме?

--------------------------------------------------------------------------------

uses ShellApi;

procedure TForm1.Button1Click(Sender: TObject);

var IconIndex : word; h : hIcon;

begin IconIndex :=0; h :=ExtractAssociatedIcon(hInstance, 'C:\WINDOWS\NOTEPAD.EXE', IconINdex); DrawIcon(Form1.Canvas.Handle, 10, 10, h);

end;

// Копирование произвольной прямоугольной области экрана
Function CaptureScreenRect( ARect: TRect ): TBitmap;
i
  ScreenDC: HDC;
begin
  Result :=TBitmap.Create;
  with Result, ARect do
  begin
    Width :=Right - Left;
    Height :=Bottom - Top;
    // получаем для экрана контекст устройства
    ScreenDC :=GetDC( 0 );
    try
      // копируем оттуда прямоугольную область на канву
      // растрового изображения
      BitBlt( Canvas.Handle, 0, 0, Width, Height, ScreenDC,
        Left, Top, SRCCOPY );
    finally
      ReleaseDC( 0, ScreenDC );
    end;
  end;
end;

Function CaptureControlImage( Control: TControl ): TBitmap;
begin
  with Control do
    IF Parent=nil
        Then Result :=CaptureScreenRect( Bounds( Left, Top, Width,Height ))
    Else With Parent.ClientToScreen( Point( Left, Top )) DO
                        Result :=CaptureScreenRect( Bounds( X, Y, Width,Height ));
end;

//------------------------------------------------------------------------------
Procedure TMain.UserListDrawItem(Control: TWinControl; Index: Integer;
                                Rect: TRect; State: TOwnerDrawState);
Begin
  With TCustomListBox(Control)  Do
  Begin
    Canvas.FillRect(Rect);
        // Вывод самого текста текущего Item-а списка со сдвигом, чтобы освободить
        // место для изображения
    Canvas.TextOut(Rect.Left + 2 + ImageList.Height, Rect.Top+3, Items[Index]);
    Rect.Bottom:=Rect.Top  + ImageList.Height; // перерисовывать только
    Rect.Right :=Rect.Left + ImageList.Width;  // часть , на которой картинка
    Rect.Top:=Rect.Top+2;
    // по состоянию юзера перерисовывается изображение
    Case  GetUserStatus(Index) Of
            suNormal  : ImageList.Draw(Canvas,Rect.Left,Rect.Top,IMAGE_NORMAL);
            suMessage : ImageList.Draw(Canvas,Rect.Left,Rect.Top,IMAGE_MESSAGE);
            suAutoans : ImageList.Draw(Canvas,Rect.Left,Rect.Top,IMAGE_AUTOANS);
    End; // Case
  End; // With
End;
//------------------------------------------------------------------------------

//------------------------------------------------------------------------------
Procedure TMainForm.GridBookDrawColumnCell(Sender: TObject;
  const Rect: TRect; DataCol: Integer; Column: TColumn;
  State: TGridDrawState);
Begin
        // Изменение цвета фонта записи
    IF TDBGrid(Sender).DataSource.DataSet.FieldByName('OWNER_TYPE').AsInteger=SF_TYPE
    Then TDBGrid(Sender).Canvas.Font.Color:=ValueDesigner.colorSimpleSF
    Else TDBGrid(Sender).Canvas.Font.Color:=ValueDesigner.colorChildrenSF;
    // Поправка для выделенной записи , иначе текст не будет автоматически подсвечен           
    IF (gdSelected in State) AND TDBGrid(Sender).Focused
    Then TDBGrid(Sender).Canvas.Font.Color:=clHighLightText;
    TDBGrid(Sender).DefaultDrawColumnCell(Rect,DataCol,Column,State);
    // установка знака АКЦЕПТОВАНО в поле Sign
    IF CompareText(Field.FieldName,'SIGN')=0
    Then IF NOT TDBGrid(Sender).DataSource.DataSet.FieldByName('ACCEPT').IsNull
          Then TDBGrid(Sender).Canvas.Draw(Rect.Left,Rect.Top,
                                        AcceptBMP.Picture.Bitmap)
end;
//------------------------------------------------------------------------------

//------------------------------------------------------------------------------
procedure TMain.UserListMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
i Point : TPoint;
    I    : Integer;
Const NoHit=-1;
begin
    If Button=mbRight
    Then Begin
              // Если нажата правая кнопка мыши, выяснить, не попал ли курсор
              // на элемент списка UserList
              Point.X:=x;
              Point.Y:=y;
              I:=UserList.ItemAtPos(Point , True);
              If Not(i=NoHit) Then
                Begin
                    // курсор попал на элемент списка с номером i
                    // принудительно назначаем его текущим, т.е. отмеченным
   
                    UserList.ItemIndex:=I;
                    TListBox(Sender).PopUpMenu.AutoPopup:=True;
                  End
              Else // курсор промахнулся , нет смысла активизировать меню
                  TListBox(Sender).PopUpMenu.AutoPopup:=False;
          End;
end;
//------------------------------------------------------------------------------

Вернуться к содержанию

  i
    b:TBitMap;

  procedure TForm1.FormCreate(sender:TObject);
  begin
    b:=TBitMap.Create;
    b.pixelformat:=pf24bit;
    b.width:=Clientwidth;
    b.height:=Clientheight;
  end;

  procedure TForm1.Tim1OnTimer(sender:TObject);
  i
    p:PARGB;
    x,y:integer;
  begin
    for y:=0 to b.height-1 do
    begin
      p:=b.scanline[y];
      for x:=0 to b.width-1 do
      begin
        p[x].r:=random(256);
        p[x].g:=random(256);
        p[x].b:=random(256);
      end;
    end;
    canvas.draw(0,0,b);
  end;

  procedure TForm1.FormDestroy(sender:TObject);
  begin
    b.free;
  end;
  ........................................................
Вернуться к содержанию 

Какой самый быстрый способ для очистки canvasа?
Ответ:
Windows API функция PatBlt().
Пример:

            procedure TForm1.Button1Click(Sender: TObject); 
            begin 
              PatBlt(Form1.Canvas.Handle, 
                      0, 
                      0, 
                      Form1.ClientWidth, 
                      Form1.ClientHeight, 
                      WHITENESS); 
            end;

            procedure TForm1.FormResize(Sender: TObject); 
            begin 
              InvalidateRect(Form1.Handle, nil, false); 
            end;

              LockWindowUpdate(Memo1.Handle); 
              . 
              . 
              LockWindowUpdate(0);

            type 
              TForm1=class(TForm) 
                procedure FormCreate(Sender: TObject); 
                procedure FormDestroy(Sender: TObject); 
              private 
                { Private declarations } 
                procedure WMHotKey(var Msg : TWMHotKey); message WM_HOTKEY; 
              public 
                { Public declarations } 
              end; 
 
            var 
              Form1: TForm1; 
 
            implementation 
 
            {$R *.DFM} 
 
            const id_SnapShot=101; 
 
            procedure TForm1.WMHotKey (var Msg : TWMHotKey); 
            begin 
              if Msg.HotKey=id_SnapShot then 
                ShowMessage('GotIt'); 
            end; 
 
            procedure TForm1.FormCreate(Sender: TObject); 
            begin 
              RegisterHotKey(Form1.Handle, 
                              id_SnapShot, 
                              0, 
                              VK_SNAPSHOT); 
            end; 
 
            procedure TForm1.FormDestroy(Sender: TObject); 
            begin 
              UnRegisterHotKey (Form1.Handle, id_SnapShot); 
            end;

            procedure TForm1.Button1Click(Sender: TObject); 
            begin 
              SendMessage(FindWindow('Progman', 'Program Manager'), 
                          WM_COMMAND, 
                          $A065, 
                          0); 
            end;

      Срздайте новый проект. 
      Установите FormStyle формы в fsMDIForm 
      Разместите Image на форме и загрузите в него картинку. 
      Найдите { Private Declarations } в обьявлении формы и добаьте следующие строки: 
 
                FClientInstance : TFarProc; 
                FPrevClientProc : TFarProc; 
                procedure ClientWndProc(var Message: TMessage); 
 
      Добаьте следующие строки в разделе implementation: 
 
            procedure TMainForm.ClientWndProc(var Message: TMessage); 
            var 
              Dc : hDC; 
              Row : Integer; 
              Col : Integer; 
            begin 
              with Message do 
                case Msg of 
                  WM_ERASEBKGND: 
                  begin 
                    Dc :=TWMEraseBkGnd(Message).Dc; 
                    for Row :=0 to ClientHeight div Image1.Picture.Height do 
                      for Col :=0 to ClientWidth div Image1.Picture.Width do 
                        BitBlt(Dc, 
                            Col * Image1.Picture.Width, 
                            Row * Image1.Picture.Height, 
                            Image1.Picture.Width, 
                            Image1.Picture.Height, 
                            Image1.Picture.Bitmap.Canvas.Handle, 
                            0, 
                            0, 
                            SRCCOPY); 
                      Result :=1; 
                  end; 
                  else 
                    Result :=CallWindowProc(FPrevClientProc, 
                                              ClientHandle, 
                                              Msg, 
                                              wParam, 
                                              lParam); 
              end; 
            end; 
 
            В методе формы OnCreate добавьте: 
 
                FClientInstance :=MakeObjectInstance(ClientWndProc); 
                FPrevClientProc :=Pointer(GetWindowLong(ClientHandle, 
                                          GWL_WNDPROC)); 
                SetWindowLong(ClientHandle, 
                              GWL_WNDPROC, LongInt(FClientInstance)); 
 
            Добавьте к проекту новую форму и установите ее свойство FormStyle в 
            fsMDIChild. 
 
            У Вас получился  MDI-проект с "обоями" в клиентской области MDI формы.

            procedure TForm1.Button1Click(Sender: TObject); 
            var 
              b : bool; 
            begin 
              SystemParametersInfo(SPI_GETDRAGFULLWINDOWS, 0, @b, 0); 
              if not b then 
                ShowMessage('Full Window Drag is not enabled') else 
                ShowMessage('Full Window Drag is enabled'); 
            end;

              SystemParametersInfo(SPI_SETDESKWALLPAPER, 
                                    0, 
                                    PChar('C:\SOMEPATH\SOME.BMP'), 
                                    SPIF_SENDWININICHANGE);

            procedure TForm1.Button1Click(Sender: TObject); 
            var 
              IconSizeX : integer; 
              IconSizeY : integer; 
              AndMask : TBitmap; 
              XOrMask : TBitmap; 
              IconInfo : TIconInfo; 
              Icon : TIcon; 
            begin 
              {Get the icon size} 
              IconSizeX :=GetSystemMetrics(SM_CXICON); 
              IconSizeY :=GetSystemMetrics(SM_CYICON); 
 
              {Create the "And" mask} 
              AndMask :=TBitmap.Create; 
              AndMask.Monochrome :=true; 
              AndMask.Width :=IconSizeX; 
              AndMask.Height :=IconSizeY; 
 
              {Draw on the "And" mask} 
              AndMask.Canvas.Brush.Color :=clWhite; 
              AndMask.Canvas.FillRect(Rect(0, 0, IconSizeX, IconSizeY)); 
              AndMask.Canvas.Brush.Color :=clBlack; 
              AndMask.Canvas.Ellipse(4, 4, IconSizeX - 4, IconSizeY - 4); 
 
              {Draw as a test} 
              Form1.Canvas.Draw(IconSizeX * 2, IconSizeY, AndMask); 
 
              {Create the "XOr" mask} 
              XOrMask :=TBitmap.Create; 
              XOrMask.Width :=IconSizeX; 
              XOrMask.Height :=IconSizeY; 
 
              {Draw on the "XOr" mask} 
              XOrMask.Canvas.Brush.Color :=ClBlack; 
              XOrMask.Canvas.FillRect(Rect(0, 0, IconSizeX, IconSizeY)); 
              XOrMask.Canvas.Pen.Color :=clRed; 
              XOrMask.Canvas.Brush.Color :=clRed; 
              XOrMask.Canvas.Ellipse(4, 4, IconSizeX - 4, IconSizeY - 4); 
 
              {Draw as a test} 
              Form1.Canvas.Draw(IconSizeX * 4, IconSizeY, XOrMask); 
 
              {Create a icon} 
              Icon :=TIcon.Create; 
              IconInfo.fIcon :=true; 
              IconInfo.xHotspot :=0; 
              IconInfo.yHotspot :=0; 
              IconInfo.hbmMask :=AndMask.Handle; 
              IconInfo.hbmColor :=XOrMask.Handle; 
              Icon.Handle :=CreateIconIndirect(IconInfo); 
 
              {Destroy the temporary bitmaps} 
              AndMask.Free; 
              XOrMask.Free; 
 
              {Draw as a test} 
              Form1.Canvas.Draw(IconSizeX * 6, IconSizeY, Icon); 
 
              {Assign the application icon} 
              Application.Icon :=Icon; 
 
              {Force a repaint} 
              InvalidateRect(Application.Handle, nil, true); 
 
              {Free the icon} 
              Icon.Free; 
            end;

            function RgbToGray(RGBColor : TColor) : TColor; 
            var 
              Gray : byte; 
            begin 
              Gray :=Round((0.30 * GetRValue(RGBColor)) + 
                            (0.59 * GetGValue(RGBColor)) + 
                            (0.11 * GetBValue(RGBColor ))); 
              Result :=RGB(Gray, Gray, Gray); 
            end; 
 
            procedure TForm1.FormCreate(Sender: TObject); 
            begin 
              Shape1.Brush.Color :=RGB(255, 64, 64); 
              Shape2.Brush.Color :=RgbToGray(Shape1.Brush.Color); 
            end;

...
function CreateRotatedFont(F : TFont; Angle : Integer) : hFont;
  {-create a rotated font based on the font object F}
var
  LF : TLogFont;
begin
  FillChar(LF, SizeOf(LF), #0);
  with LF do 
  begin
    lfHeight :=F.Height;
    lfWidth :=0;
    lfEscapement :=Angle * 10;
    lfOrientation :=0;
    if fsBold in F.Style then
      lfWeight :=FW_BOLD
    else
      lfWeight :=FW_NORMAL;
    lfItalic :=Byte(fsItalic in F.Style);
    lfUnderline :=Byte(fsUnderline in F.Style);
    lfStrikeOut :=Byte(fsStrikeOut in F.Style);
    lfCharSet :=DEFAULT_CHARSET;
    StrPCopy(lfFaceName, F.Name);
    lfQuality :=DEFAULT_QUALITY;
    {everything else as default}
    lfOutPrecision :=OUT_DEFAULT_PRECIS;
    lfClipPrecision :=CLIP_DEFAULT_PRECIS;
    case F.Pitch of
      fpVariable : lfPitchAndFamily :=VARIABLE_PITCH;
      fpFixed    : lfPitchAndFamily :=FIXED_PITCH;
    else
      lfPitchAndFamily :=DEFAULT_PITCH;
    end;
  end;
  Result :=CreateFontIndirect(LF);
end;
...
  {create the rotated font}
  if FontAngle <>0then
    Canvas.Font.Handle :=CreateRotatedFont(Font,FontAngle);
...

Функция Printer.Canvas.StretchDraw(Rect,Bitmap) не всегда правильно выводит в печать графику. По этому я предлагаю свой модуль с функцией печати битмапа. Битмап тут вмещается и перемасштабируется, чтоб попасть на страницу с увеличенным размером и разместиться по центру листа. Эти установки пользователь может изменить по своему желанию.

unit UPrint;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Printers;

 

 
 
 
 
 
 
 
 
 
 
 
 
 

procedure PrintBitmap(ABitmap: TBitmap);

implementation

procedure PrintBitmap(ABitmap: TBitmap);

var

B : TBitmap;

isPrnPal : Boolean;

Pal, OldPal : hPalette;

PageWidth, PageHeight : Integer;

PageMargin : TPoint;

TestInt : Integer;

ImagePageWidth : Integer;

ImagePageHeight : Integer;

ScaleX, ScaleY, OffsetX, OffsetY : Integer;

ImageSize, InfoSize : DWord;

PImage, PInfo : Pointer;

begin

Pal :=0;

OldPal :=0;

Printer.BeginDoc;

B :=TBitmap.Create;

B.Assign(ABitmap);

B.PixelFormat :=pf24bit;

isPrnPal :=False;

if (GetDeviceCaps(Printer.Canvas.Handle, RasterCaps) and RC_Palette)=RC_Palette then

begin

B.PixelFormat :=pf8bit;

Pal :=CopyPalette(B.Palette);

OldPal :=SelectPalette(Printer.Canvas.Handle, Pal, False);

isPrnPal :=True;

end;

PageWidth :=Integer(GetDeviceCaps(Printer.Canvas.Handle, HORZRES));

PageHeight :=Integer(GetDeviceCaps(Printer.Canvas.Handle, VERTRES));

PageMargin.X :=0; PageMargin.Y :=0;

TestInt :=Integer(GetPrintingOffset);

if Escape(Printer.Canvas.Handle, QUERYESCSUPPORT, SizeOf(TestInt), @TestInt, nil) <> 0 then

begin

if Escape(Printer.Canvas.Handle, GETPRINTINGOFFSET, 0, nil, @PageMargin) <=0 then

begin

PageMargin.X :=0;

PageMargin.Y :=0;

end;

end;

ImagePageWidth :=PageWidth - 2 * PageMargin.X;

ImagePageHeight :=PageHeight - 2 * PageMargin.Y;

if ((ImagePageWidth <=ImagePageHeight) and (B.Width>= B.Height)) or ((ImagePageWidth> ImagePageHeight) and (B.Width > B.Height)) then

begin

ScaleX :=ImagePageWidth;

ScaleY :=Trunc(B.Height * ImagePageWidth / B.Width);

OffsetX :=PageMargin.X;

OffsetY :=(PageHeight div 2) - (ScaleY div 2);

end else

begin

ScaleY :=ImagePageHeight;

ScaleX :=Trunc(B.Width * ImagePageHeight / B.Height);

OffsetY :=PageMargin.Y;

OffsetX :=(PageWidth div 2) - (ScaleX div 2);

end;

GetDIBSizes(B.Handle, InfoSize, ImageSize);

GetMem(PImage, ImageSize);

GetMem(PInfo, InfoSize);

GetDIB(B.Handle, B.Palette, PInfo^, PImage^);

StretchDIBits(Printer.Canvas.Handle, OffsetX, OffsetY, ScaleX, ScaleY, 0, 0, B.Width, B.Height, PImage, PBitmapInfo(PInfo)^, DIB_RGB_COLORS, SRCCOPY);

FreeMem(PImage); FreeMem(PInfo);

if isPrnPal then

begin

SelectPalette(Printer.Canvas.Handle, OldPal, False);

DeleteObject(Pal);

end;

Printer.EndDoc;

end;

end.

Image1.BitMap.Hande :=LoadBitMap( hInstance, 'BMP_NAME');

LoadBitmap загружает только картинку, без палитры. Если палитра BitMap'а отличается от системной, то ее надо устанавливать "вручную". Могут возникнуть проблемы, если на одной форме расположены две картинки с разными палитрами.

procedure XLoadBitmap(Instance : THandle; BitmapName : PChar; var HB : HBitmap; var HP : HPalette);

var

DC : HDC;

BI : PBitMapInfo;

Pal : PLogPalette;

I : Integer;

ResIdHandle : THandle;

ResDataHandle : THandle;

Bitmap : HBitmap;

C : HWnd;

OldPalette, Palette : HPalette;

begin

Bitmap :=0;

Palette :=0;

HB :=0;

HP :=0;

{Получить ресурс из модуля}

ResIDHandle :=FindResource(Instance, BitmapName, rt_BitMap );

if ResIDHandle <> 0 then

begin

ResDataHandle :=LoadResource(Instance, ResIDHandle );

if ResDataHandle <> 0 then

begin

BI :=LockResource( ResDataHandle );

if BI <>nil then

begin

{256-цветный битмап?}

if BI^.bmiHeader.biBitCount=8 then

begin

{Создать палитру}

GetMem( Pal, SizeOf(TLogPalette) + 256 * SizeOf( TPaletteEntry ));

for I :=0 to 255 do

with Pal^.palPalEntry[I] do

begin

peRed :=BI^.bmiColors[I].rgbRed;

peGreen :=BI^.bmiColors[I].rgbGreen;

peBlue :=BI^.bmiColors[I].rgbBlue;

peFlags :=0;

end;

Pal^.palNumEntries :=256;

Pal^.palVersion :=$300;

Palette :=CreatePalette(Pal^);

FreeMem(Pal, SizeOf(TLogPalette) + 256 * SizeOf(TPaletteEntry));

{Привести цвета палитры в системные}

DC :=CreateDC('Display', nil, nil, nil);

OldPalette :=SelectPalette(DC, Palette, False);

UnrealizeObject(Palette);

RealizePalette(DC);

{Создать битмап}

BitMap :=CreateDIBitmap(DC, BI^.bmiHeader, CBM_INIT, @PByteArray(BI)^[SizeOf(TBitMapInfo) + SizeOf(TRGBQuad) * 256 - 4], BI^, DIB_RGB_COLORS);

{Освободить ресурсы}

UnlockResource(ResDataHandle);

FreeResource(ResDataHandle);

SelectPalette(DC, OldPalette, False);

DeleteDC(DC);

end

else

begin

{Не 256-цветный битмап}

UnlockResource(ResDataHandle);

FreeResource(ResDataHandle);

BitMap :=LoadBitmap(Instance, BitmapName);

end;

HB :=Bitmap;

HP :=Palette;

end; {BI <> nil }

end; {ResDataHandle <> 0}

end; {ResIDHandle <> 0 }

end;

procedure TForm1.FormCreate(Sender: TObject);

var

HB : HBitmap;

HP : HPalette;

begin

xLoadBitmap(hInstance, 'PHOTO', HB, HP);

Image1.Picture.Bitmap.Handle :=HB;

Image1.Picture.Bitmap.Palette :=HP;

end;

Картинка будет иметь размер 128 x 128 точек:

Image1.Picture.Bitmap.Width :=128;
Image1.Picture.Bitmap.Height :=128;

Вызываем функцию Windows API для формирования BitMap:

SetBitmapBits(Image1.Picture.Bitmap.Handle, sizeof(TestArray), @TestArray);
Image1.Refresh; {для того, чтобы изменения отобразились}

Однако, если вы используете свою палитру, то ее нужно создать