Windows

Буфер обмена (Clipboard) и TMemoryStream

2017-10-19T21:09:31+07:00

Обычно, это нужно для того, чтобы запихнуть в буфер обмена данные собственного формата. Сначала необходимо зарегистрировать этот формат при помощи функции RegisterClipboardFormat():

CF_MYFORMAT := RegisterClipboardFormat('My Format Description');

Затем необходимо проделать следующие шаги:

1. Создать поток (stream) и записать в него данные.

2. Создать в памяти глобальный буфер и скопировать в него поток (stream).

3. При помощи Clipboard.SetAsHandle() поместить глобальный буфер в буфер обмена.

Подробнее...

Как скопировать содержимое строки в буфер обмена?

2017-10-19T21:22:45+07:00

Code:

procedure CopyStringToClipboard(s: string);

var

hg: THandle;

P: PChar;

begin

hg:=GlobalAlloc(GMEM_DDESHARE or GMEM_MOVEABLE, Length(S)+1);

P:=GlobalLock(hg);

StrPCopy(P, s);

GlobalUnlock(hg);

OpenClipboard(Application.Handle);

SetClipboardData(CF_TEXT, hg);

CloseClipboard;

GlobalFree(hg);

end;

Подробнее...

Как скопировать файл в Windows clipboard?

2017-10-19T21:20:13+07:00

Code:

uses

ShlObj, ClipBrd;

procedure CopyFilesToClipboard(FileList: string);

var

DropFiles: PDropFiles;

hGlobal: THandle;

iLen: Integer;

begin

iLen := Length(FileList) + 2;

FileList := FileList + #0#0;

hGlobal := GlobalAlloc(GMEM_SHARE or GMEM_MOVEABLE or GMEM_ZEROINIT,

SizeOf(TDropFiles) + iLen);

if (hGlobal = 0) then raise Exception.Create('Could not allocate memory.');

begin

DropFiles := GlobalLock(hGlobal);

DropFiles^.pFiles := SizeOf(TDropFiles);

Move(FileList[1], (PChar(DropFiles) + SizeOf(TDropFiles))^, iLen);

GlobalUnlock(hGlobal);

Clipboard.SetAsHandle(CF_HDROP, hGlobal);

end;

// Example, Beispiel:

procedure TForm1.Button1Click(Sender: TObject);

begin

CopyFilesToClipboard('C:\Bootlog.Txt'#0'C:\AutoExec.Bat');

end;

Копирование большого файла в буфер обмена

2017-10-19T21:21:17+07:00

Вот общее решение, которое будет работать, даже если у вас размер файла превышает 64Кб:

Надо пробовать.

Подробнее...

Копирование потока компонент в буфер обмена

2017-10-19T21:13:01+07:00

Буфер обмена имеет методы GetComponent и SetComponent, но нам нужно

для потоковой передачи нескольких компонентов в буфер обмена, чтобы включить тип вставки копирования

функции.

Подробнее...

Копировать RTF-текст в буфер обмена

2017-10-19T21:29:09+07:00

Вам придется копаться в Формат rtf, если вы хотите скопировать текст буфер обмена, который имеет встроенную информацию формата. Приложение, которое вы вставляете

этот текст в должен понимать RTF, или форматирование не будет отображаться.

ОК, первый шаг-это зарегистрировать Формат буфера обмена в формате rtf, так как это не предопределенный формат:

Подробнее...

Копировать буфер в поток и обратно

2017-10-19T21:13:45+07:00

Code:

uses

clipbrd;

procedure CopyStreamToClipboard(fmt: Cardinal; S: TStream);

var

hMem: THandle;

pMem: Pointer;

begin

Assert(Assigned(S));

S.Position := 0;

hMem := GlobalAlloc(GHND or GMEM_DDESHARE, S.Size);

if hMem <> 0 then

begin

pMem := GlobalLock(hMem);

if pMem <> nil then

begin

try

S.Read(pMem^, S.Size);

S.Position := 0;

finally

GlobalUnlock(hMem);

end;

Clipboard.Open;

try

Clipboard.SetAsHandle(fmt, hMem);

finally

Clipboard.Close;

end;

end { If }

else

begin

GlobalFree(hMem);

OutOfMemoryError;

end;

end { If }

else

OutOfMemoryError;

end; { CopyStreamToClipboard }

procedure CopyStreamFromClipboard(fmt: Cardinal; S: TStream);

var

hMem: THandle;

pMem: Pointer;

begin

Assert(Assigned(S));

hMem := Clipboard.GetAsHandle(fmt);

if hMem <> 0 then

begin

pMem := GlobalLock(hMem);

if pMem <> nil then

begin

try

S.Write(pMem^, GlobalSize(hMem));

S.Position := 0;

finally

GlobalUnlock(hMem);

end;

end { If }

else

raise Exception.Create('CopyStreamFromClipboard: could not lock global handle ' +

'obtained from clipboard!');

end; { If }

end; { CopyStreamFromClipboard }

procedure SaveClipboardFormat(fmt: Word; writer: TWriter);

var

fmtname: array[0..128] of Char;

ms: TMemoryStream;

begin

Assert(Assigned(writer));

if 0 = GetClipboardFormatName(fmt, fmtname, SizeOf(fmtname)) then

fmtname[0] := #0;

ms := TMemoryStream.Create;

try

CopyStreamFromClipboard(fmt, ms);

if ms.Size > 0 then

begin

writer.WriteInteger(fmt);

writer.WriteString(fmtname);

writer.WriteInteger(ms.Size);

writer.Write(ms.Memory^, ms.Size);

end; { If }

finally

ms.Free

end; { Finally }

end; { SaveClipboardFormat }

procedure LoadClipboardFormat(reader: TReader);

var

fmt: Integer;

fmtname: string;

Size: Integer;

ms: TMemoryStream;

begin

Assert(Assigned(reader));

fmt := reader.ReadInteger;

fmtname := reader.ReadString;

Size := reader.ReadInteger;

ms := TMemoryStream.Create;

try

ms.Size := Size;

reader.Read(ms.memory^, Size);

if Length(fmtname) > 0 then

fmt := RegisterCLipboardFormat(PChar(fmtname));

if fmt <> 0 then

CopyStreamToClipboard(fmt, ms);

finally

ms.Free;

end; { Finally }

end; { LoadClipboardFormat }

procedure SaveClipboard(S: TStream);

var

writer: TWriter;

i: Integer;

begin

Assert(Assigned(S));

writer := TWriter.Create(S, 4096);

try

Clipboard.Open;

try

writer.WriteListBegin;

for i := 0 to Clipboard.formatcount - 1 do

SaveClipboardFormat(Clipboard.Formats[i], writer);

writer.WriteListEnd;

finally

Clipboard.Close;

end; { Finally }

finally

writer.Free

end; { Finally }

end; { SaveClipboard }

procedure LoadClipboard(S: TStream);

var

reader: TReader;

begin

Assert(Assigned(S));

reader := TReader.Create(S, 4096);

try

Clipboard.Open;

try

clipboard.Clear;

reader.ReadListBegin;

while not reader.EndOfList do

LoadClipboardFormat(reader);

reader.ReadListEnd;

finally

Clipboard.Close;

end; { Finally }

finally

reader.Free

end; { Finally }

end; { LoadClipboard }

// Examples:

{ Save Clipboard }

procedure TForm1.Button1Click(Sender: TObject);

var

ms: TMemoryStream;

begin

ms := TMemoryStream.Create;

try

SaveClipboard(ms);

ms.SaveToFile('c:\temp\ClipBrdSaved.dat');

finally

ms.Free;

end; { Finally }

end;

{ Clear Clipboard }

procedure TForm1.Button2Click(Sender: TObject);

begin

clipboard.Clear;

end;

{ Restore Clipboard }

procedure TForm1.Button3Click(Sender: TObject);

var

fs: TfileStream;

begin

fs := TFilestream.Create('c:\temp\ClipBrdSaved.dat',

fmopenread or fmsharedenynone);

try

LoadClipboard(fs);

finally

fs.Free;

end; { Finally }

end;

Копируем русский текст в буфер обмена в Windows2000

2017-10-19T21:23:31+07:00

У меня Windows NT/2000. Когда копирую текст на русском языке, скажем, из TMemo в Ворд 97/2000, то получаю в результате каракули. Эти каракули исправляются, если перед копированием насильно переключить клавиатуру пользователя на русский язык. Но если у него нет этой клавиатуры, или если лучше не переключать ее, то как можно сообщить системе, что мы будем копировать РУССКИЙ текст. На форме создается невидимый TRichEdit (я обозвал его TRE в коде). Далее текст копируется в клипборд как обычно, после чего вызывается следующая процедура

Подробнее...

Получаем имена файлов, скопированных в буфер обмена

2017-10-19T21:21:50+07:00

Code:

procedure TForm1.Button1Click(Sender: TObject);

var

f: THandle;

buffer: array [0..MAX_PATH] of Char;

i, numFiles: Integer;

begin

if not Clipboard.HasFormat(CF_HDROP) then Exit;

Clipboard.Open;

try

f := Clipboard.GetAsHandle(CF_HDROP);

if f <> 0 then

begin

numFiles := DragQueryFile(f, $FFFFFFFF, nil, 0);

memo1.Clear;

for i := 0 to numfiles - 1 do

begin

buffer[0] := #0;

DragQueryFile(f, i, buffer, SizeOf(buffer));

memo1.Lines.Add(buffer);

end;

finally

Clipboard.Close;

end;

Поместить/получить строку из буфера обмена (Заплатка к стандартным)

2017-10-19T21:27:32+07:00

Под Win2k попытка вставить русскую строку в Clipboard ClipBoard.AsText:='Проба' с последующей вставкой в Word'е

показывает кракозябрики.. Расследование показало, что виноваты мелкомягкие (как обычно :) ) С целью нивелирования различий между

всеми Win-платформами были написаны эти 2 ф-ции.. Принимают на вход/возвращают строку в Unicode - WideString..

но не надо беспокоиться, Дельфи сам вставит при необходимости конвертацию в/из AnsiString.

Если платформа поддерживает уникод (NT), то используется этот формат, иначе вызываются стандартные процедуры/ф-ции.

Удачи!

Подробнее...

Сохранение всего содержимого буфера обмена в файл

2017-10-19T21:19:34+07:00

Сохранение буфера обмена в файл

Процедура позволяет сохранить содержимое буфера обмена в заданый файл.

P.S. На всякий случай: я не претендую на авторство данного кода, я его просто привёл к виду, который мне больше подходил.

В эту базу я его выложил исходя из предположения, что не каждый, кому понадобится такая процедура знает вышеуказанный адрес или

обратится туда (сам долго искал иные способы).

Подробнее...

Указание языка помещенного в clipboard текста

2017-10-19T21:25:25+07:00

Столкнулся с проблемой вставки в Clipboard русского текста в Win2K, WinXP. Залез в DRKB.. Ну да, там вариант предложен довольно смешной (создать TRichEdit, вставить в него clipboard, весь текст пометить русским, и вернуть в clipboard)... Всё бы ничего, но если у меня программа без форм, да и без окон вообще, то TRichEdit не создаётся ('Control has no parent window') . Почитал хелп, посмотрел, что именно Вынь сует в буфер на разных языках, и нашёл простой и красивый способ. Имхо, ему там и место - в разделе "Буфер обмена".

Подробнее...

TPaintBox в буфер обмена

2017-10-20T00:14:40+07:00

Code:

var

pbRect: TRect;

begin

pbRect := Rect(0, 0, PaintBox1.Width, PaintBox1.Height);

BitMap := TBitMap.Create;

try

Bitmap.Width := PaintBox1.Width;

Bitmap.Height := PaintBox1.Height;

