Советы по Delphi
Заполнение изображением MDI-формы I
Привет всем! Кто-нибудь знает как поместить в MDI-форму изображение и заполнить им всю форму (tile)?
(Tile - "секция, плитка" - непрерывное заполнение определенной области немасштабируемым изображением слева-направо сверху вниз - В.О.)
Да. Это легкий вопрос..
| procedure TForm.OnPaint(Sender: TObject); procedure Tile(c:TCanvas;b:TBitMap);varx,y,h,w,i,j:integer;beginwith b do beginh:=b.height;w:=b.width;end;y:=0;with c.Cliprect do begini:=bottom-top-1; //высотаj:=right-left-1; //ширинаend;while y<i do beginx:=0;while x<j do beginc.draw(x,y,b);inc(x,w);end;inc(y,h);end;end; begin if Sender is TForm thenTile(TForm(Sender).Canvas,fTileWith);end; |
Несколько людей уже спрашивали, как залить фон главной MDI-формы повторяющимся изображением. Ключевым моментом здесь является работа с дескриптором окна MDI-клиента (свойство ClientHandle) и заполнение изображением окно клиента в ответ на сообщение WM_ERASEBKGND. Тем не менее здесь существует пара проблем: прокрутка главного окна и перемещение дочернего MDI-окна за пределы экрана портят фон, и закрашивание за иконками дочерних окон не происходит.
Ну наконец-то! Похоже я нашел как решить обе проблемы. Вот код для тех, кому все это интересно. Я начинаю с проблемы дочерних форм, ниже код для решения проблемы с главной формой (модули с именами MDIWAL2U.PAS и MDIWAL1U.PAS). На главной форме расположен компонент TImage с именем Image1, содержащий изображение для заливки фона.
|
|
...private{ Private declarations }procedure WMIconEraseBkgnd(VAR Message: TWMIconEraseBkgnd);message WM_ICONERASEBKGND;...USES MdiWal1u; procedure TForm2.WMIconEraseBkgnd(VAR Message: TWMIconEraseBkgnd); BEGIN TForm1(Application.Mainform).PaintUnderIcon(Self, Message.DC);Message.Result := 0;END; |
================================================================
| ...{ Private declarations }bmW, bmH : Integer;FClientInstance,FPrevClientProc : TFarProc;PROCEDURE ClientWndProc(VAR Message: TMessage);publicPROCEDURE PaintUnderIcon(F: TForm; D: hDC);... PROCEDURE TForm1.PaintUnderIcon(F: TForm; D: hDC); VAR DestR, WndR : TRect;Ro, Co,xOfs, yOfs,xNum, yNum : Integer;BEGIN {вычисляем необходимое число изображений для заливки D}GetClipBox(D, DestR);WITH DestR DOBEGINxNum := Succ((Right-Left) DIV bmW);yNum := Succ((Bottom-Top) DIV bmW);END;{вычисление смещения изображения в D}GetWindowRect(F.Handle, WndR);WITH ScreenToClient(WndR.TopLeft) DOBEGINxOfs := X MOD bmW;yOfs := Y MOD bmH;END;FOR Ro := 0 TO xNum DOFOR Co := 0 TO yNum DOBitBlt(D, Co*bmW-xOfs, Ro*bmH-Yofs, bmW, bmH,Image1.Picture.Bitmap.Canvas.Handle,0, 0, SRCCOPY);END; PROCEDURE TForm1.ClientWndProc(VAR Message: TMessage); VAR Ro, Co : Word; begin with Message docase Msg ofWM_ERASEBKGND:beginFOR Ro := 0 TO ClientHeight DIV bmH DOFOR Co := 0 TO ClientWIDTH DIV bmW DOBitBlt(TWMEraseBkGnd(Message).DC,Co*bmW, Ro*bmH, bmW, bmH,Image1.Picture.Bitmap.Canvas.Handle,0, 0, SRCCOPY);Result := 1;end;WM_VSCROLL,WM_HSCROLL :beginResult := CallWindowProc(FPrevClientProc,ClientHandle, Msg, wParam, lParam);InvalidateRect(ClientHandle, NIL, True);end;elseResult := CallWindowProc(FPrevClientProc,ClientHandle, Msg, wParam, lParam);end;end; procedure TForm1.FormCreate(Sender: TObject); begin bmW := Image1.Picture.Width;bmH := Image1.Picture.Height;FClientInstance := MakeObjectInstance(ClientWndProc);FPrevClientProc := Pointer(GetWindowLong(ClientHandle, GWL_WNDPROC));SetWindowLong(ClientHandle, GWL_WNDPROC,LongInt(FClientInstance));end; |
Neil Rubenkind [000612]
пишет:
В разделе Заполнение изображением MDI-формы повторяющимся изображением. Я нашел (Copyright не мой а из книжки) более простой способ.
| ... private OutCanvas: TCanvas;OldWinProc, NewWinProc: Pointer;procedure NewWinProcedure (var Msg: TMessage); ... procedure TMainForm.FormCreate(Sender: TObject); begin NewWinProc := MakeObjectInstance (NewWinProcedure);OldWinProc := Pointer (SetWindowLong (ClientHandle, gwl_WndProc, Cardinal (NewWinProc)));OutCanvas := TCanvas.Create;end; procedure TMainForm.NewWinProcedure (var Msg: TMessage); var BmpWidth, BmpHeight: Integer;I, J: Integer;begin // default processing firstMsg.Result := CallWindowProc (OldWinProc,ClientHandle, Msg.Msg, Msg.wParam, Msg.lParam); // handle background repaintif Msg.Msg = wm_EraseBkgnd thenbeginBmpWidth := MainForm.Image1.Width;BmpHeight := MainForm.Image1.Height;if (BmpWidth <> 0) and (BmpHeight <> 0) thenbeginOutCanvas.Handle := Msg.wParam;for I := 0 to MainForm.ClientWidth div BmpWidth dofor J := 0 to MainForm.ClientHeight div BmpHeight doOutCanvas.Draw (I * BmpWidth, J * BmpHeight, MainForm.Image1.Picture.Graphic);end;end;end; procedure TMainForm.FormDestroy(Sender: TObject); begin OutCanvas.Free;end; |
Пока.. [000893]
