Вот со скринсейвером косяк - прога рисует шарики заданных размеров и цветов поверх рабочего стола, делая его копию и переходя в графический режим, но возникла проблема она то работает то нет Иногда возникает уже надоевшая ошибка Canvas does not alow drawning иногда просто прога переходит в графический режим но ничё не рисует иногда нормально работает В чём косяк, может я не так чё-то уничтожаю перед закрытием? Вот код Главное в нём процедура Jeans Код (Text): unit jeansform; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, settings{модуль окна настроек}, registry; {$D SCRNSAVE Jeansed.dpr} type TForm1 = class(TForm) procedure FormKeyPress(Sender: TObject; var Key: Char); procedure FormCreate(Sender: TObject); procedure FormShow(Sender: TObject); private FParameter:TScreenJoke; { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation const colors:Array [0..21] of TColor= (clBlack,clMaroon,clGreen,clOlive,clNavy,clPurple,clTeal,clGray, clSilver,clRed,clLime,clYellow,clBlue,clFuchsia,clAqua,clLTGray, clDKGray,clWhite,clMoneyGreen,clSkyBlue,clCream,clMedGray); Var DC,DC1:hdc; SX,SY,ID:cardinal; h:integer; bit:TBitmap; d:Tcanvas; Procedure InitializeKey(p:pointer); Var reg:TRegIniFile; Begin reg:=TRegIniFile.Create('Software'); If reg.KeyExists('Jeans') then with TScreenJoke(p^) do begin AllColors:=reg.ReadBool('Jeans','Colors',true); OneSize:=reg.ReadBool('Jeans','OneSize',false); invers:=reg.ReadBool('Jeans','Inversion',false); If not AllColors then ParticularColor:=reg.ReadInteger('Jeans','PartColor',clRed) else ParticularColor:=clNone; LimitOfSize:=reg.ReadInteger('Jeans','Size',140); Wait:=reg.ReadInteger('Jeans','WaitTime',50); end else begin reg.WriteBool('Jeans','Colors',true); reg.WriteBool('Jeans','OneSize',false); reg.WriteBool('Jeans','Inversion',false); reg.WriteInteger('Jeans','PartColor',clNone); reg.WriteInteger('Jeans','Size',140); reg.WriteInteger('Jeans','WaitTime',50); with TScreenJoke(p^) do begin AllColors:=true; OneSize:=false; ParticularColor:=clNone; LimitOfSize:=140; Wait:=50; end; end; reg.Free; end; procedure SetSettings(p:pointer); var reg:TRegIniFile; begin reg:=TRegIniFile.Create('Software'); with TScreenJoke(p^) do begin reg.WriteBool('Jeans','Colors',AllColors); reg.WriteBool('Jeans','OneSize',OneSize); reg.WriteBool('Jeans','Inversion',invers); reg.WriteInteger('Jeans','PartColor',ParticularColor); reg.WriteInteger('Jeans','Size',LimitOfSize); reg.WriteInteger('Jeans','WaitTime',Wait); end; reg.Free; end; Function Compare(x,y:PScreenJoke):boolean; Begin result:=(x^.AllColors=y^.AllColors) and (x^.oneSize=y^.oneSize) and (x^.ParticularColor=y^.ParticularColor) and (x^.invers=y^.invers) and (x^.LimitOfSize=y^.LimitOfSize) and (x^.Wait=y^.Wait); End; {$R *.dfm} procedure Jeans(struct:pointer); Var Ifcol,inv:boolean; {r:TRect;} cons:cardinal; X, Y: Integer; size,sizelimit,time:cardinal; col:TColor; begin randomize; with PScreenJoke(struct)^ do begin Ifcol:=AllColors; sizelimit:=LimitOfSize+1; if OneSize then size:=sizelimit; inv:=invers; if not ifcol then col:=ParticularColor; time:=Wait; end; Form1.Left:=0; Form1.Top:=0; bit:=TBitmap.Create; SX:=GetSystemMetrics(0); SY:=GetSystemMetrics(1); bit.Width:=SX; bit.Height:=SY; DC:=GetDC(GetDesktopWindow); d:=TCanvas.Create; if inv then cons:=SRCInvert else cons:=SRCCopy; DC1:=GetDc(0); if not BitBlt(bit.Canvas.Handle,0,0,SX,SY,DC,0,0,cons) then begin MessageBox(0,'Drawning in this way is not allowed','Error',MB_ICONERROR); terminateprocess(GetCurrentProcess,0); end; d.Handle:=DC1; if not ifcol then bit.Canvas.Brush.Color:=col; repeat X := Random (SX); Y := Random (SY); if size<>sizelimit then size:=Random(sizelimit); if ifcol then bit.Canvas.Brush.Color:=colors[random(22)]; bit.Canvas.Ellipse(X - size, Y - size, X + size, Y + size); d.Draw(0,0,bit); ///Здесь раньше вылезала эта ошибка sleep(time); until false; end; procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char); begin terminatethread(h,0); d.Free; bit.Free; ReleaseDC(Form1.Handle,DC1); {ReleaseDc(Form1.Handle,DC); } UpdateWindow(GetDesktopWindow); Close; end; procedure TForm1.FormCreate(Sender: TObject); begin InitializeKey(@FParameter); Data:=FParameter; ///Data - глобальная переменная модуля настроек end; procedure TForm1.FormShow(Sender: TObject); begin if ParamCount>0 then case paramStr(1)[2] of 'p':close; 'c': begin case Config.ShowModal of ///форма из модуля settings mrOk:if not compare(@FParameter,@Data) then begin Fparameter:=Data; SetSettings(@Fparameter); end; mrCancel: end; Close; end; end else begin Width:=SX; Height:=SY; h:=beginthread(nil,1024,@Jeans,@FParameter,0,ID); ///CreateScreenSaverThread end; end; end.
Вот код процедуры рисования Код (Text): procedure Jeans(struct:pointer); Var Ifcol,inv:boolean; {r:TRect;} cons:cardinal; X, Y: Integer; size,sizelimit,time:cardinal; col:TColor; begin randomize; with PScreenJoke(struct)^ do begin Ifcol:=AllColors; sizelimit:=LimitOfSize+1; if OneSize then size:=sizelimit; inv:=invers; if not ifcol then col:=ParticularColor; time:=Wait; end; Form1.Left:=0; Form1.Top:=0; bit:=TBitmap.Create; SX:=GetSystemMetrics(0); SY:=GetSystemMetrics(1); bit.Width:=SX; bit.Height:=SY; DC:=GetDC(GetDesktopWindow); d:=TCanvas.Create; if inv then cons:=SRCInvert else cons:=SRCCopy; DC1:=GetDc(0); if not BitBlt(bit.Canvas.Handle,0,0,SX,SY,DC,0,0,cons) then ///Вот здесь бывают проблемы с доступом begin MessageBox(0,'Drawning in this way is not allowed','Error',MB_ICONERROR); terminateprocess(GetCurrentProcess,0); end; d.Handle:=DC1; if not ifcol then bit.Canvas.Brush.Color:=col; repeat X := Random (SX); Y := Random (SY); if size<>sizelimit then size:=Random(sizelimit); if ifcol then bit.Canvas.Brush.Color:=colors[random(22)]; bit.Canvas.Ellipse(X - size, Y - size, X + size, Y + size); d.Draw(0,0,bit); ///Здесь чаще вылезала ошибка 'Canvas does not allow drawning' sleep(time); until false; end; Хочу заметить, что в большинстве случаев никаких ошибок не происходит просто ничё в графическом режиме не рисуется, и вместо копии рабочего стола стоит только фон графического режима Каковы предложения?
seiko попробуй Код (Text): ... //d:=TCanvas.Create; ... //DC1:=GetDc(0); ... //d.Handle:=DC1; ... //d.Draw(0,0,bit); ///Здесь чаще вылезала ошибка 'Canvas does not allow drawning' BitBlt(DC, 0, 0, SX, SY, bit.Canvas.Handle, 0, 0, cons); ... + где-то _должно_ быть вызвано ReleaseDC(GetDesktopWindow, DC);
BitBlt(DC, 0, 0, SX, SY, bit.Canvas.Handle, 0, 0, cons); Этот код наоборот зачем, чтобы отображать изменения на реальном рабочем столе, а не а бутафории? Если да, так мне это не нужно, можно это гораздо проще сделать Если нет, это надо делать в цикле или по нажатию кнопки? с releaseDC тоже не работает, я уже проверял лишь дельфа от постоянных запусков так подвисает что её диспетчер завершить не может, и всё время система отчитывается об её убиении, хотя окно и проц остаются невредимыми В итоге либо перезагружать комп, либо пытаться убить PMasterом от MS_REMa или просто надеяться на чудо, которое, если быть терпеливым - происходит От чего такие глюки?
у программистов в Borland кривые руки.... попробуй заключи код в try блок - может сообщение не будет вылазить (если это exception). посмотри в исходниках VCL - они идут в комплекте - сделай поиск по этой строке.
seiko Этот код наоборот зачем ... так мне это не нужно Тогда поясни, что ты пытаешься сделать строчками Код (Text): ... d:=TCanvas.Create; ... DC1:=GetDc(0); // это аналог GetDC(GetDesktopWindow); // зачем тебе два контекста рабочего стола? ... d.Handle:=DC1; ... d.Draw(0,0,bit); ///Здесь чаще вылезала ошибка 'Canvas does not allow drawning' ... с releaseDC тоже не работает Не вижу в твоем коде ни одного ReleaseDC. GetDC и ReleaseDC это как begin и end в Pascal'е ходят парами.
в этом коде не было это просто старая редакция, а c ReleaseDC я пробовал уже объсни разницу между GetDC и GetWindowDC, а то я не шарю в чем фишка, если GetDC(0) - это тоже самое, что и GetWindowDC(GetDesktopWindow), то тогда что мы получим вызвав GetDc(GetDesktopWindow); попробовал присвоить Canvasу d DC(0) после bitBlt, процент нормально работающих разов увеличился
seiko это просто старая редакция Зачем тогда его показывать? объсни разницу между GetDC и GetWindowDC Первая возвращает контекст клиентской области окна, дескриптор которого указан в качестве параметра. Вторая возвращает контекст всего окна, т.е. включая заголовок, рамку и.д. если GetDC(0) - это тоже самое, что и GetWindowDC(GetDesktopWindow), то тогда что мы получим вызвав GetDc(GetDesktopWindow); Логически - одно и тоже, т.к. у десктопа все окно - это клиентская часть, то разницы между GetDC и GetWindowDC нет. Что касается практики, то я ни разу не пытался получить одновременно несколько контекстов для одного окна. Afaik это ненормально. попробовал присвоить Canvasу d DC(0) после bitBlt Ты не ответил на вопрос: "Зачем это нужно?"
короче нашёл кусок проблемы вначале он рисует нормально почему-то canvas.Draw всё время работает по-разному, то он нормально рисует, то начинает рисовать, а потом убирает изображение и ставит фон формы, судя по всему первые несколько вызовов Draw проходят нормально глюки идут потом в самой поцедуре происходят вызовы SetBkColor(передается Brush.color) и SetTextColor(передается Font.Color) в итоге потом всё это покрываеться этим фоном вместо нарисованого в битмепе