BitMap.Canvas.CopyRect(pbRect, PaintBox1.Canvas, pbRect);

ClipBoard.Assign(BitMap);

finally

BitMap.Free;

end;

Вставка содержимого буфера как картинку в RTF

2017-10-20T00:15:51+07:00

Code:

procedure TForm1.Button1Click(Sender: TObject);

var

b : tbitmap;

fr: TFormatRange;

r : TRect;

begin

b:=tbitmap.create;

b.width:=rxrichedit1.width;

b.height:=rxrichedit1.height;

r:=rect(0,0,RXRichEdit1.Width*screen.Pixelsperinch,

RXRichEdit1.Height*screen.Pixelsperinch);

fr.hdc:=b.Canvas.handle;

fr.hdctarget:=b.Canvas.handle;

fr.rc:=r;

fr.rcpage:=r;

fr.chrg.cpMin:=0;

fr.chrg.cpMax:=-1;

Sendmessage(RXRichEdit1.handle,EM_FORMATRANGE,1,longint(@fr));

image1.Picture.assign(b);

b.free;

end;

Встроенные форматы буфера обмена

2017-10-20T00:16:41+07:00

Code:

procedure TForm1.BtnShowFormatsClick(Sender: TObject);

var

buf: array[0..60] of Char;

n: Integer;

fmt: Word;

name: string[30];

begin

MemFormats.Clear;

for n := 0 to Clipboard.FormatCount - 1 do

begin

fmt := Clipboard.Formats[n];

if GetclipboardFormatName(fmt, buf, Pred(Sizeof(buf))) <> 0 then

MemFormats.Lines.Add(StrPas(buf))

else

begin

case fmt of

1: name := 'CF_TEXT';

2: name := 'CF_BITMAP';

3: name := 'CF_METAFILEPICT';

4: name := 'CF_SYLK';

5: name := 'CF_DIF';

6: name := 'CF_TIFF';

7: name := 'CF_OEMTEXT';

8: name := 'CF_DIB';

9: name := 'CF_PALETTE';

10: name := 'CF_PENDATA';

11: name := 'CF_RIFF';

12: name := 'CF_WAVE';

13: name := 'CF_UNICODETEXT';

14: name := 'CF_ENHMETAFILE';

15: name := 'CF_HDROP (Win 95)';

16: name := 'CF_LOCALE (Win 95)';

17: name := 'CF_MAX (Win 95)';

$0080: name := 'CF_OWNERDISPLAY';

$0081: name := 'CF_DSPTEXT';

$0082: name := 'CF_DSPBITMAP';

$0083: name := 'CF_DSPMETAFILEPICT';

$008E: name := 'CF_DSPENHMETAFILE';

$0200..$02FF: name := 'частный формат';

$0300..$03FF: name := 'Объект GDI';

else

name := 'неизвестный формат';

end;

MemFormats.Lines.Add(name);

end;

Добавление текста в буфер обмена без использования модуля Clipbrd

2017-10-20T00:08:14+07:00

Пример использования:

Code:

procedure TForm1.Button1Click(Sender: TObject);

begin

SetClipboardText(Handle, 'qwerty');

end;

Подробнее...

Как копировать векторное изображение?

2017-10-20T00:09:17+07:00

Code:

procedure TForm1.Button1Click(Sender: TObject);

var

mf: TMetaFile;

mfc: TMetaFileCanvas;

i: integer;

ClipBrdFormat: word;

data: cardinal;

palette: hPalette;

p: array [0..90] of TPoint;

begin

mf := TMetaFile.Create;

mf.Width := 100;

mf.Height := 100;

mfc := TMetafileCanvas.Create(mf, 0);

with mfc do

begin

Pen.Color := clBlack;

FrameRect(ClipRect);

MoveTo(0, 50);

LineTo(100, 50);

LineTo(95, 48);

MoveTo(100, 50);

LineTo(95, 52);

MoveTo(50, 100);

LineTo(50, 0);

LineTo(48, 5);

MoveTo(50, 0);

LineTo(52, 5);

Brush.Style := bsClear;

Font.name := 'arial';

Font.Size := 6;

TextOut(55, 0, 'Y');

TextOut(95, 38, 'X');

Pen.Color := clRed;

for i := low(p) to high(p) do

p[i] := Point(i, round(50 - 30 * sin((i - 50) / 5)));

Polyline(p);

end;

mfc.Free;

mf.SaveToClipboardFormat(ClipBrdFormat, data, palette);

OpenClipboard(Application.Handle);

EmptyClipboard;

SetClipboardData(ClipBrdFormat, data);

CloseClipboard;

mf.Inch := 200;

Form1.Canvas.Draw(0, 0, mf);

mf.Free;

end;

Как копировать и вставлять картинки через буфер обмена?

2017-10-20T00:13:17+07:00

Как копировать и вставлять картинки через буфер обмена?

Previous Top Next

Некоторые функции для копирования и вставки Bitmap-объектов через буфер обмена.

Подробнее...

Как копировать/менять Clipboard text без использования VCL?

2017-10-20T00:01:58+07:00

Code:

procedure CopyStringToClipboard(s: string);

var

hg: THandle;

P: PChar;

begin

hg:=GlobalAlloc(GMEM_DDESHARE or GMEM_MOVEABLE, Length(S)+1);

P:=GlobalLock(hg);

StrPCopy(P, s);

GlobalUnlock(hg);

OpenClipboard(Application.Handle);

SetClipboardData(CF_TEXT, hg);

CloseClipboard;

GlobalFree(hg);

end;

Подробнее...

Копирование и вставка данных своего формата из буфера обмена

2017-10-20T00:21:21+07:00

TClipboard обеспечивает легкий доступ к буферу обмена. Но что делать, если вы хотите добавить (несколько) определенных элементов в буфер обмена?

Для всех действий требуется unit Clipboard.

Подробнее...

Скопировать изображение формы

2017-10-20T00:15:13+07:00

Code:

uses clipbrd;

procedure TShowVRML.Kopieren1Click(Sender: TObject);

var

bitmap: tbitmap;

begin

bitmap := tbitmap.create;

bitmap.width := clientwidth;

bitmap.height := clientheight;

try

with bitmap.Canvas do

CopyRect(clientrect, canvas, clientrect);

clipboard.assign(bitmap);

finally

bitmap.free;

end;

Hook на буфер обмена

2017-10-19T20:23:39+07:00

*Просто создайте новую форму и назовите его ClipFormats.

*Поместите TButton и вызывай его btnUpdate.

*Поместите лист бокс и вызывай его lbFormats.

Затем просто добавьте приведенный ниже код и подключить все обработчики событий.

Все это делает дисплей в настоящее время все форматы в буфере обмена и

обновления как только изменения буфера обмена.

Подробнее...

Использование интерфейса OLE

2017-10-19T20:10:37+07:00

Использование интерфейса OLE

Значение, которое придается сегодня внедрению интерфейса OLE, трудно переоценить. Фирма Microsoft извещает о том, что на получение логотипа "Windows 95 Compatible" будут сертифицированы только те приложения, которые имеют средства работы с OLE.

Разъяснять суть механизмов OLE с точки зрения пользователя здесь не имеет смысла; кратко опишем их с точки зрения программиста.

Подробнее...

Как программно реализовать Cut, Copy и Paste?

2017-10-19T19:28:31+07:00

Следущие операции производятся с активным контролом на форме:

Code:

procedure TForm1.Cut1Click(Sender: TObject);

begin

SendMessage (ActiveControl.Handle, WM_Cut, 0, 0);

end;

procedure TForm1.Copy1Click(Sender: TObject);

begin

SendMessage (ActiveControl.Handle, WM_Copy, 0, 0);

end;

procedure TForm1.Paste1Click(Sender: TObject);

begin

SendMessage (ActiveControl.Handle, WM_Paste, 0, 0);

end;

Если Вы разрабатываете приложение MDI, то необходимо отправлять сообщение в активное дочернее окно, т.е. использовать: ActiveMDIChild.ActiveControl.Handle

Как работать с буфером обмена (clipboard)?

2017-10-19T18:58:30+07:00

Этот пример использует картинку, кнопку и компонент shape на форме. Когда пользователь кликает по кнопке, то изображение формы сохраняется в в переменной FormImage и копируется в буфер обмена (Clipboard). Затем изображение формы копируется обратно в компонент картинки, тем самым создавая интересный эффект, особенно, если кнопку понажимать несколько раз.

Подробнее...

Как удобнее работать с буфером обмена как с последовательностью байт?

2017-10-19T19:36:06+07:00

Code:

unit ClipStrm;

interface uses Classes, Windows;

type

TClipboardStream = class(TStream)

private

FMemory : pointer;

FSize : longint;

FPosition : longint;

FFormat : word;

public

constructor Create(fmt : word);

destructor Destroy; override;

function Read(var Buffer; Count : Longint) : Longint; override;

function Write(const Buffer; Count : Longint) : Longint; override;

function Seek(Offset : Longint; Origin : Word) : Longint; override;

end;

implementation uses SysUtils;

constructor TClipboardStream.Create(fmt : word);

var

tmp : pointer;

FHandle : THandle;

begin

FFormat := fmt;

OpenClipboard(0);

FHandle := GetClipboardData(FFormat);

FSize := GlobalSize(FHandle);

FMemory := AllocMem(FSize);

tmp := GlobalLock(FHandle);

MoveMemory(FMemory, tmp, FSize);

GlobalUnlock(FHandle);

FPosition := 0;

CloseClipboard;

end;

destructor TClipboardStream.Destroy;

begin

FreeMem(FMemory);

end;

function TClipboardStream.Read(var Buffer; Count : longint) : longint;

begin

if FPosition + Count > FSize then

Result := FSize - FPosition

else

Result := Count;

MoveMemory(@Buffer, PChar(FMemory) + FPosition, Result);

Inc(FPosition, Result);

end;

function TClipboardStream.Write(const Buffer; Count : longint) : longint;

var

FHandle : HGlobal;

tmp : pointer;

begin

ReallocMem(FMemory, FPosition + Count);

MoveMemory(PChar(FMemory) + FPosition, @Buffer, Count);

FPosition := FPosition + Count;

FSize := FPosition;

FHandle := GlobalAlloc(GMEM_MOVEABLE or GMEM_SHARE or GMEM_ZEROINIT, FSize);

try

tmp := GlobalLock(FHandle);

try

MoveMemory(tmp, FMemory, FSize);

OpenClipboard(0);

SetClipboardData(FFormat, FHandle);

finally

GlobalUnlock(FHandle);

end;

CloseClipboard;

except

GlobalFree(FHandle);

end;

Result := Count;

end;

function TClipboardStream.Seek(Offset : Longint; Origin : Word) : Longint;

begin

case Origin of

0 : FPosition := Offset;

1 : Inc(FPosition, Offset);

2 : FPosition := FSize + Offset;

end;

Result := FPosition;

end;

end.

Alexey Mahotkin alexm@hsys.msk.ru (2:5020/433)

Взято из FAQ: Delphi and Windows API Tips'n'Tricks

olmal@mail.ru

Контроль за изменением содержимого буфера обмена

2017-10-19T19:49:06+07:00

Приложение может быть уведомлено об изменениях в данных, хранящихся в

Буфер обмена Windows, зарегистрировавшись как средство просмотра буфера обмена.

Подробнее...

Копирование в буфер обмена

2017-10-19T19:27:51+07:00

Code:

procedure CopyButtonClick(Sender: TObject);

begin

if ActiveControl is TMemo then

TMemo(ActiveControl).CopyToClipboard;

if ActiveControl is TDBMemo then

TDBMemo(ActiveControl).CopyToClipboard;

