» Вопросы по Delphi (до версии 2009) - часть 5

Нужен некий контейнер для массива чисел с возможностью вычитания.
Т.е. имеем массив, к примеру, из таких значений: 1,2,3,4,5
Второй массив будет 3, 4, 5, 6, 7
Путем вычитания второго массива из первого, получим 1,2.

Может есть уже какой-нибуть готовый класс-контейнер в Delphi или JCL или самому писать?

Maks150988
Я склонен верить документации:
Цитата:

The CreateDIBSection function creates a device-independent bitmap (DIB)

Тем более, что это подтверждается практикой.

Вот вы пишете biBitCount := 32, а сколько будет SizeOf(TRGBTriple)*8? Не зря в Windows.pas рядышком объявлена структура TRGBQuad С ее помощью можно спокойно объявить двумерный массив, как вы и пытались в начале.

P.S. Кстати сейчас наткнулся на функцию StretchDIBits. Использовать ее может быть довольно удобно, но она все же немного проигрывает в скорости StretchBlt.

Frodo_Torbins
А, ну это тепрь понятно. Сделал так:


Код: var
lpBits: Array [0..MAX_HEIGTH-1, 0..MAX_WIDTH-1] of TRGBQuad;

procedure SetMemDCPixel(X, Y: Integer);
begin
lpBits[Y, X].rgbBlue := 0;
lpBits[Y, X].rgbGreen := 0;
lpBits[Y, X].rgbRed := 0;
lpBits[Y, X].rgbReserved := 0;
end;

begin

with bmi.bmiHeader do
begin
biSize := SizeOf(bmi.bmiHeader);
biWidth := MAX_WIDTH;
biHeight := -MAX_HEIGTH;
biPlanes := 1;
biBitCount := 32;
biCompression := BI_RGB;
end;

GetDIBits(pcp.hdcMem, pcp.hbmMem, 0, MAX_HEIGTH, @lpBits, bmi, DIB_RGB_COLORS);

SetMemDCPixel(0, 0);

SetDIBits(pcp.hdcMem, pcp.hbmMem, 0, MAX_HEIGTH, @lpBits, bmi, DIB_RGB_COLORS);

end;

Maks150988
А без GetDIBits/SetDIBits у вас не получается? У меня все прекрасно и без них рисует.

Frodo_Torbins
Так мне надо подготовленный MemoryDC перерисовывать каждый раз. Через GetDIBits получаю текущую область памяти егошнего HBITMAP со своим содержимым, куда я должен заного отрисовать сетку поточечно.

А кстати я бы хотел уточнить одну деталь. Почему если сделать динамический массив и подизменить процедуру так, сетка не рисуется вообще.


Код: //
type
type
TBits = Array of Array of TRGBQuad;
var
lpBits: TBits;
//
procedure SetMemDCPixel(bits: TBits; X, Y: Integer);
begin
bits[Y, X].rgbBlue := 0;
bits[Y, X].rgbGreen := 0;
bits[Y, X].rgbRed := 0;
bits[Y, X].rgbReserved := 0;
end;
//
SetLength(lpBits, MAX_HEIGTH, MAX_WIDTH);
GetDIBits(pcp.hdcMem, pcp.hbmMem, 0, MAX_HEIGTH, @lpBits, bmi, DIB_RGB_COLORS);
SetMemDCPixel(lpBits, 0, 0);
//

Maks150988
Хм, я сразу после создания битмапа подключаю его к контексту. После этого в любой момент получить изображение с битмапа можно обращаясь к этому DC. Получается так:
Код: [no] bmpDC := CreateCompatibleDC(0);
bmpHandle := CreateDIBSection(bmpDC, bmi, DIB_RGB_COLORS, Pointer(bmpBits), 0, 0);
oldBmp:=SelectObject(bmpDC, bmpHandle);

bmpBits^[25, 1].rgbGreen:=255;[/no]

Frodo_Torbins


