Форум: "Начинающим";
Текущий архив: 2016.07.24;
Скачать: [xml.tar.bz2];
Вниз
Помогите переделать проседуру рисования под WinApi(Delphi). Найти похожие ветки
← →
M.A. (2014-10-26 17:22) [0]Здравствуйте. Вопрос выше.
вот код VCL:unit ChervUnit;
interface
uses
Windows, Classes, Graphics, Controls, Forms, SysUtils,
ExtCtrls, BASS;
type
TChervForm = class(TForm)
TimerCherv: TTimer;
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure FormCreate(Sender: TObject);
procedure TimerChervTimer(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure ChervVis(HWND: THandle; ind : Integer);
private
{ Private declarations }
public
{ Public declarations }
end;
var
ChervForm: TChervForm;
VisBuffCherv{, NonePic} : TBitmap;
implementation
uses mp3, SpectrUnit, LevelUnit, PeremUnit{, MemUnit}, SetFom,
CircleForm;
{$R *.dfm}
procedure TChervForm.TimerChervTimer(Sender: TObject);
begin
ChervVis(ChervForm.Canvas.Handle, ChervForm.Tag);
end;
procedure TChervForm.ChervVis(HWND: THandle; ind : Integer);
var
i, YPos : Integer;
vCherv, ColChan : Integer;
BufCherv :array of Single;
ciCherv : BASS_CHANNELINFO;
begin
VisBuffCherv.Width := ClientWidth;
VisBuffCherv.Height := ClientHeight;
VisBuffCherv.Canvas.Pen.Color := clBlack;
VisBuffCherv.Canvas.Brush.Color := clBlack;
VisBuffCherv.Canvas.Rectangle(0, 0, VisBuffCherv.Width, VisBuffCherv.Height) ;// only if no background
if BASS_ChannelIsActive(Channel) <> BASS_ACTIVE_STOPPED then
begin
BASS_ChannelGetInfo(Channel, ciCherv); // get number of channels
if VisBuffCherv.Width <= 1920 then
vCherv := VisBuffCherv.Width
else
vCherv := 1920;
SetLength(BufCherv, Integer(ciCherv.chans) * (vCherv + 1));
BASS_ChannelGetData(Channel, BufCherv, (Integer(ciCherv.chans) * vCherv * SizeOf(Single)) or BASS_DATA_FLOAT);
VisBuffCherv.Canvas.Font.Color := clYellow;
case ind of
0: //ChervLineDraw
begin
for ColChan := 0 to ciCherv.chans - 1 do
begin
VisBuffCherv.Canvas.Pen.Color := Sqr((ColChan + 2) * 94); //$00009B00;
VisBuffCherv.Canvas.MoveTo(0, VisBuffCherv.Height div 2); //146
for i := 0 to vCherv do
begin
YPos := Trunc((1-BufCherv[i * Integer(ciCherv.chans) + ColChan]) * VisBuffCherv.Height / 2);
VisBuffCherv.Canvas.lineto(i, YPos);
end;
end;
end;
1: // ChervTSDraw
begin
for ColChan := 0 to ciCherv.chans - 1 do
begin
VisBuffCherv.Canvas.Pen.Color := Sqr((ColChan + 2) * 94); //$00009B00;
for i := 0 to vCherv do
begin
YPos := Trunc((1-BufCherv[i * integer(ciCherv.chans) + ColChan]) * VisBuffCherv.Height / 2);
VisBuffCherv.Canvas.MoveTo(i, VisBuffCherv.Height div 2);
VisBuffCherv.Canvas.lineto(i, YPos);
end;
end;
end;
2: //ChervPixelDraw
begin
for ColChan := 0 to ciCherv.chans - 1 do
for i := 0 to vCherv do
begin
YPos := Trunc((1-BufCherv[i * integer(ciCherv.chans) + ColChan]) * VisBuffCherv.Height / 2);
VisBuffCherv.Canvas.Pixels[i, YPos] := Sqr((ColChan + 2) * 94);
end;
end;
end;
end;
BitBlt(HWND, 0, 0, VisBuffCherv.Width, VisBuffCherv.Height, VisBuffCherv.Canvas.Handle, 0, 0, srccopy);
end;
procedure TChervForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
TimerCherv.Enabled := False;
Form_player.CBCherv.Checked := False;
end;
procedure TChervForm.FormCreate(Sender: TObject);
begin
VisBuffCherv := TBitmap.Create;
Color := clBlack;
if ChervForm.Tag > 2 then
ChervForm.Tag := 0;
if ChervForm.Tag < 0 then
ChervForm.Tag := 0;
end;
procedure TChervForm.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if Button = mbRight then
if ChervForm.Tag < 2 then
ChervForm.Tag := ChervForm.Tag + 1
else
ChervForm.Tag := 0;
if Button = mbMiddle then
if ChervForm.Tag > 0 then
ChervForm.Tag := ChervForm.Tag - 1
else
ChervForm.Tag := 2;
end;
procedure TChervForm.FormShow(Sender: TObject);
begin
TimerCherv.Enabled := True;
end;
end.
Меня интересует - procedure TChervForm.ChervVis(HWND: THandle; ind : Integer);
пПомогите пожалуйста переделать на Api, без испольльзования модуля Graphics.
Спасибо.
ИЛИ ХОТЯ БЫ ПРИВЕДИТЬ РАБОЧИЙ ПРИМЕР РИСОВАНИЯ ПО ТАЙМРУ примитивов (SetTimer).
← →
Kilkennycat © (2014-10-26 17:53) [1]Таймер ничего не рисует, он лишь генерирует событие.
Сформулируйте вопрос правильно.
← →
M.A. (2014-10-26 17:58) [2]Kilkennycat ©
ИЛИ ХОТЯ БЫ ПРИВЕДИТЬ РАБОЧИЙ ПРИМЕР Перерисовка окна ПО ТАЙМРУ примитивов (SetTimer).
← →
Kilkennycat © (2014-10-26 18:12) [3]еще хуже.
теперь требуется перерисовка окна, причем по таймеру примитивов. но у примитивов нет таймера, они, примитивы, в основном из пикселов.
но ладно, вот пример:...
Tmr: DWORD;
procedure WMTimer( var Msg: TWMTimer ); message WM_TIMER;
...
Tmr := 12345;
SetTimer( Handle, Tmr, 100, nil );
...
procedure TForm1.WMTimer(var Msg: TWMTimer); message WM_TIMER;
var
dc : HDC;
begin
if Msg.TimerID <> Tmr then
inherited
else begin
dc := GetDC(Handle);
MoveTo(dc, 0,0);
LineTo(dc, 10,10);
Msg.Result := 0;
end;
end;
← →
M.A. (2014-10-26 18:56) [4]Посмотрите, правильно так?(на Winapi)
Tmr: DWORD = 12345;
{$R *.res}
procedure WMTimer11{(var Msg: TWMTimer)}; stdcall;
var
dc : HDC;
rr : TRect;
nBrush : HBRUSH ;
begin
GetClientRect(Form, rr);
dc := GetDC(Form);
SelectObject(dc, nBrush);
FillRect(dc, rr, nBrush);
//Rectangle(DC, 5, {rr.Right - 5}20, 5, {rr.Bottom - 5}20);
Ellipse(dc, x - 2,y - 2,x + 2,y + 2);
end;
Function WinProc(Forma: hwnd; // Окно-получатель каждого входящего сообщения
Msg: {Cardinal} UINT; // Само сообщение
wparam: WParam; // Первый и второй уточняющие параметры сообщения
LParam: {Cardinal} LPARAM): lresult; Stdcall; // Оконная процедура, здесь мы задаем реакцию программы на все нужные нам сообщения
Var
//nFont : hFONT ;
nBrush : HBRUSH ;
//nPen : HPEN ;
Begin
Result := 0; // Чтобы в случае сбоя программы до последней строки функции Windows правильно определила ошибку
Case Msg Of
WM_SHOWWINDOW:
begin
nBrush:=CreateSolidBrush(RGB(250,200,100));
SetTimer(Form, Tmr, 40, @WMTimer11);
end;
WM_MOUSEMOVE:
begin
x:=LOWORD(lParam); //узнаём координаты
y:=HIWORD(lParam);
end;
WM_DESTROY:
begin
DeleteObject(nBrush);
PostQuitMessage(0);
end;
Else // Если пришедщее сообщение мы не определили:
Result := DefWindowProc(Forma, Msg, WParam, LParam); // Эта функция обрабатывает ВСЕ ОСТАЛЬНЫЕ сообщения по умолчанию
End; // Конец блока Case
End;
только не получается Rectangle нарисовать.
← →
M.A. (2014-10-26 19:09) [5]С Rectangle разобрался, кокординаты не правильно ввел.
← →
Kilkennycat © (2014-10-26 19:45) [6]
> Посмотрите, правильно так?(на Winapi)
не хочу смотреть, это не Вы делали, просто передрали откуда-то.
← →
M.A. (2014-10-26 20:04) [7]
> Kilkennycat © (26.10.14 19:45) [6]
> >не хочу смотреть,
> это не Вы делали, просто передрали откуда-то.
Частично ВЫ правы. Создание окна полностью списано.
Были игры с WM_PAINT, кистями, шрифтами.
Вот и ваш приведенный ранее код подогнал под себя. Не надо ругаться)))
← →
HighBrain (2014-10-29 10:41) [8]Костя, не забываем ReleaseDC ;-)
← →
Kilkennycat © (2014-10-29 11:29) [9]кстати да, постоянно забываю...
← →
M.A. (2014-11-01 22:46) [10]Есть кто живой?
Как убрать мерцание? Раньше рисовал в TBitmap. А как на API?
← →
Kilkennycat © (2014-11-02 02:07) [11]
> Есть кто живой?
да
> Как убрать мерцание?
рисовать в буфере, выводить через BitBlt, оптимизировать алгоритм, отказаться от векторных шрифтов, перерисовывать только перерисовываемое, использовать DirectX, OpenGL, GDI+, иные графические движки-библиотеки, прочитать http://www.delphimaster.ru/articles/pixels/index.html, правильно задавать вопросы.
> Раньше рисовал в TBitmap. А как на API?
может, лучше прочитать какие-нибудь статьи? Есть такая вещь - поисковик. он может найти что-то типа http://www.programmersclub.ru/panic-button-winapi-%D0%B3%D1%80%D0%B0%D1%84%D0%B8%D0%BA%D0%B0/
← →
M.A. (2014-11-02 14:51) [12]Какжется зашевелилось.
var
SpecDC, DC : HDC;
BufferBitmap : HBITMAP;
WM_SHOWWINDOW:
begin
dc := GetDC(SpectrForm);
SpecDC := CreateCompatibleDC(dc);
BufferBitmap := CreateCompatibleBitmap (DC, 250, 130);
SetTimer(SpectrForm, Tmr, 40, @WMTimer11);
end;
procedure WMTimer11; stdcall;
begin
GetClientRect(SpectrForm, rr);
dc := GetDC(SpectrForm);
SelectObject(SpecDC, BufferBitmap);
BitBlt(dc, 0, 0, rr.Right, rr.Bottom, SpecDC, 0, 0, srccopy);
end;
Только незнаю как поменять размеры созданного BufferBitmap, при развертывание окна.
Подскажите пожалуйста.
← →
M.A. (2014-11-02 14:56) [13]Забыл:
Var
rr : TRect;
.....
← →
M.A. (2014-11-02 18:19) [14]Сделал так.
Создаю bitmap(с размерами клиентской облости) в таймере, рисую, вывожу, удаляю bitmap.
Или можно по другому?
← →
Kilkennycat © (2014-11-02 20:35) [15]
> dc := GetDC(SpectrForm);
мне выше напомнили о необходимости освобождения dc.
а в основном правильно. вот только постоянное создание-удаление не всегда необходимо. вполне допустимо создать битмап, dc в начале программы, в конце - удалить, а при изменении размеров клиентской области просто отловить это событие и внести там изменения.
← →
brother © (2014-11-02 20:46) [16]> а при изменении размеров клиентской области просто отловить
> это событие и внести там изменения
у автора именно в этом проблемма)
← →
M.A. (2014-11-02 21:36) [17]Kilkennycat © (02.11.14 20:35) [15]
> а в основном правильно. вот только постоянное создание-удаление
> не всегда необходимо. вполне допустимо создать битмап, dc
> в начале программы, в конце - удалить, а при изменении размеров
> клиентской области просто отловить это событие и внести
> там изменения.
Согласен, в wm_size нужно делать. Повторюсь: можно как-то по другому изменять размеры HBitMap не удаляя и создовая его?
← →
Kilkennycat © (2014-11-03 02:45) [18]http://rutracker.org/forum/viewtopic.php?t=215635 - рекомендую прочитать. Потому что "изменить размеры HBitMap" звучит страшно, понятно, конечно, что хочется сделать, но изменить размер хэндла... страшно.
что именно требуется-то? фон окна перерисовать?
> brother © (02.11.14 20:46) [16]
> у автора именно в этом проблемма)
ну, я имел ввиду другие изменения :) удаление и создание
← →
M.A. (2014-11-03 16:32) [19]
> Kilkennycat © (03.11.14 02:45) [18]
> что именно требуется-то? фон окна перерисовать?
Требовалось переписать код, который в самом начале темы. Переделал, работает(на сколько правильно переписал--черт его знает). Не хочу позориться)))), а то б , выложил для проверки.
Да, и еще, при развертывание окна, процесс начинает грузить CPU на 10-20%. В VCL при тех же условиях 3-6%. Не пойму в чем дело. Хоте переписал другую рисовалку для этого же проекта, там загрузка проца как и в VCL.
← →
DQ (2014-11-07 13:12) [20]> Повторюсь: можно как-то по другому изменять размеры HBitMap не удаляя и создовая его?
Нет.
Во-первых это тип данных, оно пишется так: HBITMAP =)
Во вторых это идентификатор, если оочень грубо говоря - указатель (или может id) на опции+изображение в памяти.
Если было создано bmp 256x64x32 - то это уже не поменять. Можно только передавать HBITMAP функциям всяким - нарисовать, присоединить, удалить.
З.Ы. Пришли мне, поколдую, пообъясняю, правда на работе аврал жуткий, как будет время.. domikdomikdomik@mail.ru
← →
Kilkennycat © (2014-11-08 19:42) [21]
> указатель (или может id) на опции+изображение в памяти
это указатель на структуру.
> Если было создано bmp 256x64x32 - то это уже не поменять.
>
вообще-то можно, но затратно.
← →
DQ (2014-11-10 01:12) [22]гм... Это что конкретно вы подразумеваете?
Страницы: 1 вся ветка
Форум: "Начинающим";
Текущий архив: 2016.07.24;
Скачать: [xml.tar.bz2];
Память: 0.52 MB
Время: 0.006 c