if ActiveControl is TEdit then

TEdit(ActiveControl).CopyToClipboard;

if ActiveControl is TDBedit then

TDBedit(ActiveControl).CopyToClipboard;

end;

procedure PasteButtonClick(Sender: TObject);

begin

if ActiveControl is TMemo then

TMemo(ActiveControl).PasteFromClipboard;

if ActiveControl is TDBMemo then

TDBMemo(ActiveControl).PasteFromClipboard;

if ActiveControl is TEdit then

TEdit(ActiveControl).PasteFromClipboard;

if ActiveControl is TDBedit then

TDBedit(ActiveControl).PasteFromClipboard;

end;

Копировать и вставлять ячейки TStringGrid в буфер обмена

2017-10-19T20:33:07+07:00

Code:

uses

Clipbrd;

//Copy

procedure TForm1.Button1Click(Sender: TObject);

var

S: string;

GRect: TGridRect;

C, R: Integer;

begin

GRect := StringGrid1.Selection;

S := '';

for R := GRect.Top to GRect.Bottom do

begin

for C := GRect.Left to GRect.Right do

begin

if C = GRect.Right then S := S + (StringGrid1.Cells[C, R])

else

S := S + StringGrid1.Cells[C, R] + #9;

end;

S := S + #13#10;

end;

ClipBoard.AsText := S;

end;

// Paste

procedure TForm1.Button2Click(Sender: TObject);

var

Grect: TGridRect;

S, CS, F: string;

L, R, C: Byte;

begin

GRect := StringGrid1.Selection;

L := GRect.Left;

R := GRect.Top;

S := ClipBoard.AsText;

R := R - 1;

