Украинская баннерная сеть

  • Как рисовать прямо на экране?
  • Как скопировать экран (или его часть) в TBitmap?
  • Как я могу использовать анимированный курсор?
  • Как вывести на Canvas надпись под углом?
  • Как проиграть звуковой файл в приложении?
  • Как вывести графику на принтер?
  • Как вставить графику в ListBox или ComboBox
  • Как подгрузить 256 цветный битмап из ресурса и отобразить его в нормальной палитре?
  • Как поместить двумерный массив в Image.


    Как рисовать прямо на экране?

    Прислал 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 может улучшить внешний вид вашего приложения и сделать пользовательский интерфейс отличным от других. Ниже приведен пример, как это сделать шаг за шагом ...

    1. Создать форму.
    2. Поместить компоненты TComboBox и TListbox на форму.
    3. Изменить свойство Style у TComboBox на csOwnerDrawVariable и lbOwnerDrawVariable для TListBox. Owner-Draw TListBox или TComboBox позволяют показать и объекты (например, картинку) и строки одновременно. В данном примере мы добавляем и графический объект и строку.
    4. Создать 5 переменных типа TBitmap в разделе var модуля для формы.
    5. Создать обработчики для событий 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; {для того, чтобы изменения отобразились}

    Однако, если вы используете свою палитру, то ее нужно создать.

    Оглавление
    Назад