Виртуальная библиотека Delphi

ReleaseDC(0, tHDC);

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.

{************************ Draw Disabled Text **************

***** This function draws text in "disabled" style. *****

***** i.e. the text is grayed . *****

**********************************************************}

function DrawDisabledText (Canvas : tCanvas; Str: PChar; Count: Integer; var Rect: TRect; Format: Word): Integer;

begin

SetBkMode(Canvas.Handle, TRANSPARENT);

OffsetRect(Rect, 1, 1);

Canvas.Font.color:= ClbtnHighlight;

DrawText (Canvas.Handle, Str, Count, Rect,Format);

Canvas.Font.Color:= ClbtnShadow;

OffsetRect(Rect, -1, -1);

DrawText (Canvas.Handle, Str, Count, Rect, Format);

end;

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;

1) Предполагается, что поле BLOB (например, Pict)

2) в запросе Query.SQL пишется что-то вроде

'select Pict from sometable where somefield=somevalue'

3) запрос открывается

4) делается "присваивание":

Image1.Picture.Assing(TBlobField(Query.FieldByName('Pict'))

или, если известно, что эта картинка — Bitmap, то можно

Image1.Picture.Bitmap.Assing(TBlobField(Query.FieldByName('Pict'))

А можно воспользоваться компонентом TDBImage.

Каким образом извлечь иконку из EXE- и DLL-файлов (ExtractAssociatedIcon) и отобразить ее на компоненте Timage или небольшой области на форме?

--------------------------------------------------------------------------------

uses ShellApi;

procedure TForm1.Button1Click(Sender: TObject);

var

IconIndex : word;

h : hIcon;

begin

IconIndex := 0;

h := ExtractAssociatedIcon(hInstance, 'C:\WINDOWS\NOTEPAD.EXE', IconINdex);

DrawIcon(Form1.Canvas.Handle, 10, 10, h);

end;

Так же как в случае с TMemo, здесь можно использовать сообщения. Например, сообщение может быть отослано в момент создания формы:

procedure TForm1.FormCreate(Sender: TObject);

begin

ListBox1.Perform(LB_SETHORIZONTALEXTENT, 1000, Longint(0));

end;

Второй параметр в вызове — ширина прокрутки в точках.

Есть функция API Windows, что заставляет искать строку в ListBox с указанной позиции.

Например, поиск строки, что начинается на '1.' От текущей позиции курсора в ListBox. Т.о., нажимая на кнопку Button1, будут перебраны все строки начинающиеся на '1.'

procedure TForm1.Button1Click(Sender: TObject);

var S : string;

begin

S:='1.';

with ListBox1 do ItemIndex := Perform(LB_SELECTSTRING, ItemIndex, LongInt(S));

end;

Более подробную информацию о работе команды LB_SELECTSTRING можно узнать из Help-а Win32.

procedure TForm1.Memo1KeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);

begin

Memo1Click(Self);

end;

procedure TForm1.Memo1Click(Sender: TObject);

VAR

LineNum : LongInt;

CharNum : LongInt;

begin

LineNum := Memo1.Perform(EM_LINEFROMCHAR, Memo1.SelStart, 0);

CharNum := Memo1.Perform(EM_LINEINDEX, LineNum, 0);

Label1.Caption := IntToStr(LineNum+1)+' : '+IntToStr((Memo1.SelStart-CharNum)+1);

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

Memo1Click(Self);

end;

В компоненте TMemo предусмотрена функция отмены последней правки (Undo). Ее можно вызвать следующим образом:

Memo1.Perform(EM_UNDO,0,0);

Узнать о том, возможна ли отмена (т.е. есть ли что отменять) можно следующим образом:

UndoEnabled:=(Memo1.Perform(EM_CAUNDO,0,0)<>0);

Я добавляю програмно несколько строк в конец поля Memo, а их не видно. Как прокрутить Memo, чтобы было видно последние строки ?

Примерно так:

SendMessage(Memo1.Handle, EM_LINESCROLL, 0, Memo1.Lines.Count-1);

Для Delphi 1. Каждый экземпляр программы имеет ссылку на свою предыдущую копию — hPrevInst: hWnd. Ее можно проверить перед созданием приложения и при необходимости отреагировать соответствующим образом. Если запущена только одна копия, то эта ссылка равна нулю.

Пример:

procedure TForm1.FormCreate(Sender: TObject);

begin