while Pos(#13, S) > 0 do

begin

R := R + 1;

C := L - 1;

CS := Copy(S, 1,Pos(#13, S));

while Pos(#9, CS) > 0 do

begin

C := C + 1;

if (C <= StringGrid1.ColCount - 1) and (R <= StringGrid1.RowCount - 1) then

StringGrid1.Cells[C, R] := Copy(CS, 1,Pos(#9, CS) - 1);

F := Copy(CS, 1,Pos(#9, CS) - 1);

Delete(CS, 1,Pos(#9, CS));

end;

if (C <= StringGrid1.ColCount - 1) and (R <= StringGrid1.RowCount - 1) then

StringGrid1.Cells[C + 1,R] := Copy(CS, 1,Pos(#13, CS) - 1);

Delete(S, 1,Pos(#13, S));

if Copy(S, 1,1) = #10 then

Delete(S, 1,1);

end;

Подробнее...

Предотвратить работу с командами буфера обмена в TEdit

2017-10-19T20:31:36+07:00

Code:

unit MyEdit;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,

Dialogs, stdctrls, clipbrd;

type

TPreventNotifyEvent = procedure(Sender: TObject; Text: string; var Accept: Boolean) of object;

type

TMyEdit = class(TCustomEdit)

private

FPreventCut: Boolean;

FPreventCopy: Boolean;

FPreventPaste: Boolean;

FPreventClear: Boolean;

FOnCut: TPreventNotifyEvent;

FOnCopy: TPreventNotifyEvent;

FOnPaste: TPreventNotifyEvent;

FOnClear: TPreventNotifyEvent;

procedure WMCut(var Message: TMessage); message WM_CUT;

procedure WMCopy(var Message: TMessage); message WM_COPY;

procedure WMPaste(var Message: TMessage); message WM_PASTE;

procedure WMClear(var Message: TMessage); message WM_CLEAR;

protected

{ Protected declarations }

public

{ Public declarations }

published

property PreventCut: Boolean read FPreventCut write FPreventCut default False;

property PreventCopy: Boolean read FPreventCopy write FPreventCopy default False;

property PreventPaste: Boolean read FPreventPaste write FPreventPaste default False;

property PreventClear: Boolean read FPreventClear write FPreventClear default False;

property OnCut: TPreventNotifyEvent read FOnCut write FOnCut;

property OnCopy: TPreventNotifyEvent read FOnCopy write FOnCopy;

property OnPaste: TPreventNotifyEvent read FOnPaste write FOnPaste;

property OnClear: TPreventNotifyEvent read FOnClear write FOnClear;

end;

procedure Register;

implementation

procedure TMyEdit.WMCut(var Message: TMessage);

var

Accept: Boolean;

Handle: THandle;

HandlePtr: Pointer;

CText: string;

begin

if FPreventCut then

Exit;

if SelLength = 0 then

Exit;

CText := Copy(Text, SelStart + 1, SelLength);

try

OpenClipBoard(Self.Handle);

Accept := True;

if Assigned(FOnCut) then

FOnCut(Self, CText, Accept);

if not Accept then

Exit;

Handle := GlobalAlloc(GMEM_MOVEABLE + GMEM_DDESHARE, Length(CText) + 1);

if Handle = 0 then

Exit;

HandlePtr := GlobalLock(Handle);

Move((PChar(CText))^, HandlePtr^, Length(CText));

SetClipboardData(CF_TEXT, Handle);

GlobalUnlock(Handle);

CText := Text;

Delete(CText, SelStart + 1, SelLength);

Text := CText;

finally

CloseClipBoard;

end;

procedure TMyEdit.WMCopy(var Message: TMessage);

var

Accept: Boolean;

Handle: THandle;

HandlePtr: Pointer;

CText: string;

begin

if FPreventCopy then

Exit;

if SelLength = 0 then

Exit;

CText := Copy(Text, SelStart + 1, SelLength);

try

OpenClipBoard(Self.Handle);

Accept := True;

if Assigned(FOnCopy) then

FOnCopy(Self, CText, Accept);

if not Accept then

Exit;

Handle := GlobalAlloc(GMEM_MOVEABLE + GMEM_DDESHARE, Length(CText) + 1);

if Handle = 0 then

Exit;

HandlePtr := GlobalLock(Handle);

Move((PChar(CText))^, HandlePtr^, Length(CText));

SetClipboardData(CF_TEXT, Handle);

GlobalUnlock(Handle);

finally

CloseClipBoard;

end;

procedure TMyEdit.WMPaste(var Message: TMessage);

var

Accept: Boolean;

Handle: THandle;

CText: string;

LText: string;

AText: string;

begin

if FPreventPaste then

Exit;

if IsClipboardFormatAvailable(CF_TEXT) then

begin

try

OpenClipBoard(Self.Handle);

Handle := GetClipboardData(CF_TEXT);

if Handle = 0 then

Exit;

CText := StrPas(GlobalLock(Handle));

GlobalUnlock(Handle);

Accept := True;

if Assigned(FOnPaste) then

FOnPaste(Self, CText, Accept);

if not Accept then

Exit;

LText := '';

if SelStart > 0 then

LText := Copy(Text, 1, SelStart);

LText := LText + CText;

AText := '';

if (SelStart + 1) < Length(Text) then

AText := Copy(Text, SelStart + SelLength + 1, Length(Text) - SelStart + SelLength + 1);

Text := LText + AText;

finally

CloseClipBoard;

end;

procedure TMyEdit.WMClear(var Message: TMessage);

var

Accept: Boolean;

CText: string;

begin

if FPreventClear then

Exit;

if SelStart = 0 then

Exit;

CText := Copy(Text, SelStart + 1, SelLength);

Accept := True;

if Assigned(FOnClear) then

FOnClear(Self, CText, Accept);

if not Accept then

Exit;

CText := Text;

Delete(CText, SelStart + 1, SelLength);

Text := CText;

end;

procedure Register;

begin

RegisterComponents('Samples', [TMyEdit]);

end;

end.

Просмотр буфера обмена

2017-10-19T20:17:02+07:00

Просмотр буфера обмена.

Пример на основе простого модуля-класса, осуществляющего просмотр буфера обмена.

Подробнее...

Скопировать HTML-код в буфер обмена

2017-10-19T20:29:27+07:00

Если вы когда-нибудь пробовали вставлять html в буфер обмена, используя обычный CF_TEXT

формате, то вы, возможно, были разочарованы, обнаружив, что визуальный HTML-код

редакторы вставляют ваше предложение, как если бы это был только текст,

вместо того, чтобы распознавать его как html. Для этого нужен формат CF_HTML.

CF_HTML полностью текстовый формат и использует формат преобразования UTF-8.

Он включает в себя описание контекста, и в контексте фрагмента.

Подробнее...

Скопировать строки TListBox в буфер обмена

2017-10-19T20:32:11+07:00

Code:

uses

Clipbrd;

procedure ListBoxToClipboard(ListBox: TListBox;

BufferSize: Integer;

CopyAll: Boolean);

var

Buffer: PChar;

Size: Integer;

Ptr: PChar;

I: Integer;

Line: string[255];

Count: Integer;

begin

if not Assigned(ListBox) then

Exit;

GetMem(Buffer, BufferSize);

Ptr := Buffer;

Count := 0;

for I := 0 to ListBox.Items.Count - 1 do

begin

Line := ListBox.Items.strings[I];

if not CopyAll and ListBox.MultiSelect and (not ListBox.Selected[I]) then

Continue;

{ Check buffer overflow }

Count := Count + Length(Line) + 3;

if Count = BufferSize then

Break;

{ Append to buffer }

Move(Line[1], Ptr^, Length(Line));

Ptr := Ptr + Length(Line);

Ptr[0] := #13;

Ptr[1] := #10;

Ptr := Ptr + 2;

end;

Ptr[0] := #0;

ClipBoard.SetTextBuf(Buffer);

FreeMem(Buffer, BufferSize);

end;

procedure ClipboardToListBox(ListBox: TListbox);

begin

if not Assigned(ListBox) then

Exit;

if not Clipboard.HasFormat(CF_TEXT) then

Exit;

Listbox.Items.Text := Clipboard.AsText;

end;

//Copy all items from Listbox1 to the clipboard

procedure TForm1.Button1Click(Sender: TObject);

begin

ListBoxToClipboard(ListBox1, 1024, True);

end;

//Paste items in clipboard to Listbox2

procedure TForm1.Button2Click(Sender: TObject);

begin

ClipboardToListBox(Listbox2);

end;

//Copy only selected items from Listbox1 to the clipboard

procedure TForm1.Button3Click(Sender: TObject);

begin

ListBoxToClipboard(Listbox1, 1024, False);

end;

Сохранение данных в Clipboard

2017-10-19T20:30:45+07:00

Мне нужно использовать clipboard для сохранения данных в собственном формате и я хочу для этого написать набор процедур ввода/вывода с использованием потоков (streams). Возможно ли создать объект TMemoryStream, эаполнить его и поместить в Clipboard?

Hе только возможно, именно так поступают функции Clipboard.GetComponent и Clipboard.SetComponent. Сначала вы должны зарегистрировать свой собственный формат данных для Clipboard с помощью функции RegisterClipboardFormat:

Подробнее...

Сэмулировать нажатие клавиш для копии и вставки из буфера

2017-10-19T20:26:02+07:00

Code:

//Ctrl+C, Strg+C:

keybd_event(VK_CONTROL, MapVirtualKey(VK_CONTROL, 0), 0, 0);

keybd_event(Ord('C'), MapVirtualKey(Ord('C'), 0), 0, 0);

keybd_event(Ord('C'), MapVirtualKey(Ord('C'), 0), KEYEVENTF_KEYUP, 0);

keybd_event(VK_CONTROL, MapVirtualKey(VK_CONTROL, 0), KEYEVENTF_KEYUP, 0)

//Ctrl+V, Strg+V:

keybd_event(VK_CONTROL, MapVirtualKey(VK_CONTROL, 0), 0, 0);

keybd_event(Ord('V'), MapVirtualKey(Ord('V'), 0), 0, 0);

keybd_event(Ord('V'), MapVirtualKey(Ord('V'), 0), KEYEVENTF_KEYUP, 0);

keybd_event(VK_CONTROL, MapVirtualKey(VK_CONTROL, 0), KEYEVENTF_KEYUP, 0)

Как получить screen shot экрана вместе с указателем мыша?

2017-10-19T17:22:22+07:00

надо его вручную дорисовать

Code:

procedure GetScreenImage(bmp: TBitmap);

var

CI: TCursorInfo;

Icon: TIcon;

II: TIconInfo;

r: TRect;

begin

bmp.Width:= Screen.Width;

bmp.Height:= Screen.Height;

BitBlt(bmp.Canvas.Handle,0,0,Screen.Width,Screen.Height,

GetDC(GetDesktopWindow),0,0,SRCCopy);

//дорисуем курсор

Icon:=TIcon.Create;

r:=Rect(0,0,GetSystemMetrics(SM_CXSCREEN),GetSystemMetrics(SM_CYSCREEN));

CI.cbSize:=SizeOf(CI);

if (GetCursorInfo(CI)) and (CI.flags=CURSOR_SHOWING) then

begin

Icon.Handle:=CopyIcon(CI.hCursor);

if GetIconInfo(Icon.Handle,II) then

bmp.Canvas.Draw(ci.ptScreenPos.x - Integer(II.xHotspot) - r.Left, ci.ptScreenPos.y - Integer(II.yHotspot) - r.Top, Icon);

end;

Автор P.O.D

Подробнее...

Как рисовать на экране

2017-10-19T17:54:18+07:00

Обладая такими способностями, вы сможете, например, разлиновать поверхность экрана как в тетради в клеточку, выводить пугающие пользователя надписи и даже создать эффект окаменение экрана, если, конечно, разработаете алгоритм выполнения данной задачи.

Подробнее...

Копирование содержимого экрана на форму

2017-10-19T17:36:28+07:00

сode:

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;

Подробнее...

Перетасовка экрана

2017-10-19T17:39:12+07:00

В статье описывается пример, который позволяет разделить экран на блоки, а затем поменять эти блоки местами. Так же можно менять размеры блоков и скорость их перемещения. На мой взгляд неплохое начало для создания логической игрушки либо экранной заставки.

Уверен, что каждый из Вас уже хоть раз видел что-то подобное в действии. При запуске, программа берёт изображение десктопа и разделяет его на определённое количество прямоугольных частей (одинакового размера). После этого часть блоков случайным образом перемещается со своего первоначального места.

Подробнее...

Получение изображения экрана

2017-10-19T17:34:56+07:00

В качестве параметров передаются:

AHandle - хэндл окна, скриншот которого мы хочем получить

CompressPercent - процент сжатия картинки

AImage - картинка, в которую будет помещено изображение

в случае успешного скриншота функция вернет True {©Drkb v.3}

Подробнее...

Сохранение изображения экрана в файле

2017-10-19T17:28:44+07:00

На форме у меня стоит TImage (его можно сделать невидимым)

Подробнее...

Эмуляция многоэкранного режима

2017-10-19T17:47:19+07:00

Я хочу представить простой мульти-экран эмулятор, написанный на Delphi.

Он состоит в небольшой форме размещения в правом нижнем углу экрана, прямо над трее, которая состоит из 5 кнопок.

В начале первая кнопка вниз; затем, когда я нажимаю другую кнопку, открывается новый новый рабочий стол. В этом новом рабочем столе я могу открыть другие программы

и так далее с другими кнопками. Когда я вернусь к одной из кнопок, Я буду видеть только заявки, открытые в этом конкурсе без других.

Фокус состоит в том, чтобы сделать следующие шаги непосредственно перед нажатием другой кнопки:

Подробнее...

Hook функций в собственном приложении

2017-11-27T21:01:18+07:00

Code:

type

TSaveRedir = packed record

Addr: Pointer;

Bytes: array[0..4] of Byte;

end;

PSaveRedir = ^TSaveRedir;

procedure RedirectCall(FromAddr, ToAddr: Pointer; SaveRedir: PSaveRedir);

var

OldProtect: Cardinal;

NewCode: packed record

JMP: Byte;

Distance: Integer;

end;

begin

if not VirtualProtect(FromAddr, 5, PAGE_EXECUTE_READWRITE, OldProtect) then

RaiseLastWin32Error;

if Assigned(SaveRedir) then

begin

SaveRedir^.Addr := FromAddr;

Move(FromAddr^, SaveRedir^.Bytes, 5);

end;

NewCode.JMP := $E9;

NewCode.Distance := PChar(ToAddr) - PChar(FromAddr) - 5;

Move(NewCode, FromAddr^, 5);

if not VirtualProtect(FromAddr, 5, OldProtect, OldProtect) then

RaiseLastWin32Error;

end;

procedure UndoRedirectCall(const SaveRedir: TSaveRedir);

var

OldProtect: Cardinal;

begin

if not VirtualProtect(SaveRedir.Addr, 5, PAGE_EXECUTE_READWRITE, OldProtect) then

RaiseLastWin32Error;

Move(SaveRedir.Bytes, SaveRedir.Addr^, 5);

if not VirtualProtect(SaveRedir.Addr, 5, OldProtect, OldProtect) then

RaiseLastWin32Error;

end;

// Example: Replace Application.MessageBox with your own.

function MyNewMessageBox(Self: TApplication; const Text, Caption: PChar;

Flags: Longint): Integer;

begin

ShowMessage('New Messagebox');

//....

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

Application.MessageBox('You`ll never see this Text /

Diesen Text wirst du nie sehen', '...', MB_OK);

end;

var

S: TSaveRedir;

initialization

RedirectCall(@TApplication.MessageBox, @MyNewMessageBox, @S);

finalization

UndoRedirectCall(S);

Hooks - аспекты реализации

2017-11-27T20:29:17+07:00

Моя обзорная статья на тему вариантов использования динамически компонуемых библиотек (DLL) вызвала множество вопросов, большая часть которых касалась использования глобальных ловушек (Hook) и размещению разного рода ресурсов в DLL. О ресурсах поговорим в следующий раз, а пока попробуем разобраться с ловушками.

Сразу хочу сделать несколько оговорок: речь в дальнейшем пойдёт только о 32-х разрядной Windows и о глобальных ловушках, т.к. именно при их программировании возникает большинство ошибок; все примеры будут даваться на Delphi, т.к. примеров и описаний для любителей С++ достаточно.

Подробнее...

Interprocess communication на примере keyboard hook (статья)

2017-11-27T21:00:31+07:00

Взаимодействие процессов

Архитектура Win32 подразумевает максимальную изоляцию выполняющихся приложений друг от друга. Каждое приложение выполняется в своем виртуальном адресном пространстве, которое полностью обособлено и не имеет доступа к памяти других программ. Однако иногда возникает необходимость в передаче данных их одного выполняющегося процесса в другой. Рассмотрим подробно одну из таких задач, а затем основные способы связи между процессами и рекомендации по их применению.

Пишем перехватчик клавиатуры

Подробнее...

Глобальный хук на клавиатуру

2017-11-27T21:11:17+07:00

Code:

library Hook;

uses Windows, SysUtils;

const KF_UP_MY = $40000000;

var CurrentHook: HHook;

KeyArray: array[0..19] of char;

KeyArrayPtr: integer;

CurFile:text;

function GlobalKeyBoardHook(code: integer; wParam: integer; lParam:

integer): longword; stdcall;

var

i:integer;

begin

if code< 0 then

begin

result:=CallNextHookEx(CurrentHook,code,wParam,lparam);

Exit;

end;

if ( (lParam and KF_UP_MY ) = 0) and (wParam> =65) and (wParam< =90) then

begin

KeyArray[KeyArrayPtr]:=char(wParam);

KeyArrayPtr:=KeyArrayPtr+1;

if KeyArrayPtr> 19 then

begin

for i:=0 to 19 do

begin

Assignfile(CurFile,'d:\log.txt');

if fileexists('d:\log.txt')=false then rewrite(CurFile)

else Append(CurFile);

write(Curfile, KeyArray[i]);

closefile(curfile);

end;

KeyArrayPtr:=0;

end;

CallNextHookEx(CurrentHook,code,wParam,lparam);

result:=0;

end;

procedure SetupGlobalKeyBoardHook;

begin

CurrentHook:=SetWindowsHookEx(WH_KEYBOARD, @GlobalKeyBoardHook,HInstance, 0);

KeyArrayptr:=0;

end;

procedure unhook;

begin

UnhookWindowshookEx(CurrentHook);

end;

exports

SetupGlobalKeyBoardHook, UnHook;

begin

end.

Демонстрационный пример хука и подмены API в приложениях

2017-11-27T21:05:37+07:00

// * Unit Name : HookDLL

// * Purpose : Демонстрационный пример хука и подмены API в приложениях...

// * Author : Александр (Rouse_) Багель

// * Version : 1.00

Код не маленький, посему вынесем отдельно

Подробнее...

Использование HOOK в Дельфи

2017-11-27T20:46:52+07:00

Что такое НООК?

НООК - это механизм перехвата сообщений, предоставляемый системой Microsoft Windows. Программист пишет специального вида функцию (НООК-функция), которая затем при помощи функции SetWindowsHookEx вставляется на верх стека НООК-функций системы. Ваша НООК-функция сама решает, передать ли ей сообщение в следующую НООК-функцию при помощи CallNextHookEx или нет.

Какие бывает НООК'и?

НООК бывают глобальные, контролирующие всю систему, так и локальные, ориентированные на какой-либо поток (Thread). Кроме того НООК различаются по типу перехватываемых сообщений (подробнее об этом - ниже). НООК несколько подтормаживают систему, поэтому ставить их рекомендуется только при необходимости, и кактолько необходимость в них отпадает - удалять.

Подробнее...

Использование ловушек, блокировка мышки, клавиатуры и т.д.

2017-11-27T20:38:41+07:00

Возможные вариации: Любые вопросы, связанные с постановкой хука. Например "Как отследить [что-то]", "Как подменить [какое-то действие]", "Как заблокировать комбинации клавиш, как заблокировать определённые действия", "Как не дать запускаться определённым приложениям, не дать открываться определённым окнам?", "Как получить список запущенных оконных приложений?" и т.д.

Рабочий пример глобальной блокировки правой кнопки мыши:

Подробнее...

Ловушки в Windows

2017-11-27T21:01:58+07:00

Для отслеживания каких-то событий во всей Windows нужно установить ловушку (hook). Например, такая ловушка может отслеживать все события, связанные с мышью, где бы ни находился курсор. Можно отслеживать и события клавиатуры.

Для ловушки нужна функция, которая, после установки ловушки при помощи SetWindowsHookEx, будет вызываться при каждом нужном событии. Эта функция получает всю информацию о событии. UnhookWindowsHookEx уничтожает ловушку.

Эта программа отслеживает все сообщения, связанные с мышью и клавиатурой. CheckBox1 показывает состояние левой клавиши мыши, CheckBox2 показывает состояние правой клавиши мыши, а CheckBox3 показывает, нажата ли какая-либо клавиша на клавиатуре.

Подробнее...

Отключить клавиши при системном Hooke

2017-11-27T21:15:20+07:00

** Что такое крюк? **

Крюк-это точка в механизме обработки системных сообщений, где приложение может установить подпрограмму для мониторинга трафика сообщений в

системе и обрабатывать определенные типы Сообщений прежде, чем они достигнут целевой оконной процедуры.

Чтобы использовать механизм окна крюк, программа вызывает функцию SetWindowsHookEx() API-интерфейс, передача адреса процедуры hook, которая уведомляется, когда указанное

событие происходит. SetWindowsHookEx() возвращает адрес ранее установленного обработать процедуру для того же типа события. Этот адрес-это важно,

потому что процедуры крючка такого же типа образуют своеобразную цепочку. Windows уведомляет первую процедуру в цепочке при возникновении события,

и каждая процедура отвечает за передачу уведомления. Для этого процедура подключения должна вызвать CallNextHookEx() функции API,

адрес прохождения предыдущей процедуры крюка.

-- >Все системные крючки должны находиться в динамической библиотеке ссылок.

** Тип крюка, используемый в этом примере кода: **

На WH_GETMESSAGE крючок позволяет приложение для мониторинга и перехвата Сообщений о том, чтобы быть возвращены функции getmessage или PeekMessage функции.

Подробнее...

Перехват (Hook) клавиатуры (программа Sendkeys)

2017-11-27T21:16:44+07:00

Code:

program Project1;

uses

Forms,

Unit1 in '..\Hooks1\Unit1.pas' {Form1};

{$R *.RES}

begin

Application.Initialize;

Application.CreateForm(TForm1, Form1);

Application.Run;

end.

// *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* //

Подробнее...

Перехват API функций, на примере MessageBoxA

2017-11-27T20:40:36+07:00

EXE:

Code:

program Project2;

uses windows;

var

sethook:procedure(flag:bool)stdcall;

hDll:hModule;

begin

hDll:=LoadLibrary('Mouse_mes.dll');

@sethook:=GetProcAddress(hDll, 'sethook');

sethook(true);

messagebox(0,'Не закрывай, пока идет работа','',0);

sethook(false);

FreeLibrary(hDll);

end.

Подробнее...

Создание ловушек в Delphi

2017-11-27T20:35:51+07:00

Рано или поздно каждый программист сталкивается с таким понятим как ловушки. Чтобы приступить к ипользованию ловушек необходимо обзавестись windows SDK, который можно так же скачать с сайта Microsoft. В прилагаемом к статье архиве содержатся два проекта: hooks.dpr - это пример приложения работающего с ловушками, а hookdll.dpr - собственно сама DLL.

Что такое ловушки (Hooks)?

Подробнее...

Установка ловушки для клавиатуры

2017-11-27T21:18:09+07:00

Code:

// 1. Library Code for a Key Hook DLL

library HookLib;

uses

madExcept,

Windows,

Messages,

SysUtils;

type

PHookRec = ^THookRec;

THookRec = record

AppHnd: Integer;

MemoHnd: Integer;

end;

var

Hooked: Boolean;

hKeyHook, hMemo, hMemFile, hApp: HWND;

PHookRec1: PHookRec;

function KeyHookFunc(Code, VirtualKey, KeyStroke: Integer): LRESULT; stdcall;

var

KeyState1: TKeyBoardState;

AryChar: array[0..1] of Char;

Count: Integer;

begin

Result := 0;

if Code = HC_NOREMOVE then Exit;

Result := CallNextHookEx(hKeyHook, Code, VirtualKey, KeyStroke);

{I moved the CallNextHookEx up here but if you want to block

or change any keys then move it back down}

if Code < 0 then

Exit;

if Code = HC_ACTION then

begin

if ((KeyStroke and (1 shl 30)) <> 0) then

if not IsWindow(hMemo) then

begin

{I moved the OpenFileMapping up here so it would not be opened

unless the app the DLL is attatched to gets some Key messages}

hMemFile := OpenFileMapping(FILE_MAP_WRITE, False, 'Global7v9k');

PHookRec1 := MapViewOfFile(hMemFile, FILE_MAP_WRITE, 0, 0, 0);

if PHookRec1 <> nil then

begin

hMemo := PHookRec1.MemoHnd;

hApp := PHookRec1.AppHnd;

end;

if ((KeyStroke and (1 shl 30)) <> 0) then

begin

GetKeyboardState(KeyState1);

Count := ToAscii(VirtualKey, KeyStroke, KeyState1, AryChar, 0);

if Count = 1 then

begin

SendMessage(hMemo, WM_CHAR, Ord(AryChar[0]), 0);

{I included 2 ways to get the Charaters, a Memo Hnadle and

a WM_USER+1678 message to the program}

PostMessage(hApp, WM_USER + 1678, Ord(AryChar[0]), 0);

end;

function StartHook(MemoHandle, AppHandle: HWND): Byte; export;

begin

Result := 0;

if Hooked then

begin

Result := 1;

Exit;

end;

if not IsWindow(MemoHandle) then

begin

Result := 4;

Exit;

end;

hKeyHook := SetWindowsHookEx(WH_KEYBOARD, KeyHookFunc, hInstance, 0);

if hKeyHook > 0 then

begin

{you need to use a mapped file because this DLL attatches to every app

that gets windows messages when it's hooked, and you can't get info except

through a Globally avaiable Mapped file}

hMemFile := CreateFileMapping($FFFFFFFF, // $FFFFFFFF gets a page memory file

nil, // no security attributes

PAGE_READWRITE, // read/write access

0, // size: high 32-bits

SizeOf(THookRec), // size: low 32-bits

//SizeOf(Integer),

'Global7v9k'); // name of map object

PHookRec1 := MapViewOfFile(hMemFile, FILE_MAP_WRITE, 0, 0, 0);

hMemo := MemoHandle;

PHookRec1.MemoHnd := MemoHandle;

hApp := AppHandle;

PHookRec1.AppHnd := AppHandle;

{set the Memo and App handles to the mapped file}

Hooked := True;

end

else

Result := 2;

end;

function StopHook: Boolean; export;

begin

if PHookRec1 <> nil then

begin

UnmapViewOfFile(PHookRec1);

CloseHandle(hMemFile);

PHookRec1 := nil;

end;

if Hooked then

Result := UnhookWindowsHookEx(hKeyHook)

else

Result := True;

Hooked := False;

end;

procedure EntryProc(dwReason: DWORD);

begin

if (dwReason = Dll_Process_Detach) then

begin

if PHookRec1 <> nil then

begin

UnmapViewOfFile(PHookRec1);

CloseHandle(hMemFile);

end;

UnhookWindowsHookEx(hKeyHook);

end;

exports

StartHook,

StopHook;

begin

PHookRec1 := nil;

Hooked := False;

hKeyHook := 0;

hMemo := 0;

DLLProc := @EntryProc;

EntryProc(Dll_Process_Attach);

end.

2. Code from the calling Program

{this program get's the Char from the DLL in 2 ways,

as a Char message to a Memo and as a DLLMessage WM_USER+1678}

Code:

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,

Dialogs, StdCtrls;

type

TForm1 = class(TForm)

but_StartHook: TButton;

but_StopHook: TButton;

label1: TLabel;

Memo1: TMemo;

procedure but_StartHookClick(Sender: TObject);

procedure but_StopHookClick(Sender: TObject);

private

{ Private declarations }

hLib2: THandle;

DllStr1: string;

procedure DllMessage(var Msg: TMessage); message WM_USER + 1678;

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.DllMessage(var Msg: TMessage);

begin

if (Msg.wParam = 8) or (Msg.wParam = 13) then Exit;

{the 8 is the Backspace and the 13 if the Enter key, You'll need to

do some special handleing for a string}

DllStr1 := DllStr1 + Chr(Msg.wParam);

label1.Caption := DllStr1;

end;

procedure TForm1.but_StartHookClick(Sender: TObject);

type

TStartHook = function(MemoHandle, AppHandle: HWND): Byte;

var

StartHook1: TStartHook;

SHresult: Byte;

begin

hLib2 := LoadLibrary('HookLib.dll');

@StartHook1 := GetProcAddress(hLib2, 'StartHook');

if @StartHook1 = nil then Exit;

SHresult := StartHook1(Memo1.Handle, Handle);

if SHresult = 0 then ShowMessage('the Key Hook was Started, good');

if SHresult = 1 then ShowMessage('the Key Hook was already Started');

if SHresult = 2 then ShowMessage('the Key Hook can NOT be Started, bad');

if SHresult = 4 then ShowMessage('MemoHandle is incorrect');

end;

procedure TForm1.but_StopHookClick(Sender: TObject);

type

TStopHook = function: Boolean;

var

StopHook1: TStopHook;

hLib21: THandle;

begin

@StopHook1 := GetProcAddress(hLib2, 'StopHook');

if @StopHook1 = nil then

begin

ShowMessage('Stop Hook DLL Mem Addy not found');

Exit;

end;

if StopHook1 then

ShowMessage('Hook was stoped');

FreeLibrary(hLib2);

{for some reason in Win XP you need to call FreeLibrary twice

maybe because you get 2 functions from the DLL? ?}

FreeLibrary(hLib2);

end;

end.

Как изменить имя компьютера?

2017-10-08T23:22:30+07:00

Code:

SetComputerName(PChar(Edit1.text));

Как узнать имя компьютера?

2017-10-08T23:24:06+07:00

Code:

Function ReadComputerName:string;

{©Drkb v.3, ®Vit (Vitaly Nevzorov) }

var

i:DWORD;

p:PChar;

begin

i:=255;

GetMem(p, i);

GetComputerName(p, i);

Result:=String(p);

FreeMem(p);

end;

Подробнее...

Выполняем встроенные команды Windows

2017-10-16T17:41:47+07:00

Впринципе эти команды можно запускать в меню "Выполнить..." (Run), кнопки Пуск. Ну а в Delphi они запускаются путём всем извесной команды winexec(Pchar('ABCD'),sw_Show);

где 'ABCD' - одна из следующих команд ...

Подробнее...

Как пользоваться командой шела - MinimizeAll?

2017-10-16T17:42:49+07:00

Для этого надо импортировать Microsoft Shell Controls & Automation Type Library.

В меню Project..Import Type Library

Выберите Microsoft Shell Controls & Automation (version 1.0).

Нажмите Install...

На панели компонентов, в закладке ActiveX появится несколько компонентов. Перетащите на форму компонент TShell. После этого, например, можно всё минимизировать:

Shell1.MinimizeAll;

Подробнее...

CreateProcess, который возвращает консольный вывод

2017-11-12T04:29:07+07:00

Code:

procedure ExecConsoleApp(CommandLine: AnsiString; Output: TStringList; Errors:

TStringList);

var

sa: TSECURITYATTRIBUTES;

si: TSTARTUPINFO;

pi: TPROCESSINFORMATION;

hPipeOutputRead: THANDLE;

hPipeOutputWrite: THANDLE;

hPipeErrorsRead: THANDLE;

hPipeErrorsWrite: THANDLE;

Res, bTest: Boolean;

env: array[0..100] of Char;

szBuffer: array[0..256] of Char;

dwNumberOfBytesRead: DWORD;

Stream: TMemoryStream;

begin

sa.nLength := sizeof(sa);

sa.bInheritHandle := true;

sa.lpSecurityDescriptor := nil;

CreatePipe(hPipeOutputRead, hPipeOutputWrite, @sa, 0);

CreatePipe(hPipeErrorsRead, hPipeErrorsWrite, @sa, 0);

ZeroMemory(@env, SizeOf(env));

ZeroMemory(@si, SizeOf(si));

ZeroMemory(@pi, SizeOf(pi));

si.cb := SizeOf(si);

si.dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;

si.wShowWindow := SW_HIDE;

si.hStdInput := 0;

si.hStdOutput := hPipeOutputWrite;

si.hStdError := hPipeErrorsWrite;

(* Remember that if you want to execute an app with no parameters you nil the

second parameter and use the first, you can also leave it as is with no

problems. *)

Res := CreateProcess(nil, pchar(CommandLine), nil, nil, true,

CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS, @env, nil, si, pi);

// Procedure will exit if CreateProcess fail

if not Res then

begin

CloseHandle(hPipeOutputRead);

CloseHandle(hPipeOutputWrite);

CloseHandle(hPipeErrorsRead);

CloseHandle(hPipeErrorsWrite);

Exit;

end;

CloseHandle(hPipeOutputWrite);

CloseHandle(hPipeErrorsWrite);

//Read output pipe

Stream := TMemoryStream.Create;

try

while true do

begin

bTest := ReadFile(hPipeOutputRead, szBuffer, 256, dwNumberOfBytesRead,

nil);

if not bTest then

begin

break;

end;

Stream.Write(szBuffer, dwNumberOfBytesRead);

end;

Stream.Position := 0;

Output.LoadFromStream(Stream);

finally

Stream.Free;

end;

//Read error pipe

Stream := TMemoryStream.Create;

try

while true do

begin

bTest := ReadFile(hPipeErrorsRead, szBuffer, 256, dwNumberOfBytesRead,

nil);

if not bTest then

begin

break;

end;

Stream.Write(szBuffer, dwNumberOfBytesRead);

end;

Stream.Position := 0;

Errors.LoadFromStream(Stream);

finally

Stream.Free;

end;

WaitForSingleObject(pi.hProcess, INFINITE);

CloseHandle(pi.hProcess);

CloseHandle(hPipeOutputRead);

CloseHandle(hPipeErrorsRead);

end;

(* got it from yahoo groups, so no copyrights for this piece :p and and example

of how to use it. put a button and a memo to a form. *)

procedure TForm1.Button1Click(Sender: TObject);

var

OutP: TStringList;

ErrorP: TStringList;

begin

OutP := TStringList.Create;

ErrorP := TstringList.Create;

ExecConsoleApp('ping localhost', OutP, ErrorP);

Memo1.Lines.Assign(OutP);

OutP.Free;

ErrorP.Free;

end;

CRT для консольного приложения

2017-11-12T04:49:23+07:00

Code:

$IfDef VER130}

{$Define NEW_STYLES}

{$EndIf}

{$IfDef VER140}

{$Define NEW_STYLES}

{$EndIf}

{..$Define HARD_CRT} {Redirect STD_...}

{..$Define CRT_EVENT} {CTRL-C,...}

{$Define MOUSE_IS_USED} {Handle mouse or not}

{..$Define OneByOne} {Block or byte style write}

unit CRT32;

Interface

{$IfDef Win32}

Const

{ CRT modes of original CRT unit }

BW40 = 0; { 40x25 B/W on Color Adapter }

CO40 = 1; { 40x25 Color on Color Adapter }

BW80 = 2; { 80x25 B/W on Color Adapter }

CO80 = 3; { 80x25 Color on Color Adapter }

Mono = 7; { 80x25 on Monochrome Adapter }

Font8x8 = 256;{ Add-in for ROM font }

{ Mode constants for 3.0 compatibility of original CRT unit }

C40 = CO40;

C80 = CO80;

{ Foreground and background color constants of original CRT unit }

Black = 0;

Blue = 1;

Green = 2;

Cyan = 3;

Red = 4;

Magenta = 5;

Brown 6;

LightGray = 7;

{ Foreground color constants of original CRT unit }

DarkGray = 8;

LightBlue = 9;

LightGreen = 10;

LightCyan = 11;

LightRed = 12;

LightMagenta = 13;

Yellow = 14;

White = 15;

{ Add-in for blinking of original CRT unit }

Blink = 128;

{ }

{ New constans there are not in original CRT unit }

{ }

MouseLeftButton = 1;

MouseRightButton = 2;

MouseCenterButton = 4;

var

{ Interface variables of original CRT unit }

CheckBreak: Boolean; { Enable Ctrl-Break }

CheckEOF: Boolean; { Enable Ctrl-Z }

DirectVideo: Boolean; { Enable direct video addressing }

CheckSnow: Boolean; { Enable snow filtering }

LastMode: Word; { Current text mode }

TextAttr: Byte; { Current text attribute }

WindMin: Word; { Window upper left coordinates }

WindMax: Word; { Window lower right coordinates }

{ }

{ New variables there are not in original CRT unit }

{ }

MouseInstalled: boolean;

MousePressedButtons: word;

{ Interface functions & procedures of original CRT unit }

procedure AssignCrt(var F: Text);

function KeyPressed: Boolean;

function ReadKey: char;

procedure TextMode(Mode: Integer);

procedure Window(X1, Y1, X2, Y2: Byte);

procedure GotoXY(X, Y: Byte);

function WhereX: Byte;

function WhereY: Byte;

procedure ClrScr;

procedure ClrEol;

procedure InsLine;

procedure DelLine;

procedure TextColor(Color: Byte);

procedure TextBackground(Color: Byte);

procedure LowVideo;

procedure HighVideo;

procedure NormVideo;

procedure Delay(MS: Word);

procedure Sound(Hz: Word);

procedure NoSound;

{ New functions & procedures there are not in original CRT unit }

procedure FillerScreen(FillChar: Char);

procedure FlushInputBuffer;

function GetCursor: Word;

procedure SetCursor(NewCursor: Word);

function MouseKeyPressed: Boolean;

procedure MouseGotoXY(X, Y: Integer);

function MouseWhereY: Integer;

function MouseWhereX: Integer;

procedure MouseShowCursor;

procedure MouseHideCursor;

{ These functions & procedures are for inside use only }

function MouseReset: Boolean;

procedure WriteChrXY(X, Y: Byte; Chr: char);

procedure WriteStrXY(X, Y: Byte; Str: PChar; dwSize: Integer);

procedure OverwriteChrXY(X, Y: Byte; Chr: char);

{$EndIf Win32}

implementation

{$IfDef Win32}

uses Windows, SysUtils;

type

POpenText = ^TOpenText;

TOpenText = function(var F: Text; Mode: Word): Integer; far;

var

IsWinNT: boolean;

PtrOpenText: POpenText;

hConsoleInput: THandle;

hConsoleOutput: THandle;

ConsoleScreenRect: TSmallRect;

StartAttr: word;

LastX, LastY: byte;

SoundDuration: integer;

SoundFrequency: integer;

OldCP: integer;

MouseRowWidth, MouseColWidth: word;

MousePosX, MousePosY: smallInt;

MouseButtonPressed: boolean;

MouseEventTime: TDateTime;

{ }

{ This function handles the Write and WriteLn commands }

{ }

function TextOut(var F: Text): Integer; far;

{$IfDef OneByOne}

var

dwSize: DWORD;

{$EndIf}

begin

with TTExtRec(F) do

begin

if BufPos > 0 then

begin

LastX := WhereX;

LastY := WhereY;

{$IfDef OneByOne}

dwSize := 0;

while (dwSize < BufPos) do

begin

WriteChrXY(LastX, LastY, BufPtr[dwSize]);

Inc(dwSize);

end;

{$Else}

WriteStrXY(LastX, LastY, BufPtr, BufPos);

FillChar(BufPtr^, BufPos + 1, #0);

{$EndIf}

BufPos := 0;

end;

Result := 0;

end;

{ }

{ This function handles the exchanging of Input or Output }

{ }

function OpenText(var F: Text; Mode: Word): Integer; far;

var

OpenResult: integer;

begin

OpenResult := 102; { Text not assigned }

if Assigned(PtrOpenText) then

begin

TTextRec(F).OpenFunc := PtrOpenText;

OpenResult := PtrOpenText^(F, Mode);

if OpenResult = 0 then

begin

if Mode = fmInput then

hConsoleInput := TTextRec(F).Handle

else

begin

hConsoleOutput := TTextRec(F).Handle;

TTextRec(Output).InOutFunc := @TextOut;

TTextRec(Output).FlushFunc := @TextOut;

end;

Result := OpenResult;

end;

{ }

{ Fills the current window with special character }

{ }

procedure FillerScreen(FillChar: Char);

var

Coord: TCoord;

dwSize, dwCount: DWORD;

Y: integer;

begin

Coord.X := ConsoleScreenRect.Left;

dwSize := ConsoleScreenRect.Right - ConsoleScreenRect.Left + 1;

for Y := ConsoleScreenRect.Top to ConsoleScreenRect.Bottom do

begin

Coord.Y := Y;

FillConsoleOutputAttribute(hConsoleOutput, TextAttr, dwSize, Coord, dwCount);

FillConsoleOutputCharacter(hConsoleOutput, FillChar, dwSize, Coord, dwCount);

end;

GotoXY(1,1);

end;

{ }

{ Write one character at the X,Y position }

{ }

procedure WriteChrXY(X, Y: Byte; Chr: char);

var

Coord: TCoord;

dwSize, dwCount: DWORD;

begin

LastX := X;

LastY := Y;

case Chr of

#13: LastX := 1;

#10:

begin

LastX := 1;

Inc(LastY);

end;

else

begin

Coord.X := LastX - 1 + ConsoleScreenRect.Left;

Coord.Y := LastY - 1 + ConsoleScreenRect.Top;

dwSize := 1;

FillConsoleOutputAttribute(hConsoleOutput, TextAttr, dwSize, Coord, dwCount);

FillConsoleOutputCharacter(hConsoleOutput, Chr, dwSize, Coord, dwCount);

Inc(LastX);

end;

if (LastX + ConsoleScreenRect.Left) > (ConsoleScreenRect.Right + 1) then

begin

LastX := 1;

Inc(LastY);

end;

if (LastY + ConsoleScreenRect.Top) > (ConsoleScreenRect.Bottom + 1) then

begin

Dec(LastY);

GotoXY(1,1);

DelLine;

end;

GotoXY(LastX, LastY);

end;

{ }

{ Write string into the X,Y position }

{ }

(* !!! The WriteConsoleOutput does not write into the last line !!!

Procedure WriteStrXY(X,Y: byte; Str: PChar; dwSize: integer );

{$IfDef OneByOne}

Var

dwCount: integer;

{$Else}

Type

PBuffer= ^TBuffer;

TBUffer= packed array [0..16384] of TCharInfo;

Var

I: integer;

dwCount: DWORD;

WidthHeight,Coord: TCoord;

hTempConsoleOutput: THandle;

SecurityAttributes: TSecurityAttributes;

Buffer: PBuffer;

DestinationScreenRect,SourceScreenRect: TSmallRect;

{$EndIf}

Begin

If dwSize>0 Then Begin

{$IfDef OneByOne}

LastX:=X;

LastY:=Y;

dwCount:=0;

While dwCount < dwSize Do Begin

WriteChrXY(LastX,LastY,Str[dwCount]);

Inc(dwCount);

End;

{$Else}

SecurityAttributes.nLength:=SizeOf(SecurityAttributes)-SizeOf(DWORD);

SecurityAttributes.lpSecurityDescriptor:=NIL;

SecurityAttributes.bInheritHandle:=TRUE;

hTempConsoleOutput:=CreateConsoleScreenBuffer(

GENERIC_READ OR GENERIC_WRITE,

FILE_SHARE_READ OR FILE_SHARE_WRITE,

@SecurityAttributes,

CONSOLE_TEXTMODE_BUFFER,

NIL

);

If dwSize<=(ConsoleScreenRect.Right-ConsoleScreenRect.Left+1) Then Begin

WidthHeight.X:=dwSize;

WidthHeight.Y:=1;

End Else Begin

WidthHeight.X:=ConsoleScreenRect.Right-ConsoleScreenRect.Left+1;

WidthHeight.Y:=dwSize DIV WidthHeight.X;

If (dwSize MOD WidthHeight.X) > 0 Then Inc(WidthHeight.Y);

End;

SetConsoleScreenBufferSize(hTempConsoleOutput,WidthHeight);

DestinationScreenRect.Left:=0;

DestinationScreenRect.Top:=0;

DestinationScreenRect.Right:=WidthHeight.X-1;

DestinationScreenRect.Bottom:=WidthHeight.Y-1;

SetConsoleWindowInfo(hTempConsoleOutput,FALSE,DestinationScreenRect);

Coord.X:=0;

For I:=1 To WidthHeight.Y Do Begin

Coord.Y:=I-0;

FillConsoleOutputAttribute(hTempConsoleOutput,TextAttr,WidthHeight.X,Coord,dwCount);

FillConsoleOutputCharacter(hTempConsoleOutput,' ' ,WidthHeight.X,Coord,dwCount);

End;

WriteConsole(hTempConsoleOutput,Str,dwSize,dwCount,NIL);

{ }

New(Buffer);

Coord.X:= 0;

Coord.Y:= 0;

SourceScreenRect.Left:=0;

SourceScreenRect.Top:=0;

SourceScreenRect.Right:=WidthHeight.X-1;

SourceScreenRect.Bottom:=WidthHeight.Y-1;

ReadConsoleOutputA(hTempConsoleOutput,Buffer,WidthHeight,Coord,SourceScreenRect);

Coord.X:=X-1;

Coord.Y:=Y-1;

DestinationScreenRect:=ConsoleScreenRect;

WriteConsoleOutputA(hConsoleOutput,Buffer,WidthHeight,Coord,DestinationScreenRect);

GotoXY((dwSize MOD WidthHeight.X)-1,WidthHeight.Y+1);

Dispose(Buffer);

{ }

CloseHandle(hTempConsoleOutput);

{$EndIf}

End;

procedure WriteStrXY(X, Y: Byte; Str: PChar; dwSize: Integer);

{$IfDef OneByOne}

var

dwCount: integer;

{$Else}

var

I: integer;

LineSize, dwCharCount, dwCount, dwWait: DWORD;

WidthHeight: TCoord;

OneLine: packed array [0..131] of char;

Line, TempStr: PChar;

procedure NewLine;

begin

LastX := 1;

Inc(LastY);

if (LastY + ConsoleScreenRect.Top) > (ConsoleScreenRect.Bottom + 1) then

begin

Dec(LastY);

GotoXY(1,1);

DelLine;

end;

GotoXY(LastX, LastY);

end;

{$EndIf}

begin

if dwSize > 0 then

begin

{$IfDef OneByOne}

LastX := X;

LastY := Y;

dwCount := 0;

while dwCount < dwSize do

begin

WriteChrXY(LastX, LastY, Str[dwCount]);

Inc(dwCount);

end;

{$Else}

LastX := X;

LastY := Y;

GotoXY(LastX, LastY);

dwWait := dwSize;

TempStr := Str;

while (dwWait > 0) and (Pos(#13#10, StrPas(TempStr)) = 1) do

begin

Dec(dwWait, 2);

Inc(TempStr, 2);

NewLine;

end;

while (dwWait > 0) and (Pos(#10, StrPas(TempStr)) = 1) do

begin

Dec(dwWait);

Inc(TempStr);

NewLine;

end;

if dwWait > 0 then

begin

if dwSize <= (ConsoleScreenRect.Right - ConsoleScreenRect.Left - LastX + 1) then

begin

WidthHeight.X := dwSize + LastX - 1;

WidthHeight.Y := 1;

end

else

begin

WidthHeight.X := ConsoleScreenRect.Right - ConsoleScreenRect.Left + 1;

WidthHeight.Y := dwSize div WidthHeight.X;

if (dwSize mod WidthHeight.X) > 0 then Inc(WidthHeight.Y);

end;

for I := 1 to WidthHeight.Y do

begin

FillChar(OneLine, SizeOf(OneLine), #0);

Line := @OneLine;

LineSize := WidthHeight.X - LastX + 1;

if LineSize > dwWait then LineSize := dwWait;

Dec(dwWait, LineSize);

StrLCopy(Line, TempStr, LineSize);

Inc(TempStr, LineSize);

dwCharCount := Pos(#13#10, StrPas(Line));

if dwCharCount > 0 then

begin

OneLine[dwCharCount - 1] := #0;

OneLine[dwCharCount] := #0;

WriteConsole(hConsoleOutput, Line, dwCharCount - 1,dwCount, nil);

Inc(Line, dwCharCount + 1);

NewLine;

LineSize := LineSize - (dwCharCount + 1);

end

else

begin

dwCharCount := Pos(#10, StrPas(Line));

if dwCharCount > 0 then

begin

OneLine[dwCharCount - 1] := #0;

WriteConsole(hConsoleOutput, Line, dwCharCount - 1,dwCount, nil);

Inc(Line, dwCharCount);

NewLine;

LineSize := LineSize - dwCharCount;

end;

if LineSize <> 0 then

begin

WriteConsole(hConsoleOutput, Line, LineSize, dwCount, nil);

end;

if dwWait > 0 then

begin

NewLine;

end;

{$EndIf}

end;

{ }

{ Empty the buffer }

{ }

procedure FlushInputBuffer;

begin

FlushConsoleInputBuffer(hConsoleInput);

end;

{ }

{ Get size of current cursor }

{ }

function GetCursor: Word;

var

CCI: TConsoleCursorInfo;

begin

GetConsoleCursorInfo(hConsoleOutput, CCI);

GetCursor := CCI.dwSize;

end;

{ }

{ Set size of current cursor }

{ }

procedure SetCursor(NewCursor: Word);

var

CCI: TConsoleCursorInfo;

begin

if NewCursor = $0000 then

begin

CCI.dwSize := GetCursor;

CCI.bVisible := False;

end

else

begin

CCI.dwSize := NewCursor;

CCI.bVisible := True;

end;

SetConsoleCursorInfo(hConsoleOutput, CCI);

end;

{ }

{ --- Begin of Interface functions & procedures of original CRT unit --- }

procedure AssignCrt(var F: Text);

begin

Assign(F, '');

TTextRec(F).OpenFunc := @OpenText;

end;

function KeyPressed: Boolean;

var

NumberOfEvents: DWORD;

NumRead: DWORD;

InputRec: TInputRecord;

Pressed: boolean;

begin

Pressed := False;

GetNumberOfConsoleInputEvents(hConsoleInput, NumberOfEvents);

if NumberOfEvents > 0 then

begin

if PeekConsoleInput(hConsoleInput, InputRec, 1,NumRead) then

begin

if (InputRec.EventType = KEY_EVENT) and

(InputRec{$IfDef NEW_STYLES}.Event{$EndIf}.KeyEvent.bKeyDown) then

begin

Pressed := True;

{$IfDef MOUSE_IS_USED}

MouseButtonPressed := False;

{$EndIf}

end

else

begin

{$IfDef MOUSE_IS_USED}

if (InputRec.EventType = _MOUSE_EVENT) then

begin

with InputRec{$IfDef NEW_STYLES}.Event{$EndIf}.MouseEvent do

begin

MousePosX := dwMousePosition.X;

MousePosY := dwMousePosition.Y;

if dwButtonState = FROM_LEFT_1ST_BUTTON_PRESSED then

begin

MouseEventTime := Now;

MouseButtonPressed := True;

{If (dwEventFlags AND DOUBLE_CLICK)<>0 Then Begin}

{End;}

end;

ReadConsoleInput(hConsoleInput, InputRec, 1,NumRead);

{$Else}

ReadConsoleInput(hConsoleInput, InputRec, 1,NumRead);

{$EndIf}

end;

Result := Pressed;

end;

function ReadKey: char;

var

NumRead: DWORD;

InputRec: TInputRecord;

begin

repeat

until KeyPressed;

ReadConsoleInput(hConsoleInput, InputRec, 1,NumRead);

until InputRec{$IfDef NEW_STYLES}.Event{$EndIf}.KeyEvent.AsciiChar > #0;

Result := InputRec{$IfDef NEW_STYLES}.Event{$EndIf}.KeyEvent.AsciiChar;

end;

procedure TextMode(Mode: Integer);

begin

end;

procedure Window(X1, Y1, X2, Y2: Byte);

begin

ConsoleScreenRect.Left := X1 - 1;

ConsoleScreenRect.Top := Y1 - 1;

ConsoleScreenRect.Right := X2 - 1;

ConsoleScreenRect.Bottom := Y2 - 1;

WindMin := (ConsoleScreenRect.Top shl 8) or ConsoleScreenRect.Left;

WindMax := (ConsoleScreenRect.Bottom shl 8) or ConsoleScreenRect.Right;

{$IfDef WindowFrameToo}

SetConsoleWindowInfo(hConsoleOutput, True, ConsoleScreenRect);

{$EndIf}

GotoXY(1,1);

end;

procedure GotoXY(X, Y: Byte);

var

Coord: TCoord;

begin

Coord.X := X - 1 + ConsoleScreenRect.Left;

Coord.Y := Y - 1 + ConsoleScreenRect.Top;

if not SetConsoleCursorPosition(hConsoleOutput, Coord) then

begin

GotoXY(1, 1);

DelLine;

end;

function WhereX: Byte;

var

CBI: TConsoleScreenBufferInfo;

begin

GetConsoleScreenBufferInfo(hConsoleOutput, CBI);

Result := TCoord(CBI.dwCursorPosition).X + 1 - ConsoleScreenRect.Left;

end;

function WhereY: Byte;

var

CBI: TConsoleScreenBufferInfo;

begin

GetConsoleScreenBufferInfo(hConsoleOutput, CBI);

Result := TCoord(CBI.dwCursorPosition).Y + 1 - ConsoleScreenRect.Top;

end;

procedure ClrScr;

begin

FillerScreen(' ');

end;

procedure ClrEol;

var

Coord: TCoord;

dwSize, dwCount: DWORD;

begin

Coord.X := WhereX - 1 + ConsoleScreenRect.Left;

Coord.Y := WhereY - 1 + ConsoleScreenRect.Top;

dwSize := ConsoleScreenRect.Right - Coord.X + 1;

FillConsoleOutputAttribute(hConsoleOutput, TextAttr, dwSize, Coord, dwCount);

FillConsoleOutputCharacter(hConsoleOutput, ' ', dwSize, Coord, dwCount);

end;

procedure InsLine;

var

SourceScreenRect: TSmallRect;

Coord: TCoord;

CI: TCharInfo;

dwSize, dwCount: DWORD;

begin

SourceScreenRect := ConsoleScreenRect;

SourceScreenRect.Top := WhereY - 1 + ConsoleScreenRect.Top;

SourceScreenRect.Bottom := ConsoleScreenRect.Bottom - 1;

CI.AsciiChar := ' ';

CI.Attributes := TextAttr;

Coord.X := SourceScreenRect.Left;

Coord.Y := SourceScreenRect.Top + 1;

dwSize := SourceScreenRect.Right - SourceScreenRect.Left + 1;

ScrollConsoleScreenBuffer(hConsoleOutput, SourceScreenRect, nil, Coord, CI);

Dec(Coord.Y);

FillConsoleOutputAttribute(hConsoleOutput, TextAttr, dwSize, Coord, dwCount);

end;

procedure DelLine;

var

SourceScreenRect: TSmallRect;

Coord: TCoord;

CI: TCharinfo;

dwSize, dwCount: DWORD;

begin

SourceScreenRect := ConsoleScreenRect;

SourceScreenRect.Top := WhereY + ConsoleScreenRect.Top;

CI.AsciiChar := ' ';

CI.Attributes := TextAttr;

Coord.X := SourceScreenRect.Left;

Coord.Y := SourceScreenRect.Top - 1;

dwSize := SourceScreenRect.Right - SourceScreenRect.Left + 1;

ScrollConsoleScreenBuffer(hConsoleOutput, SourceScreenRect, nil, Coord, CI);

FillConsoleOutputAttribute(hConsoleOutput, TextAttr, dwSize, Coord, dwCount);

end;

procedure TextColor(Color: Byte);

begin

LastMode := TextAttr;

TextAttr := (Color and $0F) or (TextAttr and $F0);

SetConsoleTextAttribute(hConsoleOutput, TextAttr);

end;

procedure TextBackground(Color: Byte);

begin

LastMode := TextAttr;

TextAttr := (Color shl 4) or (TextAttr and $0F);

SetConsoleTextAttribute(hConsoleOutput, TextAttr);

end;

procedure LowVideo;

begin

LastMode := TextAttr;

TextAttr := TextAttr and $F7;

SetConsoleTextAttribute(hConsoleOutput, TextAttr);

end;

procedure HighVideo;

begin

LastMode := TextAttr;

TextAttr := TextAttr or $08;

SetConsoleTextAttribute(hConsoleOutput, TextAttr);

end;

procedure NormVideo;

begin

LastMode := TextAttr;

TextAttr := StartAttr;

SetConsoleTextAttribute(hConsoleOutput, TextAttr);

end;

procedure Delay(MS: Word);

{

Const

Magic= $80000000;

var

StartMS,CurMS,DeltaMS: DWORD;

}

begin

Windows.SleepEx(MS, False); // Windows.Sleep(MS);

{

StartMS:= GetTickCount;

Repeat

CurMS:= GetTickCount;

If CurMS >= StartMS Then

DeltaMS:= CurMS - StartMS

Else DeltaMS := (CurMS + Magic) - (StartMS - Magic);

Until MS<DeltaMS;

}

end;

procedure Sound(Hz: Word);

begin

{SetSoundIOPermissionMap(LocalIOPermission_ON);}

SoundFrequency := Hz;

if IsWinNT then

begin

Windows.Beep(SoundFrequency, SoundDuration)

end

else

begin

asm

mov BX,Hz

cmp BX,0

jz @2

mov AX,$34DD

mov DX,$0012

cmp DX,BX

jnb @2

div BX

mov BX,AX

{ Sound is On ? }

in Al,$61

test Al,$03

jnz @1

{ Set Sound On }

or Al,03

out $61,Al

{ Timer Command }

mov Al,$B6

out $43,Al

{ Set Frequency }

@1: mov Al,Bl

out $42,Al

mov Al,Bh

out $42,Al

@2:

end;

procedure NoSound;

begin

if IsWinNT then

begin

Windows.Beep(SoundFrequency, 0);

end

else

begin

asm

{ Set Sound On }

in Al,$61

and Al,$FC

out $61,Al

end;

{SetSoundIOPermissionMap(LocalIOPermission_OFF);}

end;

{ --- End of Interface functions & procedures of original CRT unit --- }

{ }

procedure OverwriteChrXY(X, Y: Byte; Chr: char);

var

Coord: TCoord;

dwSize, dwCount: DWORD;

begin

LastX := X;

LastY := Y;

Coord.X := LastX - 1 + ConsoleScreenRect.Left;

Coord.Y := LastY - 1 + ConsoleScreenRect.Top;

dwSize := 1;

FillConsoleOutputAttribute(hConsoleOutput, TextAttr, dwSize, Coord, dwCount);

FillConsoleOutputCharacter(hConsoleOutput, Chr, dwSize, Coord, dwCount);

GotoXY(LastX, LastY);

end;

{ -------------------------------------------------- }

{ Console Event Handler }

{ }

{$IfDef CRT_EVENT}

function ConsoleEventProc(CtrlType: DWORD): Bool; stdcall; far;

var

S: {$IfDef Win32}ShortString{$Else}String{$EndIf};

Message: PChar;

begin

case CtrlType of

CTRL_C_EVENT: S := 'CTRL_C_EVENT';

CTRL_BREAK_EVENT: S := 'CTRL_BREAK_EVENT';

CTRL_CLOSE_EVENT: S := 'CTRL_CLOSE_EVENT';

CTRL_LOGOFF_EVENT: S := 'CTRL_LOGOFF_EVENT';

CTRL_SHUTDOWN_EVENT: S := 'CTRL_SHUTDOWN_EVENT';

else

S := 'UNKNOWN_EVENT';

end;

S := S + ' detected, but not handled.';

Message := @S;

Inc(Message);

MessageBox(0, Message, 'Win32 Console', MB_OK);

Result := True;

end;

{$EndIf}

function MouseReset: Boolean;

begin

MouseColWidth := 1;

MouseRowWidth := 1;

Result := True;

end;

procedure MouseShowCursor;

const

ShowMouseConsoleMode = ENABLE_MOUSE_INPUT;

var

cMode: DWORD;

begin

GetConsoleMode(hConsoleInput, cMode);

if (cMode and ShowMouseConsoleMode) <> ShowMouseConsoleMode then

begin

cMode := cMode or ShowMouseConsoleMode;

SetConsoleMode(hConsoleInput, cMode);

end;

procedure MouseHideCursor;

const

ShowMouseConsoleMode = ENABLE_MOUSE_INPUT;

var

cMode: DWORD;

begin

GetConsoleMode(hConsoleInput, cMode);

if (cMode and ShowMouseConsoleMode) = ShowMouseConsoleMode then

begin

cMode := cMode and ($FFFFFFFF xor ShowMouseConsoleMode);

SetConsoleMode(hConsoleInput, cMode);

end;

function MouseKeyPressed: Boolean;

{$IfDef MOUSE_IS_USED}

const

MouseDeltaTime = 200;

var

ActualTime: TDateTime;

HourA, HourM, MinA, MinM, SecA, SecM, MSecA, MSecM: word;

MSecTimeA, MSecTimeM: longInt;

MSecDelta: longInt;

{$EndIf}

begin

MousePressedButtons := 0;

{$IfDef MOUSE_IS_USED}

Result := False;

if MouseButtonPressed then

begin

ActualTime := NOW;

DecodeTime(ActualTime, HourA, MinA, SecA, MSecA);

DecodeTime(MouseEventTime, HourM, MinM, SecM, MSecM);

MSecTimeA := (3600 * HourA + 60 * MinA + SecA) * 100 + MSecA;

MSecTimeM := (3600 * HourM + 60 * MinM + SecM) * 100 + MSecM;

MSecDelta := Abs(MSecTimeM - MSecTimeA);

if (MSecDelta < MouseDeltaTime) or (MSecDelta > (8784000 - MouseDeltaTime)) then

begin

MousePressedButtons := MouseLeftButton;

MouseButtonPressed := False;

Result := True;

end;

{$Else}

Result := False;

{$EndIf}

end;

procedure MouseGotoXY(X, Y: Integer);

begin

{$IfDef MOUSE_IS_USED}

mouse_event(MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_MOVE,

X - 1,Y - 1,WHEEL_DELTA, GetMessageExtraInfo());

MousePosY := (Y - 1) * MouseRowWidth;

MousePosX := (X - 1) * MouseColWidth;

{$EndIf}

end;

function MouseWhereY: Integer;

{$IfDef MOUSE_IS_USED}

{Var

lppt, lpptBuf: TMouseMovePoint;}

{$EndIf}

begin

{$IfDef MOUSE_IS_USED}

{GetMouseMovePoints(

SizeOf(TMouseMovePoint), lppt, lpptBuf,

7,GMMP_USE_DRIVER_POINTS

);

Result:=lpptBuf.Y DIV MouseRowWidth;}

Result := (MousePosY div MouseRowWidth) + 1;

{$Else}

Result := -1;

{$EndIf}

end;

function MouseWhereX: Integer;

{$IfDef MOUSE_IS_USED}

{Var

lppt, lpptBuf: TMouseMovePoint;}

{$EndIf}

begin

{$IfDef MOUSE_IS_USED}

{GetMouseMovePoints(

SizeOf(TMouseMovePoint), lppt, lpptBuf,

7,GMMP_USE_DRIVER_POINTS

);

Result:=lpptBuf.X DIV MouseColWidth;}

Result := (MousePosX div MouseColWidth) + 1;

{$Else}

Result := -1;

{$EndIf}

end;

{ }

procedure Init;

const

ExtInpConsoleMode = ENABLE_WINDOW_INPUT or ENABLE_PROCESSED_INPUT or ENABLE_MOUSE_INPUT;

ExtOutConsoleMode = ENABLE_PROCESSED_OUTPUT or ENABLE_WRAP_AT_EOL_OUTPUT;

var

cMode: DWORD;

Coord: TCoord;

OSVersion: TOSVersionInfo;

CBI: TConsoleScreenBufferInfo;

begin

OSVersion.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);

GetVersionEx(OSVersion);

if OSVersion.dwPlatformId = VER_PLATFORM_WIN32_NT then

IsWinNT := True

else

IsWinNT := False;

PtrOpenText := TTextRec(Output).OpenFunc;

{$IfDef HARD_CRT}

AllocConsole;

Reset(Input);

hConsoleInput := GetStdHandle(STD_INPUT_HANDLE);

TTextRec(Input).Handle := hConsoleInput;

ReWrite(Output);

hConsoleOutput := GetStdHandle(STD_OUTPUT_HANDLE);

TTextRec(Output).Handle := hConsoleOutput;

{$Else}

Reset(Input);

hConsoleInput := TTextRec(Input).Handle;

ReWrite(Output);

hConsoleOutput := TTextRec(Output).Handle;

{$EndIf}

GetConsoleMode(hConsoleInput, cMode);

if (cMode and ExtInpConsoleMode) <> ExtInpConsoleMode then

begin

cMode := cMode or ExtInpConsoleMode;

SetConsoleMode(hConsoleInput, cMode);

end;

TTextRec(Output).InOutFunc := @TextOut;

TTextRec(Output).FlushFunc := @TextOut;

GetConsoleScreenBufferInfo(hConsoleOutput, CBI);

GetConsoleMode(hConsoleOutput, cMode);

if (cMode and ExtOutConsoleMode) <> ExtOutConsoleMode then

begin

cMode := cMode or ExtOutConsoleMode;

SetConsoleMode(hConsoleOutput, cMode);

end;

TextAttr := CBI.wAttributes;

StartAttr := CBI.wAttributes;

LastMode := CBI.wAttributes;

Coord.X := CBI.srWindow.Left;

Coord.Y := CBI.srWindow.Top;

WindMin := (Coord.Y shl 8) or Coord.X;

Coord.X := CBI.srWindow.Right;

Coord.Y := CBI.srWindow.Bottom;

WindMax := (Coord.Y shl 8) or Coord.X;

ConsoleScreenRect := CBI.srWindow;

SoundDuration := -1;

OldCp := GetConsoleOutputCP;

SetConsoleOutputCP(1250);

{$IfDef CRT_EVENT}

SetConsoleCtrlHandler(@ConsoleEventProc, True);

{$EndIf}

{$IfDef MOUSE_IS_USED}

SetCapture(hConsoleInput);

KeyPressed;

{$EndIf}

MouseInstalled := MouseReset;

Window(1,1,80,25);

ClrScr;

end;

{ }

procedure Done;

begin

{$IfDef CRT_EVENT}

SetConsoleCtrlHandler(@ConsoleEventProc, False);

{$EndIf}

SetConsoleOutputCP(OldCP);

TextAttr := StartAttr;

SetConsoleTextAttribute(hConsoleOutput, TextAttr);

ClrScr;

FlushInputBuffer;

{$IfDef HARD_CRT}

TTextRec(Input).Mode := fmClosed;

TTextRec(Output).Mode := fmClosed;

FreeConsole;

{$Else}

Close(Input);

Close(Output);

{$EndIf}

end;

initialization

Init;

finalization

Done;

{$Endif win32}

end.