Иногда эта процедура не выполняет передачу данных в битмап, возвращая как число переданных строк 0.
Глюк слабовоспроизводим, т.е. один и тот же код на одной машине работает нормально, а на другой – нет.
Гарантированным лекарством является "подушка" перед передаваемыми данными. То есть непосредственно перед Points должен располагаться большой кусок данных (из опыта: не менее 1Мб), принадлежащих памяти программы. Но по степени маразматичности это даже не костыли, а гроб на колёсиках.
Если кто сталкивался с этой ситуёвиной, расскажите, плз, как нормально защититься.
Уважаемые авторы вопросов! Большая просьба сообщить о результатах решения проблемы на этой странице. Иначе, следящие за обсуждением, возможно имеющие аналогичные проблемы, не получают ясного представления об их решении. А авторы ответов не получают обратной связи. Что можно расценивать, как проявление неуважения к отвечающим от автора вопроса.
28-02-2018 02:29
Ну, ответа я так и не нашел, а он был прост. При вызове
BitInfo.bmiColors должен содержать необходимые цвета для маски (и память, естественно, должна быть выделена). Таким образом, если количество цветов <=2^8, то память портится и, в дальнейшем, приложение будет жестоко глючить. Спасибо за внимание.
Обычно 1M (512x512x32bit). Пробовал и меньше и больше (вплоть до 2M).
Что касается шаманства, то я и не отрицаю, что сделал бубен.
Но когда я чувствую запах серы (а адрес кратный 64K, с которого процедура начинает работать, – это именно чертовщина), то вполне готов начинать промышленное производство святой воды.
Ну, а если кто-то способен произвести изгнание бесов из винды, то я буду только рад.
А вот левее не выходило.
А какой размер у картинки (в байтах)?
А вообще это шаманством попахивает и то что глюка нет, ничего не значит, он и раньше ведь не всегда проявлялся. Тут надо чётко выяснить в чём проблема, а не функции выделения наугад выбирать.
Не обязательно на 64K. Если сдвигать от этого адреса дальше вправо, то тоже проблем не будет. А вот левее не выходило.
В приведенном пример GlobalAlloc давал адреса, кончающиеся на 0020 (хотя при других обстоятельствах, в частности, при других размерах выделяемых блоков они, разумеется, могут оказаться и оказываются совершенно иными).
Почему оно работает, а другое не работает, я не знаю. Но поскольку экспериментально было установлено, что дело в размещении в памяти, я начал пробовать разные способы ее выделения. И нашел тот, при котором воспроизведения глюка добиться не удалось ни на одной машине.
Работает только GlobalAlloc.
Довольно странно, так как GlobalAlloc гарантирует выравнивание всего на 8 байт, а судя по вашему 00A80000 требуется выравнивание не меньше чем на 64К.
Удача наступила при @Points1[j]=00A80000, что говорит именно о чувствительности процедуры SetDiBits к расположению данных в памяти.
Далее я перепробовал различные методы выделения памяти под блок данных. Работает только GlobalAlloc. Расположение блока в полях объекта, глобальной переменной, выделение памяти через GetMem или SetLength проблемы не решают.
Дальнейшие исследования показали, что на одной и той же машине при одном и том же экзешнике глюк в профиле одного пользователя имеет место, в профиле другого – нет. И вообще накоплена обширная, но бессмысленная, статистика машин и ситуаций, где глюк есть и где его.
Есть предположение, что природа глюка кроется в расположении передаваемых данных относительно границ страниц памяти.
P.S. И хватит меня клевать за GetDC(Handle), переданный как параметр!
Ндя, странно, в Delphi5 без Dummy не работает, даже не смотря на то, что удалил TPaintBox`ы. А в BDS2006 и 2007 работает.
Использование в SetDiBits в качестве первого параметра GetDC(Handle) приводит к нехватке ресурсов, а если использовать 0, то не работает в Win98.
По нажатию Button2 используются процедуры GetDib SetDib и всё работает всегда.
Если
Points1: array[0..Pred(N1)] of TColor;
Points2: array[0..Pred(N2)] of TColor;
Bitmap1, Bitmap2: TBitmap;
сделать не полями, а просто переменными, то работает нормально и в Delphi5. С чем это связано, не знаю.
procedure GetDib(Bit:TBitmap; var P:PArrayColor; var BitInfo: TBitmapInfo);
var N:integer;
begin
reallocMem(P,0);
N:=Bit.Height*Bit.Width;
ReallocMem(P,SizeOf(P[0])*N);
FillChar(P^,SizeOf(P[0])*N,0);
FillChar(BitInfo,SizeOf(BitInfo),0);
BitInfo.bmiHeader.biSize:=sizeof(TBitmapInfoHeader);
BitInfo.bmiHeader.biWidth := Bit.Width;
BitInfo.bmiHeader.biHeight := Bit.Height;
BitInfo.bmiHeader.biPlanes := 1;
BitInfo.bmiHeader.biBitCount :=32;
GetDIBits(Bit.Canvas.Handle,Bit.Handle,0,Bit.Height,P,BitInfo,DIB_RGB_COLORS);
end;
procedure SetDib(Bit:TBitmap; var P:PArrayColor; var BitInfo: TBitmapInfo);
begin
try
if P<>nil then begin
Bit.Height:=BitInfo.bmiHeader.biHeight;
Bit.Width:=BitInfo.bmiHeader.biWidth;
SetDIBits(Bit.Canvas.Handle,Bit.Handle,0,Bit.Height,P,BitInfo,DIB_RGB_COLORS);
end;
finally
ReallocMem(P,0);
FillChar(BitInfo,SizeOf(BitInfo),0);
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
var i: Integer;
begin
Bitmap1 := TBitmap.Create;
with Bitmap1 do begin Width := W1; Height := H1 end;
FillChar(BitmapInfo1, SizeOf(BitmapInfo1), 0);
with BitmapInfo1, BitmapInfo1.bmiHeader do begin
biSize := SizeOf(bmiHeader);
biWidth := W1;
biHeight := H1;
biPlanes := 1;
biBitCount := 32;
biCompression := BI_RGB;
//biSizeImage := BytesPerScanLine(biWidth, biBitCount, 32) * Abs(biHeight);
end;
for i:=0 to Pred(N1) do Points1[i] := clGreen;
Bitmap2 := TBitmap.Create;
FillChar(BitmapInfo2, SizeOf(BitmapInfo2), 0);
with Bitmap2 do begin Width := W2; Height := H2 end;
with BitmapInfo2, BitmapInfo2.bmiHeader do begin
biSize := SizeOf(bmiHeader);
biWidth := W2;
biHeight := H2;
biPlanes := 1;
biBitCount := 32;
biCompression := BI_RGB;
//biSizeImage := BytesPerScanLine(biWidth, biBitCount, 32) * Abs(biHeight);
end;
for i:=0 to Pred(N2) do Points2[i] := clRed;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
Bitmap1.Free;
Bitmap2.Free;
end;
procedure TForm1.Button1Click(Sender: TObject);
var J, i1, i2: Integer;
begin
for J := 0 to 10000 do
begin
i1 := SetDiBits(Bitmap1.Canvas.Handle{GetDC(Handle)}, Bitmap1.Handle, 0, H1, @Points1[0], BitMapInfo1, DIB_RGB_COLORS);
i2 := SetDiBits(Bitmap2.Canvas.Handle{GetDC(Handle)}, Bitmap2.Handle, 0, H2, @Points2[0], BitMapInfo2, DIB_RGB_COLORS);
if (i1 <> H1) or (i2 <> H2) then
begin
MessageBox(0,PChar('Data1 = ' + IntToStr(i1) + ' Data2 = ' + IntToStr(i2)), nil, 0);
exit;
end;
Paint;
end;
Caption := 'Data1 = ' + IntToStr(i1) + ' Data2 = ' + IntToStr(i2);
end;
procedure TForm1.Button2Click(Sender: TObject);
var P1, P2: PArrayColor;
i, J: integer;
begin
P1 := nil;
P2 := nil;
for J := 0 to 10000 do
begin
GetDib(Bitmap1, P1, BitMapInfo1);
GetDib(Bitmap2, P2, BitMapInfo2);
if (P1=nil) or (P2=nil) then
begin
MessageBox(0,'Error', nil, 0);
exit;
end;
for i:=0 to Pred(N1) do P1[i] := clGreen;
for i:=0 to Pred(N2) do P2[i] := clRed;
Вот код моей маленькой тестовой программы целиком.
На панели два PaintBox'а и один Button, по нажатию на который в них должны кидаться Bitmap'ы.
Здесь негде ошибиться с областями памяти или чем-то еще.
type
TForm1 = class(TForm)
PaintBox1: TPaintBox;
PaintBox2: TPaintBox;
Button1: TButton;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure FormPaint(Sender: TObject);
private
public
// Dummmy: array[0..Pred(512*512)] of TColor;
Points1: array[0..Pred(N1)] of TColor;
Points2: array[0..Pred(N2)] of TColor;
Bitmap1, Bitmap2: TBitmap;
BitmapInfo1, BitmapInfo2: TBitmapInfo;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
var i: Integer;
begin
with PaintBox1 do begin Width := W1; Height := H1; Top := 0; Left := 0 end;
Bitmap1 := TBitmap.Create;
with Bitmap1 do begin Width := W1; Height := H1 end;
FillChar(BitmapInfo1, SizeOf(BitmapInfo1), 0);
with BitmapInfo1, bmiHeader do begin
biSize := SizeOf(bmiHeader);
biWidth := W1; biHeight := -H1;
biPlanes := 1; biBitCount := 32;
biCompression := BI_RGB;
biSizeImage := BytesPerScanLine(biWidth, biBitCount, 32) * Abs(biHeight);
end;
for i:=0 to Pred(N1) do Points1[i] := clGreen;
with PaintBox2 do begin Width := W2; Height := H2; Top := 0; Left := W1 end;
Bitmap2 := TBitmap.Create;
FillChar(BitmapInfo2, SizeOf(BitmapInfo2), 0);
with Bitmap2 do begin Width := W2; Height := H2 end;
with BitmapInfo2, bmiHeader do begin
biSize := SizeOf(bmiHeader);
biWidth := W2; biHeight := -H2;
biPlanes := 1; biBitCount := 32;
biCompression := BI_RGB;
biSizeImage := BytesPerScanLine(biWidth, biBitCount, 32) * Abs(biHeight);
end;
for i:=0 to Pred(N2) do Points2[i] := clRed;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
Bitmap1.Free;
Bitmap2.Free;
end;
Если раскоментировать строку с Dummmy, поставив тем самым "подушку", глюк исчезает в принципе.
Кстати, нашел еще одну машину, где глюк воспроизодится. Там стоит 7-й Дельфи и при компиляции под ним все тоже самое, т.е. дело не в версии Дельфей.
P.S. Все испробованные машины под Windows XP SP2.
Возможно, что ошибка проявляется где-то совсем в другом месте программы, и в какой-то момент времени Points начинает указывать на другую область памяти. Советую сделать совсем маленькую тестовую программу, где ни чего кроме копирования (в цыкле 10000 раз) не делается. И посмотреть что получится на разных машинах. Проверьте, как работают приведенные в примере процедуры. Кстати ECepBitError в примере надо заменить на Exception.
Если ни чего не помогает и необъяснимые глюки при работе в битмапами остаются, то я обычно советую посмотреть http://www.delphikingdom.com/asp/viewitem.asp?catalogid=1117 :o(
Уважаемый, Cepгей Poщин, спасибо за комментарий по поводу стиля. Замечу, что передача GetDC(Handle) взята из какого-то другого сайта по дельфийским проблемам, где яростно критиковалась именно передача Bit.Canvas.Handle в качестве device context. Разумеется, там запрос не был вставлен в строку, но я решил немного облегчить пост.
В любом случае, все это не имеет большого значения, т.к., во-первых, The device context identified by the hdc parameter is used only if the DIB_PAL_COLORS constant is set for the fuColorUse parameter; otherwise it is ignored, а во-вторых, вопрос был не о том, как сделать (это я и сам могу), а как избежать необъяснимых глюков. Ведь всё остальное я делаю более-менее так, как говорите Вы. И оно то работает, а то не работает. Кстати, передача нуля или Bit.Canvas.Handle ситуации, разумеется, не меняет.
Сразу бросается в глаза GetDC(Handle) используемый в качестве параметра! Откуда такой стиль? Т.е. контекст выделяется, но не освобождается, что приводит к утечкам памяти, потере ресурсов и прочим неприятностям. Вот пара процедур которые читают и записывают массив данных из/в битмап.
resourcestring
Errorpf32bit='Изображение должно иметь 32-битный формат';
...
procedure GetDib(Bit:TBitmap; var P:PArrayColor; var BitInfo: TBitmapInfo);
var N:integer;
begin
reallocMem(P,0);
if Bit.PixelFormat<>pf32Bit then raise ECepBitError.Create(Errorpf32bit);
N:=Bit.Height*Bit.Width;
ReallocMem(P,SizeOf(P[0])*N);
FillChar(P^,SizeOf(P[0])*N,0);
FillChar(BitInfo,SizeOf(BitInfo),0);
BitInfo.bmiHeader.biSize:=sizeof(TBitmapInfoHeader);
BitInfo.bmiHeader.biWidth := Bit.Width;
BitInfo.bmiHeader.biHeight := Bit.Height;
BitInfo.bmiHeader.biPlanes := 1;
BitInfo.bmiHeader.biBitCount :=32;
GetDIBits(Bit.Canvas.Handle,Bit.Handle,0,Bit.Height,P,BitInfo,DIB_RGB_COLORS);
end;
procedure SetDib(Bit:TBitmap; var P:PArrayColor; var BitInfo: TBitmapInfo);
begin
try
if P<>nil then begin
if Bit.PixelFormat<>pf32Bit then raise ECepBitError.Create(Errorpf32bit);
Bit.Height:=BitInfo.bmiHeader.biHeight;
Bit.Width:=BitInfo.bmiHeader.biWidth;
SetDIBits(Bit.Canvas.Handle,Bit.Handle,0,Bit.Height,P,BitInfo,DIB_RGB_COLORS);
end;
finally
ReallocMem(P,0);
FillChar(BitInfo,SizeOf(BitInfo),0);
end;
end;
Проверил. Во всех случаях (т.е. и с "подушкой", и без оной) тип bmDDB.
Ресурсов – выше крыши (картинки маленькие – типа 512x512, а памяти – 2 гига).
Зато я нашел уже вторую машины с тем же самым 6-м Дельфи, что и у меня (в смысле: с того же самого дистрибутива), на которых тот же код работает нормально и без всякой "подушки". Бред!
А вы уверены, что ваш Bitmap имеет формат DDB? Потому что он может иметь и DIB, а с DIB-растрами SetDiBits не работает. А практика показывает, что TBitmap обычно создаёт DDB, и только иногда, когда под DDB не хватает ресурсов, может создать DIB. Проверьте свойство HandleType.
Если вы заметили орфографическую ошибку на этой странице, просто выделите ошибку мышью и нажмите Ctrl+Enter. Функция может не работать в некоторых версиях броузеров.
