Как быстро выводить графику? (А то Canvas очень медленно работает). Вот пример заполнения формами точками случайного цвета.
type TRGB=record b,g,r:byte; end; ARGB=array [0..1] of TRGB; PARGB=^ARGB;
var b:TBitMap;
procedure TForm1.FormCreate(sender:TObject); begin b:=TBitMap.Create; b.pixelformat:=pf24bit; b.width:=Clientwidth; b.height:=Clientheight; end;
procedure TForm1.Tim1OnTimer(sender:TObject); Var p:PARGB; x,y:integer; begin for y:=0 to b.height-1 do begin p:=b.scanline[y]; for x:=0 to b.width-1 do begin p[x].r:=random(256); p[x].g:=random(256); p[x].b:=random(256); end; end; canvas.draw(0,0,b); end;
procedure TForm1.FormDestroy(sender:TObject); begin b.free; end;
Источник: Дельфи. Вокруг да около.
Как сделать прозрачным фон текста? Используйте функцию 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;
Источник: Дельфи. Вокруг да около.
Как в QuickReports вставить "Страница № из " »»» Алексей (04.08.00 16:40) Подскажите как можно в QuickReports на каждой странице вставить "Страница" № страницы "из" общее кол-во страниц.
»»» Fighter - FighterRu@Mail.ru (07.08.00 07:16) Компонент TQRSysData используется для показа вспомогательной и системной информации. Вид показываемой информации определяется свойством: property Data: TQRSysDataType;
Возможные значения этого свойства: qrsColumnNo - номер текущей колонки отчёта (для одноколончатого отчёта всегда 1). qrsDate - текущая дата. qrsDateTime - текущие дата и время. qrsDetailCount - количество записей в НД, а при использовании нескольких НД -количество записей в главном наборе. Для случая, когда НД представлен компонентом TQuery, эта возможность может быть недоступной. qrsDetailNo - номер текущей записи в НД. qrsPageNumber - номер текущей страницы отчёта. qrsPageCount - общее число страниц отчёта. qrsReportTitle - заголовок отчёта. qrsTime - текущее время.
Размести в компоненте QRBand подвала отчёта два компонента TQRSysData. В свойство Data первого из них установи значение qrsDetailNo, второго - qrsPageCount.
-= Из конференции сайта MASTERS OF DELPHI (http://delphi.mastak.com) =-
Проблемы с Toolbar »»» Дмитрий (26.07.00 18:31) В Дельфях 3 написаная программа при установку на другой компьютер с виндами 95 не показывает изображение на кнопках, где-то читал как можно исправить, но не помню. Помогите.
»»» Hordi - iqsoft@news.cg.ukrtel.net (27.07.00 01:18) Проблема решается обновлением на конечном компьютере файла comctl32.dll, но правильнее будет все картинки на кнопках грузить оперативно при загрузке программы.
»»» Дмитрий - eda@arhadm.net.ru (27.07.00 08:35) А на 5 Дельфях такая проблема есть?
»»» Hordi (28.07.00 00:08) А это не совсем проблема Делфи, да и проблемой её считать нельзя
-= Из конференции сайта MASTERS OF DELPHI (http://delphi.mastak.com) =-
TRichEdit и картинки »»» Nuke Dukem (28.07.00 15:25) TRichEdit и картинки подружить можно? Я мог бы наверное и рисовать картинку чуть ли не вручную поверх RichEdit-а, но при прокрутке скроллером надо картинку двигать и т.п. Вроде можно через Ole добавить картинку, но я в этом ничего не понимаю совсем.
»»» maestro - maestro@bashneft.ru (01.08.00 12:59) я работаю с Д4, в котором кажется реализован RF v1.0. я делал следующее: 1. подготовил файл с картинкой, затем: RichEdit1.PlainText := False; RichEdit1.Lines.LoadFromFile('...'); в результате все прогрузилось, кроме самой картинки 2. скопировал картинку в буфер и вставил следующий код: For nCount := 0 To Clipboard.FormatCount - 1 Do RichEdit1.Perform(EM_PASTESPECIAL, Clipboard.Formats[bCount], 0); // То бишь пытаюсь вытащить содержимое кармана во всех возможных форматах. вышеприведенный код отлично работает с текстом, но отказывается работать с графикой вывод: RF v1.0 (или сам RichEdit, что вобщем-то все равно) не поддерживает графику
»»» Sergey - ntv@kuzbe.elektra.ru (02.08.00 04:30) Попробуй RXReachEdit, классная штука, делает почти всё!
-= Из конференции сайта MASTERS OF DELPHI (http://delphi.mastak.com) =-
Как сделать RichEdit c прозрачным фоном? »»» maestro - maestro@bashneft.ru (27.07.00 13:28) Вообще-то никак. Потому что как показывает мой личный опыт, Windows для всех контролов, порожденных от TWinControl, сама закрашивает задний план. И даже если ты перехватишь WM_PAINT, то и это не поможет, так как Windows самостоятельно выполнит закраску. Однако 2 совета: 1. попробуй поиграть с WM_ERASEBCKGND (кажется так пишется); 2. попробуй ControlStyle := ControlStyle + [csOpaque] или ControlStyle := ControlStyle - [csOpaque]
»»» Merlin (27.07.00 14:10) Я одно время занимался аналогичной задачей и в инете нашел наборы прозрачных компонент. Пытался и сам сделать набор прозрачных компонент, но... :( Результат получился не очень, они достаточно глючно работали, и компоненты нужно переписывать с нуля. Поэтому советую найти дпугой способ решения своей задачи :)
-= Из конференции сайта MASTERS OF DELPHI (http://delphi.mastak.com) =-
Как получить кол-во цветов в изображении
if Image1.Picture.Graphic is TBitmap then begin case Image1.Picture.Bitmap.PixelFormat of {Find color depth} pf1bit : pf := '. Monochrome'; pf4bit : pf := '. 16 Colors'; pf8bit : pf := '. 256 Colors'; pf15bit: pf := '. 32768 Colors'; pf16bit: pf := '. 65536 Colors'; pf24bit: pf := '. 16 Million Colors'; pf32bit: pf := '. Gazillions of Colors!'; else pf := '. Custom color scheme'; end; end;
Изменения размера файлов формата JPEG »»» Andrej (19.07.00 08:17) Я недавно начал заниматься Delphi и столкнулся с проблемой изменения размера файлов формата JPEG. Вот что я пытаюсь сделать === Cut ===
var b1,b2: TJpegImage;
begin b1:=TJPEGImage.Create; b2:=TJPEGImage.Create; b1.LoadfromFile('01.jpg'); b2.Width:=b1.Width div 2; b2.SaveToFile('02.jpg'); end;
=== Cut ===
Все ноpмально компилиpyется, но пpи запyске вылетает окно виндов, мол не могy менять pазмеp файлов JPEG: "Cannot change the size of JPEG Image". Чего делать? Может кто-нибyдь подкинет готовyю пpоцедypкy для изменения pазмеpа, я бы по ней pазобpался. БМП изменять наyчился, но как не бился под JPEG никак не yдалосьпpиспособить этy пpоцедypy. Может в BMP надо пеpеводить? Я пытался юзать метод DIBNeeded, но честно говоpя ничего толком не вышло. Помогите, кто может. Спасибо.
»»» Merlin (19.07.00 17:31) 1. В приведенном коде ошибка. Зачем b2 ? Ведь ты в него картинку-то не грузишь. 2. Попробуй менять не b1.width , а его Canvas, может получится... 3. Создай b2 с нужным размером и СКОПИРУЙ в него картинку из b1 с масштабированием (функция bitblt, кажется :)
»»» GHOST - iconsun@nm.ru (19.07.00 21:46) Вот простенькая процедура:
procedure divJpeg; var b1,b2: TJpegImage; c1: TBitmap; begin b1:=TJPEGImage.Create; b2:=TJPEGImage.Create; c1:=TBitmap.Create; b1.LoadfromFile('С:\01.jpg'); c1.Height:=b1.Height; c1.Width:=b1.Width div 2; c1.Canvas.Draw(0,0,b1); b2.Assign(c1); b2.SaveToFile('C:\02.jpg'); b1.Free; b2.Free; c1.Free; end;
Таким образом можно преобразовывать .jpg в .bmp и обратно... А Canvas так просто в TJpegImage недоступен...
-= Из конференции сайта MASTERS OF DELPHI (http://delphi.mastak.com) =-
Что нужно предусмотреть при разработке приложения, которое будет работать при различном разрешении дисплея?
* а ранней стадии создания приложения решите для себя хотите ли вы позволить форме масштабироваться. Преимущество немасштабируемой формы в том, что ничего не меняется во время выполнения. В этом же заключается и недостаток (ваша форма может бать слишком маленькой или слишком большой в некоторых случаях). * Если вы Е собираетесь делать форму масштабируемой, установите св-во Scaled=False и дальше не читайте. * В противном случае Scaled=True. * Установите AutoScroll=False. AutoScroll = True означает не менять размер окна формы при выполнении что не очень хорошо выглядит, когда содержимое формы размер меняет. * Установите фонты в форме на TrueType фонты, например Arial. !!!!: Если такого фонта не окажется на пользовательском компьютере, то Windows выберет альтернативный фонт из того же семейства. Этот фонт может не совпадать по размеру, что вызовет проблемы. * Установите св-во Position в любое значение, отличное от poDesigned. poDesigned оставляет форму там, где она была во время дизайна, и, например, при разрешении 1280x1024 форма окажется в левом верхнем углу и совершенно за экраном при 640x480. * Оставляйте по-крайней мере 4 точки между компонентами, чтобы при смене положения границы на одну позицию компоненты не "наезжали" друг на друга. * Для однострочных меток (TLabel) с выравниванием alLeft или alRight установите AutoSize=True. Иначе AutoSize=False. * Убедитесь, что достаточно пустого места у TLabel для изменения ширины фонта - 25% пустого места многовато, зато безопасно. При AutoSize=False Убедитесь, что ширина метки правильная, при AutoSize=True убедитесь, что есть ссвободное место для роста метки. * Для многострочных меток (word-wrapped labels), оставьте хотя бы одну пустую строку снизу. * Будьте осторожны при открытии проекта в среде Delphi при разных разрешениях. Свойство PixelsPerInch меняется при открытии формы. Лучше тестировать приложения при разных разрешениях, запуская готовый скомпилированный проект, а редактировать его при одном разрешении. Иначе это вызовет проблемы с размерами. * Не изменяйте свойство PixelsPerInch ! * В общем, нет необходимости тестировать приложение для каждого разрешения в отдельности, но стоит проверить его на 640x480 с маленькими и большими фонтами и на более высоком разрешении перед продажей. * Уделите пристальное внимание принципиально однострочным компонентам типа TDBLookupCombo. Многострочные компоненты всегда показывают только целые строки, а TEdit покажет урезанную снизу строку. Каждый компонент лучше сделать на несколько точек больше.
Как сделать DLL и потом из него каpтинки гpузить Этап первый: создание DLL Создаёшь тексотвый файл с расширением .RC и записываешь в него строки такого вида: ---------- <название картинки1> BITMAP <название файла1> . . . <название картинкиN> BITMAP <название файлаN> ------------- запускаешь программу brcc и в качестве параметра --- твой файл, RC-файл и картинки должны храниться в одном каталоге после компиляции у тебя будет один большой RES-файл Затем у себя в программе пишешь:
AModule: THandle;
AModule := LoadLibrary(...); <--- параметры точно не помню, а в хелп лень лезть, посмотри сам
Bitmap.LoadFromResourceName(AModule, <название картинки1>);
FreeLibrary(AModule); <--- это уже в самом конце
Возникла проблема описания большого кол-ва полигонов... »»» eXtrem ART (05.08.00 18:58) Здраствуйте! -Возникла проблема описания большого кол-ва полигонов, а полигоны могут быть с разным кол-вом вершин: Я создаю
type dinmas=record num:Byte; a:array of TPoint; end;
var f: file of dinmas; a:array[1..n] of dinmas; ...
Это всё работает, но с сохранением в фаил, - .. проблема.. Помогите справиться с этой проблемой, psl^ или кинте мне идейку, как сохранять много польгонов в массиве и в файле. Спасиюо всем за внимание!
»»» VKA - vastikov@mail.ru (21.08.00 14:02) Абсолютно неправильно делаешь. A: Array of tPoint - это указатель типа pointer на данные динамического массива, и файл F:file of dinmas выглядит как запись Num:byte;A:pointer, так что нужно сохранять не указатель на данные, а сами данные, т.е.:
Var F:file; Begin BlockWrite(F,Num,1); BlockWrite(F,A^,SizeOf(Num*SizeOf(TPoint))); end;
-= Из конференции сайта MASTERS OF DELPHI (http://delphi.mastak.com) =-
Как менять разрешение экрана по ходу выполнения программы
function SetFullscreenMode:Boolean; var DeviceMode : TDevMode; begin with DeviceMode do begin dmSize:=SizeOf(DeviceMode); dmBitsPerPel:=16; dmPelsWidth:=640; dmPelsHeight:=480; dmFields:=DM_BITSPERPEL or DM_PELSWIDTH or DM_PELSHEIGHT; result:=False; if ChangeDisplaySettings(DeviceMode,CDS_TEST or CDS_FULLSCREEN) <> DISP_CHANGE_SUCCESSFUL then Exit; Result:=ChangeDisplaySettings(DeviceMode,CDS_FULLSCREEN) = DISP_CHANGE_SUCCESSFUL; end; end;
procedure RestoreDefaultMode; var T : TDevMode absolute 0; begin ChangeDisplaySettings(T,CDS_FULLSCREEN); end;
procedure TForm1.Button1Click(Sender: TObject); begin if setFullScreenMode then begin sleep(7000); RestoreDefaultMode; end; end;
Как преобразовать bmp в jpeg
unit Unit1;
interface
uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls;
type TForm1 = class(TForm) Button1: TButton; Image1: TImage; procedure Button1Click(Sender: TObject); private { Private declarations } public { Public declarations } end;
var Form1: TForm1;
implementation
{$R *.DFM}
uses JPEG;
procedure TForm1.Button1Click(Sender: TObject); var JPEG: TJPEGImage; Bitmap: TBitmap; begin JPEG := TJPEGImage.Create; Bitmap := TBitmap.Create; try Bitmap.LoadFromFile('C:\Program Files\Common Files\alarm.bmp'); JPEG.Assign(Bitmap); Image1.Picture.Assign(JPEG); finally JPEG.Free; Bitmap.Free; end; end;
end.
Как отобразить 24-битный рисунок в режиме экрана 256 цветов
uses JPEG;
procedure TForm1.Button1Click(Sender: TObject); var JP : TJPEGImage; IM : TImage; TempFileName : string; begin {Pop up an Open Dialog} OpenDialog1.Options := [ofNoChangeDir, ofFileMustExist]; OpenDialog1.Filter := 'Bitmap Files (*.bmp)|*.bmp'; if OpenDialog1.Execute then begin {Create a temporary TImage} IM := TImage.Create(nil); {Load the bitmap file} IM.Picture.LoadFromFile(OpenDialog1.FileName); {Create a temporary TJPEGImage} JP := TJPEGImage.Create; {Priority on quality} JP.Performance := jpBestQuality; {Assign the bitmap to the JPEG} JP.Assign(IM.Picture.Graphic); {Free the temp image} IM.Free; {Make a temp file name with the extension of .jpg} TempFileName := 'test.jpg'; {Save the JPEG to a temp file} JP.SaveToFile(TempFileName); {Free the JPEG} JP.Free; {Load the temp file to an image on the form} Image1.Picture.LoadFromFile(TempFileName); {Delete the temp file} DeleteFile(TempFileName); end; end;
Как загрузить и отмасштабировать JPEGImage в TImage
Image1.Picture.Graphic := nil; try Image1.Picture.Graphic := nil; Image1.Picture.LoadFromFile(jpegfile); except on EInvalidGraphic do Image1.Picture.Graphic := nil; end; if Image1.Picture.Graphic is TJPEGImage then begin TJPEGImage(Image1.Picture.Graphic).Scale := Self.Scale; TJPEGImage(Image1.Picture.Graphic).Performance := jpBestSpeed; end;
Как изменить размер Jpeg и сохранить его в новый файл
procedure TForm1.Button1Click(Sender: TObject); var bmp: TBItmap; jpg: TJpegImage; scale: Double; begin if opendialog1.execute then begin jpg:= TJpegImage.Create; try jpg.Loadfromfile( opendialog1.filename ); if jpg.Height > jpg.Width then scale := 50 / jpg.Height else scale := 50 / jpg.Width; bmp:= Tbitmap.Create; try {Create thumbnail bitmap, keep pictures aspect ratio} bmp.Width := Round( jpg.Width * scale ); bmp.Height:= Round( jpg.Height * scale ); bmp.Canvas.StretchDraw( bmp.Canvas.Cliprect, jpg ); {Draw thumbnail as control} Self.Canvas.Draw( 100, 10, bmp ); {Convert back to JPEG and save to file} jpg.Assign( bmp ); jpg.SaveToFile(ChangeFileext( opendialog1.filename, '_thumb.JPG' )); finally bmp.free; end; finally jpg.free; end; end;
Как подгружать картинки, т.е есть PageControl на некоторых закладках картинки, при это смена закладок занимает много времени. Как держать картинки подгружеными, чтобы уменьшить это время.
procedure TForm1.FormCreate(Sender: TObject); begin if Image1.Picture.Graphic is TJPEGImage then begin TJPEGImage(Image1.Picture.Graphic).DIBNeeded; end; end;
Данный код заставляет явно и сразу декодировать jpeg, вместо того, чтобы делать это при отображении картинки
Пример прорисовки "плазмы"
unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls;
type TForm1 = class(TForm) Image1: TImage; Button1: TButton; procedure makeplasma; procedure start1Click(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1 : TForm1; plasma : array[0..768,0..768] of byte; implementation {$R *.DFM} procedure TForm1.makeplasma; procedure halfway(x1,y1,x2,y2: integer); procedure adjust(xa,ya,x,y,xb,yb: integer); var d: integer; v: double; begin if plasma[x,y]<>0 then exit; d:=Abs(xa-xb)+Abs(ya-yb); v:=(plasma[xa,ya]+plasma[xb,yb])/2+(random-0.5)*d*2; if v<1 then v:=1; if v>=193 then v:=192; plasma[x,y]:=Trunc(v); end; var x,y: integer; v: double; begin if (x2-x1<2) and (y2-y1<2) then exit; x:=(x1+x2) div 2; y:=(y1+y2) div 2; adjust(x1,y1,x,y1,x2,y1); adjust(x2,y1,x2,y,x2,y2); adjust(x1,y2,x,y2,x2,y2); adjust(x1,y1,x1,y,x1,y2); if plasma[x,y]=0 then begin v:=(plasma[x1,y1]+plasma[x2,y1]+plasma[x2,y2]+plasma[x1,y2])/4; plasma[x,y]:=Trunc(v); end; halfway(x1,y1,x,y); halfway(x,y1,x2,y); halfway(x,y,x2,y2); halfway(x1,y,x,y2); end; var x,y :integer ; begin randomize; plasma[0,768]:=random(192); plasma[768,768]:=random(192); plasma[768,0]:=random(192); plasma[0,0]:=random(192); halfway(0,0,768,768); end; procedure TForm1.start1Click(Sender: TObject); var x,y:integer; begin makeplasma; for x:=0 to 255 do begin for y:=0 to 255 do begin image1.canvas.pixels[x,y]:=rgb(plasma[x,y],plasma[x+256,y+256],plasma[x+512,y+512]); end; image1.update; end; end; end.
Как временно отключить перерисовку окна? Вызовите функцию WinAPI LockWindowUpdate передав ей дескриптор окна, которое необходимо не обновлять. Передайте ноль в качестве параметра для восстановления нормального обновления.
LockWindowUpdate(Memo1.Handle); . . LockWindowUpdate(0);
Источник: Дельфи. Вокруг да около.
Перерисовка canvasf моей формы занимает довольно много времени. Как определить установлен ли у пользователя режим перерисовки всего окна при перемещении чтобы временно отключить перерисовку моего окна? В приведенном примере определяется включен ли режим "Full Window Drag" (перерисовки всего окна при перемещении) Пример:
procedure TForm1.Button1Click(Sender: TObject); var b : bool; begin SystemParametersInfo(SPI_GETDRAGFULLWINDOWS, 0, @b, 0); if not b then ShowMessage('Full Window Drag is not enabled') else ShowMessage('Full Window Drag is enabled'); end;
Источник: Дельфи. Вокруг да около.
Как включить JPG-файл внутрь exe-файла? Первое:
Нужно создать resource script file (*.RC) с помощью простого текстового файла (например блокнота), и вписать всего одну строку:
1 RCDATA "MyPic.jpg"
Единичка – это просто номер ресурса, RCDATA - определяет, что мы имеем дело с user-defined resource. Последнее – имя файла с JPG рисунком.
Второе:
Компилируем его в .RES файл, при помощи BRCC32.EXE. В MS-DOS набираем:
BRCC32 MyPic.RC
Это должно создать файл MyPic.RES.
Третье:
Добавляем директиву компилятор в исходный код нашей программы. Она должна следовать за директивой формы, как показано здесь:
{$R *.DFM} {$R MyPic.RES}
Четвертое:
Добавляем следующую процедуру в программу:
procedure LoadJPEGfromEXE;
var MyJPG : TJPEGImage; // JPEG ResStream : TResourceStream; // Resource Stream
begin MyJPG := TJPEGImage.Create; ResStream := nil; try ResStream := TResourceStream.CreateFromID(HInstance, 1, RT_RCDATA); MyJPG.LoadFromStream(ResStream); // ДА! Так просто :) Canvas.Draw(12,12,MyJPG); // Нарисуем на Canvas, чтобы убедиться, что все работает! finally MyJPG.Free; ResStream.Free; end; end; // procedure
Посмотрите на второй параметр процедуры CreateFromID объекта TresourceStream. Это просто индекс ресурса. Вы можете включить более, чем один jpeg в своей программе просто добавляя новую строчку для каждого jpeg (с другим индексом) в .RC файл.
Пятое:
Запускайте программу, и ура! Теперь можно взять с полки пирожок :)
Как определить размеры jpeg, gif, png Вот вам процедуры, но они могут не работать с последними форматами типа progressive JPEG
unit ImgSize;
interface
uses Classes;
procedure GetJPGSize(const sFile: string; var wWidth, wHeight: word); procedure GetPNGSize(const sFile: string; var wWidth, wHeight: word); procedure GetGIFSize(const sGIFFile: string; var wWidth, wHeight: word);
implementation
uses SysUtils;
function ReadMWord(f: TFileStream): word;
type TMotorolaWord = record case byte of 0: (Value: word); 1: (Byte1, Byte2: byte); end;
var MW: TMotorolaWord; begin {It would probably be better to just read these two bytes in normally and then do a small ASM routine to swap them. But we aren't talking about reading entire files, so I doubt the performance gain would be worth the trouble.} f.Read(MW.Byte2, SizeOf(Byte)); f.Read(MW.Byte1, SizeOf(Byte)); Result := MW.Value; end;
procedure GetJPGSize(const sFile: string; var wWidth, wHeight: word); const ValidSig : array[0..1] of byte = ($FF, $D8); Parameterless = [$01, $D0, $D1, $D2, $D3, $D4, $D5, $D6, $D7]; var Sig: array[0..1] of byte; f: TFileStream; x: integer; Seg: byte; Dummy: array[0..15] of byte; Len: word; ReadLen: LongInt; begin FillChar(Sig, SizeOf(Sig), #0); f := TFileStream.Create(sFile, fmOpenRead); try ReadLen := f.Read(Sig[0], SizeOf(Sig)); for x := Low(Sig) to High(Sig) do if Sig[x] <> ValidSig[x] then ReadLen := 0; if ReadLen > 0 then begin ReadLen := f.Read(Seg, 1); while (Seg = $FF) and (ReadLen > 0) do begin ReadLen := f.Read(Seg, 1); if Seg <> $FF then begin if (Seg = $C0) or (Seg = $C1) then begin ReadLen := f.Read(Dummy[0], 3); { don't need these bytes } wHeight := ReadMWord(f); wWidth := ReadMWord(f); end else begin if not (Seg in Parameterless) then begin Len := ReadMWord(f); f.Seek(Len-2, 1); f.Read(Seg, 1); end else Seg := $FF; { Fake it to keep looping. } end; end; end; end; finally f.Free; end; end;
procedure GetPNGSize(const sFile: string; var wWidth, wHeight: word); type TPNGSig = array[0..7] of byte; const ValidSig: TPNGSig = (137,80,78,71,13,10,26,10); var Sig: TPNGSig; f: tFileStream; x: integer; begin FillChar(Sig, SizeOf(Sig), #0); f := TFileStream.Create(sFile, fmOpenRead); try f.Read(Sig[0], SizeOf(Sig)); for x := Low(Sig) to High(Sig) do if Sig[x] <> ValidSig[x] then exit; f.Seek(18, 0); wWidth := ReadMWord(f); f.Seek(22, 0); wHeight := ReadMWord(f); finally f.Free; end; end;
procedure GetGIFSize(const sGIFFile: string; var wWidth, wHeight: word); type TGIFHeader = record Sig: array[0..5] of char; ScreenWidth, ScreenHeight: word; Flags, Background, Aspect: byte; end; TGIFImageBlock = record Left, Top, Width, Height: word; Flags: byte; end; var f: file; Header: TGifHeader; ImageBlock: TGifImageBlock; nResult: integer; x: integer; c: char; DimensionsFound: boolean; begin wWidth := 0; wHeight := 0; if sGifFile = '' then exit;
{$I-}
FileMode := 0; { read-only } AssignFile(f, sGifFile); reset(f, 1); if IOResult <> 0 then {Could not open file} exit; {Read header and ensure valid file.} BlockRead(f, Header, SizeOf(TGifHeader), nResult); if (nResult <> SizeOf(TGifHeader)) or (IOResult <> 0) or (StrLComp('GIF', Header.Sig, 3) <> 0) then begin {Image file invalid} close(f); exit; end; {Skip color map, if there is one} if (Header.Flags and $80) > 0 then begin x := 3 * (1 SHL ((Header.Flags and 7) + 1)); Seek(f, x); if IOResult <> 0 then begin { Color map thrashed } close(f); exit; end; end; DimensionsFound := False; FillChar(ImageBlock, SizeOf(TGIFImageBlock), #0); { Step through blocks. } BlockRead(f, c, 1, nResult); while (not EOF(f)) and (not DimensionsFound) do begin case c of ',': { Found image } begin BlockRead(f, ImageBlock, SizeOf(TGIFImageBlock), nResult); if nResult <> SizeOf(TGIFImageBlock) then begin { Invalid image block encountered } close(f); exit; end; wWidth := ImageBlock.Width; wHeight := ImageBlock.Height; DimensionsFound := True; end; 'я' : { Skip } begin { NOP } end; { nothing else, just ignore } end; BlockRead(f, c, 1, nResult); end; close(f);
{$I+}
end; end.
Как перебросить TImage с jpeg в TBitmap в runtime
b := TBitmap.Create; try b.Assign(Image1.Picture.Graphic); Image2.Picture.Graphic := b; finally b.Free; end;
Можно ли из Delphi рисовать в любой части экрана или в чужом окне? Для этого надо воспользоваться функциями API. Получить контекст чужого окна, либо всего экрана: function GetDC(Wnd: HWnd): HDC; где Wnd - указатель на нужное окно, или 0 для получения контекста всего экрана. И далее, пользуясь функциями API, нарисовать все что надо. Пример:
PROCEDURE DrawOnScreen; VAR ScreenDC: hDC; BEGIN ScreenDC := GetDC(0); {получить контекст экрана} Ellipse(ScreenDC, 0, 0, 200, 200); {нарисовать} ReleaseDC(0,ScreenDC); {освободить контекст} END;
Не забывайте после своих манипуляций посылать пострадавшим (или всем) окнам сообщение о необходимости перерисовки, для восстановления их первоначального вида.
Копирование экрана
unit ScrnCap; interface uses WinTypes, WinProcs, Forms, Classes, Graphics, Controls;
{ Копирует прямоугольную область экрана } function CaptureScreenRect(ARect : TRect) : TBitmap; { Копирование всего экрана } function CaptureScreen : TBitmap; { Копирование клиентской области формы или элемента } function CaptureClientImage(Control : TControl) : TBitmap; { Копирование всей формы элемента } function CaptureControlImage(Control : TControl) : TBitmap;
{===============================================================} implementation function GetSystemPalette : HPalette; var PaletteSize : integer; LogSize : integer; LogPalette : PLogPalette; DC : HDC; Focus : HWND; begin result:=0; Focus:=GetFocus; DC:=GetDC(Focus); try PaletteSize:=GetDeviceCaps(DC, SIZEPALETTE); LogSize:=SizeOf(TLogPalette)+(PaletteSize-1)*SizeOf(TPaletteEntry); GetMem(LogPalette, LogSize); try with LogPalette^ do begin palVersion:=$0300; palNumEntries:=PaletteSize; GetSystemPaletteEntries(DC, 0, PaletteSize, palPalEntry); end; result:=CreatePalette(LogPalette^); finally FreeMem(LogPalette, LogSize); end; finally ReleaseDC(Focus, DC); end; end;
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; Palette:=GetSystemPalette; 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.
|