Как
рисовать прямо на экране? |
Прислал Nick
Slepchenko 29 января 1999 г Например так: ........................................................
procedure DrawOnScreen;
var
DC : HDC;
DesktopCanvas : TCanvas;
begin
DC := GetDC(0); // получили DC экрана
try
DesktopCanvas := TCanvas.Create;
DesktopCanvas.Handle := DC;
..................
// здесь рисуем на Canvas экрана
..................
finally
ReleaseDC(0, DC);
DesktopCanvas.Free;
end;
end;
........................................................
|
Как
скопировать экран (или его часть) в TBitmap? |
Serg Lukashov
4 января 1999 г serg@tnd.belpak.gomel.by Например,
с помощью WinAPI так: var
Bmp : TBitmap;
DC : HDC;
begin
Bmp := TBitmap.Create;
Bmp.Height := Screen.Height;
Bmp.Width := Screen.Width;
DC := GetDC(0); //Дескpиптоp экpана
BitBlt(Bmp.Canvas.Handle, 0, 0, Screen.Width, Screen.Height,
DC, 0, 0, SRCCOPY);
Bmp.SaveToFile('Screen.bmp');
ReleaseDC(0, DC);
end;
Или с помощью обертки TCanvas - Объект
Screen[Width, Height] - размеры var
Desktop : TCanvas ;
BitMap : TBitMap;
begin
DesktopCanvas := TCanvas.Create;
DesktopCanvas.Handle := GetDC(HWND_DESKTOP);
BitMap := TBitMap.Create;
BitMap.Width := Screen.Width;
BitMap.Height := Screen.Height;
Bitmap.Canvas.CopyRect(Bitmap.Canvas.ClipRect,
DesktopCanvas, DesktopCanvas.ClipRect);
........
end;
|
Как я могу
использовать анимированный курсор? |
Borland FAQ N696
(переведен Акжаном Абдулиным) 4 января 1999 г Сперва
Вы должны взять Handle курсора Windows и присвоить его одному из элементов
массива Cursors обьекта Screen. Предопределенные курсоры имеют
отрицательный индекс, а определенные пользователем (Вами) курсоры получают
положительные индексы. Ниже пример формы, использующей анимированный
курсор: procedure TForm1.Button1Click(Sender : TObject);
var
H : THandle;
begin
H := LoadImage(0,
'C:\TheWall\Magic.ani',
IMAGE_CURSOR,
0,
0,
LR_DEFAULTSIZE or
LR_LOADFROMFILE
);
if H = 0 then ShowMessage('Cursor not loaded')
else
begin
Screen.Cursors[1] := H;
Form1.Cursor := 1;
end;
end;
|
Как вывести
на Canvas надпись под углом? |
Nikita Popov 3
января 1999 г nix@tekton.dol.ru Вот,
взгляните на пример:
...
function CreateRotatedFont(F : TFont; Angle : Integer) : hFont;
{-create a rotated font based on the font object F}
var
LF : TLogFont;
begin
FillChar(LF, SizeOf(LF), #0);
with LF do
begin
lfHeight := F.Height;
lfWidth := 0;
lfEscapement := Angle * 10;
lfOrientation := 0;
if fsBold in F.Style then
lfWeight := FW_BOLD
else
lfWeight := FW_NORMAL;
lfItalic := Byte(fsItalic in F.Style);
lfUnderline := Byte(fsUnderline in F.Style);
lfStrikeOut := Byte(fsStrikeOut in F.Style);
lfCharSet := DEFAULT_CHARSET;
StrPCopy(lfFaceName, F.Name);
lfQuality := DEFAULT_QUALITY;
{everything else as default}
lfOutPrecision := OUT_DEFAULT_PRECIS;
lfClipPrecision := CLIP_DEFAULT_PRECIS;
case F.Pitch of
fpVariable : lfPitchAndFamily := VARIABLE_PITCH;
fpFixed : lfPitchAndFamily := FIXED_PITCH;
else
lfPitchAndFamily := DEFAULT_PITCH;
end;
end;
Result := CreateFontIndirect(LF);
end;
...
{create the rotated font}
if FontAngle <> 0 then
Canvas.Font.Handle := CreateRotatedFont(Font,FontAngle);
...
Вращаются только векторные шрифты.
|
Как
проиграть звуковой файл в приложении? |
Ivanuts
Vasiliy 2 января 1999 г ivanuts@altavista.net Чтобы
выполнить звук в Вашем приложении, необходимо воспользоваться функцией API
PlaySound. При этом Вы можете вызывать и проигрывать как
предопределенные системные звуки, так и собственные (записанные в файлах
или расположенные в определенных ячейках памяти). Проигрывая звуки, Вы
можете также определить поведение Вашего приложения путем определения
способа проигрывания звука - Синхронно, Асинхронно;
что определяет будет ли выполнение Вашего приложения остановленно или нет
на период воспроизведения звука.
- PlaySound(
- pszSound : Variant, // Или имя файла, или
адрес памяти, или константа системного события
- hmod : THandle, // Дескриптор источника
звука (должен быть 0, если fdwSound <> SND_RESOURCE
- fdwSound : Word // Опция способа
воспроизведения звука
- )
Определение флага способа проигрывания звука:
SND_APPLICATION Выполнение звука,
используя специальные программы, асоциированные с файлами звуков.
SND_ALIAS Использование в качестве
параметра, переменной события системы из системного реестра или WIN.INI
файла. Не используйте с SND_FILENAME или SND_RESOURCE.
SND_ALIAS_ID Предопределенный
звуковой идентификатор.
SND_ASYNC Запуск звука в
асинхронном режиме. Для завершения проигрывания асинхронно запущенного
звука, вызовите PlaySound с набором pszSound равному 0.
SND_FILENAME Параметр pszSound
должен иметь имя файла.
SND_LOOP Неоднократное выполнение
звука до вызова PlaySound с набором параметров pszSound равному 0. Вы
должны также определить флаг SND_ASYNC, чтобы указать асинхронное
выполнение звука.
SND_MEMORY Файл звуков события
загружен в RAM. Параметр, определенный pszSound должен указать на источник
звука в памяти.
SND_NODEFAULT По умолчанию никакое
заданное звуковое событие не используется.
SND_NOSTOP Определенное звуковое
событие переходит к следующему звуковому событию, которое уже выполняется.
Если звук нельзя выполнить, потому что ресурс занят, функция немедленно
возвращает FALSE. Если этот флаг не определен, PlaySound попытается
останавить исполняемый в настоящее время звук так, чтобы приложение могло
использовать новый звук.
SND_NOWAIT Если драйвер занят,
функция немедленно прекратит свою работу.
SND_PURGE Звук может быть
приостановлен до последующего вызова. Если pszSound не 0, все определенные
в функции звуки приостанавливаются. Вы должны также определить
дескриптор звука, чтобы приостановить события, назначенные SND_RESOURCE.
SND_RESOURCE Параметр pszSound
должен содержать идентификатор ресурса; hmod должен идентифицировать
источник, который содержит ресурс.
SND_SYNC Синхронное
воспроизведение звукового события. PlaySound заканчивает свое действие
сразу после завершения события.
|
Как
вывести графику на принтер? |
Dmitry
Kiselev 24 декабря 1998 г kiselevd@glight.bmstu.ru
Функция Printer.Canvas.StretchDraw(Rect,Bitmap) не всегда
правильно выводит в печать графику. По этому я предлагаю свой модуль с
функцией печати битмапа. Битмап тут вмещается и перемасштабируется, чтоб
попасть на страницу с увеличенным размером и разместиться по центру листа.
Эти установки пользователь может изменить по своему желанию.
- unit UPrint;
- interface
- uses
- Windows, Messages, SysUtils, Classes, Graphics, Printers;
- procedure PrintBitmap(ABitmap: TBitmap);
- implementation
- procedure PrintBitmap(ABitmap: TBitmap);
- var
- B : TBitmap;
- isPrnPal : Boolean;
- Pal, OldPal : hPalette;
- PageWidth, PageHeight : Integer;
- PageMargin : TPoint;
- TestInt : Integer;
- ImagePageWidth : Integer;
- ImagePageHeight : Integer;
- ScaleX, ScaleY, OffsetX, OffsetY : Integer;
- ImageSize, InfoSize : DWord;
- PImage, PInfo : Pointer;
- begin
- Pal := 0;
- OldPal := 0;
- Printer.BeginDoc;
- B := TBitmap.Create;
- B.Assign(ABitmap);
- B.PixelFormat := pf24bit;
- isPrnPal := False;
- if (GetDeviceCaps(Printer.Canvas.Handle, RasterCaps)
and RC_Palette) = RC_Palette then
- begin
- B.PixelFormat := pf8bit;
- Pal := CopyPalette(B.Palette);
- OldPal := SelectPalette(Printer.Canvas.Handle, Pal, False);
- isPrnPal := True;
- end;
- PageWidth := Integer(GetDeviceCaps(Printer.Canvas.Handle,
HORZRES));
- PageHeight := Integer(GetDeviceCaps(Printer.Canvas.Handle,
VERTRES));
- PageMargin.X := 0; PageMargin.Y := 0;
- TestInt := Integer(GetPrintingOffset);
- if Escape(Printer.Canvas.Handle, QUERYESCSUPPORT,
SizeOf(TestInt), @TestInt, nil) <> 0 then
- begin
- if Escape(Printer.Canvas.Handle, GETPRINTINGOFFSET, 0,
nil, @PageMargin) <= 0 then
- begin
- PageMargin.X := 0;
- PageMargin.Y := 0;
- end;
- end;
- ImagePageWidth := PageWidth - 2 * PageMargin.X;
- ImagePageHeight := PageHeight - 2 * PageMargin.Y;
- if ((ImagePageWidth <= ImagePageHeight) and
(B.Width >= B.Height)) or ((ImagePageWidth >
ImagePageHeight) and (B.Width > B.Height)) then
- begin
- ScaleX := ImagePageWidth;
- ScaleY := Trunc(B.Height * ImagePageWidth / B.Width);
- OffsetX := PageMargin.X;
- OffsetY := (PageHeight div 2) - (ScaleY div 2);
- end else
- begin
- ScaleY := ImagePageHeight;
- ScaleX := Trunc(B.Width * ImagePageHeight / B.Height);
- OffsetY := PageMargin.Y;
- OffsetX := (PageWidth div 2) - (ScaleX div 2);
- end;
- GetDIBSizes(B.Handle, InfoSize, ImageSize);
- GetMem(PImage, ImageSize);
- GetMem(PInfo, InfoSize);
- GetDIB(B.Handle, B.Palette, PInfo^, PImage^);
- StretchDIBits(Printer.Canvas.Handle, OffsetX, OffsetY, ScaleX,
ScaleY, 0, 0, B.Width, B.Height, PImage, PBitmapInfo(PInfo)^,
DIB_RGB_COLORS, SRCCOPY);
- FreeMem(PImage); FreeMem(PInfo);
- if isPrnPal then
- begin
- SelectPalette(Printer.Canvas.Handle, OldPal, False);
- DeleteObject(Pal);
- end;
- Printer.EndDoc;
- end;
- end.
|
Как
вставить графику в ListBox или ComboBox. |
Возможность поместить графическое изображение в ListBox и ComboBox
может улучшить внешний вид вашего приложения и сделать пользовательский
интерфейс отличным от других. Ниже приведен пример, как это сделать шаг за
шагом ...
- Создать форму.
- Поместить компоненты TComboBox и TListbox на форму.
- Изменить свойство Style у TComboBox на
csOwnerDrawVariable и
lbOwnerDrawVariable для TListBox. Owner-Draw
TListBox или TComboBox позволяют показать и объекты
(например, картинку) и строки одновременно. В данном примере мы
добавляем и графический объект и строку.
- Создать 5 переменных типа TBitmap в разделе
var модуля для формы.
- Создать обработчики для событий OnCreate, OnDraw, OnMeasureItem,
OnClose.
{START OWNERDRW.PAS}
unit Ownerdrw;
interface
uses SysUtils, WinTypes, WinProcs, Messages, Classes,
Graphics, Controls, Forms, Dialogs, StdCtrls;
- type
- Tform1 = class(Tform)
- ComboBox1 : TcomboBox;
- ListBox1 : TListBox;
- procedure FormCreate(Sender : TObject);
- procedure FormClose(Sender : TObject;
var Action : TCloseAction);
- procedure ComboBox1DrawItem(Control :
TwinControl; Index : Integer; Rect : TRect; State :
TOwnerDrawState);
- procedure ComboBox1MeasureItem(Control :
TwinControl; Index : Integer; var Height : Integer);
- procedure ListBox1DrawItem(Control :
TwinControl; Index : Integer; Rect : TRect; State :
TOwnerDrawState);
- procedure ListBox1MeasureItem(Control :
TwinControl; Index : Integer; var Height : Integer);
- private
- { Private declarations }
- public
- { Public declarations }
- end;
- var
- Form1 : TForm1;
- TheBitmap1, TheBitmap2,
- TheBitmap3, TheBitmap4, TheBitmap5 : TBitmap;
- implementation
- {$R *.DFM}
- procedure Tform1.FormCreate(Sender : TObject);
- begin
- TheBitmap1 := TBitmap.Create;
- TheBitmap1.LoadFromFile('C:\delphi\images\buttons\globe.bmp');
- TheBitmap2 := TBitmap.Create;
- TheBitmap2.LoadFromFile('C:\delphi\images\buttons\video.bmp');
- TheBitmap3 := TBitmap.Create;
- TheBitmap3.LoadFromFile('C:\delphi\images\buttons\gears.bmp');
- TheBitmap4 := TBitmap.Create;
- TheBitmap4.LoadFromFile('C:\delphi\images\buttons\key.bmp');
- TheBitmap5 := TBitmap.Create;
- TheBitmap5.LoadFromFile('C:\delphi\images\buttons\tools.bmp');
- ComboBox1.Items.AddObject('Bitmap1 :
Globe', TheBitmap1);
- ComboBox1.Items.AddObject('Bitmap2 :
Video', TheBitmap2);
- ComboBox1.Items.AddObject('Bitmap3 :
Gears', TheBitmap3);
- ComboBox1.Items.AddObject('Bitmap4 :
Key', TheBitmap4);
- ComboBox1.Items.AddObject('Bitmap5 :
Tools', TheBitmap5);
- ListBox1.Items.AddObject('Bitmap1 :
Globe', TheBitmap1);
- ListBox1.Items.AddObject('Bitmap2 :
Video', TheBitmap2);
- ListBox1.Items.AddObject('Bitmap3 :
Gears', TheBitmap3);
- ListBox1.Items.AddObject('Bitmap4 :
Key', TheBitmap4);
- ListBox1.Items.AddObject('Bitmap5 :
Tools', TheBitmap5);
- end;
- procedure TForm1.FormClose(Sender : TObject; var
Action : TCloseAction);
- begin
- TheBitmap1.Free;
- TheBitmap2.Free;
- TheBitmap3.Free;
- TheBitmap4.Free;
- TheBitmap5.Free;
- end;
- procedure TForm1.ComboBox1DrawItem(Control : TwinControl;
Index : Integer; Rect : TRect; State : TOwnerDrawState);
- var
- Bitmap : TBitmap;
- Offset : Integer;
- begin
- with (Control as TComboBox).Canvas do
- begin
- FillRect(Rect);
- Bitmap := TBitmap(ComboBox1.Items.Objects[Index]);
- if Bitmap <> nil then
- begin
- BrushCopy(Bounds(Rect.Left + 2, Rect.Top + 2, Bitmap.Width,
Bitmap.Height), Bitmap, Bounds(0, 0, Bitmap.Width, Bitmap.Height),
clRed);
- Offset := Bitmap.width + 8;
- end;
- { display the text }
- TextOut(Rect.Left + Offset, Rect.Top, Combobox1.Items[Index]);
- end;
- end;
- procedure TForm1.ComboBox1MeasureItem(Control : TWinControl;
Index : Integer; var Height : Integer);
- begin
- Height := 20;
- end;
- procedure TForm1.ListBox1DrawItem(Control : TwinControl;
Index : Integer; Rect : TRect; State : TOwnerDrawState);
- var
- Bitmap : TBitmap;
- Offset : Integer;
- begin
- with (Control as TListBox).Canvas
do
- begin
- FillRect(Rect);
- Bitmap := TBitmap(ListBox1.Items.Objects[Index]);
- if Bitmap <> nil then
- begin
- BrushCopy(Bounds(Rect.Left + 2, Rect.Top + 2, Bitmap.Width,
Bitmap.Height), Bitmap, Bounds(0, 0, Bitmap.Width, Bitmap.Height),
clRed);
- Offset := Bitmap.width + 8;
- end;
- { display the text }
- TextOut(Rect.Left + Offset, Rect.Top, Listbox1.Items[Index]);
- end;
- end;
- procedure TForm1.ListBox1MeasureItem(Control :
TwinControl; Index : Integer; var Height : Integer);
- begin
- Height := 20;
- end;
- end.
- {END OWNERDRW.PAS}
- {START OWNERDRW.DFM}
- object Form1 : TForm1
- Left = 211
- Top = 155
- Width = 435
- Height = 300
- Caption = 'Form1'
- Font.Color = clWindowText
- Font.Height = -13
- Font.Name = 'System'
- Font.Style = []
- PixelsPerInch = 96
- OnClose = FormClose
- OnCreate = FormCreate
- TextHeight = 16
- object ComboBox1: TcomboBox
- Left = 26
- Top = 30
- Width = 165
- Height = 22
- Style = csOwnerDrawVariable
- ItemHeight = 16
- TabOrder = 0
- OnDrawItem = ComboBox1DrawItem
- OnMeasureItem = ComboBox1MeasureItem
- end
- object ListBox1: TlistBox
- Left = 216
- Top = 28
- Width = 151
- Height = 167
- ItemHeight = 16
- Style = lbOwnerDrawVariable
- TabOrder = 1
- OnDrawItem = ListBox1DrawItem
- OnMeasureItem = ListBox1MeasureItem
- end
- end
{END OWNERDRW.DFM} |
Как
подгрузить 256 цветный битмап из ресурса и отобразить его в нормальной
палитре? |
Обычно это делается таким образом:
Image1.BitMap.Hande := LoadBitMap( hInstance, 'BMP_NAME');
LoadBitmap загружает только картинку, без палитры. Если палитра
BitMap'а отличается от системной, то ее надо устанавливать "вручную".
Могут возникнуть проблемы, если на одной форме расположены две картинки с
разными палитрами.
- procedure XLoadBitmap(Instance : THandle; BitmapName : PChar;
var HB : HBitmap; var HP : HPalette);
- var
- DC : HDC;
- BI : PBitMapInfo;
- Pal : PLogPalette;
- I : Integer;
- ResIdHandle : THandle;
- ResDataHandle : THandle;
- Bitmap : HBitmap;
- C : HWnd;
- OldPalette, Palette : HPalette;
- begin
- Bitmap := 0;
- Palette := 0;
- HB := 0;
- HP := 0;
- {Получить ресурс из модуля}
- ResIDHandle := FindResource(Instance, BitmapName, rt_BitMap );
- if ResIDHandle <> 0 then
- begin
- ResDataHandle := LoadResource(Instance, ResIDHandle );
- if ResDataHandle <> 0
then
- begin
- BI := LockResource( ResDataHandle );
- if BI <> nil then
- begin
- {256-цветный битмап?}
- if BI^.bmiHeader.biBitCount = 8
then
- begin
- {Создать палитру}
- GetMem( Pal, SizeOf(TLogPalette) + 256 * SizeOf(
TPaletteEntry ));
- for I := 0 to 255 do
- with Pal^.palPalEntry[I] do
- begin
- peRed := BI^.bmiColors[I].rgbRed;
- peGreen := BI^.bmiColors[I].rgbGreen;
- peBlue := BI^.bmiColors[I].rgbBlue;
- peFlags := 0;
- end;
- Pal^.palNumEntries := 256;
- Pal^.palVersion := $300;
- Palette := CreatePalette(Pal^);
- FreeMem(Pal, SizeOf(TLogPalette) + 256 *
SizeOf(TPaletteEntry));
- {Привести цвета палитры в
системные}
- DC := CreateDC('Display', nil, nil,
nil);
- OldPalette := SelectPalette(DC, Palette, False);
- UnrealizeObject(Palette);
- RealizePalette(DC);
- {Создать битмап}
- BitMap := CreateDIBitmap(DC, BI^.bmiHeader, CBM_INIT,
@PByteArray(BI)^[SizeOf(TBitMapInfo) + SizeOf(TRGBQuad) * 256
- 4], BI^, DIB_RGB_COLORS);
- {Освободить ресурсы}
- UnlockResource(ResDataHandle);
- FreeResource(ResDataHandle);
- SelectPalette(DC, OldPalette, False);
- DeleteDC(DC);
- end
- else
- begin
- {Не 256-цветный
битмап}
- UnlockResource(ResDataHandle);
- FreeResource(ResDataHandle);
- BitMap := LoadBitmap(Instance, BitmapName);
- end;
- HB := Bitmap;
- HP := Palette;
- end; {BI <> nil
}
- end; {ResDataHandle <>
0}
- end; {ResIDHandle <> 0
}
- end;
- procedure TForm1.FormCreate(Sender: TObject);
- var
- HB : HBitmap;
- HP : HPalette;
- begin
- xLoadBitmap(hInstance, 'PHOTO',
HB, HP);
- Image1.Picture.Bitmap.Handle := HB;
- Image1.Picture.Bitmap.Palette := HP;
- end;
Код Вадима Пузанова /Красноярск/ |
Как
поместить двумерный массив в Image. |
Представим, что данные находятся в массиве:
TestArray : array[0..127, 0..127] of Byte;
Картинка будет иметь размер 128 x 128 точек:
Image1.Picture.Bitmap.Width := 128; Image1.Picture.Bitmap.Height :=
128;
Вызываем функцию Windows API для формирования BitMap:
SetBitmapBits(Image1.Picture.Bitmap.Handle, sizeof(TestArray),
@TestArray); Image1.Refresh; {для того, чтобы
изменения отобразились}
Однако, если вы используете свою палитру, то ее нужно
создать. |