Скин

← →
anod (2002-08-07 00:40) [0]

Пытаюсь сделать что-то напоминающее скин, возникла пара вопросов

-При изменении размеров формы сверху прорисовывается нормально, а снизу наблюдаются глюки, как буд-то форма не перерисовывается.
procedure TForm1.FormPaint(Sender: TObject); var R: TRect; begin r:=GetClientRect; StretchBlt(DC,0,0,r.Right,20,sDC,1,1,3,20, SRCCOPY); StretchBlt(DC,0,r.Bottom-20,r.Right,20,sDC,5,1,3,20, SRCCOPY); end;
-Как мне сделать чтобы изображение размножалось:
StretchBlt(DC,0,20,Width,r.Bottom-20,sDC,9,1,3,20, SRCCOPY); При таком коде оно только растягивается.???

← →
anod (2002-08-07 00:42) [1]

Да, а можно ли сделать чтобы окно изменяло размеры,но без WS_THICKFRAME? (не было толстой полоски)

← →
фтщв (2002-08-07 01:17) [2]

Послал я такое сообщение SendMEssage(Handle,WM_ERASEBKGND,DC,0);, но button куда-то пропадает (если перерисовывать его, то он моргает) да и проблемм , с нижней полоской это полностью не исправило.

← →
Dmk (2002-08-07 01:51) [3]

Для перерисовки снизу необходимо в буффер формы дорисовывать. Не Canvas, а в текущий DC. Получить его можно с помощью BeginPaint.

DC := BeginPaint(self.handle,PaintStruct);
рисуешь, что надо и где надо на форме при текущих
размерах.
EndPaint(Handle,PaintStruct);

Полученный DC является текущим содержимым клиентской части формы, где внутри VCL рисуются все контролы, если они есть.
Когда происходит скроллинг формы, то внутренние методы просто сдвигают содержимое DC на ScrollSize, а с противоположной стороны
ничего не прорисовывается. Что у тебя и происходит. Поэтому тебе надо на этом DC нарисовать перед паинтом, что не реально. Потому что при каждом паинте создается новый DC и на нем все заново рисуется. Что бы рисовать правильно тебе надо не давать родителю получить WM_PAINT, а перерисовывать все самому. Довольно трудоемкая задача, но вполне решаема.

Для отрисовки контролов можно воспользоваться процедурой
PaintControls(DC: HDC; First: TControl);

← →
anod (2002-08-07 11:44) [4]

Ничего вообще не рисуется?
procedure TForm1.FormPaint(Sender: TObject);
var PaintStruct: TPaintStruct;
begin
DC := BeginPaint(handle,PaintStruct);
sDC:=CreateCompatibleDC(DC);
SelectObject(sDC, bmp.Handle);
StretchBlt(DC,0,0,Width,20,sDC,1,1,3,20, SRCCOPY);
StretchBlt(DC,0,Height-25,Width,20,sDC,5,1,3,20, SRCCOPY);
EndPaint(Handle,PaintStruct);
end;

← →
фтщв (2002-08-07 12:44) [5]

Блин, ну почему с BeginPaint не рисуется????????????????

← →
Dmk (2002-08-08 00:14) [6]

Надеюсь разберетесь.

unit tryout;

interface

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

type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
procedure WMPaint(var m: TWMPaint); message WM_PAINT;
procedure WMEraseBackground(var m: TWMPaint); message WM_ERASEBKGND;
public
{ Public declarations }
end;

type
TFColorA = packed record
case Integer of
0: (b,g,r,a:Byte);
1: (Color:DWord);
end;
TFColorTable = array[0..767]of TFColorA;
//................
PBMInfo =^TBMInfo;
TBMInfo = record
bmiHeader: TBitmapInfoHeader;
case Boolean of
True: (bmiColors:TFColorTable);
False: (r,g,b:Longint);
end;

type DBufferType = record
dbWidth:DWord;
dbHeight:DWord;
dbBpp:DWord;
dbMemDC:HDC;
dbMemEntry:pointer;
dbLinearAddr:DWord;
dbBitmap:hBitmap;
dbOldBitmap:hBitmap;
end;

var
Form1: TForm1;
MyBitmap:TBitmap;
MyDC:HDC;
ScreenDC:HDC;
MyBS:tagBitmap;
MyBMP:tagBitmapInfo;
bmDbufInfo:TBMInfo;
MyBuffer:DBufferType;
hSection:Integer = 0;
FormDC:HDC;
bb:pointer;

implementation

{$R *.dfm}

procedure TForm1.WMEraseBackground(var m: TWMPaint);
begin
{Inherited;} //Not Need
m.Result := LResult(false);
end;

procedure TForm1.WMPaint(var m: TWMPaint);
var HiddenDC: HDC;
PS:TPaintStruct;

begin
{Inherited;} //Not need
HiddenDC := BeginPaint(Self.Handle,PS);

StretchBlt(HiddenDC,
0,
0,
MyBitmap.Width,
MyBitmap.Height,
MyBuffer.dbMemDC,
0,
0,
MyBitmap.Width,
MyBitmap.Height,
SrcCopy);

EndPaint(Self.Handle,PS);
//...............
m.Result := LResult(false);
end;

