Главная страница
    Top.Mail.Ru    Яндекс.Метрика
Форум: "Основная";
Текущий архив: 2002.08.19;
Скачать: [xml.tar.bz2];

Вниз

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

 
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]

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



Страницы: 1 вся ветка

Форум: "Основная";
Текущий архив: 2002.08.19;
Скачать: [xml.tar.bz2];

Наверх





Память: 0.47 MB
Время: 0.011 c
6-60781
Airs
2002-06-07 17:51
2002.08.19
Проблема с передачей сложных данных


1-60617
Вэн
2002-08-08 14:54
2002.08.19
Раблта в Интернет


1-60573
N A N
2002-08-07 18:36
2002.08.19
Как перекодировать KOI-8R в Win1251?


1-60635
Invega
2002-08-08 19:38
2002.08.19
Как в MainMenu сделать...


4-60898
whc
2002-06-14 19:13
2002.08.19
Вставка контролов в ячейки StringGrid





Afrikaans Albanian Arabic Armenian Azerbaijani Basque Belarusian Bulgarian Catalan Chinese (Simplified) Chinese (Traditional) Croatian Czech Danish Dutch English Estonian Filipino Finnish French
Galician Georgian German Greek Haitian Creole Hebrew Hindi Hungarian Icelandic Indonesian Irish Italian Japanese Korean Latvian Lithuanian Macedonian Malay Maltese Norwegian
Persian Polish Portuguese Romanian Russian Serbian Slovak Slovenian Spanish Swahili Swedish Thai Turkish Ukrainian Urdu Vietnamese Welsh Yiddish Bengali Bosnian
Cebuano Esperanto Gujarati Hausa Hmong Igbo Javanese Kannada Khmer Lao Latin Maori Marathi Mongolian Nepali Punjabi Somali Tamil Telugu Yoruba
Zulu
Английский Французский Немецкий Итальянский Португальский Русский Испанский