Код: GetDIBits(pcp.hdcMem, pcp.hbmMem, 0, MAX_HEIGTH, @lpBits[0, 0], bmi, DIB_RGB_COLORS);

Maks150988
Вроде так. Работает?

Frodo_Torbins
Нет, не работает, Runtime Error возникает.

Короче я тут выкинул из кода лишнее, оставил только код отрисовки сетки.
Ссылка

Maks150988
Да, точно. Двумерный динамический массив это по сути одномерный динамический массив с указателями на одномерные дин. массивы. Причем эти массивы не обязаны лежать в памяти вместе, а могут быть разбросаны по оперативке как угодно. Т. о. в данном случае мы можем использовать только один большой одномерный дин. массив.
И кстати память под такие массивы выделяет менеджер памяти делфи, а вы, я вижу, пытаетесь использовать исключительно системный.

И кстати рисовать черным по черному, это оригинально Остальные замечания в [more=коде.]
Код: [no]unit F_StatCtrlDib;

interface

uses
Windows, Messages, F_Windows;

procedure CreateVisualStatic(hWnd: HWND);
procedure RemoveVisualStatic(hWnd: HWND);

implementation

const

ID_TIMER = 101;

MAX_WIDTH = 89;
MAX_HEIGTH = 29;

type
TCtrlWndProc = function(hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;

TbmpBits = Array[1..MAX_HEIGTH, 1..MAX_WIDTH] of TRGBQuad;
PbmpBits = ^TbmpBits;

P_CTRL_PRO = ^T_CTRL_PRO;
T_CTRL_PRO = packed record
CtrlProc: TCtrlWndProc;
//
hdcMem : HDC;
hbmMem : HBITMAP;
hbmOld : HBITMAP;
bmBits : PbmpBits; //Указатель на пиксели тоже храним
end;

var

pcp: P_CTRL_PRO;

//

procedure DrawGridLines(pcp: P_CTRL_PRO);
type
TBits = Array of TRGBQuad;
var
lpBits: TBits;
bmi : TBitmapInfo;
pixel : Integer;

procedure SetMemDCPixel(bits: TBits; X, Y: Integer);
begin
bits[Y*MAX_WIDTH+ X].rgbBlue := 0;
bits[Y*MAX_WIDTH+ X].rgbGreen := 255;
bits[Y*MAX_WIDTH+ X].rgbRed := 0;
bits[Y*MAX_WIDTH+ X].rgbReserved := 0;
end;

begin

//
{
with bmi.bmiHeader do
begin
biSize := SizeOf(bmi.bmiHeader);
biWidth := MAX_WIDTH;
biHeight := -MAX_HEIGTH;
biPlanes := 1;
biBitCount := 32;
biCompression := BI_RGB;
end;

SetLength(lpBits, MAX_HEIGTH * MAX_WIDTH);

GetDIBits(pcp.hdcMem, pcp.hbmMem, 0, MAX_HEIGTH, @lpBits[0], bmi, DIB_RGB_COLORS);

// left.

SetMemDCPixel(lpBits, 0, 0);
SetMemDCPixel(lpBits, 1, 0);
SetMemDCPixel(lpBits, 1, 10);
SetMemDCPixel(lpBits, 0, 12);
SetMemDCPixel(lpBits, 1, 12);
SetMemDCPixel(lpBits, 1, 14);
SetMemDCPixel(lpBits, 0, 24);
SetMemDCPixel(lpBits, 1, 24);

for pixel := 0 to (MAX_HEIGTH - 3) do
if not Odd(pixel) then
SetMemDCPixel(lpBits, 2, pixel);

// right.

for pixel := 0 to (MAX_HEIGTH - 3) do
if not Odd(pixel) then
SetMemDCPixel(lpBits, MAX_WIDTH - 3, pixel);

SetMemDCPixel(lpBits, MAX_WIDTH - 1, 0);
SetMemDCPixel(lpBits, MAX_WIDTH - 2, 0);
SetMemDCPixel(lpBits, MAX_WIDTH - 2, 10);
SetMemDCPixel(lpBits, MAX_WIDTH - 1, 12);
SetMemDCPixel(lpBits, MAX_WIDTH - 2, 12);
SetMemDCPixel(lpBits, MAX_WIDTH - 2, 14);
SetMemDCPixel(lpBits, MAX_WIDTH - 1, 24);
SetMemDCPixel(lpBits, MAX_WIDTH - 2, 24);

// bottom.

for pixel := 2 to (MAX_WIDTH - 3) do
if not Odd(pixel) then
SetMemDCPixel(lpBits, pixel, MAX_HEIGTH - 3);

SetMemDCPixel(lpBits, 10, MAX_HEIGTH - 2);
SetMemDCPixel(lpBits, 10, MAX_HEIGTH - 1);
SetMemDCPixel(lpBits, 18, MAX_HEIGTH - 2);
SetMemDCPixel(lpBits, 26, MAX_HEIGTH - 2);
SetMemDCPixel(lpBits, 34, MAX_HEIGTH - 2);
SetMemDCPixel(lpBits, 44, MAX_HEIGTH - 2);
SetMemDCPixel(lpBits, 44, MAX_HEIGTH - 1);
SetMemDCPixel(lpBits, 54, MAX_HEIGTH - 2);
SetMemDCPixel(lpBits, 62, MAX_HEIGTH - 2);
SetMemDCPixel(lpBits, 70, MAX_HEIGTH - 2);
SetMemDCPixel(lpBits, 78, MAX_HEIGTH - 2);
SetMemDCPixel(lpBits, 78, MAX_HEIGTH - 1);

//

SetDIBits(pcp.hdcMem, pcp.hbmMem, 0, MAX_HEIGTH, @lpBits[0], bmi, DIB_RGB_COLORS);
}
pcp.bmBits^[2, 2].rgbGreen:=255;
pcp.bmBits^[6, 2].rgbGreen:=255;
pcp.bmBits^[7, 6].rgbGreen:=255;
pcp.bmBits^[6, 7].rgbGreen:=255;
pcp.bmBits^[5, 7].rgbGreen:=255;
pcp.bmBits^[4, 7].rgbGreen:=255;
pcp.bmBits^[3, 7].rgbGreen:=255;
pcp.bmBits^[2, 7].rgbGreen:=255;
pcp.bmBits^[1, 6].rgbGreen:=255;
end;


//

function CtrlWndProc_WmPaint(pcp: P_CTRL_PRO; hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
var
ps: TPaintStruct;
begin

//

BeginPaint(hWnd, ps);

//

StretchBlt(ps.hdc, ps.rcPaint.Left, ps.rcPaint.Top, ps.rcPaint.Right, ps.rcPaint.Bottom,
pcp.hdcMem, 0, 0, MAX_WIDTH, MAX_HEIGTH, SRCCOPY); //DPI Aware

//

EndPaint(hWnd, ps);

//

Result := 0;

end;

//

function CtrlWndProc_WmTimer(pcp: P_CTRL_PRO; hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT;
var
dwStyle: DWORD;
begin

//
//Зачем тут это?
// CallWindowProcW(@pcp.CtrlProc, hWnd, WM_PRINTCLIENT, pcp.hdcMem, PRF_CLIENT);

//
//Достаточно вызвать один раз, после создания битмапа т к содержимое все равно не меняется
DrawGridLines(pcp);

//

dwStyle := RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE;
RedrawWindow(hWnd, nil, 0, dwStyle);

//

Result := 0;

end;

//

function CtrlWndProc_WmEraseBkgnd(pcp: P_CTRL_PRO; hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT;
begin

//

Result := 1;

end;

//

function StatWndProc(hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
begin

pcp := P_CTRL_PRO(GetWindowLongW(hWnd, GWL_USERDATA));

if (pcp = nil) then
begin
Result := DefWindowProcW(hWnd, uMsg, wParam, lParam);
Exit;
end;

case uMsg of

//

WM_DESTROY:
begin
RemoveVisualStatic(hWnd);
end;

//

WM_PRINTCLIENT,
WM_PAINT,
WM_UPDATEUISTATE:
begin
Result := CtrlWndProc_WmPaint(pcp, hWnd, uMsg, wParam, lParam);
end;

//

WM_TIMER:
begin
Result := CtrlWndProc_WmTimer(pcp, hWnd, uMsg, wParam, lParam);
end;

//

WM_ERASEBKGND:
begin
Result := CtrlWndProc_WmEraseBkgnd(pcp, hWnd, uMsg, wParam, lParam);
end;

else
Result := CallWindowProcW(@pcp.CtrlProc, hWnd, uMsg, wParam, lParam);
end;

end;

//

procedure CreateVisualStatic(hWnd: HWND);
var
hdcIn : HDC;
dwStyle: DWORD;
bmi : TBitmapInfo;
begin

RemoveVisualStatic(hWnd);

pcp := P_CTRL_PRO(HeapAlloc(GetProcessHeap, HEAP_ZERO_MEMORY, SizeOf(T_CTRL_PRO)));
ZeroMemory(pcp, SizeOf(T_CTRL_PRO));

pcp.CtrlProc := TCtrlWndProc(Pointer(GetWindowLongW(hWnd, GWL_WNDPROC)));

with bmi.bmiHeader do
begin
biSize := SizeOf(bmi.bmiHeader);
biWidth := MAX_WIDTH;
biHeight := -MAX_HEIGTH; //Изменили порядок строк
biPlanes := 1;
biBitCount := 32;
biCompression := BI_RGB;
end;

hdcIn := GetDC(hWnd);

pcp.hdcMem := CreateCompatibleDC(hdcIn); //Указатель нам еще понадобится при рисовании
pcp.hbmMem := CreateDIBSection(hdcIn, bmi, DIB_RGB_COLORS, Pointer(pcp.bmBits), 0, 0);
pcp.hbmOld := SelectObject(pcp.hdcMem, pcp.hbmMem);

ReleaseDC(hWnd, hdcIn);

dwStyle := SWP_NOMOVE or SWP_NOZORDER;
dwStyle := SWP_NOSIZE or dwStyle; //DPI Aware
SetWindowPos(hWnd, HWND_TOP, 0, 0, MAX_WIDTH, MAX_HEIGTH, dwStyle);

SetWindowLongW(hWnd, GWL_USERDATA, Longint(pcp));

SetWindowLongW(hWnd, GWL_WNDPROC, Longint(@StatWndProc));

SendmessageW(hWnd, WM_TIMER, 0, 0);

SetTimer(hWnd, ID_TIMER, 25, nil);

end;

//

procedure RemoveVisualStatic(hWnd: HWND);
var
dwStyle: DWORD;
begin

pcp := P_CTRL_PRO(GetWindowLongW(hWnd, GWL_USERDATA));
if (pcp <> nil) then
begin

//

if (pcp.hdcMem <> 0) then
begin
SelectObject(pcp.hdcMem, pcp.hbmOld);
DeleteObject(pcp.hbmMem);
DeleteDC(pcp.hdcMem);
end;

//

KillTimer(hWnd, ID_TIMER);

//

SetWindowLongW(hWnd, GWL_WNDPROC, Longint(@pcp.CtrlProc));

//

SetWindowLongW(hWnd, GWL_USERDATA, 0);
HeapFree(GetProcessHeap, 0, pcp);

//

dwStyle := RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE;
RedrawWindow(hWnd, nil, 0, dwStyle);

end;

end;

end.[/no]

Frodo_Torbins
Спасибо за исправления.

По поводу замечаний:
1) В WM_PRINTCLIENT я зачищаю буфер кистью, которая идет у контрола по умолчанию, поэтому я могу сразу WM_COLORSTATIC в родителе использовать для закраски фона контрола. По умолчанию контрол должен вести себя как STATIC.
2) Рисую сетку черным потому что если рисовать на дефолтовом фоне контрола другим цветом оно еле заметно будет или расплываться + вдальнейшем можно конечно же добавить надстройку для смены цветов.
3) Наверное лучше не использовать при отрисовке координаты от ps.rcPaint, ведь ежели закрыть часть контрола другим окно будет смещение позиции блиттинга.

Maks150988
Ну, вам виднее, как оно у вас там будет взаимодействовать. По поводу ps.rcPaint согласен, просто вчера вечером было лень придумывать лучшее решение. По хорошему там вообще надо не StretchBlt делать, а размер самого битмапа менять и его отрисовку настраивать.

Подскажите, как сделать свое окно полностью прозрачным для курсора мыши? Те чтобы все события мыши шли к нижележащему окну? Нижележащие окна могут принадлежать другим приложениям, так что обработака WM_NCHITTEST с HTTRANSPARENT не помогает...

0D0A
Навскидку, SetWindowLong со стилем WS_EX_TRANSPARENT, если это то что вам нужно.

Спасибо. Методом тыка получилось с WS_EX_TRANSPARENT or WS_EX_LAYERED и ненулевое SetLayeredWindowAttributes. Одно WS_EX_TRANSPARENT не помогает. В MSDN ни слова про мышь.

TechnoDreamer, set of byte?

У кого соображалка хорошо работает, помогите мне с зеркалированием части изображения с контекста.

Ссылка

Вобщем-то в модуле F_StatBeat.pas в строчке 126 необходимо координаты правильно выставить для StretchBlt. Я что-то не пойму, вроде все правильно делаю, а оно мне половину картинки растягивает, а не блиттит. Правая часть собственно простецки через BitBlt выводится как и нужно.

Maks150988
Может отдельную тему создать (например, Рисование на Дельфи при помощи API функций) - все таки рисование на Дельфи при помощи АПИ функций достаточно интересная тема и если все будет вместе - то другим будет проще потом использовать.

Maks150988

Цитата:

Вобщем-то в модуле F_StatBeat.pas в строчке 126 необходимо координаты правильно выставить для StretchBlt.

Вот что у меня получилось

Код:
StretchBlt(pcp.hdcMem, pcp.biHalf-1, 0, -pcp.LeftPos, pcp.biHeight, hdcMem, pcp.biHalf, 0, pcp.LeftPos, pcp.biHeight, SRCCOPY);

ShIvADeSt
Не знаю, как по мне, то неплохо было бы если бы была такая тема, где выкладывались демо-примеры, чтобы каждый желающий смог посмотреть реализации.
V1s1ter
Спасибо.

Кто нибудь делал парсер для svg формата. Будь добры скиньте.

SIgor33
В библиотеке AggPas кое что есть: http://www.crossgl.com/aggpas/aggpas-svg.htm

Maks150988

Цитата:

Не знаю, как по мне, то неплохо было бы если бы была такая тема, где выкладывались демо-примеры, чтобы каждый желающий смог посмотреть реализации.

Организуй такую тему

Здравствуйте, уважаемые. Тут возник вопрос такого плана:
Использую FastReport для вывода на печать таблицы (cxGrid) в Form1. На Form2 есть другая таблица (StringGrid), в нее производится загрузка данных из excel-файл.
Все отрабатывает за исключением одного момента.
Если я загрузку данных в StringGrid не произвожу, то печатная форма (FastReport) выводится отлично. Если же производил загрузку - то при попытке вывести на печать данные с cxGrid на Form1 - получаю диалог печати с отсутствующим листом с данными - который должен выводиться на печать. Приходится перезапускать программу. Может кто сталкивался, в каком направлении искать ошибку? Спасибо.

egerLESHIK
Одно из направлений - проверить ошибки доступа к памяти. Может вы в коде работы со стринггридом затираете чего чужого.

Походу этот баг наблюдается еще до импорта данных в таблицу StringGrid.
Она возникает когда я уже выбрал файл для импорта:
Код процедуры выбора файла ниже:

[more=Код]
Код: procedure TForm2.Button2Click(Sender: TObject);
var
openDialog : TOpenDialog; // Переменная OpenDialog
begin
// Создание объекта OpenDialog - назначение на нашу переменную OpenDialog
openDialog := TOpenDialog.Create(self);

// Установка начального каталога, чтобы сделать его текущим
openDialog.InitialDir := GetCurrentDir;

// Только разрешенные существующие файлы могут быть выбраны
openDialog.Options := [ofFileMustExist];

// Разрешено выбрать только .xls файлы
openDialog.Filter := 'Excel files|*.xls';

// Выбор файлов Паскаля как стартовый тип фильтра
openDialog.FilterIndex := 2;

// Показ диалог открытия файла
if openDialog.Execute then
begin
Form2.Edit1.Text:=openDialog.FileName;
ShowMessage('File : '+openDialog.FileName)
end
else ShowMessage('Открытие файла остановлено');

// Освобождение диалога
openDialog.Free;
end;

egerLESHIK

попробуте положить TOpenDialog на форму а не создавать динамически...так же попробуйте оставить Button2Click пустым(тело процедуры)...а потом открыть отчет...может вовсе и не в этом куске дело...так же гляньте что в OnShow OnCreate onClose в Form2

mdid

Событий OnShow OnCreate onClosе нет на Form2 Попробовал просто вбить путь к файлу через процедуру загрузки в StringGrid - данные загрузились, потом закрыл Form2 и попробовал вывести печатную форму на Form1 из cxGrid код отработал - форма создалась без проблем.

Положил компоненту Opendialog на Form2 переписал код чтобы открывало через нее результаты такие:
- открываю диалог, не выбираю файл, закрываю Form2, формирую печатную форму для cxGrid - все работает;
- открываю диалог, выбираю файл, закрываю Form2, формирую печатную форму для cxGrid(загрузку в StringGrid не производил) - не работает;

Пишу сервер на Delphi, использую компонент TServerSocket
приложение клиент мне отправляет данные как мне в обработчике события OnClientRead обработать данные побайтово? в первом байте у меня находится команда к серверу и мне надо этот байт прочитать. И в зависимости от того что в нем читать определенным образом оставшиеся данные.
Помогите пожалуйста.

Камрады, помогите разобраться.

Решил при сохранении данных в БД показывать заставку-сплэш в основном потоке, а сами данные сохранять в треде (Thread). Вот беда: "не видятся" из треда датасеты да транзакции

[more=код]
Цитата:

//запускаем карусель
procedure TForm1.Button1Click(Sender: TObject);
var MyThrd: TestThrd;
begin
EndProcFlag:= False;//уберем флаг окончания доп.процесса

MyThrd:= TestThrd.Create(True);
try
MyThrd.FreeOnTerminate:= True;
MyThrd.Resume;

while not EndProcFlag do
begin
Beep;//вместо кода отрисовки заставки-сплэша
Sleep(500);
end;
finally
// MyThrd.Free;
end;
end;

{ TestThrd }
procedure TestThrd.Execute;
begin
inherited;

if not TransWrite.Active then TransWrite.StartTransaction;//вот тут уже компилятор ругается
// Undeclared identifier: 'TransWrite'
try
DSet.Insert;
DSet.FieldByName('INTEG_FLD').Value:= 2;
DSet.FieldByName('VRCHR_10_FLD').Value:= 'qwerty';
DSet.Post;
TransWrite.Commit;
except
DSet.Cancel;
TransWrite.Rollback;
end;

EndProcFlag:= True;//выставим флаг окончания работы доп.процесса
end;

[/more]
Как быть, чего и куда дописать?