← →
Dmk (2002-08-08 00:14) [7]

Function InitDC(Width, Height, Bpp:DWord; SampleDC:HDC):DBufferType;
var DIB_colors:integer;
DBufferSize:DWord;
//...
scWidth, scHeight:Integer;

begin
FillChar(Result,SizeOf(Result),0); //Clear Double Buffer
//...
DBufferSize := 0;
//...
scWidth := Width;
scHeight := Height;
Result.dbBpp := bpp;
Result.dbWidth := scWidth;
Result.dbHeight := scHeight;
//...
case Bpp of
8:DBufferSize := scWidth * scHeight;
32:DBufferSize := (scWidth * scHeight) * 4;
end;

//Structure size
FillChar(bmDbufInfo,SizeOf(bmDbufInfo),0);
bmDbufInfo.bmiHeader.biSize := SizeOf(TBitmapInfoHeader);
bmDbufInfo.bmiHeader.biPlanes :=1;

//Screen sizes
bmDbufInfo.bmiHeader.biWidth := scWidth;
bmDbufInfo.bmiHeader.biHeight := - scHeight;

//Number planes
bmDbufInfo.bmiHeader.biPlanes := 1;

//Bits per pixel
bmDbufInfo.bmiHeader.biBitCount := 32;

//Color type usage
bmDbufInfo.bmiHeader.biCompression := BI_RGB;

//Already set
bmDbufInfo.bmiHeader.biSizeImage := DBufferSize;

//resolutions
bmDbufInfo.bmiHeader.biXPelsPerMeter:=0;
bmDbufInfo.bmiHeader.biYPelsPerMeter:=0;

//Colors tables
bmDbufInfo.bmiHeader.biClrUsed:=0;
DIB_Colors := DIB_RGB_COLORS;
//...
Case Bpp of
1:begin
bmDbufInfo.bmiHeader.biClrUsed := 2;
DIB_Colors := DIB_PAL_COLORS;
end;
4:begin
bmDbufInfo.bmiHeader.biClrUsed := 16;
DIB_Colors := DIB_PAL_COLORS;
end;
8:begin
bmDbufInfo.bmiHeader.biClrUsed := 256;
DIB_Colors := DIB_PAL_COLORS;
end;
24:begin
bmDbufInfo.bmiHeader.biClrUsed := 0;
DIB_Colors := DIB_RGB_COLORS;
end;
32:begin
bmDbufInfo.bmiHeader.biClrUsed := 0;
DIB_Colors := DIB_RGB_COLORS;
end;
end;

//All colors are important
bmDbufInfo.bmiHeader.biClrImportant := 0;
//.....................
Result.dbMemEntry := nil;
//........................................
Result.dbMemDC := CreateCompatibleDC(SampleDC);
Result.dbBitmap := CreateDIBSection(Result.dbMemDC,pBitmapInfo(@bmDbufInfo)^,DIB_Colors,Result.dbMemEntry,hSection,0);
ReleaseDC(0,Result.dbMemDC);
Result.dbOldBitmap := SelectObject(Result.dbMemDC,Result.dbBitmap);
Result.dbLinearAddr := DWord(Result.dbMemEntry);
end;
//..........................................................
procedure FreeDBuffer(var _ResRec:DBufferType);
var ReturnVal:LongBool;
begin
//...
if _ResRec.dbOldBitmap <> 0 then
begin
_ResRec.dbOldBitmap := SelectObject(_ResRec.dbMemDC,_ResRec.dbBitmap);
ReturnVal := DeleteObject(_ResRec.dbOldBitmap);
If not ReturnVal then
begin
MessageDlg("Can""t delete hBitmap!",mtError,[mbOk],0);
Halt;
end else _ResRec.dbOldBitmap := 0;
end;
//............................
if _ResRec.dbMemDC <> 0 then
begin
ReleaseDC(0,_ResRec.dbMemDC);
ReturnVal := DeleteDC(_ResRec.dbMemDC);
If not ReturnVal then
begin
MessageDlg("Can""t delete DC object!",mtError,[mbOk],0);
Halt;
end else _ResRec.dbMemDC := 0;
end;
//...
_ResRec.dbWidth := 0;
_ResRec.dbHeight := 0;
_ResRec.dbBpp := 0;
_ResRec.dbMemDC := 0;
_ResRec.dbMemEntry := nil;
_ResRec.dbLinearAddr := 0;
_ResRec.dbBitmap := 0;
end;

procedure TForm1.FormCreate(Sender: TObject);
var SavedDC:HDC;
begin
FormDC := GetDC(Handle);
MyBitmap := TBitmap.Create;
MyBitmap.LoadFromFile("c:\Ducky.bmp");
ScreenDC := GetDC(0);
MyBuffer := InitDC(MyBitmap.Width,MyBitmap.Height,32,ScreenDC);

SavedDC := Self.Canvas.Handle;
Self.Canvas.Handle := MyBuffer.dbMemDC;
Self.Canvas.Draw(0,0,MyBitmap);
Self.Canvas.Handle := SavedDC;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
MyBitmap.Free;
FreeDBuffer(MyBuffer);
end;

end.

← →
anod (2002-08-08 01:18) [8]

Спасибо, буду разбираться.

Скин Найти похожие ветки