Как создать disable'ный битмап из обычного (emboss etc)?
Nomadic советует:
CreateMappedBitmap() :-)
Один из паpаметpов yказатель на COLORMAP, в нем для 16 основных цветов делаешь пеpекодиpовкy, цвета подбеpешь сам из пpинципа: все самые яpкие -> в GetSysColor( COLOR_3DLIGHT ); самые темные -> GetSysColor( COLOR_3DSHADOW ); нейтpальные, котpые бyдyт пpозpачные -> GetSysColor( COLOR_3DFACE ); Так на самом деле вот как делается данная задача:
|
procedure Tform1.aaa(bmpFrom,bmpTo:Tbitmap); var TmpImage,Monobmp:TBitmap; IRect:TRect; begin MonoBmp := TBitmap.Create; TmpImage:=Tbitmap.Create; TmpImage.Width := bmpFrom.Width; TmpImage.Height := bmpFrom.Height; IRect := Rect(0, 0, bmpFrom.Width, bmpFrom.Height); TmpImage.Canvas.Brush.Color := clBtnFace; try with MonoBmp do begin Assign(bmpFrom); Canvas.Brush.Color := clBlack; if Monochrome then begin Canvas.Font.Color := clWhite; Monochrome := False; Canvas.Brush.Color := clWhite; end; Monochrome := True; end; with TmpImage.Canvas do begin Brush.Color := clBtnFace; FillRect(IRect); Brush.Color := clBlack; Font.Color := clWhite; CopyMode := MergePaint; Draw(IRect.Left + 1, IRect.Top + 1, MonoBmp); CopyMode := SrcAnd; Draw(IRect.Left, IRect.Top, MonoBmp); Brush.Color := clBtnShadow; Font.Color := clBlack; CopyMode := SrcPaint; Draw(IRect.Left, IRect.Top, MonoBmp); CopyMode := SrcCopy; bmpTo.assign(TmpImage); TmpImage.free; end; finally MonoBmp.Free; end; end; procedure TForm1.Button1Click(Sender: TObject); begin aaa(image1.picture.bitmap,image2.picture.bitmap); Image2.invalidate; end; |
Писал это не я. Это написал сам Борланд (некузявно было бы взглянуть на класс TButtonGlyph. Как раз из него я это и выдернул).Hу а если уже совсем хорошо разобраться, то можно заметить функцию ImageList_DrawEx, в которой можно на 25 и 50 процентов уменьшить яркость (но визуально это очень плохо воспринимается). Соответственно параметры ILD_BLEND25, ILD_BLEND50, ILD_BLEND-A-MED. Естественно, что последний абзац работает только с тройкой.
Denis Tanayeff
Это кусочек из рабочей проги на Си, Вроде все лишнее я убрал. #define CO_GRAY 0x00C0C0C0L hMemDC = CreateCompatibleDC(hDC); hOldBitmap = SelectObject(hMemDC, hBits); // hBits это собственно картинка, которую надо "засерить" GetObject(hBits, sizeof(Bitmap), (LPSTR) &Bitmap); if ( GetState(BS_DISABLED) ) // Blt disabled { hOldBrush = SelectObject(hDC, CreateSolidBrush(CO_GRAY));//CO_GRAY PatBlt(hDC, BD_BORDERWIDTH, BD_BORDERWIDTH, Bitmap.bmWidth, Bitmap.bmHeight, PATCOPY); DeleteObject(SelectObject(hDC, hOldBrush)); lbLogBrush.lbStyle = BS_PATTERN; lbLogBrush.lbHatch =(int)LoadBitmap(hInsts, MAKEINTRESOURCE(BT_DISABLEBITS)); hOldBrush = SelectObject(hDC, CreateBrushIndirect(&lbLogBrush)); BitBlt(hDC, BD_BORDERWIDTH, BD_BORDERWIDTH, Bitmap.bmWidth, Bitmap.bmHeight, hMemDC, 0, 0, 0x00A803A9UL); // DPSoa DeleteObject(SelectObject(hDC, hOldBrush)); DeleteObject((HGDIOBJ)lbLogBrush.lbHatch); } [001129]
Как создать не VCL дисплей для отображения текста и изображений?
Своим опытом делится Олег Кулабухов:
|
procedure TForm1.Button1Click(Sender: TObject); var dc : hdc; MemDc : hdc; MemBitmap : hBitmap; OldMemBitmap : hBitmap; begin {Get the handle to the screen's dc} dc := GetDc(0); {Create and retrieve a handle to a memory dc based on the screen} MemDc := CreateCompatibleDc(dc); {Create a bitmap that is compatible with the display.} {Note: if you pass "MemDc" to CreateCompatibleBitmap()} {instead of "dc", you will get a monochrome bitmap!} MemBitmap := CreateCompatibleBitmap(dc, 100, 100); {Release the screen dc} ReleaseDc(0, dc); {Select the bitmap surface into the MemDc} {remembering the default bitmap} OldMemBitmap := SelectObject(MemDc, MemBitmap); {Draw on the MemoryDc} PatBlt(MemDc, 0, 0, 100, 100, WHITENESS); Ellipse(MemDc, 0, 0, 100, 100); {Copy the MemDc to the Form Canvas} BitBlt(Form1.Canvas.Handle, 100, 100, 100, 100, MemDc, 0, 0, SRCCOPY); {Select the default bitmap back into the memory dc} SelectObject(MemDc, OldMemBitmap); {Note: You can now use the memory bitmap handle with} {functions such as GetDiBits()} {Delete the Memory Bitmap} DeleteObject(MemBitmap); {Delete the MemoryDc} DeleteDc(MemDc); end; |
[001900]
Как установить прозрачность фона текста?
Своим опытом делится Олег Кулабухов:
Используем SetBkMode()
|
procedure TForm1.Button1Click(Sender: TObject); var OldBkMode : integer; begin with Form1.Canvas do begin Brush.Color := clRed; FillRect(Rect(0, 0, 100, 100)); Brush.Color := clBlue; TextOut(10, 20, 'Not Transparent!'); OldBkMode := SetBkMode(Handle, TRANSPARENT); TextOut(10, 50, 'Transparent!'); SetBkMode(Handle, OldBkMode); end; end; |
[001930]
Как вывести на Canvas надпись под углом?
Nomadic советует:
Вот, взгляни.
|
... 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 <&tg; 0 then Canvas.Font.Handle := CreateRotatedFont(Font, FontAngle); ... |
Вращаются только векторные шрифты. [001614]
Как вывести на экран текст с 'красивым' обрезанием по длине (если текст не помещается на экране)?
Nomadic советует:
Используй вызов DrawTextEx, установив в параметре dwDTFormat значение DT_PATH_ELLIPSIS. [001230]
Как записать содержимое окна OpenGL в 'bmp' файл?
Nomadic советует:
Вот что попробовал - вроде получилось:
|
bt := TBitmap.Create; bt.Width := gr.Width; bt.Height := gr.Height; bt.Canvas.CopyRect(ClientRect, gr.Canvas, gr.ClientRect); bt.SaveToFile('e:\bt.bmp'); bt.Free; |
(gr - объект, в канве которого я рисую с помощью OpenGL) [001108]
Код создания палитры
|
var Form1: TForm1; blueVal : Byte; BluePalette : HPalette; implementation {$R *.DFM} procedure TForm1.FormCreate(Sender: TObject); var LogicalPalette: PLogPalette; ColorIndex : LongInt; begin GetMem(LogicalPalette, (SizeOf(TLogPalette) + SizeOf(TPaletteEntry)*256)); GetSystemPaletteEntries(Canvas.Handle, 0, 256, LogicalPalette^.palPalEntry[0]); with LogicalPalette^ do begin palVersion := $300; palNumEntries := 256; {$R-} for ColorIndex := 10 to 245 do with palPalEntry[ColorIndex] do begin peRed := 0; peGreen := 0; peBlue := 255 - (ColorIndex-10); peFlags := PC_NOCOLLAPSE; end; end; {$R+} BluePalette := CreatePalette(LogicalPalette^); FreeMem(LogicalPalette, (SizeOf(TLogPalette) + SizeOf(TPaletteEntry)*256)); end; procedure TForm1.FormDestroy(Sender: TObject); begin DeleteObject(BluePalette); end; procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var OldPal : HPALETTE; begin OldPal := SelectPalette(Canvas.Handle, BluePalette, False); RealizePalette(Canvas.Handle); canvas.pen.color := $02000000 or (BlueVal * $00010000); canvas.pen.width := 10; canvas.moveto(0, 0); canvas.lineto(X,Y); SelectPalette(Canvas.Handle, OldPal, False); Inc(BlueVal); If BlueVal > 255 Then BlueVal := 0; end; |
[000654]
Компонент для отрисовки линий
Вот компонент, инкапсулирующий функции рисования линий. Он может рисовать горизонтальные, вертикальные и диагональные линии. Вы можете добавить необходимые вам события в секцию *published*.
|
unit Lines; {от Bill Murto, CIS 73730,2505}
interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms; type TLineOrigin = (loTopLeft, loTopRight); TLine = class(TGraphicControl) private { Private declarations } fOrigin: TLineOrigin; fPen: TPen; procedure SetOrigin(Value: TLineOrigin); procedure SetPen(Value: TPen); protected { Protected declarations } procedure Paint; override; public { Public declarations } constructor Create(AOwner: TComponent); override; destructor Destroy; override; published { Published declarations } property Origin: TLineOrigin read fOrigin write SetOrigin default loTopLeft; property Pen: TPen read fPen write SetPen; property Height default 33; property Width default 33; procedure StyleChanged(Sender: TObject); end; procedure Register; implementation procedure Register; begin RegisterComponents('Samples', [TLine]); end; procedure TLine.SetOrigin(Value: TLineOrigin); begin if fOrigin <> Value then begin fOrigin := Value; Invalidate; end; end; procedure TLine.SetPen(Value: TPen); begin fPen.Assign(Value); end; procedure TLine.StyleChanged(Sender: TObject); begin Invalidate; end; constructor TLine.Create(AOwner: TComponent); begin inherited Create(AOwner); Height := 33; Width := 33; fPen := TPen.Create; fPen.OnChange := StyleChanged; if csOpaque in ControlStyle then ControlStyle := ControlStyle - [csOpaque]; end; procedure TLine.Paint; begin with Canvas do begin Pen := fPen; if (Width <= Pen.Width) or (Height <= Pen.Width) then begin if Width <= Pen.Width then begin MoveTo(0, 0); LineTo(0, Height); end; if Height <= Pen.Width then begin MoveTo(0, 0); LineTo(Width, 0); end; end else case fOrigin of loTopLeft: begin MoveTo(0, 0); LineTo(Width, Height); end; loTopRight: begin MoveTo(Width, 0); LineTo(0, Height); end; end; end; end; destructor TLine.Destroy; begin fPen.Free; inherited Destroy; end; end. |
- William E Murto [000784]
Компонент для работы с FLIC-анимацией
Новостная группа: comp.lang.pascal.delphi.components
Тема: Компонент для работы с FLIC-анимацией: отправной пункт.
От: Paul Kuczora <paul@kuczora.demon.co.uk>
Дата: Чет, 03 Авг 95 16:51:19 GMT
В качество ответа на целый круг вопросов, я включил в свой ответ два файла: aaplay1.inc - include-файл с интерфейсом для библиотеки aaplay.dll aaplay1.pas - сырой скелет компонента для проигрывания FLIC-анимации Я разработал это глядя на другой компонент (это был полнофункциональный плейер, работающий как форма), и вынужден был сохранить некоторые вещи неприкосновенными (попробуй тут сделай иначе :-)
Для работы вам понадобится библиотека aaplay.dll от Autodesk, которую вы можете найти на множестве мест (например, я так предполагаю, на Encarta CD). Для полного счастья вы можете обратиться к файлу помощи для Animation Player for Windows, который, не удивляйтесь, содержит справку для этой DLL - на первой странице найдите в ее самой нижней части указание на эту библиотеку, и перед вами предстанет полная справка по вызовам этой самой DLL.
Надеюсь что помог вам. . .
ВНИМАНИЕ! Это мой первый код, написанный для Windows (спасибо Delphi), поэтому он рекомендуется только для ознакомления.
|
{ ============================================================================ } { aaplay1.inc } { (c) P W Kuczora } { 17-го апреля 1995 } { Заголовочный файл, содержащий константы и определения типов для aaplay1.pas } const NULL = 0; NULLPTR = ^0; { Доступные Флаги wMode: integer; Используются в aaLoad, aaReLoad Первые восемь бит wMode используются в aa_flags. } AA_MEMORYLOAD = $1; { Загрузка в память } AA_HIDEWINDOW = $2; { Скрывать окно анимации } AA_NOPALETTE = $4 ; { Анимация без палитры } AA_RESERVEPALETTE = $8; { Резервировать при старте всю палитру } AA_LOOPFRAME = $10; { Циклическая загрузка кадров } AA_FULLSCREEN = $20; { Использовать полноэкранный режим воспроизведения } AA_STOPNOTIFY = $40; { Исключать любые уведомляющие сообщения } AA_STOPSTATUS = $80; { Исключать сообщения об изменении статуса } AA_NOFAIL = $100; { Уменьшение типа нагрузки при ошибке } AA_DONTPAINT = $200; { Не делать paByVal-анимацию при загрузке } AA_BUILDSCRIPT = $400; { lpzFileName - скрипт, не имя } AA_ALLMODES = $FF; { Доступные флаги для режимов звука - wMode: integer; Используются в aaSound } AA_SNDFREEZE = $1; { Заморозка кадров при проигрывании звуков } AA_SNDDEVICEID = $100; { ID устройства, не имя } AA_SNDBUILDALIAS = $200; { создавать псевдоним звукового устройства } { aaNotify позволяет извещать приложение о проигрывании определенных кадров. lPosition - позиция, на которой должно происходить уведомление. wParam для этого сообщения - hAa, а lParam копируется из этого вызова. При установке сообщения возвращается TRUE. Следующее значение определяет необходимость завершения цикла анимации по окончании проигрывания звука. Если звук отсутствует, анимация зацикливается навсегда. } AA_LOOPSOUND = $FFFF; { Автоматическое уведомление посылается при перезагрузке в скрипте анимации. lParam для этого сообщения определен ниже } AA_ANIMATIONLOADED = 0; { Типы параметров Используется с aaGetParm и aaSetParm. } AA_STATUS = 1; { Получить текущий статус } AA_FILETYPE = 2; { Получить тип анимации на диске } AA_MODE = 3; { Получить/установить флаги анимации } AA_WINDOW = 4; { Установить/получить окно анимации } AA_SPEED = 5; { Установить/получить текущую скорость } AA_DESIGNSPEED = 6; { Получить скорость на этапе дизайна } AA_FRAMES = 7; { Получить число кадров } AA_POSITION = 8; { Установить/получить позицию текущего кадра } AA_LOOPS = 9; { Установить/получить число циклов } AA_X = 10; { Установить/получить позицию выводимого окна } AA_Y = 11; { Установить/получить позицию выводимого окна } AA_CX = 12; { Установить/получить размеры выводимого окна } AA_CY = 13; { Установить/получить размеры выводимого окна } AA_ORGX = 14; { Установить/получить начало выводимого окна } AA_ORGY = 15; { Установить/получить начало выводимого окна } AA_WIDTH = 16; { Получить ширину анимации } AA_HEIGHT = 17; { Получить высоту анимации } AA_RPTSOUND = 18; { Установить/получить повторения звуков } AA_PAUSE = 19; { Установить/получить время паузы } AA_DELAYSND = 20; { Установить/получить время задержки звука } AA_TRANSIN = 21; { Установить/получить тип входного перехода } AA_TRANSOUT = 22; { Установить/получить тип выходного перехода } AA_TIMEIN = 23; { Установить/получить время входного перехода } AA_TIMEOUT = 24; { Установить/получить время выходного перехода } AA_CALLBACK = 25; { Установить/получить окно обратного вызова } AA_ANIMWND = 26; { Получить дескриптор окна анимации } AA_MODFLAG = 100; { Установить/получить флаг изменения скрипта } AA_SCRIPTNAME = 101; { Установить/получить имя скрипта } AA_ANIMATION = 102; { Получить/установить скрипт анимации } AA_ANIMATIONCOUNT = 103; { Получить счетчик скрипта анимации } AA_SCRIPTCONTENTS = 104; { Получить содержание скрипта } AA_LASTERROR = 1001; { Получить код последней ошибки } AA_LASTERRORMESSAGE = 1002; { Получить/установить сообщение о последней ошибке } { Типы параметров Используется с aaSetParmIndirect } AA_SETMODE = $1; { Получить/установить флаги анимации } AA_SETWINDOW = $2; { Установить/получить окно анимации } AA_SETSPEED = $4; { Установить/получить текущую скорость } AA_SETPOSITION = $8; { Установить/получить позицию текущего кадра } AA_SETLOOPS = $10; { Установить/получить число циклов } AA_SETX = $20; { Установить/получить левую координату выводимого окна } AA_SETY = $40; { Установить/получить левую координату выводимого окна } AA_SETCX = $80; { Установить/получить верхнюю координату выводимого окна } AA_SETCY = $100; { Установить/получить верхнюю координату выводимого окна } AA_SETORGX = $200; { Установить/получить ширину выводимого окна } AA_SETORGY = $400; { Установить/получить ширину выводимого окна } AA_SETRPTSOUND = $800; { Установить/получить повторения звуков } AA_SETPAUSE = $1000; { Установить/получить время паузы } AA_SETDELAYSND = $2000; { Установить/получить время задержки звука } AA_SETTRANSIN = $4000; { Установить/получить тип входного перехода } AA_SETTRANSOUT = $8000; { Установить/получить тип выходного перехода } AA_SETTIMEIN = $10000; { Установить/получить время входного перехода } AA_SETTIMEOUT = $20000; { Установить/получить время выходного перехода } AA_SETCALLBACK = $40000; { Установить/получить окно обратного вызова } AA_ALL = $FFFFFFFF; { Получить/установить все параметры } { Значения статуса для анимации } AA_STOPPED = 1; { Загружена, но не воспроизводится } AA_QUEUED = 2; { Анимация ожидает воспроизведение } AA_PLAYING = 3; { Анимация воспроизводится } AA_PAUSED = 4; { Анимация в режиме паузы } AA_DONE = 5; { Анимация закончила воспроизведение } { и ожидает вызов aaStop } { Определения типов файла } AA_FLI = $1; { Формат Autodesk Animator Fli } AA_DIB = $2; { Формат Windows DIB } AA_NUMTYPES = $2; { Количество типов } AA_SCRIPT = $3; { Скрипт без анимации } { Типы переходов } AA_CUT = 0; { Простая остановка одной и запуск другой } AA_FADEBLACK = $1; { Уход/выход из черного } AA_FADEWHITE = $2; { Уход/выход из белого } { Коды ошибок, возвращаемые aaGetParm(xxx, AA_LASTERROR) } AA_ERR_NOERROR = 0; { Неизвестная ошибка } AA_ERR_NOMEMORY = $100; { 256 - Ошибка нехватки памяти } AA_ERR_BADHANDLE = $101; { 257 - Плохой дескриптор } AA_ERR_NOTIMERS = $102; { 258 - Невозможно запустить таймер } AA_ERR_BADSOUND = $103; { 259 - Плохое звуковое сопровождение } AA_ERR_NOSCRIPT = $104; { 260 - Требуется скрипт } AA_ERR_WRITEERR = $105; { 261 - Ошибка записи (для сценария) } AA_ERR_BADANIMATION = $106; { 262 - Невозможно открыть анимацию } AA_ERR_BADWINDOWHANDLE = $200; { 512 - Плохой дескриптор окна } AA_ERR_WINDOWCREATE = $201; { 513 - Невозможно создать окно } AA_ERR_DLGERROR = $202; { 514 - Ошибка диалога } AA_ERR_INVALIDSTATUS = $300; { 768 - Неверный статус } AA_ERR_BADDIBFORMAT = $301; { 769 - Плохой dib-файл } AA_ERR_BADFLIFORMAT = $302; { 770 - Плохой fli-файл } AA_ERR_UNRECOGNIZEDFORMAT = $303; { 771 - Нераспознанный формат } AA_ERR_NOSOUND = $304; { 772 - Звук не поддерживается } AA_ERR_NOTVALIDFORSCRIPTS = $305; { 773 - Неправильный сценарий } AA_ERR_INVALIDFILE = $306; { 774 - Плохой дескриптор файла } AA_ERR_NOSCRIPTS = $307; { 775 - Нет файлов-скриптов } AA_ERR_SPEED = $400; { 1024 - Неверная скорость } AA_ERR_LOOPS = $401; { 1025 - Неверные циклы } AA_ERR_RPTSOUND = $402; { 1026 - Неверный повтор звука } AA_ERR_PAUSE = $403; { 1027 - Неверная пауза } AA_ERR_TRANSIN = $404; { 1028 - Неверный переход } AA_ERR_TIMEIN = $405; { 1029 - Неверный переход } AA_ERR_TRANSOUT = $406; { 1030 - Неверное время перехода } AA_ERR_TIMEOUT = $407; { 1031 - Неверное время перехода } AA_ERR_DELAYSND = $408; { 1032 - Неверная задержка звука } AA_ERR_INVALIDTYPE = $409; { 1033 - Неверный тип параметра } AA_ERR_DUPLICATENOTIFY = $500; { 1280 - Дублирование уведомления } AA_ERR_NOSWITCH = $600; { 1536 - Отсутствие ключей в скрипте } AA_ERR_PARSELOOPS = $601; { 1537 - Плохие циклы в скрипте } AA_ERR_PARSESPEED = $602; { 1538 - Плохая скорость в скрипте } AA_ERR_BADRPTSOUND = $603; { 1539 - Плохое повторение звука в скрипте } AA_ERR_PARSEPAUSE = $604; { 1540 - Плохая пауза в скрипте } AA_ERR_PARSETRANS = $605; { 1541 - Плохой переход в скрипте } AA_ERR_PARSEDELAYSND = $606; { 1542 - Плохая задержка звука в скрипте } AA_ERR_TOOMANYLINKS = $607; { 1543 - Слишком много ссылок } { dwFlags: integer; может быть любым из нижеперечисленных Используется в aaGetFile. } AA_GETFILE_MUSTEXIST = $1; AA_GETFILE_NOSHOWSPEC = $2; AA_GETFILE_SAVE = $4; AA_GETFILE_OPEN = $8; AA_GETFILE_USEDIR = $10; AA_GETFILE_USEFILE = $20; AA_GETFILE_SOUND = $40; AA_GETFILE_SCRIPT = $80; AA_GETFILE_ANIMATION = $100; { wMode: integer; Значения Используется в aaSave } AA_SAVE_IFMODIFIED = $1; AA_SAVE_AS = $2; AA_SAVE_CANCEL = $4; { Возможности Используется в aaGetCaps } AA_CAP_TIMER = 1; AA_CAP_SOUND = 2; AA_CAP_SCRIPT = 3; { Статусные сообщения анимации Используйте RegisterWindowMessage для получения номеров реальных сообщений. } AA_NOTIFY = 'AAPLAY Уведомление'; { Сообщение-уведомление } AA_STOP = 'AAPLAY Стоп'; { Стоп-сообщение } { Это посылается в первом слове lParam с сообщением AA_ERROR. Это указывает на возникшую ошибку } AA_BADPLAY = 1; { Ошибка при попытке воспроизведения } AA_BADNOTIFY = 2; { Ошибка при попытке послать уведомление } AA_BADSCRIPT = 3; { Ошибка в сценарии при попытке } { воспроизведения } |
|
{ ========================================================================== } unit aaplay1; { (c) P W Kuczora } { 27-го апреля 1995 } interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, MPlayer; {$I AAPLAY1.INC} const AAPARMS_SIZE = 54; type AAHandle = word; { Дескриптор анимации } AASPEED = word; { Тип, содержащий скорость анимации } AATRN = word; { Тип для хранения перехода анимации } dword = longint; { Структура параметра должна быть использована для анимации. } AAPARMS = record AA_STATUS : byte; { Текущий статус анимации } AA_FILETYPE : byte; { Тип файла на диске } AA_MODE : byte; { Некоторые флаги } AA_bitpix : byte; { бит на пиксел } AA_HWnd : HWnd; { Дескриптор окна для статусного сообщения } AA_X : integer; { Левая координата выводимого окна } AA_Y : integer; { Верхняя координата выводимого окна } AA_CX : integer; { Ширина выводимого окна } AA_CY : integer; { Высота выводимого окна } AA_ORGX : integer; { PoByVal в показываемой анимации } AA_ORGY : integer; { в верхнем левом углу } AA_SPEED : AASPEED; { Скорость анимации в миллисекундах на кадр } AA_DESIGNSPEED : AASPEED; { Проектируемые миллисекунды на кадр } AA_WIDTH : word; { Ширина анимации в пикселах } AA_HEIGHT : word; { Высота анимации в пикселах } AA_FRAMES : word; { Количество кадров в анимации } AA_POSITION : dword; { Текущая кадровая позиция } AA_LOOPS : dword; { Конечная позиция анимации } AA_RPTSOUND : word; { Количество повторов звука } AA_PAUSE : word; { Количество миллисекунд замораживания кадра } AA_DELAYSND : longint; { Задержка звука в миллисекундах } AA_TRANSIN : byte; { Переход в начале анимации } AA_TRANSOUT : byte; { Переход в конце анимации } AA_TIMEIN : word; { Продолжительность входного перехода в миллисекундах } AA_TIMEOUT : word; { Продолжительность выходного перехода в миллисекундах } AA_CALLBACK : HWnd; { Сообщение окна обратного вызова } AA_ANIMWND : Hwnd; { Дескриптор окна анимации } end; AAPARMSPtr = ^AAPARMS; {type} TAAPlayer = class(TMediaPlayer) procedure OpenAA; private { Private declarations } protected { Protected declarations } public { Public declarations } AAParameters: AAPARMS; FlicHandle: AAHandle; PlayWinHandle: THandle; StatusWinHandle: THandle; CallbackWinHandle: THandle; published { Published declarations } end; procedure Register; { Внешние вызовы AAPLAY.DLL } function aaOpen : boolean; procedure aaClose; function aaGetCaps(wType: word) : word; function aaLoad(lpzFileName: PChar; WinHnd: HWnd; wMode: word; x, y, wid, hght, orgx, orgy: integer): AAHandle; function aaReLoad(hAa: AAHandle; lpzFileName: PChar; wMode, wMask: word) : boolean; function aaUnload(hAa: AAHandle): boolean; function aaPlay(hAa: AAHandle) : boolean; function aaNotify(hAa: AAHandle; lPosition, lParam: longint) : boolean; function aaCancel(hAa: AAHandle; lLoPos, lHiPos: longint) : word; function aaStop(hAa: AAHandle) : boolean; function aaPause(hAa: AAHandle) : boolean; function aaPrompt(hAa: AAHandle; lpName: PChar) : boolean; function aaGetParm(hAa: AAHandle; wType: word) : longint; function aaGetParmIndirect(hAa: AAHandle; lpAp: AAPARMSPtr; wSize: word) : boolean; function aaSetParm(hAa: AAHandle; wType: word; wValue1, lValue2: longint) : AAHandle; function aaSetParmIndirect(hAa: AAHandle; dwType: longint; lpAp: AAPARMSPtr; wMask: word): boolean; function aaShow(hAa: AAHandle; bShow: boolean) : boolean; function aaSound(hAa: AAHandle; device, ffile: PChar; wMode: word) : boolean; function aaGetFile(dwFlags: word; lpszPath: PChar; wBufLen: word; lpszDriver: PChar; wDrvLen: word) : integer; function aaSave(hAa: AAHandle; wMode: word) : integer; implementation { =========================================================================== } procedure Register; begin RegisterComponents('Samples', [TAAPlayer]); end; { --------------------------------------------------------------------------- } procedure TAAPlayer.OpenAA; var FileSuffix, tempstr: string[12]; a,b: integer; begin { tempstr := ExtractFilename(AAPlayer.Filename); } { a := StrPos(tempstr,'.'); if (a > 0) then begin b := a; while (b <= StrLen(tmpstr)) do begin FileSuffix := FileSuffix + StrUpper(tempstr[b]); b := b+1; end; if ((FileSuffix = '.FLC') or (FileSuffix = '.FLI')) then begin} { AutoEnable := False; EnabledButtons := [btRecord,btEject]; } {end; end; } end; { =========================================================================== } { Внешние вызовы 'AAPLAY.DLL' } {$F+} { =========================================================================== } { --------------------------------------------------------------------------- } function aaOpen : boolean; external 'AAPLAY'; { --------------------------------------------------------------------------- } procedure aaClose; external 'AAPLAY'; { ' AAOpen и AAClose в действительности не нужны, за исключением обработки ' ошибки в Windows, которая предохраняет освобождение библиотек в процедуре ' выхода Windows (Windows Exit Proc, WEP). ' ' Поэтому мы используем AAClose для освобождения библиотек при закрытии ' последней задачей AAPlay DLL. } { --------------------------------------------------------------------------- } function aaGetCaps(wType: word) : word; external 'AAPLAY'; { ' Получение возможностей } { --------------------------------------------------------------------------- } function aaLoad(lpzFileName: PChar; WinHnd: HWnd; wMode: word; x, y, wid, hght, orgx, orgy: integer): AAHandle; external 'AAPLAY'; { ' aaLoad загружает анимацию. ' ' Имя файла в lpzFileName ' и режим загрузки в wMode. } { --------------------------------------------------------------------------- } function aaReLoad(hAa: AAHandle; lpzFileName: PChar; wMode, wMask: word) : boolean; external 'AAPLAY'; { ' aaReLoad загружает файл новый анимации ' "в дескриптор" старой анимации. ' ' Уведомления теряются, но палитра и окно ' сохраняются. } { --------------------------------------------------------------------------- } function aaUnload(hAa: AAHandle): boolean; external 'AAPLAY'; { ' aaUnload выгружает загруженную анимацию. ' ' Возвращается FALSE, если ' hAa не является дескриптором загруженной анимации. } { --------------------------------------------------------------------------- } function aaPlay(hAa: AAHandle) : boolean; external 'AAPLAY'; { ' aaPlay воспроизводит загруженную анимацию. ' ' Возвращается TRUE, если после возврата aaPlay анимация не останавливается. } { --------------------------------------------------------------------------- } function aaNotify(hAa: AAHandle; lPosition, lParam: longint) : boolean; external 'AAPLAY'; { ' aaNotify позволяет извещать приложение о воспроизведении ' определенных кадров анимации. ' ' lPosition -позиция, в которой должно происходить уведомление. ' ' wParam для данного сообщения - hAa, а lParam копируется из этого вызова. ' ' Возвращается TRUE, если уведомление установлено. } { --------------------------------------------------------------------------- } function aaCancel(hAa: AAHandle; lLoPos, lHiPos: longint) : word; external 'AAPLAY'; { ' aaCancel позволяет приложению отменить уведомления, установленные aaNotify. ' ' lLoPos и lHiPos задает верхний и нижний предел позициям. ' ' Возвращает количество отмененных уведомлений. } { --------------------------------------------------------------------------- } function aaStop(hAa: AAHandle) : boolean; external 'AAPLAY'; { ' aaStop прекращает воспроизведение анимации. ' ' При остановке воспроизведения aaStop возвращает TRUE. } { --------------------------------------------------------------------------- } function aaPause(hAa: AAHandle) : boolean; external 'AAPLAY'; { ' aaPause приостанавливает воспроизведение. ' ' Возвращается TRUE, если после возврата aaPause анимация переходит в режим паузы. ' ' Для продолжения воспроизведения анимации используйте aaPlay. } { --------------------------------------------------------------------------- } function aaPrompt(hAa: AAHandle; lpName: PChar) : boolean; external 'AAPLAY'; { ' aaPrompt позволяет выводить диалог для получения данных от пользователя. ' ' При получении данных дескриптор меняется, и, таким образом, вступают ' в силу новые параметры. Старый дескриптор не уничтожается до тех пор, ' пока не будет создан новый. ' ' Если новый дескриптор не может быть создан, aaPrompt возвращает NULL, ' в противном случае возвращается новый дескриптор. } { --------------------------------------------------------------------------- } function aaGetParm(hAa: AAHandle; wType: word) : longint; external 'AAPLAY'; { ' aaGetParm возвращает информацию об анимации. ' ' Некоторая информация может быть установлена с помощью aaSetParm, ' и другая информация - информация о состоянии, поддерживаемая AAPLAY. } { --------------------------------------------------------------------------- } function aaGetParmIndirect(hAa: AAHandle; lpAp: AAPARMSPtr; wSize: word) : boolean; external 'AAPLAY'; { ' aaGetParmIndirect возвращает ту же информацию, что и aaGetParm, ' в структуре, удобной для легкого доступа из приложений Visual Basic. } { --------------------------------------------------------------------------- } function aaSetParm(hAa: AAHandle; wType: word; wValue1, lValue2: longint) : AAHandle; external 'AAPLAY'; { ' aaSetParm устанавливает информацию для анимации } { --------------------------------------------------------------------------- } function aaSetParmIndirect(hAa: AAHandle; dwType: longint; lpAp: AAPARMSPtr; wMask: word): boolean; external 'AAPLAY'; { ' aaSetParmIndirect устанавливает параметры анимации из структуры. } { --------------------------------------------------------------------------- } function aaShow(hAa: AAHandle; bShow: boolean) : boolean; external 'AAPLAY'; { ' aaShow позволяет показать в окне отдельный кадр анимации. ' ' Mode определяет способ рисования анимации. ' ' Параметры окна возможно задать с помощью aaSetParm или aaSetParmIndirect. ' ' aaShow возвращает TRUE, если анимация была отрисована без ошибок. } { --------------------------------------------------------------------------- } function aaSound(hAa: AAHandle; device, ffile: PChar; wMode: word) : boolean; external 'AAPLAY'; { ' aaSound открывает и закрывает канал звукового сопровождения анимации. ' ' Звуковой канал будет открыт, если аргумент file не будет равен null ' и не будет пустым, в противном случае канал будет закрыт. ' ' Если устройство равно null, то для выбора подходящего устройства ' используется формат файла. } { --------------------------------------------------------------------------- } function aaGetFile(dwFlags: word; lpszPath: PChar; wBufLen: word; lpszDriver: PChar; wDrvLen: word) : integer; external 'AAPLAY'; { ' Открывает системного диалоговое окно стандартного типа ("открыть файл"), ' предлагающее пользователю выбрать файл. ' ' <dwFlags> определяет характеристики диалогового окна. ' Список возможных флагов: ' AA_GETFILE_MUSTEXIST Выбранный файл должен удовлетворять условиям ' флагов OpenFile(), в противном случае диалог ' издаст системный звук. ' AA_GETFILE_NOSHOWSPEC НЕ показывать путь в поле редактирования. ' По умолчанию путь к файлу показывается. ' AA_GETFILE_SAVE Кнопка Ok имеет заголовок "Save". ' AA_GETFILE_OPEN Кнопка Ok имеет заголовок "Open". ' AA_GETFILE_USEFILE Взять имя файла из параметра lpszPath ' AA_GETFILE_UDEDIR Взять каталог из параметра lpszPath ' AA_GETFILE_SOUND Получить звуковой файл и драйвер ' AA_GETFILE_SCRIPT Получить файл со скриптом ' AA_GETFILE_ANIMATION Получить файл анимации (без скриптов) ' ' <lpszPath> - строковый буфер LPSTR, куда после выполнения диалога ' пишется полное имя пути. ' <wBufLen> - длина данного буфера. ' ' <lpszDriver> - строковый буфер LPSTR для хранения выбранного ' звукового устройства. ' <wDrvLen> - длина данного буфера. ' ' Возвращаемые значения: 0, если была нажата кнопка Cancel ' -1, если OpenFile() потерпело неудачу, ' а AA_GETFILE_MUSTEXIST не определен. ' В противном случае возвращается дескриптор DOS-файла. ' При возврате из aaOpenFile данный дескриптор "не открыт". } { --------------------------------------------------------------------------- } function aaSave(hAa: AAHandle; wMode: word) : integer; external 'AAPLAY'; { ' Сохранение скрипта } { --------------------------------------------------------------------------- } {$F-} { Окончание внешних вызовов 'AAPLAY.DLL' } { =========================================================================== } end. { =========================================================================== } |
Dr Paul Kuczora.
--------------------------------------------------------------------------------
Paul Kuczora c home.london.uk
(на создание файла потрачен один день)
[001137]
Копирование содержимого экрана на форму
|
var Image3: TImage; procedure TSaverForm.CopyScreen; var DeskTopDC: HDc; DeskTopCanvas: TCanvas; DeskTopRect: TRect; begin Image3 := TImage.Create(SaverForm); With Image3 do begin Height := Screen.Height; Width := Screen.Width; end; Image3.Canvas.copymode := cmSrcCopy; DeskTopDC := GetWindowDC(GetDeskTopWindow); DeskTopCanvas := TCanvas.Create; DeskTopCanvas.Handle := DeskTopDC; Image3.Canvas.CopyRect(Image3.Canvas.ClipRect, DeskTopCanvas, DeskTopCanvas.ClipRect); Image2.Picture.Assign(Image3.Picture); {image2 расположен на целевой форме и выровнен по области клиента} end; procedure TSaverForm.FormClose(Sender: TObject; var Action: TCloseAction); begin Image3.Free; end; |
В настоящее время я также разбираюсь в других ответах на мой вопрос.
Попробуйте следующий HAX 244, взятый из Авг/Сен номера журнала Visual Developer. Это работает, и работает хорошо.
|
{ смотри текстовое описание за последним END. } unit Scrncap; interface uses WinTypes, WinProcs, Forms, Classes, Graphics; function CaptureScreenRect( ARect: TRect ): TBitmap; function CaptureScreen: TBitmap; function CaptureClientImage( Control: TControl ): TBitmap; function CaptureControlImage( Control: TControl ): TBitmap; implementation { используем следующий код для захвата прямоугольной области экрана } function CaptureScreenRect( ARect: TRect ): TBitmap; var ScreenDC: HDC; begin Result := TBitmap.Create; with Result, ARect do begin Width := Right - Left; Height := Bottom - Top; ScreenDC := GetDC( 0 ); try BitBlt( Canvas.Handle, 0, 0, Width, Height, ScreenDC, Left, Top, SRCCOPY); finally ReleaseDC( 0, ScreenDC ); end; end; end; { используем следующий код для захвата целого экрана } function CaptureScreen: TBitmap; begin with Screen do Result := CaptureScreenRect( Rect( 0, 0, Width, Height )); end; { используем следующий код для захвата клиентской области формы или элемента управления...} function CaptureClientImage( Control: TControl ): TBitmap; begin with Control, Control.ClientOrigin do Result := CaptureScreenRect( Bounds( X, Y, ClientWidth, ClientHeight )); end; { используйте следующий код для захвата целой формы или элемента управления } function CaptureControlImage( Control: TControl ): TBitmap; begin with Control do if Parent = nil then Result := CaptureScreenRect( Bounds( Left, Top, Width, Height )) else with Parent.ClientToScreen( Point( Left, Top )) do Result := CaptureScreenRect( Bounds( X, Y, Width, Height )); end; end. { Источник: Visual Developer, HAX #244, Авг/Сент 1996 захват экрана с помощью Delphi В Delphi, если вы хотите получить изображение клиентской области формы, необходимо вызвать GetFormlmage. Но иногда возникает необходимость получения снимка формы целиком, вместе с заголовком, контуром и всем содержимым. Или целиком всего экрана. Если бы у вас был дефицит времени, мы бы в этом случае посоветовали показывать диалоговое окно с надписью "Теперь нажмите кнопку Print Screen!", после чего работать с изображением, помещенным в буфер обмена. |
Но мы никуда не спешим. Комбинирование хостов Delphi с несколькими функциями GDI сводят задачу получения снимка экрана всего к одной строчке кода.
CaptureScreenRect, в листинге 1, демонстрирует это. Код получает экранный контекст устройства с помощью GetDC(O), и затем копирует прямоугольную область этого DC на холст изображения (Bitmap). Для копирования используется BitBlt. Смысл использования BitBlt (и любой функции GDI) в том, что Delphi помнит, что дескриптор холста есть DC, необходимый Windows.
Остальные функции копирования экрана в листинге 1 захватывают прямоугольник и отдает реальную работу на откуп CaptureScreenRect. CaptureScreen захватывает для прямоугольника целый экран. CaptureClientImage и CaptureControlImage захватывают прямоугольник области клиента и элемента управления, соответственно.
Эти четыре функции могут быть использованы для захвата любой произвольной области экрана, а также экранных областей форм, кнопок, полей редактирования, ComboBox'ов и пр.. Не забывайте после работы освобождать используемые вами картинки (Bitmap). }
[001733]
Можно ли запустить OpenGL под Windows'95, и как поставлять его с программой?
Nomadic советует:
Надо сразу отметить, что для работы Microsoft OpenGL 1.1 требуется только наличие в системе двух динамических библиотек. Они различны для Windows 95 и для Windows NT. Они всегда инсталлируется вместе с системой, если эта система - Windows 95 OSR2 или более поздняя, или если это Windows NT. Однако, если Вы столкнулись с машиной, где OpenGL отсутствует (Windows 95 OSR1 и более ранние), то достаточно их взять из диcтpибyтива OSR2 (GLU32.DLL и OPENGL32.DLL) и записать в GetSystemDirectory - и запycкайте OpenGL-приложения на здоpовье.
Более эффективную реализацию OpenGL для Win32 от фирмы SGI я бы советовал стянуть с www.sgi.com или www.opengl.org (SGI OpenGL for Windows). Кроме того, оттуда же советую скачать дополнительную библиотеку функций-утилит, позволяющую упростить работу в OpenGL (GLUT). Возможно, что Вам понравится какой-нибудь API более высокого уровня, типа SCiTech MGL (www.scitechsoft.com). [001220]
Назначение палитры Bitmap
Если вы рисуете на TImage....
Во-первых, вам нужно использовать Image1.Picture.bitmap, а не Image.Canvas. Причина кроется в том, что Image1.Picture.Bitmap имеет палитру, в Timage нет. Затем палитру необходимо назначить. Вот пример:
|
//Устанавливаем Width и Height перед использованием Image1.Picture c Bitmap Canvasvar Bitmap: TBitmap; begin Bitmap:=TBitmap.Create; Bitmap.LoadfromFile({'Whatever.bmp'}); With Image2.Picture.bitmap do Begin Width:=Bitmap.Width; height:=Bitmap.Height; Palette:=Bitmap.Palette; Canvas.draw(0,0,bitmap); Refresh; end; end; |
Если вы рисуете на канве формы...
| Canvas.Draw(0,0,Bitmap); SelectPalette(Form1.Canvas.handle,Bitmap.Palette,True); RealizePalette(Form1.Canvas.Handle); |
[001799]
Несколько программ для работы с точечной графикой (2D и 3D)
|
unit Functs; interface uses WinTypes, Classes, Graphics, SysUtils; type TPoint2D = record X, Y: Real; end; TPoint3D = record X, Y, Z: Real; end; function Point2D(X, Y: Real): TPoint2D; function RoundPoint(P: TPoint2D): TPoint; function FloatPoint(P: TPoint): TPoint2D; function Point3D(X, Y, Z: Real): TPoint3D; function Angle2D(P: TPoint2D): Real; function Dist2D(P: TPoint2D): Real; function Dist3D(P: TPoint3D): Real; function RelAngle2D(PA, PB: TPoint2D): Real; function RelDist2D(PA, PB: TPoint2D): Real; function RelDist3D(PA, PB: TPoint3D): Real; procedure Rotate2D(var P: TPoint2D; Angle2D: Real); procedure RelRotate2D(var P: TPoint2D; PCentr: TPoint2D; Angle2D: Real); procedure Move2D(var P: TPoint2D; Angle2D, Distance: Real); function Between(PA, PB: TPoint2D; Preference: Real): TPoint2D; function DistLine(A, B, C: Real; P: TPoint2D): Real; function Dist2P(P, P1, P2: TPoint2D): Real; function DistD1P(DX, DY: Real; P1, P: TPoint2D): Real; function NearLine2P(P, P1, P2: TPoint2D; D: Real): Boolean; function AddPoints(P1, P2: TPoint2D): TPoint2D; function SubPoints(P1, P2: TPoint2D): TPoint2D; function Invert(Col: TColor): TColor; function Dark(Col: TColor; Percentage: Byte): TColor; function Light(Col: TColor; Percentage: Byte): TColor; function Mix(Col1, Col2: TColor; Percentage: Byte): TColor; function MMix(Cols: array of TColor): TColor; function Log(Base, Value: Real): Real; function Modulator(Val, Max: Real): Real; function M(I, J: Integer): Integer; function Tan(Angle2D: Real): Real; procedure Limit(var Value: Integer; Min, Max: Integer); function Exp2(Exponent: Byte): Word; function GetSysDir: String; function GetWinDir: String; implementation function Point2D(X, Y: Real): TPoint2D; begin Point2D.X := X; Point2D.Y := Y; end; function RoundPoint(P: TPoint2D): TPoint; begin RoundPoint.X := Round(P.X); RoundPoint.Y := Round(P.Y); end; function FloatPoint(P: TPoint): TPoint2D; begin FloatPoint.X := P.X; FloatPoint.Y := P.Y; end; function Point3D(X, Y, Z: Real): TPoint3D; begin Point3D.X := X; Point3D.Y := Y; Point3D.Z := Z; end; function Angle2D(P: TPoint2D): Real; begin if P.X = 0 then begin if P.Y > 0 then Result := Pi / 2; if P.Y = 0 then Result := 0; if P.Y < 0 then Result := Pi / -2; end else Result := Arctan(P.Y / P.X); if P.X < 0 then begin if P.Y < 0 then Result := Result + Pi; if P.Y >= 0 then Result := Result - Pi; end; If Result < 0 then Result := Result + 2 * Pi; end; function Dist2D(P: TPoint2D): Real; begin Result := Sqrt(P.X * P.X + P.Y * P.Y); end; function Dist3D(P: TPoint3D): Real; begin Dist3d := Sqrt(P.X * P.X + P.Y * P.Y + P.Z * P.Z); end; function RelAngle2D(PA, PB: TPoint2D): Real; begin RelAngle2D := Angle2D(Point2D(PB.X - PA.X, PB.Y - PA.Y)); end; function RelDist2D(PA, PB: TPoint2D): Real; begin Result := Dist2D(Point2D(PB.X - PA.X, PB.Y - PA.Y)); end; function RelDist3D(PA, PB: TPoint3D): Real; begin RelDist3D := Dist3D(Point3D(PB.X - PA.X, PB.Y - PA.Y, PB.Z - PA.Z)); end; procedure Rotate2D(var P: TPoint2D; Angle2D: Real); var Temp: TPoint2D; begin Temp.X := P.X * Cos(Angle2D) - P.Y * Sin(Angle2D); Temp.Y := P.X * Sin(Angle2D) + P.Y * Cos(Angle2D); P := Temp; end; procedure RelRotate2D(var P: TPoint2D; PCentr: TPoint2D; Angle2D: Real); var Temp: TPoint2D; begin Temp := SubPoints(P, PCentr); Rotate2D(Temp, Angle2D); P := AddPoints(Temp, PCentr); end; procedure Move2D(var P: TPoint2D; Angle2D, Distance: Real); var Temp: TPoint2D; begin Temp.X := P.X + (Cos(Angle2D) * Distance); Temp.Y := P.Y + (Sin(Angle2D) * Distance); P := Temp; end; function Between(PA, PB: TPoint2D; Preference: Real): TPoint2D; begin Between.X := PA.X * Preference + PB.X * (1 - Preference); Between.Y := PA.Y * Preference + PB.Y * (1 - Preference); end; function DistLine(A, B, C: Real; P: TPoint2D): Real; begin Result := (A * P.X + B * P.Y + C) / Sqrt(Sqr(A) + Sqr(B)); end; function Dist2P(P, P1, P2: TPoint2D): Real; begin Result := DistLine(P1.Y - P2.Y, P2.X - P1.X, -P1.Y * P2.X + P1.X * P2.Y, P); end; function DistD1P(DX, DY: Real; P1, P: TPoint2D): Real; begin Result := DistLine(DY, -DX, -DY * P1.X + DX * P1.Y, P); end; function NearLine2P(P, P1, P2: TPoint2D; D: Real): Boolean; begin Result := False; if DistD1P(-(P2.Y - P1.Y), P2.X - P1.X, P1, P) * DistD1P(-(P2.Y - P1.Y), P2.X - P1.X, P2, P) <= 0 then if Abs(Dist2P(P, P1, P2)) < D then Result := True; end; function AddPoints(P1, P2: TPoint2D): TPoint2D; begin AddPoints := Point2D(P1.X + P2.X, P1.Y + P2.Y); end; function SubPoints(P1, P2: TPoint2D): TPoint2D; begin SubPoints := Point2D(P1.X - P2.X, P1.Y - P2.Y); end; function Invert(Col: TColor): TColor; begin Invert := not Col; end; function Dark(Col: TColor; Percentage: Byte): TColor; var R, G, B: Byte; begin R := GetRValue(Col); G := GetGValue(Col); B := GetBValue(Col); R := Round(R * Percentage / 100); G := Round(G * Percentage / 100); B := Round(B * Percentage / 100); Dark := RGB(R, G, B); end; function Light(Col: TColor; Percentage: Byte): TColor; var R, G, B: Byte; begin R := GetRValue(Col); G := GetGValue(Col); B := GetBValue(Col); R := Round(R * Percentage / 100) + Round(255 - Percentage / 100 * 255); G := Round(G * Percentage / 100) + Round(255 - Percentage / 100 * 255); B := Round(B * Percentage / 100) + Round(255 - Percentage / 100 * 255); Light := RGB(R, G, B); end; function Mix(Col1, Col2: TColor; Percentage: Byte): TColor; var R, G, B: Byte; begin R := Round((GetRValue(Col1) * Percentage / 100) + (GetRValue(Col2) * (100 - Percentage) / 100)); G := Round((GetGValue(Col1) * Percentage / 100) + (GetGValue(Col2) * (100 - Percentage) / 100)); B := Round((GetBValue(Col1) * Percentage / 100) + (GetBValue(Col2) * (100 - Percentage) / 100)); Mix := RGB(R, G, B); end; function MMix(Cols: array of TColor): TColor; var I, R, G, B, Length: Integer; begin Length := High(Cols) - Low(Cols) + 1; R := 0; G := 0; B := 0; for I := Low(Cols) to High(Cols) do begin R := R + GetRValue(Cols[I]); G := G + GetGValue(Cols[I]); B := B + GetBValue(Cols[I]); end; R := R div Length; G := G div Length; B := B div Length; MMix := RGB(R, G, B); end; function Log(Base, Value: Real): Real; begin Log := Ln(Value) / Ln(Base); end; function Power(Base, Exponent: Real): Real; begin Power := Ln(Base) * Exp(Exponent); end; function Modulator(Val, Max: Real): Real; begin Modulator := (Val / Max - Round(Val / Max)) * Max; end; function M(I, J: Integer): Integer; begin M := ((I mod J) + J) mod J; end; function Tan(Angle2D: Real): Real; begin Tan := Sin(Angle2D) / Cos(Angle2D); end; procedure Limit(var Value: Integer; Min, Max: Integer); begin if Value < Min then Value := Min; if Value > Max then Value := Max; end; function Exp2(Exponent: Byte): Word; var Temp, I: Word; begin Temp := 1; for I := 1 to Exponent do Temp := Temp * 2; Result := Temp; end; function GetSysDir: String; var Temp: array[0..255] of Char; begin GetSystemDirectory(Temp, 256); Result := StrPas(Temp); end; function GetWinDir: String; var Temp: array[0..255] of Char; begin GetWindowsDirectory(Temp, 256); Result := StrPas(Temp); end; end. |
[000120]
Отображение ломанной линии
Как мне вывести ломанную линию на холсте, если я не знаю размер массива (количество точек) до момента запуска программы??? По-моему, это невозможно. Просветите меня!
Недавно я решал аналогичную проблему при кодировании ReportPrinter и не нашел хорошего решения для создания открытого массива параметров заданного размера. Решение, которое я, наконец, использовал, заключалось в хитрой комбинации функции polyline и polygon с ассемблерным кодом. Я публикую исходный код, поскольку думаю что он будет полезен, пока Borland не создаст стандартные и простые методы для работы с массивами заданного размера.
|
type
PPointArr = ^TPointArr;
TPointArr = array[0..16380] of TPoint;
var I1: integer; Elements: word; PointArr: PPointArr; begin GetMem(PointArr,(Elements + 1) * SizeOf(TPoint)); try For I1 := 0 to Elements do begin PointArr^[I1].X := ReadNextXValue; PointArr^[I1].Y := ReadNextYValue; end; { for } { Вызов Polygon(PointArr^), но только с Elements+1-элеменами в открытом массиве } asm les di,PointArr { Помещаем указатель на PointArr } push es push di push Elements { Помещаем High(PointArr^) } les di,self { Помещаем указатель self } push es push di les di,es:[di] { Вызов self.Polygon } call Polygon end; { asm } finally FreeMem(PointArr,(Elements + 1) * SizeOf(TPoint)); end; { try } end; |
Надеюсь это поможет.
Jim Gunkel
Nevrona Designs
[000717]
Получение DC элемента управления
|
{Bitmap в TImage} HDC:=Image1.PICTURE.bitmap.canvas.handle; |
DC - что-нибудь с Canvas.handle. [001815]
Получение контекста устройства для элемента управления
|
{Bitmap в TImage} HDC := TImage.Picture.bitmap.canvas.handle; |
DC - что нибудь с Canvas.handle. [001521]
Поворот изображения на 90 градусов
Новый модуль имеет три программы: RotateBitmap90DegreesClockwise, RotateBitmap90DegreesCounterClockwise, и RotateBitmap180Degrees. Все три используют TBitmap как переменную и вращают его согласно своему названию.
Два предостережения: Это все еще не совсем работает в Delphi3. Появляется какой-то шум на краях изображения. Мне кажется это из-за какой-то ошибки в методе LoadFromStream объекта TBitmap, но это может быть и моей ошибкой. Тем не менее есть другие решения, связанные с использованием свойства ScanLine, так что эта проблема решается. Во-вторых, этот алгоритм не работает с сжатыми RLE-алгоритмом изображениями. 4- и 8-битные (по разрешению) изображения могут быть декодированы и хранится в памяти: на случай, если они потребуются, у нас есть их дескриптор. К тому же, если изображение сжато, можно просто получить дескриптор канвы с нормальным изображением:
| ABitmap.Canvas.Handle; |
Этим мы также назначаем контекст устройства (то есть экрана), и, вероятно, сможем обрабатывать изображения вплоть до 24-битного формата. Что-то вроде компромисного решения.
Во всяком случае это работает у меня в Delphi 1 и 2 с черно-белыми, 4-, 8-, 16-, 24-, и 32-битными изображениями (но не с 4- и 8-битными изображениями, сжатыми RLE-алгоритмом, как я уже говорил выше).
|
unit bmpRot; interface uses (*$IFDEF Win32*) Windows, (*$ELSE*) WinTypes, WinProcs, (*$ENDIF*) Classes, Graphics; procedure RotateBitmap90DegreesCounterClockwise(var ABitmap: TBitmap); procedure RotateBitmap90DegreesClockwise(var ABitmap: TBitmap); procedure RotateBitmap180Degrees(var ABitmap: TBitmap); implementation uses Dialogs; (*$IFNDEF Win32*) type DWORD = LongInt; TSelOfs = record L, H: Word; end; procedure Win16Dec(var P: Pointer; const N: LongInt); forward; procedure Win16Inc(var P: Pointer; const N: LongInt); begin if N < 0 then Win16Dec(P, -N) else if N > 0 then begin Inc( TSelOfs(P).H, TSelOfs(N).H * SelectorInc ); Inc( TSelOfs(P).L, TSelOfs(N).L ); if TSelOfs(P).L < TSelOfs(N).L then Inc( TSelOfs(P).H, SelectorInc ); end; end; procedure Win16Dec(var P: Pointer; const N: LongInt); begin if N < 0 then Win16Inc(P, -N) else if N > 0 then begin if TSelOfs(N).L > TSelOfs(P).L then Dec( TSelOfs(P).H, SelectorInc ); Dec( TSelOfs(P).L, TSelOfs(N).L ); Dec( TSelOfs(P).H, TSelOfs(N).H * SelectorInc ); end; end; (* procedure HugeShift; far; external 'KERNEL' index 113; procedure Win16Dec(var P: Pointer; const N: LongInt); forward; procedure Win16Inc(var HugePtr: Pointer; Amount: LongInt); procedure HugeInc; assembler; asm mov ax, Amount.Word[0] { Сохраняем сумму в DX:AX. } mov dx, Amount.Word[2] les bx, HugePtr { Получаем ссылку на HugePtr. } add ax, es:[bx] { Добавление коррекции. } adc dx, 0 { Распространяем перенос на наибольшую величину суммы. } mov cx, Offset HugeShift shl dx, { Перемещаем наибольшую величину суммы для сегмента. } add es:[bx+2], dx { Увеличиваем сегмент HugePtr. } mov es:[bx], ax end; begin if Amount > 0 then HugeInc else if Amount < 0 then Win16Dec(HugePtr, -Amount); end; procedure Win16Dec(var P: Pointer; const N: LongInt); begin if N < 0 then Win16Inc(P, -N) else if N > 0 then begin if TSelOfs(N).L > TSelOfs(P).L then Dec( TSelOfs(P).H, SelectorInc ); Dec( TSelOfs(P).L, TSelOfs(N).L ); Dec( TSelOfs(P).H, TSelOfs(N).H * SelectorInc ); end; end; *) (*$ENDIF*) procedure RotateBitmap90DegreesCounterClockwise(var ABitmap: TBitmap); const BitsPerByte = 8; var { Целая куча переменных. Некоторые имеют дело только с одно- и четырех-битовыми изображениями, другие только с восемью- и 24-битовыми, а некоторые с обоими. Любая переменная, оканчивающаяся символом 'R', имеет отношение к вращению изображения, например если MemoryStream содержит исходное изображение, то MemoryStreamR - повернутое. } PbmpInfoR: PBitmapInfoHeader; bmpBuffer, bmpBufferR: PByte; MemoryStream, MemoryStreamR: TMemoryStream; PbmpBuffer, PbmpBufferR: PByte; BytesPerPixel, PixelsPerByte: LongInt; BytesPerScanLine, BytesPerScanLineR: LongInt; PaddingBytes: LongInt; BitmapOffset: LongInt; BitCount: LongInt; WholeBytes, ExtraPixels: LongInt; SignificantBytes, SignificantBytesR: LongInt; ColumnBytes: LongInt; AtLeastEightBitColor: Boolean; T: LongInt; procedure NonIntegralByteRotate; (* вложение *) { Эта программа осуществляет поворот изображений с разрешением меньшим, чем 8 бит на пиксел, а имеено: черно-белые (1-бит) и 16-цветные (4-бит) изображения. Имейте в виду, что такие вещи, как 2-битные изображения также могли бы вращаться, но Microsoft не включил данный формат в свои спецификации и не поддерживает его. } var X, Y: LongInt; I: LongInt; MaskBits, CurrentBits: Byte; FirstMask, LastMask: Byte; PFirstScanLine: PByte; FirstIndex, CurrentBitIndex: LongInt; ShiftRightAmount, ShiftRightStart: LongInt; begin (*$IFDEF Win32*) Inc(PbmpBuffer, BytesPerScanLine * (PbmpInfoR^.biHeight - 1) ); (*$ELSE*) Win16Inc( Pointer(PbmpBuffer), BytesPerScanLine * (PbmpInfoR^.biHeight - 1) ); (*$ENDIF*) { PFirstScanLine движется вдоль первой линии чередования bmpBufferR. } PFirstScanLine := bmpBufferR; { Устанавливаем индексирование. } FirstIndex := BitsPerByte - BitCount; { Устанавливаем битовые маски: Для черно-белого изображения, LastMask := 00000001 и FirstMask := 10000000 Для 4-битного изображения, LastMask := 00001111 и FirstMask := 11110000 Зададим значения CurrentBits и MaskBits, так как мы будем перемещаться по ним: Для монохромных изображений: 10000000, 01000000, 00100000, 00010000, 00001000, 00000100, 00000010, 00000001 Для 4-битных изображений: 11110000, 00001111 CurrentBitIndex определяет расстояние от крайнего правого бита до позиции CurrentBits. Например, если мы находимся в одиннадцатой колонке черно-белого изображения, CurrentBits равен 11 mod 8 := 3, или 3-й самый левый бит. Таким образом, крайне правый бит должен переместиться на четыре позиции, чтобы попасть на позицию CurrentBits. CurrentBitIndex как раз и хранит такое значение. } LastMask := 1 shl BitCount - 1; FirstMask := LastMask shl FirstIndex; CurrentBits := FirstMask; CurrentBitIndex := FirstIndex; ShiftRightStart := BitCount * (PixelsPerByte - 1); { Вот мясо. Перебираем в цикле все пиксели и соответственно вращаем. } { Помните что DIB'ы имеют происхождение противоположное DDB'сам. } { Счетчик Y указывает на текущую строчку исходного изображения. } for Y := 1 to PbmpInfoR^.biHeight do begin PbmpBufferR := PFirstScanLine; { Счетчик X указывает на текущую колонку пикселей исходного изображения. Здесь мы имеем дело только с полностью заполненными байтами. Обработка 'частично заполненных' байтов происходит ниже. } for X := 1 to WholeBytes do begin { Выбираем биты, начиная с 10000000 для черно-белых и заканчивая 11110000 для 4-битных изображений. } MaskBits := FirstMask; { ShiftRightAmount - сумма, необходимая для перемещения текущего байта через весь путь (помните, я об этом говорил выше) в правую часть. } ShiftRightAmount := ShiftRightStart; for I := 1 to PixelsPerByte do begin { Вот гарнир. Берем текущий байт вращаемого изображения и маскируем его с not CurrentBits. Гасятся нулями только биты CurrentBits, сам байт перемещается без изменений. Пример: Для черно-белого изображения, если бы мы находились в 11-й колонке (см. пример выше), мы должны нулем погасить 3-й слева бит, то есть мы должны использовать PbmpBufferR^ и 11011111. Теперь рассмотрим наш текущий исходный байт. Для черно-белых изображений мы организуем цикл с шагом через бит, в общей сложности для восьми пикселей. Для 4-битных изображений мы делаем цикл с обработкой четырех битов за проход для двух пикселей. В любом случае мы делаем это через маскирование с MaskBits ('PbmpBuffer^ и MaskBits'). Теперь нам нужно получить бит(ы) из той колонки(ок), на которую отобразится CurrentBits. Мы это делаем с помощью перемещения их в крайне правую часть байта ('shr ShiftRightAmount'), затем сдвигая их налево с помощью вышеупомянутого CurrentBitIndex ('shl CurrentBitIndex'). Дело в том, что хотя перемещение вправо с параметром -n должно быть просто перемещением налево с параметром +n, в Delphi это не работает. Итак, мы начинаем с первого байта, перемещая пиксели в правую часть насколько это возможно незанятыми позициями. Наконец, мы имеем наш исходный бит(ы), перемещенный на нужное место с погашенными нулями битами. Последнее делаем непосредственно или с помощью PbmpBufferR^ (гасим биты в CurrentBits, помните?). Мда... "Просто". Ладно, поехали дальше. } PbmpBufferR^ := ( PbmpBufferR^ and not CurrentBits ) or ( (PbmpBuffer^ and MaskBits) shr ShiftRightAmount shl CurrentBitIndex ); { Сдвигаем MaskBits для следующей итерации. } MaskBits := MaskBits shr BitCount; (*$IFDEF Win32*) { Перемещаем наш указатель на буфер вращаемого изображения на одну линию чередования. } Inc(PbmpBufferR, BytesPerScanLineR); { Нам не нужно перемещаться непосредственно вправо в течение некоторого времени. } Dec(ShiftRightAmount, BitCount); (*$ELSE*) Win16Inc( Pointer(PbmpBufferR), BytesPerScanLineR ); Win16Dec( Pointer(ShiftRightAmount), BitCount ); (*$ENDIF*) end; (*$IFDEF Win32*) Inc(PbmpBuffer); (*$ELSE*) Win16Inc( Pointer(PbmpBuffer), 1 ); (*$ENDIF*) end; { Если есть "частично заполненный" байт, самое время о нем позаботиться. } if ExtraPixels <> 0 then begin { Делаем такие же манипуляции, как в цикле выше. } MaskBits := FirstMask; ShiftRightAmount := ShiftRightStart; for I := 1 to ExtraPixels do begin PbmpBufferR^ := ( PbmpBufferR^ and not CurrentBits ) or ( (PbmpBuffer^ and MaskBits) shr ShiftRightAmount shl CurrentBitIndex ); MaskBits := MaskBits shr BitCount; (*$IFDEF Win32*) Inc(PbmpBufferR, BytesPerScanLineR); (*$ELSE*) Win16Inc( Pointer(PbmpBufferR), BytesPerScanLineR ); (*$ENDIF*) Dec(ShiftRightAmount, BitCount); end; (*$IFDEF Win32*) Inc(PbmpBuffer); (*$ELSE*) Win16Inc( Pointer(PbmpBuffer), 1 ); (*$ENDIF*) end; (*$IFDEF Win32*) { Пропускаем заполнение. } Inc(PbmpBuffer, PaddingBytes); { Сохраняем только что просмотренную линию чередования и переходим к следующей для получения набора очередной строки. } Dec(PbmpBuffer, BytesPerScanLine shl 1); (*$ELSE*) Win16Inc( Pointer(PbmpBuffer), PaddingBytes ); Win16Dec( Pointer(PbmpBuffer), BytesPerScanLine shl 1 ); (*$ENDIF*) if CurrentBits = LastMask then begin { Мы в конце этого байта. Начинаем с другой колонки. } CurrentBits := FirstMask; CurrentBitIndex := FirstIndex; { Идем вниз колонки вращаемого изображения , но одну колонку пропускаем. } (*$IFDEF Win32*) Inc(PFirstScanLine); (*$ELSE*) Win16Inc( Pointer(PFirstScanLine), 1 ); (*$ENDIF*) end else begin { Продолжаем заполнять этот байт. } CurrentBits := CurrentBits shr BitCount; Dec(CurrentBitIndex, BitCount); end; end; end; { procedure NonIntegralByteRotate (* вложение *) } procedure IntegralByteRotate; (* вложение *) var X, Y: LongInt; (*$IFNDEF Win32*) I: Integer; (*$ENDIF*) begin { Перемещаем PbmpBufferR в последнюю колонку первой линии чередования bmpBufferR. } (*$IFDEF Win32*) Inc(PbmpBufferR, SignificantBytesR - BytesPerPixel); (*$ELSE*) Win16Inc( Pointer(PbmpBufferR), SignificantBytesR - BytesPerPixel ); (*$ENDIF*) { Вот мясо. Перебираем в цикле все пиксели и соответственно вращаем. } { Помните что DIB'ы имеют происхождение противоположное DDB'сам. } for Y := 1 to PbmpInfoR^.biHeight do begin for X := 1 to PbmpInfoR^.biWidth do begin { Копируем пиксели. } (*$IFDEF Win32*) Move(PbmpBuffer^, PbmpBufferR^, BytesPerPixel); Inc(PbmpBuffer, BytesPerPixel); Inc(PbmpBufferR, BytesPerScanLineR); (*$ELSE*) for I := 1 to BytesPerPixel do begin PbmpBufferR^ := PbmpBuffer^; Win16Inc( Pointer(PbmpBuffer), 1 ); Win16Inc( Pointer(PbmpBufferR), 1 ); end; Win16Inc( Pointer(PbmpBufferR), BytesPerScanLineR - BytesPerPixel); (*$ENDIF*) end; (*$IFDEF Win32*) { Пропускаем заполнение. } Inc(PbmpBuffer, PaddingBytes); { Идем вверх колонки вращаемого изображения , но одну колонку пропускаем. } Dec(PbmpBufferR, ColumnBytes + BytesPerPixel); (*$ELSE*) Win16Inc( Pointer(PbmpBuffer), PaddingBytes); Win16Dec( Pointer(PbmpBufferR), ColumnBytes + BytesPerPixel); (*$ENDIF*) end; end; { Это тело процедуры RotateBitmap90DegreesCounterClockwise. } begin { Никогда сами не вызывайте GetDIBSizes! Это испортит ваше изображение. } MemoryStream := TMemoryStream.Create; { Для работы: Прежде всего установим размер. Это устранит перераспределение памяти для MemoryStream. Вызов GetDIBSizes будет к месту, но, как отмечалось выше, это может исказить ваше изображение. Вызов некоторых API функций вероятно позаботился бы об этом, но это тема отдельного разговора. } { Недокументированный метод. Все же программист иногда сродни шаману. } ABitmap.SaveToStream(MemoryStream); { Изображение больше не нужно. Создадим новое когда понадобится. } ABitmap.Free; bmpBuffer := MemoryStream.Memory; { Получаем биты компенсации. Они могут содержать информацию о палитре. } BitmapOffset := PBitmapFileHeader(bmpBuffer)^.bfOffBits; { Устанавливаем PbmpInfoR на указатель информационного заголовка исходного изображения. } { Эти заголовки могут немного раздражать, но они необходимы для работы. } (*$IFDEF Win32*) Inc( bmpBuffer, SizeOf(TBitmapFileHeader) ); (*$ELSE*) Win16Inc( Pointer(bmpBuffer), SizeOf(TBitmapFileHeader) ); (*$ENDIF*) PbmpInfoR := PBitmapInfoHeader(bmpBuffer); { Устанавливаем bmpBuffer и PbmpBuffer так, чтобы они указывали на биты оригинального изображения. } bmpBuffer := MemoryStream.Memory; (*$IFDEF Win32*) Inc(bmpBuffer, BitmapOffset); (*$ELSE*) Win16Inc( Pointer(bmpBuffer), BitmapOffset ); (*$ENDIF*) PbmpBuffer := bmpBuffer; { Имейте в виду, что нам не нужно беспокоиться о совместимости изображений версии 4 и 3, поскольку области, которые мы используем, а именно -- biWidth, biHeight, и biBitCount -- располагаются на один и тех же местах в обоих структурах. Итак, одной проблемой меньше. Изображения версии OS/2, между прочим, при этом гнусно рушатся. Обидно. } with PbmpInfoR^ do begin { ShowMessage('Компрессия := ' + IntToStr(biCompression)); } BitCount := biBitCount; { ShowMessage('BitCount := ' + IntToStr(BitCount)); } { ScanLines - "выровненный" DWORD. } BytesPerScanLine := ((((biWidth * BitCount) + 31) div 32) * SizeOf(DWORD)); BytesPerScanLineR := ((((biHeight * BitCount) + 31) div 32) * SizeOf(DWORD)); AtLeastEightBitColor := BitCount >= BitsPerByte; if AtLeastEightBitColor then begin { Нас не должен волновать бит-тильда. Классно. } BytesPerPixel := biBitCount shr 3; SignificantBytes := biWidth * BitCount shr 3; SignificantBytesR := biHeight * BitCount shr 3; { Дополнительные байты необходимы для выравнивания DWORD. } PaddingBytes := BytesPerScanLine - SignificantBytes; ColumnBytes := BytesPerScanLineR * biWidth; end else begin { Одно- или четырех-битовое изображение. Уфф. } PixelsPerByte := SizeOf(Byte) * BitsPerByte div BitCount; { Все количество байтов полностью заполняется информацией о пикселе. } WholeBytes := biWidth div PixelsPerByte; { Обрабатываем любые дополнительные биты, которые могут частично заполнять байт. Например, черно-белое изображение, у которого 14 пикселей описываются каждый соответственно своим байтом, плюс одним дополнительным, у которого на самом деле используются 6 битов, остальное мусор. } ExtraPixels := biWidth mod PixelsPerByte; { Все дополнительные байты -- если имеются -- требуется DWORD-выровнять по линии чередования. } PaddingBytes := BytesPerScanLine - WholeBytes; { Если есть дополнительные биты (то есть имеется 'дополнительный байт'), то один из заполненных байтов уже был принят во внимание. } if ExtraPixels <> 0 then Dec(PaddingBytes); end; { if AtLeastEightBitColor then } { TMemoryStream, обслуживающий вращаемые биты. } MemoryStreamR := TMemoryStream.Create; { Устанавливаем размер вращаемого изображения. Может отличаться от исходного из-за выравнивания DWORD. } MemoryStreamR.SetSize(BitmapOffset + BytesPerScanLineR * biWidth); end; { with PbmpInfoR^ do } { Копируем заголовки исходного изображения. } MemoryStream.Seek(0, soFromBeginning); MemoryStreamR.CopyFrom(MemoryStream, BitmapOffset); { Вот буфер, который мы будем "вращать". } bmpBufferR := MemoryStreamR.Memory; { Пропускаем заголовки, yadda yadda yadda... } (*$IFDEF Win32*) Inc(bmpBufferR, BitmapOffset); (*$ELSE*) Win16Inc( Pointer(bmpBufferR), BitmapOffset ); (*$ENDIF*) PbmpBufferR := bmpBufferR; { Едем дальше. } if AtLeastEightBitColor then IntegralByteRotate else NonIntegralByteRotate; { Удовлетворяемся исходными битами. } MemoryStream.Free; { Теперь устанавливаем PbmpInfoR, чтобы он указывал на информационный заголовок вращаемого изображения. } PbmpBufferR := MemoryStreamR.Memory; (*$IFDEF Win32*) Inc( PbmpBufferR, SizeOf(TBitmapFileHeader) ); (*$ELSE*) Win16Inc( Pointer(PbmpBufferR), SizeOf(TBitmapFileHeader) ); (*$ENDIF*) PbmpInfoR := PBitmapInfoHeader(PbmpBufferR); { Меняем ширину с высотой в информационном заголовке вращаемого изображения. } with PbmpInfoR^ do begin T := biHeight; biHeight := biWidth; biWidth := T; biSizeImage := 0; end; ABitmap := TBitmap.Create; { Вращение с самого начала. } MemoryStreamR.Seek(0, soFromBeginning); { Загружаем это снова в ABitmap. } ABitmap.LoadFromStream(MemoryStreamR); MemoryStreamR.Free; end; procedure RotateBitmap90DegreesClockwise(var ABitmap: TBitmap); const BitsPerByte = 8; var { Целая куча переменных. Некоторые имеют дело только с одно- и четырех-битовыми изображениями, другие только с восемью- и 24-битовыми, а некоторые с обоими. Любая переменная, оканчивающаяся символом 'R', имеет отношение к вращению изображения, например если MemoryStream содержит исходное изображение, то MemoryStreamR - повернутое. } PbmpInfoR: PBitmapInfoHeader; bmpBuffer, bmpBufferR: PByte; MemoryStream, MemoryStreamR: TMemoryStream; PbmpBuffer, PbmpBufferR: PByte; BytesPerPixel, PixelsPerByte: LongInt; BytesPerScanLine, BytesPerScanLineR: LongInt; PaddingBytes: LongInt; BitmapOffset: LongInt; BitCount: LongInt; WholeBytes, ExtraPixels: LongInt; SignificantBytes: LongInt; ColumnBytes: LongInt; AtLeastEightBitColor: Boolean; T: LongInt; procedure NonIntegralByteRotate; (* вложение *) { Эта программа осуществляет поворот изображений с разрешением меньшим, чем 8 бит на пиксел, а имеено: черно-белые (1-бит) и 16-цветные (4-бит) изображения. Имейте в виду, что такие вещи, как 2-битные изображения также могли бы вращаться, но Microsoft не включил данный формат в свои спецификации и не поддерживает его. } var X, Y: LongInt; I: LongInt; MaskBits, CurrentBits: Byte; FirstMask, LastMask: Byte; PLastScanLine: PByte; FirstIndex, CurrentBitIndex: LongInt; ShiftRightAmount, ShiftRightStart: LongInt; begin { Перемещаем PLastScanLine в первую колонку последней линии чередования bmpBufferR. } PLastScanLine := bmpBufferR; (*$IFDEF Win32*) Inc(PLastScanLine, BytesPerScanLineR * (PbmpInfoR^.biWidth - 1) ); (*$ELSE*) Win16Inc( Pointer(PLastScanLine), BytesPerScanLineR * (PbmpInfoR^.biWidth - 1) ); (*$ENDIF*) { Устанавливаем индексирование. } FirstIndex := BitsPerByte - BitCount; { Устанавливаем битовые маски: Для черно-белого изображения, LastMask := 00000001 и FirstMask := 10000000 Для 4-битного изображения, LastMask := 00001111 и FirstMask := 11110000 Зададим значения CurrentBits и MaskBits, так как мы будем перемещаться по ним: Для черно-белых изображений: 10000000, 01000000, 00100000, 00010000, 00001000, 00000100, 00000010, 00000001 Для 4-битных изображений: 11110000, 00001111 CurrentBitIndex определяет расстояние от крайнего правого бита до позиции CurrentBits. Например, если мы находимся в одиннадцатой колонке черно-белого изображения, CurrentBits равен 11 mod 8 := 3, или 3-й самый левый бит. Таким образом, крайне правый бит должен переместиться на четыре позиции, чтобы попасть на позицию CurrentBits. CurrentBitIndex как раз и хранит такое значение. } LastMask := 1 shl BitCount - 1; FirstMask := LastMask shl FirstIndex; CurrentBits := FirstMask; CurrentBitIndex := FirstIndex; ShiftRightStart := BitCount * (PixelsPerByte - 1); { Вот мясо. Перебираем в цикле все пиксели и соответственно вращаем. } { Помните что DIB'ы имеют происхождение противоположное DDB'сам. } { Счетчик Y указывает на текущую строчку исходного изображения. } for Y := 1 to PbmpInfoR^.biHeight do begin PbmpBufferR := PLastScanLine; { Счетчик X указывает на текущую колонку пикселей исходного изображения. Здесь мы имеем дело только с полностью заполненными байтами. Обработка 'частично заполненных' байтов происходит ниже. } for X := 1 to WholeBytes do begin { Выбираем биты, начиная с 10000000 для черно-белых и заканчивая 11110000 для 4-битных изображений. } MaskBits := FirstMask; { ShiftRightAmount - сумма, необходимая для перемещения текущего байта через весь путь (помните, я об этом говорил выше) в правую часть. } ShiftRightAmount := ShiftRightStart; for I := 1 to PixelsPerByte do begin { Вот гарнир. Берем текущий байт вращаемого изображения и маскируем его с not CurrentBits. Гасятся нулями только биты CurrentBits, сам байт перемещается без изменений. Пример: Для черно-белого изображения, если бы мы находились в 11-й колонке (см. пример выше), мы должны нулем погасить 3-й слева бит, то есть мы должны использовать PbmpBufferR^ и 11011111. Теперь рассмотрим наш текущий исходный байт. Для черно-белых изображений мы организуем цикл с шагом через бит, в общей сложности для восьми пикселей. Для 4-битных изображений мы делаем цикл с обработкой четырех битов за проход для двух пикселей. В любом случае мы делаем это через маскирование с MaskBits ('PbmpBuffer^ и MaskBits'). Теперь нам нужно получить бит(ы) из той колонки(ок), на которую отобразится CurrentBits. Мы это делаем с помощью перемещения их в крайне правую часть байта ('shr ShiftRightAmount'), затем сдвигая их налево с помощью вышеупомянутого CurrentBitIndex ('shl CurrentBitIndex'). Дело в том, что хотя перемещение вправо с параметром -n должно быть просто перемещением налево с параметром +n, в Delphi это не работает. Итак, мы начинаем с первого байта, перемещая пиксели в правую часть насколько это возможно незанятыми позициями. Наконец, мы имеем наш исходный бит(ы), перемещенный на нужное место с погашенными нулями битами. Последнее делаем непосредственно или с помощью PbmpBufferR^ (гасим биты в CurrentBits, помните?). Мда... "Просто". Ладно, поехали дальше. } PbmpBufferR^ := ( PbmpBufferR^ and not CurrentBits ) or ( (PbmpBuffer^ and MaskBits) shr ShiftRightAmount shl CurrentBitIndex ); { Сдвигаем MaskBits для следующей итерации. } MaskBits := MaskBits shr BitCount; (*$IFDEF Win32*) { Перемещаем наш указатель на буфер вращаемого изображения на одну линию чередования. } Dec(PbmpBufferR, BytesPerScanLineR); (*$ELSE*) Win16Dec( Pointer(PbmpBufferR), BytesPerScanLineR ); (*$ENDIF*) { Нам не нужно перемещаться непосредственно вправо в течение некоторого времени. } Dec(ShiftRightAmount, BitCount); end; (*$IFDEF Win32*) Inc(PbmpBuffer); (*$ELSE*) Win16Inc( Pointer(PbmpBuffer), 1 ); (*$ENDIF*) end; { Если есть "частично заполненный" байт, самое время о нем позаботиться. } if ExtraPixels <> 0 then begin { Делаем такие же манипуляции, как в цикле выше. } MaskBits := FirstMask; ShiftRightAmount := ShiftRightStart; for I := 1 to ExtraPixels do begin PbmpBufferR^ := ( PbmpBufferR^ and not CurrentBits ) or ( (PbmpBuffer^ and MaskBits) shr ShiftRightAmount shl CurrentBitIndex ); MaskBits := MaskBits shr BitCount; (*$IFDEF Win32*) Dec(PbmpBufferR, BytesPerScanLineR); (*$ELSE*) Win16Dec( Pointer(PbmpBufferR), BytesPerScanLineR ); (*$ENDIF*) Dec(ShiftRightAmount, BitCount); end; (*$IFDEF Win32*) Inc(PbmpBuffer); (*$ELSE*) Win16Inc( Pointer(PbmpBuffer), 1 ); (*$ENDIF*) end; { Пропускаем заполнение. } (*$IFDEF Win32*) Inc(PbmpBuffer, PaddingBytes); (*$ELSE*) Win16Inc( Pointer(PbmpBuffer), PaddingBytes ); (*$ENDIF*) if CurrentBits = LastMask then begin { Мы в конце этого байта. Начинаем с другой колонки. } CurrentBits := FirstMask; CurrentBitIndex := FirstIndex; { Идем вниз колонки вращаемого изображения , но одну колонку пропускаем. } (*$IFDEF Win32*) Inc(PLastScanLine); (*$ELSE*) Win16Inc( Pointer(PLastScanLine), 1 ); (*$ENDIF*) end else begin { Продолжаем заполнять этот байт. } CurrentBits := CurrentBits shr BitCount; Dec(CurrentBitIndex, BitCount); end; end; end; { procedure NonIntegralByteRotate (* вложение *) } procedure IntegralByteRotate; (* вложение *) var X, Y: LongInt; (*$IFNDEF Win32*) I: Integer; (*$ENDIF*) begin { Перемещаем PbmpBufferR в первую колонку последней линии чередования bmpBufferR. } (*$IFDEF Win32*) Inc( PbmpBufferR, BytesPerScanLineR * (PbmpInfoR^.biWidth - 1) ); (*$ELSE*) Win16Inc( Pointer(PbmpBufferR) , BytesPerScanLineR * (PbmpInfoR^.biWidth - 1) ); (*$ENDIF*) { Вот мясо. Перебираем в цикле все пиксели и соответственно вращаем. } { Remember that DIBs have their origins opposite from DDBs. } for Y := 1 to PbmpInfoR^.biHeight do begin for X := 1 to PbmpInfoR^.biWidth do begin { Копируем пиксели. } (*$IFDEF Win32*) Move(PbmpBuffer^, PbmpBufferR^, BytesPerPixel); Inc(PbmpBuffer, BytesPerPixel); Dec(PbmpBufferR, BytesPerScanLineR); (*$ELSE*) for I := 1 to BytesPerPixel do begin PbmpBufferR^ := PbmpBuffer^; Win16Inc( Pointer(PbmpBuffer), 1 ); Win16Inc( Pointer(PbmpBufferR), 1 ); end; Win16Dec( Pointer(PbmpBufferR), BytesPerScanLineR + BytesPerPixel); (*$ENDIF*) end; (*$IFDEF Win32*) { Пропускаем заполнение. } Inc(PbmpBuffer, PaddingBytes); { Идем вверх колонки вращаемого изображения , но одну колонку пропускаем. } Inc(PbmpBufferR, ColumnBytes + BytesPerPixel); (*$ELSE*) Win16Inc( Pointer(PbmpBuffer), PaddingBytes ); Win16Inc( Pointer(PbmpBufferR), ColumnBytes + BytesPerPixel ); (*$ENDIF*) end; end; { Это тело процедуры RotateBitmap90DegreesCounterClockwise. } begin { Никогда сами не вызывайте GetDIBSizes! Это испортит ваше изображение. } MemoryStream := TMemoryStream.Create; { Для работы: Прежде всего установим размер. Это устранит перераспределение памяти для MemoryStream. Вызов GetDIBSizes будет к месту, но, как отмечалось выше, это может исказить ваше изображение. Вызов некоторых API функций вероятно позаботился бы об этом, но это тема отдельного разговора. } { Недокументированный метод. Все же программист иногда сродни шаману. } ABitmap.SaveToStream(MemoryStream); { Don't need you anymore. We'll make a new one when the time comes. } ABitmap.Free; bmpBuffer := MemoryStream.Memory; { Get the offset bits. This may or may not include palette information. } BitmapOffset := PBitmapFileHeader(bmpBuffer)^.bfOffBits; { Устанавливаем PbmpInfoR на указатель информационного заголовка исходного изображения. } { Эти заголовки могут немного раздражать, но они необходимы для работы. } (*$IFDEF Win32*) Inc( bmpBuffer, SizeOf(TBitmapFileHeader) ); (*$ELSE*) Win16Inc( Pointer(bmpBuffer), SizeOf(TBitmapFileHeader) ); (*$ENDIF*) PbmpInfoR := PBitmapInfoHeader(bmpBuffer); { Устанавливаем bmpBuffer и PbmpBuffer так, чтобы они указывали на биты оригинального изображения. } bmpBuffer := MemoryStream.Memory; (*$IFDEF Win32*) Inc(bmpBuffer, BitmapOffset); (*$ELSE*) Win16Inc( Pointer(bmpBuffer), BitmapOffset ); (*$ENDIF*) PbmpBuffer := bmpBuffer; { Имейте в виду, что нам не нужно беспокоиться о совместимости изображений версии 4 и 3, поскольку области, которые мы используем, а именно -- biWidth, biHeight, и biBitCount -- располагаются на один и тех же местах в обоих структурах. Итак, одной проблемой меньше. Изображения версии OS/2, между прочим, при этом гнусно рушатся. Обидно. } with PbmpInfoR^ do begin { ShowMessage('Компрессия := ' + IntToStr(biCompression)); } BitCount := biBitCount; { ShowMessage('BitCount := ' + IntToStr(BitCount)); } { ScanLines - "выровненный" DWORD. } BytesPerScanLine := ((((biWidth * BitCount) + 31) div 32) * SizeOf(DWORD)); BytesPerScanLineR := ((((biHeight * BitCount) + 31) div 32) * SizeOf(DWORD)); AtLeastEightBitColor := BitCount >= BitsPerByte; if AtLeastEightBitColor then begin { Нас не должен волновать бит-тильда. Классно. } BytesPerPixel := biBitCount shr 3; SignificantBytes := biWidth * BitCount shr 3; { Дополнительные байты необходимы для выравнивания DWORD. } PaddingBytes := BytesPerScanLine - SignificantBytes; ColumnBytes := BytesPerScanLineR * biWidth; end else begin { Одно- или четырех-битовое изображение. Уфф. } PixelsPerByte := SizeOf(Byte) * BitsPerByte div BitCount; { Все количество байтов полностью заполняется информацией о пикселе. } WholeBytes := biWidth div PixelsPerByte; { Обрабатываем любые дополнительные биты, которые могут частично заполнять байт. Например, черно-белое изображение, у которого 14 пикселей описываются каждый соответственно своим байтом, плюс одним дополнительным, у которого на самом деле используются 6 битов, остальное мусор. } ExtraPixels := biWidth mod PixelsPerByte; { Все дополнительные байты -- если имеются -- требуется DWORD-выровнять по линии чередования. } PaddingBytes := BytesPerScanLine - WholeBytes; { Если есть дополнительные биты (то есть имеется 'дополнительный байт'), то один из заполненных байтов уже был принят во внимание. } if ExtraPixels <> 0 then Dec(PaddingBytes); end; { if AtLeastEightBitColor then } { TMemoryStream, обслуживающий вращаемые биты. } MemoryStreamR := TMemoryStream.Create; { Устанавливаем размер вращаемого изображения. Может отличаться от исходного из-за выравнивания DWORD. } MemoryStreamR.SetSize(BitmapOffset + BytesPerScanLineR * biWidth); end; { with PbmpInfoR^ do } { Копируем заголовки исходного изображения. } MemoryStream.Seek(0, soFromBeginning); MemoryStreamR.CopyFrom(MemoryStream, BitmapOffset); { Вот буфер, который мы будем "вращать". } bmpBufferR := MemoryStreamR.Memory; { Пропускаем заголовки, yadda yadda yadda... } (*$IFDEF Win32*) Inc(bmpBufferR, BitmapOffset); (*$ELSE*) Win16Inc( Pointer(bmpBufferR), BitmapOffset ); (*$ENDIF*) PbmpBufferR := bmpBufferR; { Едем дальше. } if AtLeastEightBitColor then IntegralByteRotate else NonIntegralByteRotate; { Удовлетворяемся исходными битами. } MemoryStream.Free; { Теперь устанавливаем PbmpInfoR, чтобы он указывал на информационный заголовок вращаемого изображения. } PbmpBufferR := MemoryStreamR.Memory; (*$IFDEF Win32*) Inc( PbmpBufferR, SizeOf(TBitmapFileHeader) ); (*$ELSE*) Win16Inc( Pointer(PbmpBufferR), SizeOf(TBitmapFileHeader) ); (*$ENDIF*) PbmpInfoR := PBitmapInfoHeader(PbmpBufferR); { Меняем ширину с высотой в информационном заголовке вращаемого изображения. } with PbmpInfoR^ do begin T := biHeight; biHeight := biWidth; biWidth := T; biSizeImage := 0; end; ABitmap := TBitmap.Create; { Вращение с самого начала. } MemoryStreamR.Seek(0, soFromBeginning); { Загружаем это снова в ABitmap. } ABitmap.LoadFromStream(MemoryStreamR); MemoryStreamR.Free; end; procedure RotateBitmap180Degrees(var ABitmap: TBitmap); var RotatedBitmap: TBitmap; begin RotatedBitmap := TBitmap.Create; with RotatedBitmap do begin Width := ABitmap.Width; Height := ABitmap.Height; Canvas.StretchDraw( Rect(ABitmap.Width, ABitmap.Height, 0, 0), ABitmap ); end; ABitmap.Free; ABitmap := RotatedBitmap; end; end. |
[000122]
При работе программ на Delphi
Nomadic советует:
A: (AB): Залить фон битмапа синим цветом. [001494]
Проблема с классом TBitmap
|
uses Graphics, Classes, WinProcs, SysUtils; type TGxBitmap = class( TBitmap ) <<<<<<<<требуется тип класса |
В Delphi 2.0 ссылка на WinProcs в действительности является ссылкой на модуль Windows. Модуль Windows практически является комбинацией модулей WinTypes и WinProcs. В нем определен тип с именем TBitmap и, поскольку WinProcs указан после Graphics, тип TBitmap в приведенном примере реально определяется в модуле Windows, а не Graphics.
Это работало в Delphi 1.0, поскольку вы должны были ссылаться на WinTypes для получения декларации TBitmap, но вы не делали этого.
Решение проблемы: в списке uses разместите Graphics после WinProcs.
- Pat Ritchey [000915]
Прозрачная растровая кисть
Следующий модуль выводит на форме два изображения. Одно используется в качестве фона, второе выводится на передний план. Изображение переднего плана отображается как изображение, обладающее "прозрачностью".
Более подробную информацию можно почерпнуть из комментариев.
|
{ Цель: Вывод прозрачного изображения, загруженного из файла Автор: Michael Vincze (vincze@ti.com) Дата: 04/20/95 Использование: Создайте пустую форму с именем Form1, скомпилируйте и запустите проект. Ограничения: Данный модуль протестирован как с 16-, так и с 256-цветными изображениями. Подразумевается, что левый нижний пиксель изображения содержит цвет, определяющий прозрачность. Примечание: Если этот модуль предполагается использовать для любой цели, пожалуйста, оставьте данный заголовок нетронутым в качестве подтверждения авторских прав. Если вы имеете к.-либо замечания или предложения по улучшению кода, пожалуйста, обратитесь к автору. Никаких ограничений по использованию данного кода не существует. Версия: 1.00 04/20/95 Первый выпуск } unit Tbmpu; interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls; type TForm1 = class(TForm) procedure FormCreate(Sender: TObject); procedure FormClose(Sender: TObject; var Action: TCloseAction); private { Private declarations } ImageForeGround: TImage; ImageBackGround: TImage; public { Public declarations } end; procedure DrawTransparentBitmap (ahdc: HDC; Image: TImage; xStart, yStart: Word); var Form1: TForm1; implementation {$R *.DFM} procedure DrawTransparentBitmap (ahdc: HDC; Image: TImage; xStart, yStart: Word); var TransparentColor: TColor; cColor : TColorRef; bmAndBack, bmAndObject, bmAndMem, bmSave, bmBackOld, bmObjectOld, bmMemOld, bmSaveOld : HBitmap; hdcMem, hdcBack, hdcObject, hdcTemp, hdcSave : HDC; ptSize : TPoint; begin { устанавливаем цвет прозрачности для левого нижнего пиксела изображения } TransparentColor := Image.Picture.Bitmap.Canvas.Pixels[0, Image.Height - 1]; TransparentColor := TransparentColor or $02000000; hdcTemp := CreateCompatibleDC (ahdc); SelectObject (hdcTemp, Image.Picture.Bitmap.Handle); { выбираем изображение } { преобразуем размеры изображения к логическим точкам } ptSize.x := Image.Width; ptSize.y := Image.Height; DPtoLP (hdcTemp, ptSize, 1); { преобразуем логические точки устройства } { создаем некие DCы для хранения временных данных } hdcBack := CreateCompatibleDC(ahdc); hdcObject := CreateCompatibleDC(ahdc); hdcMem := CreateCompatibleDC(ahdc); hdcSave := CreateCompatibleDC(ahdc); { создаем изображение для каждого DC } { черно-белый DC } bmAndBack := CreateBitmap (ptSize.x, ptSize.y, 1, 1, nil); bmAndObject := CreateBitmap (ptSize.x, ptSize.y, 1, 1, nil); bmAndMem := CreateCompatibleBitmap (ahdc, ptSize.x, ptSize.y); bmSave := CreateCompatibleBitmap (ahdc, ptSize.x, ptSize.y); { каждый DC должен выбрать bitmap-объект для хранения данных о пикселях } bmBackOld := SelectObject (hdcBack, bmAndBack); bmObjectOld := SelectObject (hdcObject, bmAndObject); bmMemOld := SelectObject (hdcMem, bmAndMem); bmSaveOld := SelectObject (hdcSave, bmSave); { устанавливаем соответствующих режим управления (Map) памятью } SetMapMode (hdcTemp, GetMapMode (ahdc)); { сохраняем переданное сюда изображение, поскольку оно будет переписано } BitBlt (hdcSave, 0, 0, ptSize.x, ptSize.y, hdcTemp, 0, 0, SRCCOPY); { устанавливаем цвет фона исходного DC в цвет прозрачности (чтобы фон был прозрачным) } cColor := SetBkColor (hdcTemp, TransparentColor); { создаем объект-маску для изображения, выполняя BitBlt(), и делая из исходного изображения черного-белое } BitBlt (hdcObject, 0, 0, ptSize.x, ptSize.y, hdcTemp, 0, 0, SRCCOPY); { устанавливаем цвет фона исходного DC обратно в оригинальный цвет } SetBkColor (hdcTemp, cColor); { создаем инвертированную маску-объект } BitBlt (hdcBack, 0, 0, ptSize.x, ptSize.y, hdcObject, 0, 0, NOTSRCCOPY); { копируем фон главного DC в целевой } BitBlt (hdcMem, 0, 0, ptSize.x, ptSize.y, ahdc, xStart, yStart, SRCCOPY); { маскируем места, где будет располагаться изображение } BitBlt (hdcMem, 0, 0, ptSize.x, ptSize.y, hdcObject, 0, 0, SRCAND); { маскируем в изображении пиксели с прозрачным цветом } BitBlt (hdcTemp, 0, 0, ptSize.x, ptSize.y, hdcBack, 0, 0, SRCAND); { делаем XOR изображения с фоном целевого DC } BitBlt (hdcMem, 0, 0, ptSize.x, ptSize.y, hdcTemp, 0, 0, SRCPAINT); { копируем целевое изображение на экран } BitBlt (ahdc, xStart, yStart, ptSize.x, ptSize.y, hdcMem, 0, 0, SRCCOPY); { устанавливаем оригинальное изображение обратно, в переданное сюда изображение } BitBlt (hdcTemp, 0, 0, ptSize.x, ptSize.y, hdcSave, 0, 0, SRCCOPY); { удаляем изображения из памяти } DeleteObject (SelectObject (hdcBack, bmBackOld)); DeleteObject (SelectObject (hdcObject, bmObjectOld)); DeleteObject (SelectObject (hdcMem, bmMemOld)); DeleteObject (SelectObject (hdcSave, bmSaveOld)); { удаляем из памяти DCы } DeleteDC (hdcMem); DeleteDC (hdcBack); DeleteDC (hdcObject); DeleteDC (hdcSave); DeleteDC (hdcTemp); end; procedure TForm1.FormCreate(Sender: TObject); begin { создаем для двух изображений элементы управления Image и назначаем им родителей } ImageForeGround := TImage.Create (Form1); ImageForeGround.Parent := Form1; ImageBackGround := TImage.Create (Form1); ImageBackGround.Parent := Form1; { загружаем изображения } ImageBackGround.Picture.LoadFromFile ('c:\delphi\images\splash\16color\earth.bmp'); ImageForeGround.Picture.LoadFromFile ('c:\delphi\images\splash\16color\athena.bmp'); { устанавливаем размер изображения заднего плана равным размеру исходного изображения } with ImageBackGround do begin Left := 0; Top := 0; Width := Picture.Width; Height := Picture.Height; end; { устанавливаем размер изображения переднего плана, отцентрированного по отношению к изображению заднего плана } with ImageForeGround do begin Left := (ImageBackGround.Picture.Width - Picture.Width) div 2; Top := (ImageBackGround.Picture.Height - Picture.Height) div 2; Width := Picture.Width; Height := Picture.Height; end; { не выводим прозрачное изображение так, как это делает BitBlt() функция, пользуемся функцией DrawTransparentBitmap() } ImageForeGround.Visible := False; { рисуем прозрачное изображение обратите внимание на то, как DC переднего плана используется в расположенной ниже функции } DrawTransparentBitmap (ImageBackGround.Picture.Bitmap.Canvas.Handle, {HDC} ImageForeGround, {TImage} ImageForeGround.Left, {X} ImageForeGround.Top {Y} ); end; procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction); begin { освобождаем изображения } ImageForeGround.Free; ImageBackGround.Free; end; end. |
[001946]
Прозрачные формы и изображения
Вот отличный код, рисующий одно изображение с прозрачными областями на другом.
|
{Данная процедура рисует исходное изображение на целевом, получая информацию об областях исходного изображения, которые должны остаться в области целевого изображения, имеющей прозрачный цвет. t = Целевой холст для рисования x,y = Позиция целевого изображения, где должно быть наложено исходноеs = Исходное изображение TrCol = Цвет, определяющий прозрачность в исходном изображении Примечание: Не забывайте обновлять (repaint) целевое изображение, например так: Image1.Invalidate} procedure DrawTransparent(t: TCanvas; x,y: Integer; s: TBitmap; TrCol: TColor); var bmpXOR, bmpAND, bmpINVAND, bmpTarget: TBitmap; oldcol: Longint; begin try bmpAND := TBitmap.Create; bmpAND.Width := s.Width; bmpAND.Height := s.Height; bmpAND.Monochrome := True; oldcol := SetBkColor(s.Canvas.Handle, ColorToRGB(TrCol)); BitBlt(bmpAND.Canvas.Handle, 0,0,s.Width,s.Height, s.Canvas.Handle, 0,0, SRCCOPY); SetBkColor(s.Canvas.Handle, oldcol); bmpINVAND := TBitmap.Create; bmpINVAND.Width := s.Width; bmpINVAND.Height := s.Height; bmpINVAND.Monochrome := True; BitBlt(bmpINVAND.Canvas.Handle, 0,0,s.Width,s.Height, bmpAND.Canvas.Handle, 0,0, NOTSRCCOPY); bmpXOR := TBitmap.Create; bmpXOR.Width := s.Width; bmpXOR.Height := s.Height; BitBlt(bmpXOR.Canvas.Handle, 0,0,s.Width,s.Height, s.Canvas.Handle, 0,0, SRCCOPY); BitBlt(bmpXOR.Canvas.Handle, 0,0,s.Width,s.Height, bmpINVAND.Canvas.Handle, 0,0, SRCAND); bmpTarget := TBitmap.Create; bmpTarget.Width := s.Width; bmpTarget.Height := s.Height; BitBlt(bmpTarget.Canvas.Handle, 0,0,s.Width,s.Height, t.Handle, x,y, SRCCOPY); BitBlt(bmpTarget.Canvas.Handle, 0,0,s.Width,s.Height, bmpAND.Canvas.Handle, 0,0, SRCAND); BitBlt(bmpTarget.Canvas.Handle, 0,0,s.Width,s.Height, bmpXOR.Canvas.Handle, 0,0, SRCINVERT); BitBlt(t.Handle, x,y,s.Width,s.Height, bmpTarget.Canvas.Handle, 0,0, SRCCOPY); finally bmpXOR.Free; bmpAND.Free; bmpINVAND.Free; bmpTarget.Free; end;{Конец секции TRY} end; |
[001948]
Прозрачный Bitmap
Вам необходимо две копии вашего изображения. Маску и само изображение. Маска является ничем иным, как изображением, состоящим из двух цветов. Черного для тех областей, которые вы хотите показать, и белого для прозрачных. Для Windows 3.1 маска изображения может быть черно-белой, и предназначена для определения размеров изображения. В Win95 черно-белая маска ни при каких обстоятельствах не работает, т.к. у нее должна быть та же глубина цветов, что и у самого изображения, которое вы хотите показать.
Изображение, которое вы хотите показать, должно содержать в прозрачных областях значение цвета, равное 0. Метод помещения изображения на экран такой же, как и в DOS. Маска AND экран, изображение OR или XOR с той же областью.
Ниже приведен код Delphi, позволяя сделать вышеописанное с помощью двух TBitmap.
| Canvas.CopyMode := cmSrcAnd; Canvas.CopyRect(TitleRect, BMask.Canvas, TitleRect); {заполняем "пробелы" изображением} Canvas.CopyMode := cmSrcPaint; Canvas.CopyRect(TitleRect, BTitle.Canvas, TitleRect); |
[001800]
Растягивание и отображение изображения
...размер изображения, которое вы назначили свойству picture.graphic, также имеет свойство размера. Если вы зададите элементу управления размер, скажем, 320x200, а хранящемуся в нем растру 160x100, то при сброшенном свойстве stretch вы обнаружите вокруг растра серую полоску.
Вот способ обойти эту проблему.
|
procedure TForm.ZoomImage; var Bitmap: TBitmap; DstRect: TRect; begin { Здесь можно установить новое растровое изображение с нужными для масштабирования пропорциями, таким образом добиваясь заполнения родительсткой области. } Bitmap := TBitmap.Create; Bitmap.Width := { задайте здесь ширину для измененого масштаба } Bitmap.Height := { задайте здесь высоту для измененого масштаба } Bitmap.Canvas.StretchDraw(Bitmap.Canvas.ClipRect,{здесь включите ваше изображение, которое вы хотите здесь видеть с измененным масштабом}); { Здесь назначьте (assign) новое изображение свойству graphic компонента ImageBox. ImageBox автоматически избавляется от ресурсов, использованных с предыдущим изображением. } Image1.Picture.Graphic := Bitmap; Image1.Invalidate; end; |
Это должно работать, или по крайней мере дать вам идею отностительно того, как это можно сделать. Если я что-то забыл, пожалуйста, не судите строго, и скажите мне об этом. Имейте в виду, что все, что я описал выше, не нужно делать в обработчике события onPaint. Мне нравится компонент ImageBox, поскольку у него хватает ума освобождаться от старого изображения при назначении нового. Я предполагаю, что если вы используете метод Assign вместо метода назначения bitmap, то вы просто получите его новую копию, поэтому вместо этого просто воспользуйтесь ImageBox... В конце процедуры вы должны все-таки освободить новое изображение.
Решение проблемы кроется в изменении свойств TImage.Picture.Bitmap.Width и TImage.Picture.Bitmap.Height. [001938]
Растягивание иконки
При выводе объекта TIcon я пытаюсь использовать функцию StretchDraw, но все что у меня получается - это оригинальный размер, вне зависимости от заданной области Trect.
Andrew
StretchDraw не работает с иконками. В данной ситуации я бы поступил так: рисовал бы иконку в Timage и затем назначал изображение другому, большему Timage.
Пример кода:
|
procedure TForm1.StringGrid1Click(Sender: TObject); begin Image1.Canvas.FillRect(Image1.Canvas.ClipRect); Image1.Canvas.Draw(0, 0, TIcon(StringGrid1.Objects [StringGrid1.Col, StringGrid1.Row])); Form2.Image1.Picture := Image1.Picture; end; {Примечание. Form2.Image1 имеет Stretch установленный в True и размер, бОльший размера иконки в 4 раза} |
Надеюсь я помог вам.
Bill
Дополнение
Андрей Бреслав пишет:
предложенный способ не работает, ибо компонента TImage использует тот же метод StretchDraw, что и спрашивающий. Растянуть иконку можно так:
|
procedure TForm1.Button1Click(Sender: TObject); var Bmp: TBitMap; begin Bmp:= TBitMap.Create; Bmp.Height:= GetSystemMetrics(SM_CYICON); Bmp.Width:= GetSystemMetrics(SM_CXICON); Bmp.Canvas.Draw(0,0, Image1.Picture.Icon); Image1.Picture.Bitmap:= Bmp; Bmp.Free; end; |
Есть более человечный способ, чем просто рисовать в Image: функция DrawIconEx Win32 API:
|
procedure TForm1.Button1Click(Sender: TObject); begin DrawIconEx(Canvas.Handle, 5, 5, LoadIcon(0, IDI_APPLICATION), 16, 32, 0, 0, DI_NORMAL); end; |
Кстати, думаю, людям будет полезно знать по подробнее о DrawIconEx: Рисует иконку или курсор в соответствии с заданными занчениями.
|
function DrawIconEx(hdc: HDC; xLeft, yTop: Integer; hIcon: HICON; cxWidth, cyWidth: Integer; istepIfAniCur: UINT; hbrFlickerFreeDraw: HBRUSH; diFlags: UINT): BOOL; stdcall; |
Рисование без мерцания
...вот я и удивляюсь - почему я получаю мерцание, если я вызываю Repaint или Refresh, а не метод OnPaint напрямую? Или это просто "вариация на тему"?
Имеются две фазы обновления окна. В первой фазе, при выводе окна, Windows посылает ему сообщение WM_ERASEBKGND, сообщающее о необходимости стирания фона перед процедурой рисования. Затем посылается сообщение WM_PAINT, служащее сигналом для закрашивания "переднего плана".
Тем не менее, вы можете пропустить первую фазу, которая вызывает мерцание, одним из двух способов: первый способ заключается в том, что вы форсируете обновление сами, с помощью вызова функции Windows API InvalidateRect. На входе он получает дескриптор окна, указатель на закрашиваемую область - передаем NIL, если вы хотите отрисовать всю область окна - и третий параметр, сообщающий о необходимости очистки фона. Вот как раз последний параметр и должен содержать значение FALSE, если вы сами будете в методе Paint полностью отрисовывать всю область:
| InvalidateRect( Handle, NIL, FALSE ) ; |
Handle должен быть дескриптором формы или элемента управления.
Описав первый способ, я скажу, что существует другое подходящее решение - использовать функциональность VCL. Вы можете указать VCL не стирать фон, добавляя [ csOpaque ] к значению свойства ControlStyle, как показано ниже:
| ControlStyle := ControlStyle + [ csOpaque ] ; |
Это ограничивает заполнение заднего фона, но вы все еще можете видеть процесс "наполнения" области изображением, т.е. процесс рисования. В этом случае вы можете отделаться от эффекта мельтешения, рисуя на TBitmap и выводя его затем на экран командой CopyRect.
Если вы хотите углубиться в тему дальше, то я отошлю вас к моей статье "Optimizing Display Updates in Delphi" (Оптимизация обновления экрана в Delphi), опубликованной в первом выпуске журнала "Delphi magazine".
Mike Scott. [000684]
Рисование фрактальных графов
Здравствуйте, Валентин!
...Очередная нетленка, которую я предлагаю Вам, написана мной самостоятельно (идею и примеры, реализованные в программе, я нашел в апрельском номере журнала "Химия и жизнь" за 1995 год). Теоретически она производит трансляцию L-систем с выводом образовавшихся фрактальных графов, а практически рисует кусты и деревья. Вроде бесполезно, но очень красиво. Эта программа написана для TP7, хотя легко переносится на Delphi (как то я уже переводил ее, но модуль бесследно исчез). Буду надеяться, что она придется Вам по душе.
|
Uses graph, crt; Const GrafType = 1; {1..3} Type PointPtr = ^Point; Point = Record X, Y : Word; Angle : Real; Next : PointPtr End; GrfLine = Array [0..5000] Of Byte; ChangeType = Array [1..30] Of Record Mean : Char; NewString : String End; Var K, T, Dx, Dy, StepLength, GrafLength : Word; grDriver, Xt : Integer; grMode : Integer; ErrCode : Integer; CurPosition : Point; Descript : GrfLine; StartLine : String Absolute Descript; ChangeNumber, Generation : Byte; Changes : ChangeType; AngleStep : Real; Mem : Pointer; Procedure Replace (Var Stroka : GrfLine; OldChar : Char; Repl : String); Var I, J : Word; Begin If (GrafLength = 0) Or (Length (Repl) = 0) Then Exit; I := 1; While I <= GrafLength Do Begin If Chr (Stroka [I]) = OldChar Then Begin For J := GrafLength DownTo I + 1 Do Stroka [J + Length (Repl) - 1] := Stroka [J]; For J := 1 To Length (Repl) Do Stroka [I + J - 1] := Ord (Repl [J]); I := I + J; GrafLength := GrafLength + Length (Repl) - 1; continue End; I := I + 1 End End; Procedure PushCoord (Var Ptr : PointPtr; C : Point); Var P : PointPtr; Begin New (P); P^.X := C.X; P^.Y := C.Y; P^.Angle := C.Angle; P^.Next := Ptr; Ptr := P End; Procedure PopCoord (Var Ptr : PointPtr; Var Res : Point); Begin If Ptr <> Nil Then Begin Res.X := Ptr^.X; Res.Y := Ptr^.Y; Res.Angle := Ptr^.Angle; Ptr := Ptr^.Next End End; Procedure FindGrafCoord (Var Dx, Dy : Word; Angle : Real; StepLength : Word); Begin Dx := Round (Sin (Angle) * StepLength * GetMaxX / GetMaxY); Dy := Round ( - Cos (Angle) * StepLength); End; Procedure NewAngle (Way : ShortInt; Var Angle : Real; AngleStep : Real); Begin If Way >= 0 Then Angle := Angle + AngleStep Else Angle := Angle - AngleStep; If Angle >= 4 * Pi Then Angle := Angle - 4 * Pi; If Angle < 0 Then Angle := 4 * Pi + Angle End; Procedure Rost (Var Descr : GrfLine; Cn : Byte; Ch : ChangeType); Var I : Byte; Begin For I := 1 To Cn Do Replace (Descr, Ch [I] .Mean, Ch [I] .NewString); End; Procedure Init1; Begin AngleStep := Pi / 8; StepLength := 7; Generation := 4; ChangeNumber := 1; CurPosition.Next := Nil; StartLine := 'F'; GrafLength := Length (StartLine); With Changes [1] Do Begin Mean := 'F'; NewString := 'FF+[+F-F-F]-[-F+F+F]' End; End; Procedure Init2; Begin AngleStep := Pi / 4; StepLength := 3; Generation := 5; ChangeNumber := 2; CurPosition.Next := Nil; StartLine := 'G'; GrafLength := Length (StartLine); With Changes [1] Do Begin Mean := 'G'; NewString := 'GFX[+G][-G]' End; With Changes [2] Do Begin Mean := 'X'; NewString := 'X[-FFF][+FFF]FX' End; End; Procedure Init3; Begin AngleStep := Pi / 10; StepLength := 9; Generation := 5; ChangeNumber := 5; CurPosition.Next := Nil; StartLine := 'SLFF'; GrafLength := Length (StartLine); With Changes [1] Do Begin Mean := 'S'; NewString := '[+++G][---G]TS' End; With Changes [2] Do Begin Mean := 'G'; NewString := '+H[-G]L' End; With Changes [3] Do Begin Mean := 'H'; NewString := '-G[+H]L' End; With Changes [4] Do Begin Mean := 'T'; NewString := 'TL' End; With Changes [5] Do Begin Mean := 'L'; NewString := '[-FFF][+FFF]F' End; End; Begin Case GrafType Of 1 : Init1; 2 : Init2; 3 : Init3; Else End; grDriver := detect; InitGraph (grDriver, grMode, ''); ErrCode := GraphResult; If ErrCode <> grOk Then Begin WriteLn ('Graphics error:', GraphErrorMsg (ErrCode) ); Halt (1) End; With CurPosition Do Begin X := GetMaxX Div 2; Y := GetMaxY; Angle := 0; MoveTo (X, Y) End; SetColor (white); For K := 1 To Generation Do Begin Rost (Descript, ChangeNumber, Changes); Mark (Mem); For T := 1 To GrafLength Do Begin Case Chr (Descript [T]) Of 'F' : Begin FindGrafCoord (Dx, Dy, CurPosition.Angle, StepLength); With CurPosition Do Begin Xt := X + Dx; If Xt < 0 Then X := 0 Else X := Xt; If X > GetMaxX Then X := GetMaxX; Xt := Y + Dy; If Xt < 0 Then Y := 0 Else Y := Xt; If Y > GetMaxY Then Y := GetMaxY; LineTo (X, Y) End End; 'f' : Begin FindGrafCoord (Dx, Dy, CurPosition.Angle, StepLength); With CurPosition Do Begin Xt := X + Dx; If Xt < 0 Then X := 0 Else X := Xt; If X > GetMaxX Then X := GetMaxX; Xt := Y + Dy; If Xt < 0 Then Y := 0 Else Y := Xt; If Y > GetMaxY Then Y := GetMaxY; MoveTo (X, Y) End End; '+' : NewAngle (1, CurPosition.Angle, AngleStep); '-' : NewAngle ( - 1, CurPosition.Angle, AngleStep); 'I' : NewAngle (1, CurPosition.Angle, 2 * Pi); '[' : PushCoord (CurPosition.Next, CurPosition); ']' : Begin PopCoord (CurPosition.Next, CurPosition); With CurPosition Do MoveTo (X, Y) End End End; Dispose (Mem); Delay (1000) End; Repeat Until KeyPressed; CloseGraph End. |
С наилучшими пожеланиями,
Михаил Марковский
mrkvsky@chem.kubsu.ru
[000469]
Рисование графов
...вы могли бы использовать объект TCanvas, чем рисовать самому. В вашем случае сгодится компонент TImage, он имеет bitmap и свойство canvas, на котором очень удобно рисовать.
Пример: (Создайте новую форму, добавьте к ней Image и Button. Добавьте следующий код к обработчику события нажатия кнопки)
|
var x,l: Integer; y,a: Double; begin Image1.Picture.Bitmap := TBitmap.Create; Image1.Picture.Bitmap.Width := Image1.Width; Image1.Picture.Bitmap.Height := Image1.Height; {Эти три строчки могут быть размещены в обработчике Form1.Create} l := Image1.Picture.Bitmap.Width; for x := 0 to l do begin a := (x/l) * 2 * Pi; {Преобразуем позицию по оси X к углу между 0 & 2Pi} y := Sin(a); {Ваша функция должна находиться здесь} y := y * (Image1.Picture.Bitmap.Height / 2); {Масштабируем по оси Y} y := y * -1; {Инвертируем Y, верх экрана это 0 !} y := y + (Image1.Picture.Bitmap.Height / 2); {Добавляем компенсацию для среднего 0} Image1.Picture.Bitmap.Canvas.Pixels[Trunc(x), Trunc(y)] := clBlack; end; end; |
Я обнаружил, что лучшим решением будет рисование на холсте. Предпочтительно делать это в отдельной процедуре, которая принимает в качестве параметров TCanvas и TRect. Таким способом мы может передать в качестве параметров холст вашего окна и клиентскую область для рисования на экране, и холст принтера и область клиента для ее позиционирования и печати. Чтобы посмотреть доступные для рисования подпрограммы, взгляните на методы холста.
[001809]
Рисование изображения на форме
|
unit Unit1; interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs; type TForm1 = class(TForm) procedure FormCreate(Sender: TObject); procedure FormPaint(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; Bitmap: TBitmap; implementation {$R *.DFM} procedure TForm1.FormCreate(Sender: TObject); begin Bitmap := TBitmap.Create; Bitmap.LoadFromFile('C:\WINDOWS\cars.BMP'); end; procedure TForm1.FormPaint(Sender: TObject); var X, Y, W, H: LongInt; begin with Bitmap do begin W := Width; H := Height; end; Y := 0; while Y < Height do begin X := 0; while X < Width do begin Canvas.Draw(X, Y, Bitmap); Inc(X, W); end; Inc(Y, H); end; end; end. |
[001941]
*** Рисование КРИВЫХ в Delphi? ***
Решение 1
Автор: dmitrys@phyast.la.asu.edu (Dmitry Streblechenko)
В: У кого-нибудь есть исходный код или какая-либо информация для рисования кривых Безье? Я должен использовать их в своем компоненте. Пожалуйста используйте для ответа мой адрес электронной почты.
О: Я делал это недавно; мне было лениво разбираться с тем, как рисовать кривые Безье с помощью Win API, поэтому я использовал функцию Polyline().
Примечание: для координатных точек я использовал реальные величины типа floating (я применял некоторый тип виртуального экрана), округляя их до целого.
|
PBezierPoint = ^TBezierPoint;
TBezierPoint = record
X,Y:double; //основной узел
Xl,Yl:double; //левая контрольная точка
Xr,Yr:double; //правая контрольная точка
end;
//P1 и P2 - две точки TBezierPoint, расположенные между 0 и 1: //когда t=0 X=P1.X, Y=P1.Y; когда t=1 X=P2.X, Y=P2.Y; procedure BezierValue(P1,P2:TBezierPoint; t:double; var X,Y:double); var t_sq,t_cb,r1,r2,r3,r4:double; begin t_sq := t * t; t_cb := t * t_sq; r1 := (1 - 3*t + 3*t_sq - t_cb)*P1.X; r2 := ( 3*t - 6*t_sq + 3*t_cb)*P1.Xr; r3 := ( 3*t_sq - 3*t_cb)*P2.Xl; r4 := ( t_cb)*P2.X; X := r1 + r2 + r3 + r4; r1 := (1 - 3*t + 3*t_sq - t_cb)*P1.Y; r2 := ( 3*t - 6*t_sq + 3*t_cb)*P1.Yr; r3 := ( 3*t_sq - 3*t_cb)*P2.Yl; r4 := ( t_cb)*P2.Y; Y := r1 + r2 + r3 + r4; end; |
Для рисования кривой Безье разделяем интервал между P1 и P2 на несколько отрезков (их количество влияет на точность воспроизведения кривой, 3 - 4 точки вполне достаточно), затем в цикле создаем массив точек, используем описанную выше процедуру с параметром t от 0 до 1 и рисуем данный массив точек, используя функцию polyline().
Решение 2
В: У кого-нибудь есть исходный код или какая-либо информация для рисования кривых Безье? Я должен использовать их в своем компоненте. Пожалуйста используйте для ответа мой адрес электронной почты.
Я решил ответить на этот крик души - причина?: 1. Не первый раз вижу подобный вопрос, 2. Задача настолько избита, что я без труда нашел ответ в своем архиве. (BTW: У меня есть более старые решения, чем это ;-P)
Тем не менее эта технология жива до сих пор и приносит свои плоды:
|
(********************************************************************) (* GRAPHIX TOOLBOX 4.0 *) (* Copyright (c) 1985, 87 by Borland International, Inc. *) (********************************************************************) unit GShell; interface {------------------------------ вырезано --------------------------} procedure Bezier(A : PlotArray; MaxContrPoints : integer; var B : PlotArray; MaxIntPoints : integer); implementation {------------------------------ вырезано --------------------------} procedure Bezier{(A : PlotArray; MaxContrPoints : integer; var B : PlotArray; MaxIntPoints : integer)}; const MaxControlPoints = 25; type CombiArray = array[0..MaxControlPoints] of Float; var N : integer; ContrPoint, IntPoint : integer; T, SumX, SumY, Prod, DeltaT, Quot : Float; Combi : CombiArray; begin MaxContrPoints := MaxContrPoints - 1; DeltaT := 1.0 / (MaxIntPoints - 1); Combi[0] := 1; Combi[MaxContrPoints] := 1; for N := 0 to MaxContrPoints - 2 do Combi[N + 1] := Combi[N] * (MaxContrPoints - N) / (N + 1); for IntPoint := 1 to MaxIntPoints do begin T := (IntPoint - 1) * DeltaT; if T <= 0.5 then begin Prod := 1.0 - T; Quot := Prod; for N := 1 to MaxContrPoints - 1 do Prod := Prod * Quot; Quot := T / Quot; SumX := A[MaxContrPoints + 1, 1]; SumY := A[MaxContrPoints + 1, 2]; for N := MaxContrPoints downto 1 do begin SumX := Combi[N - 1] * A[N, 1] + Quot * SumX; SumY := Combi[N - 1] * A[N, 2] + Quot * SumY; end; end else begin Prod := T; Quot := Prod; for N := 1 to MaxContrPoints - 1 do Prod := Prod * Quot; Quot := (1 - T) / Quot; SumX := A[1, 1]; SumY := A[1, 2]; for N := 1 to MaxContrPoints do begin SumX := Combi[N] * A[N + 1, 1] + Quot * SumX; SumY := Combi[N] * A[N + 1, 2] + Quot * SumY; end; end; B[IntPoint, 1] := SumX * Prod; B[IntPoint, 2] := SumY * Prod; end; end; { Bezier } end. { GShell } |
[000110]
Создание DIB из BMP
Если файл хранится в формате BMP, как мне преобразовать его в DIB и как затем отобразить?
Это не тривиально, но помочь нам смогут функции GetDIBSizes и GetDIB из модуля GRAPHICS.PAS. Приведу две процедуры: одну для создания DIB из TBitmap и вторую для его освобождения:
|
{ Преобразование TBitmap в DIB }
procedure BitmapToDIB( Bitmap : TBitmap ; var BitmapInfo : PBitmapInfo ; var InfoSize : integer ; var Bits : pointer ; var BitsSize : longint ) ; begin BitmapInfo := NIL ; InfoSize := 0 ; Bits := NIL ; BitsSize := 0 ; if not Bitmap.Empty then try GetDIBSizes( Bitmap.Handle, InfoSize, BitsSize ) ; GetMem( BitmapInfo, InfoSize ) ; Bits := GlobalAllocPtr( GMEM_MOVEABLE, BitsSize ) ; if Bits = NIL then Raise EOutOfMemory.Create( 'Не хватает памяти для пикселей изображения' ) ; if not GetDIB( Bitmap.Handle, Bitmap.Palette, BitmapInfo^, Bits^ ) then Raise Exception.Create( 'Не могу создать DIB' ) ; except if BitmapInfo <> NIL then FreeMem( BitmapInfo, InfoSize ) ; if Bits <> NIL then GlobalFreePtr( Bits ) ; BitmapInfo := NIL ; Bits := NIL ; Raise ; end ; end ; { используйте FreeDIB для освобождения информации об изображении и битовых указателей } procedure FreeDIB( BitmapInfo : PBitmapInfo ; InfoSize : integer ; Bits : pointer ; BitsSize : longint ) ; begin if BitmapInfo <> NIL then FreeMem( BitmapInfo, InfoSize ) ; if Bits <> NIL then GlobalFreePtr( Bits ) ; end ; |
Создаем форму с TImage Image1 и загружаем в него 256-цветное изображение, затем рядом размещаем TPaintBox. Добавляем следующие строчки к private-объявлениям вашей формы:
| { Private declarations } BitmapInfo : PBitmapInfo ; InfoSize : integer ; Bits : pointer ; BitsSize : longint ; |
Создаем нижеприведенные обработчики событий, которые демонстрируют процесс отрисовки DIB:
| procedure TForm1.FormCreate(Sender: TObject); begin
BitmapToDIB( Image1.Picture.Bitmap, BitmapInfo, InfoSize,
Bits, BitsSize ) ;
end;
procedure TForm1.FormDestroy(Sender: TObject); begin FreeDIB( BitmapInfo, InfoSize, Bits, BitsSize ) ; end; procedure TForm1.PaintBox1Paint(Sender: TObject); var OldPalette : HPalette ; begin if Assigned( BitmapInfo ) and Assigned( Bits ) then with BitmapInfo^.bmiHeader, PaintBox1.Canvas do begin OldPalette := SelectPalette( Handle, Image1.Picture.Bitmap.Palette, false ) ; try RealizePalette( Handle ) ; StretchDIBits( Handle, 0, 0, PaintBox1.Width, PaintBox1.Height, 0, 0, biWidth, biHeight, Bits, BitmapInfo^, DIB_RGB_COLORS, SRCCOPY ) ; finally SelectPalette( Handle, OldPalette, true ) ; end ; end ; end; |
Это поможет вам сделать первый шаг. Единственное, что вы можете захотеть, это создание собственного HPalette на основе DIB, вместо использования TBitmap и своей палитры. Функция с именем PaletteFromW3DIB из GRAPHICS.PAS как раз этим и занимается, но она не объявлена в качестве экспортируемой, поэтому для ее использования необходимо скопировать ее исходный код и вставить его в ваш модуль.
- Mike Scott [000785]
Создание и использование 256-цветной палитры
Вот пример того, как можно создать и использовать палитру для 256-цветных изображений. Вам, вероятно, необходимо использовать API функции SelectPalette и RealizePalette, в зависимости от того как вы хотите использовать ваше изображение.
|
procedure TfrmMain.MakePalette(forBitMap: TBitMap); var pNewPal : PLogPalette; lSize : LongInt; nCntr : Byte; begin lSize := SizeOf(TLogPalette) + SizeOf(TPaletteEntry) * 256; try GetMem(pNewPal, lSize); pNewPal^.palNumEntries := 256; pNewPal^.palVersion := $300; {$R-}{выключаем контроль допустимого диапазона} {создаем данные палитры...} for nCntr := 0 to 254 do begin pNewPal^.palPalEntry[nCntr].peRed := nCntr + 20; pNewPal^.palPalEntry[nCntr].peGreen := nCntr + 20; pNewPal^.palPalEntry[nCntr].peBlue := nCntr + 20; pNewPal^.palPalEntry[nCntr].peFlags := pc_nocollapse; end; {$R+}{включаем контроль допустимого диапазона} {удаляем старый hPal; предохраняемся от утечки памяти} DeleteObject(hPal); {создаем новую палитру на основе новых значений} hPal := CreatePalette(pNewPal^); {назначаем новую палитру} forBitMap.Palette := hPal; finally FreeMem(pNewPal, lSize); end; end; |
- Bob Teller [000826]
TCanvas и освобождение дескрипторов
TCanvas автоматически ReleaseDC не вызывает. При создании холста с WindowDC в качестве дескриптора, лучшей идеей будет создание потомка TCanvas (моделированного с TControlCanvas):
|
type
TWindowCanvas = class(TCanvas)
private
FWinControl: TWinControl;
FDeviceContext: HDC;
procedure SetWinControl(AControl: TWinControl);
protected
procedure CreateHandle; override;
public
destructor Destroy; override;
procedure FreeHandle;
property WinControl: TWinControl read FWinControl write SetWinControl;
end;
implementation destructor TWindowCanvas.Destroy; begin FreeHandle; inherited Destroy; end; procedure TWindowCanvas.CreateHandle; begin if FControl = nil then inherited CreateHandle else begin if FDeviceContext = 0 then FDeviceContext := GetWindowDC(WinControl.Handle); Handle := FDeviceContext; end; end; procedure TControlCanvas.FreeHandle; begin if FDeviceContext <> 0 then begin Handle := 0; ReleaseDC(WinControl.Handle, FDeviceContext); FDeviceContext := 0; end; end; procedure TControlCanvas.SetWinControl(AControl: TWinControl); begin if FWinControl <> AControl then begin FreeHandle; FWinControl := AControl; end; end; |
Очевидно, вы должны должны следить за ситуацией, и разрушать TWindowCanvas (или освобождать дескриптор) перед тем, как уничтожить элемент управления, связанный с ним. Также, имейте в виду, что дескриптор DeviceContext не освобождается автоматически после обработки каждого сообщения (как это происходит с дескрипторами TControlCanvas); для освобождения дескриптора вы должны явно вызвать FreeHandle (или разрушить Canvas). И, наконец, имейте в виду, что "WindowCanvas.Handle:= 0" не освобождает десктиптор, для его освобождения вы должны вызывать FreeHandle. [001576]
TImage - эффект плавного перехода
...существует ли для этого эффекта какой-либо алгоритм генерации изображений вместо использования кисточки?
Я был скептически настроен к механизму использования кистей, чтобы получить что-либо похожее на эффект перехода/ухода ("fade") по сравнению со стеркой ("wipe"), но вчера вечером я нашел следующее решение, которое делает невероятное - осуществляет плавный переход от одного изображения к другому:
|
procedure WaitAWhile(n:longint);
var
StartTime:longint;
begin
StartTime:=timeGetTime;
While timeGetTime<StartTime+n do;
end;
procedure TForm1.Image1Click(Sender: TObject); var BrushBmp,BufferBmp,Buffer2Bmp,ImageBmp,Image2Bmp:TBitmap; j,k,row,col:longint; begin row:=0;col:=0; BrushBmp:=TBitmap.Create; with BrushBmp do begin Monochrome:=false; Width:=8; Height:=8; end; imageBmp:=TBitmap.create; imagebmp.loadfromfile('c:\huh.bmp'); image2bmp:=TBitmap.Create; image2bmp.LoadFromFile('c:\whatsis.bmp'); {При 256 цветах лучше иметь ту же самую палитру!} BufferBmp:=TBitmap.Create; with BufferBmp do begin Height:=200; Width:=200; canvas.brush.bitmap:=TBitmap.Create; end; Buffer2Bmp:=TBitmap.Create; with Buffer2Bmp do begin Height:=200; Width:=200; canvas.brush.bitmap:=TBitmap.Create; end; for k:= 1 to 16 do begin WaitAWhile(0); {Для пентиума необходимо добавить задержку} for j:=0 to 3 do begin row:=(row+5) mod 8; col:=(col+1) mod 8; if row=0 then col:=(col+1) mod 8; BrushBmp.canvas.Pixels[row,col]:=clBlack; end; with BufferBmp do begin canvas.copymode:=cmSrcCopy; canvas.brush.bitmap.free; canvas.brush.style:=bsClear; canvas.brush.bitmap:=TBitmap.Create; canvas.brush.bitmap.Assign(BrushBmp); canvas.Rectangle(0,0,200,200); canvas.CopyMode:=cmMergeCopy; canvas.copyrect(rect(0,0,200,200),imageBmp.canvas, rect(0,0,200,200)); end; with Buffer2Bmp do begin canvas.copymode:=cmSrcCopy; canvas.brush.bitmap.free; canvas.brush.style:=bsClear; canvas.brush.bitmap:=TBitmap.Create; canvas.brush.bitmap.Assign(BrushBmp); canvas.Rectangle(0,0,200,200); canvas.copymode:=cmSrcErase; canvas.copyrect(rect(0,0,200,200),image2bmp.canvas, rect(0,0,200,200)); end; BufferBmp.Canvas.CopyMode:=cmSrcPaint; BufferBmp.Canvas.Copyrect(rect(0,0,200,200), Buffer2Bmp.Canvas,rect(0,0,200,200)); canvas.copymode:=cmSrcCopy; canvas.copyrect(rect(0,0,200,200),BufferBmp.Canvas, rect(0,0,200,200)); end; BufferBmp.canvas.brush.bitmap.free; Buffer2Bmp.canvas.brush.bitmap.free; BrushBmp.Free; BufferBmp.Free; Buffer2Bmp.Free; ImageBmp.Free; image2Bmp.Free; end; |
Комментарии: На Pentium I я реально использую 64 кисточки, изменив приведенные выше строки на следующие:
| for k:= 1 to 64 do begin WaitAWhile(50); for j:=0 to 0 do |
; При организации указанной задержки возможно получение плавного перехода.
Заполняя кисть в другом порядке, вы можете получить ряд других эффектов, но приведенная выше версия единственная, которую мне удалось получить максимально похожей на эффект перехода, но вы можете, скажем, написать:
| begin row:=(row+1) mod 8; (*col:=(col+1) mod 8;*) if row=0 then col:=(col+1) mod 8; |
и получить своего рода эффект перехода типа "venetian-blind wipe" (дословно - стерка венецианского хрусталя).
Вопрос: Я чуствую, что я делаю что-то неправильно, существует какая-то хитрость с кистью. Мне нужно все четыре строчки:
| canvas.brush.bitmap.free; canvas.brush.style:=bsClear; canvas.brush.bitmap:=TBitmap.Create; canvas.brush.bitmap.Assign(BrushBmp); |
чтобы все работало правильно; но я совсем не понимаю, почему первые три строки являются обязательными, но если я их выкидываю, Assign сработывает только один раз(!?!?!). Это реально работает? Есть способ другого быстрого назначения brush.bitmaps? (В документации в качестве примера указано на Brush.Bitmap.LoadFromFile, но должно быть лучшее решение. Хорошо, допустим приведенный способ лучший, но он кажется неправильным...)
- David C. Ullrich [000786]
Вертикальный текст
|
var Hfont: Thandle; logfont:TLogFont; font: Thandle; count: integer; begin LogFont.lfheight:=30; logfont.lfwidth:=10; logfont.lfweight:=900; LogFont.lfEscapement:=-200; logfont.lfcharset:=1; logfont.lfoutprecision:=out_tt_precis; logfont.lfquality:=draft_quality; logfont.lfpitchandfamily:=FF_Modern; font:=createfontindirect(logfont); Selectobject(Form1.canvas.handle,font); SetTextColor(Form1.canvas.handle,rgb(0,0,200)); SetBKmode(Form1.canvas.handle,transparent); {textout(form1.canvas.handle,10,10,'Повернутый',7);} for count:=1 to 100 do begin canvas.textout(Random(form1.width),Random(form1.height),'Повернутый'); SetTextColor(form1.canvas.handle,rgb(Random(255),Random(255),Random(255))); end; deleteobject(font); end; |
[001619]
Вращение изображения
Вот быстрый и примитивный способ вращения изображения. Должно работать. По крайней мере хоть какой-то выход из-положения, поскольку Windows этого делать не умеет. Но сначала попробуйте на небольший изображениях.
|
procedure RotateRight(BitMap : tImage);
var FirstC, LastC, c, r : integer;
procedure FixPixels(c,r : integer); var SavePix, SavePix2 : tColor; i, NewC, NewR : integer; begin SavePix := Bitmap.Canvas.Pixels[c,r]; for i := 1 to 4 do begin newc := BitMap.Height-r+1; newr := c; SavePix2 := BitMap.Canvas.Pixels[newc,newr]; Bitmap.Canvas.Pixels[newc,newr] := SavePix; SavePix := SavePix2; c := Newc; r := NewR; end; end; begin if BitMap.Width <> BitMap.Height then exit; BitMap.Visible := false; with Bitmap.Canvas do begin firstc := 0; lastc := BitMap.Width; for r := 0 to BitMap.Height div 2 do begin for c := firstc to lastc do begin FixPixels(c,r); end; inc(FirstC); Dec(LastC); end; end; BitMap.Visible := true; end; |
-Mike Williams [000715]
Вращение изображения II
...я думаю над принудительным грубым методом, но его эффективность может быть сомнительна, и не вздумайте пробовать его без сопроцессора!
Сделайте наложение пиксель-на-пиксель из исходного изображение на целевой (используя свойство Canvas.Pixels). Для каждого пикселя осуществите преобразование полярных координат, добавьте компенсирующий угол к полярной координате, затем спозиционируйте это обратно на координаты прямоугольника, и разместите пиксель с новыми координатами на целевом изображении. Также вы можете добавлять какой-либо псевдослучайный пиксель через определенное их количество, если хотите задать какую-то точность вашей операции.
Для преобразования X- и Y-координат объявлены следующие переменные: X,Y = старые координаты пикселя X1,Y1 = новые координаты пикселя T = угол вращения (в радианах) R, A - промежуточные величины, представляющие собой полярные координаты R = Sqrt(Sqr(X) + Sqr(Y)); A = Arctan(Y/X); X1 = R * Cos(A+T); Y1 = R * Sin(A+T); Я отдаю себе отчет, что это не оптимальное решение, поэтому, если вы найдете еще какое-либо решение, дайте мне знать. В действительности мой метод работает, но делает это очень медленно.
Создайте наложение пиксель-на-пиксель исходного изображение на целевое (используя свойство Canvas.Pixels).
...это хорошее начало, но я думаю другой способ будет немного лучшим. Создайте наложение пиксель-на-пиксель целевого изображения на исходное так, чтобы нам было нужно вычислять откуда брать нужные пиксели, а не думать над тем, куда их нужно поместить.
Для начала вот мой вариант формулы вращения: x, y = координаты в целевом изображении t = угол u, v = координаты в исходном изображении x = u * cos(t) - v * sin(t) y = v * cos(t) + u * sin(t) Теперь, если я захочу решить эти уравнения и вычислить u и v (привести их к правой части уравнения), то формулы будут выглядеть следующим образом (без гарантии, по этой причине я и включил исходные уравнения!): x * cos(t) + y u = -------------------- sqr(cos(t)) + sin(t) v = y * cos(t) - x -------------------- sqr(cos(t)) + sin(t) Так, подразумевая, что вы уже знаете угол вращения, можно вычислить константы cos(t) и 1/sqr(cos(t))+sin(t) непосредственно перед самим циклом; это может выглядеть примерно так (приблизительный код):
|
ct := cos(t); ccst := 1/sqr(cos(t))+sin(t); for x := 0 to width do for y := 0 to height do dest.pixels[x,y] := source.pixels[Round((x * ct + y) * ccst), Round((y * ct - x) * ccst)]; |
Если вы хотите ускорить этот процесс, и при этом волнуетесь за накопление ошибки округления, то вам следует обратить внимание на используемую нами технологию: мы перемещаем за один раз один пиксель, дистанция между пикселями равна u, v содержит константу, определяющую колонку с перемещаемым пикселем. Я использую расчитанные выше переменные как рычаг с коротким плечом (с вычисленной длиной и точкой приложения). Просто поместите в (x,y) = (1,0) и (x,y) = (0,1) и уравнение, приведенное выше:
|
duCol := ct * ccst; dvCol := -ccst; duRow := ccst; dvRow := ct * ccst; uStart := 0; vStart := 0; for x := 0 to width do begin u := uStart; v := vStart; for y := 0 to height do begin dest.pixels[x,y] := source.pixels[Round(u), Round(v)]; u := u + rowdu; v := v + rowdv; end; uStart := uStart + duCol; vStart := vStart + dvCol; end; |
Приведенный выше код можно использовать "как есть", и я не даю никаких гарантий отностительно его использования!
Если вы в душе испытатель, и хотите попробовать вращение вокруг произвольной точки, попробуйте поиграться со значенияим u и v: Xp, Yp (X-sub-p, Y-sub-p) точка оси вращения, другие константы определены выше x = Xp + (u - Xp) * cos(t) - (y - Yp) * sin(t) y = Yp + (y - Yp) * cos(t) - (x - Xp) * sin(t) Оригинальные уравнения: x = u * cos(t) - v * sin(t) y = v * cos(t) + u * sin(t) верны, но когда я решаю их для u и v, я получаю это: x * cos(t) + y * sin(t) u = ----------------------- sqr(cos(t)) + sqr(sin(t)) y * cos(t) - x * sin(t) v = ------------------------ sqr(cos(t)) + sqr(sin(t)) [001803]
Вывод текста на родительском элементе управления
Свойство Canvas в TCustomControl существует, но оно защищено. Поскольку свойство canvas инкапсулирует windows HDC (Canvas.Handle), вы можете создавать объект TCanvas и назначать через свойство Handle контекст устройства элементу управления, на котором вы хотите рисовать.
Для примера:
|
procedure AControl.DrawLabel(ACaption: TCaption); var ACanvas: TCanvas; DC: HDC; begin ACanvas:= TCanvas.Create; try WindowHandle:= parent.Handle; DC := GetDeviceContext(WindowHandle); ACanvas.Handle:= DC; with ACanvas do begin end; ACanvas.Handle:= 0; ReleaseDC(WindowHandle, DC); finally ACanvas.free; end; end; |
[001621]
Заголовок TGA-файла
OK, берем книжку 'Graphics File Formats, 2nd Edition' (форматы графических файлов) авторов David C. Kay & John R. Levine, и читаем формат заголовка файла для хранения изображения формата Targa.
| Описание заголовка файла для изображения формата Targa | ||
| Смещение | Длина (в байтах) | Описание |
| 0 | 1 | Длина ID-поля (ID Field Length) |
| 1 | 1 | Тип цветовой карты (Color-map Type) |
| 2 | 1 | Тип изображения (Image Type) |
| Информация о специфике цветовой карты (Color-map-specific Info) | ||
| 3 | 2 | Первое включение цветовой карты (First Color-map Entry) |
| 5 | 2 | Длина цветовой карты (Color-map Length) |
| 7 | 1 | Размер цветовой карты (Color-map Entry Size) |
| Информация о специфике изображения (Image-specific Info) | ||
| 8 | 2 | Горизонтальная координата начала изображения (Image X Origin) |
| 10 | 2 | Вертикальная координата начала изображения (Image Y Origin) |
| 12 | 2 | Ширина изображения (Image Width) |
| 14 | 2 | Высота изображения (Image Height) |
| 16 | 1 | Бит на пиксел (Bits-Per-Pixel) |
| 17 | 1 | Биты дескриптора изображения (Image-Descriptor Bits) |
Для изображений с разрешением True-color значение типа цветовой карты должно равняться нулю, в остальных случаях единице. В случае, когда цветовая карта присутствует, ее размер должен равняться значению 15, 16, 24 или 32. Для значений 15 и 16 каждая цветовая карта при загрузке использует 2 байта в формате:
Верхний байт Нижний байт A RRRRR GG GGG BBBBB
где бит 'A' устанавливается в 0 для 15-битных цветовых величин. 24-битный размер карты хранится как три байта в следующем порядке: (B)lue (синий), (G)reen (зеленый), и (R)ed (красный). 32-битный размер цветовой карты использует четыре байта, ее порядок такой: (B)lue (синий), (G)reen (зеленый), (R)ed (красный) и значение атрибута - (A)ttribute.
Наконец, код, хранящий тип изображения (Image Type) должен содержать одно из следующих значений:
Код Описание ---- ----------- 0 Изображение отсутствует 1 Цветовая карта, без компрессии 2 True-color, без компрессии 3 Черно-белое, без компрессии 9 Цветовая карта, RLE-компрессия 10 True-color, RLE-компрессия 11 Черно-белое, RLE-компрессия Горизонтальная и вертикальная координата начала изображения (Image X & Y Origins) и размеры изображения (Image Width & Height) разъяснений не требуют. Бит на пиксел (Bits-Per-Pixel) обозначает количество битов, содержащихся в точке изображения и может быть равен значению 8, 16, 24, и 32.
Биыт дескриптора изображения (The Image Descriptor bytes) содержит несколько полей битов, которые содержат следующую информацию:
Биты Описание ---- ----------- 0-3 Биты атрибутов (описаны ниже) 4 Ориентация Слева-на-Право 0=Л/П 1=П/Л 5 Ориентация Вехр/Низ 0=Н/В 1=В/Н 6-7 Чередование линий 00H=Нет, 40H=2 линии, 80H=4 линии Биты атрибутов используются для определения атрибутов цветов в цветовой карте или true-color пикселах. 0 - alpha-данные (alpha-канал) отсутствуют, 1 - игнорирование или неопределено, 2 - не определено, но должно быть сохранено, 3 - наличие alpha-данных и 4 - информация о пикселе уже была умножена на alpha-величину.
Файлы версии Targa 2.0 также имеют файловый колонтитул, который может содержать дополнительное изображение или комментарии. Эти файлы всегда заканчиваются строкой-терминатором 'TRUEVISION-TARGA.'. Так, если ваше Targa-изображение заканчивается значением 'TRUEVISION-TARGA.' + 00H, то вы можете извлечь восемь байтов до строки, чтобы найти начало расширенной области и месторасположение каталога сборки данного файла. Обычно файловый колонтитул версии 2.0 имеет следующий формат:
| Формат файлового колонтитула Targa версии 2.0 | ||
| Байт | Длина | Описание |
| 0 | 4 | 32-битное смещение расширенной области |
| 4 | 4 | 32-битное смещение каталога сборки |
| 8 | 17 | TRUEVISION-TARGA. |
| 25 | 1 | Двоичный ноль ($0) |
Я не собираюсь давать полные описания каталога сборки и области расширения. Вместо этого я приведу описание "почтовой марки", которая может содержаться в формате Targa V2.0. Данная "марка"-иконка должна иметь размеры 64 X 64 пикселей, представляет собой уменьшенный образ изображения, может включаться в файл по желанию компоновщика и не является обязательной.
| Область расширения | ||
| Смещение | Длина | Описание |
| 0 | 2 | Размер области расширения (должна быть 495) |
| 2 | 41 | Имя автора |
| 43 | 81 | Авторские комментарии |
| 124 | 81 | Авторские комментарии |
| 205 | 81 | Авторские комментарии |
| 286 | 81 | Авторские комментарии |
| 367 | 2 | Месяц создания |
| 369 | 2 | День создания |
| 371 | 2 | Год создания |
| ... | ... | ... |
| 482 | 4 | Смещение в файле таблицы цветовой коррекции |
| 486 | 4 | Смещение в файле изображения "почтовой марки" |
| 490 | 4 | Смещение в файле таблицы чередования линий |
| 494 | 1 | Байты атрибутов |
Данная "почтовая марка", при наличии, может быть использована вами непосредственно. Она хранится в виде несжатого изоюражения в том же цветовом формате (цветовой карте или True-color), как и исходное изображение. [000108]
Загрузка 256-цветного TBitmap
Windows не очень полезен, когда мы имеем дело с 256-цветными изображениями. Что делаю я (поскольку думаю, что это самый простой метод): я создаю в памяти изображение таким образом, чтобы TBitmap.LoadFromStream мог "принять" его. Данным методом я загружаю "сырой" ресурс изображения и размещаю его, используя инфорационный заголовок файла изображения. Вот потомок TBitmap, инкапсулирующий вышесказанное:
|
type
TMyBitmap = class(TBitmap)
public
procedure Load256ColorBitmap(Instance: THandle; BitmapName: PChar);
end;
procedure TMyBitmap.Load256ColorBitmap(Instance: THandle; BitmapName: PChar); var HDib: THandle; Size: LongInt; Info: PBitmapInfo; FileHeader: TBitmapFileHeader; S: TMemoryStream; begin HDib := LoadResource(Instance, FindResource(Instance, BitmapName, RT_BITMAP)); if HDib <> 0 then begin Info := LockResource(HDib); Size := GetSelectorLimit(Seg(Info^)) + SizeOf(TBitmapFileHeader); with FileHeader do begin bfType := $4D42; bfSize := Size; bfReserved1 := 0; bfReserved2 := 0; bfOffBits := SizeOf(TBitmapFileHeader) + SizeOf(TBitmapInfoHeader); case Info^.bmiHeader.biBitCount of 1: bfOffBits := bfOffBits + 2 * 4; 4: bfOffBits := bfOffBits + 16 * 4; 8: bfOffBits := bfOffBits + 256 * 4; end; end; S := TMemoryStream.Create; try S.SetSize(Size); S.Write(FileHeader, SizeOf(TBitmapFileHeader)); S.Write(Info^, Size - SizeOf(TBitmapFileHeader)); S.Position := 0; LoadFromStream(S); finally S.Free; FreeResource(HDib); end; end else raise EResNotFound.Create(Format('Не могу найти ресурс изображения %s', [BitmapName])); end; |
Вот как можно это использовать:
| Image1.Picture.Bitmap := TMyBitmap.Create; TMyBitmap(Image1.Picture.Bitmap).Load256ColorBitmap(hInstance, 'BITMAP_1'); |
-Steve Schafer [000709]
Загрузка иконок для TBitBtn и преобразование их к `no white` (без белого).
Если вы загружаете иконку в TImage, то этот компонент "понимает" как сделать ее прозрачной на основании полученной от нее информации. Реально иконки содержат два растровых изображения, одна из которых содержит информацию с нормальными цветами, в том числе с белым, который в дальнейшем должен стать прозрачной областью, второе же изображение представляет собой маску, состоящую из двух цветов, один из которых также белый, он необходим для создания прозрачной области, и черным цветом для цветных областей. Когда с двумя изображениями осуществляется операция "xor" вместе с фоном, белый цвет в белых областях для создания прозрачного фона (сквозь который проглядывает фон), цвет (включая белый) в черных областях для отображения иконки; (вы можете получить также области с "инвертированным фоном", они возникают в месте, где расположен черный цвет на первом изображении, но в этом же месте в изображении-маске находится белый цвет).
Когда вы преобразовываете иконку в растровое изображение, информация о прозрачности теряется, поскольку растровые изображения не имеют возможности хранения этого самого изображения-маски, которое используется для создания прозрачной области. Я догадываюсь что иконки, которые вы используете, являются "отдельностоящими" объектами с прозрачным фоном, обознащающим, что само изображение окружено белым фоном. Так, когда вы загружаете иконку в свойство Glyph компонента TBitbutton или TSpeedbutton, цвет пиксела левого нижнего угла (который в нашем случае будет белым) теперь будет интерпретироваться как цвет, задающий прозрачную область, и создающий именно тот эффект, который вы описали.
Решением будет преобразование иконки в растровое изображение, и сохранение ее как .BMP-файла, затем редактирование ее в ImageEdit, Resource Workshop, или даже PaintBrush, для задание цвета левого нижнего пиксела как цвета, задающего прозрачность. Правда, у меня есть код, который может извлечь из иконки цвет и изображение, задающее маску, но это тема уже следующей статьи. В ней мы рассмотрим способ обратного восстановления иконки по изображению и его маске. [001937]
Захват изображений
Вот пример кода, позволящего с помощью TBitmap захватить часть изображения и сохранить его в файле. Я включил функцию копирования палитры, необходимой при работе в режиме 256 цветов.
|
function CopyPalette( Palette : HPalette ) : HPalette ;
var nEntries : integer ;
LogPalSize : integer ;
LogPalette : PLogPalette ;
begin
Result := 0 ;
if Palette = 0 then exit ;
GetObject( Palette, sizeof( nEntries ), @nEntries ) ;
if nEntries < 1 then exit ;
LogPalSize := sizeof( TLogPalette ) + sizeof( TPaletteEntry ) * ( nEntries - 1 ) ;
GetMem( LogPalette, LogPalSize ) ;
with LogPalette^ do try
palVersion := $300 ;
palNumEntries := nEntries ;
GetPaletteEntries( Palette, 0, nEntries, palPalEntry[ 0 ] ) ;
Result := CreatePalette( LogPalette^ ) ;
finally
FreeMem( LogPalette, LogPalSize ) ;
end ;
end ;
procedure TForm1.Button1Click(Sender: TObject); var Bitmap : TBitmap ; begin Bitmap := TBitmap.Create ; try Bitmap.Width := 50 ; Bitmap.Height := 40 ; Bitmap.Palette := CopyPalette( Image1.Picture.Bitmap.Palette ) ; Bitmap.Canvas.CopyRect( Rect( 0, 0, 50, 40 ), Image1.Picture.Bitmap.Canvas, Bounds( 20, 10, 50, 40 ) ) ; Bitmap.SaveToFile( 'c:\windows\temp\junk.bmp' ) ; finally Bitmap.Free ; end ; end; |
- Mike Scott. [000912]
Доступ к компонентам GroupBox
Одно из свойств всех элементов управления - указатель на другие элементы, которые он содержит. Это свойство - свойство Controls, которое индексируется наподобие массива. Количество элементов управления содержится в свойстве ControlCount. Если вы хотите получить доступ к свойству или методу, которого нет у TControl, вам неоходимо осуществить приведение типа элемента списка.
|
procedure DoSomethingWithAGroupBox; var i : integer; begin with AGroupBox do for i := 0 to ControlCount - 1 do if controls[i] is TEdit then TEdit(controls[i]).text := 'Как насчет этого?'; end; end; |
Приведенный выше пример будет работать, если элементом управления является TEdit или его наследник, например, TDBEdit или TMaskEdit. Все объекты могут быть приведены к типу одного из объектов, являющегося наследником базового типа (или им самим). Но не спешите приводить все к родительскому классу, родитель в данном случае здесь не подходит, поскольку он означает объект, который содержит сам себя. [001447]
Рисование на GroupBox
Я хочу рисовать на холсте (Canvas) моего компонента GroupBox. Но когда я пробую рисовать на Component.Parent.Canvas, рисование происходит на форме, а не на моем компоненте GroupBox. Что я делаю неправильно?
Canvas - защищенное свойство TGroupBox и, поэтому, недоступное. Вы можете сделать его доступным следующим образом:
|
type TMyGroupBox = class(TGroupBox) public property Canvas; end; procedure SomeProcedure; begin ... with TMyGroupBox(GroupBox1).Canvas do CopyRect(ClipRect, Image1.Canvas, ClipRect); ... end; |
- Ralph Friedman [001126]
Как можно узнать о готовности носителя без выскакивающего сообщения об ошибке?
Своим опытом делится Олег Кулабухов:
Можно использовать SetErrorMode() для предотвращения появления подобных сообщений.
|
function IsDriveReady(DriveLetter : char) : bool; var OldErrorMode : Word; OldDirectory : string; begin OldErrorMode := SetErrorMode(SEM_NOOPENFILEERRORBOX); GetDir(0, OldDirectory); {$I-} ChDir(DriveLetter + ':\'); {$I+} if IoResult <> 0 then Result := False else Result := True; ChDir(OldDirectory); SetErrorMode(OldErrorMode); end; procedure TForm1.Button1Click(Sender: TObject); begin if not IsDriveReady('A') then ShowMessage('Drive Not Ready') else ShowMessage('Drive is Ready'); end; |
[001867]
Как определить количество свободного места на диске размером более 2Gb?
Своим опытом делится Олег Кулабухов:
Для этого вам понадобится использовать GetDiskFreeSpaceEx() с последующим переводом целочисленных значений к типу Double.
|
function GetDiskFreeSpaceEx(lpDirectoryName: PAnsiChar; var lpFreeBytesAvailableToCaller : Integer; var lpTotalNumberOfBytes: Integer; var lpTotalNumberOfFreeBytes: Integer) : bool; stdcall; external kernel32 name 'GetDiskFreeSpaceExA'; procedure GetDiskSizeAvail(TheDrive : PChar; var TotalBytes : double; var TotalFree : double); var AvailToCall : integer; TheSize : integer; FreeAvail : integer; begin GetDiskFreeSpaceEx(TheDrive, AvailToCall, TheSize, FreeAvail); {$IFOPT Q+} {$DEFINE TURNOVERFLOWON} {$Q-} {$ENDIF} if TheSize >= 0 then TotalBytes := TheSize else if TheSize = -1 then begin TotalBytes := $7FFFFFFF; TotalBytes := TotalBytes * 2; TotalBytes := TotalBytes + 1; end else begin TotalBytes := $7FFFFFFF; TotalBytes := TotalBytes + abs($7FFFFFFF - TheSize); end; if AvailToCall >= 0 then TotalFree := AvailToCall else if AvailToCall = -1 then begin TotalFree := $7FFFFFFF; TotalFree := TotalFree * 2; TotalFree := TotalFree + 1; end else begin TotalFree := $7FFFFFFF; TotalFree := TotalFree + abs($7FFFFFFF - AvailToCall); end; end; procedure TForm1.Button1Click(Sender: TObject); var TotalBytes : double; TotalFree : double; begin GetDiskSizeAvail('C:\', TotalBytes, TotalFree); ShowMessage(FloatToStr(TotalBytes)); ShowMessage(FloatToStr(TotalFree)); end; |
[001882]
Как получить серийный номер тома жесткого диска?
Своим опытом делится Олег Кулабухов:
Вот, посмотрите пример, в нем достается и еще кое-какая полезная информация.
|
procedure TForm1.Button1Click(Sender: TObject); var VolumeName, FileSystemName : array [0..MAX_PATH-1] of Char; VolumeSerialNo : DWord; MaxComponentLength, FileSystemFlags : Integer; begin GetVolumeInformation('C:\',VolumeName,MAX_PATH,@VolumeSerialNo, MaxComponentLength,FileSystemFlags, FileSystemName,MAX_PATH); Memo1.Lines.Add('VName = '+VolumeName); Memo1.Lines.Add('SerialNo = $'+IntToHex(VolumeSerialNo,8)); Memo1.Lines.Add('CompLen = '+IntToStr(MaxComponentLength)); Memo1.Lines.Add('Flags = $'+IntToHex(FileSystemFlags,4)); Memo1.Lines.Add('FSName = '+FileSystemName); end; |
NeNashev дополняет:
Тут делал защиту CD по этому самому номеру и столкнулся со следующим: под NT системами серийник CD возвращается с обратным порядком байт, нежели под 9х. То есть, если под 9х Вы считали $11223344, то под NT считаете $44332211...
А серийник дискеты - не меняется... Про тома винчестера не скажу, не прверял.
А вообще серийный номер устанавливается при форматировании, и складывается их текущей даты/времени и еще чего-то... [001860]
Как распознать тип носителя?
Своим опытом делится Олег Кулабухов:
Используем функцию GetDriveType.
|
procedure TForm1.Button1Click(Sender: TObject); begin case GetDriveType('C:\') of 0 : ShowMessage('The drive type cannot be determined'); 1 : ShowMessage('The root directory does not exist'); DRIVE_REMOVABLE:ShowMessage('The disk can be removed'); DRIVE_FIXED : ShowMessage('The disk cannot be removed'); DRIVE_REMOTE : ShowMessage('The drive is remote (network) drive'); DRIVE_CDROM : ShowMessage('The drive is a CD-ROM drive'); DRIVE_RAMDISK : ShowMessage('The drive is a RAM disk'); end; end; |
[001862]
Получение информации о диске
...я не нашел информации относительно функции 69h, но я вот что я нашел по поводу использования 4409h:
|
type MIDPtr = ^MIDRec; MIDRec = Record InfoLevel: word; SerialNum: LongInt; VolLabel: Packed Array [0..10] of Char; FileSysType: Packed Array [0..7] of Char; end; function GetDriveSerialNum(MID: MIDPtr; drive: Word): Boolean; assembler; asm push DS { Просто для безопасности, я не думаю что это действительно нужно } mov ax,440Dh { Функция получения ID устройства } mov bx,drive { номер устройства (0-по умолчанию, 1-A ...) } mov cx,0866h { код категории и минора } lds dx,MID { Загружаем pointeraddr. } call DOS3Call { Предположим, что это быстрее, чем INT 21H } jc @@err mov al,1 { No carry, поэтому возвращаем TRUE } jmp @@ok @@err: mov al,0 { Carry установлен, поэтому возвращаем FALSE } @@ok: pop DS { Восстанавливаем DS, так как не было предположений, что мы изменим это } end; procedure TForm1.NrBtnClick(Sender: TObject); var Info: MIDRec; begin Info.InfoLevel:=0; { Уровень информации } If GetDriveSerialNum(@Info,0) then { Что-то с этим делаем... } ListBox.Items.Add(IntToStr(Info.SerialNum)+' '+Info.VolLabel); end; |
[001956]
Серийный номер диска
Вот модуль Delphi, который читает эту информацию. Чтобы записать ее, необходимо перез вызовом прерывания изменить значение AX на $6901 и заполнить буфер вашими значениями. Требуется DOS 4.00+.
|
unit Sernumu; interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TMediaID = Record InfoLevel : Word; SerialNumber : LongInt; VolumeLabel : Array[0..10] of Char; SysName : Array[0..7] of Char; End; TForm1 = class(TForm) Button1: TButton; Label1: TLabel; Label2: TLabel; Label3: TLabel; procedure Button1Click(Sender: TObject); private { Private declarations } MediaID : TMediaID; public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} type DPMIRegisters = record DI : LongInt; SI : LongInt; BP : LongInt; Reserved : LongInt; BX : LongInt; DX : LongInt; CX : LongInt; AX : LongInt; Flags : Word; ES : Word; DS : Word; FS : Word; GS : Word; IP : Word; CS : Word; SP : Word; SS : Word; end; function RealIntr(IntNo : Byte; var Regs : DPMIRegisters) : Word; Assembler; asm xor bx,bx mov bl,IntNo xor cx,cx {StackWords = 0} les di,Regs mov ax,0300h int 31h jc @@ExitPoint xor ax,ax @@ExitPoint: end; function GetDiskInfo(Drive : Word; var MediaID : TMediaID) : Boolean; type tLong = Record LoWord, HiWord : Word; End; var Regs : DPMIRegisters; dwAddress : LongInt; Address : tLong absolute dwAddress; begin Result := False; FillChar(MediaID, SizeOf(MediaID), 0); dwAddress := GlobalDosAlloc(SizeOf(MediaID)); { два параграфа памяти DOS } if dwAddress = 0 then { в случае ошибки адрес будет нулевым } exit; With Regs do begin bx := Drive; cx := $66; ds := Address.HiWord; ax := $6900; dx := 0; es := 0; flags := 0; end; If RealIntr($21, Regs) <> 0 Then Exit; Move(ptr(Address.LoWord, 0)^, MediaID, SizeOf(MediaID)); GlobalDosFree(Address.LoWord) { освобождаем блок DOS памяти } Result := True; end; procedure TForm1.Button1Click(Sender: TObject); begin GetDiskInfo(1, MediaID); With MediaID do Begin Label1.Caption := IntToHex(SerialNumber, 8); Label2.Caption := VolumeLabel; Label3.Caption := SysName; End; end; end. |
[001955]
Серийный номер тома
Как с помощью Delphi 2.0 мне получить серийный номер винчестера?
Попробуй это:
|
procedure TForm1.Button1Click(Sender: TObject); var SerialNum : dword; a, b : dword; Buffer : array [0..255] of char; begin if GetVolumeInformation('c:\', Buffer, SizeOf(Buffer), @SerialNum, a, b, nil, 0) then Label1.Caption := IntToStr(SerialNum); end; |
Исправленную версию прислал: Алексей Коган FIDOnet 2:5064/7.69 Russia, Stavropol Andy Dmitriev дополняет:
Должен заметить, что GetVolumeInformation возвращает серийный номер ТОМА, а не винчестера, то есть, если заменить C:\ на D:\, то номерок-то и поменяется... Определение серийного номера винчестера несколько сложнее, я встречал этот пример в одной из конференций, да и то оно не работало под NT/2000, кажется. В любом случае оглавление надо поправить, чтобы не дезинформировать читателей.
Поправляю... [000125]
