Статьи по Delphi (014)…
Узнать, поддерживает ли принтер PostScript.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{
That is really difficult do to if it has to work on all Windows
platforms. The best way (no kidding) may be to ask the user which
printer to use. What platforms do you need to support? If it is only
Win2K (and perhaps XP) one may be able to use this (i have no
postscript-enabled printer around to see if it works!):
}
uses
WinSpool, Printers;
{: Check if the currently selected printer supports postscript.
Only applicable on Win2K/XP! }
function PrinterSupportsPostscript: Boolean;
const
POSTSCRIPT_PASSTHROUGH = 4115;
POSTSCRIPT_IDENTIFY = 4117;
Escapes: array[0..2] of Cardinal =
(POSTSCRIPT_DATA, POSTSCRIPT_IDENTIFY, POSTSCRIPT_PASSTHROUGH);
var
res: Integer;
i: Integer;
begin
Result := false;
for i := Low(Escapes) to High(Escapes) do begin
res := ExtEscape(printer.Handle,
QUERYESCSUPPORT,
sizeof(Escapes[0]),
@Escapes[i], 0, nil);
if res <> 0 then begin
Result := true;
Break;
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
const
boolstr: array[Boolean] of string = (' not', '');
var
i: Integer;
S: string;
begin
for i := 0 to Printer.Printers.Count - 1 do begin
Printer.PrinterIndex := i;
memo1.Lines.add(
Format('Printer %s does%s support Postscript',
[printer.printers[printer.printerindex],
boolstr[PrinterSupportsPostscript]]));
end;
end;
Сохранить установки принтера в файл.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{
Create a unit PrinterSetup and place code in this unit
Do the following to save the printer config to file
}
procedure TForm1.Button1Click(Sender: TObject);
var
PrinterSetup: TPrinterSetup
begin
PrinterSetup := TPrinterSetup.Create;
PrinterSetup.SaveSetup(FileName);
//where file name is a string to the location of the File ex.'c:\print.cfg'
PrinterSetup.Free;
end
{***********************************}
unit PrinterSetup;
interface
uses
printers,
windows,
SysUtils,
Classes,
WinSpool;
type
TPrinterSetup = class
private
Device, Driver, Port: array[0..CCHDEVICENAME] of char;
DeviceMode: THandle;
procedure Refresh;
protected
public
procedure SaveSetup(FileName: TFilename);
procedure LoadSetup(FileName: TFilename);
end;
TPrinterConfig = record
ADevice, ADriver, APort: array[0..CCHDEVICENAME] of char;
SizeOfDeviceMode: DWORD;
end;
implementation
procedure TPrinterSetup.Refresh;
begin
Printer.GetPrinter(Device, Driver, Port, DeviceMode);
end;
procedure TPrinterSetup.SaveSetup(FileName: TFilename);
var
StubDevMode: TDeviceMode;
SetupPrinter: TPrinterConfig;
FPrinterHandle: THandle;
fFileConfig: file of TPrinterConfig;
fFileDevMode: file of Char;
pDevMode: PChar;
Contador: Integer;
begin
Refresh;
with SetupPrinter do
begin
StrLCopy(ADevice, Device, SizeOf(ADevice));
StrLCopy(ADriver, Driver, SizeOf(ADriver));
StrLCopy(APort, Port, SizeOf(APort));
OpenPrinter(Device, FPrinterHandle, nil);
SizeOfDeviceMode := DocumentProperties(0, FPrinterHandle, Device,
StubDevMode, StubDevMode, 0);
end;
AssignFile(fFileConfig, FileName);
ReWrite(fFileConfig);
Write(fFileConfig, SetupPrinter);
CloseFile(fFileConfig);
AssignFile(fFileDevMode, FileName);
Reset(fFileDevMode);
Seek(fFileDevMode, FileSize(fFileDevMode));
pDevMode := GlobalLock(DeviceMode);
for Contador := 0 to SetupPrinter.SizeOfDeviceMode - 1 do
begin
Write(fFileDevMode, pDevMode[Contador]);
end;
CloseFile(fFileDevMode);
GlobalUnLock(DeviceMode);
end;
procedure TPrinterSetup.LoadSetup(FileName: TFilename);
var
SetupPrinter: TPrinterConfig;
fFileConfig: file of TPrinterConfig;
fFileDevMode: file of Char;
ADeviceMode: THandle;
pDevMode: PChar;
Contador: Integer;
begin
if FileExists(FileName) then
begin
AssignFile(fFileConfig, FileName);
Reset(fFileConfig);
read(fFileConfig, SetupPrinter);
CloseFile(fFileConfig);
AssignFile(fFileDevMode, FileName);
Reset(fFileDevMode);
Seek(fFileDevMode, SizeOf(SetupPrinter));
ADeviceMode := GlobalAlloc(GHND, SetupPrinter.SizeOfDeviceMode);
pDevMode := GlobalLock(ADeviceMode);
for Contador := 0 to SetupPrinter.SizeOfDeviceMode - 1 do
begin
read(fFileDevMode, char(pDevMode[Contador]));
end;
CloseFile(fFileDevMode);
GlobalUnLock(ADeviceMode);
Printer.SetPrinter(SetupPrinter.ADevice, SetupPrinter.ADriver,
SetupPrinter.APort, ADeviceMode);
end;
end;
end.
Как печатать растровые и векторные изображения и делать режим предварительного просмотра.
Маленькое предисловие
Т.к. основная моя работа связана с написанием софта для института, обрабатывающего геоданные, то и в отделе, где работаю, так же мучаются проблемами печати (в одном случае - надо печатать карты, с изолиниями, заливкой, подписями и пр.; в другом случае - свои таблицы и сложные отрисовки по внешнему виду). В итоге, моим коллегой был написан кусок, в котором ему удалось добиться качественной печати в двух режимах : MetaFile, Bitmap. Работа с MetaFile у нас сложилась уже исторически - достаточно удобно описать ф-цию, которая что-то отрисовыват (хоть на экране, хоть где), которая принимает TCanvas, и подсовывать ей то канвас дисплея, то канвас метафайла, а потом этот Metafile выбрасывать на печать. Достаточно решить лишь проблемы масштабирования, после чего - вперед. Главная головная боль при таком методе - при отрисовке больших кусков, которые занимают весь лист или его большую часть, надо этот метафайл по размерам делать сразу же в пикселах на этот самый лист. Тогда при изменении размеров (просмотр перед печатью) - искажения при уменьшении не критичны, а вот при увеличении линии и шрифты не "поползут".
Итак:
Набор идей, которые были написаны (с) Андреем Аристовым, программистом отдела матобеспечения СибНИИНП, г. Тюмень. Моего здесь только - приделывание сверху надстроек для личного использования.
Вся работа сводится к следующим шагам :
Получить необходимые коэф-ты. Построить метафайл или bmp для последующего вывода на печать. Напечатать.Ниже приведенный кусок (прошу меня не пинать, но писал я и писал для достаточно кривой реализации с передачей параметров через глобальные переменные) я использую для того, чтобы получить коэф-ты пересчета. kScale - для пересчета размеров шрифта, а потом уже закладываюсь на его размеры и получаю два новых коэф-та для kW, kH - которые и позволяют мне с учетом высоты шрифта выводить графику и пр. У меня при работе kW <> kH, что приходится учитывать.
Решили пункт 1.
// установить коэф-ты
procedure SetKoeffMeta;
var
PrevMetafile : TMetafile;
MetaCanvas : TMetafileCanvas;
begin
PrevMetafile := nil;
MetaCanvas := nil;
try
PrevMetaFile := TMetaFile.Create;
try
MetaCanvas := TMetafileCanvas.Create( PrevMetafile, 0 );
kScale := GetDeviceCaps( Printer.Handle, LOGPIXELSX ) /
Screen.PixelsPerInch;
MetaCanvas.Font.Assign( oGrid.Font);
MetaCanvas.Font.Size := Round( oGrid.Font.Size * kScale );
kW := MetaCanvas.TextWidth('W') / oGrid.Canvas.TextWidth('W');
kH := MetaCanvas.TextHeight('W') / oGrid.Canvas.TextHeight('W');
finally
MetaCanvas.Free;
end;
finally
PrevMetafile.Free;
end;
end;
|
Решаем 2.
...
var
PrevMetafile : TMetafile;
MetaCanvas : TMetafileCanvas;
begin
PrevMetafile := nil;
MetaCanvas := nil;
try
PrevMetaFile := TMetaFile.Create;
PrevMetafile.Width := oWidth;
PrevMetafile.Height := oHeight;
try
MetaCanvas := TMetafileCanvas.Create( PrevMetafile, 0 );
// здесь должен быть ваш код - с учетом масштабирования.
// я эту вещь вынес в ассигнуемую процедуру, и данный блок
// вызываю лишь для отрисовки целой страницы.
|
См. PS1.
finally MetaCanvas.Free; end; ... |
PS1. Код, который используется для отрисовки. oCanvas - TCanvas метафайла.
...
var
iHPage: integer; // высота страницы
begin
with oCanvas do
begin
iHPage := 3000;
// залили область метайфайла белым - для дальнейшей работы
Pen.Color := clBlack;
Brush.Color := clWhite;
FillRect( Rect( 0, 0, 2000, iHPage ) );
// установили шрифты - с учетом их дальнейшего масштабирования
oCanvas.Font.Assign( oGrid.Font);
oCanvas.Font.Size := Round( oGrid.Font.Size * kScale );
...
xEnd := xBegin;
iH := round( RowHeights[ iRow ] * kH );
for iCol := 0 to ColCount - 1 do
begin
x := xEnd;
xEnd := x + round( ColWidths[ iCol ] * kW );
Rectangle( x, yBegin, xEnd, yBegin + iH );
r := Rect( x + 1, yBegin + 1, xEnd - 1, yBegin + iH - 1 );
s := Cells[ iCol, iRow ];
// выписали в полученный квадрат текст
DrawText( oCanvas.Handle, PChar( s ), Length( s ), r,
DT_WORDBREAK or DT_CENTER );
|
Главное, что важно помнить на этом этапе - это не забывать, что все выводимые объекты должны пользоваться описанными коэф-тами (как вы их получите - это уже ваше дело). В данном случае - я работаю с переделанным TStringGrid, который сделал для многостраничной печати.
Последний пункт - надо сформированный метафайл или bmp напечатать.
...
var
Info: PBitmapInfo;
InfoSize: Integer;
Image: Pointer;
ImageSize: DWORD;
Bits: HBITMAP;
DIBWidth, DIBHeight: Longint;
PrintWidth, PrintHeight: Longint;
begin
...
case ImageType of
itMetafile:
begin
if Picture.Metafile<>nil then
Printer.Canvas.StretchDraw( Rect(aLeft, aTop, aLeft+fWidth,
aTop+fHeight), Picture.Metafile);
end;
itBitmap:
begin
if Picture.Bitmap<>nil then
begin
with Printer, Canvas do
begin
Bits := Picture.Bitmap.Handle;
GetDIBSizes(Bits, InfoSize, ImageSize);
Info := AllocMem(InfoSize);
try
Image := AllocMem(ImageSize);
try
GetDIB(Bits, 0, Info^, Image^);
with Info^.bmiHeader do
begin
DIBWidth := biWidth;
DIBHeight := biHeight;
end;
PrintWidth := DIBWidth;
PrintHeight := DIBHeight;
StretchDIBits(Canvas.Handle, aLeft, aTop, PrintWidth,
PrintHeight, 0, 0, DIBWidth, DIBHeight, Image, Info^,
DIB_RGB_COLORS, SRCCOPY);
finally
FreeMem(Image, ImageSize);
end;
finally
FreeMem(Info, InfoSize);
end;
end;
end;
end;
end;
end;
|
В чем заключается идея PreView ? Остается имея на руках Metafila, Bmp - отрисовать с пересчетом внешний вид изображения (надо высчитать левый верхний угол и размеры "предварительно просматриваемого" изображения. Для показа изображения достаточно использовать StretchDraw. После того, как удалось вывести объекты на печать, проблему создания PreView решили как "домашнее задание". Кстати, когда мы работаем с Bmp, то для просмотра используем следующий хинт - записываем битовый образ через такую процедуру :
w:=MulDiv(Bmp.Width,GetDeviceCaps(Printer.Handle,LOGPIXELSX), Screen.PixelsPerInch); h:=MulDiv(Bmp.Height,GetDeviceCaps(Printer.Handle,LOGPIXELSY), Screen.PixelsPerInch); PrevBmp.Width:=w; PrevBmp.Height:=h; PrevBmp.Canvas.StretchDraw(Rect(0,0,w,h),Bmp); aPicture.Assign(PrevBmp); |
При этом масштабируется битовый образ с минимальными искажениями, а вот при печати - приходится bmp печатать именно так, как описано выше. Итог - наша bmp при печати чуть меньше, чем печатать ее через WinWord, но при этом - внешне - без каких-либо искажений и пр.
Как узнать края печати в Win16 и Win32.
В Win16, для этого используется API функция Escape() с константой GETPRINTINGOFFSET. В Win32, используется API функция GetDeviceCaps() с константами PHYSICALOFFSETX и PHYSICALOFFSETY. Однако, нет гарантии, что данная последовательность кодов поддерживается принтером, поэтому для проверки желательно всегда вызывать функцию Escape с константой QUERYESCSUPPORT. Следующий пример возвращает отступы печати как в WIN16, так и в WIN32, учитывая тот факт, что не все принтеры поддерживают код GETPRINTINGOFFSET (в WIN16). Если дело обстоит так, то смещение печати вычисляется приближённо, получая размер страницы, вычитая физическую разрешающую способность устройства, и деля пополам.Пример:
uses Printers;
procedure TForm1.Button1Click(Sender: TObject);
var
EscapeCode: integer;
Margin: TPoint;
begin
if PrintDialog1.Execute then begin
{$IFDEF WIN32}
Margin.x := GetDeviceCaps(Printer.Handle, PHYSICALOFFSETX);
Margin.y := GetDeviceCaps(Printer.Handle, PHYSICALOFFSETY);
{$ELSE}
EscapeCode := GETPRINTINGOFFSET;
if Escape(Printer.Handle,
QUERYESCSUPPORT,
sizeof(EscapeCode),
@EscapeCode,
nil) <> 0 then
if Escape(Printer.Handle,
GETPRINTINGOFFSET,
0,
nil,
@Margin) < 1 then begin
EscapeCode := GETPHYSPAGESIZE;
if Escape(Printer.Handle,
QUERYESCSUPPORT,
sizeof(EscapeCode),
@EscapeCode,
nil) <> 0 then
if Escape(Printer.Handle,
GETPHYSPAGESIZE,
0,
nil,
@Margin) > 0 then begin
Margin.x := (Margin.x -
GetDeviceCaps(Printer.Handle, HorzRes)) div 2;
Margin.y := (Margin.y -
GetDeviceCaps(Printer.Handle, VertRes)) div 2;
end else begin
Margin.x := 0;
Margin.y := 0;
end;
end;
{$ENDIF}
Memo1.Lines.Add(IntToStr(Margin.x));
Memo1.Lines.Add(IntToStr(Margin.y));
end;
end;
|
Построчная печать.
В Delphi 1 (а затем и в Delphi 2) я попытался написать программу, печатающую построчно на принтере (любого типа), после выхода из которой принтер НЕ выплевывает лист, а продолжает на нем печатать в случае повторного использования программы, то есть программа позволяет печатать строчку за строчкой, не удаляя при этом лист в случае завершения задачи. Это противоречит неписанным законам Microsoft, поскольку нарушает режим многозадачности, и все же именно для моей задачи мне необходимо именно такое решение. Я создал клон объекта TPrinter, назначение которого вы поймете ниже. Это работает со всеми матричными принтерами.Вот пример объекта:
var
Myprinter: TRawPrinter;
oldprinter: TPrinter;
begin
MyPrinter := TRawPrinter.Create;
oldprinter := setprinter(MyPrinter);
try
if Printdialog1.execute then
begin
myprinter.startraw;
myprinter.write('Delphi World is the best!');
myprinter.writeln;
myprinter.endraw;
end
finally
setprinter(oldprinyter);
myprinter.free;
end
end;
|
Вот пример использования объекта:
unit Rawprinter;
interface
uses printers, windows;
type
TRawprinter = class(TPrinter)
public
dc2: HDC;
procedure startraw;
procedure endraw;
procedure write(const s: string);
procedure writeln;
end;
implementation
uses sysutils, forms;
function AbortProc(Prn: HDC; Error: Integer): Bool; stdcall;
begin
Application.ProcessMessages;
Result := not Printer.Aborted;
end;
type
TPrinterDevice = class
Driver, Device, Port: string;
constructor Create(ADriver, ADevice, APort: PChar);
function IsEqual(ADriver, ADevice, APort: PChar): Boolean;
end;
constructor TPrinterDevice.Create(ADriver, ADevice, APort: PChar);
begin
inherited Create;
Driver := ADriver;
Device := ADevice;
Port := APort;
end;
function TPrinterDevice.IsEqual(ADriver, ADevice, APort: PChar): Boolean;
begin
Result := (Device = ADevice) and (Port = APort);
end;
procedure TRawprinter.startraw;
var
CTitle: array[0..31] of Char;
CMode: array[0..4] of char;
DocInfo: TDocInfo;
r: integer;
begin
StrPLCopy(CTitle, Title, SizeOf(CTitle) - 1);
StrPCopy(CMode, 'RAW');
FillChar(DocInfo, SizeOf(DocInfo), 0);
with DocInfo do
begin
cbSize := SizeOf(DocInfo);
lpszDocName := CTitle;
lpszOutput := nil;
lpszDatatype := CMode;
end;
with TPrinterDevice(Printers.Objects[PrinterIndex]) do
begin
DC2 := CreateDC(PChar(Driver), PChar(Device), PChar(Port), nil);
end;
SetAbortProc(dc2, AbortProc);
r := StartDoc(dc2, DocInfo);
end;
procedure TRawprinter.endraw;
var
r: integer;
begin
r := windows.enddoc(dc2);
end;
type
passrec = packed record
l: word;
s: array[0..255] of char;
end;
var
pass: Passrec;
procedure TRawprinter.write(const s: string);
begin
pass.l := length(s);
strpcopy(pass.s, s);
escape(dc2, PASSTHROUGH, 0, @pass, nil);
end;
procedure TRawprinter.writeln;
begin
pass.l := 2;
strpcopy(pass.s, #13#10);
escape(dc2, PASSTHROUGH, 0, @pass, nil);
end;
end.
|
Распечатать Canvas.
uses
Printers;
procedure PrintText(Text: string);
begin
with Printer do
begin
BeginDoc;
Canvas.TextOut(5, 50, Text);
EndDoc;
end;
end;
|
Печать ячеек.
Автор: Lloyd Linklater (Sysop) (Delphi Technical Support) У кого-нибудь есть пример кода печати в заданной ячейке? Типа PrintAt(row,col,"Text")?Вот некоторый код, который я нашел после блужданий в группах новостей. Правда сам я его не проверял, но источник утверждает, что он работает. Так что будьте внимательны!
TForm1.PrintTableClick(Sender: TObject);
var
xcord: integer;
ycord: integer;
recordbuffer: string;
begin
xcord := 10;
ycord := 10;
Table1.First;
Printer.BeginDoc;
Printer.Canvas.Font.Name := 'Courier New';
while not Table1.EOF do
begin
recordbuffer := concat((Table1.Fields[0].AsString), ' ',
(Table1.Fields[1].AsString));
recordbuffer := recordbuffer + concat(' ', (Table1.Fields[2].AsString);
{пока все поля не будут в recordbuffer}
Printer.Canvas.TextOut(xcord, ycord, recordbuffer);
ycord := ycord + 50;
Table1.next;
end;
Printer.Enddoc;
end;
|
Пример вывода текста на печать, используя COM порт.
Автор: Peter.
Var
Printer: THandle;
N : Cardinal;
C : POverlapped;
begin
//Открываем порт принтера для записи
Printer := CreateFile(PChar('LPT1'),
GENERIC_READ or GENERIC_WRITE,0,nil,
OPEN_EXISTING,FILE_FLAG_OVERLAPPED,0);
//Печатаем слово 'Hello World';
WriteFile(Printer,'Hello World',11,N,c);
//Закрываем порт
CloseHandle(Printer);
|
Печать содержимого DBGrid через QuickReport.
Частенько у пользователя возникает необходимость распечатать отчёт из базы данных. Естественно, что он начинает просить Вас добавить такую возможность в приложение. Как оказалось, при помощи TQuickRep данную задачу можно очень легко решить.
Итак, приступим. Для начала создайте новую форму, назвав её TGridReport, и поместите на неё TQuickRep. Переименуйте QuickRep в GridRep. Затем сделайте следующию процедуру, которая получает в качестве параметра DBGrid:
procedure TGridReport.Preview(Grid: TDBGrid);
var
i, CurrentLeft, CurrentTop : integer;
BMark: TBookmark;
begin
GridRep.Dataset:=Grid.DataSource.DataSet;
if not GridRep.Bands.HasColumnHeader then
GridRep.Bands.HasColumnHeader:=true;
if not GridRep.Bands.HasDetail then
GridRep.Bands.HasDetail:=true;
GridRep.Bands.ColumnHeaderBand.Height:=Abs(Grid.TitleFont.Height) + 10;
GridRep.Bands.DetailBand.Height:=Abs(Grid.Font.Height) + 10;
CurrentLeft := 12;
CurrentTop := 6;
{Запись, на которой пользователь останавливается в DBGrid}
BMark:=Grid.DataSource.DataSet.GetBookmark;
{Запретим мерцание грида в процессе работы отчёта}
Grid.DataSource.DataSet.DisableControls;
try
for i:=0 to Grid.FieldCount - 1 do
begin
if (CurrentLeft + Canvas.TextWidth(Grid.Columns[i].Title.Caption)) >
(GridRep.Bands.ColumnHeaderBand.Width) then
begin
CurrentLeft := 12;
CurrentTop := CurrentTop + Canvas.TextHeight('A') + 6;
GridRep.Bands.ColumnHeaderBand.Height :=
GridRep.Bands.ColumnHeaderBand.Height + (Canvas.TextHeight('A') + 10);
GridRep.Bands.DetailBand.Height :=
GridRep.Bands.DetailBand.Height + (Canvas.TextHeight('A') + 10);
end;
{Создадим заголовок отчёта при помощи QRLabels}
with TQRLabel.Create(GridRep.Bands.ColumnHeaderBand) do
begin
Parent := GridRep.Bands.ColumnHeaderBand;
Color := GridRep.Bands.ColumnHeaderBand.Color;
Left := CurrentLeft;
Top := CurrentTop;
Caption:=Grid.Columns[i].Title.Caption;
end;
{Создадим тело отчёта при помощи QRDBText}
with TQRDbText.Create(GridRep.Bands.DetailBand) do
begin
Parent := GridRep.Bands.DetailBand;
Color := GridRep.Bands.DetailBand.Color;
Left := CurrentLeft;
Top := CurrentTop;
Alignment:=Grid.Columns[i].Alignment;
AutoSize:=false;
AutoStretch:=true;
Width:=Grid.Columns[i].Width;
Dataset:=GridRep.Dataset;
DataField:=Grid.Fields[i].FieldName;
CurrentLeft:=CurrentLeft + (Grid.Columns[i].Width) + 15;
end;
end;
lblPage.Left := bdTitle.Width - lblPage.Width - 10;
lblDate.Left := bdTitle.Width - lblDate.Width - 10;
{Далее вызовем метод предварительного просмотра из QuickRep}
GridRep.PreviewModal; {либо, если желаете, то PreviewModal}
finally
with Grid.DataSource.DataSet do
begin
GotoBookmark(BMark);
FreeBookmark(BMark);
EnableControls;
end;
end;
end;
|
Печать конверта.
Автор: Xavier Pacheco
{
Copyright © 1999 by Delphi 5 Developer's Guide - Xavier Pacheco and Steve Teixeira
}
unit MainFrm;
interface
uses
SysUtils, Windows, Messages, Classes, Graphics, Controls,
Forms, Dialogs, printers, StdCtrls, ExtCtrls, Menus, ComCtrls;
type
TEnvelope = record
Kind: string; // Stores the envelope type's name
Width: double; // Holds the width of the envelope
Height: double; // Holds the height of the envelope
end;
const
// This constant array stores envelope types
EnvArray: array[1..2] of TEnvelope =
((Kind: 'Size 10'; Width: 9.5; Height: 4.125), // 9-1/2 x 4-1/8
(Kind: 'Size 6-3/4'; Width: 6.5; Height: 3.625)); // 6-1/2 x 3-3/4
type
// This enumerated type represents printing positions.
TFeedType = (epLHorz, epLVert, epRHorz, epRVert);
TPrintPrevPanel = class(TPanel)
public
property Canvas; // Publicize the Canvas property
end;
TMainForm = class(TForm)
gbEnvelopeSize: TGroupBox;
rbSize10: TRadioButton;
rbSize6: TRadioButton;
mmMain: TMainMenu;
mmiPrintIt: TMenuItem;
lblAdressee: TLabel;
edtName: TEdit;
edtStreet: TEdit;
edtCityState: TEdit;
rgFeedType: TRadioGroup;
PrintDialog: TPrintDialog;
procedure FormCreate(Sender: TObject);
procedure rgFeedTypeClick(Sender: TObject);
procedure mmiPrintItClick(Sender: TObject);
private
PrintPrev: TPrintPrevPanel; // Print preview panel
EnvSize: TPoint; // Stores the envelope's size
EnvPos: TRect; // Stores the envelope's position
ToAddrPos: TRect; // Stores the address's position
FeedType: TFeedType; // Stores the feed type from TEnvPosition
function GetEnvelopeSize: TPoint;
function GetEnvelopePos: TRect;
function GetToAddrSize: TPoint;
function GetToAddrPos: TRect;
procedure DrawIt;
procedure RotatePrintFont;
procedure SetCopies(Copies: Integer);
end;
var
MainForm: TMainForm;
implementation
{$R *.DFM}
function TMainForm.GetEnvelopeSize: TPoint;
// Gets the envelope's size represented by a TPoint
var
EnvW, EnvH: integer;
PixPerInX,
PixPerInY: integer;
begin
// Pixels per inch along the horizontal axis
PixPerInX := GetDeviceCaps(Printer.Handle, LOGPIXELSX);
// Pixels per inch along the vertical axis
PixPerInY := GetDeviceCaps(Printer.Handle, LOGPIXELSY);
// Envelope size differs depending on the user's selection
if RBSize10.Checked then
begin
EnvW := trunc(EnvArray[1].Width * PixPerInX);
EnvH := trunc(EnvArray[1].Height * PixPerInY);
end
else
begin
EnvW := trunc(EnvArray[2].Width * PixPerInX);
EnvH := trunc(EnvArray[2].Height * PixPerInY);
end;
// return Result as a TPoint record
Result := Point(EnvW, EnvH)
end;
function TMainForm.GetEnvelopePos: TRect;
{ Returns the envelope's position relative to its feed type. This
function requires that the variable EnvSize be initialized }
begin
// Determine feed type based on user's selection.
FeedType := TFeedType(rgFeedType.ItemIndex);
{ Return a TRect structure indicating the envelope's
position as it is ejected from the printer. }
case FeedType of
epLHorz:
Result := Rect(0, 0, EnvSize.X, EnvSize.Y);
epLVert:
Result := Rect(0, 0, EnvSize.Y, EnvSize.X);
epRHorz:
Result := Rect(Printer.PageWidth - EnvSize.X, 0, Printer.PageWidth,
EnvSize.Y);
epRVert:
Result := Rect(Printer.PageWidth - EnvSize.Y, 0, Printer.PageWidth,
EnvSize.X);
end; // Case
end;
function MaxLn(V1, V2: Integer): Integer;
// Returns the larger of the two. If equal, returns the first
begin
Result := V1; // Default result to V1 }
if V1 < V2 then
Result := V2
end;
function TMainForm.GetToAddrSize: TPoint;
var
TempPoint: TPoint;
begin
// Calculate the size of the longest line using the MaxLn() function
TempPoint.x := Printer.Canvas.TextWidth(edtName.Text);
TempPoint.x := MaxLn(TempPoint.x, Printer.Canvas.TextWidth(edtStreet.Text));
TempPoint.x := MaxLn(TempPoint.x, Printer.Canvas.TextWidth(edtCityState.Text))
+ 10;
// Calculate the height of all the address lines
TempPoint.y := Printer.Canvas.TextHeight(edtName.Text) +
Printer.Canvas.TextHeight(edtStreet.Text) +
Printer.Canvas.TextHeight(edtCityState.Text) + 10;
Result := TempPoint;
end;
function TMainForm.GetToAddrPos: TRect;
// This function requires that EnvSize, and EnvPos be initialized
var
TempSize: TPoint;
LT, RB: TPoint;
begin
// Determine the size of the Address bounding rectangle
TempSize := GetToAddrSize;
{ Calculate two points, one representing the Left Top (LT) position
and one representing the Right Bottom (RB) position of the
address's bounding rectangle. This depends on the FeedType }
case FeedType of
epLHorz:
begin
LT := Point((EnvSize.x div 2) - (TempSize.x div 2),
((EnvSize.y div 2) - (TempSize.y div 2)));
RB := Point(LT.x + TempSize.x, LT.y + TempSize.Y);
end;
epLVert:
begin
LT := Point((EnvSize.y div 2) - (TempSize.y div 2),
((EnvSize.x div 2) - (TempSize.x div 2)));
RB := Point(LT.x + TempSize.y, LT.y + TempSize.x);
end;
epRHorz:
begin
LT := Point((EnvSize.x div 2) - (TempSize.x div 2) + EnvPos.Left,
((EnvSize.y div 2) - (TempSize.y div 2)));
RB := Point(LT.x + TempSize.x, LT.y + TempSize.Y);
end;
epRVert:
begin
LT := Point((EnvSize.y div 2) - (TempSize.y div 2) + EnvPos.Left,
((EnvSize.x div 2) - (TempSize.x div 2)));
RB := Point(LT.x + TempSize.y, LT.y + TempSize.x);
end;
end; // End Case
Result := Rect(LT.x, LT.y, RB.x, RB.y);
end;
procedure TMainForm.DrawIt;
// This procedure assumes that EnvPos and EnvSize have been initialized
begin
PrintPrev.Invalidate; // Erase contents of Panel
PrintPrev.Update;
// Set the mapping mode for the panel to MM_ISOTROPIC
SetMapMode(PrintPrev.Canvas.Handle, MM_ISOTROPIC);
// Set the TPanel's extent to match that of the printer boundaries.
SetWindowExtEx(PrintPrev.Canvas.Handle,
Printer.PageWidth, Printer.PageHeight, nil);
// Set the viewport extent to that of the PrintPrev TPanel size.
SetViewPortExtEx(PrintPrev.Canvas.Handle,
PrintPrev.Width, PrintPrev.Height, nil);
// Set the origin to the position at 0, 0
SetViewportOrgEx(PrintPrev.Canvas.Handle, 0, 0, nil);
PrintPrev.Brush.Style := bsSolid;
with EnvPos do
// Draw a rectangle to represent the envelope
PrintPrev.Canvas.Rectangle(Left, Top, Right, Bottom);
with ToAddrPos, PrintPrev.Canvas do
case FeedType of
epLHorz, epRHorz:
begin
Rectangle(Left, Top, Right, Top + 2);
Rectangle(Left, Top + (Bottom - Top) div 2, Right, Top + (Bottom - Top)
div 2 + 2);
Rectangle(Left, Bottom, Right, Bottom + 2);
end;
epLVert, epRVert:
begin
Rectangle(Left, Top, Left + 2, Bottom);
Rectangle(Left + (Right - Left) div 2, Top, Left + (Right - Left) div 2
+ 2, Bottom);
Rectangle(Right, Top, Right + 2, Bottom);
end;
end; // case
end;
procedure TMainForm.FormCreate(Sender: TObject);
var
Ratio: double;
begin
// Calculate a ratio of PageWidth to PageHeight
Ratio := Printer.PageHeight / Printer.PageWidth;
// Create a new TPanel instance
with TPanel.Create(self) do
begin
SetBounds(15, 15, 203, trunc(203 * Ratio));
Color := clBlack;
BevelInner := bvNone;
BevelOuter := bvNone;
Parent := self;
end;
// Create a Print preview panel
PrintPrev := TPrintPrevPanel.Create(self);
with PrintPrev do
begin
SetBounds(10, 10, 200, trunc(200 * Ratio));
Color := clWhite;
BevelInner := bvNone;
BevelOuter := bvNone;
BorderStyle := bsSingle;
Parent := self;
end;
end;
procedure TMainForm.rgFeedTypeClick(Sender: TObject);
begin
EnvSize := GetEnvelopeSize;
EnvPos := GetEnvelopePos;
ToAddrPos := GetToAddrPos;
DrawIt;
end;
procedure TMainForm.SetCopies(Copies: Integer);
var
ADevice, ADriver, APort: string;
ADeviceMode: THandle;
DevMode: PDeviceMode;
begin
SetLength(ADevice, 255);
SetLength(ADriver, 255);
SetLength(APort, 255);
{ If ADeviceMode is zero, a printer driver is not loaded. Therefore,
setting PrinterIndex forces the driver to load. }
if ADeviceMode = 0 then
begin
Printer.PrinterIndex := Printer.PrinterIndex;
Printer.GetPrinter(PChar(ADevice), PChar(ADriver), PChar(APort),
ADeviceMode);
end;
if ADeviceMode <> 0 then
begin
DevMode := GlobalLock(ADeviceMode);
try
DevMode^.dmFields := DevMode^.dmFields or DM_Copies;
DevMode^.dmCopies := Copies;
finally
GlobalUnlock(ADeviceMode);
end;
end
else
raise Exception.Create('Could not set printer copies');
end;
procedure TMainForm.mmiPrintItClick(Sender: TObject);
var
TempHeight: integer;
SaveFont: TFont;
begin
if PrintDialog.Execute then
begin
// Set the number of copies to print
SetCopies(PrintDialog.Copies);
Printer.BeginDoc;
try
// Calculate a temporary line height
TempHeight := Printer.Canvas.TextHeight(edtName.Text);
with ToAddrPos do
begin
{ When printing vertically, rotate the font such that it paints
at a 90 degree angle. }
if (FeedType = eplVert) or (FeedType = epRVert) then
begin
SaveFont := TFont.Create;
try
// Save the original font
SaveFont.Assign(Printer.Canvas.Font);
RotatePrintFont;
// Write out the address lines to the printer's Canvas
Printer.Canvas.TextOut(Left, Bottom, edtName.Text);
Printer.Canvas.TextOut(Left + TempHeight + 2, Bottom,
edtStreet.Text);
Printer.Canvas.TextOut(Left + TempHeight * 2 + 2, Bottom,
edtCityState.Text);
// Restore the original font
Printer.Canvas.Font.Assign(SaveFont);
finally
SaveFont.Free;
end;
end
else
begin
{ If the envelope is not printed vertically, then
just draw the address lines normally. }
Printer.Canvas.TextOut(Left, Top, edtName.Text);
Printer.Canvas.TextOut(Left, Top + TempHeight + 2, edtStreet.Text);
Printer.Canvas.TextOut(Left, Top + TempHeight * 2 + 2,
edtCityState.Text);
end;
end;
finally
Printer.EndDoc;
end;
end;
end;
procedure TMainForm.RotatePrintFont;
var
LogFont: TLogFont;
begin
with Printer.Canvas do
begin
with LogFont do
begin
lfHeight := Font.Height; // Set to Printer.Canvas.font.height
lfWidth := 0; // let font mapper choose width
lfEscapement := 900; // tenths of degrees so 900 = 90 degrees
lfOrientation := lfEscapement; // Always set to value of lfEscapement
lfWeight := FW_NORMAL; // default
lfItalic := 0; // no italics
lfUnderline := 0; // no underline
lfStrikeOut := 0; // no strikeout
lfCharSet := ANSI_CHARSET; //default
StrPCopy(lfFaceName, Font.Name); // Printer.Canvas's font's name
lfQuality := PROOF_QUALITY;
lfOutPrecision := OUT_TT_ONLY_PRECIS; // force TrueType fonts
lfClipPrecision := CLIP_DEFAULT_PRECIS; // default
lfPitchAndFamily := Variable_Pitch; // default
end;
end;
Printer.Canvas.Font.Handle := CreateFontIndirect(LogFont);
end;
end.
Распечатать Excel файл.
uses ComObj;
procedure TForm1.Button1Click(Sender: TObject);
var
ExcelApp: OLEVariant;
begin
// Create an Excel instance
// Excel Instanz erzeugen
ExcelApp := CreateOleObject('Excel.Application');
try
ExcelApp.Workbooks.Open('C:\test\xyz.xls');
// you can also modify some settings from PageSetup
// Man kann auch noch einige Einstellungen von "Seite Einrichten" anpassen
ExcelApp.ActiveSheet.PageSetup.Orientation := xlLandscape;
// Print it out
// Ausdrucken
ExcelApp.Worksheets.PrintOut;
finally
// Close Excel
// Excel wieder schliessen
if not VarIsEmpty(ExcelApp) then
begin
ExcelApp.Quit;
ExcelApp := Unassigned;
end;
end;
end;
|
Печать всей формы.
unit PrintF;
{Печатает TLabel, TEdit, TMemo, TStringGrid, TShape и др. DB-компоненты.
Установите Form H & V ScrollBar.Ranges на 768X1008 для страницы 8X10.5.
Примечание: это не компонент. Успехов. Bill}
interface
uses
SysUtils, WinTypes, WinProcs, Classes, Graphics, Controls,
Forms, Grids, Printers, StdCtrls, ExtCtrls, Mask;
function PrintForm(AForm: TForm; ATag: Longint): integer;
{используйте: PrintForm(Form2, 0);
AForm - форма, которую необходимо напечатать. Если вы, к примеру,
печатаете Form2 из обработчика события Form1, то используйте Unit2
в списке используемых модулей в секции implementation молуля Unit1.
ATag - поле Tag компонента, который необходимо печатать или 0 для всех.
Если Tag компонента равен 14 (2+4+8), он буден напечатан в случае,
когда ATag равен 0, 2, 4 или 8.
Функция возвращает количество напечатанных компонентов. }
implementation
var
ScaleX, ScaleY, I, Count: integer;
DC: HDC;
F: TForm;
function ScaleToPrinter(R: TRect): TRect;
begin
R.Top := (R.Top + F.VertScrollBar.Position) * ScaleY;
R.Left := (R.Left + F.HorzScrollBar.Position) * ScaleX;
R.Bottom := (R.Bottom + F.VertScrollBar.Position) * ScaleY;
R.Right := (R.Right + F.HorzScrollBar.Position) * ScaleY;
Result := R;
end;
procedure PrintMComponent(MC: TMemo);
var
C: array[0..255] of char;
CLen: integer;
Format: Word;
R: TRect;
begin
Printer.Canvas.Font := MC.Font;
DC := Printer.Canvas.Handle; {так DrawText знает о шрифте}
R := ScaleToPrinter(MC.BoundsRect);
if (not (F.Components[I] is TCustomLabel)) and (MC.BorderStyle = bsSingle)
then
Printer.Canvas.Rectangle(R.Left, R.Top, R.Right, R.Bottom);
Format := DT_LEFT;
if (F.Components[I] is TEdit) or (F.Components[I] is TCustomMaskEdit) then
Format := Format or DT_SINGLELINE or DT_VCENTER
else
begin
if MC.WordWrap then
Format := DT_WORDBREAK;
if MC.Alignment = taCenter then
Format := Format or DT_CENTER;
if MC.Alignment = taRightJustify then
Format := Format or DT_RIGHT;
R.Bottom := R.Bottom + Printer.Canvas.Font.Height;
end;
CLen := MC.GetTextBuf(C, 255);
R.Left := R.Left + ScaleX + ScaleX;
WinProcs.DrawText(DC, C, CLen, R, Format);
inc(Count);
end;
procedure PrintShape(SC: TShape);
var
H, W, S: integer;
R: TRect;
begin {PrintShape}
Printer.Canvas.Pen := SC.Pen;
Printer.Canvas.Pen.Width := Printer.Canvas.Pen.Width * ScaleX;
Printer.Canvas.Brush := SC.Brush;
R := ScaleToPrinter(SC.BoundsRect);
W := R.Right - R.Left;
H := R.Bottom - R.Top;
if W < H then
S := W
else
S := H;
if SC.Shape in [stSquare, stRoundSquare, stCircle] then
begin
Inc(R.Left, (W - S) div 2);
Inc(R.Top, (H - S) div 2);
W := S;
H := S;
end;
case SC.Shape of
stRectangle, stSquare:
Printer.Canvas.Rectangle(R.Left, R.Top, R.Left + W, R.Top + H);
stRoundRect, stRoundSquare:
Printer.Canvas.RoundRect(R.Left, R.Top, R.Left + W, R.Top + H, S div 4, S
div 4);
stCircle, stEllipse:
Printer.Canvas.Ellipse(R.Left, R.Top, R.Left + W, R.Top + H);
end;
Printer.Canvas.Pen.Width := ScaleX;
Printer.Canvas.Brush.Style := bsClear;
inc(Count);
end; {PrintShape}
procedure PrintSGrid(SGC: TStringGrid);
var
J, K: integer;
Q, R: TRect;
Format: Word;
C: array[0..255] of char;
CLen: integer;
begin
Printer.Canvas.Font := SGC.Font;
DC := Printer.Canvas.Handle; {так DrawText знает о шрифте}
Format := DT_SINGLELINE or DT_VCENTER;
Q := SGC.BoundsRect;
Printer.Canvas.Pen.Width := SGC.GridLineWidth * ScaleX;
for J := 0 to SGC.ColCount - 1 do
for K := 0 to SGC.RowCount - 1 do
begin
R := SGC.CellRect(J, K);
if R.Right > R.Left then
begin
R.Left := R.Left + Q.Left;
R.Right := R.Right + Q.Left + SGC.GridLineWidth;
R.Top := R.Top + Q.Top;
R.Bottom := R.Bottom + Q.Top + SGC.GridLineWidth;
R := ScaleToPrinter(R);
if (J < SGC.FixedCols) or (K < SGC.FixedRows) then
Printer.Canvas.Brush.Color := SGC.FixedColor
else
Printer.Canvas.Brush.Style := bsClear;
if SGC.GridLineWidth > 0 then
Printer.Canvas.Rectangle(R.Left, R.Top, R.Right, R.Bottom);
StrPCopy(C, SGC.Cells[J, K]);
R.Left := R.Left + ScaleX + ScaleX;
WinProcs.DrawText(DC, C, StrLen(C), R, Format);
end;
end;
Printer.Canvas.Pen.Width := ScaleX;
inc(Count);
end;
function PrintForm(AForm: TForm; ATag: Longint): integer;
begin {PrintForm}
Count := 0;
F := AForm;
Printer.BeginDoc;
try
DC := Printer.Canvas.Handle;
ScaleX := WinProcs.GetDeviceCaps(DC, LOGPIXELSX) div F.PixelsPerInch;
ScaleY := WinProcs.GetDeviceCaps(DC, LOGPIXELSY) div F.PixelsPerInch;
for I := 0 to F.ComponentCount - 1 do
if TControl(F.Components[I]).Visible then
if (ATag = 0) or (TControl(F.Components[I]).Tag and ATag = ATag) then
begin
if (F.Components[I] is TCustomLabel) or (F.Components[I] is
TCustomEdit) then
PrintMComponent(TMemo(F.Components[I]));
if (F.Components[I] is TShape) then
PrintShape(TShape(F.Components[I]));
if (F.Components[I] is TStringGrid) then
PrintSGrid(TStringGrid(F.Components[I]));
end;
finally
Printer.EndDoc;
Result := Count;
end;
end; {PrintForm}
end.
|
unit Rulers;
{ Добавьте в файл .DCR иконки для двух компонентов.
Успехов, Bill}
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms;
type
THRuler = class(TGraphicControl)
private
{ Private declarations }
fHRulerAlign: TAlign;
procedure SetHRulerAlign(Value: TAlign);
protected
{ Protected declarations }
procedure Paint; override;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
published
{ Published declarations }
property AlignHRuler: TAlign read fHRulerAlign write SetHRulerAlign default
alNone;
property Color default clYellow;
property Height default 33;
property Width default 768;
property Visible;
end;
type
TVRuler = class(TGraphicControl)
private
{ Private declarations }
fVRulerAlign: TAlign;
procedure SetVRulerAlign(Value: TAlign);
protected
{ Protected declarations }
procedure Paint; override;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
published
{ Published declarations }
property AlignVRuler: TAlign read fVRulerAlign write SetVRulerAlign default
alNone;
property Color default clYellow;
property Height default 1008;
property Width default 33;
property Visible;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Samples', [THRuler, TVRuler]);
end;
procedure THRuler.SetHRulerAlign(Value: TAlign);
begin
if Value in [alTop, alBottom, alNone] then
begin
fHRulerAlign := Value;
Align := Value;
end;
end;
constructor THRuler.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
AlignHRuler := alNone;
Color := clYellow;
Height := 33;
Width := 768;
end;
procedure THRuler.Paint;
var
a12th, N, X: word;
begin
a12th := Screen.PixelsPerInch div 12;
N := 0;
X := 0;
with Canvas do
begin
Brush.Color := Color;
FillRect(ClientRect);
with ClientRect do
Rectangle(Left, Top, Right, Bottom);
while X < Width do
begin
MoveTo(X, 1);
LineTo(X, 6 * (1 + byte(N mod 3 = 0) +
byte(N mod 6 = 0) +
byte(N mod 12 = 0)));
if (N > 0) and (N mod 12 = 0) then
TextOut(PenPos.X + 3, 9, IntToStr(N div 12));
N := N + 1;
X := X + a12th;
end;
end;
end;
{*********************************************}
procedure TVRuler.SetVRulerAlign(Value: TAlign);
begin
if Value in [alLeft, alRight, alNone] then
begin
fVRulerAlign := Value;
Align := Value;
end;
end;
constructor TVRuler.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
AlignVRuler := alNone;
Color := clYellow;
Height := 1008;
Width := 33;
end;
procedure TVRuler.Paint;
var
a6th, N, Y: word;
begin
a6th := Screen.PixelsPerInch div 6;
N := 0;
Y := 0;
with Canvas do
begin
Brush.Color := Color;
FillRect(ClientRect);
with ClientRect do
Rectangle(Left, Top, Right, Bottom);
while Y < Height do
begin
MoveTo(1, Y);
LineTo(6 * (2 + byte(N mod 3 = 0) +
byte(N mod 6 = 0)), Y);
if (N > 0) and (N mod 6 = 0) then
TextOut(12, PenPos.Y - 16, IntToStr(N div 6));
N := N + 1;
Y := Y + a6th;
end;
end;
end;
end.
|
Печать всей формы 2.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{
Dieser Code druckt den Inhalt einer Form aus.
Jedoch ohne Rand und Titelleiste.
This code prints out form1. Without border and caption bar.
Print uses the GetFormImage method to obtain a bitmap of the form and
draws that to the printer’s HDC.
}
procedure TForm1.Button1Click(Sender: TObject);
begin
Form1.Print;
end;
{
The following TI details a better way to print the contents of
a form, by getting the device independent bits in 256 colors
from the form, and using those bits to print the form to the
printer.
In addition, a check is made to see if the screen or printer
is a palette device, and if so, palette handling for the device
is enabled. If the screen device is a palette device, an additional
step is taken to fill the bitmap's palette from the system palette,
overcoming some buggy video drivers who don't fill the palette in.
Note: Since this code does a screen shot of the form, the form must
be the topmost window and the whole from must be viewable when the
form shot is made.
Copyright by SWAG SUPPORT TEAM
http://gdsoft.com/swag/swag.html
}
procedure PrintForm(AForm: TForm; BorderWidth: Integer);
var
dc: HDC;
isDcPalDevice: BOOL;
MemDc: hdc;
MemBitmap: hBitmap;
OldMemBitmap: hBitmap;
hDibHeader: THandle;
pDibHeader: Pointer;
hBits: THandle;
pBits: Pointer;
ScaleX: Double;
ScaleY: Double;
ppal: PLOGPALETTE;
pal: hPalette;
Oldpal: hPalette;
i: Integer;
begin
{Get the screen dc}
dc := GetDc(0);
{Create a compatible dc}
MemDc := CreateCompatibleDc(dc);
{create a bitmap}
MemBitmap := CreateCompatibleBitmap(Dc,
AForm.Width,
AForm.Height);
{select the bitmap into the dc}
OldMemBitmap := SelectObject(MemDc, MemBitmap);
{Lets prepare to try a fixup for broken video drivers}
isDcPalDevice := False;
if GetDeviceCaps(dc, RASTERCAPS) and
RC_PALETTE = RC_PALETTE then
begin
GetMem(pPal, SizeOf(TLOGPALETTE) +
(255 * SizeOf(TPALETTEENTRY)));
FillChar(pPal^, SizeOf(TLOGPALETTE) +
(255 * SizeOf(TPALETTEENTRY)), #0);
pPal^.palVersion := $300;
pPal^.palNumEntries :=
GetSystemPaletteEntries(dc,
0,
256,
pPal^.palPalEntry);
if pPal^.PalNumEntries <> 0 then
begin
pal := CreatePalette(pPal^);
oldPal := SelectPalette(MemDc, Pal, False);
isDcPalDevice := True
end
else
FreeMem(pPal, SizeOf(TLOGPALETTE) +
(255 * SizeOf(TPALETTEENTRY)));
end;
{copy from the screen to the memdc/bitmap}
BitBlt(MemDc,
0, 0,
AForm.Width, AForm.Height,
Dc,
AForm.Left, AForm.Top,
SrcCopy);
if isDcPalDevice = True then
begin
SelectPalette(MemDc, OldPal, False);
DeleteObject(Pal);
end;
{unselect the bitmap}
SelectObject(MemDc, OldMemBitmap);
{delete the memory dc}
DeleteDc(MemDc);
{Allocate memory for a DIB structure}
hDibHeader := GlobalAlloc(GHND,
SizeOf(TBITMAPINFO) +
(SizeOf(TRGBQUAD) * 256));
{get a pointer to the alloced memory}
pDibHeader := GlobalLock(hDibHeader);
{fill in the dib structure with info on the way we want the DIB}
FillChar(pDibHeader^,
SizeOf(TBITMAPINFO) + (SizeOf(TRGBQUAD) * 256),
#0);
PBITMAPINFOHEADER(pDibHeader)^.biSize :=
SizeOf(TBITMAPINFOHEADER);
PBITMAPINFOHEADER(pDibHeader)^.biPlanes := 1;
PBITMAPINFOHEADER(pDibHeader)^.biBitCount := 8;
PBITMAPINFOHEADER(pDibHeader)^.biWidth := AForm.Width;
PBITMAPINFOHEADER(pDibHeader)^.biHeight := AForm.Height;
PBITMAPINFOHEADER(pDibHeader)^.biCompression := BI_RGB;
{find out how much memory for the bits}
GetDIBits(dc,
MemBitmap,
0,
AForm.Height,
nil,
TBitmapInfo(pDibHeader^),
DIB_RGB_COLORS);
{Alloc memory for the bits}
hBits := GlobalAlloc(GHND,
PBitmapInfoHeader(pDibHeader)^.BiSizeImage);
{Get a pointer to the bits}
pBits := GlobalLock(hBits);
{Call fn again, but this time give us the bits!}
GetDIBits(dc,
MemBitmap,
0,
AForm.Height,
pBits,
PBitmapInfo(pDibHeader)^,
DIB_RGB_COLORS);
{Lets try a fixup for broken video drivers}
if isDcPalDevice = True then
begin
for i := 0 to (pPal^.PalNumEntries - 1) do
begin
PBitmapInfo(pDibHeader)^.bmiColors[i].rgbRed :=
pPal^.palPalEntry[i].peRed;
PBitmapInfo(pDibHeader)^.bmiColors[i].rgbGreen :=
pPal^.palPalEntry[i].peGreen;
PBitmapInfo(pDibHeader)^.bmiColors[i].rgbBlue :=
pPal^.palPalEntry[i].peBlue;
end;
FreeMem(pPal, SizeOf(TLOGPALETTE) +
(255 * SizeOf(TPALETTEENTRY)));
end;
{Release the screen dc}
ReleaseDc(0, dc);
{Delete the bitmap}
DeleteObject(MemBitmap);
{Start print job}
Printer.BeginDoc;
{Scale print size}
if Printer.PageWidth < Printer.PageHeight then
begin
ScaleX := Printer.PageWidth;
ScaleY := AForm.Height * (Printer.PageWidth / AForm.Width);
end
else
begin
ScaleX := AForm.Width * (Printer.PageHeight / AForm.Height);
ScaleY := Printer.PageHeight;
end;
{Just incase the printer drver is a palette device}
isDcPalDevice := False;
if GetDeviceCaps(Printer.Canvas.Handle, RASTERCAPS) and
RC_PALETTE = RC_PALETTE then
begin
{Create palette from dib}
GetMem(pPal, SizeOf(TLOGPALETTE) +
(255 * SizeOf(TPALETTEENTRY)));
FillChar(pPal^, SizeOf(TLOGPALETTE) +
(255 * SizeOf(TPALETTEENTRY)), #0);
pPal^.palVersion := $300;
pPal^.palNumEntries := 256;
for i := 0 to (pPal^.PalNumEntries - 1) do
begin
pPal^.palPalEntry[i].peRed :=
PBitmapInfo(pDibHeader)^.bmiColors[i].rgbRed;
pPal^.palPalEntry[i].peGreen :=
PBitmapInfo(pDibHeader)^.bmiColors[i].rgbGreen;
pPal^.palPalEntry[i].peBlue :=
PBitmapInfo(pDibHeader)^.bmiColors[i].rgbBlue;
end;
pal := CreatePalette(pPal^);
FreeMem(pPal, SizeOf(TLOGPALETTE) +
(255 * SizeOf(TPALETTEENTRY)));
oldPal := SelectPalette(Printer.Canvas.Handle, Pal, False);
isDcPalDevice := True
end;
{send the bits to the printer}
StretchDiBits(Printer.Canvas.Handle,
BorderWidth, BorderWidth,
Round(scaleX)-BorderWidth, Round(scaleY)-BorderWidth,
0, 0,
AForm.Width, AForm.Height,
pBits,
PBitmapInfo(pDibHeader)^,
DIB_RGB_COLORS,
SRCCOPY);
RotateBitmap(var hDIB: HGlobal; 180; clWhite);
{Just incase you printer drver is a palette device}
if isDcPalDevice = True then
begin
SelectPalette(Printer.Canvas.Handle, oldPal, False);
DeleteObject(Pal);
end;
{Clean up allocated memory}
GlobalUnlock(hBits);
GlobalFree(hBits);
GlobalUnlock(hDibHeader);
GlobalFree(hDibHeader);
{End the print job}
Printer.EndDoc;
end;
Печать содержимого TMemo или TListBox.
| Идет Иван царевич по лесу и видит: стоит избушка на курьих ножках. Как обычно, к лесу передом к нему (ну сами знаете). Иван царевич ей и говорит: - Избушка, избушка! Повернись ко мне передом, а к лесу задом! А избушка ему в ответ: - Denied of Service |
Следующая функция имеет один параметр в виде объекта TStrings и печатает каждую строку на принтер, установленный в системе по умолчанию. Так как эта функция использует TStrings, то она будет работать с различными компонентами, которые содержат свойство типа TStrings, такие как TDBMemo или TOutline:
uses Printers;
procedure PrintStrings(Strings: TStrings);
var
Prn: TextFile;
i: word;
begin
AssignPrn(Prn);
try
Rewrite(Prn);
try
for i := 0 to Strings.Count - 1 do
writeln(Prn, Strings.Strings[i]);
finally
CloseFile(Prn);
end;
except
on EInOutError do
MessageDlg('Error Printing text.', mtError, [mbOk], 0);
end;
end;
|
Чтобы распечатать содержимое TMemo или TListbox, используйте следующие команды:
PrintStrings(Memo1.Lines); |
Или.
PrintStrings(Listbox1.Items); |
Как производить Печать из WebBrowsera.
Есть два способа вывода на печать. Первый пример работает в IE 4.x и выше, в то время как второй пример расчитан на IE 3.x:
var vaIn, vaOut: OleVariant; ... WebBrowser.ControlInterface.ExecWB(OLECMDID_PRINT, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut); |
Либо:
procedure TForm1.PrintIE;
var
CmdTarget : IOleCommandTarget;
vaIn, vaOut: OleVariant;
begin
if WebBrowser1.Document <> nil then
try
WebBrowser1.Document.QueryInterface(IOleCommandTarget, CmdTarget);
if CmdTarget <> nil then
try
CmdTarget.Exec( PGuid(nil), OLECMDID_PRINT,
OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);
finally
CmdTarget._Release;
end;
except
// nothing
end;
end;
|
Обратите внимание: Если версия Delphi ниже чем 3.02, то необходимо заменить.
PGuid(nil) |
На.
PGuid(nil)^ |
Как напечатать изображение.
Используйте приведенный код. И не забудьте включить Printers в список используемых модулей:Строки, на которые вы должны обратить внимание, справа содержат комментарий // **. Данный код осуществляет корректное масштабирование изображения, в противном случае при печати вы можете получить небольшую иконку. Разрешение принтера больше, чем разрешение вашего дисплея.
procedure AngleTextOut(CV: TCanvas; const sText: string; x, y, angle: integer);
var
LogFont: TLogFont;
SaveFont: TFont;
procedure TForm1.Button1Click(Sender: TObject);
var
ScaleX, ScaleY: Integer;
R: TRect;
begin
Printer.BeginDoc; // **
with Printer do
try
ScaleX := GetDeviceCaps(Handle, logPixelsX) div PixelsPerInch;
ScaleY := GetDeviceCaps(Handle, logPixelsY) div PixelsPerInch;
R := Rect(0, 0, Image1.Picture.Width * ScaleX,
Image1.Picture.Height * ScaleY);
Canvas.StretchDraw(R, Image1.Picture.Graphic); // **
finally
EndDoc; // **
end;
end;
|
Печать текста в обход Windows.
Автор: SteveОТкройте файл типа TextFile и пишите в него напрямую:
var Lst: TextFile; begin AssignFile(Lst, 'LPT1'); Rewrite(Lst); WriteLn(Lst, 'Здравствуй, мир!'); Close(Lst); end. |
Если вы планируете посылать на принтер управляющие коды, вызывайте следующую функцию немедленно после перезаписи файла:
procedure SetBinaryMode (var F: Text); assembler; asm mov ax,$4400 les di,F mov bx,word ptr es:[di] int $21 or dl,$20 xor dh,dh mov ax,$4401 int $21 end; |
Печать на любом принтере.
Автор: Mike Scott Как лучше всего убедиться в том, что текст на странице расположен правильно вне зависимости от принтера, версии windows и т.п.? Есть пара вызовов принтерных Escape-функций API, возвращающих физический размер страницы и отступ от края при печати (верх лево). Используя это, вы можете убедиться в том, печать начинается в одном и том же месте реального листа. Примечание: тем не менее, вы все еще зависите от точности принтера и драйвера, на практике это может вылиться в разброс 1-2 мм.Для получения размера физической страницы и отступа от верхнего левого угла печатаемой области, используйте следующий код:
var PhysSize, PrintingOffset : TPoint ; begin Escape( Printer.Handle, GetPhysPageSize, 0, NIL, @PhysSize ) ; Escape( Printer.Handle, GetPrintingOffset, 0, NIL, @PrintingOffset ) ; |
PhysSize и PrintingOffset теперь устанавливаются в единицах устройства, т.е. в пикселях принтера. Для преобразования мм в единицы устройства используйте следующий код:
xDevUnits := MulDiv( XXXmm, GetDeviceCaps( Printer.Handle, HORZRES ), GetDeviceCaps( Printer.Handle, HORZSIZE ) ) ; yDevUnits := MulDiv( YYYmm, GetDeviceCaps( Printer.Handle, VERTRES ), GetDeviceCaps( Printer.Handle, VERTSIZE ) ) ; |
Затем, для примера, вы можете использовать эти координаты для вывода текста с помощью методов Printer.Canvas. Хорошая идея для этого метода - измерение единиц устройств, отступа и размера страниц для различных принтеров и сохранение полученной информации в базе данных. Также можно предусмотреть удобный для пользователя диалог, где он мог бы внести свои изменения и откорректировать точность своего принтера.
Печать структуры таблицы Paradox.
Вот код печати структуры таблицы Paradox, состряпанный на скорую руку. Предполагается, что компонент Table имеет имя Table1.
procedure TForm1.Button1Click(Sender: TObject);
const
FieldTypes: array[0..16] of string[10] = ('Unknown', 'String', 'Smallint',
'Integer', 'Word', 'Boolean', 'Float', 'Currency', 'BCD', 'Date', 'Time',
'DateTime', 'Bytes', 'VarBytes', 'Blob', 'Memo', 'Graphic');
var
i, nX, nY, nHeight, nWidth: Integer;
rtxtMetric: TTextMetric;
s: array[0..3] of string[10];
begin
with Table1.FieldDefs, Printer do
begin
Update;
PrinterIndex := -1;
Title := 'Структура ' + Table1.TableName;
BeginDoc;
nX := 0;
nY := 0;
WinProcs.GetTextMetrics(Canvas.Handle, rtxtMetric);
nHeight := rtxtMetric.tmHeight;
nWidth := rtxtMetric.tmAveCharWidth;
for i := 0 to Count - 1 do
begin
s[0] := IntToStr(Items[i].FieldNo) + #9;
s[1] := Items[i].Name + #9;
s[2] := FieldTypes[Ord(Items[i].DataType)] + #9;
s[3] := IntToStr(Items[i].Size);
Canvas.TextOut(nX, nY, s[0]);
Inc(nX, Length(s[0]) * nWidth);
Canvas.TextOut(nX, nY, s[1]);
Inc(nX, Length(s[1]) * nWidth);
Canvas.TextOut(nX, nY, s[2]);
Inc(nX, Length(s[2]) * nWidth);
Canvas.TextOut(nX, nY, s[3]);
nX := 0;
nY := i * nHeight;
end;
EndDoc;
end;
end;
|
Как распечатать картинку.
Автор: Олег Кулабухов.
uses Printers;
type
PPalEntriesArray = ^TPalEntriesArray; {for palette re-construction}
TPalEntriesArray = array[0..0] of TPaletteEntry;
procedure BltTBitmapAsDib(DestDc: hdc; {Handle of where to blt}
x: word; {Bit at x}
y: word; {Blt at y}
Width: word; {Width to stretch}
Height: word; {Height to stretch}
bm: TBitmap); {the TBitmap to Blt}
var
OriginalWidth: LongInt; {width of BM}
dc: hdc; {screen dc}
IsPaletteDevice: bool; {if the device uses palettes}
IsDestPaletteDevice: bool; {if the device uses palettes}
BitmapInfoSize: integer; {sizeof the bitmapinfoheader}
lpBitmapInfo: PBitmapInfo; {the bitmap info header}
hBm: hBitmap; {handle to the bitmap}
hPal: hPalette; {handle to the palette}
OldPal: hPalette; {temp palette}
hBits: THandle; {handle to the DIB bits}
pBits: pointer; {pointer to the DIB bits}
lPPalEntriesArray: PPalEntriesArray; {palette entry array}
NumPalEntries: integer; {number of palette entries}
i: integer; {looping variable}
begin
{If range checking is on - lets turn it off for now}
{we will remember if range checking was on by defining}
{a define called CKRANGE if range checking is on.}
{We do this to access array members past the arrays}
{defined index range without causing a range check}
{error at runtime. To satisfy the compiler, we must}
{also access the indexes with a variable. ie: if we}
{have an array defined as a: array[0..0] of byte,}
{and an integer i, we can now access a[3] by setting}
{i := 3; and then accessing a[i] without error}
{$IFOPT R+}
{$DEFINE CKRANGE}
{$R-}
{$ENDIF}
{Save the original width of the bitmap}
OriginalWidth := bm.Width;
{Get the screen's dc to use since memory dc's are not reliable}
dc := GetDc(0);
{Are we a palette device?}
IsPaletteDevice :=
GetDeviceCaps(dc, RASTERCAPS) and RC_PALETTE = RC_PALETTE;
{Give back the screen dc}
dc := ReleaseDc(0, dc);
{Allocate the BitmapInfo structure}
if IsPaletteDevice then
BitmapInfoSize := sizeof(TBitmapInfo) + (sizeof(TRGBQUAD) * 255)
else
BitmapInfoSize := sizeof(TBitmapInfo);
GetMem(lpBitmapInfo, BitmapInfoSize);
{Zero out the BitmapInfo structure}
FillChar(lpBitmapInfo^, BitmapInfoSize, #0);
{Fill in the BitmapInfo structure}
lpBitmapInfo^.bmiHeader.biSize := sizeof(TBitmapInfoHeader);
lpBitmapInfo^.bmiHeader.biWidth := OriginalWidth;
lpBitmapInfo^.bmiHeader.biHeight := bm.Height;
lpBitmapInfo^.bmiHeader.biPlanes := 1;
if IsPaletteDevice then
lpBitmapInfo^.bmiHeader.biBitCount := 8
else
lpBitmapInfo^.bmiHeader.biBitCount := 24;
lpBitmapInfo^.bmiHeader.biCompression := BI_RGB;
lpBitmapInfo^.bmiHeader.biSizeImage :=
((lpBitmapInfo^.bmiHeader.biWidth *
longint(lpBitmapInfo^.bmiHeader.biBitCount)) div 8) *
lpBitmapInfo^.bmiHeader.biHeight;
lpBitmapInfo^.bmiHeader.biXPelsPerMeter := 0;
lpBitmapInfo^.bmiHeader.biYPelsPerMeter := 0;
if IsPaletteDevice then
begin
lpBitmapInfo^.bmiHeader.biClrUsed := 256;
lpBitmapInfo^.bmiHeader.biClrImportant := 256;
end
else
begin
lpBitmapInfo^.bmiHeader.biClrUsed := 0;
lpBitmapInfo^.bmiHeader.biClrImportant := 0;
end;
{Take ownership of the bitmap handle and palette}
hBm := bm.ReleaseHandle;
hPal := bm.ReleasePalette;
{Get the screen's dc to use since memory dc's are not reliable}
dc := GetDc(0);
if IsPaletteDevice then
begin
{If we are using a palette, it must be}
{selected into the dc during the conversion}
OldPal := SelectPalette(dc, hPal, TRUE);
{Realize the palette}
RealizePalette(dc);
end;
{Tell GetDiBits to fill in the rest of the bitmap info structure}
GetDiBits(dc,
hBm,
0,
lpBitmapInfo^.bmiHeader.biHeight,
nil,
TBitmapInfo(lpBitmapInfo^),
DIB_RGB_COLORS);
{Allocate memory for the Bits}
hBits := GlobalAlloc(GMEM_MOVEABLE,
lpBitmapInfo^.bmiHeader.biSizeImage);
pBits := GlobalLock(hBits);
{Get the bits}
GetDiBits(dc,
hBm,
0,
lpBitmapInfo^.bmiHeader.biHeight,
pBits,
TBitmapInfo(lpBitmapInfo^),
DIB_RGB_COLORS);
if IsPaletteDevice then
begin
{Lets fix up the color table for buggy video drivers}
GetMem(lPPalEntriesArray, sizeof(TPaletteEntry) * 256);
{$IFDEF VER100}
NumPalEntries := GetPaletteEntries(hPal,
0,
256,
lPPalEntriesArray^);
{$ELSE}
NumPalEntries := GetSystemPaletteEntries(dc,
0,
256,
lPPalEntriesArray^);
{$ENDIF}
for i := 0 to (NumPalEntries - 1) do
begin
lpBitmapInfo^.bmiColors[i].rgbRed :=
lPPalEntriesArray^[i].peRed;
lpBitmapInfo^.bmiColors[i].rgbGreen :=
lPPalEntriesArray^[i].peGreen;
lpBitmapInfo^.bmiColors[i].rgbBlue :=
lPPalEntriesArray^[i].peBlue;
end;
FreeMem(lPPalEntriesArray, sizeof(TPaletteEntry) * 256);
end;
if IsPaletteDevice then
begin
{Select the old palette back in}
SelectPalette(dc, OldPal, TRUE);
{Realize the old palette}
RealizePalette(dc);
end;
{Give back the screen dc}
dc := ReleaseDc(0, dc);
{Is the Dest dc a palette device?}
IsDestPaletteDevice :=
GetDeviceCaps(DestDc, RASTERCAPS) and RC_PALETTE = RC_PALETTE;
if IsPaletteDevice then
begin
{If we are using a palette, it must be}
{selected into the dc during the conversion}
OldPal := SelectPalette(DestDc, hPal, TRUE);
{Realize the palette}
RealizePalette(DestDc);
end;
{Do the blt}
StretchDiBits(DestDc,
x,
y,
Width,
Height,
0,
0,
OriginalWidth,
lpBitmapInfo^.bmiHeader.biHeight,
pBits,
lpBitmapInfo^,
DIB_RGB_COLORS,
SrcCopy);
if IsDestPaletteDevice then
begin
{Select the old palette back in}
SelectPalette(DestDc, OldPal, TRUE);
{Realize the old palette}
RealizePalette(DestDc);
end;
{De-Allocate the Dib Bits}
GlobalUnLock(hBits);
GlobalFree(hBits);
{De-Allocate the BitmapInfo}
FreeMem(lpBitmapInfo, BitmapInfoSize);
{Set the ownership of the bimap handles back to the bitmap}
bm.Handle := hBm;
bm.Palette := hPal;
{Turn range checking back on if it was on when we started}
{$IFDEF CKRANGE}
{$UNDEF CKRANGE}
{$R+}
{$ENDIF}
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if PrintDialog1.Execute then
begin
Printer.BeginDoc;
BltTBitmapAsDib(Printer.Canvas.Handle,
0,
0,
Image1.Picture.Bitmap.Width,
Image1.Picture.Bitmap.Height,
Image1.Picture.Bitmap);
Printer.EndDoc;
end;
end;
|
Распечатать файл через порт принтера.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
procedure TForm1.Button1Click(Sender: TObject);
var
port, prnfile: file;
buffer: array [1..128] of Char;
Read: Integer;
begin
// Specify a file to print
AssignFile(prnfile, 'filetoprint');
Reset(prnfile, 1);
// specify printer port
AssignFile(port, 'LPT1');
Rewrite(port, 1);
repeat
BlockRead(prnfile, buffer, SizeOf(buffer), Read);
BlockWrite(port, buffer, Read);
// Application.ProcessMessages;
until EOF(prnfile) or (Read <> SizeOf(buffer));
CloseFile(prnfile);
CloseFile(port);
end;
Распечатать файл через порт принтера 2.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{
Question:
How do I write a raw string of a data to the printer?
The following unit "PrtRaw.pas" demonstrates a 16/32 bit
raw printing unit for Delphi and Borland C Builder.
Following the unit, is an exmaple on using the
PrtRaw unit.
Notes:
1) You are responsible for embedding all necessary
control codes that the printer may require (including
form feed codes).
2) You must specify a valid printer and port name.
}
unit PrtRaw;
{Copyright (c) 1998 by Joe C. Hecht - All rights Reserved}
{joehecht@gte.net You may use and share this unit}
{providing my name and the copyright notice stays intact.}
interface
uses
WinTypes;
{$IFDEF WIN32}
type SpoolInt = DWORD;
{$ELSE}
type SpoolInt = integer;
{$ENDIF}
function StartRawPrintJob(PrinterName : pChar;
Port : pChar;
DocName : pChar) : THandle;
function StartRawPrintPage(hPrn : THandle) : integer;
function PrintRawData(hPrn : THandle;
Buffer : pointer;
NumBytes : SpoolInt) : integer;
function EndRawPrintPage(hPrn : THandle) : integer;
function EndRawPrintJob(hPrn : THandle) : integer;
implementation
uses
WinProcs,
{$IFDEF WIN32}
WinSpool;
{$ELSE}
Print;
{$ENDIF}
function StartRawPrintJob(PrinterName : pChar;
Port : pChar;
DocName : pChar) : THandle;
{$IFDEF WIN32}
var
hPrn : THandle;
DocInfo1 : TDocInfo1;
{$ENDIF}
begin
{$IFDEF WIN32}
if (OpenPrinter(PChar(PrinterName),
hPrn,
nil) = FALSE) then
begin
Result := THandle(-1);
Exit;
end;
DocInfo1.pDocName := DocName;
DocInfo1.pOutputFile := Port;
DocInfo1.pDataType := 'RAW';
if (StartDocPrinter(hPrn,
1,
@DocInfo1) = 0) then
begin
Result := THandle(-1);
Exit;
end;
Result := hPrn;
{$ELSE}
result := OpenJob(Port,
DocName,
0);
{$ENDIF}
end;
function StartRawPrintPage(hPrn : THandle) : integer;
begin
{$IFDEF WIN32}
if (StartPagePrinter(hPrn) = FALSE) then
begin
Result := -1;
Exit;
end;
result := 1;
{$ELSE}
result := StartSpoolPage(hPrn);
{$ENDIF}
end;
function PrintRawData(hPrn : THandle;
Buffer : pointer;
NumBytes : SpoolInt) : integer;
{$IFDEF WIN32}
var
BytesWritten : DWORD;
{$ENDIF}
begin
if (NumBytes = 0) then
begin
Result := 1;
Exit;
end;
{$IFDEF WIN32}
if (WritePrinter(hPrn,
Buffer,
NumBytes,
BytesWritten) = FALSE) then
begin
Result := -1;
Exit;
end;
if (NumBytes <> BytesWritten) then
begin
Result := -1;
Exit;
end;
Result := 1;
{$ELSE}
result := WriteSpool(hPrn,
Buffer,
NumBytes);
{$ENDIF}
end;
function EndRawPrintPage(hPrn : THandle) : integer;
begin
{$IFDEF WIN32}
if (EndPagePrinter(hPrn) = FALSE) then
begin
Result := -1;
Exit;
end;
Result := 1;
{$ELSE}
result := EndSpoolPage(hPrn);
{$ENDIF}
end;
function EndRawPrintJob(hPrn : THandle) : integer;
begin
{$IFDEF WIN32}
if (EndDocPrinter(hPrn) = FALSE) then
begin
Result := -1;
Exit;
end;
if (ClosePrinter(hPrn) = FALSE) then
begin
Result := -1;
Exit;
end;
Result := 1;
{$ELSE}
result := CloseJob(hPrn);
{$ENDIF}
end;
end.
// Example of use:
uses
PrtRaw;
procedure TForm1.Button1Click(Sender: TObject);
var
hPrn : THandle;
Data : array[0..31] of char;
begin
hPrn := StartRawPrintJob('Generic / Text Only',
'LPT1:',
'My Document');
if (integer(hPrn) < 0) then
begin
ShowMessage('StartRawPrintJob Failed');
Exit;
end;
if (StartRawPrintPage(hPrn) < 0) then
begin
ShowMessage('StartRawPrintPage Failed');
EndRawPrintJob(hPrn);
Exit;
end;
Data[0] := 'P';
Data[1] := 'a';
Data[2] := 'g';
Data[3] := 'e';
Data[4] := ' ';
Data[5] := '1';
Data[6] := #13;
Data[7] := #10;
if (PrintRawData(hPrn,
@data,
8) < 0) then
begin
ShowMessage('PrintRawData Failed');
EndRawPrintPage(hPrn);
EndRawPrintJob(hPrn);
Exit;
end;
if (EndRawPrintPage(hPrn) < 0) then
begin
ShowMessage('EndRawPrintPage Failed');
EndRawPrintJob(hPrn);
Exit;
end;
if (StartRawPrintPage(hPrn) < 0) then
begin
ShowMessage('StartRawPrintPage Failed');
EndRawPrintJob(hPrn);
Exit;
end;
Data[0] := 'P';
Data[1] := 'a';
Data[2] := 'g';
Data[3] := 'e';
Data[4] := ' ';
Data[5] := '2';
Data[6] := #13;
Data[7] := #10;
if (PrintRawData(hPrn,
@data,
8) < 0) then
begin
ShowMessage('PrintRawData Failed');
EndRawPrintPage(hPrn);
EndRawPrintJob(hPrn);
Exit;
end;
if (EndRawPrintPage(hPrn) < 0) then
begin
ShowMessage('EndRawPrintPage Failed');
EndRawPrintJob(hPrn);
Exit;
end;
if (EndRawPrintJob(hPrn) < 0) then
begin
ShowMessage('EndRawPrintJob Failed');
Exit;
end;
end;
end.
Как изменить размер страницы при печати.
Один из способов, это перед началом печати изменить структуру devicemode у принтера. Другие настройки, которые можно поменять, смотрите в TDEVMODE в хелпе Delphi 1.02 или DEVMODE в Delphi 2.01.Следующий пример демонстрирует изменение размера печатаемой страницы:
procedure TForm1.Button1Click(Sender: TObject);
var
Device: array[0..255] of char;
Driver: array[0..255] of char;
Port: array[0..255] of char;
hDMode: THandle;
PDMode: PDEVMODE;
begin
Printer.PrinterIndex := Printer.PrinterIndex;
Printer.GetPrinter(Device, Driver, Port, hDMode);
if hDMode <> 0 then begin
pDMode := GlobalLock(hDMode);
if pDMode <> nil then begin
{Set to legal}
pDMode^.dmFields := pDMode^.dmFields or dm_PaperSize;
pDMode^.dmPaperSize := DMPAPER_LEGAL;
{Set to custom size}
pDMode^.dmFields := pDMode^.dmFields or
DM_PAPERSIZE or
DM_PAPERWIDTH or
DM_PAPERLENGTH;
pDMode^.dmPaperSize := DMPAPER_USER;
pDMode^.dmPaperWidth := 100 {SomeValueInTenthsOfAMillimeter};
pDMode^.dmPaperLength := 100 {SomeValueInTenthsOfAMillimeter};
{Set the bin to use}
pDMode^.dmFields := pDMode^.dmFields or DMBIN_MANUAL;
pDMode^.dmDefaultSource := DMBIN_MANUAL;
GlobalUnlock(hDMode);
end;
end;
Printer.PrinterIndex := Printer.PrinterIndex;
Printer.BeginDoc;
Printer.Canvas.TextOut(100, 100, 'Test 1');
Printer.EndDoc;
end;
|
Распечатать только выделенный в TRichEdit текст.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
uses
Richedit;
procedure TForm1.Button1Click(Sender: TObject);
var
printarea: TRect;
richedit_outputarea: TRect;
printresX, printresY: Integer;
fmtRange: TFormatRange;
nextChar: Integer;
S: string;
begin
Printer.BeginDoc;
try
with Printer.Canvas do
begin
printresX := GetDeviceCaps(Handle, LOGPIXELSX);
printresY := GetDeviceCaps(Handle, LOGPIXELSY);
printarea :=
Rect(printresX, // 1 inch left margin
printresY * 3 div 2, // 1.5 inch top margin
Printer.PageWidth - printresX, // 1 inch right margin
Printer.PageHeight - printresY * 3 div 2 // 1.5 inch
Bottom Margin);
// Define a rectangle for the rich edit text. The height is set
to the
// maximum. But we need to convert from device units to twips,
// 1 twip = 1/1440 inch or 1/20 point.
richedit_outputarea :=
Rect(printarea.Left * 1440 div printresX,
printarea.Top * 1440 div printresY,
printarea.Right * 1440 div printresX,
printarea.Bottom * 1440 div printresY);
// Tell rich edit to format its text to the printer. First set
// up data record for message:
fmtRange.hDC := Handle; // printer handle
fmtRange.hdcTarget := Handle; // ditto
fmtRange.rc := richedit_outputarea;
fmtRange.rcPage := Rect(0, 0,
Printer.PageWidth * 1440 div printresX,
Printer.PageHeight * 1440 div printresY);
// set range of characters to print to selection
fmtRange.chrg.cpMin := richedit1.selstart;
fmtRange.chrg.cpMax := richedit1.selStart + richedit1.sellength - 1;
// remove characters that need not be printed from end of
selection.
// failing to do so screws up the repeat loop below.
S := Richedit1.SelText;
while (fmtRange.chrg.cpMax > 0) and
(S[fmtRange.chrg.cpMax] <= ' ') do Dec(fmtRange.chrg.cpMax);
repeat
// Render the text
nextChar := richedit1.Perform(EM_FORMATRANGE, 1, Longint(@fmtRange));
if nextchar < fmtRange.chrg.cpMax then
begin
// more text to print
printer.newPage;
fmtRange.chrg.cpMin := nextChar;
end; { If }
until nextchar >= fmtRange.chrg.cpMax;
// Free cached information
Richedit1.Perform(EM_FORMATRANGE, 0, 0);
end;
finally
Printer.EndDoc;
end;
end;
{
The richedit1.perform( EM_FORMATRANGE call returns the index of the
last character that could be fitted into the passed fmtrange.rc, + 1.
So if multiple pages are required one repeats with fmtrange.chrg.cpMin
set to this value, until all characters have been printed.
}
Печать повернутого текста.
procedure AngleTextOut(CV: TCanvas; const sText:
string; x, y, angle: integer);
var
LogFont: TLogFont;
SaveFont: TFont;
begin
SaveFont := TFont.Create;
SaveFont.Assign(CV.Font);
GetObject(SaveFont.Handle, sizeof(TLogFont), @LogFont);
with LogFont do
begin
lfEscapement := angle * 10;
lfPitchAndFamily := FIXED_PITCH or FF_DONTCARE;
end; {with}
CV.Font.Handle := CreateFontIndirect(LogFont);
SetBkMode(CV.Handle, TRANSPARENT);
CV.TextOut(x, y, sText);
CV.Font.Assign(SaveFont);
SaveFont.Free;
end;
|
Печать повернутого текста 2.
procedure TextOutVertical(var bitmap: TBitmap; x, y: Integer; s: string);
var
b1, b2: TBitmap;
i, j: Integer;
begin
with bitmap.Canvas do
begin
b1 := TBitmap.Create;
b1.Canvas.Font := lpYhFont;
b1.Width := TextWidth(s) + 1;
b1.Height := TextHeight(s) + 1;
b1.Canvas.TextOut(1, 1, s);
b2 := TPackedBitmap.Create;
b2.Width := TextHeight(s);
b2.Height := TextWidth(s);
for i := 0 to b1.Width - 1 do
for j := 0 to b1.Height do
b2.Canvas.Pixels[j, b2.Height + 1 - i] := b1.Canvas.Pixels[i, j];
Draw(x, y, b2);
b1.Free;
b2.Free;
end
end;
|
Печать повернутого текста 3.
Некоторое время я делал так: я создавал шрифт, выбирал его в DC ...
function CreateMyFont(degree: Integer): HFONT; begin CreateMyFont := CreateFont( -30, 0, degree, 0, 0, 0, 0, 0, 1, OUT_TT_PRECIS, 0, 0, 0, szFontName); end; |
.... и затем использовал любую функцию рисования для вывода текста.
Печать повернутого текста 4.
Приведенное выше решение (1) очень медленно, так как требует рисования текста и содержит, на мой взгляд, неэффективный метод вращения. Попробуйте взамен это:
procedure TForm1.TextUp(aRect:tRect;aTxt:String); var LFont: TLogFont; hOldFont, hNewFont: HFont; begin GetObject(Canvas.Font.Handle,SizeOf(LFont),Addr(LFont)); LFont.lfEscapement := 900; hNewFont := CreateFontIndirect(LFont); hOldFont := SelectObject(Canvas.Handle,hNewFont); Canvas.TextOut(aRect.Left+2,aRect.Top,aTxt); hNewFont := SelectObject(Canvas.Handle,hOldFont); DeleteObject(hNewFont); end; |
Размер полей при печати.
Мне необходимо получить значения (лево, право, верх, низ) "непечатаемой области" принтера. Из статьи Delphi Developer "Take Control of your printer with a custom Delphi Class":Чтобы получить левое и верхнее поле принтера, используйте Windows Escape функцию с параметром GETPRINTINGOFFSET.
var
pntMargins: TPoint;
begin
{ @ означает " адрес переменной" }
Escape(Printer.Handle, GETPRINTINGOFFSET,0,nil,@prntMargins);
end;
|
Получить размер правого и нижнего поля не так просто. Просто не существует необходимого эквивалента при вызове Escape функции. Но вы можете узнать эти значения, получив физическую ширину (physWidth) и высоту (physHeight) бумаги, печатаемую ширину (PrintWidth) и высоту (PrintHeight) страницы и выполнив несложные арифметические операции:
RightMargin := physWidth - PrintWidth - LeftMargin; BottomMargin := physHeight - PrintHeight - TopMargin; |
Физический размер страницы можно получить с помощью Escape-функции, но на этот раз с использованием параметра GETPHYSPAGESIZE. Указатель pntPageSize содержит ширину страницы в pntPageSize.x и ее высоту в pntPageSize.y.
var pntPageSize: TPoint; begin Escape(Printer.Handle, GETPHYSPAGESIZE,o,nil,@pntPageSize); end; |
Печать через спулер на матричный принтер.
Автор: Оргиш АлександрПечатаю через спулер на матричный принтер текст таким образом :
var
pcbNeeded: DWORD;
FDevice: PChar;
FPort: PChar;
FDriver: PChar;
FPrinterHandle: THandle;
FDeviceMode: THandle;
FJob: PADDJOBINFO1;
Stream: TFileStream;
begin
GetMem(FDevice, 128);
GetMem(FDriver, 128);
GetMem(FPort, 128);
Printer.GetPrinter(FDevice, FDriver, FPort, FDeviceMode);
if FDeviceMode = 0 then
Printer.GetPrinter(FDevice, FDriver, FPort, FDeviceMode);
if OpenPrinter(FDevice, FPrinterHandle, nil) then
begin
GetMem(FJob, 1024);
//Добавляем задание, получаем имя файла в директории windows\spoool\
AddJob(FPrinterHandle, 1, FJob, 1024, pcbNeeded);
Stream := TFileStream.Create(FJob.Path, fmCreate);
// Дальше пишем текст (+ESC команды!!!!) прямо в Stream
// и не забываем переводить в DOS - кодировку
.........
Stream.Free;
//Постановка задания в очередь - только теперь принтер начинает печатать
ScheduleJob(FPrinterHandle, FJob.JobID);
FreeMem(FJob);
ClosePrinter(FPrinterHandle);
end;
FreeMem(FDevice, 128);
FreeMem(FDriver, 128);
FreeMem(FPort, 128);
end;
|
Печать StringGrid.
| Прибыли ламеры? Сажайте в камеры! |
procedure TForm1.Button1Click(Sender: TObject);
var K: Double;
begin
Printer.BeginDoc;
K := Printer.Canvas.Font.PixelsPerInch / Canvas.Font.PixelsPerInch*1.2;
PrintStringGrid(StrGrid,
K, // Коэффициент
200, // отступ от края листа в пихелах по Х
200, // --"-- по Y
200 // отступ снизу
);
Printer.EndDoc;
end;
{----------------------------------------------------------}
unit GrdPrn3;
interface
uses
Windows, Classes, Graphics, Grids, Printers, SysUtils;
const
OrdinaryLineWidth: Integer = 2;
BoldLineWidth: Integer = 4;
procedure PrintStringGrid(Grid: TStringGrid; Scale: Double; LeftMargin,
TopMargin, BottomMargin:
Integer);
function DrawStringGridEx(Grid: TStringGrid; Scale: Double; FromRow,
LeftMargin, TopMargin, Yfloor: Integer; DestCanvas: TCanvas): Integer;
// возвращает номер строки, которая не поместилась до Y = Yfloor
// не проверяет, вылезает ли общая длина таблицы за пределы страницы
// Слишком длинное слово обрежется
implementation
procedure PrintStringGrid(Grid: TStringGrid; Scale: Double; LeftMargin,
TopMargin, BottomMargin: Integer);
var NextRow: Integer;
begin
//Printer.BeginDoc;
if not Printer.Printing then raise Exception.Create('function
PrintStringGrid must be called between Printer.BeginDoc
and Printer.EndDoc');
NextRow := 0;
repeat
NextRow := DrawStringGridEx(Grid, Scale, NextRow, LeftMargin, TopMargin,
Printer.PageHeight - BottomMargin, Printer.Canvas);
if NextRow <> -1 then Printer.NewPage;
until NextRow = -1;
//Printer.EndDoc;
end;
function DrawStringGridEx(Grid: TStringGrid; Scale: Double; FromRow,
LeftMargin, TopMargin, Yfloor: Integer; DestCanvas: TCanvas): Integer;
// возвращает номер строки, которая не поместилась до Y = Yfloor
var
i, j, d, TotalPrevH, TotalPrevW, CellH, CellW, LineWidth: Integer;
R: TRect;
s: string;
procedure CorrectCellHeight(ARow: Integer);
// вычисление правильной высоты ячейки с учетом многострочного текста
// Текст рабивается только по словам слишком длинное слово обрубается
var
i, H: Integer;
R: TRect;
s: string;
begin
R := Rect(0, 0, CellH*2, CellH);
s := ':)'; // Одинарная высота строки
CellH := DrawText(DestCanvas.Handle, PChar(s), Length(s), R,
DT_LEFT or DT_TOP or DT_WORDBREAK or DT_SINGLELINE or
DT_NOPREFIX or DT_CALCRECT) + 3*d;
for i := 0 to Grid.ColCount-1 do
begin
CellW := Round(Grid.ColWidths[i]*Scale);
R := Rect(0, 0, CellW, CellH);
//InflateRect(R, -d, -d);
R.Left := R.Left+d;
R.Top := R.Top + d;
s := Grid.Cells[i, ARow];
// Вычисление ширины и высоты
H := DrawText(DestCanvas.Handle, PChar(s), Length(s), R,
DT_LEFT or DT_TOP or DT_WORDBREAK or DT_NOPREFIX or DT_CALCRECT);
текста
if CellH < H + 2*d then CellH := H + 2*d;
// if CellW < R.Right - R.Left then Слишком длинное слово -
// не помещается в одну строку; Перенос слов не поддерживается
end;
end;
begin
Result := -1; // все строки уместились между TopMargin и Yfloor
if (FromRow < 0)or(FromRow >= Grid.RowCount) then Exit;
DestCanvas.Brush.Style := bsClear;
DestCanvas.Font := Grid.Font;
// DestCanvas.Font.Height := Round(Grid.Font.Height*Scale);
DestCanvas.Font.Size := 10;
Grid.Canvas.Font := Grid.Font;
Scale := DestCanvas.TextWidth('test')/Grid.Canvas.TextWidth('test');
d := Round(2*Scale);
TotalPrevH := 0;
for j := 0 to Grid.RowCount-1 do
begin
if (j >= Grid.FixedRows) and (j < FromRow) then Continue;
// Fixed Rows рисуются на каждой странице
TotalPrevW := 0;
CellH := Round(Grid.RowHeights[j]*Scale);
CorrectCellHeight(j);
if TopMargin + TotalPrevH + CellH > YFloor then
begin
Result := j; // j-я строка не помещается в заданный диапазон
if Result < Grid.FixedRows then Result := -1;
// если фиксированные строки не влезают на страницу -
// это тяж¸лый случай...
Exit;
end;
for i := 0 to Grid.ColCount-1 do
begin
CellW := Round(Grid.ColWidths[i]*Scale);
R := Rect(TotalPrevW, TotalPrevH, TotalPrevW + CellW,
otalPrevH + CellH);
OffSetRect(R, LeftMargin, TopMargin);
if (i < Grid.FixedCols)or(j < Grid.FixedRows) then
LineWidth := BoldLineWidth
else
LineWidth := OrdinaryLineWidth;
DestCanvas.Pen.Width := LineWidth;
if LineWidth > 0 then
DestCanvas.Rectangle(R.Left, R.Top, R.Right+1, R.Bottom+1);
//InflateRect(R, -d, -d);
R.Left := R.Left+d;
R.Top := R.Top + d;
s := Grid.Cells[i, j];
DrawText(DestCanvas.Handle, PChar(s), Length(s), R,
DT_LEFT or DT_TOP or DT_WORDBREAK or DT_NOPREFIX);
TotalPrevW := TotalPrevW + CellW; // Общая ширина всех предыдущих колонок
end;
TotalPrevH := TotalPrevH + CellH; // Общая высота всех предыдущих строк
end;
end;
end.
|
Печать TMemo, TStringList или TStrings.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{
The following example project
shows how to print a memos lines, but you can as well use
listbox.items, it will work with every TStrings descendent, even a
TStirnglist.
}
unit PrintStringsUnit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
Memo1: TMemo;
Button1: TButton;
procedure Button1Click(Sender : TObject);
private
{ Private declarations }
procedure PrintHeader(aCanvas : TCanvas; aPageCount : integer;
aTextrect : TRect; var Continue : boolean);
procedure PrintFooter(aCanvas : TCanvas; aPageCount : integer;
aTextrect : TRect; var Continue : boolean);
public
{ Public declarations }
end;
var
Form1 : TForm1;
implementation
uses Printers;
{$R *.DFM}
type
THeaderFooterProc =
procedure(aCanvas : TCanvas; aPageCount : integer;
aTextrect : TRect; var Continue : boolean) of object;
{ Prototype for a callback method that PrintString will call
when it is time to print a header or footer on a page. The
parameters that will be passed to the callback are:
aCanvas : the canvas to output on
aPageCount: page number of the current page, counting from 1
aTextRect : output rectangle that should be used. This will be
the area available between non-printable margin and
top or bottom margin, in device units (dots). Output
is not restricted to this area, though.
continue : will be passed in as True. If the callback sets it
to false the print job will be aborted. }
{+------------------------------------------------------------
| Function PrintStrings
|
| Parameters :
| lines:
| contains the text to print, already formatted into
| lines of suitable length. No additional wordwrapping
| will be done by this routine and also no text clipping
| on the right margin!
| leftmargin, topmargin, rightmargin, bottommargin:
| define the print area. Unit is inches, the margins are
| measured from the edge of the paper, not the printable
| area, and are positive values! The margin will be adjusted
| if it lies outside the printable area.
| linesPerInch:
| used to calculate the line spacing independent of font
| size.
| aFont:
| font to use for printout, must not be Nil.
| measureonly:
| If true the routine will only count pages and not produce any
| output on the printer. Set this parameter to false to actually
| print the text.
| OnPrintheader:
| can be Nil. Callback that will be called after a new page has
| been started but before any text has been output on that page.
| The callback should be used to print a header and/or a watermark
| on the page.
| OnPrintfooter:
| can be Nil. Callback that will be called after all text for one
| page has been printed, before a new page is started. The callback
| should be used to print a footer on the page.
| Returns:
| number of pages printed. If the job has been aborted the return
| value will be 0.
| Description:
| Uses the Canvas.TextOut function to perform text output in
| the rectangle defined by the margins. The text can span
| multiple pages.
| Nomenclature:
| Paper coordinates are relative to the upper left corner of the
| physical page, canvas coordinates (as used by Delphis Printer.Canvas)
| are relative to the upper left corner of the printable area. The
| printorigin variable below holds the origin of the canvas coordinate
| system in paper coordinates. Units for both systems are printer
| dots, the printers device unit, the unit for resolution is dots
| per inch (dpi).
| Error Conditions:
| A valid font is required. Margins that are outside the printable
| area will be corrected, invalid margins will raise an EPrinter
| exception.
| Created: 13.05.99 by P. Below
+------------------------------------------------------------}
function PrintStrings(Lines : TStrings;
const leftmargin, rightmargin,
topmargin, bottommargin: single;
const linesPerInch: single;
aFont: TFont;
measureonly: Boolean;
OnPrintheader,
OnPrintfooter: THeaderFooterProc): Integer;
var
continuePrint: Boolean; { continue/abort flag for callbacks }
pagecount: Integer; { number of current page }
textrect: TRect; { output area, in canvas coordinates }
headerrect: TRect; { area for header, in canvas
coordinates }
footerrect: TRect; { area for footes, in canvas
coordinates }
lineheight: Integer; { line spacing in dots }
charheight: Integer; { font height in dots }
textstart: Integer; { index of first line to print on
current page, 0-based. }
{ Calculate text output and header/footer rectangles. }
procedure CalcPrintRects;
var
X_resolution : Integer; { horizontal printer resolution, in dpi }
Y_resolution : Integer; { vertical printer resolution, in dpi }
pagerect : TRect; { total page, in paper coordinates }
printorigin : TPoint; { origin of canvas coordinate system in
paper coordinates. }
{ Get resolution, paper size and non-printable margin from
printer driver. }
procedure GetPrinterParameters;
begin
with Printer.Canvas do
begin
X_resolution := GetDeviceCaps(Handle, LOGPIXELSX);
Y_resolution := GetDeviceCaps(Handle, LOGPIXELSY);
printorigin.X := GetDeviceCaps(Handle, PHYSICALOFFSETX);
printorigin.Y := GetDeviceCaps(Handle, PHYSICALOFFSETY);
pagerect.Left := 0;
pagerect.Right := GetDeviceCaps(Handle, PHYSICALWIDTH);
pagerect.Top := 0;
pagerect.Bottom := GetDeviceCaps(Handle, PHYSICALHEIGHT);
end; { With }
end; { GetPrinterParameters }
{ Calculate area between the requested margins, paper-relative.
Adjust margins if they fall outside the printable area.
Validate the margins, raise EPrinter exception if no text area
is left. }
procedure CalcRects;
var
max : integer;
begin
with textrect do
begin
{ Figure textrect in paper coordinates }
Left := Round(leftmargin * X_resolution);
if Left < printorigin.x then
Left := printorigin.x;
Top := Round(topmargin * Y_resolution);
if Top < printorigin.y then
Top := printorigin.y;
{ Printer.PageWidth and PageHeight return the size of the
printable area, we need to add the printorigin to get the
edge of the printable area in paper coordinates. }
Right := pagerect.Right - Round(rightmargin * X_resolution);
max := Printer.PageWidth + printorigin.X;
if Right > max then
Right := max;
Bottom := pagerect.Bottom - Round(bottommargin *
Y_resolution);
max := Printer.PageHeight + printorigin.Y;
if Bottom > max then
Bottom := max;
{ Validate the margins. }
if (Left >= Right) or (Top >= Bottom) then
raise EPrinter.Create('PrintString: the supplied margins are too large, there'
+
'is no area to print left on the page.');
end; { With }
{ Convert textrect to canvas coordinates. }
OffsetRect(textrect, - printorigin.X, - printorigin.Y);
{ Build header and footer rects. }
headerrect := Rect(textrect.Left, 0,
textrect.Right, textrect.Top);
footerrect := Rect(textrect.Left, textrect.Bottom,
textrect.Right, Printer.PageHeight);
end; { CalcRects }
begin { CalcPrintRects }
GetPrinterParameters;
CalcRects;
lineheight := round(Y_resolution / linesPerInch);
end; { CalcPrintRects }
{ Print a page with headers and footers. }
procedure PrintPage;
procedure FireHeaderFooterEvent(event : THeaderFooterProc; r : TRect);
begin
if Assigned(event) then
begin
event(Printer.Canvas,
pagecount,
r,
ContinuePrint);
{ Revert to our font, in case event handler changed
it. }
Printer.Canvas.Font := aFont;
end; { If }
end; { FireHeaderFooterEvent }
procedure DoHeader;
begin
FireHeaderFooterEvent(OnPrintHeader, headerrect);
end; { DoHeader }
procedure DoFooter;
begin
FireHeaderFooterEvent(OnPrintFooter, footerrect);
end; { DoFooter }
procedure DoPage;
var
y : integer;
begin
y := textrect.Top;
while (textStart < Lines.Count) and
(y <= (textrect.Bottom - charheight)) do
begin
{ Note: use TextRect instead of TextOut to effect clipping
of the line on the right margin. It is a bit slower,
though. The clipping rect would be
Rect( textrect.left, y, textrect.right, y+charheight). }
printer.Canvas.TextOut(textrect.Left, y, Lines[textStart]);
Inc(textStart);
Inc(y, lineheight);
end; { While }
end; { DoPage }
begin { PrintPage }
DoHeader;
if ContinuePrint then
begin
DoPage;
DoFooter;
if (textStart < Lines.Count) and ContinuePrint then
begin
Inc(pagecount);
Printer.NewPage;
end; { If }
end;
end; { PrintPage }
begin { PrintStrings }
Assert(Assigned(afont),
'PrintString: requires a valid aFont parameter!');
continuePrint := True;
pagecount := 1;
textstart := 0;
Printer.BeginDoc;
try
CalcPrintRects;
{$IFNDEF WIN32}
{ Fix for Delphi 1 bug. }
Printer.Canvas.Font.PixelsPerInch := Y_resolution;
{$ENDIF }
Printer.Canvas.Font := aFont;
charheight := printer.Canvas.TextHeight('Ду');
while (textstart < Lines.Count) and ContinuePrint do
PrintPage;
finally
if continuePrint and not measureonly then
Printer.EndDoc
else
begin
Printer.Abort;
end;
end;
if continuePrint then
Result := pagecount
else
Result := 0;
end; { PrintStrings }
procedure TForm1.Button1Click(Sender : TObject);
begin
ShowMessage(Format('%d pages printed',
[PrintStrings(memo1.Lines,
0.75, 0.5, 0.75, 1,
6,
memo1.Font,
False,
PrintHeader, PrintFooter)
]));
end;
procedure TForm1.PrintFooter(aCanvas : TCanvas; aPageCount : integer;
aTextrect : TRect; var Continue : boolean);
var
S: string;
res: integer;
begin
with aCanvas do
begin
{ Draw a gray line one point wide below the text }
res := GetDeviceCaps(Handle, LOGPIXELSY);
pen.Style := psSolid;
pen.Color := clGray;
pen.Width := Round(res / 72);
MoveTo(aTextRect.Left, aTextRect.Top);
LineTo(aTextRect.Right, aTextRect.Top);
{ Print the page number in Arial 8pt, gray, on right side of
footer rect. }
S := Format('Page %d', [aPageCount]);
Font.Name := 'Arial';
Font.Size := 8;
Font.Color := clGray;
TextOut(aTextRect.Right - TextWidth(S), aTextRect.Top + res div
18,
S);
end;
end;
procedure TForm1.PrintHeader(aCanvas : TCanvas; aPageCount : integer;
aTextrect : TRect; var Continue : boolean);
var
res: Integer;
begin
with aCanvas do
begin
{ Draw a gray line one point wide 4 points above the text }
res := GetDeviceCaps(Handle, LOGPIXELSY);
pen.Style := psSolid;
pen.Color := clGray;
pen.Width := Round(res / 72);
MoveTo(aTextRect.Left, aTextRect.Bottom - res div 18);
LineTo(aTextRect.Right, aTextRect.Bottom - res div 18);
{ Print the company name in Arial 8pt, gray, on left side of
footer rect. }
Font.Name := 'Arial';
Font.Size := 8;
Font.Color := clGray;
TextOut(aTextRect.Left, aTextRect.Bottom - res div 10 -
TextHeight('W'),
'W. W. Shyster & Cie.');
end;
end;
end.
Как определить количество заданий на печать.
Автор: Олег КулабуховWindows передает WM_SPOOLERSTATUS каждый раз, когда добавляется или удаляется задание на печать. В примере мы попытаемся перехватывать это сообщение.
type
TForm1 = class(TForm)
Label1: TLabel;
private
{ Private declarations }
procedure WM_SpoolerStatus(var Msg: TWMSPOOLERSTATUS);
message WM_SPOOLERSTATUS;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.WM_SpoolerStatus(var Msg: TWMSPOOLERSTATUS);
begin
Lable1.Caption := IntToStr(msg.JobsLeft) +
' Jobs currenly in spooler';
msg.Result := 0;
end;
|
Распечатать текст.
var F: TextFile; begin AssignFile(F, 'LPT1'); // LPT2, COM1, COM2... Rewrite(F); Writeln(F, 'Hello'); Writeln(F, 'There!'); Writeln(F, #12); CloseFile(F); end; |
Сброс на печать текстового файла.
Используйте CreateFile для получения дескриптора LPT1.
LPTHandle := CreateFile( 'LPT1',GENERIC_WRITE, 0, PSecurityAttributes(nil), OPEN_EXISTING, FILE_FLAG_OVERLAPPED, 0); |
Затем используйте WriteFile для посылки строки символов или сделайте так:
While not TransmitCommChar( LPTHandle, CharToSend ) do Application.ProcessMessages; |
Этим вы перешлете в параллельный порт строчку символов. Для обработки код ждет последний символ, после чего немедленно посылает новый. Метод на поверку оказался весьма быстр.
Вывод текста на печать, используя com порт.
| Сели в машину, компьютерщик, новый русский и слесарь. Заводят - не заводится. Слесарь говорит: - Сейчас я гляну, что случилось, все сделаю - и поедем. Новый русский говорит: - Сиди, я сейчас по сотовому позвоню, приедет бригада мастеров и все быстро сделает. А компьютерщик говорит: - Может, все выйдем из машины и снова зайдём? |
var
Printer: THandle;
N : Cardinal;
C : POverlapped;
begin
//Открываем порт принтера для записи
Printer := CreateFile(PChar('LPT1'),
GENERIC_READ or GENERIC_WRITE, 0, nil,
OPEN_EXISTING, FILE_FLAG_OVERLAPPED, 0);
//Печатаем слово 'Hello World';
WriteFile(Printer, 'Hello World', 11, N, c);
//Закрываем порт
CloseHandle(Printer);
|
Распечатать TImage.
{1.}
uses
printers;
procedure TForm1.Button1Click(Sender: TObject);
var
ScaleX, ScaleY: Integer;
RR: TRect;
begin
with Printer do
begin
BeginDoc;
// Mit BeginDoc wird ein Druckauftrag initiiert.
// The StartDoc function starts a print job.
try
ScaleX := GetDeviceCaps(Handle, logPixelsX) div PixelsPerInch;
ScaleY := GetDeviceCaps(Handle, logPixelsY) div PixelsPerInch;
// Informationen uber die Auflosung
// Retrieves information about the Pixels per Inch of the Printer.
RR := Rect(0, 0, Image1.picture.Width * scaleX, Image1.Picture.Height * ScaleY);
Canvas.StretchDraw(RR, Image1.Picture.Graphic);
// An die Auflosung anpassen
// Stretch to fit
finally
EndDoc; //Methode EndDoc beendet den aktuellen Druckauftrag und schlie?t die
// Textdatei-Variable.
// Steht in finally - um auch bei Abbruch des Druckauftrages Papierausgabe
// sicherzustellen
end;
end;
end;
{2.}
// Based on posting to borland.public.delphi.winapi by Rodney E Geraghty, 8/8/97.
procedure PrintBitmap(Canvas: TCanvas; DestRect: TRect; Bitmap: TBitmap);
var
BitmapHeader: pBitmapInfo;
BitmapImage: Pointer;
HeaderSize: DWORD;
ImageSize: DWORD;
begin
GetDIBSizes(Bitmap.Handle, HeaderSize, ImageSize);
GetMem(BitmapHeader, HeaderSize);
GetMem(BitmapImage, ImageSize);
try
GetDIB(Bitmap.Handle, Bitmap.Palette, BitmapHeader^, BitmapImage^);
StretchDIBits(Canvas.Handle,
DestRect.Left, DestRect.Top, // Destination Origin
DestRect.Right - DestRect.Left, // Destination Width
DestRect.Bottom - DestRect.Top, // Destination Height
0, 0, // Source Origin
Bitmap.Width, Bitmap.Height, // Source Width & Height
BitmapImage,
TBitmapInfo(BitmapHeader^),
DIB_RGB_COLORS,
SRCCOPY)
finally
FreeMem(BitmapHeader);
FreeMem(BitmapImage)
end
end {PrintBitmap};
|
Распечатать TImage 2.
Автор: http://www.experts-exchange.com
uses
printers;
procedure DrawImage(Canvas: TCanvas; DestRect: TRect; ABitmap: TBitmap);
var
Header, Bits: Pointer;
HeaderSize: DWORD;
BitsSize: DWORD;
begin
GetDIBSizes(ABitmap.Handle, HeaderSize, BitsSize);
Header := AllocMem(HeaderSize);
Bits := AllocMem(BitsSize);
try
GetDIB(ABitmap.Handle, ABitmap.Palette, Header^, Bits^);
StretchDIBits(Canvas.Handle, DestRect.Left, DestRect.Top,
DestRect.Right, DestRect.Bottom,
0, 0, ABitmap.Width, ABitmap.Height, Bits, TBitmapInfo(Header^),
DIB_RGB_COLORS, SRCCOPY);
finally
FreeMem(Header, HeaderSize);
FreeMem(Bits, BitsSize);
end;
end;
procedure PrintImage(Image: TImage; ZoomPercent: Integer);
// if ZoomPercent=100, Image will be printed across the whole page
var
relHeight, relWidth: integer;
begin
Screen.Cursor := crHourglass;
Printer.BeginDoc;
with Image.Picture.Bitmap do
begin
if ((Width / Height) > (Printer.PageWidth / Printer.PageHeight)) then
begin
// Stretch Bitmap to width of PrinterPage
relWidth := Printer.PageWidth;
relHeight := MulDiv(Height, Printer.PageWidth, Width);
end
else
begin
// Stretch Bitmap to height of PrinterPage
relWidth := MulDiv(Width, Printer.PageHeight, Height);
relHeight := Printer.PageHeight;
end;
relWidth := Round(relWidth * ZoomPercent / 100);
relHeight := Round(relHeight * ZoomPercent / 100);
DrawImage(Printer.Canvas, Rect(0, 0, relWidth, relHeight),
Image.Picture.Bitmap);
end;
Printer.EndDoc;
Screen.cursor := crDefault;
end;
// Example Call:
procedure TForm1.Button1Click(Sender: TObject);
begin
// Print image at 40% zoom:
PrintImage(Image1, 40);
end;
Реализация команды PrintTo.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
uses
Printers, Shellapi;
procedure TForm1.Button1Click(Sender: TObject);
var
Device: array[0..255] of Char;
Driver: array[0..255] of Char;
Port: array[0..255] of Char;
S: string;
hDeviceMode: THandle;
documentname: string;
begin
Printer.PrinterIndex := -1; // select a printer, in this case default
Printer.GetPrinter(Device, Driver, Port, hDeviceMode);
S := Format('"%s" "%s" "%s"', [Device, Driver, Port]);
documentname := 'c:\anydocument.doc';
ShellExecute(Handle, 'printto', PChar(documentname), PChar(S), nil, SW_HIDE);
end;
Печать Dos-файла в порт напрямую.
Автор: http://blackman.wp-club.net При печати Dos-файла в порт напрямую можно это сделать.Например, напечатать за 2 прохода: ESC @ - инициализация принтера ESC G - включение режима печати за 2 прохода ESC H - выключение режима печати за 2 прохода.
var
FileOut: TextFile;
filename: string[128];
....
Filename := 'PRN';
AssignFile(Fileout, Filename);
...
Write(FileOut, Chr(27) + '@');
Str1 := AnToAs(chr(27) + 'G' + 'Double' + chr(27) + 'H');
Writeln(FileOut, Str1);
...
{преобразование Ansi to Ascii}
function AnToAs(s: string): string;
var
i, kod: Integer;
begin
Result := s;
for i := 1 to length(s) do
begin
kod := Ord(s[i]);
if kod 13 then
Result[i] := ' ';
if (kod >= 192) and (kod = 239) then
Result[i] := Chr(kod - 64);
if (kod >= 240) and (kod = 255) then
Result[i] := Chr(kod - 16);
if kod = 168 then
Result[i] := Chr(240);
if kod = 184 then
Result[i] := Chr(241);
end;
end;
Распечатать TStringList.
uses
Printers;
procedure PrintGrid(sGrid: TStringGrid; sTitle: string);
var
X1, X2: Integer;
Y1, Y2: Integer;
TmpI: Integer;
F: Integer;
TR: TRect;
begin
Printer.Title := sTitle;
Printer.BeginDoc;
Printer.Canvas.Pen.Color := 0;
Printer.Canvas.Font.Name := 'Times New Roman';
Printer.Canvas.Font.Size := 12;
Printer.Canvas.Font.Style := [fsBold, fsUnderline];
Printer.Canvas.TextOut(0, 100, Printer.Title);
for F := 1 to sGrid.ColCount - 1 do
begin
X1 := 0;
for TmpI := 1 to (F - 1) do
X1 := X1 + 5 * (sGrid.ColWidths[TmpI]);
Y1 := 300;
X2 := 0;
for TmpI := 1 to F do
X2 := X2 + 5 * (sGrid.ColWidths[TmpI]);
Y2 := 450;
TR := Rect(X1, Y1, X2 - 30, Y2);
Printer.Canvas.Font.Style := [fsBold];
Printer.Canvas.Font.Size := 7;
Printer.Canvas.TextRect(TR, X1 + 50, 350, sGrid.Cells[F, 0]);
Printer.Canvas.Font.Style := [];
for TmpI := 1 to sGrid.RowCount - 1 do
begin
Y1 := 150 * TmpI + 300;
Y2 := 150 * (TmpI + 1) + 300;
TR := Rect(X1, Y1, X2 - 30, Y2);
Printer.Canvas.TextRect(TR, X1 + 50, Y1 + 50, sGrid.Cells[F, TmpI]);
end;
end;
Printer.EndDoc;
end;
//Examplem, Beispiel:
procedure TForm1.Button1Click(Sender: TObject);
begin
PrintGrid(StringGrid1, 'Print Stringgrid');
end;
|
Распечатать TStrings на принтере по умолчанию.
procedure PrintStrings(S: TStrings; Font: TFont; Title: string);
var
LeftMargin, TopMargin, LineCoord, LineOnPage, LinesOnDoc,
CurrentLine, TextHeight, LinesPerPage, LineInterval: integer;
procedure StartDoc;
begin
LinesOnDoc := S.Count;
Printer.Canvas.Font.Assign(Font);
Printer.Canvas.TextOut(0, 0, ' ');
LeftMargin := (Printer.Canvas.Font.PixelsPerInch) div 2;
TopMargin := (Printer.Canvas.Font.PixelsPerInch) div 2;
TextHeight := Abs(Printer.Canvas.Font.Height);
LineInterval := TextHeight + (TextHeight div 2);
LinesPerPage := (Printer.PageHeight - TopMargin) div LineInterval;
CurrentLine := 0;
end;
function MorePages:boolean;
begin
Result := (CurrentLine < LinesOnDoc) and
not Printer.Aborted;
end;
procedure StartPage;
begin
LineOnPage := 0;
LineCoord := TopMargin;
end;
procedure NextPage;
begin
if MorePages then Printer.NewPage;
end;
function MoreLines:boolean;
begin
Result := (LineOnPage < LinesPerPage) and
(LineOnPage < LinesOnDoc) and
not Printer.Aborted;
end;
procedure NextLine;
begin
Inc(LineOnPage);
Inc(LineCoord, LineInterval);
Inc(CurrentLine);
end;
procedure PrintLine;
begin
Printer.Canvas.TextOut(LeftMargin, LineCoord, S.Strings[CurrentLine]);
end;
begin
Printer.Title := Title;
Printer.BeginDoc;
StartDoc;
while MorePages do
begin
StartPage;
while MoreLines do
begin
PrintLine;
NextLine;
Application.ProcessMessages;
end;
NextPage;
end;
Printer.EndDoc;
end;
|
Показать диалог печати и распечатать текстовый файл.
unit Unit1;
interface
uses
{...,}ComCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
PrintDialog1: TPrintDialog;
RichEdit1: TRichEdit;
procedure Button1Click(Sender: TObject);
{...}
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
begin
if PrintDialog1.Execute then
Richedit1.Print('Ltp1'); {Ltp1, Lpt2 are printers}
end;
end.
|
Как распечатать WEB страничку при помощи HTML контрола.
| Ну и почерк у тебя, Xerox! |
Можно использовать два метода HTML контрола: AutoPrint или PrintPage.
Пример использования AutoPrint:
uses
Printers;
procedure TForm1.Button1Click(Sender: TObject);
var
OldCur: TCursor;
begin
OldCur := Screen.Cursor;
with Printer do
begin
BeginDoc;
HTML1.AutoPrint(handle);
Title := HTML1.URL;
EndDoc;
end;
Screen.Cursor := OldCur;
end;
|
Как печатать без TPrinter.
Автор: Олег КулабуховПример показывает, как использовать PrintDlg() для того, чтобы дать возможность пользователю выбрать принтер, и напечатать две страницы.
uses CommDlg;
{$IFNDEF WIN32}
const
MAX_PATH = 144;
{$ENDIF}
procedure TForm1.Button1Click(Sender: TObject);
var
Pd: TPrintDlg;
DocInfo: TDocInfo;
begin
FillChar(Pd, sizeof(Pd), #0);
Pd.lStructSize := sizeof(Pd);
Pd.hWndOwner := Form1.Handle;
Pd.Flags := PD_RETURNDC;
if PrintDlg(pd) then
begin
FillChar(DocInfo, sizeof(DocInfo), #0);
DocInfo.cbSize := SizeOf(DocInfo);
GetMem(DocInfo.lpszDocName, 32);
GetMem(DocInfo.lpszOutput, MAX_PATH);
lStrCpy(DocInfo.lpszDocName, 'My Document');
{Add this line to print to a file }
lStrCpy(DocInfo.lpszOutput, 'C:\Download\Test.doc');
StartDoc(Pd.hDc, DocInfo);
StartPage(Pd.hDc);
TextOut(Pd.hDc, 100, 100, 'Page 1', 6);
EndPage(Pd.hDc);
StartPage(Pd.hDc);
TextOut(Pd.hDc, 100, 100, 'Page 2', 6);
EndPage(Pd.hDc);
EndDoc(Pd.hDc);
FreeMem(DocInfo.lpszDocName, 32);
FreeMem(DocInfo.lpszOutput, MAX_PATH);
end;
end;
|
Как печатать в цвете.
| Более мощный компьютер глючит быстрее и точнее. |
Обычно нет необходимости переводить принтер в режим цветной печати, если он установлен в этот режим. Windows автоматически переведет цветную печать в черно-белую, если принтер не поддерживает цветной печати. Если Вам необходимо программно изменить режим цвета, Вы можете обратится к структуре DevMode драйвера принтера.
uses Printers;
procedure TForm1.Button1Click(Sender: TObject);
var
Device: array [0..255] of char;
Driver: array [0..255] of char;
Port: array [0..255] of char;
hDMode: THandle;
PDMode: PDEVMODE;
begin
with Printer do
begin
PrinterIndex := PrinterIndex;
GetPrinter(Device, Driver, Port, hDMode);
if hDMode <> 0 then
begin
pDMode := GlobalLock(hDMode);
if pDMode <> nil then
begin
pDMode.dmFields := pDMode.dmFields or dm_Color;
pDMode.dmColor := DMCOLOR_COLOR;
GlobalUnlock(hDMode);
end;
end;
PrinterIndex := PrinterIndex;
BeginDoc;
Canvas.Font.Color := clRed;
Canvas.TextOut(100,100, 'Delphi World is COOL :)');
EndDoc;
end;
end;
|
Как распечатать PRN файл.
Автор: http://www.swissdelphicenter.ch
uses
Printers, Winspool;
function SpoolFile(const FileName, PrinterName: string): Integer;
var
Buffer: record
JobInfo: record // ADDJOB_INFO_1
Path: PChar;
JobID: DWORD;
end;
PathBuffer: array[0..255] of Char;
end;
SizeNeeded: DWORD;
Handle: THandle;
PrtName: string;
ok: Boolean;
begin
// Flush job to printer
PrtName := PrinterName;
if PrtName = '' then
PrtName := Printer.Printers[Printer.PrinterIndex]; // Default printer name
ok := False;
if OpenPrinter(PChar(PrtName), Handle, nil) then
if AddJob(Handle, 1, @Buffer, SizeOf(Buffer), SizeNeeded) then
if CopyFile(PChar(FileName), Buffer.JobInfo.Path, True) then
if ScheduleJob(Handle, Buffer.JobInfo.JobID) then
ok := True;
if not ok then
Result := GetLastError
else
Result := 0;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if SpoolFile('c:\test.prn', Printer.Printers[0]) = 0 then
ShowMessage('No error...');
end;
Процедурные типы.
Основное назначение процедурных типов - дать программисту гибкие средства передачи функций и процедур в качестве фактических параметров обращения к другим процедурам и функциям.Для объявления процедурного типа используется заголовок процедуры (функции), в котором опускается ее имя, например:
type Proc1 = procedure(a, b, с: Real; var d: Real); Proc2 = procedure(var a, b); РгосЗ = procedure; Func1 = function: string; Func2 = function(var s: string): Real;Как видно из приведенных примеров, существует два процедурных типа: тип-процедура и тип-функция.
В следующий программе иллюстрируется механизм передачи процедур в качестве фактических параметров вызова. Программа выводит на экран таблицу двух функций: sin1 (х) = (sin(x) + 1) * Ехр(-х) и cosi(x) = (Cos(x) + 1) * Ехр(-х) . Вычисление и печать значений этих функций реализуются в процедуре printFunc, которой в качестве параметров передается количество np вычислений функции в диапазоне х от 0 до 2*3.141592 и имя нужной функции.
function Sinl(X: Real): Real;
begin
Result := (Sin(X) + 1) * Exp(-X)
end; // Sin 1
function Cosl(X: Real): Real;
begin
Result := (Cos(X) + 1) * Exp(-X)
end; // Cosi
procedure TfmExample.bbRunClick(Sender: TObject);
type
// Процедурный тип Procedure PrintFunc(NP: Integer; F; Func);
Func = function(X: Real): Real;
var
k: Integer;
X: Real;
begin
for k := 0 to NP do
begin
X := k * 2 * pi / NP;
mmOutput.Lines.Add(FloatToStrF(X, ffExponent, 10, 2) + #9#9+
FloatToStrF(F(X), ffExponent, 10, 2));
end;
end; // PrintFunc
begin // bbRunClick
nmiOutput.Lines.Add(#9'Функция SINI:');
PrintFunc(10, Sini);
mmOutput.Lines.Add(#9'Функция COSI:');
PrintFunc(10, Cosi);
end;
Обратите внимание: передаваемые подпрограммы не могут быть локальными, т. е. процедурами или функциями, объявленными внутри другой подпрограммы. Вот почему описание подпрогра^.' sini и cosi размещаются вне обработчика bbRunciick, но выше не." по тексту модуля. Замечу, что символ #9 - это символ табуляции. который вставляется в формируемые строки для разделения колонок с цифрами.
В программе могут быть объявлены переменные процедурных типов, например,так:
var p1: Proc1; fl, f2: Func2; ар: array[1..N] of Proc1;
Переменным процедурных типов допускается присваивать в качестве значений имена соответствующих подпрограмм. После такого присваивания имя переменной становится синонимом имени подпрограммы.
Unit с полезными функциями для работы с процессами.
Автор: Alex Kantchev WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Unit с полезными функциями для работы с процессами
Этот Unit содержит полезные функции для работы с процессами.
Взять информацию о данном процессе, обо всех процессах, убить процесс, и т.д.
Полезна при создании системных приложений под Win32.
Надо хорошо оттестировать этот Unit.
Зависимости: windows, PSAPI, TlHelp32, SysUtils;
Автор: Alex Kantchev, stoma@bitex.bg
Copyright: Моя разработка, некоторые функции базируются
на примере в MSDN jan 2000 Collection
Дата: 5 июня 2002 г.
***************************************************** }
unit ProcUtilz;
interface
uses windows, PSAPI, TlHelp32, SysUtils;
type
TLpModuleInfo = packed record
ModuleInfo: LPMODULEINFO;
ModulePID: Cardinal;
ModuleName: string;
end;
type
TLpModuleInfoArray = array of TLpModuleInfo;
function RegisterServiceProcess(dwProcessID, dwType: Integer): Integer; stdcall;
external 'KERNEL32.DLL';
function DisplayProcessInThreeFingerSalute(PID: Integer; Disp: Boolean):
Boolean;
function TakeProcessID(WindowTitle: string): Integer;
function GetCurrAppPID: Integer;
function GetAllProcessesInfo(ExtractFullPath: Boolean = false):
TLpModuleInfoArray;
function ExtractExeFromModName(ModuleName: string): string;
function TerminateTask(PID: integer): integer;
implementation
//Wziat PID na danoi process ot nego window title
function TakeProcessID(WindowTitle: string): Integer;
var
WH: THandle;
begin
result := 0;
WH := FindWindow(nil, pchar(WindowTitle));
if WH <> 0 then
GetWindowThreadProcessID(WH, @Result);
end;
//Wziat PID na tekuchii process
function GetCurrAppPID: Integer;
begin
GetCurrAppPID := GetCurrentProcessID;
end;
//Pokzat process s PID v task menagera Windows 9X
//WNIMANIE: Rabotaet tolko pod Win9x !!!!
function DisplayProcessInThreeFingerSalute(PID: Integer; Disp: Boolean):
Boolean;
begin
result := false;
if Win32Platform = VER_PLATFORM_WIN32_WINDOWS then
begin
try
if Disp = True then
RegisterServiceProcess(PID, 0)
else
RegisterServiceProcess(PID, 1);
except
result := false;
end;
end;
DisplayProcessInThreeFingerSalute := result;
end;
//Ostanavlivaet rabotu procesa. Ne rabotaet so WinNT
//serviznae processi.
function TerminateTask(PID: integer): integer;
var
process_handle: integer;
lpExitCode: Cardinal;
begin
process_handle := openprocess(PROCESS_ALL_ACCESS, true, pid);
GetExitCodeProcess(process_handle, lpExitCode);
if (process_handle = 0) then
TerminateTask := GetLastError
else if terminateprocess(process_handle, lpExitCode) then
begin
TerminateTask := 0;
CloseHandle(process_handle);
end
else
begin
TerminateTask := GetLastError;
CloseHandle(process_handle);
end;
end;
//Wziat informacia ob processse po ego PID
//Testirano pod WinNT.
function GetProcessInfo(PID: WORD): LPMODULEINFO;
var
RetVal: LPMODULEINFO;
hProc: DWORD;
hMod: HMODULE;
cm: cardinal;
begin
hProc := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, false,
PID);
GetMem(RetVal, sizeOf(LPMODULEINFO));
if not (hProc = 0) then
begin
EnumProcessModules(hProc, @hMod, 4, cm);
GetModuleInformation(hProc, hMod, RetVal, SizeOf(RetVal));
end;
GetProcessInfo := RetVal;
end;
//Wziat executable processa ot ego polnai put
function ExtractExeFromModName(ModuleName: string): string;
begin
ExtractExeFromModName := Copy(ModuleName, LastDelimiter('\', ModuleName) + 1,
Length(ModuleName));
;
end;
//Wziat informacia ob wse processi rabotaushtie w tekuchii
//moment. Testirano pod WinNT
function GetAllProcessesInfo(ExtractFullPath: Boolean = false):
TLpModuleInfoArray;
var
ProcList: array[0..$FFF] of DWORD;
RetVal: TLpModuleInfoArray;
ProcCnt: Cardinal;
I, MaxCnt: WORD;
ModName: array[0..max_path] of char;
ph, mh: THandle;
cm: Cardinal;
SnapShot: THandle;
ProcEntry: TProcessEntry32;
RetValLength, CVal: WORD;
ModInfo: LPMODULEINFO;
begin
//case the platform is Win9X
if Win32Platform = VER_PLATFORM_WIN32_WINDOWS then
begin
GetMem(ModInfo, SizeOf(LPMODULEINFO));
SnapShot := CreateToolhelp32Snapshot(th32cs_snapprocess, 0);
RetValLength := 0;
CVal := 0;
if not integer(SnapShot) = -1 then
begin
ProcEntry.dwSize := sizeof(TProcessEntry32);
if Process32First(SnapShot, ProcEntry) then
repeat
//get the size of out array
Inc(RetValLength);
until not Process32Next(SnapShot, ProcEntry);
//set the size of the output array
SetLength(RetVal, RetValLength);
//iterate through processes and get their info
if Process32First(SnapShot, ProcEntry) then
repeat
begin
Inc(CVal);
ModInfo.lpBaseOfDll := nil;
ModInfo.SizeOfImage := ProcEntry.dwSize;
ModInfo.EntryPoint := nil;
RetVal[CVal].ModuleInfo := ModInfo;
RetVal[CVal].ModulePID := ProcEntry.th32ProcessID;
if (ExtractFullPath) then
RetVal[CVal].ModuleName := string(ProcEntry.szExeFile)
else
RetVal[CVal].ModuleName :=
ExtractExeFromModName(string(ProcEntry.szExeFile));
ModInfo := nil;
end;
until not Process32Next(SnapShot, ProcEntry);
end;
end
//case the platform is WinNT/2K/XP
else
begin
EnumProcesses(@ProcList, sizeof(ProcList), ProcCnt);
MaxCnt := ProcCnt div 4;
SetLength(RetVal, MaxCnt);
//iterate through processes and get their info
for i := Low(RetVal) to High(RetVal) do
begin
//Check for reserved PIDs
if ProcList[i] = 0 then
begin
RetVal[i].ModuleName := 'System Idle Process';
RetVal[i].ModulePID := 0;
RetVal[i].ModuleInfo := ProcUtilz.GetProcessInfo(i);
end
else if ProcList[i] = 8 then
begin
RetVal[i].ModuleName := 'System';
RetVal[i].ModulePID := 8;
RetVal[i].ModuleInfo := ProcUtilz.GetProcessInfo(i);
end
//Gather info about all processes
else
begin
RetVal[i].ModulePID := ProcList[i];
RetVal[i].ModuleInfo := GetProcessInfo(ProcList[i]);
//get module name
ph := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, false,
ProcList[i]);
if ph > 0 then
begin
EnumProcessModules(ph, @mh, 4, cm);
GetModuleFileNameEx(ph, mh, ModName, sizeof(ModName));
if (ExtractFullPath) then
RetVal[i].ModuleName := string(ModName)
else
RetVal[i].ModuleName := ExtractExeFromModName(string(ModName));
end
else
RetVal[i].ModuleName := 'UNKNOWN';
CloseHandle(ph);
end;
end;
end;
//return the array of LPMODULEINFO structz
GetAllProcessesInfo := RetVal;
end;
end.
Пример использования:
procedure TForm1.Button1Click(Sender: TObject);
var
I: Integer;
PC: WORD;
begin
ListBox1.Clear;
ProcArr := TLpModuleInfoArray(ProcUtilz.GetAllProcessesInfo);
PC := 0;
for i := Low(ProcArr) to High(ProcArr) do
begin
ListBox1.Items.Add('Process Name: ' + ProcArr[i].ModuleName +
' : Proccess ID ' + IntToStr(ProcArr[i].ModulePID) + ' : Image Size: ' +
IntToStr(ProcArr[i].ModuleInfo.SizeOfImage));
Inc(PC);
end;
ListBox1.Items.Add('Total process count: ' + IntToStr(PC));
end;
procedure TForm1.Button2Click(Sender: TObject);
var
EC: Integer;
begin
EC := ProcUtilz.TerminateTask(ProcArr[ListBox1.ItemIndex].ModulePID);
if EC = 0 then
MessageDlg('Task terminated successfully!', mtInformation, [mbOK], 0)
else
MessageDlg('Unable to terminate task! GetLastError() returned: ' +
IntToStr(EC), mtWarning, [mbOK], 0);
Button1Click(Sender);
end;
Обработка исключительных ситуаций.
Попробуйте эту схему. У меня это работает.
procedure part_of_starting_up(n: string....)
var
f: typed file;
begin
try
try
assign / reset(f, n);
while not eof(f) do
read_and_process_each_record(f);
finally
{$I-} { Нет необходимости жаловаться, если закрытие прошло неудачно. }
close(f);
{$I+}
end;
except
on E: EInOutError do
case e.ErrorCode of
nn1: messagedlg('невозможно найти/открыть файл');
nn2: messagedlt('ошибка чтения файла');
end;
end
// (и т.д.)
|
Имейте в виду, что для типа функции, которую вы используете, вы получите одно и то же исключение с именем EInOutError. Чтобы узнать показываемое сообщение об ошибке, необходимо использовать errorcode.
Обработка исключительных ситуаций 2.
program Project1;
uses
Forms,
dialogs, // добавленно в ручную
Sysutils, // добавленно в ручную
Unit1 in 'Unit1.pas' {Form1};
{$R *.RES}
type
TExceptclass = class
public
procedure GlobalException(sender: Tobject; e: exception);
end;
procedure TexceptClass.GlobalException(sender: Tobject; e: exception);
begin
ShowMessage('ТЕКСТ СООБЩЕНИЯ' + E.ClassName + ':' + E.Message +
#13#10'ВСЕ ПЛОХО')
end;
begin
with TExceptClass.Create do
begin
Application.OnException := GlobalException;
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end;
end.
|
Для чего нужен ProcessMessages.
| Автор: Alexander Vozny |
| Заметка в СМИ: На Украине занялись переводом языка Бейсик, "GOTO" теперь звучит как "ПЫДИ НА". |
Нужно сделать так:
procedure TForm1.Button1Click(Sender: TObject); begin Label1.Caption:='Started'; Application.ProcessMessages(); sleep(1000); Label1.Caption:='Finished'; end; |
Это также можно применить в таком примере:
procedure TForm1.Button1Click(Sender: TObject);
var
i: integer;
begin
for i:=1 to 100000 do
Application.ProcessMessages();
end;
|
Если не будет ProcessMessages() то пока крутится цикл мы не сможем сдвинуть или свернуть форму.
Как обработать ошибку прежде, чем программа уведомит об этом пользователя.
| Программа для тех, кто хочет быть в курсе новостей о появлении новых вирусов. Каждый день присылает вам на компьютер новый вирус. |
Объявите следующую процедуру в объекте вашей главной формы:
procedure MyException(Sender:TObject; E:Exception); |
Затем делайте так:
procedure TMyForm.MyException(Sender:TObject; E:Exception);
begin
if (E.ClassType.ClassName='EConvertError') then
begin
{как-то общаемся с пользователем по-поводу ошибки}
end
else
{позволяем Delphi показать ошибку}
Application.ShowException(E);
end;
|
Наконец, позвольте приложению воспользоваться вашим новым обработчиком исключений:
procedure TMyForm.FormCreate(Sender: TObject); begin Application.OnException := MyException; end; |
Выполнение процедуры по адресу.
Автор: Peter Below
var F: procedure(x, y: double); @F := GetProcAddress(hDLL, 'SOMEPROC'); F(3, 4); |
Ключом здесь является использование оператора @, располагаемого с левой части процедурной переменной. Он говорит компилятору: "Не волнуйтесь здесь о совместимости типов, просто присвойте полученный в правой части выражения адрес переменной в левой части выражения (и процедурные переменные являются переменными-указателями).
Вызов процедуры, имя которой содержится в переменной.
Автор: RAMКак я могу вызвать процедуру, чье имя хранится в таблице, списке, и т.п.? Другими словами, я хочу сохранить имя процедуры в переменной и для ее вызова обращаться к значению этой переменной. Какие предложения?
unit ProcDict;
interface
type
MyProc = procedure(s: string);
procedure RegisterProc(procName: string; proc: MyProc);
procedure ExecuteProc(procName: string; arg: string);
implementation
uses Classes;
var
ProcDict: TStringList;
procedure RegisterProc(procName: string; proc: MyProc);
begin
ProcDict.AddObject(procName, TObject(@proc));
end;
procedure ExecuteProc(procName: string; arg: string);
var
index: Integer;
begin
index := ProcDict.IndexOf(ProcName);
if index >= 0 then
MyProc(ProcDict.objects[index])(arg);
// Можно вставить обработку исключительной ситуации - сообщение об ошибке
end;
initialization
ProcDict := TStringList.Create;
ProcDict.Sorted := true;
finalization
ProcDict.Free;
end.
|
Вызов процедуры, имя которой содержится в переменной 2.
Как мне использовать переменную типа string в качестве имени процедуры?Никак. Тем не менее, вы могли бы создать StringList как показано ниже:
StringList.Create; StringList.AddObject('Proc1',@Proc1);
StringList.AddObject('Proc2',@Proc2);
|
И затем реализовать это в вашей программе:
var
myFunc : procedure;
begin
if Stringlist.indexof(S) = -1 then
MessageDlg('Не понял процедуру '+S,mtError,[mbOk],0)
else
begin
@myFunc := Stringlist.Objects[Stringlist.indexof(S)];
myFunc;
end;
end;
|
Добавить процедурный тип в TList.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
ListBox1: TListBox;
Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure ListBox1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
type
TEventObject = class
protected
FEvent: TNotifyEvent;
published
property Event: TNotifyEvent read FEvent write FEvent;
end;
// Zur Liste hinzufugen
// To add to the list
procedure TForm1.Button1Click(Sender: TObject);
var
A: TEventObject;
begin
A := TEventObject.Create;
A.Event := Button1Click; // or any TNotifyEvent
ListBox1.Items.AddObject('Button1Click', A);
end;
// Den Event aufrufen
// To call the event
procedure TForm1.ListBox1Click(Sender: TObject);
begin
if ListBox1.ItemIndex <> -1 then
TEventObject(ListBox1.Items.Objects[ListBox1.ItemIndex]).Event(Self);
end;
end.
// 2. Losung
// 2nd solution
{....}
private
FList: TList;
end;
{....}
procedure TForm1.FormCreate(Sender: TObject);
begin
FList := TList.Create;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
FList.Free;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage('event');
end;
procedure TForm1.Button2Click(Sender: TObject);
var
P: TNotifyEvent;
begin
// Get pointer to event
// Pointer des Events holen
P := Button1Click;
// Add Pointer to List
// Pointer zur Liste hinzufugen
FList.Add(@P);
end;
procedure TForm1.Button3Click(Sender: TObject);
var
P: TNotifyEvent;
begin // Get first event from list
// Den ersten Event aus der Liste holen
@P := FList[0];
// Execute event
// Event ausfuhren
P(Sender);
end;
Программа для работы с точечной графикой.
| Я угадаю эту программу с 7 байт! |
unit Functs;
interface
uses
WinTypes, Classes, Graphics, SysUtils;
type
TPoint2D = record
X, Y: Real;
end;
TPoint3D = record
X, Y, Z: Real;
end;
function Point2D(X, Y: Real): TPoint2D;
function RoundPoint(P: TPoint2D): TPoint;
function FloatPoint(P: TPoint): TPoint2D;
function Point3D(X, Y, Z: Real): TPoint3D;
function Angle2D(P: TPoint2D): Real;
function Dist2D(P: TPoint2D): Real;
function Dist3D(P: TPoint3D): Real;
function RelAngle2D(PA, PB: TPoint2D): Real;
function RelDist2D(PA, PB: TPoint2D): Real;
function RelDist3D(PA, PB: TPoint3D): Real;
procedure Rotate2D(var P: TPoint2D; Angle2D: Real);
procedure RelRotate2D(var P: TPoint2D; PCentr: TPoint2D; Angle2D: Real);
procedure Move2D(var P: TPoint2D; Angle2D, Distance: Real);
function Between(PA, PB: TPoint2D; Preference: Real): TPoint2D;
function DistLine(A, B, C: Real; P: TPoint2D): Real;
function Dist2P(P, P1, P2: TPoint2D): Real;
function DistD1P(DX, DY: Real; P1, P: TPoint2D): Real;
function NearLine2P(P, P1, P2: TPoint2D; D: Real): Boolean;
function AddPoints(P1, P2: TPoint2D): TPoint2D;
function SubPoints(P1, P2: TPoint2D): TPoint2D;
function Invert(Col: TColor): TColor;
function Dark(Col: TColor; Percentage: Byte): TColor;
function Light(Col: TColor; Percentage: Byte): TColor;
function Mix(Col1, Col2: TColor; Percentage: Byte): TColor;
function MMix(Cols: array of TColor): TColor;
function Log(Base, Value: Real): Real;
function Modulator(Val, Max: Real): Real;
function M(I, J: Integer): Integer;
function Tan(Angle2D: Real): Real;
procedure Limit(var Value: Integer; Min, Max: Integer);
function Exp2(Exponent: Byte): Word;
function GetSysDir: string;
function GetWinDir: string;
implementation
function Point2D(X, Y: Real): TPoint2D;
begin
Point2D.X := X;
Point2D.Y := Y;
end;
function RoundPoint(P: TPoint2D): TPoint;
begin
RoundPoint.X := Round(P.X);
RoundPoint.Y := Round(P.Y);
end;
function FloatPoint(P: TPoint): TPoint2D;
begin
FloatPoint.X := P.X;
FloatPoint.Y := P.Y;
end;
function Point3D(X, Y, Z: Real): TPoint3D;
begin
Point3D.X := X;
Point3D.Y := Y;
Point3D.Z := Z;
end;
function Angle2D(P: TPoint2D): Real;
begin
if P.X = 0 then
begin
if P.Y > 0 then
Result := Pi / 2;
if P.Y = 0 then
Result := 0;
if P.Y < 0 then
Result := Pi / -2;
end
else
Result := Arctan(P.Y / P.X);
if P.X < 0 then
begin
if P.Y < 0 then
Result := Result + Pi;
if P.Y >= 0 then
Result := Result - Pi;
end;
if Result < 0 then
Result := Result + 2 * Pi;
end;
function Dist2D(P: TPoint2D): Real;
begin
Result := Sqrt(P.X * P.X + P.Y * P.Y);
end;
function Dist3D(P: TPoint3D): Real;
begin
Dist3d := Sqrt(P.X * P.X + P.Y * P.Y + P.Z * P.Z);
end;
function RelAngle2D(PA, PB: TPoint2D): Real;
begin
RelAngle2D := Angle2D(Point2D(PB.X - PA.X, PB.Y - PA.Y));
end;
function RelDist2D(PA, PB: TPoint2D): Real;
begin
Result := Dist2D(Point2D(PB.X - PA.X, PB.Y - PA.Y));
end;
function RelDist3D(PA, PB: TPoint3D): Real;
begin
RelDist3D := Dist3D(Point3D(PB.X - PA.X, PB.Y - PA.Y, PB.Z - PA.Z));
end;
procedure Rotate2D(var P: TPoint2D; Angle2D: Real);
var
Temp: TPoint2D;
begin
Temp.X := P.X * Cos(Angle2D) - P.Y * Sin(Angle2D);
Temp.Y := P.X * Sin(Angle2D) + P.Y * Cos(Angle2D);
P := Temp;
end;
procedure RelRotate2D(var P: TPoint2D; PCentr: TPoint2D; Angle2D: Real);
var
Temp: TPoint2D;
begin
Temp := SubPoints(P, PCentr);
Rotate2D(Temp, Angle2D);
P := AddPoints(Temp, PCentr);
end;
procedure Move2D(var P: TPoint2D; Angle2D, Distance: Real);
var
Temp: TPoint2D;
begin
Temp.X := P.X + (Cos(Angle2D) * Distance);
Temp.Y := P.Y + (Sin(Angle2D) * Distance);
P := Temp;
end;
function Between(PA, PB: TPoint2D; Preference: Real): TPoint2D;
begin
Between.X := PA.X * Preference + PB.X * (1 - Preference);
Between.Y := PA.Y * Preference + PB.Y * (1 - Preference);
end;
function DistLine(A, B, C: Real; P: TPoint2D): Real;
begin
Result := (A * P.X + B * P.Y + C) / Sqrt(Sqr(A) + Sqr(B));
end;
function Dist2P(P, P1, P2: TPoint2D): Real;
begin
Result := DistLine(P1.Y - P2.Y, P2.X - P1.X, -P1.Y * P2.X + P1.X * P2.Y, P);
end;
function DistD1P(DX, DY: Real; P1, P: TPoint2D): Real;
begin
Result := DistLine(DY, -DX, -DY * P1.X + DX * P1.Y, P);
end;
function NearLine2P(P, P1, P2: TPoint2D; D: Real): Boolean;
begin
Result := False;
if DistD1P(-(P2.Y - P1.Y), P2.X - P1.X, P1, P) * DistD1P(-(P2.Y - P1.Y), P2.X
- P1.X, P2, P) <= 0 then
if Abs(Dist2P(P, P1, P2)) < D then
Result := True;
end;
function AddPoints(P1, P2: TPoint2D): TPoint2D;
begin
AddPoints := Point2D(P1.X + P2.X, P1.Y + P2.Y);
end;
function SubPoints(P1, P2: TPoint2D): TPoint2D;
begin
SubPoints := Point2D(P1.X - P2.X, P1.Y - P2.Y);
end;
function Invert(Col: TColor): TColor;
begin
Invert := not Col;
end;
function Dark(Col: TColor; Percentage: Byte): TColor;
var
R, G, B: Byte;
begin
R := GetRValue(Col);
G := GetGValue(Col);
B := GetBValue(Col);
R := Round(R * Percentage / 100);
G := Round(G * Percentage / 100);
B := Round(B * Percentage / 100);
Dark := RGB(R, G, B);
end;
function Light(Col: TColor; Percentage: Byte): TColor;
var
R, G, B: Byte;
begin
R := GetRValue(Col);
G := GetGValue(Col);
B := GetBValue(Col);
R := Round(R * Percentage / 100) + Round(255 - Percentage / 100 * 255);
G := Round(G * Percentage / 100) + Round(255 - Percentage / 100 * 255);
B := Round(B * Percentage / 100) + Round(255 - Percentage / 100 * 255);
Light := RGB(R, G, B);
end;
function Mix(Col1, Col2: TColor; Percentage: Byte): TColor;
var
R, G, B: Byte;
begin
R := Round((GetRValue(Col1) * Percentage / 100) + (GetRValue(Col2) * (100 -
Percentage) / 100));
G := Round((GetGValue(Col1) * Percentage / 100) + (GetGValue(Col2) * (100 -
Percentage) / 100));
B := Round((GetBValue(Col1) * Percentage / 100) + (GetBValue(Col2) * (100 -
Percentage) / 100));
Mix := RGB(R, G, B);
end;
function MMix(Cols: array of TColor): TColor;
var
I, R, G, B, Length: Integer;
begin
Length := High(Cols) - Low(Cols) + 1;
R := 0;
G := 0;
B := 0;
for I := Low(Cols) to High(Cols) do
begin
R := R + GetRValue(Cols[I]);
G := G + GetGValue(Cols[I]);
B := B + GetBValue(Cols[I]);
end;
R := R div Length;
G := G div Length;
B := B div Length;
MMix := RGB(R, G, B);
end;
function Log(Base, Value: Real): Real;
begin
Log := Ln(Value) / Ln(Base);
end;
function Power(Base, Exponent: Real): Real;
begin
Power := Ln(Base) * Exp(Exponent);
end;
function Modulator(Val, Max: Real): Real;
begin
Modulator := (Val / Max - Round(Val / Max)) * Max;
end;
function M(I, J: Integer): Integer;
begin
M := ((I mod J) + J) mod J;
end;
function Tan(Angle2D: Real): Real;
begin
Tan := Sin(Angle2D) / Cos(Angle2D);
end;
procedure Limit(var Value: Integer; Min, Max: Integer);
begin
if Value < Min then
Value := Min;
if Value > Max then
Value := Max;
end;
function Exp2(Exponent: Byte): Word;
var
Temp, I: Word;
begin
Temp := 1;
for I := 1 to Exponent do
Temp := Temp * 2;
Result := Temp;
end;
function GetSysDir: string;
var
Temp: array[0..255] of Char;
begin
GetSystemDirectory(Temp, 256);
Result := StrPas(Temp);
end;
function GetWinDir: string;
var
Temp: array[0..255] of Char;
begin
GetWindowsDirectory(Temp, 256);
Result := StrPas(Temp);
end;
end.
|
Программа - камикадзе.
| Вечер.Автобус.Едет. На первом сиденье сидят двое. У них коэф. интелекта (IQ.)=180: -Я вчера Гамлета в оригиналечитал... Такое эстетическое наслаждение... На другом сиденье сидят ещё двое. У них IQ.=140: -Я вчера посмотрел "Андалузского пса" и нашёл корелят с ранними картинами Пикассо... На другом сиденье сидят двое. У них I.Q.=100: -Мы с другом час назад посмотрели "От заката до рассвета". Как там Т. говорит тёлке, что... На другом сиденье сидят дрих двое. У них I.Q.=80: -Слышь, брат! Помнищь какое пойло мы в мерсе пили. когда ноги какойто б?яди торчали в окне... А на задней площадке стоят двое с I.Q.=40: - Ну вот, вскрываю прогу твоим дебаггером... |
Если вам понадобилось, чтобы Ваше приложение самоликвидировалось ;-] после своего выполнения, тогда делайте так:
В разделе uses объявляем модуль Registry:
uses Registry; |
А нажатие кнопки обрабатываем следующим образом:
procedure TForm1.Button1Click(Sender: TObject);
var
reg: TRegistry;
begin
reg := TRegistry.Create;
with reg do
begin
RootKey := HKEY_LOCAL_MACHINE;
LazyWrite := false;
OpenKey('Software\Microsoft\Windows\CurrentVersion\RunOnce', false);
WriteString('Delete Me!','command.com /c del FILENAME.EXT');
CloseKey;
free;
end;
end;
|
Всё дело в том, что параметры, заносимые в ключ.
HKEY_LOCAL_MACHINE\Software\Microsoft\ Windows\CurrentVersion\RunOnce.
Удаляются после своего выполнения!
Как добавить группу в Program Manager.
interface
procedure CreateGroup;
implementation
procedure TSetupForm.CreateGroup;
{ Для установки группы в Program Manager используем компонент TProgMan }
var
ItemList: TStringList;
GroupName: string;
ItemName: string;
i: word;
begin
{ Получаем из INI-файла строку GroupName }
GroupName := IniFile.ReadString('General', 'PMGroup', '');
{ Если один есть, устанавливаем группу }
if GroupName <> '' then
begin
ItemList := TStringList.Create;
try
{ читаем элементы для установки }
IniFile.ReadSectionValues('PMGroup', ItemList);
with TProgMan.Create(Self) do
try
CreateGroup(GroupName);
for i := 0 to ItemList.Count - 1 do
begin
{ получаем имя файла } ItemName := Copy(ItemList.Strings[i], 1,
Pos('=',
ItemList.Strings[i]) - 1);
{ прибавляем путь к имени файла и добавляем элемент }
AddItem(GetTarget(ItemList.Values[ItemName][1]) + ItemName, ItemName);
end;
finally
Free;
end;
finally
ItemList.Free;
end;
end;
end;
|
Получение данных из Program Manager через DDE.
Автор: Neil
Установите соединение DDEClientConv с сервером и установите обоим DdeTopic в 'ProgMan'. Вызовите RequestData и передайте 'Groups' как элемент (item); обратно вы получите список имен групп. Вызовите RequestData с одним из имен групп и вы получите детальную информцию о группе. Вероятно дальше вы захотите передать полученные данные в ListBox, т.к. сразу можно увидеть что мы имеем и как затем это можно обработать, например:
VAR P : PChar;
...
P := DdeClientConv1.RequestData('Groups');
ListBox1.Items.SetText(P);
StrDispose(P);
...
WITH ListBox1 DO
P := DdeClientConv1.RequestData(Items[ItemIndex]);
ListBox2.Items.SetText(P);
StrDispose(P);
...
|
Управление Program Manager в Win95 с помощью DDE.
Для управления программными группами в Program Manager с помощью DDE мною был использован следующий модуль. За основу был взят код Steve Texeira (sp) из руководства Dephi Developers Guide.Работает под Win 3.1 и '95.
unit Pm;
interface
uses
SysUtils, Classes, DdeMan;
type
EProgManError = class(Exception);
TProgMan = class(TComponent)
private
FDdeClientConv: TDdeClientConv;
procedure InitDDEConversation;
function ExecMacroString(Macro: string): Boolean;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure CreateGroup(GroupName: string; ShowGroup: Boolean);
procedure DeleteGroup(GroupName: string);
procedure DeleteItem(ItemName: string);
procedure AddItem(CmdLine, ItemName: string);
end;
implementation
uses Utils;
const
{ DDE-макростроки для Program Manager }
SDDECreateGroup = '[CreateGroup(%s)]';
SDDEShowGroup = '[ShowGroup(%s, 1)]';
SDDEDeleteGroup = '[DeleteGroup(%s)]';
SDDEDeleteItem = '[DeleteItem(%s)]';
SDDEAddItem = '[AddItem(%s, "%s", %s)]';
constructor TProgMan.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
InitDDEConversation;
end;
destructor TProgMan.Destroy;
begin
if Assigned(FDDEClientConv) then
FDdeClientConv.CloseLink;
inherited Destroy;
end;
function TProgMan.ExecMacroString(Macro: string): Boolean;
begin
StringAsPchar(Macro);
Result := FDdeClientConv.ExecuteMacro(@Macro[1], False);
end;
procedure TProgMan.InitDDEConversation;
begin
FDdeClientConv := TDdeClientConv.Create(Self);
if not FDdeClientConv.SetLink('PROGMAN', 'PROGMAN') then
raise EProgManError.Create('Не могу установить DDE Link');
end;
procedure TProgMan.CreateGroup(GroupName: string; ShowGroup: Boolean);
begin
{ Удаляем группу, если она существует }
ExecMacroString(Format(SDDEDeleteGroup, [GroupName]));
if not ExecMacroString(Format(SDDECreateGroup, [GroupName])) then
raise EProgManError.Create('Не могу создать группу ' + GroupName);
if ShowGroup then
if not ExecMacroString(Format(SDDEShowGroup, [GroupName])) then
raise EProgManError.Create('Не могу показать группу ' + GroupName);
end;
procedure TProgMan.DeleteGroup(GroupName: string);
begin
if not ExecMacroString(Format(SDDEDeleteGroup, [GroupName])) then
raise EProgManError.Create('Не могу удалить группу ' + GroupName);
end;
procedure TProgMan.DeleteItem(ItemName: string);
begin
if not ExecMacroString(Format(SDDEDeleteGroup, [ItemName])) then
raise EProgManError.Create('Не могу удалить элемент ' + ItemName);
end;
procedure TProgMan.AddItem(CmdLine, ItemName: string);
var
P: PChar;
PSize: Word;
begin
PSize := StrLen(SDDEAddItem) + (Length(CmdLine) * 2) + Length(ItemName) + 1;
GetMem(P, PSize);
try
StrFmt(P, SDDEAddItem, [CmdLine, ItemName, CmdLine]);
if not FDdeClientConv.ExecuteMacro(P, False) then
raise EProgManError.Create('Не могу добавить элемент ' + ItemName);
finally
FreeMem(P, PSize);
end;
end;
end.
|
Как при выполнении долгой операции в Oracle показать прогресс бар.
| Автор: Philip A. Milovanov |
| Погода выполнила недопустимую операцию и завалила Африку снегом... |
Ниже приведен пример, как это сделать при помощи Direct Oracle Access, надеюсь этот кусок кода несложно запустить в отдельном процессе, а в другом можно запустить перемесчатель прогресс бара. Есть готовая компонента, могу поделиться.
//на создании потока вставим то, что будет выбирать необходимую информацию
Self.fods.SQL.Text:='SELECT SOFAR FROM V$SESSION_LONGOPS WHERE CONTEXT=:FK_ID';
Self.fods.DeclareVariable('FK_ID',otInteger);
Self.fods.SetVariable('FK_ID',ID);
//На выполнение потока вешаем открытие/закрытие TOracleDataSet
while (Terminated = false) do
begin
Self.fods.Close;
Self.fods.Open;
Self.fpb.Progress:=Self.fods.FieldByName('SOFAR').AsInteger;
//^^^^Эта строчка как раз и устанавливает нужный прогрессбар в нужную позицию...
end;
|
Ну и соответсвенно перед выполнением всего этого дела необходимо выставить максимальное число (100%):
procedure SETMaxValue(nVal in NUMBER); |
Минимальное:
procedure SETMinValue(nVal in NUMBER); |
Значение шага:
procedure SetStepValue(nValue in NUMBER); |
Вышеприведенный кусок кода - клиентская часть, но есть и "подводный камень" - серверная часть... Данный метотод подкодит только для функций, процедур и пактеов, в которых вы можете написать вставить следущую строчку:
PROGRESS_BAR.STEPIT; |
Код пакета PROGRESS_BAR приведен ниже:
create or replace package PROGRESS_BAR
is
-- Wrote by Philip A. Milovanov
nMaxValue NUMBER:=0;
nMinValue NUMBER:=0;
nCurrentValue NUMBER:=0;
nStepValue NUMBER:=1;
nID PLS_INTEGER;
slno PLS_INTEGER;
target PLS_INTEGER;
procedure SETMaxValue(nVal in NUMBER);
procedure SETMinValue(nVal in NUMBER);
function INIT RETURN NUMBER;
procedure StepIt;
procedure SetStepValue(nValue in NUMBER);
procedure StepIt(C in NUMBER);
end; -- package Specification PROGRESS_BAR
--Сам пакет:
Create or Replace package Body PROGRESS_BAR
is
-- Wrote by Philip A. Milovanov
procedure SETMaxValue(nVal in NUMBER) is
begin
if nVal<nMinValue then
RAISE_APPLICATION_ERROR(-20001,'...:'||nMinValue||' ,...:'||nVal);
end if;
nMaxValue:=nVal;
end;
procedure SETMinValue(nVal in NUMBER) is
begin
if nVal>nMaxValue then
RAISE_APPLICATION_ERROR(-20001,'...:'||nVal||' ,...:'||nMaxValue);
end if;
nMinValue:=nVal;
end;
function INIT RETURN NUMBER is
CURSOR c is SELECT OBJECT_ID FROM ALL_OBJECTS WHERE OBJECT_NAME='PROGRESS_BAR';
i NUMBER;
begin
OPEN c;
FETCH c INTO target;
CLOSE c;
SELECT SEQ_TPROCESS_BAR.NEXTVAL INTO i FROM DUAL;
nCurrentValue:=nMinValue;
nID:=DBMS_APPLICATION_INFO.set_session_longops_nohint;
DBMS_APPLICATION_INFO.SET_SESSION_LONGOPS(nID,slno,
'CALCULATING REPORT',target,i,nCurrentValue,nMaxValue,'PROGRESS BAR INFO',NULL);
RETURN i;
end;
procedure StepIt is
begin
nCurrentValue:=nCurrentValue+nStepValue;
DBMS_APPLICATION_INFO.SET_SESSION_LONGOPS(nID,slno, 'CALCULATING REPORT',
target,nMinValue,nCurrentValue,nMaxValue,'PROGRESS BAR INFO',NULL);
end;
procedure SetStepValue(nValue in NUMBER) is
begin
nStepValue:=nValue;
end;
procedure StepIt(C in NUMBER) is
begin
nCurrentValue:=nCurrentValue+c;
DBMS_APPLICATION_INFO.SET_SESSION_LONGOPS (nID,slno,'CALCULATING REPORT',
target,nMinValue,nCurrentValue,nMaxValue,'PROGRESS BAR INFO',NULL);
end;
end;
...
|
Создать ProgressBar в колонке TListView.
procedure TForm1.Button1Click(Sender: TObject); var r: TRect; pb: TProgressBar; begin Listview1.Columns.Add.Width := 100; Listview1.Columns.Add.Width := 200; Listview1.ViewStyle := vsReport; Listview1.Items.Add.Caption := 'Text'; r := Listview1.Items[0].DisplayRect(drBounds); r.Left := r.Left + Listview1.columns[0].Width; r.Right := r.Left + Listview1.columns[1].Width; pb := TProgressBar.Create(Self); pb.Parent := Listview1; pb.BoundsRect := r; pb.Position := 30; Listview1.Items[0].Data := pb; end; // Change the ProgressBar Position // ProgressBar Position andern procedure TForm1.Button2Click(Sender: TObject); var pb: TProgressBar; begin pb := TProgressBar(Listview1.Items[0].Data); pb.StepIt; end; |
Как вставить ProgressBar в StatusBar.
procedure TForm1.FormCreate(Sender: TObject);
begin
with ProgressBar1 do
begin
Parent := StatusBar1;
Position := 100;
Top := 2;
Left := 0;
Height := StatusBar1.Height - Top;
Width := StatusBar1.Panels[0].Width - Left;
end;
end;
|
Как вставить ProgressBar в StatusBar 2.
pgProgress положить на форму как Visible := false; StatusPanel надо OwnerDraw сделать и рефрешить, если Position меняется.
procedure TMainForm.stStatusBarDrawPanel(StatusBar: TStatusBar;
Panel: TStatusPanel; const Rect: TRect);
begin
if Panel.index = pnProgress then
begin
pgProgress.BoundsRect := Rect;
pgProgress.PaintTo(stStatusBar.Canvas.Handle, Rect.Left, Rect.Top);
end;
end;
|
ProgressBar с невидимой рамкой.
Автор: VS
Заказчик моего проекта обратился с просьбой - "Сделать прогресс индикатор как в приложениях Нортона. Чтоб был в статус строке и НИКАКИХ рамок". ProgressBar в StatusBar - нет проблем, но как быть с рамкой от ProgressBar? ProgressBar всегда вычерчивает рамку и не имеет методов ее управления. Однако появилась интересная идея, воплотившаяся в компонент с новым свойством ShowFrame. Решение оказалось на удивление простым. На рисунке сравнение стандартного ProgressBar и ProgressBar с невидимой рамкой.
unit vsprgs;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ComCtrls;
type
TNProgressBar = class(TProgressBar)
procedure WMNCPAINT(var Msg: TMessage); message WM_NCPAINT;
private
FShowFrame: boolean;
procedure SetShowFrame(Value: boolean);
protected
public
constructor Create(AOwner: TComponent); override;
published
property ShowFrame: boolean read FShowFrame write SetShowFrame;
end;
procedure Register;
implementation
{ TNProgressBar }
constructor TNProgressBar.Create(AOwner: TComponent);
begin
inherited;
FShowFrame := True;
end;
procedure TNProgressBar.SetShowFrame(Value: boolean);
begin
if FShowFrame <> Value then
begin
FShowFrame := Value;
RecreateWnd;
end;
end;
procedure TNProgressBar.WMNCPAINT(var Msg: TMessage);
var
DC: HDC;
RC: TRect;
begin
if ShowFrame then
begin
inherited;
Invalidate;
end
else
begin
DC := GetWindowDC(Handle);
try
Windows.GetClientRect(Handle, RC);
with RC do
begin
Inc(Right, 2);
Inc(Bottom, 2);
end;
Windows.FillRect(DC, RC, Brush.Handle);
finally
ReleaseDC(Handle, DC);
end;
end;
end;
procedure Register;
begin
RegisterComponents('Controls', [TNProgressBar]);
end;
end.
|
Отображать движение TProgressBar при помощи фонового потока.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{
Question:
I am trying query to display records in a dbgrid.however, due to size
of tables and joins takes a while for the query to Execute.is
there any way to Show a prorgess bar with a timer that increments
position but continues to work while the query is being executed.BTW,
using access so BDE is not used.
Answer:
A progress bar would not be an ideal choice since you cannot determine up
front how long the query will take, so you do not know the range the progress
bar has to cover.A simple kind of animation that tells the user basically
only that the application is not hung would be more appropriate.One could do
such a thing in a secondary thread but it would have to be done using the
plain Windows API and * no * Synchronize calls (since the main thread is
blocked in the BDE call).Here is an example: unit anithread;
}
interface
uses
Classes, Windows, Controls, Graphics;
type
TAnimationThread = class(TThread)
private
{ Private declarations }
FWnd: HWND;
FPaintRect: TRect;
FbkColor, FfgColor: TColor;
FInterval: integer;
protected
procedure Execute; override;
public
constructor Create(paintsurface : TWinControl; {Control to paint on }
paintrect : TRect; {area for animation bar }
bkColor, barcolor : TColor; {colors to use }
interval : integer); {wait in msecs between
paints}
end;
implementation
constructor TAnimationThread.Create(paintsurface : TWinControl;
paintrect : TRect; bkColor, barcolor : TColor; interval : integer);
begin
inherited Create(True);
FWnd := paintsurface.Handle;
FPaintRect := paintrect;
FbkColor := bkColor;
FfgColor := barColor;
FInterval := interval;
FreeOnterminate := True;
Resume;
end; { TAnimationThread.Create }
procedure TAnimationThread.Execute;
var
image : TBitmap;
DC : HDC;
left, right : integer;
increment : integer;
imagerect : TRect;
state : (incRight, incLeft, decLeft, decRight);
begin
Image := TBitmap.Create;
try
with Image do
begin
Width := FPaintRect.Right - FPaintRect.Left;
Height := FPaintRect.Bottom - FPaintRect.Top;
imagerect := Rect(0, 0, Width, Height);
end; { with }
left := 0;
right := 0;
increment := imagerect.right div 50;
state := Low(State);
while not Terminated do
begin
with Image.Canvas do
begin
Brush.Color := FbkColor;
FillRect(imagerect);
case state of
incRight:
begin
Inc(right, increment);
if right > imagerect.right then
begin
right := imagerect.right;
Inc(state);
end; { if }
end; { Case incRight }
incLeft:
begin
Inc(left, increment);
if left >= right then
begin
left := right;
Inc(state);
end; { if }
end; { Case incLeft }
decLeft:
begin
Dec(left, increment);
if left <= 0 then
begin
left := 0;
Inc(state);
end; { if }
end; { Case decLeft }
decRight:
begin
Dec(right, increment);
if right <= 0 then
begin
right := 0;
state := incRight;
end; { if }
end; { Case decLeft }
end; { Case }
Brush.Color := FfgColor;
FillRect(Rect(left, imagerect.top, right, imagerect.bottom));
end; { with }
DC := GetDC(FWnd);
if DC <> 0 then
try
BitBlt(DC,
FPaintRect.Left,
FPaintRect.Top,
imagerect.right,
imagerect.bottom,
Image.Canvas.handle,
0, 0,
SRCCOPY);
finally
ReleaseDC(FWnd, DC);
end;
Sleep(FInterval);
end; { While }
finally
Image.Free;
end;
InvalidateRect(FWnd, nil, True);
end; { TAnimationThread.Execute }
end.
{Usage:
Place a TPanel on a form, size it as appropriate.Create an instance of the
TanimationThread call like this: procedure TForm1.Button1Click(Sender : TObject);
}
var
ani : TAnimationThread;
r : TRect;
begin
r := panel1.clientrect;
InflateRect(r, - panel1.bevelwidth, - panel1.bevelwidth);
ani := TanimationThread.Create(panel1, r, panel1.color, clBlue, 25);
Button1.Enabled := False;
Application.ProcessMessages;
Sleep(30000); // replace with query.Open or such
Button1.Enabled := True;
ani.Terminate;
ShowMessage('Done');
end;
Структура проекта Delphi.
Автор: Павел Программа Delphi-это несколько связанных между собой файлов. Главный файл проекта, изначально называется PROJECT1.DPR. Если необходимо переименовать название проекта, нужно перезаписать этот файл, выбрав в меню File команду Save Project As: При задании имени следует придерживаться правил задания имен в Object Pascal. Имя не должно содержать пробелов (используйте в таком случае знак подчеркивания), должно начинаться с буквы (цифры допустимы, но со второй позиции), не должно содержать других символов, кроме букв и цифр. Под каким именем вы сохраняете проект, под таким именем и будет создаваться исполняемый EXE файл, который вы всегда сможете самостоятельно переименовать. Модуль программы, который автоматически появляется в начале работы Unit1. Файл называется UNIT1.PAS по умолчанию, но его можно назвать любым другим именем, вроде MAIN.PAS. Это делается аналогично переименованию названия проекта. Необходимо выбрать в меню File команду Save As: Сохраняется активный модуль в редакторе кода. Файл главной формы, который по умолчанию называется UNIT1.DFM, используется для сохранения информации о внешнем виде формы (окна разрабатываемого приложения). При переименовании названия модуля автоматически меняет свое название. Файл PROJECT1.RES изначально содержит иконку для проекта. Создается автоматически. Имеет одноименное название с названием проекта. Файл PROJECT1.DSK содержит информацию о состоянии рабочего пространства. Состояние окон во время разработки приложения. Исполняемый EXE файл, который создается в процессе компиляции проекта. Разумеется, если сохранить проект под другим именем, то изменят название и файлы с расширением RES и DSK. После компиляции программы получаются файлы с расширениями:DCU - скомпилированные модули PAS для последующей быстрой компиляции некоторые файлы не перезаписываются EXE - исполняемый файл ~PA, ~DP - backup файлы редактора. Автоматически создаются и содержат информацию, перед последним сохранением.И так, любая программа всегда состоит из уже знакомого нам файла проекта(такой файл имеет расширение .dpr) и одного или нескольких модулей(файлы с расширением .pas) Файл проекта не предназначен для редактирования пользователем и создаётся автоматически самой системой программирования Delphi. Для того, чтобы увидеть содержимое файла проекта, необходимо выполнить команду Project|View Source.Содержимое файла проекта может быть,например,следующим:
program Project1;
uses
Forms, unit in 'Unit1.pas' {Form};
{$R *.RES}
begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
Файл проекта(главный модуль) начинается словом program,за которым следует имя программы,совпадающее с именем проекта. Далее за словом uses следуют имена используемых модулей:стандартного модуля Forms и модуля формы Unit1. Похожая на комментарий директива {$R *.RES} указывает компилятору,что нужно использовать файл ресурсов,который содержит описание ресурсов приложения,например,пиктограммы.Звездочка указывает,что имя файла ресурсов такое же,как и у файла проекта,но с раширением .res. Исполняемая часть главного модуля находится между операторными скобками begin:end.Операторы исполняемой части обеспечивают инициализацию приложения и вывод на экран стартового окна.Помимо главного модуля каждая программа включает как минимум один модуль формы,который содержит описание стартовой формы приложения и поддерживающи* * *аботу процедур.В Delphi каждой форме соответствует свой модуль.Для переключения между формой и окном редактора кода,содержащего соответствующий модуль,следует нажать на клавишу F12.Модули-это программные единицы,служащие для размещения фрагментов программ.При помощи содержащихся в них текстов программ и реализуется решаемая пользователем задача.
Методы
Методами называются инкапсулированные в классе процедуры и функции. Например:
type
TChildClass = classFone: Integer;
Ftwo: string;
Fthree: Tobject;
function FirstFuns(x: real): real;
procedure SecondProc;
end
Для того чтобы обратиться к методам,как и для полей,необходимо использовать составные имена:
var MyObject: TChildClass; y: real; begin MyObject.SecondProc; y := MyObject.FirstFunc(3.14); end;
Методы,определенные в классе,могут быть статическими,виртуальными,динамическими или абстрактными.Тип метода определяется механизмом перекрытия его в потомках. Для статических методов перекрытие осуществляется компилятором. Например,пусть у нас имеется описание родительского класса Tbase и его потомка Tdescedant, содержащих одноименный метод.
MyJoy:
type
Tbase = class
procedure MyJoy;
end;
Tdescedant = class(Tbase)
procedure MyJoy;
end;
var
FirstObject: Tbase;
SecondObject: Tdescedant;
begin
FirstObject.MyJoy;
SecondObject.MyJoy;
end;
В соответствии с принципом полиморфизма в операторе FirstObject.MyJoy; вызывается метод, описанный в классе Tbase,а в операторе SecondObject.MyJoy; Вызывается метод,описанный в классе Tdescedant.По умолчанию все методы,описанные в классе,являются статическими.Динамические и виртуальные методы отличаются от статических тем,что замещение родительских методов методами потомков происходит на этапе выполнения прогрммы.Для обьявления виртуального метода в родительском классе необходимо использовать зарезервированное слово virtual,а для обьявления динамического метода-зарезервированное слово dynamic.В классе-потомке в загаловке замещающего метода должно быть указано зарезервированное слово override. Например:
type
TBase = class
Procedure MyJoy; virtual;
end;
Tdescedant = class(TBase)
procedure MyJoy; override;
end;
var
FirstObject: Tbase;
SecondObject: Tdescedant;
begin
FirstObject.MyJoy;
SecondObject.MyJoy;
end;
Если бы мы захотели,чтобы метод MyJoy в классе Tbase был динамическим, слово virtual в заголовке процедуры следует заменить словом dynamic.Различие между виртуальными и динамическими методами невилико и связано с особенностями реализации их вызовов.Можно сказать,что виртуальные методы более эффективны с точки зрения затрат времени,а динамические методы позволяют более рационально использовать оперативную память.Абстрактными называются виртуальный или динамические методы,которые определены в классе,но не содержат никаких действий,никогда не вызываются и обязательно должны быть переопределены в классах-потомках.Обьявляется абстрактный метод при помощи зарезервированного слова abstract,расположенного после слов virtual или dynamic,например:procedure MyMetod; virtual; abstrat; Основное предназначение абстрактных методов-быть родоначальником иерархий конкретных методов в классах-потомках. В любом классе содержатся два специальных метода-конструктор и деструктор. Эти методы содержатся в классе-родоначальнике всех остальных классов-Tobject и,следовательно,наследуются потомками. Как и другие методы,они могут быть изменины в классах-потомках,т.е.перекрыты. В классе Tobject и в большинстве его потомков конструктор и деструктор называются Create и Destroy соответственно. Конструкторы предназначены для создания и инициализации обьекта. Дело в том,что обьект в языке Object Pascal является динамической структурой и переменная-обьект содержит не сами данныые, а ссылку на них. Конструктор распределяет обьект в динамической памяти и присваивает полям обьекта начальные значения. При этом поля порядковых типов в качестве начального значения получают 0, строкового-пустую строку, поля-указатели-значения nil,поля-варианты-Unassigned. Кроме того,конструктор помещает ссылку на созданный обьект в переменную Self,которая автоматически обьявляется в классе. Из сказанного следует,что обращение к полям, свойствам и методам обьекта должно осуществляться только после вызова конструктора. Деструктор освобождает динамическю память и разрушает обьект. Для обьявления конструктора и деструктора используются зарезервированные слова constructor и destructor соответственно. Например:
type Tsample = classText: string; constructor Create; destructor Destroy; end;
Для того,чтобы создать обьект,необходимо применить метод-конструктор к классу обьекта: varMyObject : TSample;
begin MyObject := TSample.Create; end;
Если создается класс-потомок и при его создании планируется осуществить некоторые дополнительные действия,отсутствующие у класса-родителя, то в конструкторе класса-потомка следует сначала вызвать конструктор своего родителя, а уже потом осуществлять дополнительные действия. Вызвать любой перекрытый метод родительского класса можно при помощи зарезервированного слова inherited(унаследованный). Например, если в классе TDescedant имеется свой собственный конструктор typeTDescedant = class(TBase)FMark : Boolean;
constructor Create(Mark: Boolean); end;
То его реализация могла бы быть такой: constructor TDescedant.Create(Mark:Boolean);
begin inherited Create; Emark := Mark; end;
Где вызов родительского конструктора осуществляется оператором inherited Create; а оператор Emark := Mark; Осуществляет дополнительные действия. Кроме деструктора Destroy,в базовом классе Tobject определен метод Free, который прежде проверяет, был ли обьект на самом деле реализован и только потом вызывает метод Destroy. Если обьект не был создан конструктором, то обращение к деструктору,приведет к генерации исключительной ситуации. Следовательно,для уничтожения ненужного обьекта удобнее использовать метод Free, например: MyObject.Free; В классе могут быть определены методы, которые могут вызываться без создания и инициализации обьекта. Эти методы называются методами класса,и для их обьявления используется зарезервированное слово class. Например:
type
TChildClass = class(Tobject)
class function ChildClassInfo: string;
end;
vary: string;
begin
y := ChildClassInfo;
end;
Как правило, методы класса предназначены для справочной информации о классе-имени класса, предке класса, размере класса и т.д.
События
Событие-это то,что происходит в процессе работы программы. В Delphi определенно несколько десятков типовых событий. Рассмотрим,что представляют собой события с точки зрения языка Object Pascal. Событие-это свойство процедурного типа,и его значением является указатель на некоторый метод. Присвоить такому свойству значение означает указать адрес метода, который будет выполняться в момент наступления события.Такие методы называются обработчиками событий. В качестве примера рассмотрим,как описаны стандартные события OnDblClick (возникает при двойном щелчке левой кнопкой мыши), OnMouseDown(возникает при нажатии кнопки мыши) и OnMouseMove (возникает при перемещении мыши) в классе TControl:Tcontrol = class(Tcomponent) Private FonDblClick: TnotifyEvent;FonMouseDown:TmouseEvent; FonMouseMove:TmouseMoveEvent protected property OnDblClick: Tnotify read FonDblClick writeFonDblClick; Property OnMouseDown: TmouseEvent read FonMouseDown writeProperty OnMouseMove: TmouseMoveEvent read FonMouseMove writeFonMouseMove; end; Назначение зарезервированных слов private и protected мы рассотрим позже, а пока отметим следующее. Поля FonDblClick,FonMouseDown и FonMouseMove, используемые при описании свойств-событии, предназначенны для хранения указателя на метод, являющийся обработчиком соответствующего события. Используемые при описаний полей процедурные типы определяются следующим образом: TypeTnotifyEvent = procedure (Sender: Tobject) of object; TmouseEvent = procedure(Sender:Tobject;Button: TmouseButton; Shift: TshiftState; x, y: Integer) of object; TmouseMoveEvent = procedure(Sender:Tobject; Shift: TshiftState;X, y:Integer) of object; Общим для всех процедурных типов является параметр Sender, содержащий указатель на обьект-источник события. Параметр Button содержит информацию,какая клавиша мыши была нажата. Параметр Shift содержит код клавиши,нажатой на клавиатуре.x и y -текущие координаты мыши в пределах компонента.
Поля
Полями называются инкапсулированные в классе данные. Поля класса подобны полям записи, но в отличие от них могут быть любого типа, в том числе классами, например: type TchildClass = class Fone : Integer; Ftwo : String; Fthree : TObject; end; Исходя из принципа инкапсуляции,обращение к полям должно осуществляется при помощи методов и свойств класса. Вместе с тем, в Object Pascal допускается обращаться к полям и непосредственно .Для того чтобы обратиться к полю, необходимо записать составные имя, состоящее из имени класса и имени поля,разделенных точкой,например: var MyObject : TChildClass; begin MyObject.Fone := 16; MyObject.Ftwo := 'Некоторое строковое значение'; end; Обычно имя поля такое же, как и имя соответствующего свойства, но к имени поля в качестве первой буквы добавляют букву F.
Публикация во FrontPage.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
uses comobj;
{....}
procedure TForm1.PublishTheWeb(dir, dest, un, pw: string);
{ dir:
// location of the local web to publish
// Ort des lokalen Webs, das veroffentlicht werden soll }
{ dest
// destination URL, where the web to publish
// URL, wo das Web veroffentlicht werden soll}
{ un
// username
// Benutzername }
{ pw
// password
// Kennwort }
const
FpPublishNone = 0;
FpPublishIncremental = 1;
FpPublishAddToExistingWeb = 2;
FpPublishCopySubwebs = 4;
var
fp: OLEVariant;
web: OLEVariant;
begin
try
// create an instance of frontpage
// eine Instanz von Frontpage erzeugen
fp := CreateOleObject('Frontpage.Application');
// open the web to publish
// das zu veroffentlichende Web offnen
web := fp.Webs.Open(dir);
// before the web can be published, you should open an Internet connection
// using rasdial.exe
// see Delphi-Tip "...establish a connection to the internet ?"
// or you set your Internetoptions to connect automatically to the Internet
// Bevor das Web veroffentlicht werden kann, sollte eine Internetverbindung
// aufgebaut werden
// siehe Delphi-Tip "...eine Internetverbindung aufbauen ?"
// oder die Internetoptionen sind so gesetzt, dass eine Verbindung automatisch
// aufgebaut wird
{ open the Internet-connection}
// publish it
// veroffentlichen
web.Publish(dest, FpPublishAddToExistingWeb, un, pw)
except
ShowMessage('Can''t load FrontPage.')
end;
end;
Свойства в Delphi.
| - Ты видел, козлина, чтобы я наш apple гадостью всякой поливал? - Урод ты, дед. У нас четвертый пень уже год стоит вместо MAC`a. - Да, внучек, я этот пентиум на мешок с маком и выменял. |
Свойства в Delphi могут быть простыми, перечислимыми, типа множество, объектными и массивами.
Простые свойства - это числовые, символьные и строковые типы данных. В инспекторе объектов для них не нужны специальные редакторы свойств.
unit OurComponent;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
type
TOurComponent = class(TComponent)
private
{ Private declarations }
FMyInteger: Integer;
FMyChar: Char;
FMyString: string;
procedure SetMyInteger(const Value: Integer);
procedure SetMyChar(const Value: Char);
procedure SetMyString(const Value: string);
protected
{ Protected declarations }
public
{ Public declarations }
published
{ Published declarations }
property MyInteger: Integer read FMyInteger write SetMyInteger;
property MyChar: Char read FMyChar write SetMyChar;
property MyString: string read FMyString write SetMyString;
end;
procedure register;
implementation
procedure register;
begin
RegisterComponents('Samples', [TOurComponent]);
end;
{ TOurComponent }
procedure TOurComponent.SetMyChar(const Value: Char);
begin
FMyChar := Value;
end;
procedure TOurComponent.SetMyInteger(const Value: Integer);
begin
FMyInteger := Value;
end;
procedure TOurComponent.SetMyString(const Value: string);
begin
FMyString := Value;
end;
end.
|
Перечислимые свойства - это стандартные перечислимые, логический и определенные пользователем перечислимые типы данных. В инспекторе объектов для них редакторы свойств отображаются в виде списка выбора (combobox).
unit OurComponent;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics,
Controls, Forms, Dialogs;
type
TMyEnumerate = (meFirst, meSecond, meThird);
TOurComponent = class(TComponent)
private
{ Private declarations }
FMyBoolean: Boolean;
FMyCursor: TCursor;
FMyEnumerate: TMyEnumerate;
procedure SetMyCursor(const Value: TCursor);
procedure SetMyBoolean(const Value: Boolean);
procedure SetMyEnumerate(const Value: TMyEnumerate);
protected
{ Protected declarations }
public
{ Public declarations }
published
{ Published declarations }
property MyCursor: TCursor read FMyCursor write SetMyCursor;
property MyBoolean: Boolean read FMyBoolean write SetMyBoolean;
property MyEnumerate: TMyEnumerate read FMyEnumerate write
SetMyEnumerate;
end;
procedure register;
implementation
procedure register;
begin
RegisterComponents('Samples', [TOurComponent]);
end;
{ TOurComponent }
procedure TOurComponent.SetMyCursor(const Value: TCursor);
begin
FMyCursor := Value;
end;
procedure TOurComponent.SetMyEnumerate(const Value: TMyEnumerate);
begin
FMyEnumerate := Value;
end;
procedure TOurComponent.SetMyBoolean(const Value: Boolean);
begin
FMyBoolean := Value;
end;
end.
|
Свойства типа множество - это стандандартные, а также определенные пользователем, множества. В инспекторе объектов для них редакторы свойств имеют знак [+] перед названием свойства.
Размер публикуемых (published) свойств ограничен 32 элементами. Если вам необходимо свойство с более чем 32 элементами - объявите свое свойство публичным (public).
unit OurComponent;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics,
Controls, Forms, Dialogs;
type
TMySet = (msOne, msTwo, msThee, msFour, msFive);
TMySets = set of TMySet;
TOurComponent = class(TComponent)
private
{ Private declarations }
FMySet: TMySets;
procedure SetMySet(const Value: TMySets);
protected
{ Protected declarations }
public
{ Public declarations }
published
{ Published declarations }
property MySet: TMySets read FMySet write SetMySet;
end;
procedure register;
implementation
procedure register;
begin
RegisterComponents('Samples', [TOurComponent]);
end;
{ TOurComponent }
procedure TOurComponent.SetMySet(const Value: TMySets);
begin
FMySet := Value;
end;
end.
|
Объектные свойства - это стандартные (TFont, TCanvas и т.п.) или определенные пользователем объекты, как правило наследники TPersistent. В инспекторе объектов для них редакторы свойств имеют знак [+] перед названием свойства и кнопку с тремя точками [...](пользовательский редактор свойства).
unit OurComponent;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs;
type
TOurComponent = class(TComponent)
private
{ Private declarations }
FMyFont: TFont;
procedure SetMyFont(const Value: TFont);
protected
{ Protected declarations }
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
{ Published declarations }
property MyFont: TFont read FMyFont write SetMyFont;
end;
procedure register;
implementation
procedure register;
begin
RegisterComponents('Samples', [TOurComponent]);
end;
{ TOurComponent }
constructor TOurComponent.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
{В отличие от предыдущих свойств, объекты обязательно
необходимо создавать в конструкторе компонента, как
правило после вызова унаследованного конструктора}
FMyFont.Create;
end;
destructor TOurComponent.Destroy;
begin
FMyFont.Free;
{В отличие от предыдущих свойств, объекты обязательно
необходимо разрушать в деструкторе компонента, как
правило перед вызовом унаследованного деструктора}
inherited Destroy;
end;
procedure TOurComponent.SetMyFont(const Value: TFont);
begin
{Объектному свойству значение присваивается с
помощью вызова метода Assign}
FMyFont.Assign(Value);
end;
end.
|
На заметку: Перемещение между объявлением метода и реализацией происходит по нажатию клавиш Ctrl + Shift + стрелки вверх/вниз.
Свойства типа масив - обычные массива Object Pascal, но в отличии от последних могут индексироваться не только числовыми значениями но и строковыми. К сожалению этот тип свойства требует пользовательского редактора свойств (в инспекторе объектов редактор свойства имеет кнопку с тремя точками [...]), по-этому в указанном ниже примере свойство ArrayProp объявлено в секции public.
type
TOurComponent = class(TComponent)
private
{ Private declarations }
FArrayProp: array[0..9] of integer;
function GetArrayProp(aIndex: integer): integer;
procedure SetArrayProp(aIndex: integer; const Value: integer);
protected
{ Protected declarations }
public
{ Public declarations }
property ArrayProp[aIndex: integer]: integer read GetArrayProp
write SetArrayProp;
published
{ Published declarations }
end;
|
Спецификаторы свойств
Спецификатор default указывает сохранять значение свойства в файле формы или нет. Если значение свойства совпадает со значением default - значение в файле формы не сохраняется, если значения не равны - сохраняется. Это можно проверить, положив компонент на форму и выбрать правой кнопкой мыши пункт меню "View as Text". Default не устанавливает первоначальное значение свойства к указанному. Это необходимо сделать в конструкторе компонента.
unit OurComponent;
interface
uses
Windows, SysUtils, Classes, Graphics, Forms, Controls;
type
TOurComponent = class(TComponent)
private
{ Private declarations }
FMyInteger: Integer;
protected
{ Protected declarations }
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
published
{ Published declarations }
property MyInteger: Integer read FMyInteger write FMyInteger default 10;
end;
implementation
constructor TOurComponent.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FInteger := 10;
end;
end.
|
Спецификатор nodefault отменяет заданное по умолчанию значение свойства. Этот спецификатор, как правило, используется для отмены заданого по умолчанию значения унаследованного свойства. Например: property AutoSize nodefault; Спецификатор stored указывает когда сохранять в файле формы значение свойства. После stored может стоять true (всегда сохранять), false (никогда не сохранять) или название функции, которая возвращает логический результат.
property OneProp: integer read FOneProp write SetOneProp stored False; property TwoProp: integer read FTwoProp write SetTwoProp stored True; property ThreeProp: integer read FThreeProp write SetThreeProp stored Fuct; |
Спецификатор index мы разберем в следующем выпуске, когда будем говорить о методах доступа к значению свойства. На заметку: Выделять прямоугольный фрагмент текста в редакторе исходного кода можно с помощью комбинации клавиш Alt + Shift + стрелки вверх/вниз.
Создание свойства-массива компонентов.
Автор: Mike Scott У меня есть форма, на которой имеется около 20 компонентов CheckBox, и я хотел бы поочередно ссылаться на них как на элементы массива... Вот способ использования свойства-массива. Здесь использована стандартная техника создания списка компонентов CheckBox в обработчике события OnCreate, позволяющая затем обращаться к ним как именно к массиву компонентов CheckBox.Здесь я приведу два способа "собирания" CheckBox в одном массиве. Один просто собирает все CheckBox на форме. Это простой список, но вы должны убедиться в том, что порядок размещения в нем компонентов такой, каким вы хотите его видеть в массиве. Это нормально в данном случае. Другой способ перечисляет все компоненты согласно их нумерации, заложенной в их имени, но чтобы им воспользоваться, его необходимо раскоментарить. Существует множество других способов. Пусть данный совет послужит вам отправной точкой в изучении интересного вопроса оптимизации кода.
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
FCheckboxes: TList;
function GetCheckbox(Index: integer): TCheckbox;
public
property Checkboxes[Index: integer]: TCheckbox read GetCheckbox;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
var
i: integer;
AComponent: TComponent;
begin
FCheckboxes := TList.Create;
{ ТАКЖЕ: это собирает все CheckBox в порядке очередности }
for i := 0 to ComponentCount - 1 do
if Components[i] is TCheckbox then
FCheckboxes.Add(Components[i]);
{ ИЛИ: если они имеют имя CheckboxNN и вы хотите
разместить их в массиве в том же порядке... }
{for i := 1 to MaxInt do begin
AComponent := FindComponent( 'Checkbox' + IntToStr( i ) ) ;
if AComponent = NIL then break ;
FCheckboxes.Add( AComponent ) ;
end ;}
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
FCheckboxes.Free;
end;
function TForm1.GetCheckbox(Index: integer): TCheckbox;
begin
Result := TCheckbox(FCheckboxes[Index]);
end;
|
Пропорциональное отображение в TScrollBar или TStringGrid.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
// Getting a TScrollbar control to Show a proportional thumb:
procedure TForm1.Button1Click(Sender: TObject);
var
info: TScrollInfo;
begin
FillChar(info, SizeOf(info), 0);
with info do
begin
cbsize := SizeOf(info);
fmask := SIF_PAGE;
nPage := ScrollBar1.LargeChange;
end;
SetScrollInfo(ScrollBar1.Handle, SB_CTL, info, True);
end;
// Same for a TStringGrid
procedure TForm1.Button1Click(Sender: TObject);
var
info: TScrollInfo;
begin
FillChar(info, SizeOf(info), 0);
with info do
begin
cbsize := SizeOf(info);
fmask := SIF_ALL;
GetScrollInfo(StringGrid1.Handle, SB_VERT, info);
fmask := fmask or SIF_PAGE;
nPage := 5 * (nmax - nmin) div StringGrid1.RowCount;
// whatever number of cells you consider a "page"
end;
SetScrollInfo(StringGrid1.Handle, SB_VERT, info, True);
end;
Как получить контекст свойства по его целочисленному значению.
Автор: Ralph Friedman WEB-сайт: http://www.lmc-mediaagentur.de
unit PropertyList;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Buttons;
type
TMyStream = class(TFileStream)
private
FFred: integer;
published
property Fred: integer read FFred write FFred;
end;
type
TFrmPropertyList = class(TForm)
SpeedButton1: TSpeedButton;
ListBox1: TListBox;
procedure SpeedButton1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
FrmPropertyList: TFrmPropertyList;
implementation
{$R *.DFM}
uses
TypInfo;
procedure ListProperties(AInstance: TPersistent; AList: TStrings);
var
i: integer;
pInfo: PTypeInfo;
pType: PTypeData;
propList: PPropList;
propCnt: integer;
tmpStr: string;
begin
pInfo := AInstance.ClassInfo;
if (pInfo = nil) or (pInfo^.Kind <> tkClass) then
raise Exception.Create('Invalid type information');
pType := GetTypeData(pInfo); {Pointer to TTypeData}
AList.Add('Class name: ' + pInfo^.Name);
{If any properties, add them to the list}
propCnt := pType^.PropCount;
if propCnt > 0 then
begin
AList.Add(EmptyStr);
tmpStr := IntToStr(propCnt) + ' Propert';
if propCnt > 1 then
tmpStr := tmpStr + 'ies'
else
tmpStr := tmpStr + 'y';
AList.Add(tmpStr);
FillChar(tmpStr[1], Length(tmpStr), '-');
AList.Add(tmpStr);
{Get memory for the property list}
GetMem(propList, sizeOf(PPropInfo) * propCnt);
try
{Fill in the property list}
GetPropInfos(pInfo, propList);
{Fill in info for each property}
for i := 0 to propCnt - 1 do
AList.Add(propList[i].Name + ': ' + propList[i].PropType^.Name);
finally
FreeMem(propList, sizeOf(PPropInfo) * propCnt);
end;
end;
end;
function GetPropertyList(AControl: TPersistent; AProperty: string): PPropInfo;
var
i: integer;
props: PPropList;
typeData: PTypeData;
begin
Result := nil;
if (AControl = nil) or (AControl.ClassInfo = nil) then
Exit;
typeData := GetTypeData(AControl.ClassInfo);
if (typeData = nil) or (typeData^.PropCount = 0) then
Exit;
GetMem(props, typeData^.PropCount * SizeOf(Pointer));
try
GetPropInfos(AControl.ClassInfo, props);
for i := 0 to typeData^.PropCount - 1 do
begin
with Props^[i]^ do
if (Name = AProperty) then
result := Props^[i];
end;
finally
FreeMem(props);
end;
end;
procedure TFrmPropertyList.SpeedButton1Click(Sender: TObject);
var
c: integer;
begin
ListProperties(self, ListBox1.Items);
for c := 0 to ComponentCount - 1 do
begin
ListBox1.Items.Add(EmptyStr);
ListProperties(Components[c], ListBox1.Items);
end;
end;
end.
Как получить значение свойства в виде варианта по тексту имени свойства.
Автор: Ralph Friedman WEB-сайт: http://www.lmc-mediaagentur.de
unit MorePropInfo;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TFrmMorePropInfo = class(TForm)
Button1: TButton;
Button2: TButton;
ListBox1: TListBox;
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
FrmMorePropInfo: TFrmMorePropInfo;
implementation
{$R *.DFM}
uses
TypInfo;
procedure GetPropertyValues(AObj: TObject; AValues: TStrings);
var
count: integer;
data: PTypeData;
default: string;
i: integer;
info: PTypeInfo;
propList: PPropList;
propInfo: PPropInfo;
propName: string;
value: variant;
begin
info := AObj.ClassInfo;
data := GetTypeData(info);
GetMem(propList, data^.PropCount * SizeOf(PPropInfo));
try
count := GetPropList(info, tkAny, propList);
for i := 0 to count - 1 do
begin
propName := propList^[i]^.Name;
propInfo := GetPropInfo(info, propName);
if propInfo <> nil then
begin
case propInfo^.PropType^.Kind of
tkClass, tkMethod:
value := '$' + IntToHex(GetOrdProp(AObj, propInfo), 8);
tkFloat:
value := GetFloatProp(AObj, propInfo);
tkInteger:
value := GetOrdProp(AObj, propInfo);
tkString, tkLString, tkWString:
value := GetStrProp(AObj, propInfo);
tkEnumeration:
value := GetEnumProp(AObj, propInfo);
else
value := '???';
end;
if propInfo.default = longint($80000000) then
default := 'none'
else
default := IntToStr(propInfo.default);
AValues.Add(Format('%s: %s [default: %s]', [propName, value, default]));
{$80000000 apparently indicates "no default"}
end;
end;
finally
FreeMem(propList, data^.PropCount * SizeOf(PPropInfo));
end;
end;
procedure TFrmMorePropInfo.Button2Click(Sender: TObject);
var
count: integer;
data: PTypeData;
i: integer;
info: PTypeInfo;
propList: PPropList;
propInfo: PPropInfo;
propName: string;
propVal: variant;
tmpS: string;
begin
info := Button2.ClassInfo;
data := GetTypeData(info);
GetMem(propList, data^.PropCount * SizeOf(PPropInfo));
try
count := GetPropList(info, tkAny, propList);
ListBox1.Clear;
for i := 0 to count - 1 do
begin
propName := propList^[i]^.Name;
propInfo := GetPropInfo(info, propName);
if propInfo <> nil then
begin
case propInfo^.PropType^.Kind of
tkClass, tkMethod:
propVal := '$' + IntToHex(GetOrdProp(Button2, propInfo), 8);
tkFloat:
propVal := GetFloatProp(Button2, propInfo);
tkInteger:
propVal := GetOrdProp(Button2, propInfo);
tkString, tkLString, tkWString:
propVal := GetStrProp(Button2, propInfo);
tkEnumeration:
propVal := GetEnumProp(Button2, propInfo);
else
propVal := '...';
end;
tmpS := propVal;
ListBox1.Items.Add(Format('%s: %s [default: %s]', [propName, tmpS, '$'
+ IntToHex(propInfo.default, 8)]));
{$80000000 apparently indicates "no default"}
end;
end;
finally
FreeMem(propList, data^.PropCount * SizeOf(PPropInfo));
end;
end;
end.
Редактор свойства Color с заданными ограничениями.
Автор: Ed JordanРедактор свойства, пример которого приведен ниже, имеет ограничение на устанавливаемые цвета: только clRed, clWhite или clBlue.
unit ClrComps;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes,
Graphics, Controls, Forms, Dialogs, DsgnIntf;
type
TColorComponent = class(TComponent)
private
FColor: TColor;
protected
procedure SetColor(Value: TColor);
public
constructor Create(AnOwner: TComponent); override;
published
property Color: TColor read FColor write SetColor;
end;
{ Это специальный редактор свойства выбора цветов... }
TMyColorProperty = class(TIntegerProperty)
public
function GetAttributes: TPropertyAttributes; override;
function GetValue: string; override;
procedure GetValues(Proc: TGetStrProc); override;
procedure SetValue(const Value: string); override;
end;
procedure Register;
implementation
{ TMyColorProperty }
function TMyColorProperty.GetAttributes: TPropertyAttributes;
begin
Result := [paMultiSelect, paValueList];
end;
function TMyColorProperty.GetValue: string;
begin
Result := ColorToString(TColor(GetOrdValue));
end;
procedure TMyColorProperty.GetValues(Proc: TGetStrProc);
begin
Proc('clRed');
Proc('clWhite');
Proc('clBlue');
end;
procedure TMyColorProperty.SetValue(const Value: string);
var
NewValue: Longint;
begin
if IdentToColor(Value, NewValue) and
((NewValue = clRed) or
(NewValue = clWhite) or
(NewValue = clBlue)) then
SetOrdValue(NewValue);
end;
{ Образец компонента... }
constructor TColorComponent.Create(AnOwner: TComponent);
begin
inherited Create(AnOwner);
FColor := clRed;
end;
procedure TColorComponent.SetColor(Value: TColor);
begin
if (Value = clRed) or
(Value = clWhite) or
(Value = clBlue) then
begin
FColor := Value;
end;
end;
procedure Register;
begin
RegisterComponents('Samples', [TColorComponent]);
RegisterPropertyEditor(TypeInfo(TColor), TColorComponent,
'Color', TMyColorProperty);
end;
end.
|
Способ защиты программы от несанкционированного копирования.
Автор: Павел Озерский WEB-сайт: http://delphibase.endimus.comДробим прогу на exe и несколько DLL-ей, функциям в DLL-ях даем одинаковые рubliс'и, а названия DLL-ям даем длинные, притом начальные части названий должны совпадать, так, чтобы короткие имена отличались только числом после тильды. Вот по коротким-то именам мы их вызывать и будем. А число после тильды, как известно, зависит от порядка копирования файлов на диск, при стирании файлов с "промежуточными" номерами не меняется и при копировании не воспроизводится. Так что, копируя в "неалфавитном порядке", перемежая рабочие DLL-и с "заглушками" (потом их можно стереть), легко можно добиться невоспроизводимости сочетаний длинное-короткое имя, и после несанкционированного копирования EXE будет вызывать не те функции из не тех библиотек. Единственная тонкость: неплохо поставить проверку на длинность имени в самих dll-ях, причем с использованием FindFirstFile, так как часть win32-платформ передает dll-и, вызываемой по короткому имени, как имя ее модуля именно короткое имя. А иначе прога будет легко копироваться из DOS (т.е. только короткие имена) без потери функциональности.
Как защитить запись в DBGrid от удаления.
| - Убирать за собой надо... - раздраженно сказал программист, удаляя папку `mssetup.t |
procedure TForm1.DBGrid1KeyDown(Sender: TObject;
var Key: Word; Shift: TShiftState);
begin
if (ssctrl in shift) and (key=vk_delete) then
key:=0;
end;
|
Доступ к защищенным свойствам.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{*** It is not always necessary to write a new class when you miss the properties you need ***}
{
Let's say, you writing a program with some standard controls on it's form.
One of the components is a TProgressBar.
All components, except the progressbar, are yellow (brrrr!!!)
but it is not possible to change the color of the progressbar the normal way.
There are three things that you can do:
1. Leave it this way
2. Write a new component
3. Try to use WinAPI
OR try this:
}
// Put this on top of your unit
type
TAccessControl = class(TWinControl)
public
property Color;
end;
// and put into TForm1.FormCreate() the following code:
TAccessControl(MyProgressBar).Color:= clYellow;
{
This is possible because TwinControl is the immediate ancestor.
There is also another trick to give a existing class more functionality
without the need of creating a new component, for example:
}
type
// Just a few lines of code and your TLabel
// components on the form has more
// functionality without writing a new class
TLabel = class(stdctrls.TLabel)
public
procedure SayHello();
end;
// ...
procedure TLabel.SayHello();
begin
ShowMessage( 'I just want to say hello (and not hello world!)');
end;
// As you know the Custom version of a class does not
// publish all it's properties, so you can do it the same way as with TLabel.
type
TTheBaseClass = class(UnitName.TTheBaseClass)
public
property Align;
property Color;
property YourProp;
{etc etc}
end;
{
NOTES:
- You can never add new published properties when controls properties are stored
in the DFM file (on a form)
- You can put modified classes into another unit file so that you can add it
AS THE LAST UNIT to the uses clause.
I hope you find it usable.
}
Защита программ от взлома.
| Ползет по улице в дымину пьяный хакер. Еле руки и ноги передвигает. А навстречу ему другой, трезвый: - Слушай, Вась, ты чего? Ведь ты же неделю назад закодировался? - Ага! - Ик! - А я - Ик! - в-вчера к-к-код подобрал... |
Эта статья посвящена достаточно актуальной в настоящее время тематике - защите программ от взлома и нелегального копирования. Этой теме посвящено много статей, одна из наиболее интересных (из тех, которые попались мне) - статья "Защита shareware-программ" Владимира Каталова в Компьютерре Online#240. Он привел ряд советов по написанию shareware программ и я не хочу повторяться - сходите, почитайте.
Рассмотрим некоторые тонкости организации защиты на достаточно популярном примере - предполагаем, что программа защищена некоторым кодом (серийным номером, паролем), который сообщается пользователю после соблюдения им определенных условий. До регистрации в этой программе заблокирован ряд каких либо полезных функций, используется надоедливая реклама или ограничен строк работы. После ввода этого кода производится его проверка и при положительном исходе проверки программа начинает нормально работать. По неизвестной мне причине в большинстве современных программ данная защита сделана однообразно и для ее снятия необходимо 10-15 минут. В этой статье я постараюсь поделиться опытом в построении систем защиты. Могу сразу предупредить - хорошему хакеру противостоять практически бесполезно, да и не нужно - при желании любая защита может быть взломана, это вопрос времени.
Инструментарий хакера. Современный хакер имеет в своем арсенале набор разнообразных утилит для взлома. Их можно подразделить на несколько категорий:
Отладчики. Позволяют прерывать выполнение программы при достижении заранее заданных условий, производить пошаговое выполнение программы, изменять содержимое памяти и регистров и т.п. . Наиболее популярным, удобным и мощным является отладчик SoftICE, который при достаточно примитивном интерфейсе обладает приличными возможностями и весьма стабильно работает. Дизассемблеры. Производят дизассемблирование программы для дальнейшего изучения полученного кода. Один из наиболее популярных - IDA. От дизассемблера достаточно легко защититься - зашифровать или заархивировать программу. Тогда дизассемблируется только архиватор или кодировщик. Средства мониторинга. Это набор утилит, отслеживающих операции с файлами, реестром, портами и сетью. Средства пассивного анализа программы. Показывают разную информацию о программе - извлекают ресурсы, показывают связи, используемые библиотеки. Классический пример - утилита DEPENDS.EXE из комплекта Visual Studio. Она показывает, какие библиотеки используются программой и какие функции импортируются. Прочие утилиты. Их великое множество (можно найти на диске типа "Все для хакера", причем в изобилии). Это разнообразные редакторы, анализаторы ...Наиболее популярны следующие программы мониторинга :
FileMon - утилита, позволяющая вести мониторинг всех операций с файлами. Имеет удобный фильтр, может сохранять отчет в файле. Поэтому нет смысла делать "секретные" файлы где-нибудь в Windows/System - их элементарно найти. RegMon - аналог FileMon, только ведется мониторинг всех операций с реестром. Аналогично файлам, бессмысленно создавать в реестре "секретные" ключи - они сразу бросаются в глаза. PortMon - мониторинг работы с портами ввода/вывода TCP_VIEW - монитор соединений по TCP-IP RegUtils - набор утилит для контроля за реестром - делает копии реестра, позволяет сравнивать копии и просматривать изменения.Утилиты типа FileMon могут резко упростить взлом программы - легко определить место, в котором программа обращается к указанному файлу или ключу реестра.
Основы построения защиты - шаг за шагом
Как ввести регистрационный код. Ввод пароля или регистрационного номера является ответственным делом - хакер постарается отловить адрес памяти, в который будет записан пароль. Затем на обращение по этому адресу ставится точка останова (команда BPM в SoftICE), что позволяет поймать начало процедуры проверки регистрационного кода. Если для ввода используются стандартные элементы ввода Windows, то алгоритм действий хакера можно формализовать и выглядит он примерно так:
Устанавливает точку останова на считывание текста из стандартного элемента ввода (функции GetWindowText, GetGlgItemText модуля KERNEL32) При вызове этой функции анализируем ее параметры и таким образом определяем, по какому адресу будет размещено считываемое значение и ставим обращение к этой области памяти точку останова. А достоверности определенного адреса легко убедиться - после выполнения функции там появится введенная строка При срабатывании этой точки останова мы попадаем в анализатор введенного значения и либо делаем генератор регистрационных ключей, либо ломаем процедуру проверки. И то, и другое весьма просто сделать - достаточно только изучить ассемблер и APIНабор этих действий стандартен и мне не раз попадались подробные руководства типа "Взлом Windows программ - шаг за шагом", ориентированные на продвинутого пользователя.
Рассмотри несколько решений, которые могут затруднить взлом на этом этапе.
Старайтесь как можно меньше применять стандартные функции (особенно API-шные) и компоненты VCL. Так что Assembler, Assembler и еще раз Assembler ... Сущность этого совета надеюсь очевидна - современные дизассемблеры умеют распознавать стандартные процедуры высокоуровневых языков, а API - вообще отдельный разговор - SoftICE обладает изумительной возможностью - загружать символьные имена для любых указанных библиотек (особенно для KERNEL32.DLL) - отладка резко упрощается, т.к. мы видим имена вызываемых функций и можем ставить точки останова на вызов функций по их имени. Применяйте нестандартный способ ввода пароля. Наипростейший путь - написать свой визуальный компонент для ввода регистрационного кода. Он конечно должен будет обрабатывать события от клавиатуры, но момент считывания кода нельзя поймать избитыми методами. Это уже что-то, но есть второй способ взлома, основанный на поиске введенного кода в памяти. Для этого в SoftICE есть удобная команда "S стартовый адрес L длина 'образец'" , которая позволяет найти введенное значение в памяти. Не храните введенный код в одном месте ! Не храните введенный код открытым текстом ! Итак, что же следует сделать. Для начала необходимо завести в программе 5-10 переменных типа STRING и после ввода кода переписать введенное значение в них. Делать это лучше всего не в одном месте, а распределить по программе. Таким образом поиск даст кучу адресов, по которым будет находиться введенный код. Я в таком случае поступаю так - по таймеру создаю в динамической памяти новую строковую переменную, пишу в нее код. Затем на следующем срабатывании таймера создаю новую переменную, переписываю в нее код, а старую уничтожаю. При определенном навыке можно заполонить память значениями введенного кода и сделать поиск почти бесполезным. Причем такое копирование можно совместить с проверкой кода или эмуляцией этой проверки. Затем с эти строками неплохо поделать какие-либо операции - сравнить с чем-нибудь ... Советы 3 и 1 можно объединить - создать свой компонент, который позволит вводить код нестандартным способом с его одновременной шифровкой. Анализ регистрационного кода. Итак, код введен и приняты меры для того, чтобы его было непросто найти (хотя найти то его можно, но это время, навык ...). Теперь следующий шаг - анализ. Поэтому сразу совет: Ни в коем случае не анализируйте код сразу после его ввода. Чем дальше ввод кода от его анализа, тем лучше. Самое разумное - после ввода кода поблагодарить пользователя за сотрудничество и сообщить, что со временем будет выполнена регистрация программы. А анализ кода произвести, например, через 1-2 минуты в совершенно другом месте программы. Не проверяйте код только в одном месте и не пишите для проверки функцию. Достаточно найти и отключить эту проверку, и защита взломана. Если проверок несколько, они разные и распределены по программе, то взлом затрудняется. Не проверяйте пароль одним алгоритмом. Рекомендуется разработать 2-3 алгоритма проверки, например 1-2 цифры должны делиться на 3, а 3-7 наложенные по какому-либо алгоритму на имя пользователя должны дать в сумме 4. Эти две проверки осуществляем в различных местах с достаточно большим временным разносом - взломав первый метод хакер не будет догадываться о существовании еще нескольких, которые проявятся со временем. Ни в коем случае не предпринимайте никаких действий после проверки. По неизвестной причине большинство программ выглядят примерно так
if not(SuperRegCodeCheck) then
begin
ShowMessage('Неверный код, дальнейшая работа невозможна');
halt;
end;
|
В примере некая процедура проверяет код и при несовпадении предпринимает активные действия, которые буквально кричат "вот она где защита !!". Наилучший шаг - выждать день -два (или хотя бы минут 15). Причем все действия по проверке следует как можно дальше отнести от выдачи сообщений и прочих действий, предпринимаемых при обнаружении неправильного кода.
Отвлекающие маневры. Кроме реальных функций проверки кода очень неплохо сделать пару бутафорских - они будут вызываться после ввода кода, проводить активные манипуляции с введенным значением, выдавать сообщения о некорректности введенного кода ... - т.е. отвлекать внимание от реальной проверки. Не храните результатов проверки в переменной и не используйте ее для явного ограничения функций незарегистрированной программы. Классический пример нарушения этого правила
if not(LegalCopy) then
ShowMessage('Сохранение работает только в зарегистрированной версии')
else
SaveFile;
|
Таким образом элементарный анализ показывает, что переменная LegalCopy хранит результат проверки и поставив на нее точку останова можно выловить саму проверку. Отредактировав это значения в памяти можно временно сделать копию "зарегистрированной",а установка точки останова на изменение этой переменной выведет на место ее проверки. Да и взлом сводится к тому, что функция проверки кода урезается до двух команд ассемблера:
MOV [адрес LegalCopy], 1 RET |
Типичная ошибка - выяснили, что копия зарегистрирована и сделали где-нибудь метку. Отловить это достаточно просто (см. описание REGMON и FILEMON). Наилучший способ - сохранить пароль и имя пользователя в том виде, в котором он их ввел. Затем при каждом запуске программы проверять корректность этого кода, но не забывая Совет _11. Ничего не проверяйте сразу при запуске приложения или сразу после считывания сохраненного имени или кода. Помните, что считывание кода и его ввод в окне регистрации идентичны по мерам защиты - дублирование в разных областях памяти, шифрование ...
Выводы: мы устроим проверку кода в нескольких местах программы, при этом применим несколько алгоритмов проверки, не будем использовать API.Кроме того, стоит проделать несколько отвлекающих маневров.
Общие советы по защите программ.
CRC - контрольные суммы. Любой файл, строку или блок данных можно защитить контрольной суммой, которую затем можно рассчитать и сравнить с эталоном. При сравнении с эталоном конечно следует весть осторожно - см. первые 11 советов. Итак, совет 12. Защищайте программы и данные контрольными суммами. Это поможет не только от взлома, но и защитит программы от вируса или внедрения троянца. Применяйте шифровку программ и данных. Очень неплохо сжать программу и данные. Я, например, разработал свой собственный архиватор - RAR-у и ZIP-у он конкуренции не составит, но сжатые им данные разжать очень непросто, придется изрядно повозиться. Да и изменить их проблематично - придется разжать, изменить и сжать. Отлов пошаговой отладки программы. Существует много способов, я в свое время провел целое исследование этого вопроса под DOS, насобирал и придумал не менее 20 методов, но они мало приемлемы под Windows. Самый простой и надежный способ - таймер. При работе программы периодически фиксируем системное время и рассчитываем время работы фрагментов кода между ними. И если 200-400 команд процессора работают 2-3 минуты, то тут есть над чем задуматься. Не определяйте дату и время стандартными способом !! Придумайте что-нибудь оригинальное. Не стоит хранить что-либо секретное в файлах или реестре. Работа с файлами или реестром может быть детально запротоколирована и проанализирована, и все тайное станет явным. Не храните ничего важного открытым текстом, особенно сообщения типа "Это незарегистрированная версия ...", "Введенный пароль не верен ...".Они для хакера - как для быка красная тряпка, и действительно - находим такое сообщение, ставим точку останова на обращение к участку памяти с этим сообщением и получаем возможность поймать момент выдачи этого сообщения.
Советы по созданию меток для организации ограничения по времени
Защита "ограничение времени работы" состоит в том, что программа каким образом фиксирует момент своего первого запуска и работает установленное время (обычно 20-30 дней). После истечения этого срока программа отказывается запускаться. Как проверить текущую дату я уже где-то тут писал - нестандартным способом, например по дате на файлах реестра или свежесозданном своем файле. Весь фокус в другом - как зафиксировать на компьютере дату первого запуска (естественно так, чтобы изничтожение программы и ее повторная установка не давали эффекта). Использование "секретных" файлов в системных папках или изменения в существующих файлах легко отловить при помощи FILEMON. Реестр то же отпадает из-за REGMON. Прочие методы (типа записи в ВООТ сектор ...) тоже неприемлемы - не те времена, по Windows все это не пройдет. Наиболее оригинально (на мой взгляд) прошить дату в саму программу и постоянно обновлять ее на своем сайте (естественно, автоматически). Таким образом отсчет неявно идет от момента скачивания программы с сайта. Есть тут правда и минус - после завершения срока можно повторно скачать эту программу и получить еще 15-20 дней ... . С другой стороны это оригинально - пользователю рано или поздно надоест скачивать эту программу и он или откажется от нее, или купит. Но при этом стоит помнить, что программу можно скачать несколько раз и сравнить варианты, выявив, где лежит дата. Поэтому стоит позаботиться о том, чтобы изменился почти весь файл (например, изменить пару опций компилятора).
Советы по формированию регистрационных кодов
Формирование кодов может вестись по следующим основным направлениям:
Жестко фиксированные коды, прошитые в программу. Их обычно немного и их огласка сводит защиту к нулю. Некий алгоритм проверки кода. Немного лучше первого, но лишь немного. Возьмите за пример код Windows - его знает любой пользователь Алгоритм проверки кода, использующий имя пользователя. Очевидно, что для каждого имени будет уникальный номер (или номера - их может быть несколько, в зависимости от алгоритма). Это уже лучше, но нелегальное распространение держится на эгоизме зарегистрированных пользователей - ничто не мешает им предать имя/пароль огласке, но тогда хотя бы можно вычислить виновника и заблокировать его код Алгоритм проверки кода, использующий имя пользователя и некоторые уникальные или динамически изменяющиеся параметры, например информацию о компьютере. Это надежно, дает привязку к компьютеру, но в наш век постоянных апгрейдов очень неудобен. On-Line регистрация. Состоит в том, что программа в On-Line связывается с сайтом разработчиков (или компании, осуществляющей продужу софта) и передает туда ревизиты пользователя. В ответ программе передается регистрационная информация. Этот метод может и хорош для ряда программ, но на мой взгляд не выдерживает никакой критики по двум соображениям: Никто не может гарантировать, что конкретно передаст программа в Инет. А передать она может все, что угодно - параметры компьютера, пароли, любые данные и т.п. Конкретный пользователь ножет не иметь доступа к Инет. Это особенно важно для программ, работа которых не связана напрямую с Сетью. И зарегистрировать такую программу его практически никто к себе на компьютер не пустит (из соображений п.п. 1)Рекомендовать тут что-либо бесполезно, но я например использую разновидности метода 3.
Программа A4 Proxy для проверки анонимности Proxy.
Оформил: DeeCo
Если надо бысто переключать прокси серверы, проверить их на анонимность, скорость и т.д. воспользуйтесь программой A4Proxy. Ниже написано как настроить свой броузер на работу с этой прогой. Настройка Internet: Explorer: надо зайти Сервис\совойства обозревателя\подключение\настройка сети нужно поставить галочку использовать прокси сервер, ввести адрес и порт на котором работает прокси. Настройка Netscape Navigator: правка/настройки/дополнительные настройки/прокси сервер выбрать "Подключение через прокси сервер", нажать "настройка" и вписать прокси (для HTTP): 127.0.0.1 и порт например: 3128. Настройка Opera: Файл/Настройки/Подключения/Пркси-серверы/ выбрать HTTP и вписать 127.0.0.1 и порт например: 3128. Если надо бысто переключать прокси серверы, проверить их на анонимность, скорость и т.д. воспользуйтесь программой A4Proxy Фишки: Еще при помощи этой проги можно поменять http_referrer. Для этого сначала надо посетить несколько web-страниц, потом открыть закладку "Browser options" и внизу посмотреть поле "Outgoing requestst" т.е. исходящие запросы, это та инфа которую послал бровзер посещенным сайтам, там же есть и "Referer" надо по нему щелкнуть чтобы два поля вверху заполнились, там вписать свое значение например: http://antichat.by.ru/ :), затем нажать кнопку "add" Также можно поменять "User-Agent" но если там что-то типа: Mozilla/4.0 (compatible; MSIE 5.5; Windows 98), то лучше так и оставить и не выделяться, и не забудьте поставить галочку внизу рядом с "Enable HTTP requestst modification" чтобы данные при отправке изменились. Tray menu Favorites - Сдесь находятся, прокси-серверы помеченные как "Дабавлен в список" и одним щелчком мыши можно выбрать активный New on each req - Если выбрать эту функцию то a4proxy будет использовать разные пркси-серверы для каждой web-страницы, это можно сделать и на вкладке "proxy options" Modify Requests - Сдесь можно активировать "Modification List" (список изменений) заголовков запросом Block All Cookies - Выберите, что-бы блокировать все исходящие и всодящие "Куки". Direct Connection - Если вы хотите что бы браузер на прямую обратился к web-странице то используйте Direct Connection Proxy activity Proxy Activity Показывает текущий статус и статистику подключений a4proxy, если все поля пустые это значит что ваш браузер не может соедениться с a4proxy. Proxy Clients - IP адреса в сети, которые используют A4Proxy как прокси-сервер. Этот список можно использовать, что бы добавлять некоторые IP-адреса в stop-лист. Requested Hosts - Имена запрошеных хостов, Names of requested hosts- Этот список можно использовать что бы ассоциировать запросы к удаленному хосту с определенных прокси-серверов, так же, что бы добавить хост в "HOST Stop List". Sockets used - Этот индикатор показывает наибольшее количество каналов данных, используемых одновременно. Sockets Activity - Показывает статистику текущих операций. Proxy check Используется для проверки анонимности и скорости прокси-сервера, список прокси-серверов содержит много полезной информации, проктутите его что бы увидеть все колонки. Кнопка "Check Proxy"- Проверка proxy-сервера, если проверка затянулась то можно нажать "Stop&Save" Reset Data если эта функция активирована, то все данные о прокси-сервере будут сбрасываться при каждой проверке, если не активна(по умолчанию), то данные будут собиратья по принципу "Плохой результат важнее хорошего" Repeats количество повторяющихся проверок Active Requests - количество активных запросов, если в течении длительного времени количество не уменьшается, то рекомендуется нажать кнопку "Stop&Save" Если слева появилась иконка в форме зеленого круга перечеркнутого красным крестиком, это значит что прокси анонимный (скрывает IP) но не соответствует критериям выбранным в закладке "Proxy options". Proxy options Здесь при помощи настроек можно установить фильтры для прокси-сервров, и контролировать их поведение, так же можно изменить порт соединения программы A4Proxy с вашим браузером. прокси-серверы, которые не удовлетворяют требованиям списка, помечаются красным крестиком Первая группа настроек позволяет вам препятствовать использованию прокси серверы, которые посылают следующие заголовки запросов web-сайтам: HTTP_VIA- Это основной фильтр. Параметр HTTP_VIA "говорит" веб-серверу что вы используете прокси сервер. Когда вы вибираете этот фильтр, вы "вычеркиваете" все такие прокси-серверы Присутствие этой переменной в запросе к веб-сайту обнаруживает факт, использования вами proxy-сервера, так же передается информация о proxy- сервере, но не о вашей машине. HTTP_FORWARDED - Аналогичен to HTTP_VIA. Показывает адрес и порт прокси сервера, а так же адрес и порт через который был подан запрос. HTTP_USER_AGENT_VIA - Снова, аналогичный предыдущему. В некоторый случаях показывает через какой прокси был подан запрос. HTTP_CACHE_CONTROL and HTTP_CACHE_INFO - Присутствие любого из этих параметров передает веб-сайту что вы используете прокси, эти параметры содержат информацию о кэше прокси -сервера. HTTP_[PROXY]_CONNECTION- Выключайте в большинстве случаев. Тип соединения "close" показывает, что используется прокси-сервер (Броузет использует соединение типа "Keep-Alive") Use new proxy on each request - Включите, для того что-бы использовать разные прокси при каждом запросе. Таким образом для сервера это будет выглядеть, будто много разных людей получают доступ в одно и то же время. Но это может замедлить соединение. Use n proxies from position... - Вы можете сортировать прокси по разным параметрам, щелкая мышкой в верху колонки Connection: Keep-Alive only - Это два основных вида подключения "Close" и "Keep-Alive". Первый типичен для прокси серверов, второй использыется броузерами для прямого подключения. Некоторые прокси серверы поддерживают "Keep-Alive", это смотрится как прямое соединение броузера. Эта опция ограничиват прокси теми, которые поддерживают такой тип. Наличие информации Proxy_(Connection), в запросе показывает, что он сделан через прокси сервер, если вы хотите убрать эту информацию, выберите эту функцию. Но некоторые веб-сайты, не устанавливают соединения без это1 информации. Кроме того некоторые прокси сами изменяют данные в соответствии со своими настройками Simulate HTTP_X_FORWARDED_FOR_IP (HTTP_CLIENT_IP) - Этот параметр заменяет реальный IP-адрес случайным, Anonymity Check Options: Check for anonymity on each request - Если выбран этот пункт, то A4Proxy проверяет на анонимность текущий прокси сервер, перед отправлением запроса. Check for FTP/HTTPS support on Reset Data - Выберите эту функцию если вы хотите вести полную проверку функций прокси серверов, когда вы проверяете их со сбросом данных(вкладка Proxy Options) Additional Options: Default Proxy - Прокси сервер используемый по умолчанию(если не используется функция Use new proxy on each request, т.е. использование нового прокси при каждом запросе) Proxies in use - Этот индикатор показывает те прокси, которые соответствуют требованиям пользователя. Anonymity rank - Этот индикатор показывает относительный уровень анонимности соединения, в соответствии с выбранными фильтрами и дрю наастройками Browser Port - Порт для входящих HTTP запросов с вашего броузера (и сетевых компьютеров, использующих A4Proxy для соединения с интернет). Вы можете использовать числа от 1024 до 65535 или 80 (рекомендуется оставить по умолчанию) Но если другая программа использует этот же порт, вам следует поменять его и в A4Proxy и в вашем броузере. Check Port - Порт используемый для проверки прокси-сервера на анонимность. Вы можете использовать, то же число что и броузер, или другой. Browser options Во время посещения веб-сайтов, загружая файлы, ваш браузер посылает им, так называемые HTTP request (запросы), информируя о том какая страничка вам нужна, в каждом таком запросе содержится различная информация, необходимая для соединения браузера и веб-сайт: Тип вашей операционной системы (Windows 95/98/Me/2000/XP, и т.д.) и тип используемого браузера, эти данные могут быть использованы для обнаружения "дыр" Accept-Language (Язык/Кодировка) Эта информация может быть использована для ограничения доступа к ресурсам или для др. целей. The Referrer information- позволяет выявить ваши интересы, т.е. откуда вы пришли Cookies- Могут содержать огромное количество информации, как ннапример e-mail, адрес, пароли... Вся эта информация находится в заголовках HTTP запросов. При использовании A4Proxy, который "стоит" между вашим браузером и сайтом, становится возможным изменять или удалять эти данные, для этого надо выбрать функцию "HTTP request modifications" и ввести описание в список изменений, если вы только хотите блокировать "Cooke" то выберите функцию "Block Cookies". Обе эти фукции доступны из меню в трее. Modification list - Содержит список данных HTTP, которые вы хотите изменить или удалить. Variable field- Имена тех переменных, которые вы хотите удалить или изменить (без двоеточия, они будут добавлены автоматически) Replace with... field- Введите здесь новые данные или оставьте поле пустым, если вы хотите удалить эти данные из запросов- конпка "Revove" "Set as defoult"-Нажмите что-бы ипользовать данные по умолчанию, такие как: Accept-Language:en (английский) - язык вашего браузера, Идентификация вас как; User-Agent:Mozilla/4.0 - скрывет тип и версию используемого броузера. Очень просто вносить изменения, используя список исходящих запросов: Список исходящих запросов содержит последние HTTP запросы, разделенные пустыми линиями. Самые последние помещены вверх. Этот список очень удобный, он позволяет немедленно увидеть, какие данные в настоящий момент присутствуют в запросе, и легко удалить или поменять их. Когда вы выберите данные в списке исходящих запросов поля: "Variable" и "Replace with..." автоматически заполняются, затем вы можете изменить содержание и добавить в список исходящих. Некоторые наиболее часто встречающиеся данные: GET, POST, CONNECT - эти данные не отноятся к переменным HTTP, это названия методов запроса, т.о. не изменяйте это поле. Двоеточие разделяет переменную. "Accept:" - Показывает типы файлов которые могут быть приняты. Информирует удаленный компьютер о типе информации к которой вы получаете доступ. "Accept-Language:" - Информирует удаленный компьютер о языке, используемом вашим броузером. "Accept-Encoding:" - Информирует удаленный компьютер кодировке, принимаемой вашим броузером. "If-Modified-Since:" - Загружвет файл, если только он был изменен с [дата/время] "User-Agent:" - Содержит информацию о вашей ОС и типе броузера. "Host:" - Запрошенный хост. Не удаляйте и не изменяйте этот параметр, запрос пропадет "Proxy-Connection:" - Тип соединения. В большинстве случаев не надо удалять, т.к. эти данные изменяются прокси сервером. "Pragma:"- Метод использования прокси сервером кэша. В большинсте случаев присутствие этих данных говорит о подключении через прокси сервер. Security&Redirection CLIENT-PROXY Server Associations - Список клиентов в сети, proxy-серверов сопоставленных с ними. Если IP-адрес клиента(машины сделавшей запрос) находится в этом списке, то HTTP запрос перенаправляется proxy-серверу присвоенному этому IP. Этот режим позволяет например, использовать особый proxy-сервер для каждого компьютера в локальной сети. Чтобы сопоставить машину с определенным прокси сервером выберите клиента(компьютер в LAN-Local area network т.е. локальная сеть) из списка активных proxy-серверов и нажмите "add" (добавить) HOST-PROXY Server Associations - Список удаленных компьютеров и прокси-серверов сопоставленных с ними. Если запрсивший хост содержится в списке, то запрос перенаправляется соответствующему proxy- серверу. Этот режим позволяет например, использовать особый proxy-сервер для определенного хоста. Для то что бы сопоставить хост и proxy-сервер, выберите хост из списка хостов, которые были запрошены (Закладка Proxy Activity : Requested Hosts) и прокси сервер из списка proxy-серверов (Proxy Check tab), нажмите "add" Client Stop List- Все запросы с этих IP-адресов блокируются. HOST Stop List- Все запросы сделанные к этим IP-адресам блокируются программой A4Proxy. Полезно для блокировки баннеров CLIENT Allowed List- Этот параметр полезен для администраторов, которые открывают доступ в интернет всем иашинам в локальной сети, используя A4Proxy. Все адреса которых нет в этом списке блокируются Notify in Browser Response- Когда эта функция включена , машины присутствующие "CLIENT Stop List" получают соответствующее предупреждение в их браузерах, когда пытаются получить доступ в интернет. Аналогичное уведомление получает пользователь, удаленного хоста, при попытке получить доступ к ресурсам машины, находящейся в этом списке. Enable Stop and Associations Lists- Включите эту функцию, что бы активировать вышеперечисленные настройки. Если программа не работает Возможные причины: -Все Proxies повреждены (нерабочие) -Неправилная настройка Если вы проверили все прокси сервера в базе данных, и все из них показаны с Красным Крестом ,то что может быть неправильно: 1. Firewall на вашей машине(компьютере), блокирует входящий трафик к A4Proxy - это функционирует, как будто этот прокси посылает запросы к себе через proxies, чтобы проверить их надежно. Если firewall блокирует входящий трафик на порт 80 (или порт на который настроена программа в разделе Proxy Options-Listen port 8080 или 3128 - но 80 предпочтительней), проверка не будет работать. 2. Ваша машина(компьютер) не имеет публичный IP адрес, который является видимым в Интернете: Пожалуйста запустите Тест Совместимости(Compatibility Test) в меню Помощи(Help). 3. Присутствие программного обеспечения, которое использует порт 80 (или порт который установлен в A4Proxy для прослушивания).Пожалуйста запустите Тест Совместимости(Compatibility Test) в меню Помощи (Help). 4. Ваш поставщик Интернета блокирует доступ общественным прокси серверам. Введите в строку адрес и номер порта одного из прокси серверов непосредственно в вашем browser вместо 127.0.0.1, и см., можете ли Вы соединяться с любым вэбсервером в этой конфигурации. Повторите это с различным proxies. Если Вы можете соединиться с websites, ваш поставщик не блокирует proxies. 5. Ваш поставщик может блокировать входящий трафик на некоторых портах (своего рода firewall, используемый поставщиком). 6. Возможно включена функция Direct Conneckion, дотупная в меню "Options" и в tray menu Вы не можете соедениться с любым сайтом. Если, после ввода в настройках браузера 127.0.0.1 порта 80 Вы не можете подсоедениться к любому сайту, возможная причина, что порт 80 используется другой программой(приложением). Пожалуйста запустите Тест Совместимости(Compatibility Test) в меню Помощи(Help). Фактически, это - адрес вашей собственной машины(компьтера). Ваш browser теперь посылает запросы о страницах и файлах не к website непосредственно, а к A4Proxy, который, в свою очередь, переадресовывает все эти запросы анонимным прокси серверам. Связь между A4Proxy и вашим browser требует, чтобы они оба использовали один и тот же порт: в этом случае, 80. Однако, если порт уже занят в соответствии с другой программой, это предотвратит связь между browser и A4Proxy, и Вы не будете способны подключиться к любому websites. Удостовертесь, что ваша машина(компьютер) не управляет другим местным(локальным) прокси сервером, или Web сервером (MS Front Page Personal Web Server extension), или WinGate и т.д. - любое программное обеспечение, которое использует порт 80, предотвратит ваш browser от "наблюдения" A4Proxy.Проверка попадания точки в прямоугольник (TPoint в TRect).
Автор: Lipskiy WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Проверка попадания точки в прямоугольник (TPoint в TRect)
Проверка - входят ли координаты точки TPoint в область,
ограниченную координатами прямоугольника TRect.
P.S. Вероятно, есть стандартная, но я не нашел.
Зависимости: Windows
Автор: lipskiy, lipskiy@mail.ru, ICQ:51219290, Санкт-Петербург
Copyright: Собственное написание (lipskiy)
Дата: 26 июня 2002 г.
***************************************************** }
function PointIntoRect(Point: TPoint; Rect: TRect): boolean;
begin
Result :=
(Point.x >= Rect.Left) and
(Point.x <= Rect.Right) and
(Point.y >= Rect.Top) and
(Point.y <= Rect.Bottom);
end;
Находится ли точка внутри многоугольника.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
function PtInRgn(TestPolygon : array of TPoint; const P : TPoint): boolean;
var
ToTheLeftofPoint, ToTheRightofPoint : byte;
np : integer;
OpenPolygon : boolean;
XIntersection : real;
begin
ToTheLeftofPoint := 0;
ToTheRightofPoint := 0;
OpenPolygon := False;
{Prufen ob das Polygon geschlossen ist}
{tests if the polygon is closed}
if not ((TestPolygon[0].X = TestPolygon[High(TestPolygon)].X) and
(TestPolygon[0].Y = TestPolygon[High(TestPolygon)].Y)) then
OpenPolygon := True;
{Tests fur jedes Paar der Punkte, um zu sehen wenn die Seite zwischen
ihnen, die horizontale Linie schneidet, die TestPoint durchlauft}
{tests for each couple of points to see if the side between them
crosses the horizontal line going through TestPoint}
for np := 1 to High(TestPolygon) do
if ((TestPolygon[np - 1].Y <= P.Y) and
(TestPolygon[np].Y > P.Y)) or
((TestPolygon[np - 1].Y > P.Y) and
(TestPolygon[np].Y <= P.Y))
{Wenn es so ist} {if it does}
then
begin
{berechnet die x Koordinate des Schnitts}
{computes the x coordinate of the intersection}
XIntersection := TestPolygon[np - 1].X +
((TestPolygon[np].X - TestPolygon[np - 1].X) /
(TestPolygon[np].Y - TestPolygon[np - 1].Y)) * (P.Y - TestPolygon[np - 1].Y);
{Zahler entsprechend verringern}
{increments appropriate counter}
if XIntersection < P.X then Inc(ToTheLeftofPoint);
if XIntersection > P.X then Inc(ToTheRightofPoint);
end;
{Falls das Polygon offen ist, die letzte Seite testen}
{if the polygon is open, test for the last side}
if OpenPolygon then
begin
np := High(TestPolygon); {Thanks to William Boyd - 03/06/2001}
if ((TestPolygon[np].Y <= P.Y) and
(TestPolygon[0].Y > P.Y)) or
((TestPolygon[np].Y > P.Y) and
(TestPolygon[0].Y <= P.Y)) then
begin
XIntersection := TestPolygon[np].X +
((TestPolygon[0].X - TestPolygon[np].X) /
(TestPolygon[0].Y - TestPolygon[np].Y)) * (P.Y - TestPolygon[np].Y);
if XIntersection < P.X then Inc(ToTheLeftofPoint);
if XIntersection > P.X then Inc(ToTheRightofPoint);
end;
end;
if (ToTheLeftofPoint mod 2 = 1) and (ToTheRightofPoint mod 2 = 1) then Result := True
else
Result := False;
end; {PtInRgn}
Запись буфера BDE на диск.
| Can't write: disk full. (R)etry, (F)ormat, (C)all #911? |
DbiSaveChanges сохраняет на диске все обновления, находящиеся в буфере таблицы, связанной с курсором (hDBICur). Может быть вызвана из любого места программы. Например, можно при каждом обновлении записи сохранять на диске все изменения (добавьте dbiProcs в список используемых модулей):
procedure TForm1.Table1AfterPost(DataSet: TDataSet); begin DbiSaveChanges(Table1.handle); end; |
В Delphi это может быть использовано таким образом (добавьте dbiProcs в список используемых модулей):
procedure TForm1.FormCreate(Sender: TObject); begin Application.onIdle := UseIdle; end; procedure Tform1.UseIdle(Sender: TObject; var Done: Boolean); begin DbiUseIdleTime; end; |
В случае, если в таблице выполняется не слишком много изменений, клиент может использовать вызов DbiSaveChanges после каждого постинга или же "повесить" на таймер вызов DbiUseIdleTime.
Как поместить картинку в заголовок TListView.
| Программисты (он и она) лежат в постели и отдыхают после занятий любовью. Она: - Не хочешь повторить процедуру? Он: - Функция еще не вернула значения. |
Иногда бывает полезно в заголовке колонки показывать стрелочку, чтобы информировать пользователя, по какой колонке идёт сортировка. Добавьте следующий код в форму:
procedure TForm1.SetColumnImage( List: TListView; Column,
Image: Integer; ShowImage: Boolean);
var
Align, hHeader: integer;
HD: HD_ITEM;
begin
hHeader := SendMessage(List.Handle, LVM_GETHEADER, 0, 0);
with HD do
begin
case List.Columns[Column].Alignment of
taLeftJustify:
Align := HDF_LEFT;
taCenter:
Align := HDF_CENTER;
taRightJustify:
Align := HDF_RIGHT;
else
Align := HDF_LEFT;
end;
mask := HDI_IMAGE or HDI_FORMAT;
pszText := PChar(List.Columns[Column].Caption);
if ShowImage then
fmt := HDF_STRING or HDF_IMAGE or HDF_BITMAP_ON_RIGHT
else
fmt := HDF_STRING or Align;
iImage := Image;
end;
SendMessage(hHeader, HDM_SETITEM, Column, Integer(@HD));
end;
|
Картинки берутся из списка SmallImages. Вам надо будет вызвать эту функцию для каждой колонки и установить ShowImage в TRUE для той колонки, которую Вы будете сортировать. Сделать это можно в функции OnColumnClick():
procedure TForm1.ListView1ColumnClick(Sender: TObject;
Column: TListColumn);
var
i: integer;
begin
// Это Ваша собственная функция сортировки
CustomSort( @CustomSortProc, Column.index );
// Этот цикл отображает иконку в выбранной колонке.
for i := 0 to ListView1.Columns.Count-1 do
SetColumnImage( ListView1, i, 0, i = Column.index );
end;
|
Проблема: Изменение размера колонки генерирует сообщение WM_PAINT, которое стирает картинку, поэтому Вам прийдётся переопределить WM_PAINT и вызвать SetColumnImage снова.
Использовался компонент TApplicationEvents в delphi 5.
В DBGrid напротив некоторых строк можно поставить галочку.
| Идут курсы Майкрософт по Win'98. Инструктор (И) читает лекции чайникам-слушателям, среди которых случайно затесался программер. (П). (И) Windows - это абсолютно надежная система, но если все же что-то случится, то для этих целей существует утилита Scandisk, которая работает абсолютно безупречно. Главное: не вздумайте отключать автоматический запуск этой утилиты после сбоев в работе. Вот недавно был такой случай: один программист удалил Scandisk, и когда Windows'98 случайно повисла, то после перезагрузки жесткий диск был поврежден, а неисправность не была устранена. А на другом компьютере, где была установлена эта утилита, после сбоя в работе Windows'98 проверила диск, поставила новые параметры и для подстраховки перезагрузила компьютер. (П) Ага, знаю я этот комп, до сих пор Sсаndisк'ом проверяется, ставит новые параметры и для подстраховки перезагружается. |
На сервере - таблица Advertis.DB, первичный ключ ID - autoincrement. Ha локальном диске - таблица Founds.DB, с полем Advertis: integer, по которому есть индекс, и.
tblFounds.IndexFieldNames = 'Advertis' |
Ha гриде:
procedure TMainForm.dbgWorkDblClick(Sender: TObject);
begin
TriggerRowSelection;
end;
procedure TMainForm.TriggerRowSelection;
begin
if dmFile.AdvertisCount <> 0 then
begin
with dmFile do
if not tblFounds.FindKey([tblAdvertisID.Value]) then
tblFounds.AppendRecord([tblAdvertisID.Value])
else
tblFounds.Delete;
dbgWork.Refresh;
end;
end;
procedure TMainForm.dbgWorkDrawColumnCell(Sender: TObject;
const Rect: TRect; DataCol: Integer; Column: TColumn;
State: TGridDrawState);
begin
if DataCol = 0 then
with dmFile, dbgWork.Canvas do
begin
FillRect(Rect); {clear the cell}
if tblFounds.FindKey([tblAdvertisID.Value]) then
TextOut(Rect.Left, Rect.Top, 'ь');
end;
end;
|
Оказывается, я переопределял рисование грида, a не вычислял поле. Не помню точно, но кажется, чтобы не перечитывать таблицу на каждый даблклик, a только перерисовать грид.
А колонка для галки в гриде определялась так:
with dmFile, dbgWork.Columns do
begin
BeginUpdate;
Clear;
{check mark}
nc := Add;
nc.Width := 14;
nc.Font.name := 'Wingdings';
nc.Font.Size := 11;
nc.Alignment := taRightJustify;
nc.Title.Caption := 'ю';
nc.Title.Font.name := 'Wingdings';
nc.Title.Font.Size := 10;
nc.Title.Alignment := taCenter;
{skip определения остальных колонок}
EndUpdate;
end;
|
Вроде всё. Ну, как напечатать/обработать только помеченное, сам разберёшься. У меня там накручено чего-то с фильтрами, думаю, можно проще. Что касается других способов - можно вместо временной таблицы попользовать список, массив или in-memory table.
Имплантация таймера в компонент.
Автор: Mike Scott Я не могу разобраться как мне вставить TTimer в мой компонент и получить доступ к его методам и свойствам. Я нигде не могу найти пример такого использования таймера. Кто-нибудь может мне помочь?Я просто создал это для вас:
type
TMyControl = class(TCustomControl)
private
FTimer: TTimer;
procedure TimerEvent(Sender: TObject);
public
constructor Create(AOwner: TComponent); override;
end;
constructor TMyControl.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FTimer := TTimer.Create(Self);
FTimer.Interval := 100; { 100 ms }
FTimer.OnTimer := TimerEvent;
end;
procedure TMyControl.TimerEvent(Sender: TObject);
begin
{ вот ваш обработчик события, который вызывается при каждом
срабатывании таймера - делайте здесь все что вам необходимо }
end;
|
Легче не бывает! Правда, есть за что любить Delphi?
Квадратное уравнение.
unit SqRoot_;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, OleCtrls;
type
TForm1 = class(TForm)
Edit1: TEdit;
Edit2: TEdit;
Edit3: TEdit;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
Label4: TLabel;
Button1: TButton;
Label5: TLabel;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
// решает квадратное уравнение
procedure SqRoot(a, b, c: real; var x1, x2: real; var ok: boolean);
{ a,b,c - коэффициенты уравнения
x1,x2 - корни уравнения
ok = True - решение есть
ok = False - решения нет }
var
d: real; // дискриминант
begin
d := Sqr(b) - 4 * a * c;
if d < 0
then
ok := False // уравнение не имеет решения
else
begin
ok := True;
x1 := (-b + Sqrt(d)) / (2 * a);
x2 := (b + Sqrt(d)) / (2 * a);
end;
end;
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
var
k1, k2: real; // корни уравнения
rez: boolean; // True - решение есть, False - решения нет
mes: string; // сообщение
begin
SqRoot(StrToFloat(Edit1.Text), StrToFloat(Edit2.Text),
StrToFloat(Edit3.Text), k1, k2, rez);
if rez then
mes := 'Корни уравнения' + #13 +
'x1=' + FloatToStrF(k1, ffGeneral, 4, 2) + #13 +
'x2=' + FloatToStrF(k2, ffGeneral, 4, 2) + #13
else
mes := 'Уравнение не имеет решения';
label5.Caption := mes;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
winhelp(Form1.Handle, 'sqroot.hlp', HELP_CONTEXT, 1);
end;
end.
Качественно уменьшить изображение.
В Delphi изменять размеры изображения очень просто, используя CopyRect:
procedure TForm1.Button1Click(Sender: TObject); begin Form1.Canvas.Font.Size := 24; Form1.Canvas.TextOut(0, 0, 'Text'); Form1.Canvas.CopyRect(Bounds(0, 50, 25, 10), Form1.Canvas, Bounds(0, 0, 100, 40)); end; |
Но этот способ не очень хорош для уменьшения не маленьких картинок – мелкие детали сливаются. Для частичного устранения этого недостатка при уменьшении изображения в четыре раза я беру средний цвет в каждом квадратике 4X4. К чему это приводит, посмотрите сами.
procedure TForm1.Button1Click(Sender: TObject);
var
x, y: integer;
i, j: integer;
r, g, b: integer;
begin
Form1.Canvas.Font.Size := 24;
Form1.Canvas.TextOut(0, 0, 'Text');
for y := 0 to 10 do
begin
for x := 0 to 25 do
begin
r := 0;
for i := 0 to 3 do
for j := 0 to 3 do
r := r + GetRValue(Form1.Canvas.Pixels[4*x+i, 4*y+j]);
r := round(r / 16);
g := 0;
for i := 0 to 3 do
for j := 0 to 3 do
g := g + GetGValue(Form1.Canvas.Pixels[4*x+i, 4*y+j]);
g := round(g / 16);
b := 0;
for i := 0 to 3 do
for j := 0 to 3 do
b := b + GetBValue(Form1.Canvas.Pixels[4*x+i, 4*y+j]);
b := round(b / 16);
Form1.Canvas.Pixels[x,y+50] := RGB(r, g, b)
end;
Application.ProcessMessages;
end;
end;
|
Модуль, позволяющий в Delphi осуществить форму запроса для компонентов DBGrid.
| Автор: Rick Rutt |
| Визит министра здравоохранения (МЗ) в одну из психиатрических лечебниц. Осмотрев палаты, процедурные залы, столовую МЗ изьявляет желание проверить, как содержатся буйнопомешанные больные, опасные для окружающих. Спускаются на 1-й этаж, Главный врач (ГВ) отпирает стальную кованую дверь. За дверью длинный коридор. МЗ переходит от камеры, к камере, читает таблички, иногда заглядывает внутрь. Около одной из камер. МЗ: - Так-так. Острая паранойя, OS/2 Warp, мания величия... Заглядывает в окошко. Угрюмый тип, увидев МЗ, начинает метаться по камере, крича: "Ла-а-меры!!! Ла-а-а-меры!!! Суксь, Суксь МастДайная!!!" МЗ: (Обращается к ГВ) Часто он так? ГВ: Как новое лицо увидит, сразу приступ... Идут дальше. МЗ: Так-так. Острая паранойя. UNIX, мания величия... Заглядывает в окошко. Угрюмый тип, оторвавшись от созерцания собственных рук, поворачивается, и расплывшись в улыбке, изрекает: "Истинная многозадачность, полный контроль, Рулез Форева!" МЗ: (Обращается к ГВ) Тихий какой! Выздоравливает? ГВ: Нет, временное улучшение. (Повернувшись к окошку) - NT! Больной, вскочив с кровати, начинает метаться по камере, крича: "А-а-а!!! Вытесняющая многозадачность!!! Исходные тексты!!! Суксь!!! Ла-а-а-меры!!!" Идут дальше. МЗ: Так-так. Острая паранойя. Windows'95, мания величия. Заглядывает в окошко... Камера пуста. МЗ: (Недоумённо поворачивается к ГВ) - А где же больной? На процедурах? ГВ: Видите ли... Только поймите нас правильно... Бухгалтерия у нас на Excel, личные дела больных на Access... |
Имейте в виду, что модуль охраняется авторским правом, как требует того лицензия, и желательно, чтобы вы сохранили полностью весь код данного модуля. Имейте в виду, что авторские условия допускают безвозмездное использование данного модуля для любых целей.
unit Db_QBF; { Форма запроса базы данных }
{ Все права защищены. Автор Rick Rutt.
Данный модуль может без какой-либо оплаты быть использован в программе,
скопирован или распространен любым человеком и для любой цели, если все
копии данного модуля сохраняют это авторское уведомление.
Автор предоставляет разрешение каждому для создания производного кода, если
каждая производная работа содержит авторское уведомление и строку
"Части данной работы основываются на Db_QBF.PAS, созданным Rick Rutt."
}
{ Данный модуль обеспечивает простую, но эффективную форму запроса
для доступа приложений к базам данных, используя Borland Delphi.
Данный модуль также располагает сервисом Sort By Form (форма сортировки).
Форма запроса отображает модальное диалоговое окно с компонентом StringGrid,
содержащим искомые поля, полученные при вызове DbGrid. Пользователь может
ввести точную величину поиска для любого количества полей и использовать
функцию drag and drop (перетащи и брось) для изменения порядка сортировки полей.
(Только тех полей, которые содержат искомые величины, влияющие на сортировку.)
Когда пользователь щелкает в диалоговом окне на кнопку OK, данный модуль
модифицирует значение свойства IndexFieldNames компонента DbGrid, применяет
диапазон поиска (точные величины), и обновляет данные.
В случае, если пользователь не указывает ни одной из величин поиска,
данный модуль очищает значение свойства IndexFieldNames компонента DbGrid,
очищает диапазон поиска и обновляет данные.
Сервис Sort By Form работает аналогично, за исключением того,
что не принимает в расчет величину поиска, введенную пользователем. Пользователь
пользуется функцией drag and drop (перетащи и брось) для установления порядка
сортировки и затем нажимает на кнопку OK. Данный модуль модифицирует
значение свойства IndexFieldNames компонента DbGrid, очищает диапазон поиска
и обновляет данные.
}
{ Создайте соответствуюшую форму диалога, используя меню "File/New.../Dialogs"
и выбрав пункт "Standard Dialog Box". Разместите на форме компонент StringGrid
(Вы найдете его в палитре компонентов на странице "Additional").
Установите следующие размеры StringGrid: высота 161 и ширина 305.
И, наконец, замените исходный код новой формы (PAS-файл) данным модулем.
}
interface
uses WinTypes, WinProcs, Classes, Graphics, Forms, Controls, Buttons,
StdCtrls, ExtCtrls, Grids, DBGrids;
{ Следующие две процедуры обеспечивают механизм доступа
сервисов данного модуля.
Кнопка (или пункт меню) вызывают процедуру,
передавая ей в качестве аргумента DbGrid. (Не забудьте добавить строку
"uses Db_QBF;" в секцию реализации модуля вызова форм.)
Ограничение: компонент DbGrid должен ссылаться на DataSource,
который, в свою очередь, ссылается на DataSet, работающий с
таблицой. Данный модуль не поддерживает запрос напрямую к
DataSet ввиду отсутствия свойства IndexFieldNames.
}
procedure QueryByForm(grid: TDbGrid);
procedure SortByForm(grid: TDbGrid);
{ Следующая секция управляется средой Delphi. }
type
TdlgQBF = class(TForm)
OKBtn: TBitBtn;
CancelBtn: TBitBtn;
HelpBtn: TBitBtn;
gridQBF: TStringGrid;
procedure OKBtnClick(Sender: TObject);
procedure CancelBtnClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
dlgQBF: TdlgQBF;
implementation
{ Следующая секция пишется программистом
с помощью среды Delphi. }
uses Dialogs, Db, DbTables;
{$R *.DFM}
const
qbfRowHeight = 16;
qbfColWidth = 150;
qbfFieldLabel = '<<Поле>>';
qbfValueLabel = '<<Значение>>';
qbfQueryCaption = 'Запрос для таблицы ';
qbfSortCaption = 'Порядок сортировки для таблицы ';
var
{ Объявим некоторые элементы управления, участвующие
в QBF-диалоге при нажатии кнопки OK. }
CallingGrid: TDbGrid;
CallingMode: (modeQuery, modeSort);
procedure SetupAndShowForm;
{ Инициализация формы, обеспечивающей визуализацию
работы двух объявленных выше процедур }
var
i, j, n: integer;
tbl: TTable;
f: TField;
begin
n := CallingGrid.FieldCount;
if n <= 0 then
begin { Вместо вывода сообщений могут генерится исключительные ситуации }
MessageDlg(
'При обращении к DbGrid, модуль Db_QBF не обнаружил полей',
mtWarning, [mbOK], 0);
end
else if CallingGrid.DataSource = nil then
begin
MessageDlg(
'При обращении к DbGrid, модуль Db_QBF не обнаружил ссылки на DataSource',
mtWarning, [mbOK], 0);
end
else if CallingGrid.DataSource.DataSet = nil then
begin
MessageDlg(
'При обращении к DbGrid, модуль Db_QBF обнаружил подключенный
DataSource без ссылки на DataSet',
mtWarning, [mbOK], 0);
end
else if not (CallingGrid.DataSource.DataSet is TTable) then
begin
MessageDlg(
'При обращении к DbGrid, модуль Db_QBF обнаружил подключенный
DataSource с сылкой на DataSet, не являющийся таблицей.',
mtWarning, [mbOK], 0);
end
else
with dlgQBF.gridQBF do
begin
{ Данные свойства могут быть изменены и в режиме проектирования }
DefaultRowHeight := qbfRowHeight;
Scrollbars := ssVertical;
ColCount := 2; { Для режима сортировки необходимы две пустые колонки }
{ Данные свойства должны быть установлены во время выполнения программы }
RowCount := Succ(n);
Cells[0, 0] := qbfFieldLabel;
Options := Options + [goRowMoving];
tbl := TTable(CallingGrid.DataSource.DataSet);
if CallingMode = modeQuery then
begin
dlgQBF.Caption := qbfQueryCaption + tbl.TableName;
Cells[1, 0] := qbfValueLabel;
Options := Options + [goEditing];
{ Позволяем пользователю ввести значение }
DefaultColWidth := qbfColWidth;
end
else
begin
dlgQBF.Caption := qbfSortCaption + tbl.TableName;
Cells[1, 0] := '';
{ Ввод "пустышки" для первой, нефункциональной колонки }
Options := Options - [goEditing]; { Убираем возможность редактирования }
DefaultColWidth := (2 * qbfColWidth);
{ Этим трюком мы помещаем две пустых секции над одной колонкой }
end;
j := 0; { Фактическое число полей, показываемое пользователю }
for i := 1 to n do
begin
f := CallingGrid.Fields[Pred(i)];
if f.DataType in [ftBlob, ftBytes, ftGraphic, ftMemo, ftUnknown,
ftVarBytes] then
RowCount := Pred(RowCount) { Игнорируем неиндексируемые поля }
else
begin
Inc(j);
Cells[0, j] := f.FieldName;
Cells[1, j] := ''; { Сбрасываем искомую величину }
end;
end;
dlgQBF.HelpBtn.Visible := False; { Помощь, понятно, отсутствует... }
dlgQBF.ShowModal;
end; { with dlgQBF.gridQBF }
end;
procedure QueryByForm(Grid: TDbGrid);
begin
CallingGrid := Grid; { Сохраняем для использования при нажатии на кнопку OK }
CallingMode := modeQuery;
SetupAndShowForm;
end;
procedure SortByForm(Grid: TDbGrid);
begin
CallingGrid := Grid; { Сохраняем для использования при нажатии на кнопку ОК }
CallingMode := modeSort;
SetupAndShowForm;
end;
procedure TdlgQBF.CancelBtnClick(Sender: TObject);
begin
{ Просто прячем диалог, не делая никаких изменений в вызывающем Grid'е. }
dlgQBF.Hide;
end;
procedure TdlgQBF.OKBtnClick(Sender: TObject);
var
flds, sep, val: string;
i, n, nfld: integer;
begin
flds := ''; { Список полей, разделенных ';'. }
sep := ''; { Разделитель ';' ставится после добавления первого поля. }
nfld := 0; { Количество полей в списке. }
with dlgQBF.gridQBF do
begin
n := Pred(RowCount);
if n > 0 then
for i := 1 to n do
begin
val := Cells[1, i];
{ Значение поиска, введенное пользователем (если имеется) }
if (CallingMode = modeSort)
or (val <> '') then
begin
flds := flds + sep + Cells[0, i];
sep := ';';
nfld := Succ(nfld);
end;
end;
with CallingGrid.DataSource.DataSet as TTable do
begin
IndexFieldNames := flds;
if (CallingMode = modeSort)
or (flds = '') then
begin
CancelRange;
end
else
begin
SetRangeStart;
for i := 1 to n do
begin
val := Cells[1, i];
if val <> '' then
begin
FieldByName(Cells[0, i]).AsString := val;
end;
end;
{Устанавливаем конец диапазона так, чтобы он соответствовал его началу}
SetRangeEnd;
for i := 1 to n do
begin
val := Cells[1, i];
if val <> '' then
begin
FieldByName(Cells[0, i]).AsString := val;
end;
end;
ApplyRange;
end;
Refresh;
end; { with CallingGrid.DataSource.DataSet }
end; { with dlgQBF.gridQBF }
dlgQBF.Hide;
end;
end.
|
Параметризованные запросы.
Как мне передать переменную в запрос? Сначала вы должны создать запрос, использующий переменную.Select Test."FName", Test."Salary Of Employee" From Test Where Test."Salary of Employee" > :valПримечание: Если вы просто пишете имя поля как "Salary of Employee", вы получите ошибку "Capability Not Supported". Это должно быть просто Test."Salary of Employee". В нашем случае имя переменной "val", но это может быть любое другое (естественно). Затем вы переходите к свойству TQuery's params и устанавливаете параметр "val" в зависимости от требуемого типа. В нашем примере мы используем тип integer.
Затем вы должны создать код, устанавливающий значение параметра. Для задания значения мы будем использовать компонент TEdit.
procedure TForm1.Button1Click(Sender: TObject);
begin
with Query1 do
begin
Close;
ParamByName('val').AsInteger := StrToInt(Edit1.Text);
Open;
end;
end;
|
SELECT * FROM CUSTOMER WHERE Company LIKE :CompanyName
Код Delphi:
procedure TForm1.Button1Click(Sender: TObject);
begin
with Query1 do
begin
Close;
ParamByName('CompanyName').AsString := Edit1.Text + '%';
Open;
end;
end;
|
Вот демонстрация такого способа:
ParamByName('CompanyName').AsString := Edit1.Text + '%';
|
Или, в качестве альтернативы:
Params[0].AsString := Edit1.Text + '%'; |
Хитрость шаблона - в конкатенирующем знаке процента в конце параметра.
Проблемы со шрифтами у QuickReport.
Я использую Delphi 2.0 и QuickReports 1.1. Я создал ОЧЕНЬ сложный (графически, во всяком случае) отчет и только что обнаружил, что это не выводится как положено на экране и на принтере во время выполнения программы (хотя это и корректно отображается в окне предварительного просмотра в режиме проектирования). Ошибка возникает только в том случае, если в Windows 95 установлены большие (LARGE) системные шрифты! Ну и что мне теперь прикажете делать? У меня тоже была такая же серьезная проблема, но только при печати под Win 95 на офисный HP 4M и при просмотре отчета под NT 4.0. Но то же самое приложение у меня прекрасно работало под NT 3.51 SP5.Я видел дискуссию по поводу этой ошибки, возникающей в GDI коде под NT 4.0, поэтому я не удивился, обнаружив ее у себя. Мне пришлось засучить рукава и очень тесно познакомиться с кодом QuickReports, особенно с процедурой первичного вывода текста, когда программа изменяет шрифт в каждой выводимой области. Вот этот злосчастный сегмент кода в методе TQRCustomControl.Print:
QRPrinter.Canvas.Font:=Font; QRPrinter.Canvas.Font.size:=trunc(abs(parentreport.xpos(font.size))); QRPrinter.Canvas.brush.Color:=Color; |
Лучшее решение я увидел в следующем:
// При установке нового шрифта сохраняем шрифт принтера SaveFont := TFont.Create; SaveFont.Assign(QRPrinter.Canvas.Font); QRPrinter.Canvas.Font:=Font; QRPrinter.Canvas.Font.size:=trunc(abs(parentreport.xpos(font.size))); QRPrinter.Canvas.brush.Color:=Color; // Освобождаем сохраненный шрифт принтера. Теперь работа сделана. SaveFont.Free; SaveFont := nil; |
Так, если у вас есть зарегистрированная версия QuickReports, вы можете сделать коррекцию исходных файлов, и вы увидите, что ваши отчеты будут генериться быстрее, выглядеть "мягче" и не будет ошибок и издержек шрифтовых ресурсов из-за ограничения кода расширенных метафайлов и GDI.
Заголовок окна предварительного просмотра QuickReport.
Попробуйте сделать следующее:
QRPrinter.PreviewCaption := 'Мой заголовок'; |
QRPrinter - глобальная переменная, определенная в модуле Quickrep.pas.
Как сохранить QuickReport в stream.
Автор: http://www.swissdelphicenter.ch
uses QRPrntr;
procedure SaveQuickReportToStream(AQuickReport: TQuickRep; AStream: TStream);
var
PL: TQRPageList;
I: Integer;
begin
PL := nil;
try
PL := TQRPageList.Create;
PL.Stream := TQRStream.Create(100000);
AQuickReport.Prepare;
PL.LockList;
try
for I := 1 to AQuickReport.QRPrinter.PageCount do
PL.AddPage(AQuickReport.QRPrinter.GetPage(I));
PL.Finish;
finally
PL.UnlockList;
end;
PL.Stream.SaveToStream(AStream);
finally
FreeAndNil(PL);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
stream: TFileStream;
begin
stream := TFileStream.Create('c:\quickreport.dat', fmCreate);
QuickReportToStream(QuickRep1, stream);
stream.Free;
end;
Функция для быстрого копирования таблиц вместе со всеми дополнительными файлами.
// Только для не SQL-ых, т.е не промышленных БД (dBase, Paradox ..)
// Путь нужно задавать только АНГЛИЙСКИМИ буквами
procedure QuickCopyTable(T: TTable; DestTblName: string; Overwrite: boolean);
var
DBType: DBIName;
WasOpen: boolean;
NumCopied: word;
begin
WasOpen := T.Active;
if not WasOpen then
T.Open;
Check(DbiGetProp(hDBIObj(T.Handle),drvDRIVERTYPE, @DBType,SizeOf(DBINAME), NumCopied));
Check(DbiCopyTable(T.DBHandle, Overwrite, PChar(T.TableName),DBType, PChar(DestTblName)));
T.Active := WasOpen;
end;
|
Быстрый поиск в базах данных.
| Кинул как-то уркаган маляву по Яндексу... |
Я представляю на Ваш суд утилиту быстрого поиска по базе данных. Данная технология производит поиск по полям, преобразуя их значения в строки (все значения преобразуются в верхний регистр, включая действительные числа). Данное решение может быть не самым быстрым, однако на поверку оно оказывается быстрее остальных, обнаруженных мною в Интернете (может вам повезет больше). Более того, представьте, что действительное значение какого-либо поля равно 4.509375354, а значение поиска равно 7, в этом случае утилита засчитает "попадание". Утилита удобна также тем, что она за один проход производит поиск более, чем в одном поле. Это удобно, если у Вас имеются, к примеру, два поля с адресами. Это моя первая "серьезная" разработка, так как первое, с чем я столкнулся, изучая Delphi, стала необходимость включения процедуры поиска в любое приложение, работающее с базой данных. А так как поиск - вещь тоже сугубо специфическая, как и любое приложение, то мне пришлось побороть свой страх перед "крутым программированием" и попробовать написать свой поисковый механизм, удовлетворивший меня (и, надеюсь, других) своей скоростью и возможностью "мульти"-поиска по нескольким полям. Я надеюсь, что он поможет тем программистам, кто часто сталкивается с подобными задачами. Технология довольно легка для понимания, но если у Вас возникли какие-либо вопросы, пошлите мне письмо электронной почтой, я буду рад Вам помочь. Посмотрев код, можно легко узнать поддерживаемые типы полей (добавить новые не составит проблем). Если кто-либо обнаружит ошибочный код или расширит функциональность утилиты, пожалуйста, пошлите это мне, я буду весьма благодарен. Спасибо.
unit Finder;
interface
uses DB, DBTables, SysUtils;
function GrabMemoFieldAsPChar(TheField: TMemoField): PChar;
function DoFindIn(TheField: TField; SFor: string): Boolean;
function FindIt(TheTable: TDataSet; TheFields: array of integer;
SearchBackward: Boolean; FromBeginning: Boolean; SFor: string): Boolean;
{применение функции FindIt -
if FindIt(NotesSearchT,
[NotesSearchT.FieldByName('Leadman').Index],
False, True, SearchText.Text) then DoSomething; }
implementation
function GrabMemoFieldAsPChar(TheField: TMemoField): PChar;
begin
with TBlobStream.Create(TheField, bmRead) do
begin
GetMem(Result, Size + 1);
FillChar(Result^, Size + 1, #0);
Read(Result^, Size);
Free;
end;
end;
function DoFindIn(TheField: TField; SFor: string): Boolean;
var
PChForMemo: PChar;
begin
Result := False;
case TheField.DataType of
ftString:
begin
if (Pos(SFor, UpperCase(TheField.AsString)) > 0) then
Result := True;
end;
ftInteger:
begin
if (Pos(SFor, TheField.AsString) > 0) then
Result := True;
end;
ftBoolean:
begin
if SFor = UpperCase(TheField.AsString) then
Result := True;
end;
ftFloat:
begin
if (Pos(SFor, TheField.AsString) > 0) then
Result := True;
end;
ftCurrency:
begin
if (Pos(SFor, TheField.AsString) > 0) then
Result := True;
end;
ftDate..ftDateTime:
begin
if (Pos(SFor, TheField.AsString) > 0) then
Result := True;
end;
ftMemo:
begin
SFor[Ord(SFor[0]) + 1] := #0;
PChForMemo := GrabMemoFieldAsPChar(TMemoField(TheField));
StrUpper(PChForMemo);
if not (StrPos(PChForMemo, @SFor[1]) = nil) then
Result :=
True;
FreeMem(PChForMemo, StrLen(PChForMemo + 1));
end;
end;
end;
function FindIt(TheTable: TDataSet; TheFields: array of integer;
SearchBackward: Boolean; FromBeginning: Boolean; SFor: string): Boolean;
var
i, HighTheFields, LowTheFields: integer;
BM: TBookmark;
begin
TheTable.DisableControls;
BM := TheTable.GetBookmark;
try
LowTheFields := Low(TheFields);
HighTheFields := High(TheFields);
SFor := UpperCase(SFor);
Result := False;
if FromBeginning then
TheTable.First;
if SearchBackward then
begin
TheTable.Prior;
while not TheTable.BOF do
begin
for i := LowTheFields to HighTheFields do
begin
if DoFindIn(TheTable.Fields[TheFields[i]], SFor) then
begin
Result := True;
Break;
end;
end;
if Result then
Break
else
TheTable.Prior;
end;
end
else
begin
TheTable.Next;
while not TheTable.EOF do
begin
for i := LowTheFields to HighTheFields do
begin
if DoFindIn(TheTable.Fields[TheFields[i]], SFor) then
begin
Result := True;
Break;
end;
end;
if Result then
Break
else
TheTable.Next;
end;
end;
finally
TheTable.EnableControls;
if not Result then
TheTable.GotoBookmark(BM);
TheTable.FreeBookmark(BM);
end;
end;
end.
|
Пример быстрой работы с графикой.
Автор: KosterПример быстрой работы с графикой в среде Windows без использования средств DirectX Совместимость: Windows 95, 98, NT, 2000, Me, TrE, XP, Whistler, Tristler :)).
// © Koster < mtaurus@rambler.ru >
// Greetz to: Vano aka RIS, Uras aka Assargadon
// Special thanx to: Leon the Trillennium
unit VisualForm;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls, Buttons, ComCtrls;
type
TfmMain = class(TForm)
Panel1: TPanel;
Panel2: TPanel;
pbDraw: TPaintBox;
Timer1: TTimer;
Label1: TLabel;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormResize(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
{ Private declarations }
procedure CreateBitmap(aSX, aSY: Integer);
procedure RecreateBitmap(aSX, aSY: Integer);
procedure DeleteBitmap;
procedure RestrictSize(var msg: TMessage); message WM_GETMINMAXINFO;
procedure pbDrawPaint(Sender: TObject);
private
ScrBitmap: TBitmap;
Scr: Pointer;
SX, SY: Integer;
public
{ Public declarations }
end;
var
fmMain: TfmMain;
implementation
{$R *.DFM}
type
TBig = array[0..0] of Integer;
procedure TfmMain.CreateBitmap(aSX, aSY: Integer);
var
BInfo: tagBITMAPINFO;
begin
// Создание DIB
SX := aSX; SY := aSY;
BInfo.bmiHeader.biSize := sizeof(tagBITMAPINFOHEADER);
BInfo.bmiHeader.biWidth := SX;
BInfo.bmiHeader.biHeight := -SY;
BInfo.bmiHeader.biPlanes := 1;
BInfo.bmiHeader.biBitCount := 32;
BInfo.bmiHeader.biCompression := BI_RGB;
ScrBitmap := TBitmap.Create();
ScrBitmap.Handle := CreateDIBSection(Canvas.Handle, BInfo, DIB_RGB_COLORS, Scr, 0, 0);
ZeroMemory(Scr, SX * SY * 4);
end;
procedure TfmMain.DeleteBitmap;
begin
// Удаление DIB
ScrBitmap.FreeImage();
ScrBitmap.Destroy;
end;
procedure TfmMain.RecreateBitmap(aSX, aSY: Integer);
var
BInfo: tagBITMAPINFO;
begin
// Пересоздание DIB при изменении размеров "экрана"
ScrBitmap.FreeImage();
SX := aSX; SY := aSY;
BInfo.bmiHeader.biSize := sizeof(tagBITMAPINFOHEADER);
BInfo.bmiHeader.biWidth := SX;
BInfo.bmiHeader.biHeight := -SY;
BInfo.bmiHeader.biPlanes := 1;
BInfo.bmiHeader.biBitCount := 32;
BInfo.bmiHeader.biCompression := BI_RGB;
ScrBitmap.Handle := CreateDIBSection(Canvas.Handle, BInfo, DIB_RGB_COLORS, Scr, 0, 0);
ZeroMemory(Scr, SX * SY * 4);
end;
procedure TfmMain.FormCreate(Sender: TObject);
begin
CreateBitmap(pbDraw.ClientWidth, pbDraw.ClientHeight);
pbDraw.Canvas.Draw(0, 0, ScrBitmap);
Caption := 'Визуализатор'; Application.Title := Caption;
end;
procedure TfmMain.FormDestroy(Sender: TObject);
begin
DeleteBitmap();
end;
procedure TfmMain.FormResize(Sender: TObject);
begin
ReCreateBitmap(pbDraw.ClientWidth, pbDraw.ClientHeight);
pbDraw.Canvas.Draw(0, 0, ScrBitmap);
end;
procedure TfmMain.RestrictSize(var msg: TMessage);
var
p: PMinMaxInfo;
begin
// Ограничитель размеров окна (обработка сообщений Windows).
// Удобная вещь кстати (важно: см. объявление процедуры в классе TFmMain)
// The lParam contains a pointer on a structure of type TMinMaxInfo
p := PMinMaxInfo(Msg.lParam);
// This represents the size of the Window when Maximized
// p.ptMaxSize.x := 320;
// p.ptMaxSize.y := 240;
// This represents the position of the Window when Maximized
// p.ptMaxPosition.x := 10;
// p.ptMaxPosition.y := 10;
// This represents the minimum size of the Window
p.ptMinTrackSize.x := 520;
p.ptMinTrackSize.y := 240;
// This represents the maximum size of the Window
// p.ptMaxTrackSize.x := 400;
// p.ptMaxTrackSize.y := 320;
end;
procedure TfmMain.pbDrawPaint(Sender: TObject);
begin
pbDraw.Canvas.Draw(0, 0, ScrBitmap);
end;
|
BBBBBBBB GGGGGGGG RRRRRRRR ********
В Delphi (то что ВСЕГДА возвращает функция RGB, при любой разрядности картинки):
RRRRRRRR GGGGGGGG BBBBBBBB ********
Усматривается аналогия :) Все что нужно это просто перечислить аргументы функции в обратном порядке :))
TBig(Scr^)[x + y * SX] := RGB(B, G, R);
B, G, R - соответственно значения интенсивности синего, зеленого, и красного цветов размером байт, т.е. [0..255].
Палитра 32-разрядным режимом не поддерживается, за нас думает Windows (вернее, понятия палитры в таком режиме вообще нет). Ну а нам остается это все юзать как надо +)))
Чтобы почистить виртуальный экран, нужно сделать так: ZeroMemory(Scr, SX * SY * 4);
procedure TfmMain.Timer1Timer(Sender: TObject);
var
x, y: Integer;
begin
// В цикле рисуется полная левота. Рисуйте тут свою левоту :)
for x := 0 to SX - 1 do for y := 0 to SY - 1 do
TBig(Scr^)[x + y * SX] := RGB(Random(256),Random(256),Random(256));
// При желании, используем средства Delphi на объекте ScrBitmap типа TBitmap
// в т.ч. можно нарисовать на нем другой Bitmap с помощью функции
// ScrBitmap.Canvas.Draw(x,y,AnotherBitmap);
// Чтобы текст выглядел красивее (без фона), раскомментируйте строки
// SetBkMode(ScrBitmap.Canvas.Handle, TRANSPARENT);
ScrBitmap.Canvas.Font.Size := 24;
ScrBitmap.Canvas.TextOut(10, 10, 'Demo');
// SetBkMode(ScrBitmap.Canvas.Handle, OPAQUE);
// Нарисуемся
pbDrawPaint(Self);
end;
end.
|
Быстрый поиск в списке.
ListBox1.Perform(LB_SELECTSTRING, -1, longint(Pchar(Edit1.text))); |
Быстрая сортировка.
Автор: www.structur.h1.ru Цель: изучение алгоритма быстрой сортировки и ее модификаций. На этом занятии мы изучим алгоритм быстрой сортировки, который, пожалуй, используется более часто, чем любой другой. Основа алгоритма была разработана в 1960 году (C.A.R.Hoare) и с тех пор внимательно изучалась многими людьми. Быстрая сортировка особенно популярна ввиду легкости ее реализации; это довольно хороший алгоритм общего назначения, который хорошо работает во многих ситуациях, и использует при этом меньше ресурсов, чем другие алгоритмы. Основные достоинства этого алгоритма состоят в том, что он точечный (использует лишь небольшой дополнительный стек), в среднем требует только около N log N операций для того, чтобы отсортировать N элементов, и имеет экстремально короткий внутренний цикл. Недостатки алгоритма состоят в том, что он рекурсивен (реализация очень затруднена когда рекурсия недоступна), в худшем случае он требует N2 операций, кроме того он очень "хрупок": небольшая ошибка в реализации, которая легко может пройти незамеченной, мо жет привести к тому, что алгоритм будет работать очень плохо на некоторых файлах. Производительность быстрой сортировки хорошо изучена. Алгоритм подвергался математическому анализу, поэтому существуют точные математические формулы касающиеся вопросов его производительности. Результаты анализа были неоднократно проверены эмпирическим пу тем, и алгоритм был отработан до такого состояния, что стал наиболее предпочтительным для широкого спектра задач сортировки. Все это делает алгоритм стоящим более детального изучения наиболее эффективных путей его реализации. Похожие способы реализации по дходят также и для других алгоритмов, но в алгоритме быстрой сортировки мы можем использовать их с уверенностью, поскольку его производительность хорошо изучена. Улучшить алгоритм быстрой сортировки является большим искушением: более быстрый алгоритм сортировки - это своеобразная "мышеловка" для программистов. Почти с того момента, как Oia?a впервые опубликовал свой алгоритм, в литературе стали появляться "улучшен ные" версии этого алгоритма. Было опробовано и проанализировано множество идей, но все равно очень просто обмануться, поскольку алгоритм настолько хорошо сбалансирован, что результатом улучшения в одной его части может стать более сильное ухудшение в друг ой его части. Мы изучим в некоторых деталях три модификации этого алгоритма, которые дают ему существенное улучшение. Хорошо же отлаженная версия быстрой сортировки скорее всего будет работать гораздо быстрее, чем любой другой алгоритм. Однако стоит еще раз напомнить, что алгоритм очень хрупок и любое его изменение может привести к нежелательным и неожиданным эффектам дл я некоторых входных данных.Суть алгоритма: число операций перемены местоположений элементов внутри массива значительно сократится, если менять местами далеко стоящие друг от друга элементы. Для этого выбирается для сравнения один элемент х, отыскивается слева первый элемент, которы й не меньше х, а справа первый элемент, который не больше х. Найденные элементы меняются местами. После первого же прохода все элементы, которые меньше х, будут стоять слева от х, а все элементы, которые больше х, - справа от х. С двумя половинами массива поступают точно также. Продолжая деление этих половин до тех пор пока не останется в них по 1 элементу.
program Quitsort;
uses
crt;
Const
N=10;
Type
Mas=array[1..n] of integer;
var
a: mas;
k: integer;
function Part(l, r: integer):integer;
var
v, i, j, b: integer;
begin
V:=a[r];
I:=l-1;
j:=r;
repeat
repeat
dec(j)
until (a[j]<=v) or (j=i+1);
repeat
inc(i)
until (a[i]>=v) or (i=j-1);
b:=a[i];
a[i]:=a[j];
a[j]:=b;
until i>=j;
a[j]:=a[i];
a[i]:= a[r];
a[r]:=b;
part:=i;
end;
procedure QuickSort(l, t: integer);
var i: integer;
begin
if l<t then
begin
i:=part(l, t);
QuickSort(l,i-1);
QuickSort(i+1,t);
end;
end;
begin
clrscr;
randomize;
for k:=1 to 10 do
begin
a[k]:=random(100);
write(a[k]:3);
end;
QuickSort(1,n);
writeln;
for k:=1 to n do
write(a[k]:3);
readln;
end.
|
Пример: 60,79, 82, 58, 39, 9, 54, 92, 44, 32 60,79, 82, 58, 39, 9, 54, 92, 44, 32 9,79, 82, 58, 39, 60, 54, 92, 44, 32 9,79, 82, 58, 39, 60, 54, 92, 44, 32 9, 32, 82, 58, 39, 60, 54, 92, 44, 79 9, 32, 44, 58, 39, 60, 54, 92, 82, 79 9, 32, 44, 58, 39, 54, 60, 92, 82, 79 9, 32, 44, 58, 39, 92, 60, 54, 82, 79 9, 32, 44, 58, 39, 54, 60, 79, 82, 92 9, 32, 44, 58, 54, 39, 60, 79, 82, 92 9, 32, 44, 58, 60, 39, 54, 79, 82, 92 9, 32, 44, 58, 54, 39, 60, 79, 82, 92 9, 32, 44, 58, 54, 39, 60, 79, 82, 92 9, 32, 44, 58, 54, 39, 60, 79, 82, 92 9, 32, 39, 58, 54, 44, 60, 79, 82, 92 9, 32, 39, 58, 54, 44, 60, 79, 82, 92 9, 32, 39, 44, 54, 58, 60, 79, 82, 92 9, 32, 39, 44, 58, 54, 60, 79, 82, 92 9, 32, 39, 44, 54, 58, 60, 79, 82, 92 9, 32, 39, 44, 54, 58, 60, 79, 92, 82 9, 32, 39, 44, 54, 58, 60, 79, 82, 92"Внутренний цикл" быстрой сортировки состоит только из увеличения указателя и сравнения элементов массива с фиксированным числом. Это как раз и делает быструю сортировку быстрой. Сложно придумать более простой внутренний цикл. Положительные эффекты сторож евых ключей также оказывают здесь свое влияние, поскольку добавление еще одной проверки к внутреннему циклу оказало бы отрицательное влияние на производительность алгоритма. Самая сомнительная черта вышеприведенной программы состоит в том, что она очень мало эффективна на простых подфайлах. Например, если файл уже сортирован, то разделы будут вырожденными, и программа просто вызовет сама себя N раз, каждый раз с меньшим на од ин элемент подфайлом. Это означает, что не только производительность программы упадет примерно до N2/2, но и пространство необходимое для ее работы будет около N (смотри ниже), что неприемлемо. К счастью, есть довольно простые способы сделать так, чтобы т акой "худший" случай не произошел при практическом использовании программы. Когда в файле присутствуют одинаковые ключи, то возникает еще два сомнительных вопроса. Первое, должны ли оба указателя останавливаться на ключах равных делящему элементу или останавливать только один из них, а второй будет проходить их все, или оба указа теля должны проходить над ними. На самом деле, этот вопрос детально изучался, и результаты показали, что самое лучшее - это останавливать оба указателя. Это позволяет удерживать более или менее сбалансированные разделы в присутствии многих одинаковых ключ ей. На самом деле, эта программа может быть слегка улучшена терминированием сканирования j<i, и использованием после этого quicksort(l, j) для первого рекурсивного вызова. Характеристики Производительности Быстрой Сортировки Самое лучшее, что могло бы произойти для алгоритма - это если бы каждый из подфайлов делился бы на два равных по величине подфайла. В результате количество сравнений делаемых быстрой сортировкой было бы равно значению рекурсивного выражения CN = 2CN/2+N - наилучший случай. (2CN/2 покрывает расходы по сортировке двух полученных подфайлов; N - это стоимость обработки каждого элемента, используя один или другой указатель.) Нам известно также, что примерное значение этого выражения равно CN = N lg N. Хотя мы встречаемся с подобной ситуацией не так часто, но в среднем время работы программы будет соответствовать этой формуле. Если принять во внимание вероятные позиции каждого раздела, то это сделает вычисления более сложными, но конечный результат буде т аналогичным. Свойство 1 Быстрая сортировка в среднем использует 2N ln N сравнений. Методы улучшения быстрой сортировки. 1. Небольшие Подфайлы. Первое улучшение в алгоритме быстрой сортировки возникает из наблюдения, что программа гарантировано вызывает себя для огромного количества небольших подфайлов, поэтому следует использовать самый лучший метод сортировки когда мы встречаем небольшой подфай л. Очевидный способ добиться этого, это изменить проверку в начале рекурсивной функции из "if r>l then" на вызов сортировки вставкой (соответственно измененной для восприятия границ сортируемого подфайла): "if r-l<=M then insertion(l, r)." Значение для M не обязано быть "самым-самым" лучшим: алгоритм работает примерно одинаково для M от 5 до 25. Время работы программы при этом снижается примерно на 20% для большинства программ. <p> При небольших подфайлах (5- 25 элементов) быстрая сортировка очень много раз вызывает сама себя (в наше примере для 10 элементов она вызвала сама себя 15 раз), поэтому следует применять не быструю сортировку, а сортировку вставкой. </p> <table><tr><td><br> <PRE> <B>procedure</B> QuickSort (l,t:integer); <B>var</B> i:integer; <B>begin</B> <B>if</B> t-l>m <B>then</B> <B>begin</B> i:=part(l,t); QuickSort (l,i-1); QuickSort (i+1,t); <B>end</B> <B>Else</B> Insert(l,t); <B>end</B>; </PRE> </td></tr></table><br> <p> <b>2. Деление по Медиане из Трех</b> <p> Второе улучшение в алгоритме быстрой сортировки состоит в попытке использования лучшего делящего элемента. У нас есть несколько возможностей. Наиболее безопасная из них будет попытка избежать худшего случая посредством выбора произвольного элемента массив а в качестве делящего элемента. Тогда вероятность худшего случая становится пренебрежимо мала. Это простой пример "вероятностного" алгоритма, который почти всегда работает вне зависимости от входных данных. Произвольность может быть хорошим инструментом п ри разработке алгоритмов, особенно если возможны подозрительные входные данные. <p> Более полезное улучшение состоит в том, чтобы взять из файла три элемента, и затем использовать среднее из них в качестве делящего элемента. Если элементы взяты из начала, середины, и конца файла, то можно избежать использования сторожевых элементов: сорт ируем взятые три элемента, затем обмениваем центральный элемент с a[r-1], и затем используем алгоритм деления на массиве a[l+1..r-2]. Это улучшение называется делением по медиане из трех. <p> Метод деления по медиане из трех полезен по трем причинам. Во-первых, он делает вероятность худшего случая гораздо более низкой. Чтобы этот алгоритм использовал время пропорциональной N2, два из трех взятых элементов должны быть либо самыми меньшими, либо самыми большими, и это должно повторяться из раздела в раздел. Во-вторых, этот метод уничтожает необходимость в сторожевых элементах, поскольку эту роль играет один из трех взятых нами перед делением элементов. В третьих, он на самом деле снижает время р аботы алгоритма приблизительно на 5%. </p> <table><tr><td><br> <PRE> <B>procedure</B> exchange(i,j:integer); <B>var</B> k:integer; <B>begin</B> k:=a[i]; a[i]:=a[j]; a[j]:=k; <B>end</B>; <B>procedure</B> Mediana; <B>var</B> i:integer; <B>begin</B> i:=n <B>div</B> 4;<FONT COLOR="#00007F"><I>{Рис.}</FONT><FONT COLOR="#000000"></I> <B>if</B> a[i]>a[i*2] <B>then</B> <B>if</B> a[i]>a[i*3] <B>then</B> exchange(i,n) <B>else</B> exchange(i*3,n) <B>else</B> <B>if</B> a[i*2]>a[i*3] <B>then</B> exchange(i*2,n); quicksort(1,n); <B>end</B>; </PRE> </font> </td></tr></table><br> <p> <b>3. Нерекурсивная реализация.</b> <p> Можно переписать данный алгоритм без использования рекурсии используя стек, но здесь мы это не будем делать. <p> Комбинация нерекурсивной реализации деления по медиане из трех с отсечением на небольшие файлы может улучшить время работы алгоритма от 25% до 30%. <p> Итак, на сегодняшнем занятии мы рассмотрели алгоритм быстрой сортировки. <p> <b>Слияние</b> <p> На сегодняшнем занятии мы начнем рассмотрении темы внешняя сортировка. <p> Внешняя сортировка сортирует файлы, которые не помещаются целиком в оперативную память. <p> Внешняя сортировка сильно отличается от внутренней. Дело в том, что доступ к файлу является последовательным, а не параллельным как это было в массиве. И поэтому считывать файл можно только блоками и этот блок отсортировать в памяти и снова записать в фай л. <p> Принципиальную возможность эффективно отсортировать файл, работая с его частями и не выходя за пределы части обеспечивает алгоритм слияния. <p> Под слиянием понимается объединение двух (или более) упорядоченных последовательностей в одну упорядоченную последовательность при помощи циклического выбора элементов, доступных в данный момент. <p> Слияние - намного более простая операция, чем сортировка. <p> Мы рассмотрим 2 алгоритма слияния: <p> Прямое слияние. Алгоритм Боуза - Нельсона Естественное (Неймановское) слияние. <br> Прямое слияние. Алгоритм Боуза - Нельсона Последовательность а разбивается на две половины b и с. <p> Последовательности b и с сливаются при помощи объединения отдельных элементов в упорядоченные пары. <p> Полученной последовательности присваивается имя а, после чего повторяются шаги 1 и 2; при этом упорядоченные пары сливаются в упорядоченные четверки. <p> Предыдущие шаги повторяются, при этом четверки сливаются в восьмерки и т.д., пока не будет упорядочена вся последовательность, т.к. длины последовательностей каждый раз удваиваются. <p> Пример </p> <pre> Исходная последовательность А = 44 55 12 42 94 18 06 67 1 b = 44 55 12 42 с = 94 18 06 67 а = 44 94' 18 55' 06 12' 42 67 2 b = 44 94' 18 55' с =06 12' 42 67 а = 06 12 44 94' 18 42 55 67' 3 b = 06 12 44 94' с = 18 42 55 67' а = 06 12 18 42 44 55 67 94 </pre> <p> Операция, которая однократно обрабатывает всё множество данных, называется фазой. <p> Наименьший подпроцесс, который, повторяясь, образует процесс сортировки, называется проходом или этапом. <p> В нашем примере сортировка производится за три прохода. Каждый проход состоит из фазы разбиения и фазы слияния. <p> Главным минусом сортировки слиянием является удвоение размера памяти, первоначально занятой сортируемыми данными. Рассмотрим алгоритм с рекурсивным актом слияния, предложенный Боузом и Нельсоном и не требующий резерва памяти. <p> Он основан на очевидной идее: слить две равные упорядоченные части можно слиянием их начальных половин, слиянием конечных и слиянием 2-й половины 1-го результата с 1-й половиной 2-го результата, например: <p> Если части не равны или не делятся точно пополам, процедуру уточняют надлежащим образом. Аналогично слияние "половинок" можно свести к слиянию "четвертушек", "восьмушек" и т. д.; имеет место рекурсия. </p> <table><tr><td><br> <PRE> <B>Const</B> n=200; <B>Type</B> tipkl=word; tip = <B>Record</B> kl: tipkl; z:<B>Array</B>[1..50] <B>of</B> real <B>End</B>; <B>Var</B> A: <B>Array</B>[1..n] <B>of</B> tip; j:word; <B>Procedure</B> Bose (<B>Var</B> AA; voz:Boolean); <B>Var</B> m,j:word; x:tip; <FONT COLOR="#00007F"><I>{tip - тип сортируемых записей}</FONT><FONT COLOR="#000000"></I> A: <B>Array</B> [1..65520 <B>div</B> Sizeof(tip)] <B>of</B> tip <B>Absolute</B> AA; <B>Procedure</B> Sli(j,r,m: word); </FONT><FONT COLOR="#00007F"><I>{ r - расстояние между началами сливаемых частей, а m - их размер, j - наименьший номер записи}</FONT><FONT COLOR="#000000"></I> <B>Begin</B> <B>if</B> j+r<=n <B>Then</B> <B>If</B> m=1 <B>Then</B> <B>Begin</B> <B>If</B> voz <B>Xor</B> (A[j].kl < A[j+r].kl) <B>Then</B> <B>Begin</B> x:=A[j]; A[j]:= A[j+r]; A[j+r]:=x <B>End</B> <B>End</B> <B>Else</B> <B>Begin</B> m:=m <B>div</B> 2; Sli(j,r,m); </FONT><FONT COLOR="#00007F"><I>{Слияние "начал"}</FONT><FONT COLOR="#000000"></I> <B>If</B> j+r+m<=n <B>Then</B> Sli(j+m,r,m); </FONT><FONT COLOR="#00007F"><I>{Слияние "концов"}</FONT><FONT COLOR="#000000"></I> Sli(j+m,r-m,m) <B>End</B> </FONT><FONT COLOR="#00007F"><I>{Слияние в центральной части}</FONT><FONT COLOR="#000000"></I> <B>End</FONT><FONT COLOR="#00007F"></B><I>{блока Sli}</FONT><FONT COLOR="#000000"></I>; <B>Begin</B> m:=1; <B>Repeat</B> j:=1; </FONT><FONT COLOR="#00007F"><I>{Цикл слияния списков равного размера: }</FONT><FONT COLOR="#000000"></I> <B>While</B> j+m<=n <B>do</B> <B>Begin</B> Sli(j,m,m); j:=j+m+m <B>End</B>; m:=m+m </FONT><FONT COLOR="#00007F"><I>{Удвоение размера списка перед началом нового прохода}</FONT><FONT COLOR="#000000"></I> <B>Until</B> m >= n </FONT><FONT COLOR="#00007F"><I>{Конец цикла, реализующего все дерево слияний}</FONT><FONT COLOR="#000000"></I> <B>End</FONT><FONT COLOR="#00007F"></B><I>{блока Bose}</FONT><FONT COLOR="#000000"></I>; <B>BEGIN</B> Randomize; <B>For</B> j:=1 <B>to</B> n <B>do</B> <B>begin</B> A[j].kl:= Random(65535); Write(A[j].kl:8); <B>end</B>; Readln; Bose(A,<B>true</B>); <B>For</B> j:=1 <B>to</B> n <B>do</B> Write(A[j].kl:8); Readln <B>END</B>. </PRE> </font> </td></tr></table><br> <p> <b>Естественное (Неймановское) слияние.</b> <p> Она объединяются упорядоченные части, спонтанно возникшие в исходном массиве; они могут быть также следствием предыдущей обработки данных. Рассчитывать на одинаковый размер сливаемых частей не приходится. <p> Записи, идущие в порядке неубывания ключей, сцепляются, образуя подсписок. Минимальный подсписок одна запись. <p> Пример: </p> <pre> Пусть даны ключи записей 5 7 8 3 9 4 1 7 6 </pre> <p> Ищем подсписки <p> В один общий список соединяются 1-й, 3-й, 5-й и т. д. подсписки, в другой - 2-й, 4-й и т. д. подсписки. <p> Произведем слияние 1 подсписка 1 списка и 1 подсписка 2 списка, 2 подсписка 1 списка и 2 подсписка 2 списка и т.д. </p> <pre> Будут получены следующие цепи 3 --> 5 --> 7 --> 8 --> 9 и 1 --> 4 --> 7 </pre> <p> Подсписок, состоящий из записи "6", пары не имеет и "принудительно" объединяется с последней цепью, принимающей вид 1 --> 4--> 6 --> 7. <p> При нашем небольшом числе записей 2-й этап, на котором сливаются две цепи, окажется последним. <p> В общем случае на каждом этапе подсписок - результат слияния начальных подсписков 1 и 2 списка становится началом нового 1-го списка, а результат слияния следующих двух подсписков - началом 2-го списка. Следующие образуемые подсписки поочередно включаются в 1-й и во 2-й список. <p> Для программной реализации заводят массив sp: элемент sp[i] - это номер записи, которая следует за i-й. <p> Последняя запись одного подсписка ссылается на первую запись другого, а для различения концов подсписков эта ссылка снабжается знаком минус. </p> <table><tr><td><br> <PRE> <B>Repeat</B> <FONT COLOR="#00007F"><I>{Повторение актов слияний подсписков}</FONT><FONT COLOR="#000000"></I> <B>If</B> A[j].kl < A[i].kl <B>Then</B> </FONT><FONT COLOR="#00007F"><I>{Выбирается меньшая запись}</FONT><FONT COLOR="#000000"></I> <B>Begin</B> sp[k]:=j; k:=j; j:=sp[j]; <B>If</B> j<=0 <B>Then</B> </FONT><FONT COLOR="#00007F"><I>{Сцепление с остатком "i"-подсписка}</FONT><FONT COLOR="#000000"></I> <B>Begin</B> sp[k]:=i; <B>Repeat</B> m:=i; i:=sp[i] <B>Until</B> i<=0 <B>End</B> <B>End</B> <B>Else</B> <B>Begin</B> sp[k]:=i; k:=i; i:=sp[i]; <B>If</B> i<=0 <B>Then</B> </FONT><FONT COLOR="#00007F"><I>{Сцепление с остатком "j"-подсписка}</FONT><FONT COLOR="#000000"></I> <B>Begin</B> sp[k]:=j; <B>Repeat</B> m:=j; j:=sp[j] <B>Until</B> j<=0 <B>End</B> <B>End</B>; <B>If</B> j<=0 <B>Then</B> <B>Begin</B> sp[m]:= 0; sp[p]:=-sp[p]; i:=-i; j:=-j; <B>If</B> j<>0 <B>Then</B> p:=r; k:=r; r:=m <B>End</B> <B>Until</B> j=0; </PRE> </font> </td></tr></table><br> <p> {В конец сформированного подсписка всегда заносится нулевая ссылка (sp[m]:= 0), ибо он может оказаться последним. <p> Действие sp[p]:= -sp[p] обозначает минусом конец ранее построенного подсписка. <p> В переменных i,j ссылки на начала новых сливаемых подсписков - со знаком минус; его снимаем. Переход к новым подспискам требует обновления переменных p, k, r} <p> Итак, на сегодняшнем занятии мы рассмотрели алгоритмы слияния. </p> <!-- end -->
Группа радиокнопок и ActiveControl.
Автор: Ralph Friedman На форме я имею группу радиокнопок. Я хотел бы вызывать контекстно-зависимую подсказку, если пользователь нажал F1. Для данной конкретной группы радиокнопок я установил HelpContext равным 22, но при любом вызове ActiveControl.HelpContext это возвращает (0). Все другие элементы управления работают как положено. Что я делаю неправильно?Нет. Проблема в том, что ActiveControl - RadioButton, а не RadioButtonGroup. Поместите следующий код в обработчик события формы OnShow, он должен решить вашу проблему:
procedure TForm1.FormShow(Sender: TObject);
var
c: integer;
begin
with RadioGroup1 do
begin
for c := 0 to ControlCount - 1 do
TRadioButton(Controls[c]).HelpContext := HelpContext;
end;
end;
|
Инициализация исключительной ситуации.
Автор: Xavier Pacheco
{
Copyright © 1999 by Delphi 5 Developer's Guide - Xavier Pacheco and Steve Teixeira
}
unit MainFrm;
interface
uses
SysUtils, Windows, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, AppEvnts, Buttons;
type
ENotSoBadError = class(Exception);
EBadError = class(Exception);
ERealBadError = class(Exception);
TMainForm = class(TForm)
btnNotSoBad: TButton;
btnBad: TButton;
btnRealBad: TButton;
appevnMain: TApplicationEvents;
procedure btnNotSoBadClick(Sender: TObject);
procedure btnBadClick(Sender: TObject);
procedure btnRealBadClick(Sender: TObject);
procedure appevnMainException(Sender: TObject; E: Exception);
public
end;
var
MainForm: TMainForm;
implementation
{$R *.DFM}
procedure TMainForm.btnNotSoBadClick(Sender: TObject);
begin
raise ENotSoBadError.Create('This isn''t so bad!');
end;
procedure TMainForm.btnBadClick(Sender: TObject);
begin
raise EBadError.Create('This is bad!');
end;
procedure TMainForm.btnRealBadClick(Sender: TObject);
begin
raise ERealBadError.Create('This is real bad!');
end;
procedure TMainForm.appevnMainException(Sender: TObject; E: Exception);
var
rslt: Boolean;
begin
if E is EBadError then
begin
{ Show a custom message box and prompt for application termination. }
rslt := MessageDlg(Format('%s %s %s %s %s', ['An', E.ClassName,
'exception has occurred.', E.Message, 'Quit App?']),
mtError, [mbYes, mbNo], 0) = mrYes;
if rslt then
Application.Terminate;
end
else if E is ERealBadError then
begin // Show a custom message
// and terminate the application.
MessageDlg(Format('%s %s %s %s %s', ['An', E.ClassName,
'exception has occured.', E.Message, 'Quitting Application']),
mtError, [mbOK], 0);
Application.Terminate;
end
else // Perform default exception handling
Application.ShowException(E);
end;
end.
Как получить неповторяющиеся случайные числа.
Автор: http://www.swissdelphicenter.ch
procedure Shuffle(var aArray; aItemCount: Integer; aItemSize: Integer);
{ after Julian M Bucknall }
var
Inx: Integer;
RandInx: Integer;
SwapItem: PByteArray;
A: TByteArray absolute aArray;
begin
if (aItemCount > 1) then
begin
GetMem(SwapItem, aItemSize);
try
for Inx := 0 to (aItemCount - 2) do
begin
RandInx := Random(aItemCount - Inx);
Move(A[Inx * aItemSize], SwapItem^, aItemSize);
Move(A[RandInx * aItemSize], A[Inx * aItemSize], aItemSize);
Move(SwapItem^, A[RandInx * aItemSize], aItemSize);
end;
finally
FreeMem(SwapItem, aItemSize);
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
a: array[1..10] of Integer;
i: Shortint;
begin
Randomize;
for i := Low(a) to High(a) do
a[i] := i;
Shuffle(a, High(a), SizeOf(Integer));
for i := 1 to High(a) - 1 do
ListBox1.Items.Add(IntToStr(a[i]));
end;
Как выбрать случайную запись.
Автор: http://www.swissdelphicenter.ch
procedure TForm1.FormCreate(Sender: TObject); begin Randomize; end; procedure TForm1.Button1Click(Sender: TObject); begin Table1.First; Table1.MoveBy(Random(Table1.RecordCount)); end;
Нарисовать случайным образом кривую Безье.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
procedure TForm1.Button1Click(Sender: TObject);
var
pusat: array of TPoint;
i: Integer;
begin
SetLength(pusat, 4);
for i := Low(pusat) to High(pusat) do
begin
pusat[i].x := Random(Width);
pusat[i].y := Random(Height);
end;
Canvas.PolyBezier(pusat);
end;
Случайные пароли.
Автор: Archer Тут поговорим случайных паролях с точки зрения математики. Конкретнее - как количество возможных вариантов пароля зависит от его длины и размерности используемого при генерации "алфавита". Тема не новая, но ни в одной статье на эту тему (во всяком случае из тех, что я читал) вопрос не рассматривается достаточно подробно. Частенько просто отделываются утверждением, что возможных вариантов паролей "огромное количество". Но это понятие растяжимое - современный ПК тоже выполняет "огромное количество" операций в секунду. Так сколько ему понадобится времени, чтобы при переборе вариантов добраться до нашего пароля? Особо продвинутые авторы пугают читателя огромными числами. Не будем верить на слово - если мы пишем программу, в которой предусмотрены пароли, надо самим уметь оценить их надежность. Не вдаваясь в строгое математическое доказательство, посмотрим, откуда берутся эти зверские числа и как их рассчитать для каждого конкретного случая. Давайте договоримся, что мы имеем алфавит из n возможных символов, а наш пароль k символов в длину. Надо узнать, сколько вариантов пароля может быть в принципе, и дополнительно посмотрим, сколько будет вариантов паролей из неповторяющихся символов - иногда встречаются утверждения, что такой пароль лучше. Не ручаюсь за точность терминологии, лень было искать:), просто для себя назовем такие пароли соответственно "обычными" и "уникальными". Обычные пароли Как мы только что договорились, обычными называем пароли, которые могут содержать повторяющиеся символы. То есть это полное количество комбинаций длиной k, которые мы можем составить из n элементов. Слишком сильно в математику вдаваться не будем, а рассмотрим несколько простых примеров. Начнем как положено, с самого начала. Пример 1: У нас есть элементы "А" и "В". Сколько комбинаций длиной 1 можно из них сотворить? Очевидно, две. Попутно отмечаем на будущее, что это равно nk. Пример 2: У нас есть элементы "А", "В" и "С". Сколько имеем комбинаций длиной в 2 символа? Давайте считать. Перебираем по принципу "каждый с каждым". Получаем "АА", "АВ", "АС", "ВА", "ВВ", "ВС", "СА", "СВ", "СС", всего 9. Занятное совпадение - снова nk :) Дальше предлагаю просто принять на веру, что их nk, поскольку так оно и есть, строго доказывать будет длинновато. Интересующиеся могут обратиться к разделу алгебры "Комбинаторика". Это называется размещения с повторениями. Рассмотрим более практический пример. Число букв английского алфавита 26. Составляем всевозможные пароли длиной в 9 символов. Их у нас 269=5 429 503 678 976 штук. Для начала неплохо:) Уникальные пароли Снова вернемся к примерам. Уникальные пароли не содержат повторяющихся символов, потому первый пример оставляет нам оба варианта. Из второго примера мы должны вычеркнуть "АА", "ВВ" и "СС", то есть имеем шесть случаев. В математике это называется размещениями. Количество размещений (без повторения) рассчитываем по формуле n*(n-1)*(n-2)*...*(n-k+1) = n! / (n-k)! (что такое факториал, надеюсь, все помнят). Сразу видим, что для наших примеров получаем соответственно 2 и 6, то есть все правильно. Снова тот же более практический пример - на этот раз имеем 26! / (26 - 9)! = 26! / 17! = 1 133 836 704 000 вариантов. Даже без "куркулятора" понятно, насколько мы сузили диапазон возможных паролей наложением условия неповторяемости символов. Это к вопросу об использовании "уникальных" паролей:) Реальный пример Давайте перейдем к практическим вещам. Например, рассмотрим пароли MS Office. Они могут быть до 15 знаков в длину, включать буквы (не только английские, но и языков локализации), цифры, а также специальные символы ("{", "#", "!" и т.п.). Кроме того, учитывается регистр символов, то есть английских букв реально можем использовать 52. Надо отметить, что MS Office ничего не имеет против пароля, состоящего из букв разных языков, но я бы не стал такого делать - легко самому запутаться. Потому прикидываем для английского - 52 буквы, 10 цифр, еще пару десятков надо накинуть на спецсимволы... Для круглого счета определим наш алфавит в 80 символов. Максимальное количество паролей максимальной длины при таком допущении будет примерно 3,5 * 1028. А если не допускать повторения символов? 8,6 * 1027. Снова вариантов в несколько раз меньше. ЗависимостиПопробуем ответить на самый интересный вопрос - как количество вариантов зависит от размерности алфавита и длины пароля? И что вообще важнее - увеличивать размерность алфавита или использовать пароль максимальной длины? Формулы этих зависимостей мы уже получили, для наглядности теперь нарисуем пару картинок. Снова берем 80 символов алфавита и 15 символов пароля.
|
|
| Рисунок 1: Зависимость количества "обычных" вариантов от размерности алфавита и длины пароля. | Рисунок 2: Зависимость количества "уникальных" вариантов от размерности алфавита и длины пароля. |
Так сколько же компьютеру понадобится времени для взлома нашего документа? Давайте оценим. Специально заходил на сайты нескольких утилит для "восстановления забытых паролей", но сведений о скорости перебора там благоразумно не приводилось:) Единственное, что удалось откопать в сети - упоминание о том, что одна из таких программ, написанная несколько лет назад, перебирает 85000 вариантов в секунду на Pentium III. В алгоритмах с тех пор вряд ли что-то существенно изменилось. Давайте введем поправку на возросшие компьютерные мощности, например, помножим на пять. Для 9-ти значного пароля и для алфавита в 26 символов получится около 145 суток. Это для обычных паролей. Для паролей из неповторяющихся символов получается ровно месяц. Конечно, эти расуждения относятся к взлому пароля прямым перебором вариантов - относительно иных способов не берусь подсчитать.
Формат архивного файла RAR.
Оформил: DeeCo
(ОПИСЫВАЕМЫЙ ФОРМАТ АРХИВА ДЕЙСТВИТЕЛЕН ДЛЯ RAR ВЕРСИИ 1.50 И СТАРШЕ) Файл архива состоит из блоков разной длины. Порядок следования этих блоков может меняться, но первым блоком всегда должен быть блок-маркер, за которым следует блок заголовка архива. Каждый блок начинается со следующих полей: HEAD_CRC 2 байта CRC всего блока или его части HEAD_TYPE 1 байт Тип блока HEAD_FLAGS 2 байта Флаги блока HEAD_SIZE 2 байта Размер блока ADD_SIZE 4 байта Необязательное поле - добавление к размеру блока Поле ADD_SIZE присутствует, только если (HEAD_FLAGS & 0x8000) != 0 Общий размер блока указан в поле HEAD_SIZE, если (HEAD_FLAGS & 0x8000) == 0 или HEAD_SIZE+ADD_SIZE, если есть поле ADD_SIZE, при этом (HEAD_FLAGS & 0x8000) != 0. Во всех блоках следующие биты в HEAD_FLAGS имеют одинаковое значение: 0x4000 - если установлен, то старые версии RAR будут игнорировать этот блок и удалять его при изменении архива; если не установлен, то блок копируется в новый архивный файл при изменении архива; 0x8000 - если установлен, то поле ADD_SIZE присутствует и размер полного блока составляет HEAD_SIZE+ADD_SIZE. Заявленные типы блоков: HEAD_TYPE=0x72 блок-маркер HEAD_TYPE=0x73 заголовок архива HEAD_TYPE=0x74 заголовок файла HEAD_TYPE=0x75 заголовок комментария HEAD_TYPE=0x76 дополнительная информация HEAD_TYPE=0x77 субблок HEAD_TYPE=0x78 информация для восстановления Блок комментария используется только внутри других блоков. Обработка архива происходит следующим образом: 1. Читается и проверяется блок-маркер 2. Читается заголовок архива 3. Читаются или пропускаются HEAD_SIZE-размер(MAIN_HEAD) байт 4. Если обнаружен конец архива, то обработка архива прекращается, иначе читаются 7 байт в полях HEAD_CRC, HEAD_TYPE, HEAD_FLAGS, HEAD_SIZE. 5. Проверяется HEAD_TYPE. Если надо прочитать блок: если HEAD_TYPE==0x74 прочитать заголовок файла (первые 7 байт уже прочитаны) прочитать или пропустить HEAD_SIZE-размер(FILE_HEAD) байт прочитать или пропустить FILE_SIZE байт иначе прочитать соответствующий блок HEAD_TYPE: прочитать HEAD_SIZE-7 байт если (HEAD_FLAGS & 0x8000) прочитать ADD_SIZE байт Если надо пропустить блок: пропустить HEAD_SIZE-7 байт если (HEAD_FLAGS & 0x8000) пропустить ADD_SIZE байт 6. Перейти к шагу 4. ========================================================================== Форматы блоков ========================================================================== Блок-маркер (MARK_HEAD) ~~~~~~~~~~~~~~~~~~~~~~~ HEAD_CRC Всегда 0x6152 2 байта HEAD_TYPE Тип заголовка: 0x72 1 байт HEAD_FLAGS Всегда 0x1a21 2 байта HEAD_SIZE Размер блока = 0x0007 2 байта Блок-маркер в действительности считается фиксированной последовательностью байт: 0x52 0x61 0x72 0x21 0x1a 0x07 0x00 Заголовок архива (MAIN_HEAD) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ HEAD_CRC CRC полей от HEAD_TYPE до RESERVED2 2 байта HEAD_TYPE Тип заголовка: 0x73 1 байт HEAD_FLAGS Битовые флаги: 2 байта 0x01 - Атрибут тома (том многотомного архива) 0x02 - Присутствует архивный комментарий 0x04 - Атрибут блокировки архива 0x08 - Атрибут непрерывного (solid) архива 0x10 - Не используется 0x20 - Присутствует авторская подпись (AV) остальные биты в HEAD_FLAGS зарезервированы для внутреннего использования HEAD_SIZE Общий размер архивного заголовка, включая архивные 2 байта комментарии RESERVED1 Зарезервировано 2 байта RESERVED2 Зарезервировано 4 байта Блок комментария присутствует, если (HEAD_FLAGS & 0x02) != 0 Заголовок файла (файл в архиве) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ HEAD_CRC CRC полей от HEAD_TYPE до FILEATTR и имени файла 2 байта HEAD_TYPE Тип заголовка: 0x74 1 байт HEAD_FLAGS Битовые флаги: 2 байта 0x01 - файл продолжается из предыдущего тома 0x02 - файл продолжается в следующем томе 0x04 - файл зашифрован паролем 0x08 - присутствует комментарий файла 0x10 - используется информация из предыдущих файлов (флаг непрерывности) (для RAR 2.0 и выше) биты 7 6 5 (для RAR 2.0 и выше) 0 0 0 - размер словаря 64 Кбайт 0 0 1 - размер словаря 128 Кбайт 0 1 0 - размер словаря 256 Кбайт 0 1 1 - размер словаря 512 Кбайт 1 0 0 - размер словаря 1024 Кбайт 1 0 1 - зарезервировано 1 1 0 - зарезервировано 1 1 1 - файл в каталоге (HEAD_FLAGS & 0x8000) == 1, так как полный размер блока составляет HEAD_SIZE + PACK_SIZE HEAD_SIZE Полный размер заголовка файла, включая имя файла и комментарии 2 байта PACK_SIZE Размер файла в архиве (сжатый) 4 байта UNP_SIZE Размер исходного файла (несжатый) 4 байта HOST_OS Использованная при архивировании операционная система 1 байт 0 - MS-DOS 1 - OS/2 2 - Win32 3 - Unix 4 - Mac OS FILE_CRC CRC файла 4 байта FTIME Дата и время в стандартном формате MS-DOS 4 байта UNP_VER Версия RAR, необходимая для извлечения файла 1 байт METHOD Метод сжатия 1 байт NAME_SIZE Размер имени файла 2 байта ATTR Атрибуты файла 4 байта FILE_NAME Имя файла - строка размером NAME_SIZE байт Блок комментария присутствует, если (HEAD_FLAGS & 0x08) != 0 Блок комментария ~~~~~~~~~~~~~~~~ HEAD_CRC CRC полей от HEAD_TYPE до COMM_CRC 2 байта HEAD_TYPE Тип заголовка: 0x75 1 байт HEAD_FLAGS Битовые флаги 2 байта HEAD_SIZE Размер заголовка комментария + размер комментария 2 байта UNP_SIZE Размер несжатого комментария 2 байта UNP_VER Версия RAR, необходимая для извлечения комментария 1 байт METHOD Метод сжатия 1 байт COMM_CRC CRC комментария 2 байта COMMENT Текст комментария Блок дополнительной информации ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ HEAD_CRC CRC блока 2 байта HEAD_TYPE Тип заголовка: 0x76 1 байт HEAD_FLAGS Битовые флаги 2 байта HEAD_SIZE Общий размер блока 2 байта INFO Прочие данные Субблок ~~~~~~~ Объект в архиве (блок или заголовок) может сопровождаться субблоком. Субблок зависит от основного объекта. Субблок может быть удален или перемещен в новой версии архива при его обновлении. Субблок содержит следующие поля: HEAD_CRC CRC блока 2 байта HEAD_TYPE Тип заголовка: 0x77 1 байт HEAD_FLAGS Битовые флаги 2 байта (HEAD_FLAGS & 0x8000) == 1, так как полный размер блока составляет HEAD_SIZE + DATA_SIZE HEAD_SIZE Общий размер блока 2 байта DATA_SIZE Общий размер данных 4 байта SUB_TYPE Тип субблока 2 байта RESERVED Должно быть 0 1 байт Другие поля Другие поля в зависимости от типа субблока Субблок расширенных атрибутов OS/2 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ HEAD_CRC CRC блока 2 байта HEAD_TYPE Тип заголовка: 0x77 1 байт HEAD_FLAGS Битовые флаги 2 байта (HEAD_FLAGS & 0x8000) == 1, так как полный размер блока составляет HEAD_SIZE + DATA_SIZE HEAD_SIZE Общий размер блока 2 байта DATA_SIZE Общий размер данных (сжатый размер расширенных атрибутов) 4 байта SUB_TYPE 0x100 2 байта RESERVED Должно быть 0 1 байт UNP_SIZE Размер несжатых расширенных атрибутов 4 байта UNP_VER Версия RAR, необходимая для извлечения расширенных атрибутов 1 байт METHOD Метод сжатия 1 байт EA_CRC CRC расширенных атрибутов 4 байта ========================================================================== Примечания ========================================================================== 1. Для обработки SFX-архива нужно пропустить модуль SFX, для чего в архиве осуществляется поиск блока-маркера. В модуле SFX нет последовательности байтов блока-маркера (0x52 0x61 0x72 0x21 0x1a 0x07 0x00). 2. CRC вычисляется с помощью стандартного многочлена 0xEDB88320. В случае, если размер CRC меньше 4 байт, то используются только младшие байты. 3. Кодирование метода сжатия: 0x30 - сохранение (без сжатия) 0x31 - скоростное сжатие 0x32 - быстрое сжатие 0x33 - нормальное сжатие 0x34 - хорошее сжатие 0x35 - лучшее сжатие 4. Номер версии RAR, необходимой для извлечения, кодируется как 10 * старший номер версии + младший номер версии.RAS API для непродвинутых.
| Автор: Александр Терехов |
| Особые благодарности Королеве дельфийского королевства Елене Филипповой, которая подвигла меня на ваяние сего опуса. |
Рассмотрим работу этой функции. Прежде всего определим переменные:
BuffSize: Integer; размер массива из AnsiChar, в который будут помещаться сведения об "удаленных соединениях" Entries: Integer; количество зарегистрированных "удаленных соединений" Entry : Array[1..MaxEntries] of TRasEntryName; массив состоящий из переменных, в которые будут помещены сведения об "удаленных соединениях", где константа MaxEntries - количество возможных соединений, TRasEntryName - определение (type) записи состоящей из двух полей dwSize и szEntryName (определены в RasUnit.pas) X, Result_ : Integer; необходимые процедурные переменные AllEntries: TStrings; сюда мы поместим названия "удаленных соединений" для дальнейшей работы с ними Перейдем к описанию работы функции RasEnumEntries.1. Определим размер переменной типа TRasEntryName и инициализируем переменную Entry, поместив в поле dwSize полученный размер.
Entry[1].dwSize := SizeOf(TRasEntryName); |
2. Определим размер AnsiChar-массива, в который поместим сведения обо всех "удаленных соединениях".
BuffSize := SizeOf(TRasEntryName) * MaxEntries; |
В случае успешного выполнения функции и существования хотя бы одного зарегистрированного "удаленного соединения" заполним нашу переменную.
if (Result_ = 0) and (Entries > 0) then
begin
AllEntries := TStringList.Create;
for X := 1 to Entries do
begin
AllEntries.Add(Entry[x].szEntryName);
end;
{.....здесь мы работает со своей переменной, например,
помещаем сведения об "удаленных соединениях" в ListBox......}
AllEntries.Free;
end;
|
Глобальные:
MyDialParam : TMyDialParam переменная состояния соединения, гдеTMyDialParam = Record AMsg : Integer; - код сообщения AState : TRasConnState; - статус соединения (тип переменной определен в RasUnit.pas) AError : Integer; - код ошибкиhRas: ThRASConn в эту переменную будет помещен handle (так сказать "ИНН") "удаленного соединения", к этой переменной будет обращаться функция RasHangUp для завершения соединения, тип переменной описан в RasUnit.pas
Локальные:
Fp:LongBool если в "удаленном доступе" не указан пароль пользователя, то эта переменная устанавливается в False и появляется приглашение ввести пароль, если пароль указан, то переменная устанавливается в True и приглашение не появляется. DialParams: TRasDialParams переменная, в которую будут переданы параметры "удаленного соединения", описывать тип этой переменной я не буду - он хорошо описан в Win32 Programmer's Reference (кто не знает - это один из разделов Неlр'а, поставляемого вместе с Delphi) и определен в RasUnit.pas AEntryDial:String переменная, в которую поместим название "удаленного соединения" R: Integer результат выполнения библиотечных функций C : Array[0..100] of Char переменная, в которую записывается текст сообщения об ошибкеКроме переменных необходимо также определить CallBack-процедуру, которая будет использована в функции RasDial (***).
procedure RasCallBack(msg: Integer;
state: TRasConnState;
error: Integer); stdcall
{****}
{где
msg: Integer - код сообщения
state: TRasConnState - состояние соединения
error: Integer - код ошибки}
|
В этой процедуре передадим глобальной переменной MyDialParam значения указанных переменных.
MyDialParam.AMsg := msg; MyDialParam.AState := state; MyDialParam.AError := error; |
А также вызовем функцию GetStatusString (будет описана ниже), которая сообщит нам в Label1.Caption о состоянии соединения.
Form1.Label1.Caption := GetStatusString(MyDialParam.AState, MyDialParam.AError);
Form1.Label1.Update; {на всякий случай}
|
AEntryDial:=ListBox1.Items.Strings[ListBox1.ItemIndex];Заполним все поля переменной DialParams нолями.
FillChar(DialParams, SizeOf(TRasDialParams), 0);Инициализируем переменную DialParams и поместим в поле szEntryName этой переменной название выбранного "удаленного соединения"
With DialParams Do
Begin
dwSize:=Sizeof(TRasDialParams);
StrPCopy(szEntryName, FEntry2Dial);
End;
Вызовем библиотечную функцию RasGetEntryDialParams, которая заполнит оставшиеся незаполненными поля переменной DialParams R:=RasGetEntryDialParams(nil, DialParams, Fp);Далее, если все удачно (см. значение переменной R), вызываем библиотечную функцию RasDial, поместив в нее переменную DialParams и указав на описанную выше CallBack-процедуру RasCallBack. В случае ошибок в работе функции RasDial вызовем библиотечную функцию обработки ошибок RasGetErrorString
, которая даст нам текст сообщения об ошибке, и выйдем из процедуры.
if R = 0 then
begin
Application.ProcessMessages; {*****}
R := RasDial(nil, nil, DialParams, 0, @RasCallback, hRAS);
if R <> 0 then
begin
RasGetErrorString(R, C, 100);
MessageBox(0, C, 'Ошибка!', MB_OK);
Exit;
end;
end;
|
Которая даст нам состояние соединения. Думаю, что переменные State и Error уже не требуют объяснения.
if Error <> 0 then
begin
RasGetErrorString(Error, C, 100);
Result := C;
end
else
begin
S := '';
case State of
RASCS_OpenPort:
S := 'Opening port';
// .................................
// вырезано ....
// .................................
RASCS_Disconnected:
S := 'Disconnected';
end;
Result := S;
end;
|
После того, что мы уже рассмотрели, ответ на этот вопрос покажется очень простым - надо вызвать библиотечную функцию RasHangUp с одной единственной уже описанной нами переменной hRas: ThRASConn.
RasHangUp(hRas) |
***** - Это для того, чтобы в процессе соединения с сервером наше приложение могло реагировать на сообщения Windows, например, на нажатие кнопок.
RAS API программирование.
| Автор: Антонянц Вадим Валерьевич |
| Приходит программист в библиотеку и спрашивает библиотекаря: - Книги по программированию где? Ему объясняют, что заканчивать предложение на вопросительном слове стилистически неправильно. Программист: - Понял! Книги по программированию где, дурья твоя башка? |
В последнее время, я получаю много писем с просьбой объяснить на конкретном примере, принцип построения программ заменяющих собой стандартное средство дозвона Windows. Это довольно сложно сделать просто и понятно, в связи со спецификой работы разных модификаций этой популярной операционной системы. Для каждого случая необходим индивидуальный подход, но основополагающие алгоритмы функционирования неизменны. В начале 1999 года, я опубликовал в Usenet~е, некоторые соображения по этому поводу в месте с простым примером написания программы осуществляющей дозвон и соединение с провайдером. Не берусь утверждать, что такой подход единственно правильный. Но как мне кажется данный пример, позволяет ответить на массу вопросов по программированию RASAPI.
Некоторое время назад у меня появилась проблема с учетом времени проведенного в сети и дополнительного сервиса в плане автоматической конфигурации модема в зависимости от времени суток. Хочу пояснить, что у нас используется АТС старого типа с механическими контактами и поэтому качество соединения с провайдером изменяется по определенному закону. С 10-12 часов дня до 22-24 часов вероятность рас соединения в процессе работы примерно возрастает, а в остальное время таких проблем обычно не возникает. Выходом из ситуации являлось дополнительное программирование модема при помощи АТ команд. То есть создается несколько соединений в телефонной книге Windows и в зависимости от времени суток дозванивание до провайдера осуществляется по определенной закономерности. Появилось желание все это автоматизировать, но подходящей программы "звонилки" обнаружить не удалось. Тогда было принято решение написать программу позволяющую решить все эти и некоторые другие поставленные задачи по телефонному соединению с провайдером.
Первоначальный вариант эскиза программы был написан мной на Microsoft С, благодаря достаточному обилию информации по Remote Access Service (Удаленное Обслуживание Доступа) и вполне приличной справочной документации в стандартной поставке Visual C++ V5.0. Однако, такие факторы как "раздутость" кода бесконечные мытарства при выражении оптимизированного алгоритма функционирования и наконец большие затраты времени на составление красивого интерфейса пользователя привели меня к мысли о написании программы в среде разработки Delphi 4. Вначале это казалось довольно сложной задачей, так как в Delphi отсутствует модуль прототипов RASAPI функций, но небольшое их количество и логическая простота составления подобных прототипов в объектном Паскале Delphi позволило в короткий срок сгруппировать необходимые данные.
Предполагаемый алгоритм работы программы "звонилки" достаточно прост. Есть два пути проведения соединения с удаленным сервером. Первый путь - это когда программа не интегрирована в операционную систему и работает автономно. То есть она при помощи RAS API функций получает информацию о списке текущих соединений и после выбора необходимого, начинает процесс телефонного соединения вплоть до конечного результата. Системная программа "звонилка" в этом случаи может быть активизирована независимо от вашей программы и при наличии встроенной функции учета времени проведенного в сети может сучиться, что при соединении с ее помощью учет времени будет нарушен. Правда на сей счет, есть оговорка, что при безостановочном цикле проверки существующих соединений все-таки можно проводить достаточно точный учет времени проведенного в Интернете. Но при этом значительно расходуются ресурсы системы. Второй путь - несколько сложнее, но он наиболее интересен с точки зрения алгоритма реализации. При помощи функций RAS API, программа интегрируется в систему и в некоторых случаях позволяет заменять собой системную "звонилку". При необходимости проведения соединения, система проецирует в адресное пространство вызывающего процесса вашу DLL, вызывая функцию повторного вызова, прототип которой заранее известен и стандартизирован. В момент вызова данной функции из DLL, в ней может быть создан новый поток или потоки в текущем пространстве вызывающего процесса для создания интерфейса программы "звонилки". Так же, из этой DLL может быть создан новый объект ядра типа процесс со своими 4 Гб виртуального адресного пространства, в котором порождается главный поток отдельной программы "звонилки".
В конечном итоге я остановился на втором варианте, где из моей DLL вызывается отдельная программа "звонилка", запускаемая в отдельном процессе и управляемая из функции повторного вызова DLL разнообразными способами. Осталось дело за малым - выбором способа обмена данными между приложениями. Автоматизация OLE и создание и внедрение COM объектов были отброшены сразу из за больших и безосновательных затрат системных ресурсов и памяти. Оставалось использовать несколько устаревший способ динамический обмена данными между приложениями DDE. Вот тут и начались казусы. При применении библиотеки DDEML при выполнении транзакции XTYP_REQUEST (запрос клиентом на возвращение данных из сервера) необходимо создать в DLL специальную функцию повторного вызова, в которую при запросе клиента, сервер должен возвращать данные. Хочу сразу отметить, что здесь речь идет только об асинхронных транзакциях, так как функция повторного вызова DLL должна возвращать приложению ее запросившему, результат работы вашей программы "звонилки" и в случае неудачи вызывать системную "звонилку". Так вот, если производилась вышеописанная транзакция и не было выхода из функции повторного вызова, отправка данных сервера клиенту не производилась (в свою функцию повторного вызова). Причем это происходило и в библиотеке написанной в Microsoft С. Не помогало да же открытие нового потока и создание обработчика транзакции в нем. Причиной тому, по моему глубокому убеждению, являлось специфика работы Windows 98 (в Windows NT все работало прекрасно). Решением проблемы оставалось использование DDE без применения библиотеки Ddeml.dll и оконные общения на уровне системы. Первый путь из-за своей неэффективности (из пушки по воробьям), был отброшен сразу и обмен данными между библиотекой и программой "звонилки" производился при помощи оконных сообщений (Window Messages).
Теперь я хочу кратко описать алгоритм функционирования моей программы. В случае интеграции программы в систему, при надобности соединения с удаленным сервером браузер, например Internet Explorer, проецирует DLL в сое адресное пространство (динамическая загрузка) и вызывает функцию повторного вызова. Информацию об имени функции и полном пути к DLL он получает в процессе интеграции программы. В начальном этапе вызова функции в DLL создается новый поток, в котором регистрируется новый класс окна и создается невидимое пользователю скрытое окно. Функция обработчик оконных сообщений регистрирует только два типа оконных сообщений - это WM_DESTROY и WM_USER. Первое необходимо для деструктуризации окна, а второе, непосредственно для получения данных из программы сервера. В дальнейшем, производится поиск окна программы "звонилки" в системе и в случаи его отсутствия порождается новый отдельный процесс, в главном потоке которого идет выполнение Вашей программы. Дальнейший обмен данными между приложениями происходит на уровне оконных сообщений. При удачном или неудачном результате дозвона функция повторного вызова возвращает в программу заказчик соответствующее значение и в зависимости от этого, вызывается или не вызывается системная программа "звонилка". При выгрузке DLL из памяти скрытое окно получает сообщение WM_DESTROY, тем самым, корректно завершая поток. Хочу особо отметить, что для упрощения кода программы в программе-сервере (написанной в Delphi) не создается дополнительное окно, а все оконные сообщения обрабатываются в главном окне программы. Для этого была переопределена процедура базового класса VCL WndProc. Данный способ не является достаточно корректным, однако при правильном понимании специфики работы VCL (Visual components library) значительно упрощает программирование.
Приведенные мной здесь исходники не являются законченной программой, а представляют собой испытательный полигон для проверки разнообразных алгоритмов и их способов реализации. Поэтому, буду очень рад любой информации и готов поддержать любое обсуждение этого вопроса. Только есть большая просьба, не присылать сообщения подобного типа - "На кой ляд тебе это все сдалось. Уже такая прога существует...".
PS: Внимание!!! Если в среде разработки Delphi4 будет открыта страница с Maim.pas, работа отлаживаемой программы будет нарушена т. к. это окно будет ошибочно найдена функцией API FindWindow. Поэтому пред отладкой программы закройте эту страницу.Загрузить пример (17 Кб).
Работа с отчетами Rave Report в режиме RunTime.
Автор: Турушев Виталий Введение С выходом Delphi 7 мы стали свидетелями выхода нового генератора отчетов Rave Report Borland Edition от разработчиков фирмы Nevrona. Среда разработки Rave имеет довольно много новшеств, и в тоже время ряд ошибок и недочетов. Среди положительных качеств можно отметить: сохранение проекта отчета в файл и чтение его из файла, что позволяет удобно загрузить или сохранить необходимый проект отчета, и в дальнейшем работать с ним. Также есть набор компонентов для конвертирования отчета Rave в другие форматы (PDF, HTML, RTF, TEXT). Rave Report значительно облегчает разработку отчетов где используются базы данных, ведь выбор компонентов доступа к источникам данных весьма неплох. Среди недочетов отмечу: недоработку среды разработки отчетов Rave, где присутствует ряд серьезных ошибок. Также Nevrona предоставила довольно таки очень скудную справку для разработчика и не порадовала достаточным количеством примеров работы с отчетами Rave. Причиной написания данной статьи стало отсутствие примеров и описания работы с отчетами Rave в режиме RunTime, что не позволяет пользователю более гибко работать с отчетом (например: изменение данных/оформления в отчете при наступлении определенного события в программе, а возможности Event Editor в Rave Report увы ограничены), что отталкивает пользователей от использования генератора отчетов Rave. Возможно, по этой причине или по причине недоработки генератора отчета часть пользователей возвращается к генератору отчетов Quick Report или к генераторам отчетов других разработчиков. Исследование классов в проекте отчета Rave ReportДля работы с отчетами в RunTime потребуется, знание имен подключаемых модулей в раздел uses, создаваемого проекта. Ниже представлена таблица описания основных модулей, которые могут понадобятся для работы с отчетом Rave в RunTime. Примечание: Для разработчиков CLX приложений название модулей почти идентично, только в имени модуля предшествует символ «Q». Например: QRvCsBars. Все модули находятся в каталоге «\Rave5\Lib» куда установлена среда программирования Delphi 7.
Имя модуля Описание модуля
RvClass Этот модуль содержит реализацию базовых классов
RvProj В этом модуле набор классов реализующие собственно сам проект
отчета и отвечающих за работу с ним
RvCsDraw Классы в этом модуле реализуют графические примитивы
RvCsBars В этом модуле реализованы штриховые коды
RvCsStd В этом модуле реализуются основные элементы оформления отчета
RvCsRpt, Набор классов в данном модуле служит для вывода данных из
RvCsData баз данных или других источников данных
Примечание: В качестве файла отчета взят уже готовый демонстрационный пример отчета RaveDemo.rav, поставляемый с генератором отчета Rave Report, который находится в каталоге «\Rave5\Demos». Поэтому следует указать полный путь к файлу отчета или скопировать данный файл в каталог с текущим проектом.
И так, осталось выяснить, что далее необходимо для работы с отчетом в RunTime. Всю работу с проектом отчета обеспечивает класс TRaveProjectManager – менеджер отчетов. Следовательно, потребуются некоторые знания о свойствах и методах этого класса.
Примечание: Следует разделять понятие проект отчета и отчет как таковой в отдельности. Проект отчета – может содержать в себе целую коллекцию отдельных отчетов. Отчет – это набор страниц, элементов оформления, элементов доступа к различным источникам данных и т.п., то, что подготовлено или подготавливается для печати отчета.
Также могут, пригодиться знания по работе с технологией RTTI для извлечения наименований свойств, событий (методов) и другой информации из объектов (компонентов) отчета Rave Report. Можно и не изучать принципы работы с технологией RTTI, ведь наименование доступных свойств интересующего объекта можно увидеть в среде разработки Rave Report инспектора объектов.
И так, двигаемся далее. Для работы с отчетом в RunTime, конечно, необходимо знать из набора каких объектов состоит данный отчет и, от каких классов произошли эти объекты, ведь в справочной системе Rave Report о них нет ни слова. Для этого необходимо написать процедуру, которая поможет узнать, из каких объектов состоит отчет, а также поможет выяснить имена классов и объектов. Код данной процедуры представлен ниже:
procedure GetListObjects(ListClass: TStrings; ClassX: TComponent; TabStr:
string; AddObjects: Boolean = False);
var
I: Integer;
begin
if (ClassX = nil) or (ListClass = nil) then
EXIT;
for I := 0 to ClassX.ComponentCount - 1 do
begin
if AddObjects then
ListClass.AddObject(TabStr + ClassX.Components[I].Name +
' - ' + ClassX.Components[I].ClassName, ClassX.Components[I])
else
ListClass.Add(TabStr + ClassX.Components[I].Name +
' - ' + ClassX.Components[I].ClassName);
if ClassX.Components[I].ComponentCount > 0 then
GetListObjects(ListClass, ClassX.Components[I], TabStr + '..',
AddObjects);
end;
end;
Как видите, процедура достаточно проста. В цикле процедуры осуществляется проход по всем дочерним компонентам в компоненте «ClassX» и если дочерний компонент содержит в себе еще вложенные компоненты, то используется рекурсивный вызов процедуры GetListObjects. В результате чего будет получен список всех компонентов. Вполне вероятно, что захочется узнать всех предков исследуемого объекта, тогда можно воспользоваться приведенной ниже процедурой.
procedure GetListParentClassName(ListClass: TStrings;
ClassX: TClass; ClearList: Boolean = True);
begin
if (ClassX = nil) or (ListClass = nil) then
EXIT;
if ClearList then
ListClass.Clear;
while ClassX <> nil do
begin
ListClass.Add(ClassX.ClassName);
ClassX := ClassX.ClassParent;
end;
end;
Пример вызова процедуры GetListParentClassName:
GetListParentClassName(MemoInfo.Lines, RvProjectRTR.ClassType);
или
GetListParentClassName(MemoInfo.Lines, TRvProject);
Как было сказано выше, для доступа к проекту отчета необходим класс TRaveProjectManager. Чтобы получить к нему доступ, необходимо обратиться к свойству «ProjMan» класса TRvProject. Как известно в проекте отчета Rave Report может содержаться несколько отчетов. Работа с отчетом осуществляется через класс TRaveReport. Для доступа к текущему активному отчету нужно обратиться к свойству «ActiveReport» класса TRaveProjectManager.
Вот для свойства «ActiveReport» класса TRaveProjectManager и следует применить выше описанную процедуру GetListObjects для получения списка объектов из отчета. Для использования процедуры можно использовать, к примеру, такие строки кода:
... ListObjects.Clear; GetListObjects(ListObjects.Items, RvProjectRTR.ProjMan.ActiveReport, '', True); ...Посмотрите на результат работы процедуры GetListObjects. Вы наверняка сразу заметили одну особенность, что все имена классов представленных объектов начинаются с приставки «TRave…». Ну вот, зная имена классов, работать будет уже намного легче. Совет: Если известен некий класс, но неизвестно в каком модуле данный класс описан, то это можно выяснить с помощью поисковика файлов с поддержкой поиска текста внутри файлов. В поисковике задать маску для поиска «*.dcu» в папке «\Rave5\Lib», а в строке для поиска текста указать наименование класса, например: TRaveControl. Исследование объектов средствами технологии RTTI Получив список объектов, не мешало бы поподробнее получить информацию об интересующем объекте. В этом, безусловно, поможет технология RTTI. Если вы имеете опыт работы с RTTI, то можете пропустить данный раздел статьи. Примечание: В данной статье не будет достаточно подробно рассматриваться принцип работы с RTTI так как эта тема довольно-таки велика по объему. Будет рассмотрено только то, что поможет в дальнейшей работе. Более подробно с принципами работы технологии RTTI вы можете познакомиться в книге Стива Тейксейра и Ксавье Пачеко «DELPHI 5 Руководство разработчика. Том 2. Разработка компонентов и работа с базами данных». Процедуры, реализованные в этой статье, основаны на примерах из этой книги, и были несколько доработаны для работы с проектом, описываемым в данной статье.
Для работы с RTTI в раздел проекта uses необходимо подключить модуль TypInfo. Для извлечения информации RTTI обычно требуется две структуры: PTypeInfo и PTypeData. Ниже приведена процедура, которая выводит базовую информацию об интересующем объекте.
// Извлечение базовой информации об объекте
procedure GetListClassInfo(ListInfo: TStrings; ClassX: TObject; ClearList:
Boolean = True);
var
// В данные структуры записывается информация об RTTI объекта
Class_PTI: PTypeInfo;
Class_PTD: PTypeData;
begin
if (ClassX = nil) or (ListInfo = nil) then
EXIT;
if ClearList then
ListInfo.Clear;
// Получение информации об RTTI объекта
Class_PTI := ClassX.ClassInfo;
Class_PTD := GetTypeData(Class_PTI);
// Вывод базовой информации об объекте
with ListInfo do
begin
Add('Базовая информация:');
Add(Format('Имя класса: '#9' %s',[Class_PTI.Name]));
Add(Format('Тип класса: '#9' %s',
[GetEnumName(TypeInfo(TTypeKind),
Integer(Class_PTI.Kind))]));
Add(Format('Размер объекта: '#9' %d',[ClassX.InstanceSize]));
Add(Format('Описан в модуле: '#9' %s',[Class_PTD.UnitName]));
Add(Format('Всего доступно свойств: %d', [Class_PTD.PropCount]));
if ClassX is TRaveControl then
begin
Add('Родительский компонент:');
Add(Format('Тип класса: %s',
[TRaveControl(ClassX).Parent.ClassName]));
Add(Format('Имя компонента: %s', [TRaveControl(ClassX).Parent.Name]));
end;
Add('Генеалогическое дерево класса:');
// Вывод информации о предках объекта
GetListParentClassName(ListInfo, ClassX.ClassType, False);
end;
end;
Примечание: Следует помнить, что в RTTI доступны только те свойства и методы, которые определены в секции published исследуемого объекта, т.е. те которые видны в инспекторе объ-ектов среды разработки Delphi. Свойства и методы необъявленные в секции published через технологию RTTI будут недоступны.
Следующая процедура выводит список наименований свойств, свойств-событий (методы) и тип свойств исследуемого объекта. Также данная процедура выводит текущие значения, присвоенные свойствам объекта. Для свойств типа tkClass (в этих свойствах храниться ссылка на некий объект) выводиться имя объекта, на который ссылается данное свойство. Если же это свойство не ссылается на объект, то будет выведено значение «NIL».
// Извлечение информации о наименовании свойств и событий объекта
procedure GetListProperty(ListPropertys: TStrings; ClassX: TObject; AddObjects:
Boolean = False; ClearList: Boolean = True);
var
PropList: PPropList;
Class_PTI: PTypeInfo;
Class_PTD: PTypeData;
I, PropertyCount: Integer;
S, StrVal: string;
TmpObj: TObject;
begin
if (ClassX = nil) or (ListPropertys = nil) then
EXIT;
if ClearList then
ListPropertys.Clear;
Class_PTI := ClassX.ClassInfo;
Class_PTD := GetTypeData(Class_PTI);
if Class_PTD.PropCount <> 0 then
begin
// Выделение памяти под структуры TPropInfo, в зависимости от количества свойств объекта
GetMem(PropList, SizeOf(PPropInfo) * Class_PTD.PropCount);
try
// Заполнение PropList указателями на структуры TPropInfo
GetPropInfos(ClassX.ClassInfo, PropList);
for I := 0 to Class_PTD.PropCount - 1 do
// Добавляются свойства не являющиеся событиями
if not (PropList[I]^.PropType^.Kind = tkMethod) then
begin
// Извлечение текущего значения свойства
if PropList[I]^.PropType^.Kind = tkClass then
begin
TmpObj := GetObjectProp(ClassX, PropList[I]^.Name);
if TmpObj = nil then
StrVal := 'NIL'
else
// Если у объекта есть предок TComponent,
// то извлекается имя объекта иначе имя класса
if TmpObj is TComponent then
StrVal := TComponent(TmpObj).Name
else
StrVal := '(' + TmpObj.ClassName + ')';
end
else
StrVal := GetPropValue(ClassX, PropList[I]^.Name);
S := Format('%s: %s = %s', [PropList[I]^.Name,
PropList[I]^.PropType^.Name, StrVal]);
if AddObjects then
ListPropertys.AddObject(S, TObject(PropList[I]^.PropType^))
else
ListPropertys.Add(S);
end;
// Поиск свойств-событий
PropertyCount := GetPropList(ClassX.ClassInfo, [tkMethod], PropList);
ListPropertys.Add('*** Свойства-события ***');
// Добавляются свойства-события
for i := 0 to PropertyCount - 1 do
begin
S := Format('%s: %s', [PropList[I]^.Name, PropList[I]^.PropType^.Name]);
if AddObjects then
ListPropertys.AddObject(S, TObject(PropList[I]^.PropType^))
else
ListPropertys.Add(S);
end;
finally
// Освобождение ранее выделенной памяти
FreeMem(PropList, SizeOf(PPropInfo) * Class_PTD.PropCount);
end;
end;
end;
Процедур GetListClassInfo и GetListProperty вполне достаточно, чтобы изучить необходимый объект. Но самой полезной является, конечно, процедура GetListProperty. Как видите процедура GetListProperty достаточно сложная по виду. Еще бы, ведь структуры PTypeInfo и особенно PTypeData довольно-таки «ветвистые» по своему строению. Понимание выше приведенных процедур осложняет еще и то, что Borland не документирует данную технологию так как, она может изменяться от одной версии Delphi к другой, вследствие чего это не может гарантировать работоспособность одного и того же кода в различных версиях Delphi.
Для просмотра результата работы приведенных выше двух можно применить следующие строки кода:
...
if ListObjects.Items.Objects[ListObjects.ItemIndex] <> nil then
begin
GetListClassInfo(MemoInfo.Lines,
ListObjects.Items.Objects[ListObjects.ItemIndex]);
GetListProperty(ListProperty.Items,
ListObjects.Items.Objects[ListObjects.ItemIndex], True);
end;
...
Но и это еще не все возможности технологии RTTI. Также есть возможность получить достаточно полную информацию о свойстве или методе исследуемого объекта. Для извлечения столь немаловажной информации следует воспользоваться приведенной ниже процедурой.
// Извлечение информации о свойствах и методах объекта
procedure GetPropertyInfo(ListInfo: TStrings; PTI: PTypeInfo; PTD: PTypeData;
ClearList: Boolean = True);
type
// Структура для извлечения информации из методов (свойства-события)
PParamRec = ^TParamRec;
TParamRec = packed record
Flags: TParamFlags;
ParamName: ShortStringBase;
TypeName: ShortStringBase;
end;
var
I: Integer;
S, S2: string;
TeStr,
RStr: ^ShortStringBase;
ParamRec: PParamRec;
// Базовая информация для всех свойств
procedure Name_Info;
begin
ListInfo.Add(Format('Тип свойства: %s', [PTI.Name]));
ListInfo.Add(Format('Подтип свойства: %s',
[GetEnumName(TypeInfo(TTypeKind),
Integer(PTI^.Kind))]));
end;
// Информация для целочисленных, множеств и перечисляемых типов свойств
procedure Int_Info;
begin
ListInfo.Add(Format('Минимальное значение: %d', [PTD^.MinValue]));
ListInfo.Add(Format('Максимальное значение: %d', [PTD^.MaxValue]));
end;
// Информация для типов свойств с плавающей точкой
procedure Float_Info;
begin
// Определение подтипа свойства
case PTD^.FloatType of
ftSingle: S := 'ftSingle';
ftDouble: S := 'ftDouble';
ftExtended: S := 'ftExtended';
ftComp: S := 'ftComp';
ftCurr: S := 'ftCurr';
end;
ListInfo.Add(Format('Подтип tkFloat: %s', [S]));
ListInfo.Add('Минимальное значение: ' + FloatToStr(PTD^.MinInt64Value));
ListInfo.Add('Максимальное значение: ' + FloatToStr(PTD^.MaxInt64Value));
end;
// Информация для свойства представленного как класс
procedure Class_Info;
begin
ListInfo.Add(Format('Предок класса свойства: %s',
[PTD^.ParentInfo^.Name]));
ListInfo.Add(Format('Доступно свойств у объекта: %d', [PTD^.PropCount]));
ListInfo.Add(Format('Описан в модуле: %s',
[PTD^.UnitName]));
end;
// Информация для методов (свойства-события)
procedure Method_Info;
var
J: Integer;
begin
// Определение типа метода
case PTD^.MethodKind of
mkProcedure: S := 'Procedure ';
mkFunction: S := 'Function ';
mkConstructor: S := 'Constructor ';
mkDestructor: S := 'Destructor ';
mkClassProcedure: S := 'ClassProcedure ';
mkClassFunction: S := 'ClassFunction ';
mkSafeProcedure: S := 'SafeProcedure ';
mkSafeFunction: S := 'SafeFunction ';
end;
// Извлечение информации о передаваемом параметре
ParamRec := @PTD^.ParamList;
J := 1;
ListInfo.Add(Format('Передаваемых параметров: %d',
[PTD^.ParamCount]));
while J <= PTD^.ParamCount do
begin
if J = 1 then
S := S + '(';
// Определение метода передачи параметра
if pfVar in ParamRec.Flags then
S2 := 'var ';
if pfConst in ParamRec.Flags then
S2 := 'const ';
if pfArray in ParamRec.Flags then
S2 := 'array of ';
if pfOut in ParamRec.Flags then
S2 := 'out ';
// Извлечение информации о типе передаваемого параметра
TeStr := Pointer(Integer(@ParamRec^.ParamName) +
Length(ParamRec^.ParamName) + 1);
S := S + S2;
S := Format('%s%s: %s', [S, ParamRec^.ParamName, TeStr^]);
Inc(J);
// Извлечение информации о следующем передаваемом параметре
ParamRec := PParamRec(Integer(ParamRec) + SizeOf(TParamFlags) +
(Length(ParamRec^.ParamName) + 1) + (Length(TeStr^) + 1));
if J > PTD^.ParamCount then
S := S + ')';
// Если метод является функцией, то извлекается информация о возвращаемом параметре
if PTD^.MethodKind = mkFunction then
begin
RStr := Pointer(ParamRec);
S := Format('%s: %s;', [S, RStr^]);
end
else
S := S + '; ';
end;
ListInfo.Add(S);
end;
// Вывод информации для строковых типов свойств
procedure Str_Info;
begin
ListInfo.Add(Format('Максимальная длина: %d', [PTD^.MaxLength]));
end;
begin
if (ListInfo = nil) or (PTI = nil) or (PTD = nil) then
EXIT;
if ClearList then
ListInfo.Clear;
Name_Info;
// Извлечение информации для свойств множеств
if PTI^.Kind = tkSet then
begin
PTI := PTD^.CompType^;
PTD := GetTypeData(PTI);
Name_Info;
end;
case PTI^.Kind of
tkInteger: Int_Info;
tkFloat: Float_Info;
tkString: Str_Info;
tkLString: Str_Info;
tkWString: Str_Info;
// Извлечение информации для перечисляемых свойств
tkEnumeration:
begin
Int_Info;
ListInfo.Add('Варианты значений:');
for I := PTD^.MinValue to PTD^.MaxValue do
ListInfo.Add(Format('Значение: %s', [GetEnumName(PTI, I)]));
end;
tkClass: Class_Info;
tkMethod: Method_Info;
end;
end;
Примечание: Для перечисляемых свойств, информацию «Минимальное значение» и «Максимальное значение» выводимую процедурой GetPropertyInfo следует понимать как первый и последний индекс элемента перечисляемого свойства.
Использовать процедуру GetPropertyInfo можно так:
procedure TFormRTR.ListPropertyClick(Sender: TObject);
var
TI: PTypeInfo;
TD: PTypeData;
begin
if ListProperty.Items.Objects[ListProperty.ItemIndex] = nil then
EXIT;
TI := PTypeInfo(ListProperty.Items.Objects[ListProperty.ItemIndex]);
TD := GetTypeData(TI);
GetPropertyInfo(MemoInfo.Lines, TI, TD);
end;
Имея на вооружении такие замечательные процедуры, наконец, то можно изучить интересующие классы, узнать свойства и методы, а также тип свойств исследуемых классов. Получив достаточно подробную информацию с помощью технологии RTTI теперь, наконец, можно перейти к работе с проектом отчета Rave Report в режиме RunTime, но сначала ознакомимся с основными классами, которые встречаются в проекте отчета Rave Report.
Описание классов TRaveXXX
В этом разделе статьи содержится описание классов, из которых в основном состоит проект отчета. Проект отчета формируют три основных класса: TRaveProjectManager, TRaveReport, TRavePage. Для работы с источниками данных могут использоваться классы TRaveDataView, TRaveDataField, а так же TRaveRegion и TRaveDataBand. Разберем эти основные классы более конкретно.
Как описывалось выше, класс TRaveProjectManager обеспечивает всю базовую работу с проектом отчета Rave. Осуществляет такие основные задачи как: чтение/сохранение проекта отчета, работа с коллекцией отчетов и глобальными страницами, поиск необходимого отчета и компонентов TRaveXXX и многое другое. Ниже приведено описание основных свойств класса TRaveProjectManager.
Примечание: * – предположительное описание свойства, ввиду того, что в справочной системе Rave не предоставлена информация по данному свойству. (скрытый) – данное свойство доступно через технологию RTTI, но скрыто в инспекторе объектов среды разработки Rave Report.
TRaveProjectManager
AdminPassword Пароль для доступа к проекту отчета * Categories Хранит список наименования категорий. Далее отдельному отчету можно указать тип категории, что помогает организовать более удобную работу и произвести поиск отчетов по категориям CompileNeeded Необходима компиляция (скрытый) * Description Сюда записывается более подробная информация о компоненте DevLocked Блокировка компонента от случайных изменений его свойств FullName Альтернативное наименование компонента Locked Блокировка компонента от случайных изменений его свойств Name Имя компонента Parameters Описание параметров, которые могут использоваться для сохранения временных вычислений или другой информации PIVars По назначению подобны Parameters, но присваиваются значения, которые определены после передачи команды на печать (After Print) SecurityControl Определяет параметры доступа к серверам баз данных для ввода имени и пароля пользователя Tag Тег, хранит целое число, которое используется разработчиком для собственных нужд Units Определяет единицу измерения для всех отчетов UnitsFactor Коэффициент для перевода текущей единицы измерения в дюймы OnBeforeReport Обработчик события перед генерацией отчета OnAfterReport Обработчик события после генерации отчета OnBeforePrint Обработчик события пред посылкой задания на печать OnAfterPrint Обработчик события после завершения печати Примечание: Если вы исследовали, какой либо класс TRaveXXX средствами RTTI, то наверно обратили внимание, что события OnBeforeReport, OnAfterReport, OnBeforePrint, OnAfterPrint не являются методами как в VCL Delphi, а являются ссылками на класс TRaveSimpleEvent. Теперь познакомимся с классом TRaveReport. Данный класс представляет собой отдельный отчет, который является контейнером, хранящим в себе страницы отчета. Описание основных свойств класса TRaveReport приведены ниже.TRaveReport
AlwaysGenerate Перед печатью отчета заполняет переменные типа TotalPages, чтобы их значение было известно перед печатью первой страницы Category Позволяет установить принадлежность отчета к заданной категории. Список доступных категорий задается в свойстве «Categories» менеджера отчетов TRaveProjectManager Collate Определяет тип упорядочивания задания на печать CompileNeeded Необходима компиляция (скрытый) * Copies Хранит количество копий, после печати отчета Description Сюда записывается более подробная информация о компоненте DevLocked Блокировка компонента от случайных изменений его свойств Duplex Установка типа дуплексной печати для принтера (не для всех принтеров) FirstPage Первая страница отчета FullName Альтернативное наименование компонента Locked Блокировка компонента от случайных изменений его свойств MaxPages Ограничивает число генерируемых страниц при генерации отчета после вызова метода Execute, 0 – генерируются все страницы Name Имя компонента PageList Список страниц для печати. Здесь можно задать какие страницы печатать и в каком порядке Parameters Описание параметров, которые могут использоваться для сохранения временных вычислений или другой информации PIVars По назначению подобны Parameters, но присваиваются значения, которые определены после передачи команды на печать (After Print) Printer Задается имя принтера, на который выводится печать. Если поле пустое, то вывод данных осуществляется на текущий принтер Resolution Установка качества печати SecurityControl Определяет параметры доступа к серверам баз данных для ввода имени и пароля пользователя Tag Тег, хранит целое число, которое используется разработчиком для собственных нужд OnAfterPrint Обработчик события после завершения печати OnAfterReport Обработчик события после генерации отчета OnBeforePrint Обработчик события пред посылкой задания на печать OnBeforeReport Обработчик события перед генерацией отчета Переходим к классу TRavePage. Данный класс реализует страницу отчета и также является контейнером, в который помещаются различные элементы оформления отчета, а также вспомогательные не визуальные элементы, например как TRaveFontMaster. Рассмотрим свойства класса TRavePage в приведенной ниже таблице.TRavePage
Bin Указывается тип лотка для подачи бумаги BinCustom Если в представленном списке Bin нет необходимого типа лотка, то указывается пользовательская константа лотка, поддерживаемая принтером CompileNeeded Необходима компиляция (скрытый) * Description Сюда записывается более подробная информация о компоненте DevLocked Блокировка компонента от случайных изменений его свойств FullName Альтернативное наименование компонента GotoMode Определяет метод перехода по страницам «GotoPage» при печати GotoPage Печать указанной страницы после печати текущей страницы GridLines Определяет шаг видимой линии в координатной сетке GridSpacing Размер шага между линиями в координатной сетке Locked Блокировка компонента от случайных изменений его свойств Name Имя компонента Orientation Вид ориентации страницы (книжная/альбомная) PageHeight Высота страницы PageWidth Ширина страницы PaperSize Выбор формата страницы поддерживаемый текущим принтером Parameters Описание параметров, которые могут использоваться для сохранения временных вычислений или другой информации PIVars По назначению подобны Parameters, но присваиваются значения, которые определены после передачи команды на печать (After Print) Tag Тег, хранит целое число, которое используется разработчиком для собственных нужд WasteFit Запрещает или разрешает при генерации отчета, пропорционально располагать элементы оформления на всю рабочую область страницы OnAfterPrint Обработчик события после завершения печати OnAfterReport Обработчик события после генерации отчета OnBeforePrint Обработчик события пред посылкой задания на печать OnBeforeReport Обработчик события перед генерацией отчета TRaveDataView – данный класс-посредник обеспечивает работу и связь между источниками данных и отчетом (данное назначение класса предположительно ввиду отсутствия справочной информации о нем). Описан он в модуле RvDirectDataView.TRaveDataView
CompileNeeded Необходима компиляция * ConnectionName Хранит имя подключенного источника данных Description Сюда записывается более подробная информация о компоненте DevLocked Блокировка компонента от случайных изменений его свойств FullName Альтернативное наименование компонента Locked Блокировка компонента от случайных изменений его свойств Name Имя компонента Tag Тег, хранит целое число, которое используется разработчиком для собственных нужд OnBeforeReport Обработчик события перед генерацией отчета OnAfterReport Обработчик события после генерации отчета OnBeforePrint Обработчик события пред посылкой задания на печать OnAfterPrint Обработчик события после завершения печати TRaveDataField – данный класс представляет собой поле данных и предоставляет вывод информации из источника данных. Этот класс расположен в модуле RvDataField.TRaveDataField
Calculated Вычисляемое поле или нет * Description Сюда записывается более подробная информация о компоненте DevLocked Блокировка компонента от случайных изменений его свойств FieldName Имя поля FullName Альтернативное наименование компонента Locked Блокировка компонента от случайных изменений его свойств Name Имя компонента NullText Текст, выводимый по умолчанию (если нет данных в источнике данных) Size Размер поля Tag Тег, хранит целое число, которое используется разработчиком для собственных нужд OnBeforeReport Обработчик события перед генерацией отчета OnAfterReport Обработчик события после генерации отчета OnBeforePrint Обработчик события пред посылкой задания на печать OnAfterPrint Обработчик события после завершения печати Ниже в таблице приведено описание классов, которые можно встретить в палитре компонентов среды разработки отчетов Rave Report. Визуальные компоненты – это те самые элементы оформления отчетов, такие как: линия, текст, штриховые коды и др. Не визуальные компоненты выполняют вспомогательные функции в оформлении отчета (TRaveFontMaster, TRavePageNumInit), или выполняют вычисления при генерации отчета, такие компоненты как TRaveCalcController, TRaveCalcOp и другие. Также к не визуальным элементам отчетов относятся компоненты TRaveRegion, TRaveBand, TRaveDataBand и компоненты доступа к источникам данных. В заголовке таблицы приведено имя модуля, где данные классы реализованы.RvCsDraw
TRaveGraphicBase Является базовым классом для всех классов данного модуля. Произошел данный класс от TRaveControl. TRaveSurface Происходит от класса TRaveGraphicBase и уже содержит в себе свойства реализующие базовые элементы оформления и стилей. TRaveLine Элемент оформления – линия. TRaveHLine Элемент оформления – горизонтальная линия. TRaveVLine Элемент оформления – вертикальная линия TRaveRectangle Элемент оформления – прямоугольник TRaveSquare Элемент оформления – квадрат. TRaveEllipse Элемент оформления – эллипс. TRaveCircle Элемент оформления – окружность.RvCsBars
TRaveBaseBarCode Базовый класс штрихового кода. TRavePostNetBarCode Постсетевой штриховой код (PostNet), используется американской почтовой службой в доставке почты. TRaveI2of5BarCode Числовой штриховой код (I2of5). TRaveCode39BarCode Алфавитно-цифровой штриховой код (Code39). Символ может хранить кодируемые данные. Разработан, чтобы кодировать 26 прописных букв, 10 цифр и 7 специальных символов. TRaveCode128BarCode Алфавитно-цифровой штриховой код с высокой плотностью (Code128). Символ может хранить кодируемые данные. Разработан, чтобы кодировать первые 128 ASCII символов. TRaveUPCBarCode Универсальный штриховой код изделия (UPC). TRaveEANBarCode Европейский международный номер, штриховой код подобен штриховому коду UPC (EAN).RvCsStd
TRaveText Элемент оформления – текст. TRaveMemo Элемент оформления – текстовое поле MEMO. TRaveSection Вспомогательный элемент оформления, реализующий группировку объектов. TRaveBitmap Элемент оформления для вывода растрового изображения. TRaveMetaFile Элемент оформления для вывода метафайла. TRaveFontMaster Вспомогательный элемент оформления, для установки свойства шрифта у текстовых компонентов. Компоненты позволяющие работать с компонентом TRaveFontMaster содержат свойство «FontMirror». TRavePageNumInit Вспомогательный элемент оформления позволяющий производить нумерацию страниц.RvCsRpt
TRaveRegion Компонент-контейнер, размещающий в себе элементы оформления отчета. Также позволяет создать печать отчета в несколько столбцов. Используется для работы с источниками баз данных. TRaveBand Компонент-контейнер, также размещающий в себе элементы оформления отчета. В основном используется для создания верхних и нижних колонтитулов или других сносок. TRaveDataBand Компонент-контейнер, размещающий в себе элементы оформления отчета для вывода информации из баз данных. TRaveDataCycle Используется для вычислений, сортировки или фильтрации.RvCsData
TRaveDataText Элемент оформления отчета, для вывода однострочных данных из источника баз данных. TRaveDataMemo Элемент оформления отчета, для вывода многострочных данных из источника баз данных. TRaveDataMirrorSection Компонент-контейнер, размещающий в себе элементы оформления отчета для доступа к источникам баз данных и объединяющий их в одну группу. TRaveCalcText Элемент оформления отчета, позволяющий производить вычисления по указанному полю источника данных. TRaveCalcOp Вспомогательный элемент, позволяющий производить вычисления по двум указанным полям источника данных. TRaveCalcTotal Вспомогательный элемент, позволяющий производить вычисления по указанному полю источника данных и имеет возможность передать вычисленное значение какому либо элементу оформления отчета. TRaveCalcController Вспомогательный элемент, позволяющий задать параметры вычислений. Также данный класс выполняет все заданные функции вычислений. Доступ к объектам проекта отчета Rave Report в режиме RunTimeНу вот, когда проведена большая работа по исследованию классов в проекте отчета Rave Report, наконец, можно приступить непосредственно к работе с отчетом в режиме RunTime. Еще раз напомню порядок доступа к активному (текущему) отчету Rave:
Для доступа к проекту отчета необходимо обратиться к классу TRaveProjectManager. Для доступа к классу TRaveProjectManager следует обратиться к свойству «ProjMan» класса TRvProject. Чтобы получить доступ к активному отчету, следует обратиться к свойству «ActiveReport» класса TRaveProjectManager. То есть последовательность такого типа: TRvProject.ProjMan.ActiveReport.Как вы уже знаете в отчете содержаться еще и страницы. К сожалению, разработчики не предоставили методов для навигации по страницам отчета (представлено только одно свойство «FirstPage» – первая страница), но это проблема вполне решаема. Ниже приведена процедура, которая возвращает список указателей на объекты (если таковые имеются), порожденных от указанного класса.
// Возвращает список указателей на объекты, порожденных от указанного класса FindClass
procedure GetObjectList(RootComponent: TComponent; FindClass: TClass; var
PageList: TList);
var
I: Integer;
begin
PageList.Clear;
if (RootComponent = nil) or (PageList = nil) then
EXIT;
for I := 0 to RootComponent.ComponentCount - 1 do
if RootComponent.Components[I] is FindClass then
PageList.Add(RootComponent.Components[I]);
end;
Пример вызова процедуры:
GetObjectList(RvProjectRTR.ProjMan.ActiveReport, TRavePage, RavePageList);Данный вызов процедуры заполняет список RavePageList указателями на все найденные страницы в текущем отчете. Теперь используя список RavePageList можно удобно осуществлять навигацию по страницам отчета, точно так же, как по списку отчетов представленный менеджером отчетов TRaveProjectManager. Список отчетов можно получить, обратившись к свойству «ReportList» класса TRaveProjectManager. Используя процедуру GetObjectList можно получить список и других объектов произошедших от определенного класса, что облегчает навигацию по объектам определенного типа. Примечание: У класса TRaveReport в наличии есть свойство «PageList». Данное свойство определяет порядок страниц при печати. Допустим, в отчете имеется 10 страниц, а в «PageList» указанно печатать 3-ю и 8-ю страницу. Тогда свойство «PageList.Count», будет равным 2-ум, и доступ вы сможете получить только к 3-й и 8-й странице отчета. Если же в свойстве «PageList» нет ссылок на страницы отчета (PageList = NIL), то при попытке обратиться к данному свойству будет получено сообщение об ошибке. Поэтому не следует забывать специфику данного свойства. Примечание: TRaveReport также предоставляет свойство «Page» доступное только для чтения. Можно было бы предположить, что данное свойство хранит ссылку на активную страницу текущего отчета, но по каким то причинам в данном свойстве все время присутствует значение равное NIL. Так что назначение данного свойства для меня пока неизвестно. Слов сказано уже много, но на практике еще мало чего сделано. Думаю, настало время перейти к практической части. За основу, как оговаривалось в начале статьи, взят демонстрационный проект отчета «RaveDemo.rav», вот над ним и будут производиться все опыты на практике. Для экспериментов возьмем, к примеру, отчет «Mirror Report».
Попробуем изменить заголовок первой страницы у отчета «Mirror Report». Для оттого необходимо:
Найти и активизировать отчет «Mirror Report» средством вызова метода «SelectReport» класса TRvProject. Произвести поиск текстового элемента оформления TRaveText на первой странице отчета TRavePage. Для этого можно воспользоваться методом «FindRaveComponent» класса TRaveProjectManager, который в случае успешного поиска в качестве возвращаемого параметра вернет найденный объект, в противном случае возвратится NIL. Убедиться, что искомый объект произошел от нужного класса. Если искомый объект найден, то произвести с ним все необходимые манипуляции. После внесенных изменений сгенерировать отчет методом «Execute» или «ExecuteReport» класса TRvProject.Ниже представлен пример реализации всего выше изложенного.
...
var
I: Integer;
TmpRaveComponent: TRaveComponent;
begin
// Поиск и активизация необходимого отчета. Метод вернет false если отчет не найден
if not RvProjectRTR.SelectReport('Mirror Report', true) then
EXIT;
// Поиск компонента с именем 'Text1' на первой странице отчета
TmpRaveComponent := RvProjectRTR.ProjMan.FindRaveComponent('Text1',
RvProjectRTR.ProjMan.ActiveReport.FirstPage);
// Если объект найден, и он произошел от класса TRaveText
if (TmpRaveComponent <> nil) and (TmpRaveComponent is TRaveText) then
begin
// Замена выводимого текста
TRaveText(TmpRaveComponent).Text := 'Это мой новый заголовок';
// Изменение стиля шрифта
TRaveText(TmpRaveComponent).Font.Style := [fsItalic];
end;
// Генерация активного отчета
RvProjectRTR.Execute;
end;
...
Как видите, ничего особо сложного нет. Найдя необходимый объект в отчете с ним можно делать почти все что угодно. Почему почти? Когда вы исследовали визуальные элементы оформления отчета средствами RTTI, то, может быть, обратили внимание на то, что все эти компоненты не имеют свойства «Visible», хотя данное свойство уже доступно начиная с класса TRaveComponent. К сожалению, разработчики по каким то причинам не стали учитывать значение свойства «Visible», что в принципе огорчает. Все-таки иногда может возникнуть необходимость скрыть, что-либо из отчета в зависимости от событий в программе.
Есть возможность имитировать свойство «Visible» используя свойство «Parent» нужного объекта. Чаще всего в качестве родителя объектов выступает страница отчета, но для группировки визуальных компонентов отчета в качестве родителя может выступать компонент-контейнер TRaveSection (также группировку объектов выполняют TRaveRegion и TRaveDataBand). Если визуальному компоненту не будет указан родитель в свойстве «Parent», т.е. значение равное NIL, то данный объект не будет отображен в сгенерированном отчете. Для имитации свойства «Visible» объектов вновь обратимся к отчету «Mirror Report». В данном отчете скроем все элементы оформления TRaveRectangle путем скрытия объектов TRaveSection. Последовательность действий будет следующей:
Найти и активизировать отчет «Mirror Report» средством вызова метода «SelectReport» класса TRvProject. Пробежаться по всем дочерним компонентам страницы и найти компоненты производные от класса TRaveSection. У компонентов TRaveSection в свойстве «Parent» проверить наличие родителя. Если родительский компонент назначен, то данному свойству присвоить значение NIL (скрытие объекта), в ином случае данному свойству в качестве родителя присвоить страницу отчета (отображение объекта на странице). После внесенных изменений сгенерировать отчет.Возможно, некоторые задались вопросом, – почему бы сразу не скрыть TRaveRectangle напрямую, а через объект TRaveSection? Все возможно, но в данном случае:
Элементы оформления TRaveRectangle объединены в группу компонентом TRaveSection. Следовательно, у объектов TRaveRectangle общий родитель TRaveSection. При назначении свойству «Parent» значения NIL у объекта TRaveSection, данный объект теряет родителя и скрывается со всеми его дочерними компонентами TRaveRectangle. Если каждому объекту TRaveRectangle в свойстве «Parent» указать значение равное NIL, а затем в данном свойстве в качестве нового родителя указать страницу отчета, то данные компоненты окажутся не на своем месте. Это вызвано тем, что значения в свойствах «Left» и «Top» компонента TRaveRectangle получены относительно клиентской части компонента TRaveSection. Отсюда вывод, что для корректного восстановления объектов для каждого TRaveRectangle нужно указать своего прежнего родителя, а это несколько усложняет подход к данной задаче. Но при необходимости все это возможно реализовать.Ниже представлен фрагмент кода, имитирующий скрытие объектов.
...
var
I: Integer;
TmpRaveComponent: TRaveComponent;
begin
// Поиск и активизация необходимого отчета. Метод вернет false если отчет не найден
if not RvProjectRTR.SelectReport('Mirror Report', true) then
EXIT;
// Проход по всем объектам первой страницы отчета
for I := 0 to RvProjectRTR.ProjMan.ActiveReport.FirstPage.ComponentCount - 1
do
// Если объект является TRaveSection
if RvProjectRTR.ProjMan.ActiveReport.FirstPage.Components[I] is TRaveSection
then
begin
TmpRaveComponent :=
TRaveComponent(RvProjectRTR.ProjMan.ActiveReport.FirstPage.Components[I]);
// Если данный объект не имеет родителя, то в качестве
// родителя указывается первая страница отчета
if TmpRaveComponent.Parent = nil then
TmpRaveComponent.Parent := RvProjectRTR.ProjMan.ActiveReport.FirstPage
// Если объект имеет родителя, то уничтожается ссылка на родителя,
// что в следствии приводит к скрытию объекта
else
TmpRaveComponent.Parent := nil;
end;
// Генерация активного отчета
RvProjectRTR.Execute;
...
Примечание: Вместо свойства «Visible» разработчики предусмотрели свойство «DisplayOn» у визуальных элементов оформления. Данное свойство позволяет установить, в каком случае отображать данный элемент оформления. Отображать: только при предварительном просмотре, только при выводе на печать, отображать в обоих случаях или наследовать настройки родителя. Изменение значения данного свойства упорно игнорируется визуальными компонентами. Очень жаль.
Рассмотрим еще одну проблему при оформлении отчета. Следует обратить внимание на отсутствие привычных свойств у некоторых визуальных компонентов. Возьмем, например компонент для вывода текста (TRaveText – аналог компонента TLabel). Данный компонент не предоставляет свойства для выбора фонового цвета (цвет кисти Brush) и по умолчанию является прозрачным.
На заметку: Фоновый цвет TRaveText останется прозрачным в том случае, если сгенерировать отчет, вызвав метод «Execute» или «ExecuteReport» класса TRvProject. Если отчет сгенерировать из среды разработки Rave Report, то фоновая заливка белого цвета под текстом останется непрозрачной. Такая вот недоработка присутствует в Rave Report.
Также в данном компоненте отсутствует свойство, определяющее его высоту. Не найдется там и привычное свойство «AutoSize» для выравнивания клиентского размера объекта под размер выводимого текста. Отчасти некоторые недостатки можно имитировать. Для придания фонового цвета можно подложить под компонент, к примеру, элемент оформления прямоугольник (TRaveRectangle).
Создать имитацию фонового цвета для текста в редакторе событий «Event Editor» весьма проблематично. Данная проблема выражается в следующем: т.к. в TRaveText не предоставлено свойство «Height» определяющее его высоту, то соответственно нет возможности получить точный размер по высоте компонента. Следовательно, при изменении размера шрифта компонента придется вручную подгонять высоту компонента TRaveRectangle. Также попытка получить доступ к свойству «BoundsRect, Height» (или к другому свойству или методу, не предоставленному в инспекторе объектов среды разработки отчета Rave Report) компонента может привести к плачевным результатам (даже если компиляция кода в «Event Editor» прошла успешно). В лучшем случае можно отделаться сообщением об ошибке, в худшем – критическое завершение работы генератора отчета Rave Report c потерей всех несохраненных данных, а при работе под
Windows 98 возможен полный «крах» системы.
Как видите, редактор событий «Event Editor» не предоставляет таких гибких возможностей для работы, как доступ к объектам в режиме RunTime. Для имитации фонового цвета как упоминалось выше вполне можно применить TRaveRectangle. Для этого необходимо:
Создать объект производный от TRaveRectangle и придать ему нужное оформление. Подогнать размеры TRaveRectangle под размеры TRaveText. Поместить объект TRaveRectangle на задний план, воспользовавшись методом объекта «SendToBack».Реализация имитации фонового цвета под текстом представлена ниже. В данном случае не удалось только создать имитацию «AutoSize» для объекта TRaveText:
...
var
I: Integer;
TmpRaveComponent: TRaveComponent;
TmpRavePage: TRavePage;
BGRect: TRaveRectangle;
begin
// Поиск и активизация необходимого отчета. Метод вернет false если отчет не найден
if not RvProjectRTR.SelectReport('Mirror Report', true) then
EXIT;
TmpRavePage := RvProjectRTR.ProjMan.ActiveReport.FirstPage;
// Поиск компонента с именем 'Text1' на первой странице отчета
TmpRaveComponent := RvProjectRTR.ProjMan.FindRaveComponent('Text1',
TmpRavePage);
// Если объект найден, и он произошел от класса TRaveText
if (TmpRaveComponent <> nil) and (TmpRaveComponent is TRaveText) then
begin
// Создание графического примитива - прямоугольник
BGRect := TRaveRectangle.Create(TmpRavePage);
// Заполнение свойств вновь созданного объекта
with BGRect do
begin
Name := 'BackGroundRect';
FillColor := clYellow;
BorderStyle := psClear;
// Указание родителя компонента
Parent := TmpRavePage;
// Подгонка размеров прямоугольника под размеры компонента TRaveText
BoundsRect := TRaveText(TmpRaveComponent).BoundsRect;
// Перемещение объекта на задний план
SendToBack;
end;
end;
// Генерация активного отчета
RvProjectRTR.Execute;
end;
...
В режиме RunTime вполне самостоятельно возможно создать: отчет, страницу отчета, визуальные элементы оформления или другие объекты, поддерживаемые отчетом Rave Report. Для создания нового отчета необходимо обратиться к методу «NewReport» менеджера отчетов TRaveProjectManager. В качестве возвращаемого параметра, возвращается объект порожденный от класса TRaveReport вновь созданного отчета. Для создания новой страницы для отчета следует обратиться к методу «NewPage» класса TRaveReport. Данный метод, как и в предыдущей ситуации, в качестве возвращаемого параметра возвращает объект типа TRavePage вновь созданной страницы отчета.
Примечание: При создании нового отчета автоматически создается и новая страница.
При создании многостраничного отчета не следует забывать про свойство «GotoPage» компонента TRavePage или свойство «PageList» компонента TRaveReport, ведь данные свойства содержат указатели на следующую генерируемую страницу отчета. Если не воспользоваться ни одним из представленных свойств, то при генерации отчета будет сгенерированна только первая страница отчета. При создании новой страницы или отчета в RunTime нет необходимости указывать вновь созданным объектам хозяина или родителя компонента, все это, данные методы «NewReport» и «NewPage» осуществляют самостоятельно. При создании визуальных и не визуальных компонентов следует указать хозяина объекта. Если в качестве хозяина будет передано значение равное NIL, то после завершения работы с данными объектами, программист должен уничтожить их самостоятельно, воспользовавшись методом «Free» данного объекта. Для всех визуальных элементов оформления отчета следует обязательно указывать нужного родителя в свойстве «Parent». Вспомните имитацию скрытия объектов
в отчете. Также учитывайте установленную единицу измерения в проекте отчета, для верного размещения визуальных объектов в отчете, иначе можете удивиться полученному результату.
В ниже приведенном примере создается отчет с двумя страницами. На первой странице создается текстовый элемент оформления TRaveText, а на второй странице компонент
TRaveBitMap для вывода графического изображения.
const
NewRep = 'MyNewReport'; // Имя отчета (динамически создаваемого)
FieldStr = 'FieldStr'; // Имя строкового поля
FieldInt = 'FieldInt'; // Имя целочисленного поля
NewDataView = 'NewDataView';
// Имя компонента для посредника с источником данных
...
// Вычисление позиции точки в процентах относительно
// ширины/высоты визуального компонента
function SetPointInPercent(RaveControlWH: TRaveUnits; Percent: Byte):
TRaveUnits;
begin
Result := (RaveControlWH / 100) * Percent;
end;
...
const
Picture = '1.bmp';
var
TmpRaveReport: TRaveReport;
TmpRavePage: TRavePage;
TmpRaveText: TRaveText;
TmpRaveBitMap: TRaveBitmap;
TmpPageList: TRaveComponentList;
begin
// Если отчет уже создан, то выходим
if RvProjectRTR.SelectReport(NewRep, true) then
EXIT;
// Добавление нового отчета в проект и заполнение его свойств
TmpRaveReport := RvProjectRTR.ProjMan.NewReport;
with TmpRaveReport do
begin
Name := NewRep;
FullName := NewRep;
// Создание новой страницы для отчета (здесь будет графическое изображение)
TmpRavePage := NewPage;
// Указывается следующая страница для генерации отчета,
// после того, как будет сгенерированна первая страница отчета
TmpRaveReport.FirstPage.GotoPage := TmpRavePage;
end;
// Создание компонента для вывода графического изображения и заполнение его свойств
TmpRaveBitMap := TRaveBitMap.Create(TmpRavePage);
with TmpRaveBitMap do
begin
Name := 'MyNewRaveBitMap';
Left := SetPointInPercent(TmpRavePage.PageWidth, 5);
Top := SetPointInPercent(TmpRavePage.PageHeight, 20);
Width := SetPointInPercent(TmpRavePage.PageWidth, 30);
Height := SetPointInPercent(TmpRavePage.PageHeight, 30);
// Загрузка графического изображения (если найден указанный файл)
if FileExists(Picture) then
Image.LoadFromFile(Picture);
// Размеры изображения будут подогнаны под клиентские размеры компонента
MatchSide := msBoth;
// Родителем данного компонента будет страница TmpRavePage
Parent := TmpRavePage;
end;
// Создание элемента TRaveText и заполнение его свойств
TmpRaveText := TRaveText.Create(TmpRaveReport.FirstPage);
with TmpRaveText do
begin
Left := SetPointInPercent(TmpRaveReport.FirstPage.PageWidth, 10);
;
Top := SetPointInPercent(TmpRaveReport.FirstPage.PageHeight, 15);
;
Font.Size := 18;
Name := 'MyNewRaveText';
// Родителем данного объекта будет первая страница отчета
Parent := TmpRaveReport.FirstPage;
Text := 'Этот текст расположен на первой странице отчета';
end;
// Заполение свойств страницы TmpRavePage
with TmpRavePage do
begin
Name := 'MyNewRavePage';
FullName := 'Моя новая страница';
end;
// Создание списка генерируемых страниц
TmpPageList := TRaveComponentList.Create;
TmpPageList.Add(TmpRavePage);
TmpPageList.Add(TmpRaveReport.FirstPage);
TmpRaveReport.PageList := TmpPageList;
// Обновление списка доступных отчетов
RvProjectRTR.GetReportList(ListReport.Items, True);
end;
...
В данном примере для перехода к следующей генерируемой странице применены оба свойства «PageList» и «GotoPage». Чтобы лучше понять их принцип работы создайте новый отчет по выше представленному примеру и сгенерируйте его.
...
if RvProjectRTR.SelectReport('Мой новый отчет', true) then
RvProjectRTR.Execute;
...
Как видите, отчет сгенерировал три страницы. Это происходит потому, что сначала осуществляется проход по списку в свойстве «PageList» (если он не пуст). Вновь генерируемая страница из этого списка также проверяет свое свойство «GotoPage» на наличие перехода на другую страницу. После генерации страницы указанной в свойстве «GotoPage» (если данное свойство указывает на страницу) продолжается обход по списку «PageList». Следует соблюдать осторожность при указании порядка генерации страниц отчета, при задании неверного порядка может произойти бесконечный цикл генерации страниц (если данный случай имеет место быть). Схематично это можно отобразить так (в скобках указан порядок генерации страниц):
Если очистить список страниц у отчета в свойстве «PageList» (все в том же выше приведенном примере) и вновь сгенерировать отчет, то результат соответственно будет совсем другим.
...
if RvProjectRTR.SelectReport('Мой новый отчет', true) then
begin
RvProjectRTR.ProjMan.ActiveReport.PageList := nil;
RvProjectRTR.Execute;
end;
...
Можно в отчете в RunTime подключить и источник данных. Как оговаривалось выше эти функции выполняют основные классы: TRaveDataView, TRaveDataField и собственно сам источник данных, например TRvDataSetConnection.
Условимся, что некий источник данных в проекте уже существует и содержит некоторые данные. В данном случае рассмотрим пример подключения к текстовому типу поля таблицы. Для начала нам потребуется «связной» с источником данных – TRaveDataView. Для того, чтобы созданный «связной» присутствовал в проекте отчета Rave Report его нужно добавить в список подключенный модулей данных, воспользовавшись методом «Add» свойства «DataObjectList» у класса TRaveProjectManager. У созданного объекта TRaveDataView достаточно заполнить четыре основных свойства: Name – имя компонента, Parent – родительский компонент (TRaveProjectManager), DataCon.Connection – подключаемый источник данных (в данном примере TRvDataSetConnection), ConnectionName – имя подключаемого источника данных. Далее необходимо найти необходимое поле в источнике данных TDataSet воспользовавшись методом «FindField» и выяснить к какому типу данных это поле принадлежит. После определения типа поля в источнике данных необходимо создать соответствующее (совместимое) поле данных TRaveDataField для отчета Rave Report. Для TRaveDataField также достаточно заполнить четыре основных свойства: Name – имя компонента, FieldName – имя поля, Parent – родительский компонент (TRaveDataView), DataIndex – порядковый номер в списке полей источника данных (таблице). При необходимости в отчете можно создать TRaveRegion, TRaveDataBand, TRaveDataText (если не созданны). Будем считать, что данные объекты уже созданы в проекте отчета Rave Report. Для TRaveDataBand, TRaveDataText следует указать поставщика источников данных (TRaveDataView) воспользовавшись свойством «DataView» этих классов. Для TRaveDataText следует дополнительно указать имя поля, из которого будет производиться выборка данных, для чего следует обратиться к свойству «DataField» этого класса.Пример реализации подключения источника данных приведен ниже. Данный пример присоединяет источник данных к вновь созданному отчету ('MyNewReport' – рассмотренному выше).
...
var
TmpRaveReport: TRaveReport;
TmpDataView: TRaveDataView;
TmpDataField: TRaveDataField;
TmpRaveRegion: TRaveRegion;
TmpRaveDataBand: TRaveDataBand;
TmpRaveDataText: TRaveDataText;
TmpField: TField;
begin
TmpDataField := nil;
if not RvProjectRTR.SelectReport(NewRep, true) then
EXIT;
if (ADOTableRTR.FieldCount < 1) or (not ADOTableRTR.Active) then
EXIT;
// Поиск строкового поля
TmpField := RvDataSetConnectionRTR.DataSet.FindField(FieldStr);
if TmpField = nil then
EXIT;
TmpRaveReport := RvProjectRTR.ProjMan.ActiveReport;
// Создание TRaveDataView обеспечивающий работу с источником данных
TmpDataView := TRaveDataView.Create(RvProjectRTR.ProjMan);
RvProjectRTR.ProjMan.DataObjectList.Add(TmpDataView);
with TmpDataView do
begin
Name := NewDataView;
Parent := RvProjectRTR.ProjMan;
DataCon.Connection := RvDataSetConnectionRTR;
ConnectionName := TmpDataView.DataCon.Connection.Name;
end;
// В зависимости от типа данных поля создается поле данных для отчета
// Rave Report соотвествующего типа
case TmpField.DataType of
ftString,
ftWideString: TmpDataField := TRaveStringField.Create(TmpDataView);
ftInteger: TmpDataField := TRaveIntegerField.Create(TmpDataView);
end;
if TmpDataField = nil then
EXIT;
// Заполение свойств поля данных
with TmpDataField do
begin
Name := TmpField.Name; // Имя компонента
FieldName := TmpField.FieldName; // Имя поля
FullName := TmpField.DisplayName; // Альтернативное имя поля
// Порядковый номер в списке полей источника данных (таблице)
DataIndex := TmpField.Index;
Parent := TmpDataView; // Родительский компонент
end;
// Создание TRaveRegion на котром будут расположены компоненты для работы с источником данных
TmpRaveRegion := TRaveRegion.Create(TmpRaveReport.FirstPage);
with TmpRaveRegion do
begin
Name := 'NewRaveRegion';
Parent := TmpRaveReport.FirstPage;
Left := SetPointInPercent(TmpRaveReport.FirstPage.PageWidth, 5);
Top := SetPointInPercent(TmpRaveReport.FirstPage.PageHeight, 15);
Width := SetPointInPercent(TmpRaveReport.FirstPage.PageWidth, 70);
Height := SetPointInPercent(TmpRaveReport.FirstPage.PageHeight, 60);
end;
// Создание TRaveDataBand для размещения елементов оформления отчета на нем
TmpRaveDataBand := TRaveDataBand.Create(TmpRaveRegion);
with TmpRaveDataBand do
begin
Name := 'NewDataBand';
Parent := TmpRaveRegion;
Left := SetPointInPercent(TmpRaveRegion.Width, 5);
Top := SetPointInPercent(TmpRaveRegion.Height, 5);
Width := SetPointInPercent(TmpRaveRegion.Width, 90);
Height := SetPointInPercent(TmpRaveRegion.Height, 5);
DataView := TmpDataView;
end;
// TRaveDataText обеспечит отображение информации из источника данных
TmpRaveDataText := TRaveDataText.Create(TmpRaveDataBand);
with TmpRaveDataText do
begin
Name := 'NewDataText';
Parent := TmpRaveDataBand;
Left := SetPointInPercent(TmpRaveDataBand.Width, 1);
Top := SetPointInPercent(TmpRaveDataBand.Height, 1);
Width := SetPointInPercent(TmpRaveDataBand.Width, 50);
DataView := TmpDataView;
DataField := TmpDataField.FieldName;
end;
RvProjectRTR.ExecuteReport(NewRep);
...
Создав новый отчет или изменив существующий можно сохранить внесенные изменения. Чтобы ваши труды не пропали даром, измененный проект отчета можно сохранить, воспользовавшись методом «Save». Если возникнет необходимость сохранить проект отчета Rave Report под другим именем, то следует изменить имя файла проекта в свойстве «ProjectFile» или воспользоваться методом «SetProjectFile» перед сохранением проекта. Все данные свойства и методы доступны у менеджера отчета TRvProject или TRaveProjectManager. Пример сохранения проекта отчета под другим именем:
...
// Сохраниение новго отчета под именем 'TestSave.rav'
RvProjectRTR.SetProjectFile('TestSave.rav');
RvProjectRTR.Save;
...
Скачать пример можно здесь
P.S. Ну, вот вроде и все о чем хотелось поведать. Надеюсь после выхода данной статьи, у пользователей генератора отчета Rave Report работа хоть сколько-то облегчится. Если вы заметили какие-либо ошибки, недочеты в данной статье, а также если у вас есть какие либо предложения или дополнения к данной статье, то все ваши отзывы будут приятны здесь: Sun-bittern@mail.ru
Турушев Виталий (Sun bittern ©)
Нижний Тагил 2004г.
Литература: 1. Стив Тейксейра и Ксавье Пачеко «DELPHI 5 Руководство разработчика. Том 2. Разработка компонентов и работа с базами данных».
Показать TRadioButtons в TListView.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ComCtrls;
type
TMain = class(TForm)
ListView1: TListView;
Button1: TButton;
Button2: TButton;
procedure FormCreate(Sender : TObject);
procedure FormDestroy(Sender : TObject);
procedure Button1Click(Sender : TObject);
procedure Button2Click(Sender : TObject);
private
ListViewRadioList: TList;
procedure ListViewRadioCreate(List : TListView; R : TRect);
procedure ListViewRadioClear(List : TListView; Liste : TList);
procedure ListViewRadioFree(List : TListView; Liste : TList);
procedure ListViewListSelected(Item : integer; List : TListView);
procedure ListViewRadioClick(Sender : TObject);
public
{ Public-Deklarationen }
end;
var
Main : TMain;
implementation
{$R *.DFM}
procedure TMain.FormCreate(Sender : TObject);
begin
ListViewRadioList := TList.Create;
end;
procedure TMain.FormDestroy(Sender : TObject);
begin
ListViewRadioFree(ListView1, ListViewRadioList);
end;
procedure TMain.Button1Click(Sender : TObject);
var
R : TRect;
NewColumn : TListColumn;
ListItem : TListItem;
I : integer;
begin
with ListView1 do
begin
ViewStyle := vsReport;
Align := alLeft;
RowSelect := True;
ReadOnly := True;
ShowColumnHeaders := False;
NewColumn := Columns.Add;
NewColumn.Width := 15;
NewColumn := Columns.Add;
NewColumn.Width := Width - 15 - 19; // - breite Button - breite vom Scrollbalken
Items.BeginUpdate;
for I := 0 to 9 do
begin
ListItem := Items.Add;
R := Items[I].DisplayRect(drBounds);
R.Left := 1;
R.Right := Columns[0].Width;
ListViewRadioCreate(ListView1, R);
Items[I].Data := TRadioButton(ListViewRadioList[I]);
ListItem.SubItems.Add('Test' + IntToStr(I));
end;
Items.EndUpdate;
end;
end;
procedure TMain.Button2Click(Sender : TObject);
begin
ListViewRadioClear(ListView1, ListViewRadioList);
end;
//------------------------------------------------------------------------------
procedure TMain.ListViewRadioCreate(List : TListView; R : TRect);
function NewViewRadio: TRadioButton;
begin
Result := TRadioButton.Create(Self);
Result.Parent := List;
Result.BoundsRect := R;
Result.OnClick := ListViewRadioClick;
end;
begin
ListViewRadioList.Add(NewViewRadio);
end;
//------------------------------------------------------------------------------
procedure TMain.ListViewRadioFree(List : TListView; Liste : TList);
var
I : integer;
begin
if Liste.Count - 1 < 0 then exit;
for I := 0 to Liste.Count - 1 do TRadioButton(Liste[I]).Free;
Liste.Free;
end;
//------------------------------------------------------------------------------
procedure TMain.ListViewRadioClear(List : TListView; Liste : TList);
var
I : integer;
begin
if Liste.Count - 1 < 0 then exit;
List.Items.BeginUpdate;
for I := 0 to Liste.Count - 1 do TRadioButton(Liste[I]).Free;
List.Items.Clear;
Liste.Clear;
List.Items.EndUpdate;
end;
//------------------------------------------------------------------------------
procedure TMain.ListViewListSelected(Item : integer; List : TListView);
begin
with List do
begin
try
SetFocus;
except
end;
Selected := Items[Item];
ItemFocused := Selected;
end;
end;
//------------------------------------------------------------------------------
procedure TMain.ListViewRadioClick(Sender : TObject);
var
I : integer;
begin
for I := 0 to ListViewRadioList.Count - 1 do
if TRadioButton(ListViewRadioList[I]).Checked then
begin
ListViewListSelected(I, ListView1);
break;
end;
end;
end.
Модуль для RC5 шифрования.
Автор: Матвеев Игорь "Я бы изменил мир - но Бог не даёт исходников..." - ALI.
В предыдущей статье "Модуль для IDEA шифрования" речь шла об алгоритме шифрования IDEA - International Data Encryption Algorithm. В данной статье я продолжу тему шифрования, на этот раз мы разберем алгоритм RC5.
Прежде всего немного о самом алгоритме: алгоритм был разработан Рональдом Ривестом (Ronald L. Rivest) для компании RSA Data Security. На основе RC5 в свое время был создан алгоритм шифрования RC6, который участвовал в конкурсе на звание AES (Advanced Encryption Standard - "Продвинутый" алгоритм шифрования). объявленном национальным институтом стандартизации и технологий для замены уже устаревшего алгоритма DES. Тогда RC6 не выиграл только из-за низкой производительности аппаратных реализаций алгоритма. А программные реализации RC5 и RC6 являются, пожалуй, самыми быстрыми среди всех алгоритмов шифрования, обеспечивающих достаточную стойкость перед атаками.
Например, по некоторым данным скорость грамотно построенной аппаратной реализации алгоритма RC5 на компьютере с скоростью процессора 200 МГц может достигать 10..11 Мбайт/сек, а алгоритма RC6 - 11..12 Мбайт/сек. Для сравнения - скорость работы алгоритма Rijndael (победитель конкурса на звание AES) при вышеозначенных характеристиках процессора может достигать максимум 7 Мбайт/сек.
Если вам срочно нужно внедрить алгоритмы шифрования в свои коммерческие проекты - на мой взгляд лучший выбор это RC5 или RC6. И не только потому, что они значительно проще в реализации, чем, например, IDEA, но и потому, что RC5 и RC6 (насколько я знаю - ручаться не могу) свободные алгоритмы и вы не должны отчислять часть прибыли при коммерческом использовании алгоритма.
Итак, RC5 работает с блоками по восемь байт - два 32 битных слова. В отличии от IDEA и Rijndael в RC5 после развертывания ключа вычисляется один подключ, который используется и при шифровании, и при дешифровании. RC5, как и большинство алгоритмов - раундовый алгоритм, другими словами, при шифрации блока над ним производятся одни и те же операции несколько раз, в RC5 таких раундов 12.
Вот пожалуй и все, что вам нужно знать о теории алгоритма RC5, все остальное видно из модуля. Модуль RC5 похож на модуль IDEA из моей предыдущей статьи. Если вы уже используете модуль IDEA в своих программах - для использования RC5 вам достаточно просто уброть из uses модуль IDEA и включить туда модуль RC5 (все имена методов сохраняются).
{ *********************************************************************** }
{ }
{ Delphi Еnсгурtiоn Library }
{ Еnсгурtiоn / Decryption stream - RC5 }
{ }
{ Copyright (c) 2004 by Matveev Igor Vladimirovich }
{ With offers and wishes write: teap_leap@mail.ru }
{ }
{ *********************************************************************** }
unit RC5;
interface
uses
SysUtils, Classes;
type
TRC5Block = array[1..2] of LongWord;
const
Rounds = 12;
BlockSize = 8;
BufferSize = 2048;
KeySize = 64;
KeyLength = 2 * (Rounds + 1);
P32 = $b7e15163;
Q32 = $9e3779b9;
var
Key : string;
KeyPtr : PChar;
S : array[0..KeyLength-1] of LongWord;
////////////////////////////////////////////////////////////////////////////////
// Дополнительные функции
procedure Initialize(AKey: string); // Инициализация
procedure CalculateSubKeys; // Подготовка подключей
function EncipherBlock(var Block): Boolean; // Шифрация блока (8 байт)
function DecipherBlock(var Block): Boolean; // Дешифрация блока
////////////////////////////////////////////////////////////////////////////////
// Главные функции
function EncryptCopy(DestStream, SourseStream : TStream; Count: Int64;
Key : string): Boolean; // Зашифровать данные из одного потока в другой
function DecryptCopy(DestStream, SourseStream : TStream; Count: Int64;
Key : string): Boolean; // Расшифровать данные из одного потока в другой
function EncryptStream(DataStream: TStream; Count: Int64;
Key: string): Boolean; // Зашифровать содержимое потока
function DecryptStream(DataStream: TStream; Count: Int64;
Key: string): Boolean; // Расшифровать содержимое потока
implementation
////////////////////////////////////////////////////////////////////////////////
function ROL(a, s: LongWord): LongWord;
asm
mov ecx, s
rol eax, cl
end;
////////////////////////////////////////////////////////////////////////////////
function ROR(a, s: LongWord): LongWord;
asm
mov ecx, s
ror eax, cl
end;
////////////////////////////////////////////////////////////////////////////////
procedure InvolveKey;
var
TempKey : string;
i, j : Integer;
K1, K2 : LongWord;
begin
// Разворачивание ключа до длинны 64 символа
TempKey := Key;
i := 1;
while ((Length(TempKey) mod KeySize) <> 0) do
begin
TempKey := TempKey + TempKey[i];
Inc(i);
end;
// Now shorten the key down to one KeySize block by combining the bytes
i := 1;
j := 0;
while (i do
begin
Move((KeyPtr+j)^, K1, 4);
Move(TempKey[i], K2, 4);
K1 := ROL(K1, K2) xor K2;
Move(K1, (KeyPtr+j)^, 4);
j := (j + 4) mod KeySize;
Inc(i, 4);
end;
end;
////////////////////////////////////////////////////////////////////////////////
procedure Initialize(AKey: string);
begin
Key := AKey;
GetMem(KeyPtr, KeySize);
FillChar(KeyPtr^, KeySize, #0);
InvolveKey;
end;
////////////////////////////////////////////////////////////////////////////////
{$R-,Q-}
procedure CalculateSubKeys;
var
i, j, k : Integer;
L : array[0..15] of LongWord;
A, B : LongWord;
begin
// Copy the key into L
Move(KeyPtr^, L, KeySize);
// Now initialize the S table
S[0] := P32;
for i := 1 to KeyLength-1 do
S[i] := S[i-1] + Q32;
// Now scramble the S table with the key
i := 0;
j := 0;
A := 0;
B := 0;
for k := 1 to 3*KeyLength do
begin
A := ROL((S[i] + A + B), 3);
S[i] := A;
B := ROL((L[j] + A + B), (A + B));
L[j] := B;
i := (i + 1) mod KeyLength;
j := (j + 1) mod 16;
end;
end;
////////////////////////////////////////////////////////////////////////////////
function EncipherBlock(var Block): Boolean;
var
RC5Block : TRC5Block absolute Block;
i : Integer;
begin
Inc(RC5Block[1], S[0]);
Inc(RC5Block[2], S[1]);
for i := 1 to Rounds do
begin
RC5Block[1] := ROL((RC5Block[1] xor RC5Block[2]), RC5Block[2]) + S[2*i];
RC5Block[2] := ROL((RC5Block[2] xor RC5Block[1]), RC5Block[1]) + S[2*i+1];
end;
Result := TRUE;
end;
////////////////////////////////////////////////////////////////////////////////
function DecipherBlock(var Block): Boolean;
var
RC5Block : TRC5Block absolute Block;
i : Integer;
begin
for i := Rounds downto 1 do
begin
RC5Block[2] := ROR((RC5Block[2]-S[2*i+1]), RC5Block[1]) xor RC5Block[1];
RC5Block[1] := ROR((RC5Block[1]-S[2*i]), RC5Block[2]) xor RC5Block[2];
end;
Dec(RC5Block[2], S[1]);
Dec(RC5Block[1], S[0]);
Result := TRUE;
end;
////////////////////////////////////////////////////////////////////////////////
// Реализация главных функций
function EncryptCopy(DestStream, SourseStream : TStream; Count: Int64;
Key : string): Boolean;
var
Buffer : TRC5Block;
PrCount : Int64;
AddCount : Byte;
begin
Result := True;
try
if Key = '' then
begin
DestStream.CopyFrom(SourseStream, Count);
Exit;
end;
Initialize(Key);
CalculateSubKeys;
PrCount := 0;
while Count - PrCount >= 8 do
begin
SourseStream.Read(Buffer, BlockSize);
EncipherBlock(Buffer);
DestStream.Write(Buffer, BlockSize);
Inc(PrCount, 8);
end;
AddCount := Count - PrCount;
if Count - PrCount <> 0 then
begin
SourseStream.Read(Buffer, AddCount);
DestStream.Write(Buffer, AddCount);
end;
except
Result := False;
end;
end;
////////////////////////////////////////////////////////////////////////////////
function DecryptCopy(DestStream, SourseStream : TStream; Count: Int64;
Key : string): Boolean;
var
Buffer : TRC5Block;
PrCount : Int64;
AddCount : Byte;
begin
Result := True;
try
if Key = '' then
begin
DestStream.CopyFrom(SourseStream, Count);
Exit;
end;
Initialize(Key);
CalculateSubKeys;
PrCount := 0;
while Count - PrCount >= 8 do
begin
SourseStream.Read(Buffer, BlockSize);
DecipherBlock(Buffer);
DestStream.Write(Buffer, BlockSize);
Inc(PrCount, 8);
end;
AddCount := Count - PrCount;
if Count - PrCount <> 0 then
begin
SourseStream.Read(Buffer, AddCount);
DestStream.Write(Buffer, AddCount);
end;
except
Result := False;
end;
end;
////////////////////////////////////////////////////////////////////////////////
function EncryptStream(DataStream: TStream; Count: Int64; Key: string): Boolean;
var
Buffer : TRC5Block;
PrCount : Int64;
begin
Result := True;
try
if Key = '' then
begin
DataStream.Seek(Count, soFromCurrent);
Exit;
end;
Initialize(Key);
CalculateSubKeys;
PrCount := 0;
while Count - PrCount >= 8 do
begin
DataStream.Read(Buffer, BlockSize);
EncipherBlock(Buffer);
DataStream.Seek(-BlockSize, soFromCurrent);
DataStream.Write(Buffer, BlockSize);
Inc(PrCount, 8);
end;
except
Result := False;
end;
end;
////////////////////////////////////////////////////////////////////////////////
function DecryptStream(DataStream: TStream; Count: Int64; Key: string): Boolean;
var
Buffer : TRC5Block;
PrCount : Int64;
begin
Result := True;
try
if Key = '' then
begin
DataStream.Seek(Count, soFromCurrent);
Exit;
end;
Initialize(Key);
CalculateSubKeys;
PrCount := 0;
while Count - PrCount >= 8 do
begin
DataStream.Read(Buffer, BlockSize);
DecipherBlock(Buffer);
DataStream.Seek(-BlockSize, soFromCurrent);
DataStream.Write(Buffer, BlockSize);
Inc(PrCount, 8);
end;
except
Result := False;
end;
end;
// Завершение главных функций ...
////////////////////////////////////////////////////////////////////////////////
{$R+,Q+}
end.
Вот и все что касается RC5 шифрования, в следующей статье мы рассмотрим алгоритм RC6 - заранее могу сказать, что он очень похож на RC5.
Перепечатка данной статьи разрешается автором только без изменения, модуль, представленный в данной статье абсолютно свободен для использования - пользуйтесь!
Матвеев Игорь Владимирович.
Модуль для RC6 шифрования.
| Автор: Матвеев Игорь Переквалифицировался хакер в священника и однажды приходит на проповедь после большого перепоя. Заплетающимся языком: - И да поможет тебе F1, и сохранит тебя F2! Во имя Controla, Alta и святого Dela, да будет так - Reset! |
Данная статья является логическим завершением темы шифрования данных, которой я посвятил три статьи (Модуль для IDEA шифрования, Модуль для RC5 шифрования и данная). Данная статья посвящена алгоритму шифрования RC6.
Как я уже говорил, RC6 Очень похож на RC5, во всяком случае расчет подключа производится тем же способом, что и в RC5. RC6 участвовал в конкурсе на звание AES и, по некоторым данным, не выиграл только из-за медленной работы аппаратных реализаций. Программные же реализации RC6, пожалуй, являются самыми быстрыми среди алгоритмов шифрования, при обеспечении достаточной стойкости шифра.
Нижепредставленный модуль построен по тому же принципу, что и предыдущие - имена функций совпадают и если вы хотите заменить в своей программе шифрование с IDEA или RC5 на RC6 - просто добавьте модуль RC6, а IDEA или RC5 - удалите из списка uses.
Шифр RC6, в отличии от RC5, оперирует блоками по 16 байт, а модуль построен так, что если при шифрации методами: EncryptCopy, DecryptCopy, EncryptStream, DecryptStream размер данных не будет кратен 16 - последний блок длинной 1..15 байт не шифруется и в "чистом" виде добавляется к зашифрованным. Также и при дешифровании - если последний блок размером 1..15 байт он не дешифруется а добавляется к расшифрованным данным. Такой подход обеспечивает в полной мере "симметричное" шифрование так как размеры входных и выходных данных полностью совпадают. Однако такой подход приводит к некоторым сложностям, если последний блок также нуждается в шифровании. На мой взгляд лучший выход - добавить при шифровании к исходным данным строку определенной длинны и после дешифрования отсечь с конца строку той же длинны.
Также в заключении цыкла статей, посвященных шифрованию я подготовил примеры по всем представленным алгоритмам (IDEA, RC5, RC6).
Загрузить демо примеры.
А вот последний модуль:
{ *********************************************************************** }
{ }
{ Delphi Еnсгурtiоn Library }
{ Еnсгурtiоn / Decryption stream - RC6 }
{ }
{ Copyright (c) 2004 by Matveev Igor Vladimirovich }
{ With offers and wishes write: teap_leap@mail.ru }
{ }
{ *********************************************************************** }
unit RC6;
interface
uses
SysUtils, Classes;
const
Rounds = 20;
KeyLength = 2 * (Rounds + 2);
BlockSize = 16;
KeySize = 16 * 4;
P32 = $b7e15163;
Q32 = $9e3779b9;
lgw = 5;
type
TRC6Block = array[1..4] of LongWord;
var
S : array[0..KeyLength-1] of LongWord;
Key : string;
KeyPtr : PChar;
////////////////////////////////////////////////////////////////////////////////
// Дополнительные функции
procedure Initialize(AKey: string); // Инициализация
procedure CalculateSubKeys; // Подготовка подключей
function EncipherBlock(var Block): Boolean; // Шифрация блока (16 байт)
function DecipherBlock(var Block): Boolean; // Дешифрация блока
////////////////////////////////////////////////////////////////////////////////
// Главные функции
function EncryptCopy(DestStream, SourseStream : TStream; Count: Int64;
Key : string): Boolean; // Зашифровать данные из одного потока в другой
function DecryptCopy(DestStream, SourseStream : TStream; Count: Int64;
Key : string): Boolean; // Расшифровать данные из одного потока в другой
function EncryptStream(DataStream: TStream; Count: Int64;
Key: string): Boolean; // Зашифровать содержимое потока
function DecryptStream(DataStream: TStream; Count: Int64;
Key: string): Boolean; // Расшифровать содержимое потока
implementation
////////////////////////////////////////////////////////////////////////////////
function ROL(a, s: LongWord): LongWord;
asm
mov ecx, s
rol eax, cl
end;
////////////////////////////////////////////////////////////////////////////////
function ROR(a, s: LongWord): LongWord;
asm
mov ecx, s
ror eax, cl
end;
////////////////////////////////////////////////////////////////////////////////
procedure InvolveKey;
var
TempKey : string;
i, j : Integer;
K1, K2 : LongWord;
begin
// Разворачивание ключа до длинны KeySize = 64
TempKey := Key;
i := 1;
while ((Length(TempKey) mod KeySize) <> 0) do
begin
TempKey := TempKey + TempKey[i];
Inc(i);
end;
i := 1;
j := 0;
while (i do
begin
Move((KeyPtr+j)^, K1, 4);
Move(TempKey[i], K2, 4);
K1 := ROL(K1, K2) xor K2;
Move(K1, (KeyPtr+j)^, 4);
j := (j + 4) mod KeySize;
Inc(i, 4);
end;
end;
////////////////////////////////////////////////////////////////////////////////
procedure CalculateSubKeys;
var
i, j, k : Integer;
L : array[0..15] of LongWord;
A, B : LongWord;
begin
// Копирование ключа в L
Move(KeyPtr^, L, KeySize);
// Инициализация подключа S
S[0] := P32;
for i := 1 to KeyLength-1 do
S[i] := S[i-1] + Q32;
// Смешивание S с ключом
i := 0;
j := 0;
A := 0;
B := 0;
for k := 1 to 3*KeyLength do
begin
A := ROL((S[i] + A + B), 3);
S[i] := A;
B := ROL((L[j] + A + B), (A + B));
L[j] := B;
i := (i + 1) mod KeyLength;
j := (j + 1) mod 16;
end;
end;
////////////////////////////////////////////////////////////////////////////////
procedure Initialize(AKey: string);
begin
GetMem(KeyPtr, KeySize);
FillChar(KeyPtr^, KeySize, #0);
Key := AKey;
InvolveKey;
end;
////////////////////////////////////////////////////////////////////////////////
function EncipherBlock(var Block): Boolean;
var
RC6Block : TRC6Block absolute Block;
i : Integer;
t, u : LongWord;
Temp : LongWord;
begin
// Инициализация блока
Inc(RC6Block[2], S[0]);
Inc(RC6Block[4], S[1]);
for i := 1 to Rounds do
begin
t := ROL((RC6Block[2] * (2*RC6Block[2] + 1)), lgw);
u := ROL((RC6Block[4] * (2*RC6Block[4] + 1)), lgw);
RC6Block[1] := ROL((RC6Block[1] xor t), u) + S[2*i];
RC6Block[3] := ROL((RC6Block[3] xor u), t) + S[2*i+1];
Temp := RC6Block[1];
RC6Block[1] := RC6Block[2];
RC6Block[2] := RC6Block[3];
RC6Block[3] := RC6Block[4];
RC6Block[4] := Temp;
end;
RC6Block[1] := RC6Block[1] + S[2*Rounds+2];
RC6Block[3] := RC6Block[3] + S[2*Rounds+3];
Result := TRUE;
end;
////////////////////////////////////////////////////////////////////////////////
function DecipherBlock(var Block): Boolean;
var
RC6Block : TRC6Block absolute Block;
i : Integer;
t, u : LongWord;
Temp : LongWord;
begin
// Инициализация блока
RC6Block[3] := RC6Block[3] - S[2*Rounds+3];
RC6Block[1] := RC6Block[1] - S[2*Rounds+2];
for i := Rounds downto 1 do
begin
Temp := RC6Block[4];
RC6Block[4] := RC6Block[3];
RC6Block[3] := RC6Block[2];
RC6Block[2] := RC6Block[1];
RC6Block[1] := Temp;
u := ROL((RC6Block[4] * (2*RC6Block[4] + 1)),lgw);
t := ROL((RC6Block[2] * (2*RC6Block[2] + 1)),lgw);
RC6Block[3] := ROR((RC6Block[3]-S[2*i+1]), t) xor u;
RC6Block[1] := ROR((RC6Block[1]-S[2*i]), u) xor t;
end;
Dec(RC6Block[4], S[1]);
Dec(RC6Block[2], S[0]);
Result := TRUE;
end;
////////////////////////////////////////////////////////////////////////////////
// Реализация главных функций
function EncryptCopy(DestStream, SourseStream : TStream; Count: Int64;
Key : string): Boolean;
var
Buffer : TRC6Block;
PrCount : Int64;
AddCount : Byte;
begin
Result := True;
try
if Key = '' then
begin
DestStream.CopyFrom(SourseStream, Count);
Exit;
end;
Initialize(Key);
CalculateSubKeys;
PrCount := 0;
while Count - PrCount >= BlockSize do
begin
SourseStream.Read(Buffer, BlockSize);
EncipherBlock(Buffer);
DestStream.Write(Buffer, BlockSize);
Inc(PrCount, BlockSize);
end;
AddCount := Count - PrCount;
if Count - PrCount <> 0 then
begin
SourseStream.Read(Buffer, AddCount);
DestStream.Write(Buffer, AddCount);
end;
except
Result := False;
end;
end;
////////////////////////////////////////////////////////////////////////////////
function DecryptCopy(DestStream, SourseStream : TStream; Count: Int64;
Key : string): Boolean;
var
Buffer : TRC6Block;
PrCount : Int64;
AddCount : Byte;
begin
Result := True;
try
if Key = '' then
begin
DestStream.CopyFrom(SourseStream, Count);
Exit;
end;
Initialize(Key);
CalculateSubKeys;
PrCount := 0;
while Count - PrCount >= BlockSize do
begin
SourseStream.Read(Buffer, BlockSize);
DecipherBlock(Buffer);
DestStream.Write(Buffer, BlockSize);
Inc(PrCount, BlockSize);
end;
AddCount := Count - PrCount;
if Count - PrCount <> 0 then
begin
SourseStream.Read(Buffer, AddCount);
DestStream.Write(Buffer, AddCount);
end;
except
Result := False;
end;
end;
////////////////////////////////////////////////////////////////////////////////
function EncryptStream(DataStream: TStream; Count: Int64; Key: string): Boolean;
var
Buffer : TRC6Block;
PrCount : Int64;
begin
Result := True;
try
if Key = '' then
begin
DataStream.Seek(Count, soFromCurrent);
Exit;
end;
Initialize(Key);
CalculateSubKeys;
PrCount := 0;
while Count - PrCount >= BlockSize do
begin
DataStream.Read(Buffer, BlockSize);
EncipherBlock(Buffer);
DataStream.Seek(-BlockSize, soFromCurrent);
DataStream.Write(Buffer, BlockSize);
Inc(PrCount, BlockSize);
end;
except
Result := False;
end;
end;
////////////////////////////////////////////////////////////////////////////////
function DecryptStream(DataStream: TStream; Count: Int64; Key: string): Boolean;
var
Buffer : TRC6Block;
PrCount : Int64;
begin
Result := True;
try
if Key = '' then
begin
DataStream.Seek(Count, soFromCurrent);
Exit;
end;
Initialize(Key);
CalculateSubKeys;
PrCount := 0;
while Count - PrCount >= BlockSize do
begin
DataStream.Read(Buffer, BlockSize);
DecipherBlock(Buffer);
DataStream.Seek(-BlockSize, soFromCurrent);
DataStream.Write(Buffer, BlockSize);
Inc(PrCount, BlockSize);
end;
except
Result := False;
end;
end;
// Завершение главных функций ...
////////////////////////////////////////////////////////////////////////////////
end.
Использование команды RDTSC процессора Pentium для работы с малыми временными интервалам.
Оформил: DeeCo
Автор: Шевченко В.В.
Приветствую Вас, жители королевства! В одной толстой книге нашел интересное использование команды RDTSC процессора Pentium для работы с малыми временными интервалами. Я думаю, что эта функция может найти широкое применение (в таймерах, управлении внешними устройствами, научных исследованиях).Пример прилагается Project_RDTSC.Zip.(4K).
Этот счетчик увеличивается на 1 на каждом такте CPU. Он стартует при включении компьютера или при нажатии кнопки RESET. Обычно функцию RDTSC используют при определении тактовой частоты процессора. Применяя программные ухищрения можно добиться измерения очень малых временных величин в реальном масштабе времени или применять для калибровки таймеров (предварительно определив при помощи этой же функции тактовую частоту процессора). Готовые примеры определения тактовой частоты при помощи функции RDTSC есть в интернете, например, на сайте Мастера Delphi" : "Скорость работы процессора, точный таймер"
function RDTSC: comp;
var
TimeStamp: record
case byte of
1: (Whole: comp);
2: (Lo, Hi: Longint);
end;
begin
asm
db $0F; db $31;
{$ifdef Cpu386}
mov [TimeStamp.Lo], eax
mov [TimeStamp.Hi], edx
{$else}
db D32
mov word ptr TimeStamp.Lo, AX
db D32
mov word ptr TimeStamp.Hi, DX
{$endif}
end;
Result := TimeStamp.Whole;
end;
Readln для более чем 255 символов.
| Построили новый полностью роботизированный завод. Идет экскурсия по цехам. Экскурсовод: - Внимание, господа, в этом цехе все роботы управаляются операцинной системой MS-DOS. Посмотрели, идут дальше. - В этом цехе все роботы работают под управлением операционной системы Unix. Посмотрели, идут дальше. - Вот в этом цехе все роботы работают под управлением операционной системы QNX. Проходят в след. цех. - А в этом цехе все роботы управляются операционной системой Microsoft Windows'98. Всем присутствующим просьба надеть защитные каски. |
Обходной путь:
type
{используем самое большое количество символов в
строке, с которым вы можете иметь дело}
TLine = array[0..1024] of Char;
PLine = ^TLine;
var
pBuf: PLine;
...
New(pBuf);
...
ReadLn(F, pBuf^);
|
Примечание: вы, конечно, можете использовать объявление переменной типа TLine или непосредственно массив символов, но я предпочитаю распределять из кучи нечто большее, чем 4 байта...
Читаем файл Access используя ADO.
// Читаем файл (любой версии)
// Проверяем что это ACCESS MDB
// Нужны компаненты:
// TADOtable,TDataSource,TOpenDialog,TDBGrid,TBitBtn.
unit uMain;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Db, DBTables, ADODB, Grids, DBGrids, ExtCtrls, DBCtrls, StdCtrls, Buttons;
type
TfrmMain = class(TForm)
DSUsers: TDataSource;
DBGridUsers: TDBGrid;
BitBtn1: TBitBtn;
OpenDialog1: TOpenDialog;
TUsers: TADOTable;
procedure FormCreate(Sender: TObject);
procedure ValidateAccessDB;
function CheckIfAccessDB(lDBPathName: string): boolean;
private
{ Private declarations }
public
{ Public declarations }
end;
var
frmMain: TfrmMain;
const
DBNAME = 'ADODemo.MDB';
DBPASSWORD = '123'; // Access DB Password Protected
implementation
{$R *.DFM}
procedure TfrmMain.FormCreate(Sender: TObject);
begin
validateAccessDB;
end;
procedure TfrmMain.ValidateAccessDB;
var
lDBpathName : String;
lDBcheck : boolean;
begin
if FileExists(ExtractFileDir(Application.ExeName) + '\' + DBNAME) then
lDBPathName := ExtractFileDir(Application.ExeName) + '\' + DBNAME
else if OpenDialog1.Execute then
// Set the OpenDialog Filter for ADOdemo.mdb only
lDBPathName := OpenDialog1.FileName;
lDBCheck := False;
if Trim(lDBPathName) <> '' then
lDBCheck := CheckIfAccessDB(lDBPathName);
if lDBCheck = True then
begin
// ADO Connection String to the MS-ACCESS DB
TUsers.ConnectionString :=
'Provider=Microsoft.Jet.OLEDB.4.0;' +
'Data Source=' + lDBPathName + ';' +
'Persist Security Info=False;' +
'Jet OLEDB:Database Password=' + DBPASSWORD;
TUsers.TableName := 'Users';
TUsers.Active := True;
end
else
frmMain.Free;
end;
// Check if it is a valid ACCESS DB File Before opening it.
function TfrmMain.CheckIfAccessDB(lDBPathName: string): Boolean;
var
UnTypedFile: file of byte;
Buffer: array[0..19] of byte;
NumRecsRead: Integer;
i: Integer;
MyString: string;
begin
AssignFile(UnTypedFile, lDBPathName);
reset(UnTypedFile);
BlockRead(UnTypedFile, Buffer, High(Buffer), NumRecsRead);
CloseFile(UnTypedFile);
for i := 1 to High(Buffer) do
MyString := MyString + Trim(Chr(Ord(Buffer[i])));
Result := False;
if Mystring = 'StandardJetDB' then
Result := True;
if Result = False then
MessageDlg('Invalid Access Database', mtInformation, [mbOK], 0);
end;
end.
|
Читаем Adobe Acrobat PDF файлы из нашего приложения.
Adobe Acrobat PDF - хорошо извесный формат, который нравится многим пользователям. Давайте посмотрим, как можно заставить приложение на Delphi прочитать файл такого формата.
Итак, Вы должны быть уверены, что у вас проинсталлирован Acrobat Reader, елси таковой программы нет, то её можно скачать с http://www.adobe.com
После этого необходимо проинсталировать типовую библиотеку для Acrobat (Project -> Import Type Library из меню Delphi) выберите "Acrobat Control for ActiveX (version x)". Где x - текущая версия библиотеки. Нажмите кнопку инсталяции.
Теперь создайте новое приложение, поместите на форму проинсталлированный компонент TPDF, далее добавите OpenDialog, и в заключении кнопку, при на нажатии на которую будет вызываться процедура открытия файла:
procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenDialog1.Execute then
pdf1.src := OpenDialog1.FileName;
end;
|
В юните PdfLib_TLB вы можете найти интерфейс класса TPdf:
TPdf = class(TOleControl)
private
FIntf: _DPdf;
function GetControlInterface: _DPdf;
protected
procedure CreateControl;
procedure InitControlData; override;
public
function LoadFile(const fileName: WideString): WordBool;
procedure setShowToolbar(On_: WordBool);
procedure gotoFirstPage;
procedure gotoLastPage;
procedure gotoNextPage;
procedure gotoPreviousPage;
procedure setCurrentPage(n: Integer);
procedure goForwardStack;
procedure goBackwardStack;
procedure setPageMode(const pageMode: WideString);
procedure setLayoutMode(const layoutMode: WideString);
procedure setNamedDest(const namedDest: WideString);
procedure Print;
procedure printWithDialog;
procedure setZoom(percent: Single);
procedure setZoomScroll(percent: Single; left: Single; top: Single);
procedure setView(const viewMode: WideString);
procedure setViewScroll(const viewMode: WideString; offset: Single);
procedure setViewRect(left: Single; top: Single; width: Single; height: Single);
procedure printPages(from: Integer; to_: Integer);
procedure printPagesFit(from: Integer; to_: Integer; shrinkToFit: WordBool);
procedure printAll;
procedure printAllFit(shrinkToFit: WordBool);
procedure setShowScrollbars(On_: WordBool);
procedure AboutBox;
property ControlInterface: _DPdf read GetControlInterface;
property DefaultInterface: _DPdf read GetControlInterface;
published
property TabStop;
property Align;
property DragCursor;
property DragMode;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property TabOrder;
property Visible;
property OnDragDrop;
property OnDragOver;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnStartDrag;
property src: WideString index 1 read GetWideStringProp write SetWideStringProp stored False;
end;
|
В заключение можно добавить следующее:
Если Вы не уверены, что у конечного пользователя Вашей программы установлен Acrobat Reader, то необходимо, чтобы приложение проверяло эту ситуацию, прежде чем будут производится различные манипуляции с компонентой TPdf. И второе, если файл PDF имеет различные связи, например с AVI файлами, то они не будут работать из Delphi.
Надеюсь этот пример будет Вам полезен.
Прочитать данные из другого дочернего окна.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
type
TMDIChildForm = class(TForm)
Edit1: TEdit;
private
{ Private declarations }
procedure ReadDataFromOtherMDIChildForm;
end;
var
MDIChildForm: TMDIChildForm;
implementation
{$R *.DFM}
uses
MainForm;
// Property FormStyle of this form is fsMDIForm
procedure TMDIChildForm.ReadDataFromOtherMDIChildForm;
var
i: Integer;
DataFromOtherForm: string;
begin
// Suppose you have created three different MDIChild forms of the same type,
// each with the following caption: "aaa", "bbb", "ccc".
// You are currently on form with caption "aaa" and want to read data
// contained on form with caption "ccc".
// You can find here the code, you have to use the "as" clause and
// properties MDIChildCount and MDIChildren:
// First you have to find where the form "ccc" is in memory;
for i := 0 to MDIForm.MDIChildCount - 1 do
begin
if (Pos('ccc', MDIForm.MDIChildren[i].Caption) 0) then
Break;
end;
// Check to see if the form is the last on MDIChildren array and
// correct I variable
if (i = MDIChildCount) then Dec(i);
// I variable contains the index of the form with caption 'ccc'
if (Pos('ccc', MDIForm.MDIChildren[i].Caption) 0) then
begin
// If the form with caption 'ccc' exists then you access data and show it
// The following line of code is very interesting, look at the "as" clause,
// if you have different types of MDIChild forms, you simply change
// the type of form after the "as" clause
// The data you want is contained on Edit1.Text
with (MDIForm.MDIChildren[I] as TMDIChildForm).Edit1 do
DataFromOtherForm := Text;
ShowMessage(DataFromOtherForm);
end;
end;
Чтение бинарного файла.
var f: File; c: Char; begin AssignFile(f, 'this.bin'); Reset(f, 1); BlockRead(f, c, sizeof(c)); CloseFile(f); end; |
function FindInFile(cFileName: string; cCh: char): boolean;
var
fFile: file;
aBuf: array[1..1024] of char;
lFound: boolean;
x, nRead: integer;
begin
Assign(fFile, cFileName);
Reset(fFile, 1);
lFound := False;
repeat
BlockRead(fFile, aBuf, SizeOf(aBuf), nRead);
x := 1;
while not lFound and (x <= nRead) do
begin
lFound := (aBuf[x] = cCh)
Inc(x)
end;
until
(nRead < SizeOf(aBuf)) or lFound;
FindInFile := lFound
end;
|
Взгляните на следующий код:
var
f: file;
c: Char;
begin
AssignFile(f, 'c:\autoexec.bat');
Reset(f, 1); <- Примечание: Размер записи = 1 байту это нормально!
while not Eof(f) do
begin
BlockRead(f, c, SizeOf(c));
{Теперь обрабатываем c}
end;
CloseFile(f);
end;
|
Для ускорения этой процедуры не следует за один проход читать по одному символу. Возможно, лучшим решением будет объявление PChar скажем, размером 200, и чтением за один проход блоков размером 200 байт. {например, BlockRead(f, p, 200);} Но для этого требуется немного больше кода, чем показано здесь... (Используйте все тот же recordsize, равный 1, меняется только blocksize).
Как прочитать байт из параллельного порта.
| Как объяснить тупому, что такое бит? Элементарно - это байт минус налоги. Как объяснить тупому, что такое байт? Элементарно - объясните ему 8 раз, что такое бит. Что такое килобайт? Это слишком долго рассказывать... |
var
BytesRead: BYTE;
begin
asm { Читаем порт (LPT1) через встроенный ассемблер }
MOV dx,$379;
in al,dx;
MOV BytesRead,al;
end;
BytesRead := (BytesRead or $07); { OR а затем XOR данных }
BytesRead := (BytesRead xor $80); { маскируем неиспользуемые биты }
end;
|
Как прочитать байт из параллельного порта 2.
Используем команды Turbo Pascal ...
value:=port[$379]; { Прочитать из порта }
port[$379]:=value; { Записать в порт }
|
Как динамически прочитать информацию о классе.
Автор: http://www.lmc-mediaagentur.de
procedure TForm1.FormCreate(Sender: TObject);
begin
{This only works for classes registered using RegisterClass}
RegisterClasses([TButton, TForm]);
end;
procedure TForm1.Button1Click(Sender: TObject);
var
CRef: TPersistentClass;
PTI: PTypeInfo;
AControl: TControl;
begin
CRef := GetClass('TButton');
if CRef <> nil then
begin
AControl := TControl(TControlClass(CRef).Create(Self));
with AControl do
begin
Parent := Self;
Width := 50;
Height := 30;
end;
Inc(Id);
end
else
MessageDlg('No such class', mtWarning, [mbOk], 0);
end;
Как читать файлы Outlook Express (DBX).
Автор: Samum WEB-сайт: http://samum2000.narod.ru Структура файла Сообщения хранятся в таблицах, расположенных друг за другом, по порядку. Каждая таблица состоит из двух частей - заголовка и _входа_. Смещение первой таблицы от начала файла располагается со смещением $30 от начала файла и представляет собой знаковое 32-х битное число (тип integer или longint). Общее же количество записей (т.е. этих самых таблиц) расположено со смещением $C4 от начала файла, и представляет собой число типа integer (longint).Заголовок таблицы содержит количество _входов_, собственное смещение, а так же смещения предыдущей и следующей таблиц (все смещения, разумеется, от начала файла). Для чтения заголовка таблицы я использую такую структуру:
Toe5_IndexHeader = record
FilePos: longint; {Это смещение структуры, используется для контроля}
Unknown1: longint; { ??? }
PrevIndex: longint; {Смещение предыдущей таблицы}
NextIndex: longint; {Смещение следующей таблицы}
Count: longint; {Количество _входов_, реальное количество находится так: count shr 8}
Unknown2: longint; { ??? }
end;
Чтобы получить реальное количество _входов_, значение поля count надо конвертировать .
Каждый _вход_ содержит смещение (всегда от начала файла) заголовка письма (Message Header) и позицию другой индексной таблицы (эта таблица используется, чтобы обеспечить поддержку наследования (или связывания) сообщения, то есть любой заголовок сообщения, на который ссылается эта таблица - ребенок текущего сообщения). Вот структура входа:
Toe5_IndexItem = record
HeaderPos: longint; {Смещение (от начала файла) заголовка письма}
ChildIndex: longint; {Смещение (от начала файла) дочерней индексной таблицы}
Unknown: longint;
end;
На мой взгляд, лучшим методом чтения таблиц является рекурсивная функция (см. пример).
Заголовок сообщения содержит некоторую информацию, которую Outlook Express использует, чтобы избежать доступа к сообщению, пока в этом нет особой необходимости. Эта структура разделена на три части: заголовок структуры, таблицу параметров типа DWORD и блок данных.
Заголовок структуры - это то, что вам необходимо прочитать в первую очередь, так как он определяет размер оставшихся двух частей. В её состав входят размер всей структуры (все 3 части), суммарный размер таблицы параметров, блока данных и количество параметров в таблице (я называю эти параметры флагами).
THeaderData = record
position: longint; {смещение данной структуры от BOF, используется только для контроля}
DataLength: longint; {размер таблицы параметров и блока данных}
HeaderLength: WORD; {размер всех трех частей}
FlagCount: WORD; {количество элементов в таблице}
end;
Чтобы получить размер таблицы флагов, можно написать SizeOfTable:=FlagCount*SizeOf(DWord), a размер блока данных используйте DataLength-SizeOfTable. Каждый элемент таблицы параметров должен быть декодирован, для того, чтобы получить его идентификатор и значение: идентификатор находят как element and $FF, а значение флага - element shr 8. Блок данных содержит такую информацию, как дата получения, отправки, тема, адресат, отправитель, аккаунт и т.д. Для её чтения используется таблица флагов (параметров). Вот пример таблицы параметров и соответствующего блока данных:
Flags = 16
80: 00000074
81: 00000081
02: 00000000
84: 0002ECA0
05: 00000008
06: 00000025
07: 0000002D
08: 0000006E
0D: 0000008B
0E: 000000A5
90: 00000003
91: 0000376F
12: 000000D4
13: 000000DC
14: 00000102
1C: 0000012A
Data Block:
00 72 F3 E4 58 22 C0 01 41 63 74 69 76 65 57 65
r o a X " A _ A c t i v e W e
62 20 44 65 76 65 6C 6F 70 65 72 20 65 58 54 52
b D e v e l o p e r e X T R
41 20 23 38 00 60 E2 F2 9C 90 35 C0 01 3C 4F 46
A # 8 ` a o ? ? 5 A _ A c
74 69 76 65 57 65 62 20 44 65 76 65 6C 6F 70 65
t i v e W e b D e v e l o p e
72 20 65 58 54 52 41 20 23 38 00 41 63 74 69 76
r e X T R A # 8 A c t i v
65 57 65 62 20 44 65 76 65 6C 6F 70 65 72 20 65
e W e b D e v e l o p e r e
58 54 52 41 00 61 63 74 69 76 65 77 65 62 64 65
X T R A a c t i v e w e b d e
76 65 6C 6F 70 65 72 65 78 74 72 61 40 70 69 6E
v e l o p e r e x t r a @ p i n
6E 61 63 6C 65 70 75 62 6C 69 73 68 69 6E 67 2E
n a c l e p u b l i s h i n g .
63 6F 6D 00 00 23 5E 0F 8B 22 C0 01 41 63 74 69
c o m # ^ _ ‹ " A _ A c t i
76 65 57 65 62 20 44 65 76 65 6C 6F 70 65 72 20
v e W e b D e v e l o p e r
65 58 54 52 41 20 53 75 62 73 63 72 69 62 65 72
e X T R A S u b s c r i b e r
20 00 3C 41 63 74 69 76 65 57 65 62 20 44 65 76
? _
02 4E 00 00 00 00 F9 37 00 00 02 4E 00 00 01 00
_ N u 7 _ N _
00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00
00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00
00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00
00 00 00 00 00 00 40 05 00 00 F9 37 00 00 00 00
@ _ u 7
00 00 00 00 00 00 01 00 00 00 00 00 00 00 00 00
_
00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00
00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00
00 00 00 00 00 00 6D 70
m p
Теперь давайте разберёмся, что означает каждый флаг.
Для файла Folders.dbx:
$2: смещение от начала блока данных, по которому расположено название папки (Nullterminated string) $3: смещение от начала блока данных, по которому расположено имя файла, представляющего эту папку (это тоже Nullterminated string) $6: не важный флаг. Если папка его имеет, то значит она - специальная папка, у неё нет собственного файла, и она используется лишь для организации; $80: идентификатор папки; $81: идентификатор родительской папки (флаг $80 родительской папки).Для других файлов:
$1: Смещение от начала блока данных, по которому расположен статус сообщения. $2: Смещение от начала блока данных, по которому расположена дата отправки (дата представлена в TFileTime) $4: Иногда типа DWord не хватает, чтобы представить и идентификатор флага, и смещения тела сообщения от начала файла, тогда смещение, по которому расположено тело, размещается в блоке данных. Значение этого флага - смещение (от начала блока данных) по которому находится это значение. $7: Смещение от начала блока данных, по которому расположен идентификатор письма MessageID (nullterminated string) $8: Смещение от начала блока данных, по которому расположена тема сообщения (nullterminated string) $9: Смещение от начала блока данных, по которому расположен параметр “From Reply” сообщения (nullterminated string) $A: Смещение от начала блока данных, по которому расположены ссылки (References)сообщения (nullterminated string) $B: Смещение от начала блока данных, по которому расположена новостная группа сообщения (null terminated string) $D: Смещение от начала блока данных, по которому расположен адресат (null terminated string) $E: Смещение от начала блока данных, по которому расположены данные “Reply to:” (null terminated string) $12: Смещение от начала блока данных, по которому расположена дата получения (дата представлена в формате TFileTime) $13: Смещение от начала блока данных, по которому расположен получатель (null terminated string) $1A: Смещение от начала блока данных, по которому расположен аккаунт (null terminated string) $1B: Смещение от начала блока данных, по которому расположен идентификатор аккаунта (null terminated string) $80: Номер сообщения $81: Используется для хранения статуса письма $84: Смещение тела сообщения в файле $91: Размер сообщения.Сообщения: Каждое письмо или сообщение групп новостей хранятся в блоках по 512 байт, у каждого блока есть заголовок. То есть каждое сообщение делится на части, и к каждой части добавляют заголовок (в котором содержится размер блока, размер занятой части блока, а так же положение следующего блока). Я использую такую структуру для чтения блоков (вместе с их заголовками):
Toe5_MsgItem = record
FilePos: longint; {смещение структуры от BOF, используется для контроля верности операций}
Unknown: longint; {я думаю, это размер блока данных}
ItemSize: longint; {использованная часть блока}
NextItem: longint; {смещение следующего блока от BOF, и 0, если это последний блок}
MsgContent: array[0..511] of Char; {блок, содержащий непосредственно данные}
end;
Удаление сообщений
Когда какое либо сообщение удаляется, оно сначала помещается в папку "Удаленные", а физически - в соответствующий этой папке файл. Место же, которое занимало сообщение в прежнем файле, добавляется в список пустого пространства, и когда приходит новое сообщение, Outlook Express использует сначала это место. Смещение первого элемента в списке сободного места сохранено по смещению $48 от начала файла. Каждый элемент этого списка разделен на две части: заголовок и блок свободного пространства. Вот структура заголовка:
Toe5_FreeSpace = record
FilePos: longint; {это смещение всей структуры от начала файла BOF, используется для контроля}
ElementSize: longint; {размер структуры - заголовок и свободное место}
FreeSpaceSize: longint; {Размер свободного пространства}
PreviousElement: longint; {смещение (от начала файла) предыдущего элемента}
NextElement: longint; {смещение следующего элемента}
end;
Даты
Все даты в заголовке сообщения сохранены в формате TFileTime, и основаном на UTC. Перед использованием это значение надо перевести в местное время. Вот небольшой пример того, как это можно сделать:
function FiletimeToDatetime(const date: TFileTime): TDateTime; var st: TSystemTime; localft: TFileTime; begin FileTimeToLocalFileTime(date, localft); FileTimeToSystemTime(localft, st); Result := SystemTimeToDateTime(st); end;Статус сообщения
Для получения статуса сообщения можно использовать значение флага $81 следующим образом:
... x := < значение флага $81 > if (x and constant) <> 0 then ...
И на последок, некоторые константы:
DOWNLOADED = $1 MARKED = $20 (Отмечено флажком) READED = $80 DOWNLOAD_LATER = $100 NEWS_MSG = $800Эти константы надо проверить:
ATTACHMENTS = $4000 REPLY =$80000 INSPECT_CONVERSATION = $400000 IGNORE_CONVERSATION =$800000 Модули к статье можно взять здесь Все дополнения, модификации, предложения, благодарности и т.п. просьба присылать на Samum2000@mail15.com (особенно к русскому переводу) или на walther_e@yahoo.com (на английском языке, касательно оригинала). Walther Estergaard Walther_e@yahoo.comПеревод: Боднар Денис aka Samum, Samum2000@mail15.com, ICQ: 278395965.
Чтение сложных OLE-документов.
Автор: John Lam Не используйте для этого компонент TOleContainer. Создавая приложение с возможностью доступа к файлам OLE Structured Storage (стуктурное хранилище), реально необходима только пара вызовов OLE API, и 5-6 вызовов API для доступа к функциям-членам интерфейсов IStorage, IRootStorage и IStream. Я подозреваю, что функция-член TOleContainer IStorage является указателем на корневое хранилище файла Structured Storage, создаваемого функциями-членами LoadFromFile/SaveToFile TOleContainer. Необходимые функции API: StgOpenStorage StgIsStorageFile Если у вас есть OLE 2.01 SDK, вы можете найти определения там.Будьте внимательны, при переносе заголовочных файлов C++ из OLE SDK в Delphi, Borland допустил несколько ошибок. Одна из ошибок при создании апплета обернулась мне тремя бессонными ночами. Вот правильное определение IStorage:
MyIStorage = class(IUnknown) function CreateStream(const pwcsName: PChar; grfMode: Longint; reserved1: Longint; reserved2: Longint; var ppstm: IStream): HResult; virtual; cdecl; export; abstract; function OpenStream(const pwcsName: PChar; reserved1: Pointer; grfMode: Longint; reserved2: Longint; var ppstm: IStream): HResult; virtual; cdecl; export; abstract; function CreateStorage(const pwcsName: PChar; grfMode: Longint; reserved1: Longint; reserved2: Longint; var ppstg: MyIStorage): HResult; virtual; cdecl; export; abstract; function OpenStorage(const pwcsName: PChar; pstgPriority: MyIStorage; grfMode: Longint; snbExclude: PStr; reserved: Longint; var ppstg: MyIStorage): HResult; virtual; cdecl; export; abstract; function CopyTo(ciidExclude: Longint; const rgiidExclude: IID; var snbExclude: PStr; pstgDest: MyIStorage): HResult; virtual; cdecl; export; abstract; function MoveElementTo(const lpszName: PChar; pstgDest: MyIStorage; const lpszNewName: PChar; grfFlags: Longint): HResult; virtual; cdecl; export; abstract; function Commit(grfCommitFlags: Longint): HResult; virtual; cdecl; export; abstract; function Revert: HResult; virtual; cdecl; export; abstract; function EnumElements(reserved1: Longint; reserved2: Pointer; reserved3: Longint; var ppenm: IEnumStatStg): HResult; virtual; cdecl; export; abstract; function DestroyElement(const pwcsName: PChar): HResult; virtual; cdecl; export; abstract; function RenameElement(const pwcsOldName: PChar; const pwcsNewName: PChar): HResult; virtual; cdecl; export; abstract; function SetElementTimes(const lpszName: PChar; const pctime: TFileTime; const patime: TFileTime; const pmtime: TFileTime): HResult; virtual; cdecl; export; abstract; function SetClass(const clsid: IID): HResult; virtual; cdecl; export; abstract; function SetStateBits(grfStateBits: Longint; grfMask: Longint): HResult; virtual; cdecl; export; abstract; function Stat(var pstatstg: TStatStg; grfStatFlag: Longint): HResult; virtual; cdecl; export; abstract; end; |
Надеюсь, это поможет.
Следить за изменениями в каталоге.
Автор: FliNT Использование ReadDirectoryChangesW Очень хорошая функция, только " Windows 95/98/Me: Unsupported" . Т.е. в Win9x этой функции нет. Но мы же пишем для NT, а там с этой функцией все в порядке (если 3-ий сервис пак для NT3.1 поставили :)))Кратко пройдемся по описанию функции (взято из windows.
function ReadDirectoryChangesW( hDirectory: THandle; // описатель каталога, за которым надо следить lpBuffer: Pointer; // Указатель на буфер, в который будет записана информация nBufferLength: DWORD; // Размер буфера bWatchSubtree: Bool; // Следить ли за подкаталогами dwNotifyFilter: DWORD; // Фильтр действий lpBytesReturned: LPDWORD; // Сколько было записано в буфер lpOverlapped: POverlapped; // Для асинхронной работы lpCompletionRoutine: FARPROC // Функция, которая будет вызвана при окончании операции ): BOOL; stdcall; |
Функция потока будет описана так:
procedure WorkThread(LV: TListView); stdcall; |
А вот ее текст:
procedure WorkThread(LV : TListView);stdcall;
var
hDir : THandle;
lpBuf : Pointer;
Ptr : Pointer;
cbReturn : Cardinal;
FileName : PWideChar;
Item : TListItem;
sTime : _SYSTEMTIME;
begin
// Сначала нам надо получить описатель каталога, за которым мы будем следить
// В данном примере это будет весь диск C:
hDir := CreateFile ('C:\',GENERIC_READ,FILE_SHARE_READ or FILE_SHARE_WRITE
or FILE_SHARE_DELETE,nil,OPEN_EXISTING,FILE_FLAG_BACKUP_SEMANTICS,0);
// Если ошиблись...
if hDir = INVALID_HANDLE_VALUE
then begin ShowMessage(SysErrorMessage(GetLastError)); exit; end;
// Выделяем память под буфер
// const BUF_SIZE = 2048 - думаю вполне достаточно
GetMem(lpBuf,BUF_SIZE);
repeat
// очищаем память перед записью в нее (на всякий случай)
ZeroMemory(lpBuf,BUF_SIZE);
// Теперь мы будем ждать пока чего-нибудь в интересующем нас каталоге
// изменится или произойдет ошибка (и мы выйдем из цикла)
// FILE_NOTIFY_CHANGE - это список флагов - о них ниже.
if not ReadDirectoryChangesW(hDir,lpBuf,BUF_SIZE,true,
FILE_NOTIFY_CHANGE,@cbReturn,nil,nil)
then Break;
// Сюда мы попадаем, если функция выполнилась успешно
// и lpBuf указывает на одну или несколько структур FILE_NOTIFY_INFORMATION
Ptr:=lpBuf;
|
Но возникает вопрос - как узнать, сколько таких структур было записано в буфер. Для этого используется 1 параметр структуры - NextEntryOffset. Если он не равен нулю, то в нем будет кол-во байт, через которые находится следующая запись и нам надо сдвинуть указатель на это кол-во байт, чтобы " получить" следующую структуру. И так далее, пока NextEntryOffset не будет равен 0 (т.е. эта запись была последней).
repeat
// Добавляем новый элемент в TListView (ViewStyle = vsReport )
Item := LV.Items.Add;
// Выделяем память под имя файла
GetMem(FileName,PFileNotifyInformation(Ptr).FileNameLength+2);
// Очищаем память - чтобы последним символом после копирования
// был бы #0 нуль
ZeroMemory(FileName,PFileNotifyInformation(Ptr).FileNameLength+2);
// WinAPI функция для копирования Unicode строки
lstrcpynW(FileName,PFileNotifyInformation(Ptr).FileName,
PFileNotifyInformation(Ptr).FileNameLength div 2+1);
// Имя файла у нас дается относительно папки
// т.е.если изменится файл C:\File\test.dat, то FileName
// будет равно File\test.dat
Item.Caption:='C:\'+FileName;
// Имя файла нам больше не нужно - очищаем память
FreeMem(FileName);
// Определяем тип произошедшего действия
case PFileNotifyInformation(Ptr).Action of
FILE_ACTION_ADDED : Item.SubItems.Add('Файл был создан');
FILE_ACTION_REMOVED : Item.SubItems.Add('Файл был удален');
FILE_ACTION_MODIFIED : Item.SubItems.Add('Файл был изменен');
FILE_ACTION_RENAMED_OLD_NAME :
Item.SubItems.Add('Файл был переименован и в имени файла - предыдущее имя');
FILE_ACTION_RENAMED_NEW_NAME :
Item.SubItems.Add('новое имя после переименования');
else Item.SubItems.Add('Произошло что-то странное');
end;
// Время, когда произошло событие
GetLocalTime(sTime);
with sTime do
Item.SubItems.Add(Format('%.2d:%.2d:%.2d',[wHour,wMinute,wSecond])); // 13:54:20
// Если эта запись не последняя (NextEntryOffset < > 0), то...
if PFileNotifyInformation(Ptr).NextEntryOffset=0
then Break
else begin
// ... добавляем строку в примечания (если интересно посмотреть смещение)
Item.SubItems.Add('Offset : '+
IntToStr(PFileNotifyInformation(Ptr).NextEntryOffset));
//Передвигаем указатель на NextEntryOffset байт вперед
Inc(Cardinal(Ptr),PFileNotifyInformation(Ptr).NextEntryOffset);
// Теперь Ptr указывает на следующую запись
end;
// Передвигать надо именно Ptr, а не lpBuf
until false;
until false;
// Очищаем память
FreeMem(lpBuf);
end;
|
Параметр функции dwNotifyFilter - действия, информацию о которых мы хотим получать.
FILE_NOTIFY_CHANGE_FILE_NAME - создание, удаление, переименование файла. FILE_NOTIFY_CHANGE_DIR_NAME - созданием и удаление каталога. FILE_NOTIFY_CHANGE_ATTRIBUTES - изменение атрибутов файла. FILE_NOTIFY_CHANGE_SIZE - изменение размера файла. FILE_NOTIFY_CHANGE_LAST_WRITE - изменение файла (это и предыдущее уведомление будет получено только в момент реальной записи файла на диск). FILE_NOTIFY_CHANGE_LAST_ACCESS - изменение времени последнего доступа. FILE_NOTIFY_CHANGE_CREATION - изменение времени создания файла. FILE_NOTIFY_CHANGE_SECURITY - изменение параметров безопасности (прав доступа и т.д.) У меня в примере используются FILE_NOTIFY_CHANGE_FILE_NAME, FILE_NOTIFY_CHANGE_DIR_NAME и FILE_NOTIFY_CHANGE_LAST_WRITE.А теперь надо только запустить поток.
procedure TForm1.Button1Click(Sender: TObject); var ThID : Cardinal; begin // hThread - THandle - глобальная переменная // Создаем поток // LV - TListView, WorkThread - функция выше hThread:=CreateThread(nil,0,@WorkThread,LV,0,ThID); // В случае неудачи выводим сообщение if hThread=0 then ShowMessage(SysErrorMessage(GetLastError)); end; |
У меня в исходниках поток останавливается функцией TerminateThread(hThread,Cardinal(-1)). Но при таком завершении не будут освобождены все ресурсы, занятые потоком (а это как минимум BUF_SIZE байт памяти. Вместо этой функции было бы лучше использовать SuspendThread(hThread), а при запуске проверять на существование потока WaitForSingleObject(hThread,0)= WAIT_TIMEOUT и если он существует - делать ResumeThread(hThread)... но в исходниках этого пока нет :).
Прочесть текстовый файл DOS.
| Лозунг компании Microsoft на презентации Windows ME: "ДОС - НАФИГ!" |
Если попытаться открыть текст, написанный в DOS, не меняя свойство Charset, то получится набор непонятных символов. Например в Windows символ с кодом 174 - это значок "®", а в DOS это обычная "о". Свойство Charset, установленное в OEM_CHARSET, заставляет выводить именно "о", если код символа 174. Эта программа читает файлы DOS.
procedure TForm1.FormCreate(Sender: TObject);
begin
Memo1.Font.Charset := OEM_CHARSET;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenDialog1.Execute then
Memo1.Lines.LoadFromFile(OpenDialog1.FileName)
end;
|
Считать данные из ячеек Excel.
Автор: Rusher
var
Excel: variant;
i, j: word;
S: string;
begin
Excel := CreateOleObject('Excel.Application');
Excel.Workbooks.Open(FileName);
Excel.Visible:=True;
for i := 1 to 5 do
for j := 1 to 5 do
begin
S := Excel.Sheets[1].Cells[i,j].Text;
ShowMessage(S);
end;
end;
|
Читаем заголовок exe файла.
Автор: http://www.swissdelphicenter.ch
{ You'll need a OpenDialog to open a Exe-File
and a Memo to show the file informations }
procedure DumpDOSHeader(const h: IMAGE_DOS_HEADER; Lines: TStrings);
begin
Lines.Add('Dump of DOS file header');
Lines.Add(Format('Magic number: %d', [h.e_magic]));
Lines.Add(Format('Bytes on last page of file: %d', [h.e_cblp]));
Lines.Add(Format('Pages in file: %d', [h.e_cp]));
Lines.Add(Format('Relocations: %d', [h.e_crlc]));
Lines.Add(Format('Size of header in paragraphs: %d', [h.e_cparhdr]));
Lines.Add(Format('Minimum extra paragraphs needed: %d', [h.e_minalloc]));
Lines.Add(Format('Maximum extra paragraphs needed: %d', [h.e_maxalloc]));
Lines.Add(Format('Initial (relative) SS value: %d', [h.e_ss]));
Lines.Add(Format('Initial SP value: %d', [h.e_sp]));
Lines.Add(Format('Checksum: %d', [h.e_csum]));
Lines.Add(Format('Initial IP value: %d', [h.e_ip]));
Lines.Add(Format('Initial (relative) CS value: %d', [h.e_cs]));
Lines.Add(Format('File address of relocation table: %d', [h.e_lfarlc]));
Lines.Add(Format('Overlay number: %d', [h.e_ovno]));
Lines.Add(Format('OEM identifier (for e_oeminfo): %d', [h.e_oemid]));
Lines.Add(Format('OEM information; e_oemid specific: %d', [h.e_oeminfo]));
Lines.Add(Format('File address of new exe header: %d', [h._lfanew]));
Lines.Add('');
end;
procedure DumpPEHeader(const h: IMAGE_FILE_HEADER; Lines: TStrings);
var
dt: TDateTime;
begin
Lines.Add('Dump of PE file header');
Lines.Add(Format('Machine: %4x', [h.Machine]));
case h.Machine of
IMAGE_FILE_MACHINE_UNKNOWN: Lines.Add(' MACHINE_UNKNOWN ');
IMAGE_FILE_MACHINE_I386: Lines.Add(' Intel 386. ');
IMAGE_FILE_MACHINE_R3000:
Lines.Add(' MIPS little-endian, 0x160 big-endian ');
IMAGE_FILE_MACHINE_R4000: Lines.Add(' MIPS little-endian ');
IMAGE_FILE_MACHINE_R10000: Lines.Add(' MIPS little-endian ');
IMAGE_FILE_MACHINE_ALPHA: Lines.Add(' Alpha_AXP ');
IMAGE_FILE_MACHINE_POWERPC: Lines.Add(' IBM PowerPC Little-Endian ');
// some values no longer defined in winnt.h
$14D: Lines.Add(' Intel i860');
$268: Lines.Add(' Motorola 68000');
$290: Lines.Add(' PA RISC');
else
Lines.Add(' unknown machine type');
end; { Case }
Lines.Add(Format('NumberOfSections: %d', [h.NumberOfSections]));
Lines.Add(Format('TimeDateStamp: %d', [h.TimeDateStamp]));
dt := EncodeDate(1970, 1, 1) + h.Timedatestamp / SecsPerDay;
Lines.Add(FormatDateTime(' c', dt));
Lines.Add(Format('PointerToSymbolTable: %d', [h.PointerToSymbolTable]));
Lines.Add(Format('NumberOfSymbols: %d', [h.NumberOfSymbols]));
Lines.Add(Format('SizeOfOptionalHeader: %d', [h.SizeOfOptionalHeader]));
Lines.Add(Format('Characteristics: %d', [h.Characteristics]));
if (IMAGE_FILE_DLL and h.Characteristics) <> 0 then
Lines.Add(' file is a DLL')
else if (IMAGE_FILE_EXECUTABLE_IMAGE and h.Characteristics) <> 0 then
Lines.Add(' file is a program');
Lines.Add('');
end;
procedure DumpOptionalHeader(const h: IMAGE_OPTIONAL_HEADER; Lines: TStrings);
begin
Lines.Add('Dump of PE optional file header');
Lines.Add(Format('Magic: %d', [h.Magic]));
case h.Magic of
$107: Lines.Add(' ROM image');
$10B: Lines.Add(' executable image');
else
Lines.Add(' unknown image type');
end; { If }
Lines.Add(Format('MajorLinkerVersion: %d', [h.MajorLinkerVersion]));
Lines.Add(Format('MinorLinkerVersion: %d', [h.MinorLinkerVersion]));
Lines.Add(Format('SizeOfCode: %d', [h.SizeOfCode]));
Lines.Add(Format('SizeOfInitializedData: %d', [h.SizeOfInitializedData]));
Lines.Add(Format('SizeOfUninitializedData: %d', [h.SizeOfUninitializedData]));
Lines.Add(Format('AddressOfEntryPoint: %d', [h.AddressOfEntryPoint]));
Lines.Add(Format('BaseOfCode: %d', [h.BaseOfCode]));
Lines.Add(Format('BaseOfData: %d', [h.BaseOfData]));
Lines.Add(Format('ImageBase: %d', [h.ImageBase]));
Lines.Add(Format('SectionAlignment: %d', [h.SectionAlignment]));
Lines.Add(Format('FileAlignment: %d', [h.FileAlignment]));
Lines.Add(Format('MajorOperatingSystemVersion: %d',
[h.MajorOperatingSystemVersion]));
Lines.Add(Format('MinorOperatingSystemVersion: %d',
[h.MinorOperatingSystemVersion]));
Lines.Add(Format('MajorImageVersion: %d', [h.MajorImageVersion]));
Lines.Add(Format('MinorImageVersion: %d', [h.MinorImageVersion]));
Lines.Add(Format('MajorSubsystemVersion: %d', [h.MajorSubsystemVersion]));
Lines.Add(Format('MinorSubsystemVersion: %d', [h.MinorSubsystemVersion]));
Lines.Add(Format('Win32VersionValue: %d', [h.Win32VersionValue]));
Lines.Add(Format('SizeOfImage: %d', [h.SizeOfImage]));
Lines.Add(Format('SizeOfHeaders: %d', [h.SizeOfHeaders]));
Lines.Add(Format('CheckSum: %d', [h.CheckSum]));
Lines.Add(Format('Subsystem: %d', [h.Subsystem]));
case h.Subsystem of
IMAGE_SUBSYSTEM_NATIVE:
Lines.Add(' Image doesnot require a subsystem. ');
IMAGE_SUBSYSTEM_WINDOWS_GUI:
Lines.Add(' Image runs in the Windows GUI subsystem. ');
IMAGE_SUBSYSTEM_WINDOWS_CUI:
Lines.Add(' Image runs in the Windows character subsystem. ');
IMAGE_SUBSYSTEM_OS2_CUI:
Lines.Add(' image runs in the OS/2 character subsystem. ');
IMAGE_SUBSYSTEM_POSIX_CUI:
Lines.Add(' image run in the Posix character subsystem. ');
else
Lines.Add(' unknown subsystem')
end; { Case }
Lines.Add(Format('DllCharacteristics: %d', [h.DllCharacteristics]));
Lines.Add(Format('SizeOfStackReserve: %d', [h.SizeOfStackReserve]));
Lines.Add(Format('SizeOfStackCommit: %d', [h.SizeOfStackCommit]));
Lines.Add(Format('SizeOfHeapReserve: %d', [h.SizeOfHeapReserve]));
Lines.Add(Format('SizeOfHeapCommit: %d', [h.SizeOfHeapCommit]));
Lines.Add(Format('LoaderFlags: %d', [h.LoaderFlags]));
Lines.Add(Format('NumberOfRvaAndSizes: %d', [h.NumberOfRvaAndSizes]));
end;
// Example Call, Beispielaufruf:
procedure TForm1.Button1Click(Sender: TObject);
var
fs: TFilestream;
signature: DWORD;
dos_header: IMAGE_DOS_HEADER;
pe_header: IMAGE_FILE_HEADER;
opt_header: IMAGE_OPTIONAL_HEADER;
begin
memo1.Clear;
with Opendialog1 do
begin
Filter := 'Executables (*.EXE)|*.EXE';
if Execute then
begin
fs := TFilestream.Create(FileName, fmOpenread or fmShareDenyNone);
try
fs.read(dos_header, SizeOf(dos_header));
if dos_header.e_magic <> IMAGE_DOS_SIGNATURE then
begin
memo1.Lines.Add('Invalid DOS file header');
Exit;
end;
DumpDOSHeader(dos_header, memo1.Lines);
fs.seek(dos_header._lfanew, soFromBeginning);
fs.read(signature, SizeOf(signature));
if signature <> IMAGE_NT_SIGNATURE then
begin
memo1.Lines.Add('Invalid PE header');
Exit;
end;
fs.read(pe_header, SizeOf(pe_header));
DumpPEHeader(pe_header, memo1.Lines);
if pe_header.SizeOfOptionalHeader > 0 then
begin
fs.read(opt_header, SizeOf(opt_header));
DumpOptionalHeader(opt_header, memo1.Lines);
end;
finally
fs.Free;
end; { finally }
end;
end;
end;
Access to table disabled because of previous error - Read failure.
Автор: Наталия Елманова WEB-сайт: http://www.sources.ru При добавлении новых записей с помощью метода TTable.AppendRecord в индексированную таблицу FoxPro через какое-то время (то есть при одновременном добавлении большого количества записей) возникает ошибка: "Access to table disabled because of previous error. Read failure. File ". Возможно, причина заключается в том, что операции чтения-записи в файл, содержащий таблицу FoxPro, особенно при использовании кэширования, предоставляемого операционной системой, конфликтуют с содержимым индексного файла (это часто происходит при многопользовательской работе). Дело в том, что ранние версии dBase, FoxPro, Clipper работали с неподдерживаемыми индексами, то есть индексные файлы не обновлялись одновременно с таблицей, и для их синхронизации требовалось выполнять специальные операции. Но соответствующие средства разработки, применявшиеся в то время, обычно не поддерживали никаких аналогов транзакций - записи чаще всего вставлялись по одной. В случае применения старых версий формата FoxPro следует избегать кэширования при выполнении дисковых операций с файловым сервером, содержащим базу данных FoxPro. Кроме того, следует проверить и, если необходимо, изменить в настройках BDE параметры MINBUFSIZE, MAXBUFSIZE, LOCAL SHARE - возможно, проблема заключается в недостаточной величине буферов BDE для кэширования данных или в одновременном доступе к данным приложений, использующих и не использующих BDE.Еще одним из способов решения этой проблемы (самым радикальным) является замена FoxPro на какую-нибудь из серверных СУБД. Например, InterBase неплохо справляется с одновременным вводом большого количества записей благодаря некоторым специфическим особенностям архитектуры этого сервера.
Как прочесть атрибут файла Last Accessed (последний доступ).
procedure TForm1.Button1Click(Sender: TObject);
var
FileHandle: THandle;
LocalFileTime: TFileTime;
DosFileTime: DWORD;
LastAccessedTime: TDateTime;
FindData: TWin32FindData;
begin
FileHandle := FindFirstFile('AnyFile.FIL', FindData);
if FileHandle <> INVALID_HANDLE_VALUE then
begin
Windows.FindClose(Handle);
if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then
begin
FileTimeToLocalFileTime(FindData.ftLastWriteTime, LocalFileTime);
FileTimeToDosDateTime(LocalFileTime,
LongRec(DosFileTime).Hi, LongRec(DosFileTime).Lo);
LastAccessedTime := FileDateToDateTime(DosFileTime);
Label1.Caption := DateTimeToStr(LastAccessedTime);
end;
end;
end;
|
Чтение из файла длинной строки.
Автор: LazyManДля решения этой задачи на помощь можно призвать потоки (TFileStream, TMemoryStream). Для поиска конца строк нужно искать пары CR/LF, но это делается очень легко, приблизительно так (я сегодня вечером слишком ленивый для реального кода):
Start := Stream.Position;
End := Start;
Repeat
Stream.Read(Buffer^, 1024);
CRPos := FindCR(Buffer^); { где FindCR возвращает 0..1023 для CR,
и 1024, если он не найден}
Inc(End, CRPos);
Until CRPos < 1024;
GetMem(MyPChar, End - Start); { Здесь может быть +-1 -- мне лень сегодня проверять! }
Stream.Seek(Start);
Stream.Read(MyPChar^, End - Start)
|
Затем установите CR в конце MyPChar в 0, и сделайте Seek в конец (End + 1), или что-то еще, чтобы пропустить LF.
Чтение из файла.
Пусть на диске есть некоторый текстовый файл. Нужно в диалоговое окно вывести содержимое этого файла. Решение задачи довольно очевидно: надо открыть файл, прочитать первую строку, затем вторую, третью и т. д. до тех пор, пока не будет достигнут конец файла. Но как определить, что прочитана последняя строка, достигнут конец файла? Для определения конца файла можно воспользоваться функцией EOF (End of File — конец файла). У функции EOF один параметр — файловая переменная. Значение функции EOF равно False, если прочитанный элемент данных не является последним в файле, т. е. возможно дальнейшее чтение. Если прочитанный элемент данных является последним, то значение EOF равно True. Значение функции EOF можно проверить сразу после открытия файла. Если при этом оно окажется равным True, то это значит, что файл не содержит ни одного элемента данных, т. е. является пустым (размер такого файла равен нулю).В листинге приведена процедура, которая выполняет поставленную задачу. Она читает строки из файла, имя которого ввел пользователь во время работы программы, и выводит эти строки в поле Memo.
unit rd_;
interface
uses
Windows, Messages, SysUtils, Variants, Classes,
Graphics, Controls, Forms, Dialogs, StdCtrls, Buttons;
type
TForm1 = class(TForm)
Button2: TButton;
Edit1: TEdit;
Memo1: TMemo;
Button1: TButton;
procedure Button2Click(Sender: TObject);
procedure ButtonlClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForml;
implementation
{$R *.dfm}
// щелчок на кнопке Открыть
procedure TForm1.Button1Click(Sender: TObject);
var
f: TextFile; // файл
fName: String[80]; // имя файла
buf: string[80]; // буфер для чтения из файла
begin
fName := Edit1.Text; AssignFile(f, fName);
{$!-}
Reset(f); // открыть для чтения
{$I+}
if IOResult <> 0 then
begin
MessageDlgt 'Ошибка доступа к файлу ' + fName,
mtError, [mbOk], 0); exit;
end;
// чтение из файла
while not EOF(f) do
begin
readln(f, buf); // прочитать строку из файла
Memo1.Lines.Add(buf); // добавить строку в поле Memo1
end;
CloseFile(f); // закрыть файл
end;
// щелчок на кнопке Сохранить — запись в файл
procedure TForml.Button2Click(Sender: TObject);
var
f: TextFile; // файл
fName: string[80]; // имя файла
i: integer;
begin
fName := Edit1.Text;
AssignFile(f, fName);
Rewrite(f); // открыть для перезаписи
// запись в файл
for i := 0 to Memo1.Lines.Count do // строки нумеруются с нуля
writeln(f, Memo1.Lines[i]);
CloseFile(f); // закрыть файл
MessageDlg('Данные записаны в файл ', mtlnformation, [mbOk], 0);
end;
end.
Для организации обработки файла использована инструкция цикла while, которая обеспечивает проверку значения функции EOF перед каждым чтением, в том числе и перед первым.
Наличие кнопки Сохранить и соответствующей ей процедуры позволяет сохранить содержимое поля Memo в файле, т. е. программа чтение из файла представляет собой примитивный редактор текста.
Добавление очередной прочитанной из файла строки в поле Memo выполняется применением метода Add к свойству Lines.
Как прочитать из модема.
| Помимо двух настоящих извращений - хоккея на траве и балета на льду, существует и третье - диалап через ip-телефонию. |
После предварительной настройки переменных, COM порт открывается как обычный файл. Так же пример показывает, как очищать буфер COM порта и читать из него.
var
PortSpec : array[0..255] of char;
PortNo : Word;
success : Boolean;
error:integer;
begin
FillChar(PortSpec,Sizeof(PortSpec),#0);
StrPCopy(PortSpec,'Com1:19200,n,8,1');
PortSpec[3]:=Char(Ord(PortSpec[3])+Ord(PortNo));
if not BuildCommDCB(PortSpec,Mode) then
begin
//какая-то ошибка...
Exit;
end;
PortSpec[5]:=#0; { 'Com1:' }
Mode.Flags:=EV_RXCHAR + EV_EVENT2; { $1001 }
Com := CreateFile(PortSpec,GENERIC_READ or GENERIC_WRITE,
0, { comm устройство открывается с эксклюзивным доступом }
nil, { нет security битов }
OPEN_EXISTING, { comm устройства должны использовать OPEN_EXISTING }
0, { not overlapped I/O }
0 { hTemplate должен быть NULL для comm устройств }
);
if Com = INVALID_HANDLE_VALUE then
Error := GetLastError;
Success := GetCommState(Com,Mode);
if not Success then // Обработчик ошибки.
begin
end;
Mode.BaudRate := 19200;
Mode.ByteSize := 8;
Mode.Parity := NOPARITY;
Mode.StopBits := ONESTOPBIT;//нужен был для перезаписи в NT
Success := SetCommState(Com, Mode);
if not Success then // Обработчик ошибки.
begin
end;
end;
|
Переменная "com" типа dword.
Вы так же можете очистить буффер COM порта.
PurgeComm(Com, PURGE_RXCLEAR or PURGE_TXCLEAR); |
И прочитать из него.
function ReadCh(var Ch: Byte): dword; var n: dword; begin Readfile(Com, ch, 1, result, nil); end; |
Читаем из файла, открытого другим приложением.
Даже если файл открыт с низкими привелегиями (используя ReadOnly, ShareReadWrite) , иногда открытие уже открытого файла может приводить к ошибкам, особенно, если это файл интенсивно используется другим приложением. Самый простой способ решить эту проблемму - это использовать MemoryStream вместо непосредственного доступа к файлу:
var
Memory: TMemoryStream;
begin
Memory := TMemoryStream.Create;
try
Memory.LoadFromFile('DelphiWorld.dat'); // это он!!
...
Memory.read(...); // Вы можете использовать методы чтения как у файлов
Memory.Seek(...);
FileSize := Memory.Size;
...
finally
Memory.Free;
end;
end;
|
Данный способ никогда не открывает файл, а заместо этого создаёт копию его в памяти. Конечно Вы можете и записать в поток (Stream) в Памяти(Memory), но изменения не будут записаны на диск до тех пор, пока Вы не запишете их в файл (командой SaveToFile).
Прочитать и изменить текстовый файл строка за строкой.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
procedure TForm1.Button1Click(Sender: TObject);
var
i, z: Integer;
f: TextFile;
t: string;
Data: array of string;
begin
if OpenDialog1.Execute then
begin
//Read line by line in to the array data
AssignFile(f, OpenDialog1.FileName);
Reset(f);
z := 0;
SetLength(Data, 0);
//Repeat for each line until end of file
repeat
Inc(z);
readln(f, t);
SetLength(Data, Length(Data) + Length(t));
Data[z] := t;
until EOF(f);
SetLength(Data, Length(Data) + 3 * z);
//Add to each line the line number
for i := 1 to z do Data[i] := IntToStr(i) + ' ' + Data[i];
SetLength(Data, Length(Data) + 2);
//Add a carriage return and line feed
Data[1] := Data[1] + #13 + #10;
i := Length(Data[5]);
Data[5] := '';
SetLength(Data, Length(Data) - i);
//create a new textfile with the new data
AssignFile(f, OpenDialog1.FileName + '2');
ReWrite(f);
//write all lines
for i := 1 to z do writeln(f, Data[i]);
//save file and close it
CloseFile(f);
end;
end;
Чтение OLE из Blob поля Paradox.
Автор: Eryk ...после моих дискуссий с людьми из службы технической поддержки Borland вывод один -- это невозможно!Попробуйте так:
procedure TForm1.SpeedButton1Click(Sender: TObject);
var
b: TBlobStream;
begin
try
b := TBlobStream.Create((Table1.FieldByName('OLE') as TBlobField),bmRead);
OLEContainer1.LoadFromStream(b);
finally
b.free;
end;
end;
|
...и:
procedure TForm1.SpeedButton2Click(Sender: TObject);
var
b: TBlobStream;
begin
try
Table1.Insert;
b := TBlobstream.Create((Table1.FieldByName('OLE') as TBlobField),bmReadWrite);
OLEContainer1.SaveToStream(b);
Table1.Post;
finally
b.free;
end;
end;
|
Я, кажется, припоминаю несколько ошибок GPFs с этим кодом, но это, вероятно, связано с тем, что я использую WinNT с другим распределением памяти... тем не менее, основные функции работали как положено (т.е. данные сохранялись и загружались). Основная специфика проявилась в том, что PdoxWIN не смог прочесть данные TOLEContainer. Но это результаты моих экспериментов и предположений, исходя из которых PdoxWIN ожидает 8-байтовый заголовок BLOB-поля, который ему просто не дает TOLEContainer... если это так, то это легко обойти.
Прочитать адрес отправителя сообщения для MS Outlook.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{
If you tried to work with messages from Delphi, you know that received message have the
SenderName property (name of sender) but doesn't allow to read the real address of sender.
Something like SenderAddress is not available.
There exist a few methods to retrieve this information:
1. help file says that sender is in Recipients collection
with Type property - 0 (olOriginator).
But this way does work for any version of MS Outlook.
So just iterate thru collection of Recipients and find an item with Type=0
couldn't return required value
2. as alternative you can read a ReplyTo property - there you'll receive an address
(but generally ReplyTo and Sender could be different).
For example, in messages which I send from own mail account these values are different.
3. to create a new MailItem (just will be destroyed without saving in end of work),
define a Recipient as value which you received from SenderName of your original
message and call a Resolve method - after that you'll recieve a correct email address of this sender.
4. more correct and fast solution is the next:
}
var
s: string;
objCDO: OLEVariant;
begin
objCDO := CreateOLEObject('MAPI.Session');
objCDO.Logon('', '', False, False);
objMsg := objCDO.GetMessage(itemOL.EntryID, itemOL.Parent.StoreID);
s := objMsg.Sender.Address;
ShowMessage(s);
objMsg := Unassigned;
objCDO := Unassigned;
end
{ where itemOL is a MailItem which contain a SenderName but doesn't contain a SenderAddress }
Установка атрибута Только для чтения у столбцов компонента StringGrid.
| Сидят двое программистов в кафе и, натурально, пьют пиво. Мимо проходит такая девушка, вся из себя девушка. Один программист другому: - Ты посмотри какие propertes!!! Другой: - Вчера проверял, все read only. |
Манипулирование вышеуказанным атрибутом возможно в обработчике события OnSelectCell:
if Col mod 2 = 0 then grd.Options := grd.Options + [goEditing] else grd.Options := grd.Options - [goEditing]; |
Чтение из открытого файла.
Автор: Neutrino WEB-сайт: http://forum.vingrad.ruДаже если файл открыт с низкими привелегиями (используя ReadOnly, ShareReadWrite) , иногда открытие уже открытого файла может приводить к ошибкам, особенно, если это файл интенсивно используется другим приложением. Самый простой способ решить эту проблемму - это использовать MemoryStream вместо непосредственного доступа к файлу:
var
Memory: TMemoryStream;
begin
Memory := TMemoryStream.Create;
try
Memory.LoadFromFile('busyfile.dat'); // это он!!
..
Memory.Read(...); // Вы можете использовать методы чтения как у файлов
Memory.Seek(...);
FileSize := Memory.Size;
..
finally
Memory.Free;
end;
end;
Данный способ никогда не открывает файл, а заместо этого создаёт копию его в памяти. Конечно Вы можете и записать в поток (Stream) в Памяти(Memory), но изменения не будут записаны на диск до тех пор, пока Вы не запишете их в файл (командой SaveToFile).
Решение хорошее, но накладно если файл большой...
Чтение из открытого файла 2.
Автор: Vit WEB-сайт: http://forum.vingrad.ru
var
b: string[15];
begin
with TFileStream.create('c:\MyFile.doc', fmShareDenyNone) do
try
read(b, 14);
showmessage(b);
finally
Free;
end;
end;
Чтение из открытого файла 3.
Автор: PILOTIK WEB-сайт: http://forum.vingrad.ru
procedure TForm1.Button1Click(Sender: TObject);
type
AnyType = byte;
var
F: file of AnyType;
const
FName = 'D:/Exp.exe';
begin
begin
AssignFile(F, FName); { File selected in dialog }
FileMode := fmOpenRead;
Reset(F);
// ...
// ...
CloseFile(F);
FileMode := fmOpenReadWrite;
end;
end;
Как прочитать очередь печати.
Автор: http://www.swissdelphicenter.ch
uses
Winspool, Printers;
function GetCurrentPrinterHandle: THandle;
var
Device, Driver, Port: array[0..255] of Char;
hDeviceMode: THandle;
begin
Printer.GetPrinter(Device, Driver, Port, hDeviceMode);
if not OpenPrinter(@Device, Result, nil) then
RaiseLastWin32Error;
end;
function SavePChar(p: PChar): PChar;
const
error: PChar = 'Nil';
begin
if not Assigned(p) then
Result := error
else
Result := p;
end;
procedure TForm1.Button1Click(Sender: TObject);
type
TJobs = array[0..1000] of JOB_INFO_1;
PJobs = ^TJobs;
var
hPrinter: THandle;
bytesNeeded, numJobs, i: Cardinal;
pJ: PJobs;
begin
hPrinter := GetCurrentPrinterHandle;
try
EnumJobs(hPrinter, 0, 1000, 1, nil, 0, bytesNeeded,
numJobs);
pJ := AllocMem(bytesNeeded);
if not EnumJobs(hPrinter, 0, 1000, 1, pJ, bytesNeeded,
bytesNeeded, numJobs) then
RaiseLastWin32Error;
memo1.Clear;
if numJobs = 0 then
memo1.Lines.Add('No jobs in queue')
else
for i := 0 to Pred(numJobs) do
memo1.Lines.Add(Format('Printer %s, Job %s, Status (%d): %s',
[SavePChar(pJ^[i].pPrinterName), SavePChar(pJ^[i].pDocument),
pJ^[i].Status, SavePChar(pJ^[i].pStatus)]));
finally
ClosePrinter(hPrinter);
end;
end;
Как прочитать свойство напрямую из его ресурса.
Автор: Michael Duerig WEB-сайт: http://www.lmc-mediaagentur.deDoes anyone know if there is an easy way to load the value of a component's property directly from its resource without creating the component? Something like:
if ReadPropertyValue('Form1.Button1', 'width') > 1000 then
ShowMessage('You are about to create a big button!');
function TForm1.ReadProp(r: TReader): string;
begin
result := '';
{Determine the value type of the property, read it with the appropriate method of TReader
and convert it to string. Not all value types are implemented here but you get the idea.}
case r.NextValue of
vaInt8, vaInt16, vaInt32:
result := IntToStr(r.ReadInteger);
vaExtended:
result := FloatToStr(r.ReadFloat);
vaString:
result := r.ReadString;
else
r.SkipValue; {Not implemented}
end;
end;
procedure TForm1.ReadRes(PropPath: string; r: TReader);
var
p: string;
begin
{Skip the class name}
r.ReadStr;
{Construct the property path}
if PropPath = '' then
p := r.ReadStr
else
p := PropPath + '.' + r.ReadStr;
{Read all properties and its values and fill them into the memo}
while not r.EndOfList do
Memo1.Lines.Add(p + '.' + r.ReadStr + ' = ' + ReadProp(r));
{Skip over the end of the list of the properties of this component}
r.CheckValue(vaNull);
{Recursively read the properties of all sub-components}
while not r.EndOfList do
begin
ReadRes(p, r);
r.CheckValue(vaNull);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
strm: TResourceStream;
Reader: TReader;
begin
strm := TResourceStream.Create(HInstance, 'TForm1', RT_RCDATA);
Reader := TReader.Create(strm, 1024);
try
Memo1.Clear;
Reader.ReadSignature;
ReadRes('', Reader);
finally
Reader.Free;
strm.Free;
end;
end;
Only one small problem. r.SkipValue was protected (in D5) but I hacked that out with the following code:
type
THackReader = class(TReader);
{ ... }
THackReader(r).SkipValue;
And now it works like a charm.
Чтение текста RichEdit из базы данных.
Автор: Сергей ЛагонскийЗапись TRichEdit в файл и сохранение этого файла в БД является наиболее простым способом сохранения текста компонента в таблице, но тот же способ может быть достигнут и без использования промежуточного файла, а именно с помощью TBlobStream. Пример, приведенный ниже, демонстрирует чтение текста TRichEdit из таблицы. Надеюсь с записью текста проблем у вас уже не возникнет.
procedure ReadRichEditFromTable(Table : TTable; var RichEdit : TRichEdit);
var
BlobStream: TBlobStream;
begin
try
BlobStream := TBlobStream.Create(Table.FieldByName('BODY') as TBlobField, bmRead);
if (not Table.FieldByName('BLOBFieldName').IsNull) then
begin
RichEdit.Lines.LoadFromStream (BlobStream);
end;
finally
BlobStream.Free;
end;
end;
|
Прочитать ROM-BIOS.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
// An Example of this unit is availabe as Demo Download.
// Ein Beispiel zur Anwendung dieser Unit kann als Demo heruntergeladen werden.
////////////////////////////////////////////////////////////////////////////////
//
// BIOS Helper for Delphi
//
// BIOS related utilities for Win9x and WinNT(i386)
//
////////////////////////////////////////////////////////////////////////////////
//
// The Original Code is:
// BiosHelp.pas, released 2001-09-02.
//
// The Initial Developer of the Original Code is Nico Bendlin.
//
// Portions created by Nico Bendlin are
// Copyright (C) 2001-2003 Nico Bendlin. All Rights Reserved.
//
// Contributor(s):
// Nico Bendlin<nicode@gmx.net>
//
// The contents of this file are subject to the Mozilla Public License Version
// 1.1 (the "License"); you may not use this file except in compliance with the
// License. You may obtain a copy of the License at http://www.mozilla.org/MPL/
//
// Software distributed under the License is distributed on an "AS IS" basis,
// WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
// the specific language governing rights and limitations under the License.
//
// Alternatively, the contents of this file may be used under the terms of
// either the GNU General Public License Version 2 or later (the "GPL"), or
// the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
// in which case the provisions of the GPL or the LGPL are applicable instead
// of those above. If you wish to allow use of your version of this file only
// under the terms of either the GPL or the LGPL, and not to allow others to
// use your version of this file under the terms of the MPL, indicate your
// decision by deleting the provisions above and replace them with the notice
// and other provisions required by the GPL or the LGPL. If you do not delete
// the provisions above, a recipient may use your version of this file under
// the terms of any one of the MPL, the GPL or the LGPL.
//
////////////////////////////////////////////////////////////////////////////////
//
// Revision:
//
// 2003-02-15 2.00 [NicoDE]
// - generic dump method completely rewritten
// - default range is now E000:0000-F000:FFFF
//
////////////////////////////////////////////////////////////////////////////////
{$IFDEF CONDITIONALEXPRESSIONS}
{$DEFINE DELPHI6UP}
{$IF NOT DEFINED(VER140)}
{$DEFINE DELPHI7UP}
{$IFEND}
{$ENDIF}
unit BiosHelp {$IFDEF DELPHI6UP} platform {$ENDIF};
{$MINENUMSIZE 4}
{$WEAKPACKAGEUNIT}
{$IFDEF DELPHI7UP}
{$WARN UNSAFE_TYPE OFF}
{$WARN UNSAFE_CODE OFF}
{$ENDIF}
interface
uses
Windows;
const
RomBiosDumpBase = $000E0000;
RomBiosDumpEnd = $000FFFFF;
RomBiosDumpSize = RomBiosDumpEnd - RomBiosDumpBase + 1;
type
PRomBiosDump = ^TRomBiosDump;
TRomBiosDump = array [RomBiosDumpBase..RomBiosDumpEnd] of Byte;
type
TRomDumpMethod = (rdmAutomatic, // Autodetect OS type and use proper method
rdmGeneric, // Use 16-bit EXE program to dump the BIOS
rdmMemory, // Dump from process's address space (Win9x)
rdmPhysical // Dump from physical memory object (WinNT)
);
function DumpRomBios(out Dump: TRomBiosDump;
Method: TRomDumpMethod = rdmAutomatic; Timeout: DWORD = 5000): Boolean;
function DumpRomBiosEx(RomBase: Pointer; RomSize: Cardinal; out Dump;
Method: TRomDumpMethod = rdmAutomatic; Timeout: DWORD = 5000): Boolean;
procedure ReadRomDumpBuffer(const Dump: TRomBiosDump; Addr: Pointer;
var Buffer; Size: Cardinal);
procedure ReadRomDumpBufferEx(const Dump; Base, Addr: Pointer;
var Buffer; Size: Cardinal);
function GetRomDumpAddr(const Dump: TRomBiosDump; Addr: Pointer): Pointer;
function GetRomDumpAddrEx(const Dump; Base, Addr: Pointer): Pointer;
implementation
////////////////////////////////////////////////////////////////////////////////
//
// DumpRomBios16 (rdmGeneric)
//
// Creates an 16-bit EXE program in TEMP and runs it redirected to an file.
//
// WARNING: One day 16-bit code will not run on future Windows.
// WARNING: You are dumping the BIOS inside the MS-DOS 'emulator'.
//
function _RomDumpCode(RomBase: Pointer; RomSize: Cardinal;
out Code: Pointer; out Size: Cardinal): Boolean;
const
BlockSize = $1000;
type // ; RomDump (dumps mem to STDOUT)
PRomDumpCode = ^TRomDumpCode; // ; BlockSize MUST be multiple of 10h.
TRomDumpCode = packed record //
_header: TImageDosHeader; //
_notice: array[0..$4F] of AnsiChar; // @@note: db 'RomDump 2.0', ...
init: packed record // @@init:
_mov_44: array[0..2] of Byte; // mov ax, 4400h
_mov_bx: array[0..2] of Byte; // mov bx, 0001h
_dos_21: array[0..1] of Byte; // int 21h
_jcf_18: array[0..1] of Byte; // jc @@code
_and_dx: array[0..3] of Byte; // and dx, 0082h
_cmp_dx: array[0..3] of Byte; // cmp dx, 0082h
_jne_0E: array[0..1] of Byte; // jne @@code
_psh_cs: Byte; // push cs
_pop_ds: Byte; // push ds
_mov_dx: array[0..2] of Byte; // mov dx, offset @@note
_mov_09: array[0..1] of Byte; // mov ah, 09h
_int_21: array[0..1] of Byte; // int 21h
_mov_4C: array[0..2] of Byte; // mov ax, 4C01h
_int_20: array[0..1] of Byte; // int 21h
end; //
code: packed record // @@code:
_mov_cx: Byte;
BlockCount: Word; // mov cx, <BlockCount>
_mov_dx: Byte;
DatSegment: Word; // mov dx, <DatSegment>
_jcx_1C: array[0..1] of Byte; // jcxz @@rest
end; //
loop: packed record // @@loop:
_psh_cx: Byte; // push cx
_psh_dx: Byte; // push dx
_mov_ds: array[0..1] of Byte; // mov ds, dx
_mov_dx: Byte;
DatOffset: Word; // mov dx, <DatOffset>
_mov_cx: array[0..2] of Byte; // mov cx, <BlockSize>
_mov_bx: array[0..2] of Byte; // mov bx, 0001h
_mov_ax: array[0..2] of Byte; // mov ax, 4000h
_int_21: array[0..1] of Byte; // int 21h
_pop_dx: Byte; // pop dx
_pop_cx: Byte; // pop cx
_jcf_1C: array[0..1] of Byte; // jc @@exit
_add_dx: array[0..3] of Byte; // add dx, <BlockSize/10h>
_lop_E4: array[0..1] of Byte; // loop @@loop
end; //
rest: packed record // @@rest:
_mov_ds: array[0..1] of Byte; // mov ds, dx
_mov_dx: Byte;
DatOffset: Word; // mov dx, <DatOffset>
_mov_cx: Byte;
LenghtMod: Word; // mov cx, <LenghtMod>
_mov_bx: array[0..2] of Byte; // mov bx, 0001h
_mov_ax: array[0..2] of Byte; // mov ax, 4000h
_jcx_06: array[0..1] of Byte; // jcxz @@exit
_int_21: array[0..1] of Byte; // int 21h
_jcf_02: array[0..1] of Byte; // jc @@exit
_mov_al: array[0..1] of Byte; // mov al, 00h
end; //
Exit: packed record // @@exit:
_mov_ah: array[0..1] of Byte; // mov ah, 4Ch
_int_21: array[0..1] of Byte; // int 21h
end; //
end;
const
RomDumpCodeSize = SizeOf(TRomDumpCode) - SizeOf(TImageDosHeader);
RomDumpCode: TRomDumpCode = (_header: (e_magic: IMAGE_DOS_SIGNATURE;
e_cblp: Word(RomDumpCodeSize) and $1FF;
e_cp: Word((RomDumpCodeSize - 1) shr 9) + 1;
e_crlc: $0000;
e_cparhdr: SizeOf(TImageDosHeader) shr 4;
e_minalloc: $0000;
e_maxalloc: $FFFF;
e_ss: $0000;
e_sp: $1000;
e_csum: $0000;
e_ip: SizeOf(RomDumpCode._notice);
e_cs: $0000;
e_lfarlc: SizeOf(TImageDosHeader);
e_ovno: $0000;
e_res: ($0000, $0000, $0000, $0000);
e_oemid: $0000;
e_oeminfo: $0000;
e_res2: ($0000, $0000, $0000, $0000, $0000, $0000, $0000, $0000,
$0000, $0000);
_lfanew: $00000000
);
_notice: #13#10+
'RomDump 2.0'#13#10 +
'Copyright (c) 2003 Nico Bendlin'#13#10 +
#13#10+
'Usage: RomDump > filename'#13#10 +
#13#10$';
init: (_mov_44: ($B8, $00, $44);
_mov_bx: ($BB, $01, $00);
_dos_21: ($CD, $21);
_jcf_18: ($72, $18);
_and_dx: ($81, $E2, $82, $00);
_cmp_dx: ($81, $FA, $82, $00);
_jne_0E: ($75, $0E);
_psh_cs: $0E;
_pop_ds: $1F;
_mov_dx: ($BA, $00, $00);
_mov_09: ($B4, $09);
_int_21: ($CD, $21);
_mov_4C: ($B8, $01, $4C);
_int_20: ($CD, $21);
);
code: (_mov_cx: $B9; BlockCount: $0010;
_mov_dx: $BA; DatSegment: $F000;
_jcx_1C: ($E3, $1C)
);
loop: (_psh_cx: $51;
_psh_dx: $52;
_mov_ds: ($8E, $DA);
_mov_dx: $BA; DatOffset: $0000;
_mov_cx: ($B9, Lo(BlockSize), Hi(BlockSize));
_mov_bx: ($BB, $01, $00);
_mov_ax: ($B8, $00, $40);
_int_21: ($CD, $21);
_pop_dx: $5A;
_pop_cx: $59;
_jcf_1C: ($72, $1C);
_add_dx: ($81, $C2, Lo(BlockSize shr 4), Hi(BlockSize shr 4));
_lop_E4: ($E2, $E4)
);
rest: (_mov_ds: ($8E, $DA);
_mov_dx: $BA; DatOffset: $0000;
_mov_cx: $B9; LenghtMod: $0000;
_mov_bx: ($BB, $01, $00);
_mov_ax: ($B8, $00, $40);
_jcx_06: ($E3, $06);
_int_21: ($CD, $21);
_jcf_02: ($72, $02);
_mov_al: ($B0, $00)
);
Exit: (_mov_ah: ($B4, $4C);
_int_21: ($CD, $21)
)
);
begin
Result := False;
if (RomSize > 0) and (RomSize <= $100000) and
(Cardinal(RomBase) < $100000) and
(Cardinal(RomBase) + RomSize <= $100000) then
begin
Size := SizeOf(TRomDumpCode);
Code := Pointer(LocalAlloc(LPTR, Size));
if Code <> nil then
try
PRomDumpCode(Code)^ := RomDumpCode;
with PRomDumpCode(Code)^ do
begin
code.BlockCount := Word(RomSize div BlockSize);
code.DatSegment := Word(Cardinal(RomBase) shr 4);
loop.DatOffset := Word(Cardinal(RomBase)) and $000F;
rest.DatOffset := loop.DatOffset;
rest.LenghtMod := Word(RomSize mod BlockSize);
end;
Result := True;
except
LocalFree(HLOCAL(Code));
Code := nil;
Size := 0;
end;
end;
end;
function _SaveRomDumpCodeToFile(RomBase: Pointer; RomSize: Cardinal;
const FileName: string): Boolean;
var
Code: Pointer;
Size: Cardinal;
Hand: THandle;
Num: DWORD;
begin
Result := False;
if _RomDumpCode(RomBase, RomSize, Code, Size) then
try
Hand := CreateFile(PChar(FileName), GENERIC_WRITE, FILE_SHARE_READ, nil,
CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0);
if Hand <> INVALID_HANDLE_VALUE then
try
Result := WriteFile(Hand, Code^, Size, Num, nil) and (Num = Size);
if not Result then
DeleteFile(PChar(FileName));
finally
CloseHandle(Hand);
end;
finally
LocalFree(HLOCAL(Code));
end;
end;
function _ExecuteRomDumpCode(const Code, Dump: string; Timeout: DWORD): Boolean;
var
ComSpec: string;
StartInfo: TStartupInfo;
ProcInfo: TProcessInformation;
ErrorMode: Cardinal;
begin
Result := False;
SetLength(ComSpec, MAX_PATH + 1);
SetLength(ComSpec,
GetEnvironmentVariable('ComSpec', PChar(@ComSpec[1]), MAX_PATH));
if Length(ComSpec) <= 0 then
Exit;
FillChar(StartInfo, SizeOf(TStartupInfo), 0);
StartInfo.cb := SizeOf(TStartupInfo);
StartInfo.dwFlags := STARTF_USESHOWWINDOW;
StartInfo.wShowWindow := SW_HIDE;
ErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS or SEM_NOGPFAULTERRORBOX or
SEM_NOALIGNMENTFAULTEXCEPT or SEM_NOOPENFILEERRORBOX);
try
if CreateProcess(nil, PChar(ComSpec + ' /C ' + Code + ' > ' + Dump),
nil, nil, False, HIGH_PRIORITY_CLASS, nil, nil, StartInfo, ProcInfo) then
try
Result :=
(WaitForSingleObject(ProcInfo.hProcess, Timeout) <> WAIT_TIMEOUT);
if not Result then
TerminateProcess(ProcInfo.hProcess, STATUS_TIMEOUT);
finally
CloseHandle(ProcInfo.hThread);
CloseHandle(ProcInfo.hProcess);
end;
finally
SetErrorMode(ErrorMode);
end;
end;
function DumpRomBios16(RomBase: Pointer; RomSize: Cardinal; var Dump;
Timeout: DWORD): Boolean;
var
Tmp: array [0..MAX_PATH] of Char;
Dmp: array [0..MAX_PATH] of Char;
Exe: array [0..MAX_PATH] of Char;
Hnd: THandle;
Num: DWORD;
begin
Result := False;
if GetTempPath(MAX_PATH, Tmp) > 0 then
GetShortPathName(Tmp, Tmp, MAX_PATH)
else
lstrcpy(Tmp, '.');
if GetTempFileName(Tmp, 'rom', 0, Dmp) > 0 then
try
lstrcpy(Exe, Dmp);
lstrcat(Exe, '.exe'); // Win9x requires .EXE extention
if _SaveRomDumpCodeToFile(RomBase, RomSize, Exe) then
try
if _ExecuteRomDumpCode(Exe, Dmp, Timeout) then
begin
Hnd := CreateFile(Dmp, GENERIC_READ, FILE_SHARE_READ or
FILE_SHARE_WRITE, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
if Hnd <> INVALID_HANDLE_VALUE then
try
Result := ReadFile(Hnd, Dump, RomSize, Num, nil) and (Num = RomSize);
finally
CloseHandle(Hnd);
end;
end;
finally
DeleteFile(Exe);
end;
finally
DeleteFile(Dmp);
end;
end;
////////////////////////////////////////////////////////////////////////////////
//
// DumpRomBios9x (rdmMemory)
//
// Win9x maps the BIOS into every process - therefore it's directly accessed.
//
function DumpRomBios9x(RomBase: Pointer; RomSize: Cardinal; var Dump): Boolean;
begin
Result := False;
try
Move(RomBase^, Dump, RomSize);
Result := True;
except
// ignore exeptions
end
end;
////////////////////////////////////////////////////////////////////////////////
//
// DumpRomBiosNt (rdmPhysical)
//
// On WinNT the BIOS is accessable through section '\Device\PhysicalMemory'.
// This object can only be opened by members of local 'Adminstrators' group.
// ZwOpenSection and RtlNtStatusToDosError are documented in newer MSDN/DDK.
//
type
NTSTATUS = Integer;
PUnicodeString = ^TUnicodeString;
TUnicodeString = packed record
Length: Word;
MaximumLength: Word;
Buffer: PWideChar;
end;
PObjectAttributes = ^TObjectAttributes;
TObjectAttributes = record
Length: ULONG;
RootDirectory: THandle;
ObjectName: PUnicodeString;
Attributes: ULONG;
SecurityDescriptor: PSecurityDescriptor;
SecurityQualityOfService: PSecurityQualityOfService;
end;
TFNZwOpenSection = function(out Section: THandle; Access: ACCESS_MASK;
Attributes: PObjectAttributes): NTSTATUS;
stdcall;
TFNRtlNtStatusToDosError = function(Status: NTSTATUS): DWORD;
stdcall;
const
PhysMemDevName = '\Device\PhysicalMemory';
PhysMemName: TUnicodeString = (Length: Length(PhysMemDevName) * SizeOf(WideChar);
MaximumLength: Length(PhysMemDevName) * SizeOf(WideChar) + SizeOf(WideChar);
Buffer: PhysMemDevName;
);
PhysMemMask: ACCESS_MASK = SECTION_MAP_READ;
PhysMemAttr: TObjectAttributes = (Length: SizeOf(TObjectAttributes);
RootDirectory: 0;
ObjectName: @PhysMemName;
Attributes: $00000040; // OBJ_CASE_INSENSITIVE
SecurityDescriptor: nil;
SecurityQualityOfService: nil;
);
var
ZwOpenSection: TFNZwOpenSection;
RtlNtStatusToDosError: TFNRtlNtStatusToDosError;
function DumpRomBiosNt(RomBase: Pointer; RomSize: Cardinal; var Dump): Boolean;
var
HMod: HMODULE;
Stat: NTSTATUS;
Sect: THandle;
View: Pointer;
begin
Result := False;
HMod := GetModuleHandle('ntdll.dll');
if HMod = 0 then
SetLastError(ERROR_CALL_NOT_IMPLEMENTED)
else
begin
if not Assigned(ZwOpenSection) then
ZwOpenSection := GetProcAddress(HMod, 'ZwOpenSection');
if not Assigned(RtlNtStatusToDosError) then
RtlNtStatusToDosError := GetProcAddress(HMod, 'RtlNtStatusToDosError');
if not Assigned(ZwOpenSection) or not Assigned(RtlNtStatusToDosError) then
SetLastError(ERROR_CALL_NOT_IMPLEMENTED)
else
begin
Stat := ZwOpenSection(Sect, PhysMemMask, @PhysMemAttr);
if Stat >= 0 then
try
View := MapViewOfFile(Sect, PhysMemMask, 0, Cardinal(RomBase), RomSize);
if View <> nil then
try
Move(View^, Dump, RomSize);
Result := True;
finally
UnmapViewOfFile(View);
end;
finally
CloseHandle(Sect);
end
else
SetLastError(RtlNtStatusToDosError(Stat));
end;
end;
end;
////////////////////////////////////////////////////////////////////////////////
//
// DumpRomBios(Ex)
//
// Public functions to call OS-dependent implementations.
//
function DumpRomBios(out Dump: TRomBiosDump;
Method: TRomDumpMethod = rdmAutomatic; Timeout: DWORD = 5000): Boolean;
begin
Result := DumpRomBiosEx(Pointer(RomBiosDumpBase), RomBiosDumpSize, Dump,
Method, Timeout);
end;
function DumpRomBiosEx(RomBase: Pointer; RomSize: Cardinal; out Dump;
Method: TRomDumpMethod = rdmAutomatic; Timeout: DWORD = 5000): Boolean;
begin
Result := False;
case Method of
rdmAutomatic:
if (GetVersion() and $80000000) <> 0 then
Result := DumpRomBios9x(RomBase, RomSize, Dump)
else
begin
Result := DumpRomBiosNt(RomBase, RomSize, Dump);
if not Result then
DumpRomBios16(RomBase, RomSize, Dump, DWORD(Timeout));
end;
rdmGeneric:
Result := DumpRomBios16(RomBase, RomSize, Dump, DWORD(Timeout));
rdmMemory:
Result := DumpRomBios9x(RomBase, RomSize, Dump);
rdmPhysical:
Result := DumpRomBiosNt(RomBase, RomSize, Dump);
else
SetLastError(ERROR_INVALID_PARAMETER);
end;
end;
////////////////////////////////////////////////////////////////////////////////
//
// ReadRomDumpBuffer(Ex) / GetRomDumpAddr(Ex)
//
// Utilities to simplify the access to dumps.
//
procedure ReadRomDumpBuffer(const Dump: TRomBiosDump; Addr: Pointer;
var Buffer; Size: Cardinal);
begin
Move(Dump[Cardinal(Addr)], Buffer, Size);
end;
procedure ReadRomDumpBufferEx(const Dump; Base, Addr: Pointer;
var Buffer; Size: Cardinal);
begin
Move(Pointer(Cardinal(@Dump) + Cardinal(Addr) - Cardinal(Base))^,
Buffer, Size);
end;
function GetRomDumpAddr(const Dump: TRomBiosDump; Addr: Pointer): Pointer;
begin
Result := @Dump[Cardinal(Addr)];
end;
function GetRomDumpAddrEx(const Dump; Base, Addr: Pointer): Pointer;
begin
Result := Pointer(Cardinal(@Dump) + Cardinal(Addr) - Cardinal(Base));
end;
end.
Как прочитать русский текст MS-DOS.
| - Почему не было Windows 96? - Очень похоже на 69. |
Для перекодировки из Win(1251) кодовой страницы в Dos(866) кодовую страницу и обратно используются функции:
CharToOEM OEMToChar CharToOEMBuff OEMToCharBuff OemToAnsi AnsiToOem:Пример чтения текста dos из файла в memo.
procedure TForm1.FormCreate(Sender: TObject);
var
N: PChar;
begin
memo1.Lines.LoadFromFile('c:\file.txt');
N := Memo1.Lines.GetText;
OemToAnsi(N, N);
Memo1.Lines.Text := StrPas(N);
end;
|
Как прочитать русский текст MS-DOS 2.
| Нам не заменят ДОС'а простоту заманчивые окны пополамов! |
procedure TForm1.FormCreate(Sender: TObject);
var
i, j: integer;
s: string;
c: set of char;
begin
c := ['А'..'Я', 'а'..'я'];
memo1.Lines.LoadFromFile('c:\11.txt');
for i:=0 to memo1.Lines.Count do
begin
s:=memo1.Lines.Strings[i];
for j:=1 to length(s) do
if chr(ord(S[j])+64) in c then
s[j]:=chr(ord(S[j])+64);
memo1.Lines.Strings[i]:=s;
end;
end;
|
Как прочитать русский текст MS-DOS 3.
| - У меня проблема с ДОСОМ! - Что, компьютер не запускается? - Нет. Дасморк. |
Один из вариантов кодировщика слегка громоздкий, но работает быстро, изменяя таблицу можно отключить пропуск непечатаемых символов.
const
ConvertSet: array[0..255] of byte =
{таблица перекодировки ASCII с альтернативной кодовой страницой 866 в
WIN 1251. Украинские символы - по кодовой таблице PRINTFXU. Непечатные
символы заменяются пробелами}
{основная таблица}
{ 00 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F }
{00} ( 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32,
{10} 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32,
{20} 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47,
{30} 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63,
{40} 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79,
{50} 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95,
{60} 96, 97, 98, 99,100,101,102,103,104,105,106,107,108,109,110,111,
{70} 112,113,114,115,116,117,118,119,120,121,122,123,124,125,126,127,
{дополнительная таблица}
{80} 192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,
{90} 208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,
{A0} 224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,
{B0} 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32,
{C0} 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32,
{B0} 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32,
{E0} 240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,
{F0} 168,184,178,179, 32, 32,175,191,170,186, 32,177,185, 32, 32, 32);
var
TextString : string[250];
TextTmpArr : array[0..250] of byte absolute TextString;
WinString : string[250];
WinTmpArr : array[0..250] of byte absolute WinString;
DosFile : Text;
TextFName : string;
TextFDir : string;
WinFName : string;
procedure TMainFm.ConvertFile;
var
I: Integer;
begin
AssignFile(DosFile,TextFName);
ReSet(DosFile);
while not(EOF(DosFile)) do
begin
ReadLn(DosFile,TextString);
WinTmpArr[0] := TextTmpArr[0];
for I := 1 to TextTmpArr[0] do
WinTmpArr[I] := ConvertSet[TextTmpArr[I]];
Memo.Lines.Add(WinString);
end;
end;
|
Как прочитать русский текст MS-DOS 4.
| "Компьютерщики" - это такие люди, у которых слова "вчера с матерью трахался" вызывают не возмущение, а сочувствие. |
function ConvertAnsiToOem(const S: string): string;
{ ConvertAnsiToOem translates a string into the OEM-defined character set }
{$IFNDEF WIN32}
var
Source, Dest : array[0..255] of Char;
{$ENDIF}
begin
{$IFDEF WIN32}
SetLength(Result, Length(S));
if Length(Result) > 0 then
AnsiToOem(PChar(S), PChar(Result));
{$ELSE}
if Length(Result) > 0 then
begin
AnsiToOem(StrPCopy(Source, S), Dest);
Result := StrPas(Dest);
end;
{$ENDIF}
end; { ConvertAnsiToOem }
function ConvertOemToAnsi(const S: string): string;
{ ConvertOemToAnsi translates a string from the OEM-defined
character set into either an ANSI or a wide-character string }
{$IFNDEF WIN32}
var
Source, Dest : array[0..255] of Char;
{$ENDIF}
begin
{$IFDEF WIN32}
SetLength(Result, Length(S));
if Length(Result) > 0 then
OemToAnsi(PChar(S), PChar(Result));
{$ELSE}
if Length(Result) > 0 then
begin
OemToAnsi(StrPCopy(Source, S), Dest);
Result := StrPas(Dest);
end;
{$ENDIF}
end; { ConvertOemToAnsi }
|
Считать строковые значения из ресурса.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
implementation
{$R *.DFM}
{$R test.res} //Your resource file
procedure TForm1.Button1Click(Sender: TObject);
var
buffer: array[0..255] of Char;
begin
Loadstring(hinstance, 1, @buffer, 255); //1 = first string
label1.Caption := StrPas(buffer);
end;
Запись и чтение чисел в Blob-поле.
| Автор: Ralph Friedman |
| Болтают трое молодых программистов о жизни. Двое холостых и один женатый. - Зря вы говорите, что жениться sux, вот я жене на домашнем компе права админа дал! |
Вы можете начать свое исследование со следующего модуля:
unit BlobFld;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, Buttons, DBTables, DB, ExtCtrls, DBCtrls,
Grids, DBGrids;
type
TFrmBlobFld = class(TForm)
BtnWrite: TBitBtn;
Table1: TTable;
DataSource1: TDataSource;
DBNavigator1: TDBNavigator;
LbxDisplayBlob: TListBox;
Table1pubid: TIntegerField;
Table1comments: TMemoField;
Table1UpdateTime: TTimeField;
Table1Real1: TFloatField;
Table1Real2: TFloatField;
Table1Real3: TFloatField;
Table1Curr1: TCurrencyField;
Table1Blobs: TBlobField;
Table1Bytes: TBytesField;
CbxRead: TCheckBox;
procedure BtnWriteClick(Sender: TObject);
procedure DataSource1DataChange(Sender: TObject; Field: TField);
procedure FormShow(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
{ Private-Deklarationen }
public
{ Public-Deklarationen }
end;
var
FrmBlobFld: TFrmBlobFld;
implementation
{$R *.DFM}
type
ADouble = array[1..12] of double;
PADouble = ^ADouble;
procedure TFrmBlobFld.BtnWriteClick(Sender: TObject);
var
i: integer;
myBlob: TBlobStream;
v: longint;
begin
Table1.Edit;
myBlob := TBlobStream.Create(Table1Blobs, bmReadWrite);
try
v := ComponentCount;
myBlob.Write(v, sizeof(longint));
for i := 0 to ComponentCount - 1 do
begin
v := Components[i].ComponentIndex;
myBlob.Write(v, sizeof(longint));
end;
finally
Table1.Post;
myBlob.Free;
end;
end;
procedure TFrmBlobFld.DataSource1DataChange(Sender: TObject; Field: TField);
var
i: integer;
myBlob: TBlobStream;
t: longint;
v: longint;
begin
if CbxRead.Checked then
begin
LbxDisplayBlob.Clear;
myBlob := TBlobStream.Create(Table1Blobs, bmRead);
try
myBlob.Read(t, sizeof(longint));
LbxDisplayBlob.Items.Add(IntToStr(t));
for i := 0 to t - 1 do
begin
myBlob.Read(v, sizeof(longint));
LbxDisplayBlob.Items.Add(IntToStr(v));
end;
finally
myBlob.Free;
end;
end;
end;
procedure TFrmBlobFld.FormShow(Sender: TObject);
begin
Table1.Open;
end;
procedure TFrmBlobFld.FormClose(Sender: TObject;
var Action: TCloseAction);
begin
Table1.Close;
end;
end.
|
Чтение и запись компонента.
Автор: Blake Вот участок кода из предстоящей статьи о VBX/OCX, который я написал чтобы протестировать поточность своих компонентов. Если компонент поточнен, код сможет его сохранить и загрузить. В противном случае вы получите сообщение об ошибке, отладка которой сравнительна легка для определении проблем с VCL.В действительности технология чтения и записи компонентов не так уж и сложна, убедитесь в этом сами.
procedure TForm1.StoreClick(Sender: TObject);
var
W: TWriter;
begin
W := TWriter.Create(
TFileStream.Create('c:\source\delphi\example.dob', fmCreate), 4096);
W.WriteSignature;
W.WriteComponent(Spin);
W.Free;
end;
procedure TForm1.LoadClick(Sender: TObject);
var
R: TReader;
begin
R := TReader.Create(
TFileStream.Create('c:\source\delphi\example.dob', fmOpenRead), 4096);
Spin := R.ReadRootComponent(nil) as TSpinner;
Spin.Top := 0;
Spin.Left := 0;
Spin.Parent := Self;
InsertComponent(Spin);
R.Free;
end;
|
Чтение и запись файлов.
1) Направление выходного потока вашей программы в файл. 2) Направление выходного потока вашей программы на принтер. 3) Чтение из входного файла. Направление выходного потока вашей программы в файл ...часто мои профессора, чтобы убедиться в моей честности и поверить в то, что программа создана моими руками, требуют ее полный листинг или упоминания обо мне в качестве одного из авторов. Далее они хотят, чтобы все генерируемые программой данные выводились в файл. Но как это сделать на Delphi или на простом Паскале???Просто в Delphi ....
program CrtApp; uses WinCrt; var outfile: TextFile; begin AssignFile(outfile, 'c:\outfile.txt'); Rewrite(outfile); writeln(outfile, 'Привет из Delphi'); writeln(outfile, 'Моя программа работает, и выводит ' + 'данный текст, чтобы доказать это...'); CloseFile(outfile); end. |
Просто в Паскале.....
Program HelloWorld; var outfile: text; begin assign(outfile, 'c:\output.txt'); rewrite(outfile); writeln(outfile, 'Здравствуй, мир'); writeln(outfile, 'Моя программа работает, и выводит данный текст, чтобы доказать это...'); close(outfile); end. |
В Delphi ...
program CrtApp; uses WinCrt; var outfile: TextFile; begin assignfile(outfile, 'LPT1'); rewrite(outfile); writeln(outfile, 'Привет из Delphi'); writeln(outfile, 'Моя программа работает, и выводит ' + 'данный текст, чтобы доказать это...'); closefile(outfile); end. |
В Паскале ...
Program HelloWorld; var outfile: text; begin assign(outfile, 'LPT1'); rewrite(outfile); writeln(outfile, 'Здравствуй, мир'); writeln(outfile, 'Моя программа работает, и выводит данный текст, чтобы доказать это...'); close(outfile); end. |
В Delphi ...
program CrtApp;
uses WinCrt;
var
infile, outfile: TextFile;
num_lines, x: integer;
line: string;
begin
assignfile(infile, 'C:\INFILE.TXT');
assignfile(outfile, 'C:\OUTFILE.TXT');
reset(infile); {перемещаем указатель}
{в начало файла.}
rewrite(outfile); {очищаем содержимое файла}
readln(infile, num_lines);
for x:= 1 to num_lines do
begin
readln(infile, line);
writeln(outfile, line);
end;
closefile(infile);
closefile(outfile);
end.
|
В Паскале ...
Program ReadInput;
var
infile, outfile: text;
num_lines, x: integer;
line: string;
begin
assign(infile, 'C:\INFILE.TXT');
assign(outfile, 'C:\OUTFILE.TXT');
reset(infile); {перемещаем указатель}
{в начало файла.}
rewrite(outfile); {очищаем содержимое файла}
readln(infile, num_lines);
for x:= 1 to num_lines do
begin
readln(infile, line);
writeln(outfile, line);
end;
close(infile);
close(outfile);
end.
|
{НАЧАЛО INFILE.TXT}
2
Здравствуй, мир
Моя программа работает, и этот текст доказательство этому.
{КОНЕЦ INFILE.TXT}
Для получения дополнительной информации обратитесь к Руководству Разработчика. Ознакомьтесь с описанием функций AssignFile, Assign, Reset, Rewrite, readln, writeln, Close, CloseFile.
Данный документ был написан автором под впечатлением просьбы умоляющего студента и чувством симпатии к нему, поскольку он сам недавно сидел на студенческой скамье..!!
Как читать-писать в I-O порты.
A := Port[20]; {чтение байта из порта 20}
Port[20] := A; {запись байта в порт 20}
B := PortW[20]; {чтение слова из порта 20-21}
PortW[20] := B; {запись слова в порт 20-21}
|
Запись и чтение из файла массива записей.
Это не очень Delphi-подобно (тем не менее, работа происходит с действительно паскалевскими записями), но вы можете писать и читать записи из/в файл, используя паскалевские процедуры для работы с файлами:
type
TMyRec = record ;
Field1: integer;
Field2: string;
end;
TMyRecArray = array[0..9] of TMyRec;
var
MyArray: TMyRecArray;
MyRec: TMyRec;
RecFile: file of TMyRec;
begin
{...здесь должен быть расположен код инициализации MyArray...}
AssignFile(RecFile, 'MYREC.FIL');
ReWrite(RecFile);
for i := 0 to 9 do
begin
Write(RecFile, MyRec[i]);
end;
CloseFile(RecFile);
end;
|
Если вы хотите делать это с Data Aware компонентами (компонентами для работы с базами данных), вы должны создать базу данных, где база данных "records" должна отражать структуру ваших паскалевских записей, при этом необходимо создать механизмы трансляции данных из одной среды в другую. Я не готов сейчас сказать вам, как это можно сделать, но, во всяком случае, всю функциональность можно инкапсулировать в отдельном специализированном компоненте.
Запись и чтение из файла массива записей 2.
type TR=Record
Name:string[100];
Age:Byte;
Income:Real;
end;
var f:file of TR;
r:TR;
begin
//assign file
assignFile(f, 'MyFileName');
//open file
if FileExists('MyFileName') then
reset(f)
else
rewrite(f);
//чтение 10й записи
seek(f,10);
read(f,r);
//запись 20й записи
seek(f, 20);
write(f,r);
closefile(f);
end;
|
Чтение и запись звука.
Автор: Даниил Карапетян WEB сайт: http://program.dax.ru Все функции чтения и записи звука я выделил в отдельный модуль. Он приведен после текста программы. При нажатии Button1 создается звуковой файл в памяти (то есть в памяти создается заголовок, затем идут данные - все точно так же, как в обычном wav-файле), сохраняется на диск и одновременно начинает воспроизводиться. Для этого используется функция playsound. Остановить воспроизведение можно кнопкой Button2. При нажатии Button3 открывается файл ex.wav (если Вы уже нажимали Button1, то он существует). Далее из файла считываются данные и для каждого канала находится средняя громкость. Не уверен, что это самый правильный способ, но здесь за громкость я взял просто среднее арифметическое. Результаты выводятся в заголовок окна. Для каждого канала выводится значение в процентах от максимально возможной громкости. Теперь о самой структуре данных. Она очень проста. Если канал один, то данные записаны подряд: первое значение, второе значение, третье значение ... Если же в файле два канала, то они чередуются: первое значение первого канала, первое значение второго канала, второе значение первого канала, второе значение второго канала, третье значение первого канала, третье значение второго канала, ... Если файл восьми битный, то каждое значение занимает 1 байт, если шестнадцати битный - 2 байта. Это соответствует типам shortint и smallint соответственно. В этой программе данные записываются при помощи процедуры GetData. SaveSound вызывает ее для каждого значения. В качестве параметров передаются канал и номер. А возвращаемое значение передается через нетипизированный параметр res. Такой подход позволяет избежать проблем с типами данных. При чтении все данные копируются в память, а затем находится сумма всех значений для каждого канала. При выводе громкости эти суммы делятся на максимально возможные суммы и умножаются на сто.Скачать все необходимые для компиляции файлы проекта можно на program.dax.ru.
uses MMSystem, wavfile;
procedure TForm1.Button1Click(Sender: TObject);
const
fr = 11025; {Частота в герцах}
len = 1; {Длина звука в секундах}
procedure GetData(ch: smallint; index: integer; var res);
var
v: smallint absolute res; // конечное значение
amp: single; // амплитуда
begin
if ch = 0
then amp := sin(index * 2 * Pi / (fr * len))
else amp := cos(index * 2 * Pi / (fr * len));
v := round(amp * (random(60000) - 30000));
end;
var
M: TMemoryStream; // поток для хранения информации в памяти
F: TFileStream; // Поток для созранения файла
begin
M := nil; F := nil;
try
M := TMemoryStream.Create;
randomize;
SaveSound(M {Куда записывать}, round(fr * len) {len секунд},
fr {частота}, 16 {16 бит}, 2 {2 каналла}, @GetData);
// Воспроизведение звука:
if not playsound(M.Memory, 0, SND_MEMORY or SND_LOOP or SND_ASYNC)
then ShowMessage('Can not play the sound');
F := TFileStream.Create('ex.wav', fmCreate);
M.Position := 0;
F.CopyFrom(M, M.Size);
finally
M.Free; F.Free;
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
playsound(nil, 0, 0); // Остановка воспроизведения
end;
procedure TForm1.Button3Click(Sender: TObject);
var
SampleCount, SamplesPerSec: integer;
BitsPerSample, Channeles: smallint;
F: TFileStream;
Volume: array [0..1] of single;
ToPercent: single;
buf: pointer;
buf8: ^shortint;
buf16: ^smallint;
i, ch: integer;
begin
F := nil; buf := nil;
try
Volume[0] := 0; Volume[1] := 0;
F := TFileStream.Create('ex.wav', fmOpenRead);
ReadWaveHeader(F, SampleCount, SamplesPerSec,
BitsPerSample, Channeles);
// Чтение данных:
GetMem(buf, SampleCount * Channeles * BitsPerSample);
F.Read(buf^, SampleCount * Channeles * BitsPerSample);
if BitsPerSample = 8 then begin
buf8 := buf;
for i := 0 to SampleCount - 1 do
for ch := 0 to Channeles - 1 do begin
Volume[ch] := Volume[ch] + abs(buf8^);
inc(buf8); // Переход к следующему элементу
end
end else begin
buf16 := buf;
for i := 0 to SampleCount - 1 do
for ch := 0 to Channeles - 1 do begin
Volume[ch] := Volume[ch] + abs(buf16^);
inc(buf16); // Переход к следующему элементу
end;
end;
// Вывод результатов:
ToPercent := (1 shl BitsPerSample) / 100 * SampleCount;
if Channeles = 1
then Form1.Caption := Format('volume: %2.2f%%',
[Volume[0] / ToPercent])
else Form1.Caption := Format('left: %2.2f%%, right: %2.2f%%',
[Volume[0] / ToPercent, Volume[1] / ToPercent]);
finally
F.Free;
FreeMem(buf);
end;
end;
--------------------------------------------------------------------------------
unit wavfile;
interface
uses classes, sysutils;
type
TWaveHeader = record
idRiff: array [0..3] of char;
RiffLen: longint;
idWave: array [0..3] of char;
idFmt: array [0..3] of char;
InfoLen: longint;
WaveType: smallint;
Ch: smallint;
Freq: longint;
BytesPerSec: longint;
align: smallint;
Bits: smallint;
end;
TDataHeader = record
idData: array [0..3] of char;
DataLen: longint;
end;
TGetData = procedure(ch: smallint; index: integer; var res);
TSetData = procedure(ch: smallint; index: integer; data: smallint);
procedure CreateWaveHeader(SampleCount, SamplesPerSec: integer;
BitsPerSample, Channeles: smallint; var WaveHeader: TWaveHeader;
var DataHeader: TDataHeader);
procedure ReadWaveHeader(Stream: TStream;
var SampleCount, SamplesPerSec: integer;
var BitsPerSample, Channeles: smallint);
procedure SaveSound(Stream: TStream; SampleCount, SamplesPerSec: integer;
BitsPerSample, Channeles: smallint; GetData: TGetData);
implementation
procedure Creat
BitsPerSample, Channeles: smallint; var WaveHeader: TWaveHeader;
var DataHeader: TDataHeader);
var
len: integer;
begin
if (SampleCount < 0) or (SamplesPerSec < 1) or
(not BitsPerSample in [8, 16]) or
(not Channeles in [1, 2])
then raise Exception.Create('Wrong params');
len := SampleCount * BitsPerSample div 8 * Channeles;
with WaveHeader do begin
idRiff := 'RIFF';
RiffLen := len + 38;
idWave := 'WAVE';
idFmt := 'fmt ';
InfoLen := 16;
WaveType := 1;
Ch := Channeles;
Freq := SamplesPerSec;
BytesPerSec := SamplesPerSec * BitsPerSample div 8 * Channeles;
align := Channeles * BitsPerSample div 8;
Bits := BitsPerSample;
end;
with DataHeader do begin
idData := 'data';
DataLen := len;
end;
end;
procedure ReadWaveHeader(Stream: TStream;
var SampleCount, SamplesPerSec: integer;
var BitsPerSample, Channeles: smallint);
var
WaveHeader: TWaveHeader;
DataHeader: TDataHeader;
begin
Stream.Read(WaveHeader, sizeof(TWaveHeader));
with WaveHeader do begin
if idRiff < > 'RIFF' then raise EReadError.Create('Wrong idRIFF');
if idWave < > 'WAVE' then raise EReadError.Create('Wrong idWAVE');
if idFmt < > 'fmt ' then raise EReadError.Create('Wrong idFmt');
if WaveType < > 1 then raise EReadError.Create('Unknown format');
Channeles := Ch;
SamplesPerSec := Freq;
BitsPerSample := Bits;
Stream.Seek(InfoLen - 16, soFromCurrent);
end;
Stream.Read(DataHeader, sizeof(TDataHeader));
if DataHeader.idData = 'fact' then begin
Stream.Seek(4, soFromCurrent);
Stream.Read(DataHeader, sizeof(TDataHeader));
end;
with DataHeader do begin
if idData < > 'data' then raise EReadError.Create('Wrong idData');
SampleCount := DataLen div (Channeles * BitsPerSample div 8)
end;
end;
procedure SaveSound(Stream: TStream; SampleCount, SamplesPerSec: integer;
BitsPerSample, Channeles: smallint; GetData: TGetData);
var
WaveHeader: TWaveHeader;
DataHeader: TDataHeader;
buf: smallint;
BytesPerSample: smallint;
i: integer;
begin
CreateWaveHeader(SampleCount, SamplesPerSec, BitsPerSample,
Channeles, WaveHeader, DataHeader);
Stream.Write(WaveHeader, sizeof(TWaveHeader));
Stream.Write(DataHeader, sizeof(TDataHeader));
BytesPerSample := BitsPerSample div 8;
if Channeles = 1
then
for i := 0 to SampleCount - 1 do begin
GetData(0, i, buf);
Stream.Write(buf, BytesPerSample);
end
else
for i := 0 to SampleCount - 1 do begin
GetData(0, i, buf);
Stream.Write(buf, BytesPerSample);
GetData(1, i, buf);
Stream.Write(buf, BytesPerSample);
end;
end;
end.
|
Скопировать строку в Буфер и прочитать её.
| По понятиям "чайников" -- "кофейники" просто ламеры... |
uses
ClipBrd;
procedure StrToClipbrd(StrValue: string);
var
S: string;
hMem: THandle;
pMem: PChar;
begin
hMem := GlobalAlloc(GHND or GMEM_SHARE, Length(StrValue) + 1);
if hMem <> 0 then
begin
pMem := GlobalLock(hMem);
if pMem <> nil then
begin
StrPCopy(pMem, StrValue);
GlobalUnlock(hMem);
if OpenClipboard(0) then
begin
EmptyClipboard;
SetClipboardData(CF_TEXT, hMem);
CloseClipboard;
end
else
GlobalFree(hMem);
end
else
GlobalFree(hMem);
end;
end;
function GetStrFromClipbrd: string;
begin
if Clipboard.HasFormat(CF_TEXT) then
Result := Clipboard.AsText
else
begin
ShowMessage('There is no text in the Clipboard!');
Result := '';
end;
end;
// write "Hallo" to the clipboard and read it back.
procedure TForm1.Button1Click(Sender: TObject);
begin
StrToClipbrd('Hallo');
ShowMessage(GetStrFromClipbrd);
end;
|
Реализация событий COM+ в среде Delphi.
Введение
Обработка событий является одним из ключевых моментов в COM. Существует масса программ, для нормального функционирования которых требуется поддержка событий.
GUI пользователя должен уметь обрабатывать различное количество событий, например, таких как: нажатие на кнопку мыши, перемещение мыши по экрану и т.д. Приблизительно так же может возникнуть потребность обрабатывать события внутри объектов COM. В данной статье мы рассмотрим принцип работы свободно связанных событий и создадим наглядное приложение для демонстрации использования такого типа событий в COM+. (Для более детальной информации о события в COM+ смотрите статью А.Новика «Система поддержки событий COM+» на сайте журнала «Клиент-Сервер»).
Что такое свободно связанные события? Понятие «Издатель-Подписчик»
До появления COM+, модель COM поддерживала систему событий, реализованную через интерфейс IConnectionPointContainer. Это жестко связанные события. (В данной статье, мы не будем рассматривать реализацию этого подхода). В COM+ появилось новое понятие: СВОБОДНО СВЯЗАННЫЕ СОБЫТИЯ (Loosely coupled events - LCE), разработанные для удовлетворения потребностей распределенных вычислений.
В COM+ Инициатор события (Издатель) и потребитель (Подписчик) свободно связаны.
Информация от различных издателей хранится в каталоге COM+, а подписчики указывают, какую информацию они хотят получать, регистрируясь в каталоге.
Архитектура событий в COM+
Для реализации свободно связанных событий вы должны создать компонент EventClass, который будет зарегистрирован в каталоге COM+. Подписчики вызываются объектом события, который определяет и активизирует объекты, подписанные на него.
Следует различать виды подписки. Существует временная и постоянная подписки:
Временная подписка (transient) создается средствами административного API. Для более детальной информации можно обратиться в MSDN. Управлять жизненным циклом такой подписки нужно программными средствами. А не средствами ComponentServices. Постоянная подписка (persistent) создается средствами ComponentServices. Такая подписка в состоянии пережить перезапуск системы.Фильтрация существует только в системе COM+. Такой возможности нет в системе жестко связанных событий. Её суть мы рассмотрим дальше, при более детальном изучении примера.
Пример реализации компонента EventClass
Допустим, у нас существует задача на базе существующей системы, функционирующей в среде COM+, реализовать систему ведения собственно журнала событий в текстовом файле. Для начала нам нужно реализовать компонент EventClass, о котором речь шла выше. Он будет представлять собой пустую заглушку для подписчика. Именно через него будут запускаться наши подписчики в каталоге COM+.
Когда компонент-издатель будет создавать событие, компонент EventClass передаст все входящие параметры события и активизирует всех подписчиков.
Важно! Метод события может содержать только входные параметры [in]. Выходным может быть только результирующий тип HRESULT, принятый в COM для определения статуса завершения S_OK, в результате удачи или E_FAIL, в результате неудачи выполнения метода.
Запустим среду Delphi, создадим простую ActiveX библиотеку и поместим в неё объект автоматизации (Automation Object). Определим нумератор типов ошибок и создадим интерфейс ISysLogEvent с методом ReportLog.
type
LogMessageTypes = TOleEnum;
const
lmtInformation = $00000000;
lmtWarning = $00000001;
lmtError = $00000002;
lmtFatal = $00000003;
lmtDebug = $00000004;
lmtUnknown = $00000005;
type
TSysLogEvent = class(TAutoObject, ISysLogEvent)
protected
{ Protected declarations }
procedure ReportLog(enMsgType: LogMessageTypes; const strUserName,
strModuleName, strMsgText: WideString); safecall;
end;
|
В разделе Implementation создадим заглушку метода для EventClass:
implementation uses ComServ; procedure TSysLogEvent.ReportLog(enMsgType: LogMessageTypes; const strUserName, strModuleName, strMsgText: WideString); begin // Event class methods are not implemented. end; initialization TAutoObjectFactory.Create(ComServer, TSysLogEvent, Class_SysLogEvent, ciMultiInstance, tmApartment); end. |
На этом закончим. Остается зарегистрировать заглушку в нашем приложении COM+. Если приложение не создано, создайте его через средства ComponentServices.
Пример реализации Объекта-подписчика
После регистрации компонента EventClass создадим компонент-подписчик:
Точно так же, как при создании компонента EventClass создадим библиотеку и объект автоматизации. Немного будет отличаться наполнение реализации методов и метод регистрации. Создадим интерфейс с методом, аналогичным методу интерфейса ILogEvent – ISysLogВажно! Не забудьте подключить в вашу библиотеку типов зарегистрированную в ComponentServices библиотеку с заглушкой EventClass и укажите интерфейс ISysLogEvent в разделе Implements.
Ниже приведен код компоненты подписчика, который будет получать события от издателя. Из реализации бизнес-логики видно, что при возникновении метода-события ReportLog, компонент-подписчик будет выдавать диалоговое окно с информацией для записи в журнал. Если вы замените реализацию этого метода программным кодом записи в файл, вы получите готовый компонент для регистрации ваших событий в бизнес объекте (вывода информации, сообщений об ошибках, отладке и т.д.).
unit SysLogUnit;
interface
uses
ComObj, ActiveX, SystemLogger_TLB, StdVcl, LogEvent_TLB, Dialogs;
type
TSysLog = class(TAutoObject, ISysLog, ISysLogEvent)
protected
{ Protected declarations }
procedure ReportLog(enMsgType: LogMessageTypes; const strUserName,
strModuleName, strMsgText: WideString); safecall;
end;
implementation
uses
ComServ, SysUtils;
procedure TSysLog.ReportLog(enMsgType: LogMessageTypes; const strUserName,
strModuleName, strMsgText: WideString);
begin
ShowMessage('MessageType : '+IntToStr(enMsgtype)+#10#13+
'ModuleName : '+strModuleName+#10#13+
'UserName : '+strUserName+#10#13+
'TextMessage : '+strMsgText);
end;
initialization
TAutoObjectFactory.Create(ComServer, TSysLog, Class_SysLog,
ciMultiInstance, tmApartment);
end.
|
Зарегистрируйте компонент в каталоге COM+ и подпишите его к компоненту EventClass.
Далее следуйте инструкциям визарда.
Итак, у вас на компьютере установлены объекты EventClass и подписчик.
Пример реализации методов издателя
Создадим простенькое приложение и проверим существующею связку. Создайте бизнес-объект COM+ инициирующий в любом своем методе метод-событие ReportLog.
Пример реализации объекта приведен ниже:
unit BsObjectUnit;
interface
uses
ComObj, ActiveX, BsObject_TLB, StdVcl, LogEvent_TLB;
type
TBusinessObject = class(TAutoObject, IBusinessObject)
protected
{ Protected declarations }
function NewObject(param1: Integer): HResult; safecall;
end;
implementation
uses
ComServ;
function TBusinessObject.NewObject(param1: Integer): HResult;
var
LogEvent: ISysLogEvent;
begin
LogEvent := CoSysLogEvent.Create;
try
LogEvent.ReportLog(lmtInformation, 'Nonamed', 'BsObjectUnit',
'TBusinessObject.NewObject executed!')
except
LogEvent.ReportLog(lmtInformation, 'Nonamed', 'BsObjectUnit',
'TBusinessObject.NewObject failed!')
end;
end;
initialization
TAutoObjectFactory.Create(ComServer, TBusinessObject,
Class_BusinessObject, ciMultiInstance, tmApartment);
end.
|
После вызова метода NewObject у объекта BusinessObject будет создано событие, которое создаст объект SysLog и запишет и отобразит информацию в диалоговом окне. Подписчиков у созданного объекта EventClass может быть неограниченное количество с самыми разнообразными функциями, от отображения диалогового окна до записи данных в отдельную БД.
Фильтры
Механизм фильтрации подписчиков использует строку условия фильтрации, являющуюся свойством подписки. Такая фильтрация выполняется для каждого метода и каждой подписки. Вы можете использовать строку, используя имена параметров из библиотеки типов. Можно использовать так же стандартные операции отношения, вложенные скобки и ключевые слова AND, OR, NOT. Строка может быть определена с помощью средств ComponentServices или средств административного API.
Сравнение чисел с плавающей точкой.
Автор: Олег Кулабухов У меня два числа с плавающей запятой неправильно сравниваются! Задаю if d1=d2 ..., или if d1<>d2, а результат иногда неверный. В чем дело? Это баг Дельфи? Нет. Просто в отличие от целочисленных IEEE числа с плавающей запятой являются приблизительными значениями и вы не должны использовать = или <> для сравнивания двух чисел такого типа. Вместо этого вычтите из одного числа другое и сравните разницу с очень малой величиной.Например.
if abs(d1-d2) < 0.00001 then
ShowMessage('D1 и D2 равны');
|
Окно в виде кольца с изогнутой заголовочной полосой.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, Buttons, StdCtrls;
type
TForm1 = class(TForm)
SpeedButton1: TSpeedButton;
Button1: TButton;
procedure FormCreate(Sender: TObject);
procedure FormPaint(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
rTitleBar : THandle;
Center : TPoint;
CapY : Integer;
Circum : Double;
SB1 : TSpeedButton;
RL, RR : Double;
procedure TitleBar(Act : Boolean);
procedure WMNCHITTEST(var Msg: TWMNCHitTest); message WM_NCHITTEST;
procedure WMNCACTIVATE(var Msg: TWMNCACTIVATE); message WM_NCACTIVATE;
procedure WMSetText(var Msg: TWMSetText); message WM_SETTEXT;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
const
TitlColors : array[Boolean] of TColor = (clInactiveCaption, clActiveCaption);
TxtColors : array[Boolean] of TColor = (clInactiveCaptionText, clCaptionText);
procedure TForm1.FormCreate(Sender: TObject);
var
rTemp, rTemp2 : THandle;
Vertices : array[0..2] of TPoint;
X, Y : INteger;
begin
Caption := 'Delphi World is great!';
BorderStyle := bsNone; {required}
if Width > Height then
Width := Height
else
Height := Width; {harder to calc if width <> height}
Center := Point(Width div 2, Height div 2);
CapY := GetSystemMetrics(SM_CYCAPTION)+8;
rTemp := CreateEllipticRgn(0, 0, Width, Height);
rTemp2 := CreateEllipticRgn((Width div 4), (Height div 4),
3*(Width div 4), 3*(Height div 4));
CombineRgn(rTemp, rTemp, rTemp2, RGN_DIFF);
SetWindowRgn(Handle, rTemp, True);
DeleteObject(rTemp2);
rTitleBar := CreateEllipticRgn(4, 4, Width-4, Height-4);
rTemp := CreateEllipticRgn(CapY, CapY, Width-CapY, Height-CapY);
CombineRgn(rTitleBar, rTitleBar, rTemp, RGN_DIFF);
Vertices[0] := Point(0,0);
Vertices[1] := Point(Width, 0);
Vertices[2] := Point(Width div 2, Height div 2);
rTemp := CreatePolygonRgn(Vertices, 3, ALTERNATE);
CombineRgn(rTitleBar, rTitleBar, rTemp, RGN_AND);
DeleteObject(rTemp);
RL := ArcTan(Width / Height);
RR := -RL + (22 / Center.X);
X := Center.X-Round((Center.X-1-(CapY div 2))*Sin(RR));
Y := Center.Y-Round((Center.Y-1-(CapY div 2))*Cos(RR));
SB1 := TSpeedButton.Create(Self);
with SB1 do
begin
Parent := Self;
Left := X;
Top := Y;
Width := 14;
Height := 14;
OnClick := Button1Click;
Caption := 'X';
Font.Style := [fsBold];
end;
end;
procedure TForm1.WMNCHITTEST(var Msg: TWMNCHitTest);
begin
inherited;
with Msg do
with ScreenToClient(Point(XPos,YPos)) do
if PtInRegion(rTitleBar, X, Y) and
(not PtInRect(SB1.BoundsRect, Point(X,Y))) then
Result := htCaption;
end;
procedure TForm1.WMNCActivate(var Msg: TWMncActivate);
begin
inherited;
TitleBar(Msg.Active);
end;
procedure TForm1.WMSetText(var Msg: TWMSetText);
begin
inherited;
TitleBar(Active);
end;
procedure TForm1.TitleBar(Act: Boolean);
var
TF : TLogFont;
R : Double;
N, X, Y : Integer;
begin
if Center.X = 0 then
Exit;
with Canvas do
begin
Brush.Style := bsSolid;
Brush.Color := TitlColors[Act];
PaintRgn(Handle, rTitleBar);
R := RL;
Brush.Color := TitlColors[Act];
Font.name := 'Arial';
Font.Size := 12;
Font.Color := TxtColors[Act];
Font.Style := [fsBold];
GetObject(Font.Handle, SizeOf(TLogFont), @TF);
for N := 1 to Length(Caption) do
begin
X := Center.X-Round((Center.X-6)*Sin(R));
Y := Center.Y-Round((Center.Y-6)*Cos(R));
TF.lfEscapement := Round(R * 1800 / pi);
Font.Handle := CreateFontIndirect(TF);
TextOut(X, Y, Caption[N]);
R := R - (((TextWidth(Caption[N]))+2) / Center.X);
if R then
Break;
end;
Font.name := 'MS Sans Serif';
Font.Size := 8;
Font.Color := clWindowText;
Font.Style := [];
end;
end;
procedure TForm1.FormPaint(Sender: TObject);
begin
with Canvas do
begin
Pen.Color := clBlack;
Brush.Style := bsClear;
Pen.Width := 1;
Pen.Color := clWhite;
Arc(1, 1, Width-1, Height-1, Width, 0, 0, Height);
Arc((Width div 4)-1, (Height div 4)-1,
3*(Width div 4)+1, 3*(Height div 4)+1, 0, Height, Width, 0);
Pen.Color := clBlack;
Arc(1, 1, Width-1, Height-1, 0, Height, Width, 0);
Arc((Width div 4)-1, (Height div 4)-1,
3*(Width div 4)+1, 3*(Height div 4)+1, Width, 0, 0, Height);
TitleBar(Active);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Close;
end;
end.
|
Преобразование дробной и целой части REAL-числа в два целых.
Я написал программу, которая делает это. Это DOS-программа. Вы вызываете ее с десятичным числом, передаваемым в качестве параметра. После чего программка выведет 3 колонки, в первой будет находиться исходное число, две остальные будут содержать числитель и знаменатель. Вы можете преобразовать программу в функцию и применять ее в своих приложениях, но, думаю, это несложно, и с этим вы справитесь сами. Для ее запуска достаточно в подсказке DOS набрать ее имя и число:CONTFRAC 3.141592654
program contfrac; { непрерывные дроби }
{$N+}
const
order = 20;
var
y, lasterr, error, x: extended;
a: array[0..order] of longint;
i, j, n: integer;
op, p, q: longint;
begin
lasterr := 1E30;
val(paramstr(1), y, n);
if n <> 0 then
halt;
x := y;
a[0] := trunc(x);
writeln;
writeln(a[0]: 20, a[0]: 14, 1: 14);
{ это может вызвать резкую головную боль и галлюцинации }
for i := 1 to order do
begin
x := 1.0 / frac(x);
a[i] := trunc(x);
p := 1;
q := a[i];
for j := pred(i) downto 0 do
begin
op := p;
p := q;
q := a[j] * q + op;
end;
error := abs(y - int(q) / int(p));
if abs(error) >= abs(lasterr) then
halt;
writeln(a[i]: 20, q: 14, p: 14, error: 10);
if error < 1E-18 then
halt;
lasterr := error;
end;
end.
|
valA := (val div 100);
valB := (valA - val); or valB := (valA - val) * 100;
val = 23.56
ValA = 23
ValB = .56 or 56
Как завершить сеанс работы или перезагрузить Windows NT.
Для этого нам потребуются определённые привелегии:
function SetPrivilege(aPrivilegeName: string;
aEnabled: boolean): boolean;
var
TPPrev,
TP: TTokenPrivileges;
Token: THandle;
dwRetLen: DWord;
begin
Result := False;
OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES
or TOKEN_QUERY, @Token);
TP.PrivilegeCount := 1;
if (LookupPrivilegeValue(nil, PChar(aPrivilegeName),
TP.Privileges[0].LUID)) then
begin
if (aEnabled) then
TP.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED
else
TP.Privileges[0].Attributes := 0;
dwRetLen := 0;
Result := AdjustTokenPrivileges(Token, False, TP,
SizeOf(TPPrev),
TPPrev, dwRetLen);
end;
CloseHandle(Token);
end;
function WinExit(iFlags: integer): boolean;
// возможные флаги:
// EWX_LOGOFF
// EWX_REBOOT
// EWX_SHUTDOWN
begin
Result := True;
if (SetPrivilege('SeShutdownPrivilege', true)) then
begin
if (not ExitWindowsEx(iFlags, 0)) then
begin
Result := False;
end;
SetPrivilege('SeShutdownPrivilege', False)
end
else
begin
Result := False;
end;
end;
|
Сколько времени прошло с момента перезагрузки.
Автор: Павел Чтобы определить сколько времени прошло с момента последней перезагрузки системы необходимо воспользоваться функцией GetCurrentTime: LongInt; Возвращаемое значение: время в миллисекундах.Пример использования:
Edit1.Text := FloatToStr(GetCurrentTime / 1000) + ' секунд с момента перезагрузки';
Как пересчитать все вычисляемые поля (Calculated fields) без переоткрытия TDataSet.
Автор: Nomadic.
Resync( [rmExact, rmCenter] ); |
RecCount в таблицах ASCII.
Автор: Mark Edington В Delphi 1.0 для получения количества записей в ASCII файле (.TXT- и .SCH-файлы) я пользовался свойством RecordCount компонента TTable. В Delphi 2.0 эта функциональность не поддерживается! Я прав или не прав? Во всяком случае как мне получить количество записей, содержащихся в ASCII таблице? В Delphi 2.0, свойство RecordCount отображается на недокументированную функцию BDE DbiGetExactRecordCount. Данное изменение было сделано для обеспечения правильных величин при работе с "живыми" запросами. Очевидно, данное API по какой-то причине не поддерживает текстовые файлы.Вы можете обойти эту проблему, вызывая функцию API BDE DbiGetRecordCount напрямую (добавьте BDE к списку используемых модулей):
procedure TForm1.FormKeyUp(Sender: TObject; var Key: Word; var RecCount: Integer; begin Check(DbiGetRecordCount(Table1.Handle, RecCount); end; |
Недавно использовавшиеся файлы в главном меню.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{
Die folgende Unit enthalt eine Klasse, die eine
RecentListe in ein TMainMenu einfugt.
}
{
This unit contains a class to add a
RecentList in a TMainMenu.
}
unit UnitRecentList;
interface
uses Windows, SysUtils, menus, Registry, Forms, Dialogs, Classes;
type
TOnClickPorc = procedure(Path : string) of object;
type
TRecentList = class(TObject)
private
Regis: TRegistryIniFile;
Count: integer;
Parent: TForm;
MainMenu: TMainMenu;
Items: TStringList;
AddPos: integer;
ClickProc: TOnClickPorc;
Ident: integer;
public
// Key : Porduktname zum Beispiel "SuperSoftware"
// Count : Anzahl der angezeigten MenuItems
// MainMenu : Das MainMenu auf dem Formular in dem angezeigt werden soll
// Parent : Das Parent Formular vom MainMenu (z.B. Form1)
// Proc : Prozedur, die ausgefurt werden soll, wenn auf ein MenuItem geklickt wird.
// z. B. "Procedure TForm1.RecentListClick(FileName : string);"
constructor Create(Key : string; Count, MenuIndex : integer;
MainMenu : TMainMenu; Parent : TForm;
Proc : TOnClickPorc);
destructor Destroy; override;
procedure CustomItemAdd(Value : string);
procedure ItemsToMenu;
procedure ItemClick(Sender : TObject);
end;
implementation
constructor TRecentList.Create(Key : string; Count, MenuIndex : integer;
MainMenu : TMainMenu; Parent : TForm;
Proc : TOnClickPorc);
var
I : integer;
NewItem : TMenuItem;
begin
// Initialisieren
Items := TStringList.Create;
// Klasseneigenschaften setzen
Self.Count := Count;
Self.Parent := Parent;
Self.MainMenu := MainMenu;
Self.Ident := MenuIndex;
AddPos := MainMenu.Items[Ident].Count + 1;
// Ubergebene Prozedur gleich der der lokalen "ClickPorc" setzen
ClickProc := Proc;
// TRegistryIniFile instanzieren
Regis := TRegistryIniFile.Create('Software\' + Key);
// Trennstrisch realisieren
NewItem := TMenuItem.Create(Parent);
NewItem.Caption := '-';
MainMenu.Items[Ident].Add(NewItem);
// uber Schliefe alles einlesen
for i := 0 to Count - 1 do CustomItemAdd(Regis.ReadString('RecentFiles',
'Item' + IntToStr(i) + IntToStr(Ident), ''));
end;
procedure TRecentList.ItemsToMenu;
var
NewItem : TMenuItem;
I : integer;
begin
// Beim ersten mal "count" MenuItems erstellen
if MainMenu.Items[Ident].Count = AddPos then
for i := 0 to Count - 1 do
begin
NewItem := TMenuItem.Create(Parent);
NewItem.Caption := '';
NewItem.OnClick := ItemClick;
MainMenu.Items[Ident].Add(NewItem);
end;
// Die Liste "Items" duchgehen und die MenuItems danach benennen
for I := 0 to Items.Count - 1 do
MainMenu.Items[Ident][i + AddPos].Caption := Items[i];
// Dei leeren Eintrage unsichtbar machen die vollen sichtbar
for I := 0 to Count - 1 do
MainMenu.Items[Ident][i + AddPos].Visible :=
not (MainMenu.Items[Ident][i + AddPos].Caption = '');
if Items.Count = 0 then MainMenu.Items[Ident][AddPos - 1].Visible := False
else
MainMenu.Items[Ident][AddPos - 1].Visible := True;
end;
procedure TRecentList.ItemClick(Sender : TObject);
begin
ClickProc((Sender as TMenuItem).Caption);
end;
procedure TRecentlIst.CustomItemAdd(Value : string);
var
i : integer;
begin
// Prufen
if Length(Value) = 0 then
begin
ItemsToMenu;
Exit;
end;
// Testen, ob "Value" schon vorkommt
for i := 0 to Items.Count - 1 do
if (Items[i] = Value) then
begin
Items.Delete(i);
Break;
end;
// Items.Delete(i);
// Eintrag anhangen
Items.Insert(0, Value);
// Wenn Liste voll, dann letztes rausschmeissen
if Items.Count > Count then
begin
//For i := 1 to Items.Count - 1 do Items[ i - 1 ] := Items[ i ];
Items.Delete(Items.Count - 1);
end;
// Anzeige aktuallisieren
ItemsToMenu;
end;
// FreeAndNil(TRecentList) bei OnClose nicht vergessen
destructor TRecentList.Destroy;
var
i : integer;
begin
// DAten in der Registry speichern
for i := 0 to Items.Count - 1 do
Regis.WriteString('RecentFiles', 'Item' + IntToStr(I) + IntToStr(Ident), Items[i]);
// Speicherleichen ausradieren
Regis.Free;
end;
end.
{ Und so instanziert man die Klasse: }
// Createn
// 1. Parameter : Registry Schlussel
// 2. Parameter : Anzal der Eintrage in der RecentList
// 3. Parameter : Nummer des MenuItems unter das die RecentList kommen soll (meistens 0)
// 4. Parameter : Das Menu, in die die Recentlist eingefugt werden soll
// 5. Parameter : Das Formular, in dem sich das Menu befindet
// 6. Parameter : Die Procedure, die ausgefuhrt werden soll, wenn auf einen Eintrag
// in der Recentlist gecklickt wird.
procedure TForm1.FormCreate(Sender: TObject);
begin
RecentList.Create('SuperSoftware', 5, 0, MainMenu1, Self, Click);
end;
// Die Procedure wird ausgefuhrt, wenn auf einen Eintrag in der
// RecentList gecklickt wird.
// "Value" ist der Dateiname
procedure TForm1.Click(FilePath: string );
begin
DateiOeffnen(FilePath);
end;
// Einen Eintrag in die Rechenlist vorhehmen
procedure TForm1.Button1Click(Sender: TObject);
begin
RecentList.CustomItemAdd(Edit1.Text);
end;
// nicht vergessen, sonst werden die Anderungen nicht gespeichert
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
FreeAndNil(RecentList);
end;
// von Sven Laufersweiler & Phillip Kroll
Получение имени обработчика события.
Имеется возможность получить значение указателя на обработчик события, который вы можете сравнить по адресу с другими методами, чтобы вычислить тот, которому передается данное событие:
procedure TForm1.Button3Click(Sender: TObject);
var
P: record case Integer of
1: (E: TNotifyEvent);
2: (P: Pointer);
end;
begin
P.E := Button1.OnClick;
Panel1.Caption := 'Обработчик события = ' + MethodName(P.P);
ShowMessage(Format('%p', [P.P]));
end;
|
Как получить номер записи в dBASE или Paradox.
| Попали в одну камеру разбойник и хакер. Разбойник: - Я вот сижу за ограбление магазина... А ты за что сидишь? Хакер: - Ограбил банк на 7 миллионов долларов... Разбойник: - Да ты че... ни фига себе.. как же ты унес их из банка - денег-то офигенно много? Хакер рассказывает в общих чертах о компьютерах, сетях, взломах и т. д. Разбойник: - Ну ни фига себе, а как же ты попался? Хакер: - Брандмауэр засек и сработала защита.. Разбойник: - Ах ты... Брандмауэр, твою мать... Всегда знал, что евреев опасаться надо... |
function FindRecordNumber (aDataSet : TDataSet): longint;
var
cP: CurProps;
rP: RECProps;
DBRes: DBiResult;
begin
{Return 0 if dataset is not Paradox or dBase}
Result := 0;
with aDataset do
begin
if state = dsInactive then exit;
{we need to make this call to grab the cursor's iSeqNums}
DBRes := DBiGetCursorProps(Handle,cP);
if DBRes <> DBIERR_NONE then exit;
{synchronize the BDE cursor with the dataset's cursor}
UpdateCursorPos;
{fill rP with the current record's properties}
DBRes := DBiGetRecord(Handle,DBiNOLOCK,nil,@rP);
if DBRes <> DBIERR_NONE then exit;
{what kind of dataset are we looking at?}
case cP.iSeqNums of
0: result := rP.iPhyRecNum; {dBase}
1: result := rP.iSeqNum; {Paradox}
end;
end;
end;
|
Запись RecNo из RecordCount.
Автор: Mike Downey ...какой метод вовращает номер текущей записи? (т.е.: Я хочу использовать это вместе с функцией RecordCount и выводить для пользователя в строке состояния нечто вроде: "Запись #n из x")Вот функция, возвращающая номер текущей записи в наборе данных DataSet. В основном я все скопировал и расставил комментарии, которые теперь лишают меня возможности поговорить на эту тему. Могли бы вы получить эти цифирьки из DBIPROCS.INT?
function RecordNumber(Dataset: TDataset): Longint;
var
CursorProps: CurProps;
RecordProps: RECProps;
begin
{ Возвращаем 0, если набор данных не Paradox или dBASE }
Result := 0;
with Dataset do
begin
{ Набор данных активен? }
if State = dsInactive then
DBError(SDataSetClosed);
{ Нам необходимо сделать этот вызов, чтобы "захватить" курсор iSeqNums }
Check(DbiGetCursorProps(Handle, CursorProps));
{ Синхронизируем курсор BDE с курсором набора данных }
UpdateCursorPos;
{ Заполняем RecordProps текущими свойствами записи }
Check(DbiGetRecord(Handle, dbiNOLOCK, nil, @RecordProps));
{ С каким типом набора данных мы работаем? }
case CursorProps.iSeqNums of
0: Result := RecordProps.iPhyRecNum; { dBASE }
1: Result := RecordProps.iSeqNum; { Paradox }
end; { case }
end; { with }
end; { function }
|
Затем, в обработчике события OnDataChange DataSet, я использовал команду:
MyTextVariable := 'Запись ' + IntToStr( RecordNumber( tImport ) ) + ' из ' + IntToStr( tImport.RecordCount ) ; |
Перекодирование.
Этот алгоритм позволяет перекодировать текст. Реализованы кодировки Windows-1251, KOI8-R, ISO-8859-5 и DOS. Кодировка – это таблица, в которой указано, например, что символ под номером 160 - это русская буква "а", а под номером 150 – "Ц" и т. д. Кодировки различаются номерами русских букв (как располагать английские буквы договорились). Разные компьютеры в Интернете используют разные кодировки. И поэтому, когда русский текст идет по Интернету, его многократно перекодируют.Этот алгоритм обеспечивает высокую скорость перекодирования больших объемов данных.
procedure TForm1.Button1Click(Sender: TObject);
var
code1, code2: TCode;
s: string;
c: char;
i: integer;
chars: array [char] of char;
str: array [TCode] of string;
begin
case ComboBox1.ItemIndex of
1: code1 := koi;
2: code1 := iso;
3: code1 := dos;
else code1 := win;
end;
case ComboBox2.ItemIndex of
1: code2 := koi;
2: code2 := iso;
3: code2 := dos;
else code2 := win;
end;
s := Memo1.Text;
Str[win] := 'АаБбВвГгДдЕеЖжЗзИиЙйКкЛлМмНнОоПпРрСсТтУуФфХхЦцЧчШшЩщЪъЫыЬьЭэЮюЯя';
Str[koi] := 'юЮаАбБцЦдДеЕфФгГхХиИйЙкКлЛмМнНоОпПяЯрРсСтТуУжЖвВьЬыЫзЗшШэЭщЩчЧъЪ';
Str[iso] := 'РрСсТтУуФфХхЦцЧчШшЩщЪъЫыЬьЭэЮюЯяа¹б¸в?гƒдºе¾ж³з¿и¼йšкœлžм?н§о¢пŸ';
Str[dos] := '€ ?¡‚¢ƒ£„¤…¥†¦‡§ˆ¨‰©Šª‹"Œ¬?Ž®?¯?а'б'в“г”д•е–ж—з˜и™йšк›лœм?нžоŸп';
for c := #0 to #255 do
Chars[c] := c;
for i := 1 to Length(Str[win]) do
Chars[Str[code2][i]] := Str[code1][i];
for i := 1 to Length(s) do
s[i] := Chars[s[i]];
Memo2.Text := s;
end;
|
Как можно перекодировать сообщение (содержание) из Win в КОИ8-Р для отправки по EMail.
| Разговаривают две фидошницы: - Знаешь, мы с одним парнем сексом по переписке занимаемся! - ?! Ну, и как? Оргазм когда-нибудь получаешь? - Ага... Когда не получаю его дурацких писем. |
const
Koi: array[0..66] of Char = (
'T', 'Ё', 'ё', 'А', 'Б', 'В', 'Г', 'Д', 'Е', 'Ж',
'З', 'И', 'Й', 'К', 'Л', 'М', 'Н', 'О', 'П', 'Р',
'С', 'Т', 'У', 'Ф', 'Х', 'Ц', 'Ч', 'Ш', 'Щ', 'Ъ',
'Ы', 'Ь', 'Э', 'Ю', 'Я', 'а', 'б', 'в', 'г', 'д',
'е', 'ж', 'з', 'и', 'й', 'к', 'л', 'м', 'н', 'о',
'п', 'р', 'с', 'т', 'у', 'ф', 'х', 'ц', 'ч', 'ш',
'щ', 'ъ', 'ы', 'ь', 'э', 'ю', 'я');
Win: array[0..66] of Char = (
'ё', 'Ё', 'T', 'ю', 'а', 'б', 'ц', 'д', 'е', 'ф',
'г', 'х', 'и', 'й', 'к', 'л', 'м', 'н', 'о', 'п',
'я', 'р', 'с', 'т', 'у', 'ж', 'в', 'ь', 'ы', 'з',
'ш', 'э', 'щ', 'ч', 'ъ', 'Ю', 'А', 'Б', 'Ц', 'Д',
'Е', 'Ф', 'Г', 'Х', 'И', 'Й', 'К', 'Л', 'М', 'Н',
'О', 'П', 'Я', 'Р', 'С', 'Т', 'У', 'Ж', 'В', 'Ь',
'Ы', 'З', 'Ш', 'Э', 'Щ', 'Ч', 'Ъ');
function WinToKoi(Str: string): string;
var
i, j, index: Integer;
begin
Result := '';
for i := 1 to Length(Str) do
begin
index := -1;
for j := Low(Win) to High(Win) do
if Win[j] = Str[i] then
begin
index := j;
Break;
end;
if index = -1 then
Result := Result + Str[i]
else
Result := Result + Koi[index];
end;
end;
function KoiToWin(Str: string): string;
var
i, j, index: Integer;
begin
Result := '';
for i := 1 to Length(Str) do
begin
index := -1;
for j := Low(Win) to High(Win) do
if Koi[j] = Str[i] then
begin
index := j;
Break;
end;
if index = -1 then
Result := Result + Str[i]
else
Result := Result + Win[index];
end;
end;
procedure SendFileOnSMTP(Host: string; Port: Integer;
Subject, FromAddress, ToAddress, Body, FileName: string);
var
NMSMTP: TNMSMTP;
begin
if DelSpace(ToAddress) = '' then
Exit;
if ToAddress[1] = '' then
Exit;
if (DelSpace(FileName) <> '') and not FileExists(FileName) then
raise Exception.Create('SendFileOnSMTP: file not exist: ' + FileName);
NMSMTP := TNMSMTP.Create(nil);
try
NMSMTP.Host := Host;
NMSMTP.Port := Port;
NMSMTP.Charset := 'koi8-r'
NMSMTP.PostMessage.FromAddress := FromAddress;
NMSMTP.PostMessage.ToAddress.Text := ToAddress;
NMSMTP.PostMessage.Attachments.Text := FileName;
NMSMTP.PostMessage.Subject := Subject;
NMSMTP.PostMessage.Date := DateTimeToStr(Now);
NMSMTP.UserID := 'netmaster'
NMSMTP.PostMessage.Body.Text := WinToKoi(Body);
NMSMTP.FinalHeader.Clear;
NMSMTP.TimeOut := 5000;
NMSMTP.Connect;
NMSMTP.SendMail;
NMSMTP.Disconnect;
finally
NMSMTP.Free;
end;
end;
|
Перекодировка текста DOS-Windows-Koi8.
| Подходит компьютерщик (К) к газетному киоску и спрашивает у продавца (П): К: - Есть ли у вас свежий номер 'Компьютерного обозрения'? П: - Есть. К: - Ну тогда, пожалуйста, один номер в кодировке KOI8-R |
procedure WinToDos;
var
Src, Str: PChar;
begin
Src := Memo1.Lines.GetText; //Берем текст из TMemo как тип PChar
CharToOem(Src, Str); //API функция для перевода текста
Memo2.Lines.Text := StrPas(Str);//Записываем назад
end;
procedure DosToWin;
var
Src, Str: PChar;
begin
Src := Memo1.Lines.GetText; //Берем текст из TMemo как тип PChar
OemToChar(Src, Str); //API функция для перевода текста
Memo2.Lines.Text := StrPas(Str);//Записываем назад
end;
var
koi8toalt : array [0..127] of char = (
CHR($c4), Chr($b3), Chr($da), Chr($bf),
Chr($c0), Chr($d9), Chr($c3), Chr($b4),
Chr($c2), Chr($c1), Chr($c5), Chr($df),
Chr($dc), Chr($db), Chr($dd), Chr($de),
Chr($b0), Chr($b1), Chr($b2), Chr($f4),
Chr($fe), Chr($f9), Chr($fb), Chr($f7),
Chr($f3), Chr($f2), Chr($ff), Chr($f5),
Chr($f8), Chr($fd), Chr($fa), Chr($f6),
Chr($cd), Chr($ba), Chr($d5), Chr($f1),
Chr($d6), Chr($c9), Chr($b8), Chr($b7),
Chr($bb), Chr($d4), Chr($d3), Chr($c8),
Chr($be), Chr($bd), Chr($bc), Chr($c6),
Chr($c7), Chr($cc), Chr($b5), Chr($f0),
Chr($b6), Chr($b9), Chr($d1), Chr($d2),
Chr($cb), Chr($cf), Chr($d0), Chr($ca),
Chr($d8), Chr($d7), Chr($ce), Chr($fc),
Chr($ee), Chr($a0), Chr($a1), Chr($e6),
Chr($a4), Chr($a5), Chr($e4), Chr($a3),
Chr($e5), Chr($a8), Chr($a9), Chr($aa),
Chr($ab), Chr($ac), Chr($ad), Chr($ae),
Chr($af), Chr($ef), Chr($e0), Chr($e1),
Chr($e2), Chr($e3), Chr($a6), Chr($a2),
Chr($ec), Chr($eb), Chr($a7), Chr($e8),
Chr($ed), Chr($e9), Chr($e7), Chr($ea),
Chr($9e), Chr($80), Chr($81), Chr($96),
Chr($84), Chr($85), Chr($94), Chr($83),
Chr($95), Chr($88), Chr($89), Chr($8a),
Chr($8b), Chr($8c), Chr($8d), Chr($8e),
Chr($8f), Chr($9f), Chr($90), Chr($91),
Chr($92), Chr($93), Chr($86), Chr($82),
Chr($9c), Chr($9b), Chr($87), Chr($98),
Chr($9d), Chr($99), Chr($97), Chr($9a));
function Koi8toWin(const Data: PChar; DataLen: Integer): PChar;
var
PCh: PChar;
i: Integer;
begin
PCh := Data;
for i := 1 to DataLen do
begin
if Ord(Pch^) > 127 then
Pch^ := koi8toalt[Ord(Pch^) - 128];
Inc(PCh);
end;
PCh := Data;
OemToCharBuff(PCh, PCh, DWORD(DataLen));
Result := Data;
end;
|
Перекодировка текста из Win1251 в KOI8-R и наоборот.
| Встречается компьютерщик(К) со своим старым другом(Д), бывшем алкашем. - (К) Ну что, больше не пьешь? - (Д) Закодировался. - (К) В какой кодировке? - (Д) KOI-8. - (К) Говорят, в Windows-1251 дольше не пьют. |
type
TConvertChars = array [#128..#255] of char;
const
Win_KoiChars: TConvertChars = (
#128,#129,#130,#131,#132,#133,#134,#135,#136,#137,#060,#139,#140,#141,#142,#143,
#144,#145,#146,#147,#148,#169,#150,#151,#152,#153,#154,#062,#176,#157,#183,#159,
#160,#246,#247,#074,#164,#231,#166,#167,#179,#169,#180,#060,#172,#173,#174,#183,
#156,#177,#073,#105,#199,#181,#182,#158,#163,#191,#164,#062,#106,#189,#190,#167,
#225,#226,#247,#231,#228,#229,#246,#250,#233,#234,#235,#236,#237,#238,#239,#240,
#242,#243,#244,#245,#230,#232,#227,#254,#251,#253,#154,#249,#248,#252,#224,#241,
#193,#194,#215,#199,#196,#197,#214,#218,#201,#202,#203,#204,#205,#206,#207,#208,
#210,#211,#212,#213,#198,#200,#195,#222,#219,#221,#223,#217,#216,#220,#192,#209);
Koi_WinChars: TConvertChars = (
#128,#129,#130,#131,#132,#133,#134,#135,#136,#137,#138,#139,#140,#141,#142,#143,
#144,#145,#146,#147,#148,#149,#150,#151,#152,#153,#218,#155,#176,#157,#183,#159,
#160,#161,#162,#184,#186,#165,#166,#191,#168,#169,#170,#171,#172,#173,#174,#175,
#156,#177,#178,#168,#170,#181,#182,#175,#184,#185,#186,#187,#188,#189,#190,#185,
#254,#224,#225,#246,#228,#229,#244,#227,#245,#232,#233,#234,#235,#236,#237,#238,
#239,#255,#240,#241,#242,#243,#230,#226,#252,#251,#231,#248,#253,#249,#247,#250,
#222,#192,#193,#214,#196,#197,#212,#195,#213,#200,#201,#202,#203,#204,#205,#206,
#207,#223,#208,#209,#210,#211,#198,#194,#220,#219,#199,#216,#221,#217,#215,#218);
function Win_KoiConvert(const St: string): string;
var
i: integer;
begin
Result:=St;
for i:=1 to Length(St) do
if St[i]>#127 then
Result[i]:=Win_KoiChars[St[i]];
end;
|
Распознавание кодировки. Перекодировка.
| Приходит программист к окулисту. Тот его усаживает напротив таблицы, берет указку: - Читайте! - "БНОПНЯ"... Доктор, у вас что-то не то с кодировкой! |
Алгоритм распознавания кодировки нужен для автоматического декодирования текста. Этот алгоритм основан на том, что некоторые буквы русского алфавита встречается очень часто, а некоторые редко. Поскольку этот способ статистический, то лучше всего он работает с большими текстами.
type
TCode = (win, koi, iso, dos);
const
CodeStrings: array [TCode] of string = ('win','koi','iso','dos');
procedure TForm1.Button1Click(Sender: TObject);
var
str: array [TCode] of string;
norm: array ['А'..'я'] of single;
code1, code2: TCode;
min1, min2: TCode;
count: array [char] of integer;
d, min: single;
s, so: string;
chars: array [char] of char;
c: char;
i: integer;
begin
so := Memo1.Text;
norm['А'] := 0.001;
norm['Б'] := 0;
norm['В'] := 0.002;
norm['Г'] := 0;
norm['Д'] := 0.001;
norm['Е'] := 0.001;
norm['Ж'] := 0;
norm['З'] := 0;
norm['И'] := 0.001;
norm['Й'] := 0;
norm['К'] := 0.001;
norm['Л'] := 0;
norm['М'] := 0.001;
norm['Н'] := 0.001;
norm['О'] := 0.001;
norm['П'] := 0.002;
norm['Р'] := 0.002;
norm['С'] := 0.001;
norm['Т'] := 0.001;
norm['У'] := 0;
norm['Ф'] := 0;
norm['Х'] := 0;
norm['Ц'] := 0;
norm['Ч'] := 0.001;
norm['Ш'] := 0.001;
norm['Щ'] := 0;
norm['Ъ'] := 0;
norm['Ы'] := 0;
norm['Ь'] := 0;
norm['Э'] := 0.001;
norm['Ю'] := 0;
norm['Я'] := 0;
norm['а'] := 0.057;
norm['б'] := 0.01;
norm['в'] := 0.031;
norm['г'] := 0.011;
norm['д'] := 0.021;
norm['е'] := 0.067;
norm['ж'] := 0.007;
norm['з'] := 0.013;
norm['и'] := 0.052;
norm['й'] := 0.011;
norm['к'] := 0.023;
norm['л'] := 0.03;
norm['м'] := 0.024;
norm['н'] := 0.043;
norm['о'] := 0.075;
norm['п'] := 0.026;
norm['р'] := 0.038;
norm['с'] := 0.034;
norm['т'] := 0.046;
norm['у'] := 0.016;
norm['ф'] := 0.001;
norm['х'] := 0.006;
norm['ц'] := 0.002;
norm['ч'] := 0.011;
norm['ш'] := 0.004;
norm['щ'] := 0.004;
norm['ъ'] := 0;
norm['ы'] := 0.012;
norm['ь'] := 0.012;
norm['э'] := 0.003;
norm['ю'] := 0.005;
norm['я'] := 0.015;
Str[win] := 'АаБбВвГгДдЕеЖжЗзИиЙйКкЛлМмНнОоПпРрСсТтУуФфХхЦцЧчШшЩщЪъЫыЬьЭэЮюЯя';
Str[koi] := 'юЮаАбБцЦдДеЕфФгГхХиИйЙкКлЛмМнНоОпПяЯрРсСтТуУжЖвВьЬыЫзЗшШэЭщЩчЧъЪ';
Str[iso] := 'РрСсТтУуФфХхЦцЧчШшЩщЪъЫыЬьЭэЮюЯяа№бёвђгѓдєеѕжізїијйљкњлћмќн§оўпџ';
Str[dos] := 'Ђ ЃЎ‚ўѓЈ"¤…Ґ†¦‡§€Ё‰©ЉЄ‹"ЊЌЋ®ЏЇђа'б'в"г"дое-ж-зи™йљк›лњмќнћоџпз?и™йљк›лњмќнћоџп';
for c := #0 to #255 do
Chars[c] := c;
min1 := win;
min2 := win;
min := 0;
s := so;
fillchar(count, sizeof(count), 0);
for i := 1 to Length(s) do
inc(count[s[i]]);
for c := 'А' to 'я' do
min := min + sqr(count[c] / Length(s) - norm[c]);
for code1 := low(TCode) to high(TCode) do
begin
for code2 := low(TCode) to high(TCode) do
begin
if code1 = code2 then
continue;
s := so;
for i := 1 to Length(Str[win]) do
Chars[Str[code2][i]] := Str[code1][i];
for i := 1 to Length(s) do
s[i] := Chars[s[i]];
fillchar(count, sizeof(count), 0);
for i := 1 to Length(s) do
inc(count[s[i]]);
d := 0;
for c := 'А' to 'я' do
d := d + sqr(count[c] / Length(s) - norm[c]);
if d then
begin
min1 := code1;
min2 := code2;
min := d;
end;
end;
end;
s := Memo1.Text;
if min1 <> min2 then
begin
for c := #0 to #255 do
Chars[c] := c;
for i := 1 to Length(Str[win]) do
Chars[Str[min2][i]] := Str[min1][i];
for i := 1 to Length(s) do
s[i] := Chars[s[i]];
end;
Form1.Caption := CodeStrings[min2] + ' ' + CodeStrings[min1];
Memo2.Text := s;
end;
|
Передача массива записей символов в Memo.
| Юзер заходит в магазин: - А какой компьютер лучше? Windows или Pentium. |
Обработка больших строк в 16-битной версии Delphi задача далеко непростая. Особенно когда строки являются частью структуры записи и вы хотите передать их в TMemo. В данном совете показано как создать структуру записи размером 1000 символов, прочесть в нее содержимое Memo и затем записать ее обратно в Memo. Основной метод, который мы здесь используем - метод Memo GetTextBuf. Используемая структура записи представляет собой простую строку и массив из 1000 символов, но структура могла бы быть сложнее.
unit URcrdIO;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, dbtables;
type
TForm1 = class(TForm)
Button1: TButton;
Memo1: TMemo;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
type
TMyRec = record
MyArray: array[1..1000] of char;
mystr: string;
end;
var
Form1: TForm1;
MyRec: TMyRec;
mylist: TStringlist;
PMyChar: PChar;
myfile: file;
mb: TStream;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
begin
assignfile(myfile, 'c:\testblob.txt');
rewrite(myfile, 1);
fillchar(MyRec.MyArray, sizeof(MyRec.MyArray), #0);
pmychar := @MyRec.MyArray;
StrPCopy(pmychar, memo1.text);
Blockwrite(MyFile, MyRec, SizeOf(MyRec));
closefile(MyFile);
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
assignfile(myfile, 'c:\testblob.txt');
reset(myfile, 1);
fillchar(MyRec.MyArray, sizeof(MyRec.MyArray), #0);
Blockread(MyFile, MyRec, SizeOf(MyRec));
pmychar := @MyRec.MyArray;
Memo1.SetTextBuf(pmychar);
end;
end.
|
Присвоить значение полям записи с помощью Assemblera.
Автор: Xavier Pacheco
unit Main;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure Foo(var I: integer);
begin
{ some code }
asm
mov eax, I
inc dword ptr [eax]
end;
{ i has now been incremented by one }
{ some more code }
end;
type
TDumbRec = record
i: integer;
c: char;
end;
procedure ManipulateRec(var DR: TDumbRec);
asm
mov [eax].TDumbRec.i, 24
mov [eax].TDumbRec.c, 's'
end;
procedure TForm1.Button1Click(Sender: TObject);
var
R: TDumbRec;
begin
ManipulateRec(R);
ShowMessage(IntToStr(R.i));
Caption := Caption + R.c;
end;
end.
При обращении клиента, к уже редактируемой записи другим клиентом, выдаётся сообщение.
Ответ 1:Самое дешевое решение - завести поле, в которое будет записываться ID usera перед началом операции. Перед началом обновления данных выполняете следующее. 1. При старте программы каждому юзеру раздаете уникальный ID. 2. Перед началом обновления данных записываете ID в поле в и коммитете данные. После этого поле будет залочено для этого юзера. 3. Вносите изменения. 4. В блокирующее поле записываете 0 и коммитете. Перед началом обновления, проверяете чему равно значение блокирующего поля. Если оно не нулевое, то вы не только сможете сообщить, что запись заблокирована, но и сказать кем именно. Если не делать ничего подобного то запросто при многопользовательской работе можно получить deadlock на сервере а есть не очень хорошо.
Ответ 2:
Так сделать нельзя. Можно по другому. Оцени критические ситуации и поставь проверку на триггер или еще лучше сделай с помощью CHECK. Например: колличество на складе не может быть меньше 0 CHECK TOVAR_COUNT>0 Если один из клиентов изменил количество , а второй попытался снять больше чем есть на складе - то сервер выдаст ошибку, которую ты можешь обработать программой. Очень хорошая книга по этой теме П.В. Шумаков - Дельфи 3 и разработка приложений баз данных. После ее прочтения 80% твоих вопросов будут решены.
Ответ 3:
Думаю, что Вашу задачу можно решить следующим путем. На сервере метод, который осуществляет обработку данных. "закрыть" критической секцией. В начале критическую секцию необходимо объявить в составе класса или отдельно:
SectionLock: TCriticalSection; |
Затем:
procedure TForm1.FormCreate(Sender: TObject); begin SectionLock := TCriticalSection.Create; end; procedure TForm1.FormDestroy(Sender: TObject); begin SectionLock.Free; end; |
Теперь при инициализации Вашего метода можно использовать SectionLock:
SectionLock.Acquire; try DoSomething; finally SectionLock.Release; end; // или SectionLock.Enter; try DoSomething; finally SectionLock.Leave; end; |
Когда поток достигает критической секции, то все что заключено в этой секции перестает реагировать на любые внешние воздействия до момента выхода из критической секции. Теперь на попытку обращения к серверу другого клиента в качестве результата можно возвращать значение, которое будет идентифициороваться как "Занято". Например:
if Lock then "Ответ - занято" SectionLock.Enter; try Lock := True; DoSomething; finally SectionLock.Leave; Lock := False; end; |
P.S. Что бы сервер мог одновременно реагировать на несколько запросов, его необходимо реализовать в СОМ технологии.
Запись nnn из nnn.
Автор: OAmiry (Borland) Нет ли метода или свойства, позволяющих осуществить сабж из Delphi?Для этого необходимо поработать с BDE. Нижеприведенный код у меня работает прекрасно. Условия выполнения: A) Вы используете таблицы dBASE B) На форме расположен компонент DBNavigator B) На форме расположен табличный компонент с именем Table1 C) На форме расположен компонент Label с именем Label1 D) Обработчик события OnClick компонента DBNavigator имеет следующий код:
procedure TForm1.DBNavigator1Click(Sender: TObject; Button: TNavigateBtn);
var
pRecProperty: pRECProps;
begin
if Button in [nbFirst, nbPrior, nbNext, nbLast] then
begin
if MaxAvail > SizeOf(RECProps) then
begin
GetMem(pRecProperty, SizeOf(RECProps));
DbiGetRecord(Table1.Handle, dbiNOLOCK, nil, pRecProperty);
Label1.Caption := Concat('Запись: ', IntToStr(pRecProperty^.iPhyRecNum),
' из ', IntToStr(Table1.RecordCount));
FreeMem(pRecProperty, SizeOf(RECProps));
end;
end;
end;
|
Получить номер записи можно в момент показа формы или в момент открытия таблицы.
Запись звука.
Автор: John Mertus
var
WaveRecorder : TWaveRecorder;
// 4 размером 2048 байт
WaveRecorder := TwaveRecorder(2048, 4);
{ Устанавливает параметры дискретизации }
with WaveRecorder.pWavefmtEx do
begin
wFormatTag := WAVE_FORMAT_PCM;
nChannels := 1;
nSamplesPerSec := 20000;
wBitsPerSample := 16;
nAvgBytesPerSec := nSamplesPerSec*(wBitsPerSample div 8)*nChannels;
end;
// Затем используем вариантную запись, поскольку я не знаю
// как получить адрес самого объекта
WaveRecorder.SetupRecord(@WaveRecorder);
// Начинаем запись
WaveRecorder.StartRecord;
// При каждом заполнении буфера вызывается процедура
WaveRecorder.Processbuffer.
// Заканчиваем запись
WaveRecorder.StopRecord;
WaveRecorder.Destroy;
{
Имя файла: RECUNIT.PAS V 1.01
Создан: Авг 19 1996 в 21:56 на IBM ThinkPad
Ревизия #7: Авг 22 1997, 15:01 на IBM ThinkPad
-John Mertus
Данный модуль содержит необходимые процедуры для записи звука.
Версия 1.00 - первый релиз
1.01 - добавлен TWaveInGetErrorText
}
{-Unit-RECUNIT----------John Mertus---Авг 96---}
unit RECUNIT;
interface
uses
Windows, MMSystem, SysUtils, MSACM;
{ Ниже определен класс TWaveRecorder для обслуживания входа звуковой }
{ карты. Ожидается, что новый класс будет производным от TWaveRecorder }
{ и перекроет TWaveRecorder.ProcessBuffer. После начала записи данная }
{ процедура вызывается каждый раз при наличии в буфере аудио-данных. }
const
MAX_BUFFERS = 8;
type
PWaveRecorder = ^TWaveRecorder;
TWaveRecorder = class(TObject)
constructor Create(BfSize, TotalBuffers : Integer);
destructor Destroy; override;
procedure ProcessBuffer(uMsg : Word; P : Pointer; n : Integer); virtual;
private
fBufferSize : Integer; // Размер буфера
BufIndex : Integer;
fTotalBuffers : Integer;
pWaveHeader : array [0..MAX_BUFFERS-1] of PWAVEHDR;
hWaveHeader : array [0..MAX_BUFFERS-1] of THANDLE;
hWaveBuffer : array [0..MAX_BUFFERS-1] of THANDLE;
hWaveFmtEx : THANDLE;
dwByteDataSize : DWORD;
dwTotalWaveSize : DWORD;
RecordActive : Boolean;
bDeviceOpen : Boolean;
{ Внутренние функции класса }
function InitWaveHeaders : Boolean;
function AllocPCMBuffers : Boolean;
procedure FreePCMBuffers;
function AllocWaveFormatEx : Boolean;
procedure FreeWaveFormatEx;
function AllocWaveHeaders : Boolean;
procedure FreeWaveHeader;
function AddNextBuffer : Boolean;
procedure CloseWaveDeviceRecord;
public
{ Public declarations }
pWaveFmtEx : PWaveFormatEx;
WaveBufSize : Integer; { Размер поля nBlockAlign }
InitWaveRecorder : Boolean;
RecErrorMessage : string;
QueuedBuffers,
ProcessedBuffers : Integer;
pWaveBuffer : array [0..MAX_BUFFERS-1] of lpstr;
WaveIn : HWAVEIN; { Дескриптор Wav-устройства }
procedure StopRecord;
function 477576218068StartRecord : Boolean;
function 477576218068SetupRecord(P : PWaveRecorder) : Boolean;
end;
implementation
function TWaveInGetErrorText(iErr : Integer) : string;
{ Выдает сообщения об ошибках WaveIn в формате Pascal }
{ iErr - номер ошибки }
var
PlayInErrorMsgC : array [0..255] of Char;
begin
waveInGetErrorText(iErr,PlayInErrorMsgC,255);
TWaveInGetErrorText := StrPas(PlayInErrorMsgC);
end;
function TWaveRecorder.AllocWaveFormatEx : Boolean;
{ Распределяем формат большого размера, требуемый для инсталляции ACM-в}
var
MaxFmtSize : UINT;
begin
{ maxFmtSize - сумма sizeof(WAVEFORMATEX) + pwavefmtex.cbSize }
if( acmMetrics( 0, ACM_METRIC_MAX_SIZE_FORMAT, maxFmtSize ) <> 0) >then
begin
RecErrorMessage := 'Ошибка получения размера формата максимального сжатия';
AllocWaveFormatEx := False;
Exit;
end;
{ распределяем структуру WAVEFMTEX }
hWaveFmtEx := GlobalAlloc(GMEM_MOVEABLE, maxFmtSize);
if (hWaveFmtEx = 0) then
begin
RecErrorMessage := 'Ошибка распределения памяти для структуры WaveFormatEx';
AllocWaveFormatEx := False;
Exit;
end;
pWaveFmtEx := PWaveFormatEx(GlobalLock(hWaveFmtEx));
if (pWaveFmtEx = nil) then
begin
RecErrorMessage := 'Ошибка блокировки памяти WaveFormatEx';
AllocWaveFormatEx := False;
Exit;
end;
{ инициализация формата в стандарте PCM }
ZeroMemory( pwavefmtex, maxFmtSize );
pwavefmtex.wFormatTag := WAVE_FORMAT_PCM;
pwavefmtex.nChannels := 1;
pwavefmtex.nSamplesPerSec := 20000;
pwavefmtex.nBlockAlign := 1;
pwavefmtex.wBitsPerSample := 16;
pwavefmtex.nAvgBytesPerSec := pwavefmtex.nSamplesPerSec*
(pwavefmtex.wBitsPerSample div 8)*pwavefmtex.nChannels;
pwavefmtex.cbSize := 0;
{ Все успешно, идем домой }
AllocWaveFormatEx := True;
end;
function TWaveRecorder.InitWaveHeaders : Boolean;
{ Распределяем память, обнуляем заголовок wave и инициализируем }
var
i : Integer;
begin
{ делаем размер буфера кратным величине блока... }
WaveBufSize := fBufferSize - (fBufferSize mod pwavefmtex.nBlockAlign);
{ Устанавливаем wave-заголовки }
for i := 0 to fTotalBuffers-1 do
with pWaveHeader[i]^ do
begin
lpData := pWaveBuffer[i]; // адрес буфера waveform
dwBufferLength := WaveBufSize; // размер, в байтах, буфера
dwBytesRecorded := 0; // смотри ниже
dwUser := 0; // 32 бита данных пользователя
dwFlags := 0; // смотри ниже
dwLoops := 0; // смотри ниже
lpNext := nil; // зарезервировано; должен быть ноль
reserved := 0; // зарезервировано; должен быть ноль
end;
InitWaveHeaders := TRUE;
end;
function TWaveRecorder.AllocWaveHeaders : Boolean;
{ Распределяем и блокируем память заголовка }
var
i : Integer;
begin
for i := 0 to fTotalBuffers-1 do
begin
hwaveheader[i] := GlobalAlloc( GMEM_MOVEABLE or GMEM_SHARE or
GMEM_ZEROINIT, sizeof(TWAVEHDR));
if (hwaveheader[i] = 0) then
begin
{ Примечание: Это может привести к утечке памяти, надеюсь скоро исправить }
RecErrorMessage := 'Ошибка распределения памяти для wave-заголовка';
AllocWaveHeaders := FALSE;
Exit;
end;
pwaveheader[i] := GlobalLock (hwaveheader[i]);
if (pwaveheader[i] = nil ) then
begin
{ Примечание: Это может привести к утечке памяти, надеюсь скоро исправить }
RecErrorMessage := 'Не могу заблокировать память заголовка для записи';
AllocWaveHeaders := FALSE;
Exit;
end;
end;
AllocWaveHeaders := TRUE;
end;
procedure TWaveRecorder.FreeWaveHeader;
{ Просто освобождаем распределенную AllocWaveHeaders память. }
var
i : Integer;
begin
for i := 0 to fTotalBuffers-1 do
begin
if (hWaveHeader[i] <> 0) then
begin
GlobalUnlock(hwaveheader[i]);
GlobalFree(hwaveheader[i]);
hWaveHeader[i] := 0;
end
end;
end;
function TWaveRecorder.AllocPCMBuffers : Boolean;
{ Распределяем и блокируем память waveform. }
var
i : Integer;
begin
for i := 0 to fTotalBuffers-1 do
begin
hWaveBuffer[i] := GlobalAlloc( GMEM_MOVEABLE or GMEM_SHARE, fBufferSize );
if (hWaveBuffer[i] = 0) then
begin
{ Здесь возможна утечка памяти }
RecErrorMessage := 'Ошибка распределения памяти wave-буфера';
AllocPCMBuffers := False;
Exit;
end;
pWaveBuffer[i] := GlobalLock(hWaveBuffer[i]);
if (pWaveBuffer[i] = nil) then
begin
{ Здесь возможна утечка памяти }
RecErrorMessage := 'Ошибка блокирования памяти wave-буфера';
AllocPCMBuffers := False;
Exit;
end;
pWaveHeader[i].lpData := pWaveBuffer[i];
end;
AllocPCMBuffers := TRUE;
end;
procedure TWaveRecorder.FreePCMBuffers;
{ Освобождаем использованную AllocPCMBuffers память. }
var
i : Integer;
begin
for i := 0 to fTotalBuffers-1 do
begin
if (hWaveBuffer[i] <> 0) then
begin
GlobalUnlock( hWaveBuffer[i] );
GlobalFree( hWaveBuffer[i] );
hWaveBuffer[i] := 0;
pWaveBuffer[i] := nil;
end;
end;
end;
procedure TWaveRecorder.FreeWaveFormatEx;
{ Просто освобождаем заголовки ExFormat headers }
begin
if (pWaveFmtEx = nil) then
Exit;
GlobalUnlock(hWaveFmtEx);
GlobalFree(hWaveFmtEx);
pWaveFmtEx := nil;
end;
constructor TWaveRecorder.Create(BFSize, TotalBuffers : Integer);
{ Устанавливаем wave-заголовки, инициализируем указатели данных и }
{ и распределяем буферы дискретизации }
{ BFSize - размер буфера в байтах }
var
i : Integer;
begin
inherited Create;
for i := 0 to fTotalBuffers-1 do
begin
hWaveHeader[i] := 0;
hWaveBuffer[i] := 0;
pWaveBuffer[i] := nil;
pWaveFmtEx := nil;
end;
fBufferSize := BFSize;
fTotalBuffers := TotalBuffers;
{ распределяем память для структуры wave-формата }
if(not AllocWaveFormatEx) then
begin
InitWaveRecorder := FALSE;
Exit;
end;
{ ищем устройство, совместимое с доступными wave-характеристиками }
if (waveInGetNumDevs then
begin
RecErrorMessage := 'Не найдено устройств, способных записывать звук';
InitWaveRecorder := FALSE;
Exit;
end;
{ распределяем память wave-заголовка }
if (not AllocWaveHeaders) then
begin
InitWaveRecorder := FALSE;
Exit;
end;
{ распределяем память буфера wave-данных }
if (not AllocPCMBuffers) then
begin
InitWaveRecorder := FALSE;
Exit;
end;
InitWaveRecorder := TRUE;
end;
destructor TWaveRecorder.Destroy;
{ Просто освобождаем всю память, распределенную InitWaveRecorder. }
begin
FreeWaveFormatEx;
FreePCMBuffers;
FreeWaveHeader;
inherited Destroy;
end;
procedure TWaveRecorder.CloseWaveDeviceRecord;
{ Просто освобождаем (закрываем) waveform-устройство. }
var
i : Integer;
begin
{ если устройство уже закрыто, то выходим }
if (not bDeviceOpen) then
Exit;
{ работа с заголовками - unprepare }
for i := 0 to fTotalBuffers-1 do
if (waveInUnprepareHeader(WaveIn, pWaveHeader[i],
sizeof(TWAVEHDR)) <> 0 ) then
RecErrorMessage := 'Ошибка в waveInUnprepareHeader';
{ сохраняем общий объем записи и обновляем показ }
dwTotalwavesize := dwBytedatasize;
{ закрываем входное wave-устройство }
if (waveInClose(WaveIn) <> 0) then
RecErrorMessage := 'Ошибка закрытия входного устройства';
{ сообщаем вызвавшей функции, что устройство закрыто }
bDeviceOpen := FALSE;
end;
procedure TWaveRecorder.StopRecord;
{ Останавливаем запись и устанавливаем некоторые флаги. }
var
iErr : Integer;
begin
RecordActive := False;
iErr := waveInReset(WaveIn);
{ прекращаем запись и возвращаем стоящие в очереди буферы }
if (iErr <> 0) then
RecErrorMessage := 'Ошибка в waveInReset';
CloseWaveDeviceRecord;
end;
function TWaveRecorder.AddNextBuffer : Boolean;
{ Добавляем буфер ко входной очереди и переключаем буферный индекс. }
var
iErr : Integer;
begin
{ ставим буфер в очередь для получения очередной порции данных }
iErr := waveInAddBuffer(WaveIn, pwaveheader[bufindex], sizeof(TWAVEHDR));
if (iErr <> 0) then
begin
StopRecord;
RecErrorMessage := 'Ошибка добавления буфера' + TWaveInGetErrorText(iErr);
AddNextBuffer := FALSE;
Exit;
end;
{ переключаемся на следующий буфер }
bufindex := (bufindex+1) mod fTotalBuffers;
QueuedBuffers := QueuedBuffers + 1;
AddNextBuffer := TRUE;
end;
procedure BufferDoneCallBack(
hW : HWAVE; // дескриптор waveform-устройства
uMsg : DWORD; // посылаемое сообщение
dwInstance : DWORD; // экземпляр данных
dwParam1 : DWORD; // определяемый приложением параметр
dwParam2 : DWORD; // определяемый приложением параметр
); stdcall;
{ Вызывается при наличии у wave-устройства какой-либо информации, }
{ например при заполнении буфера }
var
BaseRecorder : PWaveRecorder;
begin
BaseRecorder := Pointer(DwInstance);
with BaseRecorder^ do
begin
ProcessBuffer(uMsg, pWaveBuffer[ProcessedBuffers mod fTotalBuffers],
WaveBufSize);
if (RecordActive) then
case uMsg of
WIM_DATA:
begin
BaseRecorder.AddNextBuffer;
ProcessedBuffers := ProcessedBuffers+1;
end;
end;
end;
end;
function TWaveRecorder.StartRecord : Boolean;
{ Начало записи. }
var
iErr, i : Integer;
begin
{ начало записи в первый буфер }
iErr := WaveInStart(WaveIn);
if (iErr <> 0) then
begin
CloseWaveDeviceRecord;
RecErrorMessage := 'Ошибка начала записи wave: ' +
TWaveInGetErrorText(iErr);
end;
RecordActive := TRUE;
{ ставим в очередь следующие буферы }
for i := 1 to fTotalBuffers-1 do
if (not AddNextBuffer) then
begin
StartRecord := FALSE;
Exit;
end;
StartRecord := True;
end;
function TWaveRecorder.SetupRecord(P : PWaveRecorder) : Boolean;
{ Данная функция делает всю работу по созданию waveform-"записывателя". }
var
iErr, i : Integer;
begin
dwTotalwavesize := 0;
dwBytedatasize := 0;
bufindex := 0;
ProcessedBuffers := 0;
QueuedBuffers := 0;
{ открываем устройство для записи }
iErr := waveInOpen(@WaveIn, WAVE_MAPPER, pWaveFmtEx,
Integer(@BufferDoneCallBack),
Integer(P), CALLBACK_FUNCTION + WAVE_ALLOWSYNC );
if (iErr <> 0) then
begin
RecErrorMessage := 'Не могу открыть входное устройство для записи: ' + ^M
+ TWaveInGetErrorText(iErr);
SetupRecord := FALSE;
Exit;
end;
{ сообщаем CloseWaveDeviceRecord(), что устройство открыто }
bDeviceOpen := TRUE;
{ подготавливаем заголовки }
InitWaveHeaders();
for i := 0 to fTotalBuffers-1 do
begin
iErr := waveInPrepareHeader( WaveIn, pWaveHeader[I], sizeof(TWAVEHDR));
if (iErr <> 0) then
begin
CloseWaveDeviceRecord;
RecErrorMessage := 'Ошибка подготовки заголовка для записи: ' + ^M +
TWaveInGetErrorText(iErr);
SetupRecord := FALSE;
Exit;
end;
end;
{ добавляем первый буфер }
if (not AddNextBuffer) then
begin
SetupRecord := FALSE;
Exit;
end;
SetupRecord := TRUE;
end;
procedure TWaveRecorder.ProcessBuffer(uMsg: Word; P : Pointer;
n: Integer);
{ Болванка процедуры, вызываемой при готовности буфера. }
begin
end;
end.
|
Нарушение уникальности записи.
try
tMyTable.Post;
except
on E : EDBEngineError do
if E.Message = 'Key violation' then
begin
MessageDlgC ('Дублирование записи не допускается.', mtError, [mbOk], 0);
// Я не уверен в том, что это нужно делать:
tMyTable.Cancel;
end
else
Raise;
end;
|
Создайте функцию типа этой:
function DBError(DataSet: TDataSet;
E: EDatabaseError; var Action: TDataAction);
const
eKeyViol = 9729;
var
iDBIError: Integer;
begin
if (E is EDBEngineError) then
begin
iDBIError := (E as EDBEngineError).Errors[0].Errorcode;
case iDBIError of
eKeyViol:
begin
MessageDlg('Нарушение уникальности записи ', mtWarning, [mbOK], 0);
Abort;
end;
end;
|
Затем для каждой таблицы вашего приложения создайте следующий обработчик события:
procedure TMainForm.Table1EditError(DataSet: TDataSet; E: EDatabaseError; var Action: TDataAction); begin DBError(Table1, E, Action); end; |
Таким образом вы можете перехватить множество ошибок. Смотрите примеры от Borland, там много чего есть полезного.
Запись с помощью MediaPlayer.
| Автор: Nick Hodges |
| Origin: - Ори, джинн! Ори, с#ка! |
Компонент Mediaplayer работает только с корректными звуковыми файлами и не работает с файлами нулевого размера. Нижеприведенная функция создаст звуковой файл с размером 1. Вариантная запись. Хотелось бы видеть лучшее решение, но пока такой вариант работает у меня без проблем.
function CreateNewWave(NewFileName: string): Boolean;
var
DeviceID: Word;
Return: LongInt;
MciOpen: TMCI_Open_Parms;
MciRecord: TMCI_Record_Parms;
MciPlay: TMCI_Play_Parms;
MciSave: TMCI_SaveParms;
MCIResult: LongInt;
Flags: Word;
TempFileName: array[0..255] of char;
begin
MediaPlayer.Close;
try
StrPCopy(TempFileName, NewFilename);
MciOpen.lpstrDeviceType := 'waveaudio';
MciOpen.lpstrElementName := '';
Flags := Mci_Open_Element or Mci_Open_Type;
MCIResult := MciSendCommand(0, MCI_OPEN, Flags, LongInt(@MciOpen));
DeviceID := MciOpen.wDeviceId;
MciRecord.dwTo := 1;
Flags := Mci_To or Mci_Wait;
MCIResult := MciSendCommand(DeviceID, Mci_Record, Flags,
LongInt(@MciRecord));
mciPlay.dwFrom := 0;
Flags := Mci_From or Mci_Wait;
MciSendCommand(DeviceId, Mci_Play, Flags, LongInt(@MciPlay));
mciSave.lpfileName := TempFilename.CString;
Flags := MCI_Save_File or Mci_Wait;
MCIResult := MciSendCommand(DeviceID, MCI_Save, Flags, LongInt(@MciSave));
Result := MciSendCommand(DeviceID, Mci_Close, 0, LongInt(nil)) = 0;
end;
end;
|
Восстановление поврежденных таблиц.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
How to recover Data in a damaged Header of DbTables. (Paradox or Dbase) Tables If this problem occurs and we have not copies of data. Paradox can''t directly open those damaged Tables so Paradox can''t repair those tables. solution : T1: the Damaged Table 1- We Have to create an empty Table (T2.Db or T2.Dbf) that have the same structure of damaged table (T1.DB or T1.Dbf). 2- With Dos Prompts or excutable batch File we have to execute this command: Copy T2.Db+T1.db T3.Db or Copy T2.Dbf+T1.dbf T3.Dbf 3-Finally with paradox browser we can open T3 Table we have to delete bad records. and copy t3 to t1 table.Как бороться с квадратичностью Image.
| Автор: Аркадий |
| Билл-Гей. Тс-с-с... |
Вставляем картинку ,например с белым фоном, transpert:=true и на OnMouseOver, или еще где, пишем:
if image1.picture.bitmep.canvas.pixels[X, Y]<>clwhite then image1.cursor:=crHourGlass else image1.cursor:=crDefault |
Пояснение: при наведении прога проверяет цвет пиксела под указатем и если оно отличается от белого, т.е. цвета фона, то указатель меняет свой вид!
Проверка пересечения двух прямоугольников (TRect).
Автор: MikeZ WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Проверка пересечения двух прямоугольников (TRect)
Функция использовалась для проверки пересекаемости 2-х форм,
панелей и т.п. Причем пересекаться они могут и не углами, а,
например, находиться один полностью в другом.
Зависимости: нет
Автор: MikeZ, Zhuravsky2@Yandex.ru, Kiev
Copyright: MikeZ (C) 2003
Дата: 8 октября 2003 г.
***************************************************** }
function OverlapRects(R1, R2: TRect): Boolean;
var
Temp: TRect;
begin
Result := False;
if not UnionRect(Temp, R1, R2) then
Exit;
if (Temp.Right - Temp.Left <= R1.Right - R1.Left + R2.Right - R2.Left) and
(Temp.Bottom - Temp.Top <= R1.Bottom - R1.Top + R2.Bottom - R2.Top) then
Result := True;
end;
Рекурсивные механизмы спуска по дереву.
| - Каких деревьев не хватает в ботаническом саду? - Бинарных, - ответил программист. |
Нужно использовать рекурсивные механизмы спуска по дереву и иметь метод определения наличия child узлов у текущего узла.
function TDBTreeView.RecurseChilds(node: TTreeNode): double;
begin
while node <> nil do begin
if node.HasChildren then
Result := RecurseChilds(node.GetFirstChild);
Result := Result + GetResultForNode(node));
node := node.GetNextSibling;
end;
end;
function TDBTreeView.GetResult(curnode: TTreeNode;): double;
begin
Result := 0;
if curnode = nil then Exit;
Result := RecurseChilds(curnode.GetFirstChild);
end;
|
Рекурсия и опережающее описание.
Рекурсия - это такой способ организации вычислительного процесса, при котором подпрограмма в ходе выполнения составляющих ее операторов обращается сама к себе. Рассмотрим классический пример - вычисление факториала. Программа получает от компонента edinput целое число n и выводит в компонент lboutput значение N!, которое вычисляется с помощью рекурсивной функции Factorial.При выполнении правильно организованной рекурсивной подпрограммы осуществляется многократный переход от некоторого текущего уровня организации алгоритма к нижнему уровню последовательно до тех пор, пока, наконец, не будет получено тривиальное решение поставленной задачи. В нашем случае решение при n = 0 тривиально и используется для остановки рекурсии.
procedure TfmExample.bbRunClick(Sender: TObject);
function Factorial(N: Word): Extended;
begin
if N = 0 then
Result: = 1 else
Result := N * Factorial(N - 1)
end;
var
N: Integer;
begin
try
N := StrToInt(Trim(edinput.Text));
except
Exit; end;
IbOutput.Caption := FloatToStr(Factorial(N))
end;
Рекурсивная форма организации алгоритма обычно выглядит изящнее итерационной и дает более компактный текст программы, но при выполнении, как правило, медленнее и может вызвать переполнение стека (при каждом входе в подпрограмму ее локальные переменные размещаются в организованной особым образом области памяти, называемой программным стеком).
Рекурсивный вызов может быть косвенным. В этом случае подпрограмма обращается к себе опосредованно, путем вызова другой подпрограммы, в которой содержится обращение к первой, например:
procedure A(i: Byte); begin В(i); end; procedure В(j: Byte); begin а(j); end;
Если строго следовать правилу, согласно которому каждый идентификатор перед употреблением должен быть описан, то такую программную конструкцию использовать нельзя. Чтобы такого рода вызовы стали возможны, вводится опережающее описание:
procedure В(j: Byte); forward; procedure A(i: Byte); begin В(i); end; procedure B; begin A(j); end;
Как видим, опережающее описание заключается в том, что объявляется лишь заголовок процедуры в, а ее тело заменяется стандартной директивой Forward. Теперь в процедуре а можно использовать обращение к процедуре в - ведь она уже описана, точнее, известны ее формальные параметры, и компилятор может правильным образом организовать ее вызов. Обратите внимание: тело процедуры в начинается заголовком, в котором уже не указываются описанные ранее формальные параметры.
Класс для рекурсивного обхода дерева каталогов.
Автор: Святослав WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Класс (компонент) для рекурсивного обхода дерева каталогов
(всего диска или заданной папки). На каждый файл и директорию
вызывается соответствующий event.
TTreeWalker.TargetPath - путь для обхода.
TTreeWalker.OnNewDir - event вызывается при обнаружении каждой поддиректории
TTreeWalker.OnNewFile - файла.
Зависимости: Windows, Messages, SysUtils, Classes;
Автор: Святослав, lisin@asicdesign.ru, ICQ:138752432, Saint Petersburg
Copyright: (C) NetBreaker666[AWD]<SP666>@Svjatoslav_Lisin - т.е. я сам
Дата: 11 августа 2002 г.
***************************************************** }
unit TreeWalker;
//Просто рекурсивный обход. Я думаю комментарии не требуются.
interface
uses
Windows, Messages, SysUtils, Classes;
type
PNewDir = procedure(Sender: TObject; Dir: string) of object;
PNewFile = procedure(Sender: TObject; F: TSearchRec) of object;
type
TTreeWalker = class(TComponent)
private
{ Private declarations }
TargetPathV: string;
OnNewFileV: PNewFile;
OnNewDirV: PNewDir;
procedure SetTargetPath(const S: string);
function GetTargetPath: string;
procedure SetOnFile(const ONF: PNewFile);
function GetOnFile: PNewFile;
procedure SetOnDir(const OND: PNewDir);
function GetOnDir: PNewDir;
procedure Recurs(S: string; D: Integer);
protected
{ Protected declarations }
public
{ Public declarations }
procedure Process;
published
{ Published declarations }
property TargetPath: string read GetTargetPath write SetTargetPath;
property OnNewFile: PNewFile read GetOnFile write SetOnFile;
property OnNewDir: PNewDir read GetOnDir write SetOnDir;
end;
procedure Register;
implementation
procedure TTreeWalker.SetTargetPath(const S: string);
begin
TargetPathV := S;
if TargetPathV[Length(TargetPathV)] <> '\' then
TargetPathV := TargetPathV + '\';
end;
function TTreeWalker.GetTargetPath: string;
begin
Result := TargetPathV;
end;
procedure TTreeWalker.SetOnFile(const ONF: PNewFile);
begin
OnNewFileV := ONF;
end;
function TTreeWalker.GetOnFile: PNewFile;
begin
Result := OnNewFileV;
end;
procedure TTreeWalker.SetOnDir(const OND: PNewDIr);
begin
OnNewDirV := OND;
end;
function TTreeWalker.GetOnDir: PNewDir;
begin
Result := OnNewDirV;
end;
procedure TTreeWalker.Process;
begin
Recurs(TargetPathV, 0);
end;
procedure TTreeWalker.Recurs(S: string; D: Integer);
var
F: TSearchRec;
R: Integer;
begin
if D > 512 then
Exit;
if @OnNewDirV <> nil then
OnNewDirV(self, S);
R := FindFirst(S + '*.*', faAnyFile, F);
while R = 0 do
begin
if @OnNewFileV <> nil then
OnNewFileV(self, F);
if (F.Attr and faDirectory <> 0)
and (F.Name <> '.') and (F.Name <> '..') then
Recurs(S + F.Name + '\', D + 1);
R := FindNext(F);
end;
FindClose(F);
end;
procedure Register;
begin
RegisterComponents('NetBreakers', [TTreeWalker]);
end;
end.
Рекурсивное удаление файлов и подкаталогов.
| Один программист очень любил рекурсию. И когда шеф начинал требовать у него отчет о проделанной работе, он отсылал его к ... себе. И так до переполнения стека у шефа. |
{
Здесь я привожу немного сокращенный код, который я создавал для Borland
Pascal 5.5 под DOS (оригинальный код не делал rmDir, поэтому вы можете
поэкспериментировать с этим, передав указатель на каталог функции rmDir
в конце этого кода). Я подозреваю, что Delphi-версия может быть или
идентичной, или иметь некоторые различии в написании имен функций
(рекомендую ознакомиться с электронной документацией по Delphi, с темой,
где описаны функции для работы с файлами). Данный код не предусматривает
проверку атрибутов файлов, которые могут быть установлены для
предотвращения удаления файла. (В Pascal 5.5 вам необходимо между парой
{$I-}{$I+} {поместить функцию, которая вызывает проблему, не знаю,
делаете ли вы это в Delphi.)
}
procedure removeTree(DirName: string);
var
FileSearch: SearchRec;
begin
{ для начала пробегаемся, и удаляем все файлы }
chDir(DirName);
FindFirst('*.*', Directory, FileSearch);
while (DosError = 0) do
begin
if (FileSearch.name <> '.') and (FileSearch.name <> '..') and
((FileSearch.attr and Directory) <> 0) then
begin
if DirName[length(DirName)] = '\' then
removeTree(DirName + FileSearch.Name)
else
removeTree(DirName + '\' + FileSearch.Name);
ChDir(DirName);
end;
FindNext(FileSearch)
end;
{ затем пробегаемся, и удаляем все каталоги }
FindFirst('*.*', AnyFile, FileSearch);
while (DosError = 0) do
begin
if (FileSearch.name <> '.') and (FileSearch.name <> '..') then
Remove(workdir);
end;
FindNext(FileSearch)
end;
rmDir(DirName)
end;
|
Ищем файл рекурсивно.
| Встречаются двое юзеров. Один говорит: - Я тут свежий антивирус достал, не хочешь себе установить? - Нет, мне это не нужно. - Почему? - Да мой комп так глючит, что на нем ни один вирус не запустится. |
procedure GetAllFiles(mask: string);
var
search: TSearchRec;
directory: string;
begin
directory := ExtractFilePath(mask);
// find all files
if FindFirst(mask, $23, search) = 0 then
begin
repeat
// add the files to the listbox
Form1.ListBox1.Items.Add(directory + search.Name);
Inc(Count);
until FindNext(search) <> 0;
end;
// Subdirectories/ Unterverzeichnisse
if FindFirst(directory + '*.*', faDirectory, search) = 0 then
begin
repeat
if ((search.Attr and faDirectory) = faDirectory) and (search.Name[1] <> '.') then
GetAllFiles(directory + search.Name + '\' + ExtractFileName(mask));
until FindNext(search) <> 0;
FindClose(search);
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
var
directory: string;
mask: string;
begin
Count := 0;
Listbox1.Items.Clear;
directory := 'C:\temp\';
mask := '*.*';
Screen.Cursor := crHourGlass;
try
GetAllFiles(directory + mask);
finally
Screen.Cursor := crDefault;
end;
ShowMessage(IntToStr(Count) + ' Files found');
end;
{**************************************}
{ Code from P. Below: }
// recursively scanning all drives
{ excerpt from form declaration, form has a listbox1 for the
results, a label1 for progress, a button2 to start the scan,
an edit1 to get the search mask from, a button3 to stop
the scan. }
private
{ Private declarations }
FScanAborted: Boolean;
public
{ Public declarations }
function ScanDrive(root, filemask: string; hitlist: TStrings): Boolean;
implementation
function TForm1.ScanDrive(root, filemask: string; hitlist: TStrings): Boolean;
function ScanDirectory(var path: string): Boolean;
var
SRec: TSearchRec;
pathlen: Integer;
res: Integer;
begin
label1.Caption := path;
pathlen := Length(path);
{ first pass, files }
res := FindFirst(path + filemask, faAnyfile, SRec);
if res = 0 then
try
while res = 0 do
begin
hitlist.Add(path + SRec.Name);
res := FindNext(SRec);
end;
finally
FindClose(SRec)
end;
Application.ProcessMessages;
Result := not (FScanAborted or Application.Terminated);
if not Result then Exit;
{second pass, directories}
res := FindFirst(path + '*.*', faDirectory, SRec);
if res = 0 then
try
while (res = 0) and Result do
begin
if ((Srec.Attr and faDirectory) = faDirectory) and
(Srec.Name <> '.') and
(Srec.Name <> '..') then
begin
path := path + SRec.Name + '\';
Result := ScanDirectory(path);
SetLength(path, pathlen);
end;
res := FindNext(SRec);
end;
finally
FindClose(SRec)
end;
end;
begin
FScanAborted := False;
Screen.Cursor := crHourglass;
try
Result := ScanDirectory(root);
finally
Screen.Cursor := crDefault
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
var
ch: Char;
root: string;
begin
root := 'C:\';
for ch := 'A' to 'Z' do
begin
root[1] := ch;
case GetDriveType(PChar(root)) of
DRIVE_FIXED, DRIVE_REMOTE:
if not ScanDrive(root, edit1.Text, listbox1.Items) then
Break;
end;
end;
end;
procedure TForm1.Button3Click(Sender: TObject);
begin // aborts scan
FScanAborted := True;
end;
|
Получить количество файлов в корзине и их общий размер.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
type
PSHQueryRBInfo = ^TSHQueryRBInfo;
TSHQueryRBInfo = packed record
cbSize: DWORD;
// Size of the structure, in bytes.
// This member must be filled in prior to calling the function.
i64Size: Int64;
// Total size of all the objects in the specified Recycle Bin, in bytes.
i64NumItems: Int64;
// Total number of items in the specified Recycle Bin.
end;
const
shell32 = 'shell32.dll';
function SHQueryRecycleBin(szRootPath: PChar; SHQueryRBInfo: PSHQueryRBInfo): HResult;
stdcall; external shell32 Name 'SHQueryRecycleBinA';
function GetDllVersion(FileName: string): Integer;
var
InfoSize, Wnd: DWORD;
VerBuf: Pointer;
FI: PVSFixedFileInfo;
VerSize: DWORD;
begin
Result := 0;
InfoSize := GetFileVersionInfoSize(PChar(FileName), Wnd);
if InfoSize <> 0 then
begin
GetMem(VerBuf, InfoSize);
try
if GetFileVersionInfo(PChar(FileName), Wnd, InfoSize, VerBuf) then
if VerQueryValue(VerBuf, '\', Pointer(FI), VerSize) then
Result := FI.dwFileVersionMS;
finally
FreeMem(VerBuf);
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
DllVersion: integer;
SHQueryRBInfo: TSHQueryRBInfo;
r: HResult;
begin
DllVersion := GetDllVersion(PChar(shell32));
if DllVersion >= $00040048 then
begin
FillChar(SHQueryRBInfo, SizeOf(TSHQueryRBInfo), #0);
SHQueryRBInfo.cbSize := SizeOf(TSHQueryRBInfo);
R := SHQueryRecycleBin(nil, @SHQueryRBInfo);
if r = s_OK then
begin
label1.Caption := Format('Size:%d Items:%d',
[SHQueryRBInfo.i64Size, SHQueryRBInfo.i64NumItems]);
end
else
label1.Caption := Format('Err:%x', [r]);
end;
end;
{
The SHQueryRecycleBin API used in this method is
only available on systems with the latest shell32.dll installed with IE4 /
Active Desktop.
}
Использовать Запись для сохранения информации из свойств различных классов.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{
Es ist manchmal interessant, Informationen die zusammen gehoren in Records
abzuspeichern. In einer Klassendeklaration kann der Record dann als
Sammelstelle benutzt werden, was zum einen die Ubersichtlichkeit des
Programmes erhoht, zum anderen eine gewisse Logik widderspiegelt.
Der Zugriff auf die einzelnen Felder des Records kann von au?erhalb
der Klasse mittels Eigenschaften (Properties) erfolgen, was zu besseren
Code fuhrt...
Letzlich konnen Records z.B. sehr einfach dann in Dateien abgespeichert
bzw. von dort aus wieder geladen werden. This wird dann in einem einzigen
Vorgang erledigt: das Speichern des Records.
}
{
You sometimes wish to store multiple information in a given class like
in the example: alltogether when it belongs together.
Thus accessing this information from out of the class can be achieved
using property declaration. Its a good way to "clean your code" and
make it as "logic" as possible.
You also may have to store or load information from your class using
file or stream technology. This can be done at once for the recorded
information from within the given class.
}
type
TPersonRecord = Record
FirstName: String;
LastName: String;
BirthDate: TDate;
End;
TForm4 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
fActualUser: TPersonRecord;
...
procedure SaveActualUser(S: TFileStream); // it's an example
procedure LoadActualUser(S: TFileStream);
...
public
property FirstName: string read fActualUser.FirstName
write fActualUser.FirstName;
property LastName : string read fActualUser.LastName
write fActualUser.LastName;
property BirthDate: TDate read fActualUser.BirthDate
write fActualUser.BirthDate;
end;
procedure TForm4.SaveActualUser(S: TFileStream);
begin
// All that stuff at once in your Stream
S.Write(fActualUser, SizeOf(fActualUser))
end;
procedure TForm4.LoadActualUser(S: TFileStream);
begin
// All that stuff at once back in your class
S.Read(fActualUser, SizeOf(fActualUser));
end;
Переопределить параметры формы при её создании.
Данный код позволяет создать окно без неклиентской области, но с толстым бордюром:
unit MainFrm;
interface
uses
SysUtils, Windows, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls;
type
TMainForm = class(TForm)
btnClose: TButton;
procedure btnCloseClick(Sender: TObject);
private
{ Private declarations }
protected
// Capture the WM_NCHITTEST message to enable moving the form.
procedure WMNCHitTest(var message: TWMNCHitTest); message WM_NCHITTEST;
public
{ Public declarations }
procedure CreateParams(var Params: TCreateParams); override;
end;
var
MainForm: TMainForm;
implementation
{$R *.DFM}
procedure TMainForm.WMNCHitTest(var message: TWMNCHitTest);
begin
inherited;
message.Result := HTCAPTION;
end;
procedure TMainForm.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.Style := WS_THICKFRAME or WS_POPUP or WS_BORDER;
end;
procedure TMainForm.btnCloseClick(Sender: TObject);
begin
Close;
end;
end.
|
FTP - докачка файлов.
| Периоды зачатия инетчика: 1. Connect 2. Download 3. Disconnect 4. UnZip (Estimated time: 9 месяцев) |
»»» Диман.
Как качать файлы через интернет по протоколу FTP я разобрался - послать команду RETR - и эдать файл. А какую команду нужно послать, что бы файл начал скачиваться не с начала а с определённого места - т.е. при обрыве связи докачать его. Может кто знает - подскажите. Или может знаете где раскопать инфу по этому вопросу?
»»» Wonder.
Читайте RFC 959 "File Transfer Protocol". А делается это просто:
REST [С_КАКОГО_БАЙТА_ПРОДОЛЖИТЬ] RETR [ИМЯ_ФАЙЛА] |
Но это только в том случае сработает, если FTP сервер поддерживает докачку.
»»» Диман.
В связи с этим 2 вопроса: Подскажите по какому адресу можно прочитать спецификацию RCF 959, а так же другие из этой серии Как определить - поддерживает ли сервер докачку файлов. Заранее спасибо.
»»» Wonder.
Как определить:
Как правило при входе на FTP сервер в т.н. Welcome message либо написано либо нет о поддержке докачки. Что-то типа "This server can resume broken downloads". Просто проверить, поддерживает сервер команду REST или нет. Проверить в смысле кода ответа (в RFC написаны все возможные коды ответов на все команды)Где взять:
Пойти на (например) http://www.yahoo.com и поискать "RFC" (ссылок море) Или воспользоваться (например) ссылкой http://src.doc.ic.ac.uk/computing/internet/rfc/rfc959.txtКак заставить перерисоваться все окна.
InvalidateRect(0, nil, true); |
Как уменьшить размер EXE-файла.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
Generally, EXE files created with Delphi are larger than EXE files created with another programming language. The reason is the VCL. (Sure, VCL has many advantages...) There are several ways to reduce a EXE''s size: 01) Use a EXE-Packer (UPX, ASPack,...) 02) Use KOL. 03) Write your application without VCL 04) Use the ACL (API Controls Library) 05) Use StripReloc. 06) Deactivate remote debugging information and TD32. 07) You might want to put code in a dll. 08) Don''t put the same images several times on a form. Load them at runtime. 09) Use compressed images (JPG and not BMP) 10) Store less properties in DFM files (See Link below "How To Make Your EXE''s Lighter") 11) Use the TStringList replacement by ~LOM~ Use the Minireg - TRegistry replacement by Ben Hochstrasser {*****************************************} Mit Delphi erstellte Exe-Dateien sind im allgemeinen einiges gгцssег als solche, welche mit anderen Programmiersprachen erzeugt wurden. Der Grund dаfьг ist die VCL. (Klar, Die VCL hat viele Vorteile...) Es gibt verschiedene Мцg1iсhкеitеn, um die Exe-Gгцssе zu reduzieren. 01) Einen EXE-Packer verwenden (UPX, ASPack, ....) 02) KOL verwenden. 03) Die Anwendung ohne VCL schreiben (nur mit API, nonVCL) 04) Die ACL (API Controls Library) verwenden. 05) StripReloc verwenden. 06) Debug Informationen und TD32 ausschalten. 07) Code in eine Dll auslagern. 08) Wenn Bilder mehrmals verwendet werden, dann nur einmal einbinden und die anderen zur Laufzeit laden. 09) Bilder komprimieren (nicht bmp sondern z.B das jpg Format verwenden) 10) Weniger Properties in den DFM Dateien speichern (Siehe Link unten ("How To Make Your EXE''s Lighter") 11) Verwende den TStringList Ersatz von ~LOM~ Verwende die Minireg - TRegistry Ersatz von Ben Hochstrasser {*****************************************} // Further descriptions and links: // Beschreibungen in Englisch und Links: {****************************************************************} 01) UPX is a free, portable, extendable, high-performance executable packer for several different executable formats. It achieves an excellent compression ratio and offers very fast decompression. Your executables suffer no memory overhead or other drawbacks. http://upx.sourceforge.net/ ASPack is an advanced Win32 executable file compressor, capable of reducing the file size of 32-bit Windows programs by as much as 70%. (ASPack''s compression ratio improves upon the industry-standard zip file format by as much as 10-20%.) ASPack makes Windows 95/98/NT programs and libraries smaller, and decrease load times across networks, and download times from the internet; it also protects programs against reverse engineering by non-professional hackers. Programs compressed with ASPack are self-contained and run exactly as before, with no runtime performance penalties. http://www.aspack.com/aspack.htm {****************************************************************} 02) KOL - Key Objects Library is a set of objects to develop power (but small) 32 bit Windows GUI applications using Delphi but without VCL. It is distributed free of charge, with source code. http://bonanzas.rinet.ru/ {****************************************************************} 03) nonVCL Delphi lets you have it both ways. If you want tiny EXE's, then don't use the VCL. Its entirely possible to use all the rich features of Delphi IDE using 100% WinAPI calls, standard resources, etc. http://nonvcl.luckie-online.de http://www.erm.tu-cottbus.de/delphi/stuff/Tutorials/nonVCL/index.html http://www.angelfire.com/hi5/delphizeus/ http://www.tutorials.delphi-source.de/nonvcl/ {****************************************************************} 04) ACL (API Controls Library) To write the program on pure API certainly it is possible, but I have deci- ded to reach both goals - both to make that program and to receive the tool, through which it would be possible in further to build similar programs, almost, as on Delphi with VCL. So the idea to create my own TWinControl and all standard Windows controls classes, derived from it has appeared. http://www.apress.ru/pages/bokovikov/delphi/index.html/ {****************************************************************} 05) StripReloc is a free (GPL license) command line utility that removes the relocation (".reloc") section from Win32 PE EXE files, reducing their size. Most compilers/linkers (including Delphi) put a relocation section in EXE files, but this is actually not necessary since EXEs never get relocated. Hence, a relocation section only wastes space. Why not use an EXE compressor? http://www.jrsoftware.org/striprlc.php {****************************************************************} 06) Deactivating the Debug Information Exclude any debug information for the final build (project-Options Compiler - Debugging and project-Options Linker EXE and DLL options) Dependeing on the amount of Debug information, Debugging can take up until half of the size. The options that are going to singificantly reduce your file size are "Include TD32 debug info" and "Build with runtime packages". If you are shipping commercial applications, you usually don''t need the debug info linked with your project. {****************************************************************} 08/09) About Images The forms in your project have any bitmaps on them, then these are compiled into the EXE. If you use the same bitmap multiple times, don''t assign them at design-time in the IDE as it will be included in the EXE multiple times, assign them in code instead. This can help reduce the size of the EXE, especially if you use large bitmaps. Use JPEG-files instead of BMP-files. This also reduces the EXE size. {****************************************************************} 10) How To Make Your EXE''s Lighter: http://www.undu.com/DN970301/00000064.htm {****************************************************************} 11) TStringList replacement by ~LOM~ Minireg - TRegistry replacementМожно ли как-то уменьшить мерцание при перерисовке компонента.
Если добавить флаг csOpaque (непрозрачный) к свойству ControlStyle компонента - то фон компонента перерисовываться не будет.
constructor TMyControl.Create; begin inherited; ControlStyle := ControlStyle + [csOpaque]; end; |
Обновление вычисляемых полей.
Автор: OAmiry (Borland)Разместите строчку типа нижеприведенной в конце кода обработчика события OnCalcFields:
{предположим, что вы используете DBGrid1}
if DBGrid1.Showing then
DBGrid1.Invalidate ;
|
Как заставить Рабочий Стол обновится.
procedure TForm1.Button1Click(Sender: TObject);
begin
SendMessage(FindWindow('Progman', 'Program Manager'),
WM_COMMAND, $A065, 0);
end;
|
Как заставить Рабочий Стол обновится 2.
procedure RefreshDesktop;
var
hDesktop: HWND;
begin
hDesktop := FindWindowEx(FindWindowEx(
FindWindow('Progman', 'Program Manager'), 0,
'SHELLDLL_DefView', ''), 0, 'SysListView32', '');
PostMessage(hDesktop, WM_KEYDOWN, VK_F5, 0);
PostMessage(hDesktop, WM_KEYUP, VK_F5, 1 shl 31);
end;
|
Как заставить Рабочий Стол обновится 3.
Автор: Radmin WEB-сайт: http://forum.vingrad.ru
winexec(Pchar('rundll32 user,repaintscreen'), sw_Show);
Обновить рабочий стол.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
uses ShlObj; procedure RefreshDesktop1; begin SHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_IDLIST, nil, nil); end;
Обновить список дисков TDriveComboBox с сетевыми дсками и Plug&Play.
| И вновь я не замечен Plug-n-Рlау'ем... |
type //это наш "class cracer" TNewDriveComboBox = class(TDriveComboBox) end; procedure TForm1.Button1Click(Sender: TObject); var Drive : char; begin Drive := DriveComboBox1.Drive; //вызываем защищенный метод родительского класса TNewDriveComboBox(DriveComboBox1).BuildList; DriveComboBox1.Drive := Drive; end; |
Обновление файла после перезагрузки системы.
Автор: Dimka Maslov WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Обновление файла после перезагрузки системы
Данная процедура настраивает систему для обновления файлов после перезагрузки.
TargetFileName - имя файла, содержиоме которого при перезагрузке будет заменено
на содержимое файла, имя которого укзаывается в параметре SourceFileName.
Если первый аргумент процедуры представляет собой пустую строку, при
перезагрузке файл SourceFileName будет удалён.
Зависимости: Windows
Автор: Dimka Maslov, mainbox@endimus.ru, ICQ:148442121, Санкт-Петербург
Copyright: Dimka Maslov
Дата: 18 ноября 2002 г.
***************************************************** }
procedure BootReplaceFile(TargetFileName, SourceFileName: string)
var
WinInitName: string;
P: PChar;
procedure InternalGetShortPathName(var S: string);
begin
UniqueString(S);
GetShortPathName(PChar(S), PChar(S), Length(S));
SetLength(S, StrLen(@S[1]));
CharToOEM(PChar(S), PChar(S));
end;
begin
if Win32Platform = VER_PLATFORM_WIN32_NT then
begin
if TargetFileName <> '' then
P := PChar(TargetFileName)
else
P := nil;
MoveFileEx(PChar(SourceFileName), P,
MOVEFILE_DELAY_UNTIL_REBOOT or MOVEFILE_REPLACE_EXISTING);
end
else
begin
SetLength(WinInitName, MAX_PATH);
GetWindowsDirectory(@WinInitName[1], MAX_PATH);
SetLength(WinInitName, StrLen(@WinInitName[1]));
WinInitName := IncludeTrailingBackslash(WinInitName) + 'WININIT.INI';
if TargetFileName = '' then
TargetFileName := 'NUL'
else
InternalGetShortPathName(TargetFileName);
InternalGetShortPathName(SourceFileName);
WritePrivateProfileString('Rename', PChar(TargetFileName),
PChar(SourceFileName), PChar(WinInit));
end;
end;
Пример использования:
// После перезагрузки содержимое первого файла будет заменено на
// содержимое второго файла, а второй файл будет удалён
BootReplaceFile('c:\Program Files\proga.exe', 'c:\temp\proga.exe');
// Указанный файл будет удалён после перезагрузки
BootReplaceFile('', 'c:\temp\proga.exe');
Как обновить TQuery не потеряв при этом текущей записи.
procedure RefreshQuery(AQuery: TQuery; const FieldsForSearch: string);
var
AList: TList;
AVarArray: Variant;
i: Byte;
begin
AList := TList.Create;
try
AQuery.GetFieldList(AList, FieldsForSearch);
AVarArray := VarArrayCreate([0, AList.Count - 1], varVariant);
for i := 0 to Pred(AList.Count) do
AVarArray[i] := TField(AList.Items[i]).AsVariant;
AQuery.Close;
AQuery.Open;
AQuery.Locate(FieldsForSearch, AVarArray, []);
finally
AList.Free;
AVarArray.Free;
end;
end;
|
Обновить иконки на экране.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{
Microsoft's Tweak UI has a feature 'rebuild icon cache now'.
Windows then rebuilds its internal cache of icons.
Unfortunately, there is no single API to do this.
}
uses
Registry;
function RefreshScreenIcons : Boolean;
const
KEY_TYPE = HKEY_CURRENT_USER;
KEY_NAME = 'Control Panel\Desktop\WindowMetrics';
KEY_VALUE = 'Shell Icon Size';
var
Reg: TRegistry;
strDataRet, strDataRet2: string;
procedure BroadcastChanges;
var
success: DWORD;
begin
SendMessageTimeout(HWND_BROADCAST,
WM_SETTINGCHANGE,
SPI_SETNONCLIENTMETRICS,
0,
SMTO_ABORTIFHUNG,
10000,
success);
end;
begin
Result := False;
Reg := TRegistry.Create;
try
Reg.RootKey := KEY_TYPE;
// 1. open HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics
if Reg.OpenKey(KEY_NAME, False) then
begin
// 2. Get the value for that key
strDataRet := Reg.ReadString(KEY_VALUE);
Reg.CloseKey;
if strDataRet <> '' then
begin
// 3. Convert sDataRet to a number and subtract 1,
// convert back to a string, and write it to the registry
strDataRet2 := IntToStr(StrToInt(strDataRet) - 1);
if Reg.OpenKey(KEY_NAME, False) then
begin
Reg.WriteString(KEY_VALUE, strDataRet2);
Reg.CloseKey;
// 4. because the registry was changed, broadcast
// the fact passing SPI_SETNONCLIENTMETRICS,
// with a timeout of 10000 milliseconds (10 seconds)
BroadcastChanges;
// 5. the desktop will have refreshed with the
// new (shrunken) icon size. Now restore things
// back to the correct settings by again writing
// to the registry and posing another message.
if Reg.OpenKey(KEY_NAME, False) then
begin
Reg.WriteString(KEY_VALUE, strDataRet);
Reg.CloseKey;
// 6. broadcast the change again
BroadcastChanges;
Result := True;
end;
end;
end;
end;
finally
Reg.Free;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
RefreshScreenIcons
end;
{
The result is Window's erasing all its icons, and recalculating them
based on the registry settings.
This means if you have changed a DefaultIcon key within the registry for
some application or file, Windows will display the new icon when the
refresh is completed.
Original source:
www.mvps.org/vbnet/index.html?code/reg/screenrefresh.htm
Translated from VB by Thomas Stutz
}
Перегенерировать все индексы с истекшей датой.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
procedure TForm1.Button1Click(Sender: TObject); begin Table.Close; Table.Exclusive := True; Table.Open; DbiRegenIndexes(Table.Handle); Table.Close; end;
Регионарные стандарты.
Автор: Vit WEB-сайт: http://forum.vingrad.ruВ Дельфи есть предопределенные переменные языковых установок и форматов:
// SysUtils var CurrencyString: string; var CurrencyFormat: Byte; var NegCurrFormat: Byte; var ThousandSeparator: Char; var DecimalSeparator: Char; var CurrencyDecimals: Byte; var DateSeparator: Char; var ShortDateFormat: string; var LongDateFormat: string; var TimeSeparator: Char; var TimeAMString: string; var TimePMString: string; var ShortTimeFormat: string; var LongTimeFormat: string; var ShortMonthNames: array[1..12] of string; var LongMonthNames: array[1..12] of string; var ShortDayNames: array[1..7] of string; var LongDayNames: array[1..7] of string; var SysLocale: TSysLocale; var EraNames: array[1..7] of string; var EraYearOffsets: array[1..7] of Integer; var TwoDigitYearCenturyWindow: Word = 50; var TListSeparator: Char;
Как зарегистрировать ActiveX-компонент (OCX-файл) на компьютере пользователя.
| Программер (П) привел к себе домой девушку (Д). Посидели, поболтали, программеру не терпится в постель перейти. Он думает "Щаз вот покажу ей, какой у меня Виндоуз последней версии стоит, она скажет "Ого, какой у тебя Виндоуз!", а я ей- "Да ну его, пошли лучше потрахаемся." Показал, она - ноль эмоций. П опять думает: "Так... Ну ладно, щаз покажу ей, какой у меня модем крутой, на 33600, она скажет "Ого, какой у тебя модем весь крутой!", а я ей - "Да ну его, пошли лучше потрахаемся!" Показал, та же реакция. Программер думает: "Блин, ну что бы ей еще показать? Во, придумал, покажу ей, какой у меня ноутбук весь белой сборки, она скажет "Ого, какой у тебя ноутбук весь белый!", а я ей- "Да ну его, пошли лучше потрахаемся!" Показал. Девушка: (Д): Слушай, а может, да ну все это, пошли лучше потрахаемся! (П): Какое потрахаемся, ты смотри, какой у меня ноутбук весь белый! |
Из командной строки:
| C:\WINDOWS\SYSTEM\REGSVR32.EXE "c:\my path\myocx.ocx" |
Регистрация компонент.
C:\WINNT\system32\regsvr32.exe "c:\AGUN\VoiceMan\FRALIBCS.DLL" |
Зарегистрировать новый тип файлов.
| Возлюбленная компьютерщика мурлычет ему на ушко: - Любимый, ну когда, когда мы будем регистрироваться? - А на хр#на? Я сейчас и так взломаю... |
Не хуже M$ получается! У них свои типы файлов, и у нас будут свои! Всё, что для этого нужно - точно выполнять последовательность действий и научиться копировать в буфер, чтобы не писать все те коды, что будут тут изложены :)).
Сначала, естественно, объявляем в uses модуль Registry.
uses Registry; |
Затем в публичных объявлениях объявляем процедуру регистрации нового типа файлов:
public
{ Public declarations }
procedure RegisterFileType(ext: string; FileName: string);
|
Описываем её так:
procedure TForm1.RegisterFileType(ext: string; FileName: string);
var
reg: TRegistry;
begin
reg:=TRegistry.Create;
with reg do
begin
RootKey:=HKEY_CLASSES_ROOT;
OpenKey('.'+ext,True);
WriteString('',ext+'file');
CloseKey;
CreateKey(ext+'file');
OpenKey(ext+'file\DefaultIcon',True);
WriteString('',FileName+',0');
CloseKey;
OpenKey(ext+'file\shell\open\command',True);
WriteString('',FileName+' "%1"');
CloseKey;
Free;
end;
end;
|
Ну а по нажатию какого-нибудь батона регистрируем!
procedure TForm1.Button1Click(Sender: TObject);
begin
RegisterFileType('DelphiWorld', Application.ExeName);
end;
|
Как зарегистрировать OCX.
Вы правы, прежде чем использовать OCX, его необходимо зарегистрировать в системном регистре. Предположим вы создали OCX с именем "test.ocx".Теперь его необходимо зарегистрировать в системе:
var
OCXHand: THandle;
RegFunc: TDllRegisterServer; //добавьте OLECtl в список используемых модулей
begin
OCXHand := LoadLibrary('c:\windows\system\test.ocx');
RegFunc := GetProcAddress(OCXHand, 'DllRegisterServer');
//чуствительность к регистру?
if RegFunc <> 0 then
ShowMessage('Ошибка!');
FreeLibrary(OCXHand);
end;
|
OCX - специфический форма dll, поэтому вы можете загрузить ее в память, используя знакомую уже API функцию LoadLibrary(). OCX экспортирует две функции, осуществляющие ее регистрацию и "отрегистрацию". Для получения адреса этих функций используется соответствующая функция GetProcAddress. После этого остается только вызвать необходимую функцию. И это все! После этого для успокоения души с помощью редактора регистров (regedit.exe) вы можете проверить регистрацию вашего OCX.
Регистрация редактора свойства.
Автор: Mike Scott(Mobius Ltd.)Скажем, вы имеете компонент TContainer, содержащий TContainedClass в свойстве с именем 'Contained' - попробуйте добавить следующую строку к процедуре Register вашего компонента:
RegisterPropertyEditor( TypeInfo( TContainedClass ), TContainer, 'Contained', TClassProperty ) ; |
Все это задокументировано в справке помощи. Первым параметром всегда идет TypeInfo() с "коллекционируемым" классом в качестве параметра, затем контейнерный класс или NIL, если он должен работать для всех экземпляров контейнерного класса с заданным свойством, затем идет имя контейнерного свойства или '', если редактор должен работать для всех свойств, и завершает славную четверку параметров класс TClassProperty, расширяющий классовое свойство, т.е. "создающий" знак "+" в Инспекторе Объектов, позволяющий редактировать вложенные свойства (щелчок на плюсике раскрывает список вложенных свойств описываемого контейнерного класса).
Регистрация WinZip 7.0 (beta).
| Если мысль не укладывается в голове, заархивируйте ее. |
В этой статье мы попытаемся почувствовать себя настоящими исследователями программ. Конечно, это будут только первые робкие шаги, но именно они обычно являются определяющими для всей остальной работы в этом направлении. Нашей целью будет регистрация всемирно известной программы WinZip 7.0 (beta). В статье рассматривается build 1243, для более новой программы возможны некоторые отличия в адресах.
Устанавливаем и запускаем WinZip. Сразу после старта появляется окно, сообщающее о том, что программа не зарегистрирована. Если программу не зарегистрировать это окно будет появляться при каждом новом запуске. Это неудобно! В меню Help выбираем пункт About WinZip... В появившемся окне нажимаем кнопку Register. Открывается окно регистрации. Вводим в поле Имя имя, под которым хотим зарегистрировать программу (я использовал Fox Mulder). В поле РН вводим любую информацию (я обычно использую 200001, чтобы потом при необходимости его легко было опознать) и нажимаем кнопку ОК. Появляется окно, сообщающее, что введена неполная или неверная информация. Обращаю Ваше внимание на это окно. Это типичное окно MessageBox (окно сообщения). Его отличительными чертами являются:
неактивная кнопка закрытия окна наличие внутри окна иконки (вид иконки зависит от типа сообщения) наличие одной или нескольких кнопок (их названия и количество также зависит от типа сообщения)В программе окно MessageBox может создаваться с помощью четырех функций: MessageBox(), MessageBoxA(), MessageBoxIndirect() и MessageBoxIndirectA(). Функции, не оканчивающиеся символом A (MessageBox(), MessageBoxIndirect()) используются преимущественно приложениями Win16 (Windows 3.x) и на них мы будем рассчитывать меньше всего. Остаются две функции: MessageBoxA() и MessageBoxIndirectA(). Какая из них используется программой, определяем опытным путем:
Закрываем окно сообщения Активизируем SoftICE (Ctrl+D) Устанавливаем точки прерывания на вызов MessageBoxA() и MessageBoxIndirectA() (bpx MessageBoxA, bpx MessageBoxIndirectA) Возвращаемся в Windows (F5)Нажимаем кнопку ОК в окне регистрации, программа прерывается при вызове функции и передает управление SoftICE. В окне команд сообщается, что программа прервалась при вызове функции MessageBoxIndirectA() из модуля USER32. И действительно в окне кода мы видим, что курсор стоит на первой строке этой функции и, что имя текущего модуля USER32 (написано внизу окна кода). Дальше мы тоже знаем, что делать:
Нажимаем F12 (команда p ret), для продолжения программы до выполнения команды ret. Перед нами вновь появляется знакомое окно сообщения, при нажатии в нем на кнопку ОК программа прерывается и управление передается SoftICE. Мы видим, что теперь программа остановилась в модуле WINZIP32:
0137:00426920 FF15C4AF4700 call [USER32!MessageBoxIndirectA] 0137:00426926 EB14 jmp 0042693C |
Вот мы и нашли то место, где вызывается функция MessageBoxIndirectA() и создается окно сообщения. Теперь можно удалить установленные точки прерывания (команда bc *), т.к. они нам больше не понадобятся. В этой статье мы больше ничего, связанного с функцией MessageBoxIndirectA(), не узнаем. Использовали мы ее по двум причинам:
Чтобы Вы научились устанавливать точки прерывания на вызовы API-функций, и находит место их вызова в программе. Чтобы прервать программу в модуле WINZIP32. Это необходимо для установки точек прерывания на конкретные адреса в памяти. Как я уже говорил в статье о распределении памяти, каждая программа работает в своем адресном пространстве. Причем, практически у всех запущенных приложений есть разные участки кода с одинаковыми адресами. Поэтому, для установки точки прерывания на некоторый адрес памяти кроме самого этого адреса, необходимо еще правильно указать нужное адресное пространство (или модуль, что в данном случае одно и тоже). Особенностью SoftICE является то, что он устанавливает точку прерывания на адрес в том модуле, в котором прервалось выполнение. Вот почему, для установки точки прерывания на адрес памяти (нам ее еще только предстоит установить) пришлось воспользоваться точкой прерывания на вызов функции MessageBoxIndirectA()Здесь уместным был бы Ваш вопрос о том, почему для установки этой точки прерывания не пришлось прибегать к каким-либо хитростям? Все очень просто! Точка прерывания на вызов MessageBoxIndirectA() устанавливается на первую команду кода этой функции в модуле USER32. Этот модуль находится в области памяти, которая является общей для всех запущенных приложений Windows (она расположена выше 2-го Гб), поэтому здесь никаких трудностей не возникает.
Итак, продолжим:
Мы все еще находимся в SoftICE. Устанавливаем точку прерывания на выполнение команды по адресу 00407CA5 (команда bpx 407CA5). Выходим в Windows (F5) и вновь пытаемся зарегистрироваться. При этом программа прерывается при выполнении команды по адресу 00407CA5, в окне команд SoftICE сообщается, что программа остановилась на точке прерывания по адресу 0137:00407CA5. Вводим команду db eax (показать в окне данных содержимое памяти в виде байт, начиная с адреса, содержащегося в регистре eax) и переписываем 8 символов нашего регистрационного номера (у меня это 409A11AA). Убираем не нужную уже точку прерывания (команда bc *) и выходим в Windows (F5). Наступает решающий момент. Вводим в поле РН полученный регистрационный номер и нажимаем кнопку ОК. Программа просит подтвердить регистрационную информацию, и после нажатия ОК Вы уже являетесь владельцем личного WinZiр'а.Я надеюсь, Вас посетило чувство гордости, как оно посещает меня всегда, когда я справляюсь с чем-либо сложным и поначалу непонятным. Иногда, очень приятно почувствовать, что ты тоже чего-то стоишь в этой жизни! На этом наша очередная статья закончена. Не смущайтесь, если Вы чего-то не поняли, я не ставил целью объяснить Вам все в мельчайших подробностях в самый первый Ваш раз. Нет, я хотел, чтобы Вы узнали, с чем мы будем иметь дело, и что после успешной работы чувствует настоящий Исследователь Программ.
Регистры - доступ и использование вместо WIN.INI.
| Плачет молодая забеременевшая программистка, слезами заливается. Над ней висит мать: - Да как ты могла? Да как ты посмела? Где твои глаза были? Программистка: - А он обещал стать зарегистрированным пользователем... |
uses
Registry, Windows;
var
TheReg: TRegistry;
KeyName: string;
ValueStr: string;
begin
TheReg := TRegistry.Create;
try
TheReg.RootKey := HKEY_CURRENT_USER;
KeyName := 'Software\MyTinyApp\StartUp';
if TheReg.OpenKey(KeyName, False) then
begin
ValueStr := TheReg.ReadString('WorkPath');
TheReg.CloseKey;
end;
finally
TheReg.Free;
end;
end;
|
Также имейте в виду, что корректное место для сохранения пути к вашему приложению (EXE-файлу) в регистрах Win95 находится по адресу:
HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\AppPaths\MYAPP.EXE |
Сохранение полного пути к вашему приложению (EXE-файлу) позволит пользователю запустить его, просто набрав MYAPP (зарегистрированное имя) в стартовом меню Start|Run. Вот пример, регистрирующий путь к вашему приложению:
uses
Registry, Regstr;
var
TheReg: TRegistry;
KeyName: string;
begin
TheReg := TRegistry.Create;
try
{Проверяем установку AppPath и при необходимости корректируем}
TheReg.RootKey := HKEY_LOCAL_MACHINE;
KeyName := REGSTR_PATH_APPPATHS + ExtractFileName(Application.ExeName);
if TheReg.OpenKey(KeyName, True) then
begin
if CompareText(TheReg.ReadString(''), Application.ExeName) <> 0 then
TheReg.WriteString('', Application.ExeName);
TheReg.CloseKey;
end;
finally
TheReg.Free;
end;
end;
|
Как работать с реестром, используя только WinAPI.
Автор: i-s-v
unit apiregistry;
interface
uses Windows;
function RegSetString(RootKey: HKEY; Name: string; Value: string): boolean;
function RegSetMultiString(RootKey: HKEY; Name: string; Value: string): boolean;
function RegSetExpandString(RootKey: HKEY; Name: string; Value: string): boolean;
function RegSetDWORD(RootKey: HKEY; Name: string; Value: Cardinal): boolean;
function RegSetBinary(RootKey: HKEY; Name: string; Value: array of Byte): boolean;
function RegGetString(RootKey: HKEY; Name: string; var Value: string): boolean;
function RegGetMultiString(RootKey: HKEY; Name: string; var Value: string): boolean;
function RegGetExpandString(RootKey: HKEY; Name: string; var Value: string): boolean;
function RegGetDWORD(RootKey: HKEY; Name: string; var Value: Cardinal): boolean;
function RegGetBinary(RootKey: HKEY; Name: string; var Value: string): boolean;
function RegGetValueType(RootKey: HKEY; Name: string; var Value: Cardinal): boolean;
function RegValueExists(RootKey: HKEY; Name: string): boolean;
function RegKeyExists(RootKey: HKEY; Name: string): boolean;
function RegDelValue(RootKey: HKEY; Name: string): boolean;
function RegDelKey(RootKey: HKEY; Name: string): boolean;
function RegConnect(MachineName: string; RootKey: HKEY; var RemoteKey: HKEY): boolean;
function RegDisconnect(RemoteKey: HKEY): boolean;
function RegEnumKeys(RootKey: HKEY; Name: string; var KeyList: string): boolean;
function RegEnumValues(RootKey: HKEY; Name: string; var ValueList: string): boolean;
implementation
function LastPos(Needle: Char; Haystack: string): integer;
begin
for Result := Length(Haystack) downto 1 do
if Haystack[Result] = Needle then
Break;
end;
function RegConnect(MachineName: string; RootKey: HKEY; var RemoteKey: HKEY):
boolean;
begin
Result := (RegConnectRegistry(PChar(MachineName), RootKey, RemoteKey) =
ERROR_SUCCESS);
end;
function RegDisconnect(RemoteKey: HKEY): boolean;
begin
Result := (RegCloseKey(RemoteKey) = ERROR_SUCCESS);
end;
function RegSetValue(RootKey: HKEY; Name: string; ValType: Cardinal; PVal:
Pointer; ValSize: Cardinal): boolean;
var
SubKey: string;
n: integer;
dispo: DWORD;
hTemp: HKEY;
begin
Result := False;
n := LastPos('\', Name);
if n > 0 then
begin
SubKey := Copy(Name, 1, n - 1);
if RegCreateKeyEx(RootKey, PChar(SubKey), 0, nil, REG_OPTION_NON_VOLATILE,
KEY_WRITE,
nil, hTemp, @dispo) = ERROR_SUCCESS then
begin
SubKey := Copy(Name, n + 1, Length(Name) - n);
Result := (RegSetValueEx(hTemp, PChar(SubKey), 0, ValType, PVal, ValSize)
= ERROR_SUCCESS);
RegCloseKey(hTemp);
end;
end;
end;
function RegGetValue(RootKey: HKEY; Name: string; ValType: Cardinal; var PVal:
Pointer;
var ValSize: Cardinal): boolean;
var
SubKey: string;
n: integer;
MyValType: DWORD;
hTemp: HKEY;
Buf: Pointer;
BufSize: Cardinal;
begin
Result := False;
n := LastPos('\', Name);
if n > 0 then
begin
SubKey := Copy(Name, 1, n - 1);
if RegOpenKeyEx(RootKey, PChar(SubKey), 0, KEY_READ, hTemp) = ERROR_SUCCESS
then
begin
SubKey := Copy(Name, n + 1, Length(Name) - n);
if RegQueryValueEx(hTemp, PChar(SubKey), nil, @MyValType, nil, @BufSize) =
ERROR_SUCCESS then
begin
GetMem(Buf, BufSize);
if RegQueryValueEx(hTemp, PChar(SubKey), nil, @MyValType, Buf, @BufSize)
= ERROR_SUCCESS then
begin
if ValType = MyValType then
begin
PVal := Buf;
ValSize := BufSize;
Result := True;
end
else
begin
FreeMem(Buf);
end;
end
else
begin
FreeMem(Buf);
end;
end;
RegCloseKey(hTemp);
end;
end;
end;
function RegSetString(RootKey: HKEY; Name: string; Value: string): boolean;
begin
Result := RegSetValue(RootKey, Name, REG_SZ, PChar(Value + #0), Length(Value)
+ 1);
end;
function RegSetMultiString(RootKey: HKEY; Name: string; Value: string): boolean;
begin
Result := RegSetValue(RootKey, Name, REG_MULTI_SZ, PChar(Value + #0#0),
Length(Value) + 2);
end;
function RegSetExpandString(RootKey: HKEY; Name: string; Value: string):
boolean;
begin
Result := RegSetValue(RootKey, Name, REG_EXPAND_SZ, PChar(Value + #0),
Length(Value) + 1);
end;
function RegSetDword(RootKey: HKEY; Name: string; Value: Cardinal): boolean;
begin
Result := RegSetValue(RootKey, Name, REG_DWORD, @Value, SizeOf(Cardinal));
end;
function RegSetBinary(RootKey: HKEY; Name: string; Value: array of Byte):
boolean;
begin
Result := RegSetValue(RootKey, Name, REG_BINARY, @Value[Low(Value)],
length(Value));
end;
function RegGetString(RootKey: HKEY; Name: string; var Value: string): boolean;
var
Buf: Pointer;
BufSize: Cardinal;
begin
Result := False;
if RegGetValue(RootKey, Name, REG_SZ, Buf, BufSize) then
begin
Dec(BufSize);
SetLength(Value, BufSize);
if BufSize > 0 then
CopyMemory(@Value[1], Buf, BufSize);
FreeMem(Buf);
Result := True;
end;
end;
function RegGetMultiString(RootKey: HKEY; Name: string; var Value: string):
boolean;
var
Buf: Pointer;
BufSize: Cardinal;
begin
Result := False;
if RegGetValue(RootKey, Name, REG_MULTI_SZ, Buf, BufSize) then
begin
Dec(BufSize);
SetLength(Value, BufSize);
if BufSize > 0 then
CopyMemory(@Value[1], Buf, BufSize);
FreeMem(Buf);
Result := True;
end;
end;
function RegGetExpandString(RootKey: HKEY; Name: string; var Value: string):
boolean;
var
Buf: Pointer;
BufSize: Cardinal;
begin
Result := False;
if RegGetValue(RootKey, Name, REG_EXPAND_SZ, Buf, BufSize) then
begin
Dec(BufSize);
SetLength(Value, BufSize);
if BufSize > 0 then
CopyMemory(@Value[1], Buf, BufSize);
FreeMem(Buf);
Result := True;
end;
end;
function RegGetDWORD(RootKey: HKEY; Name: string; var Value: Cardinal): boolean;
var
Buf: Pointer;
BufSize: Cardinal;
begin
Result := False;
if RegGetValue(RootKey, Name, REG_DWORD, Buf, BufSize) then
begin
CopyMemory(@Value, Buf, BufSize);
FreeMem(Buf);
Result := True;
end;
end;
function RegGetBinary(RootKey: HKEY; Name: string; var Value: string): boolean;
var
Buf: Pointer;
BufSize: Cardinal;
begin
Result := False;
if RegGetValue(RootKey, Name, REG_BINARY, Buf, BufSize) then
begin
SetLength(Value, BufSize);
CopyMemory(@Value[1], Buf, BufSize);
FreeMem(Buf);
Result := True;
end;
end;
function RegValueExists(RootKey: HKEY; Name: string): boolean;
var
SubKey: string;
n: integer;
hTemp: HKEY;
begin
Result := False;
n := LastPos('\', Name);
if n > 0 then
begin
SubKey := Copy(Name, 1, n - 1);
if RegOpenKeyEx(RootKey, PChar(SubKey), 0, KEY_READ, hTemp) = ERROR_SUCCESS
then
begin
SubKey := Copy(Name, n + 1, Length(Name) - n);
Result := (RegQueryValueEx(hTemp, PChar(SubKey), nil, nil, nil, nil) =
ERROR_SUCCESS);
RegCloseKey(hTemp);
end;
end;
end;
function RegGetValueType(RootKey: HKEY; Name: string; var Value: Cardinal):
boolean;
var
SubKey: string;
n: integer;
hTemp: HKEY;
ValType: Cardinal;
begin
Result := False;
Value := REG_NONE;
n := LastPos('\', Name);
if n > 0 then
begin
SubKey := Copy(Name, 1, n - 1);
if (RegOpenKeyEx(RootKey, PChar(SubKey), 0, KEY_READ, hTemp) = ERROR_SUCCESS)
then
begin
SubKey := Copy(Name, n + 1, Length(Name) - n);
Result := (RegQueryValueEx(hTemp, PChar(SubKey), nil, @ValType, nil, nil)
= ERROR_SUCCESS);
if Result then
Value := ValType;
RegCloseKey(hTemp);
end;
end;
end;
function RegKeyExists(RootKey: HKEY; Name: string): boolean;
var
SubKey: string;
n: integer;
hTemp: HKEY;
begin
Result := False;
n := LastPos('\', Name);
if n > 0 then
begin
SubKey := Copy(Name, 1, n - 1);
if RegOpenKeyEx(RootKey, PChar(SubKey), 0, KEY_READ, hTemp) = ERROR_SUCCESS
then
begin
Result := True;
RegCloseKey(hTemp);
end;
end;
end;
function RegDelValue(RootKey: HKEY; Name: string): boolean;
var
SubKey: string;
n: integer;
hTemp: HKEY;
begin
Result := False;
n := LastPos('\', Name);
if n > 0 then
begin
SubKey := Copy(Name, 1, n - 1);
if RegOpenKeyEx(RootKey, PChar(SubKey), 0, KEY_WRITE, hTemp) = ERROR_SUCCESS
then
begin
SubKey := Copy(Name, n + 1, Length(Name) - n);
Result := (RegDeleteValue(hTemp, PChar(SubKey)) = ERROR_SUCCESS);
RegCloseKey(hTemp);
end;
end;
end;
function RegDelKey(RootKey: HKEY; Name: string): boolean;
var
SubKey: string;
n: integer;
hTemp: HKEY;
begin
Result := False;
n := LastPos('\', Name);
if n > 0 then
begin
SubKey := Copy(Name, 1, n - 1);
if RegOpenKeyEx(RootKey, PChar(SubKey), 0, KEY_WRITE, hTemp) = ERROR_SUCCESS
then
begin
SubKey := Copy(Name, n + 1, Length(Name) - n);
Result := (RegDeleteKey(hTemp, PChar(SubKey)) = ERROR_SUCCESS);
RegCloseKey(hTemp);
end;
end;
end;
function RegEnum(RootKey: HKEY; Name: string; var ResultList: string; const
DoKeys: Boolean): boolean;
var
i: integer;
iRes: integer;
s: string;
hTemp: HKEY;
Buf: Pointer;
BufSize: Cardinal;
begin
Result := False;
ResultList := '';
if RegOpenKeyEx(RootKey, PChar(Name), 0, KEY_READ, hTemp) = ERROR_SUCCESS then
begin
Result := True;
BufSize := 1024;
GetMem(buf, BufSize);
i := 0;
iRes := ERROR_SUCCESS;
while iRes = ERROR_SUCCESS do
begin
BufSize := 1024;
if DoKeys then
iRes := RegEnumKeyEx(hTemp, i, buf, BufSize, nil, nil, nil, nil)
else
iRes := RegEnumValue(hTemp, i, buf, BufSize, nil, nil, nil, nil);
if iRes = ERROR_SUCCESS then
begin
SetLength(s, BufSize);
CopyMemory(@s[1], buf, BufSize);
if ResultList = '' then
ResultList := s
else
ResultList := Concat(ResultList, #13#10,s);
inc(i);
end;
end;
FreeMem(buf);
RegCloseKey(hTemp);
end;
end;
function RegEnumValues(RootKey: HKEY; Name: string; var ValueList: string):
boolean;
begin
Result := RegEnum(RootKey, Name, ValueList, False);
end;
function RegEnumKeys(RootKey: HKEY; Name: string; var KeyList: string): boolean;
begin
Result := RegEnum(RootKey, Name, KeyList, True);
end;
end.
Браузер по реестру.
unit main;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Grids, Outline, ComCtrls, ImgList, ExtCtrls;
type
TRegForm = class(TForm)
TreeView1: TTreeView;
ListView1: TListView;
ImageList1: TImageList;
ImageList2: TImageList;
Splitter1: TSplitter;
procedure FormCreate(Sender: TObject);
procedure TreeView1Change(Sender: TObject; Node: TTreeNode);
procedure FormDestroy(Sender: TObject);
procedure TreeView1Expanded(Sender: TObject; Node: TTreeNode);
procedure TreeView1GetImageIndex(Sender: TObject; Node: TTreeNode);
private
{ Private declarations }
public
{ Public declarations }
procedure ShowSubKeys(ParentNode: TTreeNode; depth: Integer);
function GetFullNodeName(Node: TTreeNode): string;
end;
var
RegForm: TRegForm;
implementation
uses registry;
{$R *.DFM}
var reg: TRegistry;
function TRegForm.GetFullNodeName(Node: TTreeNode): string;
var CurNode: TTreeNode;
begin
Result := ''; CurNode := Node;
while CurNode.Parent <> nil do
begin
Result := '\' + CurNode.Text + Result;
CurNode := CurNode.Parent;
end;
end;
procedure TRegForm.TreeView1Change(Sender: TObject; Node: TTreeNode);
var s: string;
KeyInfo: TRegKeyInfo;
ValueNames: TStringList;
i: Integer;
DataType: TRegDataType;
begin
ListView1.Items.Clear;
s := GetFullNodeName(Node);
if not Reg.OpenKeyReadOnly(s) then Exit;
Reg.GetKeyInfo(KeyInfo);
if KeyInfo.NumValues <= 0 then Exit;
ValueNames := TStringList.Create;
Reg.GetValueNames(ValueNames);
for i := 0 to ValueNames.Count - 1 do
with ListView1.Items.Add do
begin
Caption := ValueNames[i];
DataType := Reg.GetDataType(ValueNames[i]);
case DataType of
rdString: s := Reg.ReadString(ValueNames[i]);
rdInteger: s := '0x' + IntToHex(Reg.ReadInteger(ValueNames[i]), 8);
rdBinary: s := 'Binary';
else s := '???';
end;
SubItems.Add(s);
ImageIndex := 1;
end;
ValueNames.Free;
end;
procedure TRegForm.ShowSubKeys(ParentNode: TTreeNode; depth: Integer);
var ParentKey: string;
KeyNames: TStringList;
KeyInfo: TRegKeyInfo;
CurNode: TTreeNode;
i: Integer;
begin
Cursor := crHourglass;
TreeView1.Items.BeginUpdate;
ParentKey := GetFullNodeName(ParentNode);
if ParentKey <> '' then
Reg.OpenKeyReadOnly(ParentKey)
else
Reg.OpenKeyReadOnly('\');
Reg.GetKeyInfo(KeyInfo);
if KeyInfo.NumSubKeys <= 0 then Exit;
KeyNames := TStringList.Create;
Reg.GetKeyNames(KeyNames);
while ParentNode.GetFirstChild <> nil do ParentNode.GetFirstChild.Delete;
if (KeyNames.Count > 0) then for i := 0 to KeyNames.Count - 1 do
begin
Reg.OpenKeyReadOnly(ParentKey + '\' + KeyNames[i]);
Reg.GetKeyInfo(KeyInfo);
CurNode := TreeView1.Items.AddChild(ParentNode, KeyNames[i]);
if KeyInfo.NumSubKeys > 0 then
begin
TreeView1.Items.AddChild(CurNode, ''); //
end;
end;
KeyNames.Free;
TreeView1.Items.EndUpdate;
Cursor := crDefault;
end;
procedure TRegForm.FormCreate(Sender: TObject);
var root: TTreeNode;
begin
Reg := TRegistry.Create;
ListView1.ViewStyle := vsReport;
with ListView1 do
begin
with Columns.Add do begin Width := ListView1.Width div 3 - 2; Caption := 'Name'; end;
with Columns.Add do begin Width := ListView1.Width div 3 * 2 - 2; Caption := 'Value'; end;
end;
TreeView1.Items.Clear;
Reg.RootKey := HKEY_LOCAL_MACHINE;
Root := TreeView1.Items.Add(nil, 'HKEY_LOCAL_MACHINE');
TreeView1.Items.AddChild(root, '');
end;
procedure TRegForm.FormDestroy(Sender: TObject);
begin
Reg.Free;
end;
procedure TRegForm.TreeView1Expanded(Sender: TObject; Node: TTreeNode);
begin
ShowSubKeys(Node, 1);
end;
procedure TRegForm.TreeView1GetImageIndex(Sender: TObject; Node: TTreeNode);
begin
with Node do
begin
if Expanded then ImageIndex := 2
else ImageIndex := 3;
end;
end;
end.
Скачать весь проект
Экспорт и импорт из реестра.
Reg-файлы это, как и ожидалось, формат, понимаемый и поддерживаемый сугубо программой regedit.
Командная строка у неё такая:
Импорт в реестр:
regedit RegData.reg |
regedit /e RegData.reg HKEY_LOCAL_MACHINE\Software\Microsoft\Windows |
Если в параметрах встречаются пробелы, их ессно надо заключать в кавычки. Код в Delphi, который экспортирует ветвь реестра может быть например такой:
uses
ShellApi;
procedure TMain.ExportBtnClick(Sender: TObject);
var
FileName, Key: string;
begin
FileName := ... //заполнить именем файла (расширение указывать)
Key := ... //заполнить именем ключа, типа
//Key := 'HKEY_LOCAL_MACHINE\Software\Microsoft\Windows NT\CurrentVersion'
if ShellExecute(Handle, 'open', 'regedit.exe',
PChar(Format('/e "%s" "%s"', [FileName, Key])),
'', SW_SHOWDEFAULT) then //если ошибка, то возвращаемый код
RaiseLastWin32Error();
end;
|
Как можно определить доступные сервера приложений на этой машине через Registry.
| Автор: Nomadic |
| Встречаются два системных администратора, и один спрашивает другого: - Ты чего такой грустный? - Да вот сервер вчера "упал". - Ну да ты что, его до сих пор не "поднял"? - Поднял, но он со стола упал... |
Ниже пример, который загружает имена доступных серверов приложений в Listbox:
uses Registry;
procedure TForm1.FormCreate(Sender: TObject);
var
I: integer;
TempList: TStringList;
begin
TempList := TStringList.Create;
try
with TRegistry.Create do
try
RootKey := HKEY_CLASSES_ROOT;
if OpenKey('CLSID', False) then
GetKeyNames(TempList);
CloseKey;
for I := 1 to TempList.Count - 1 do
if KeyExists('CLSID\' + TempList[I] + '\Borland DataBroker') then
begin
if OpenKey('CLSID\' + TempList[I] + '\ProgID', False) then
begin
Listbox1.Items.Add(ReadString(''));
CloseKey;
end;
end;
finally
Free;
end;
finally
TempList.Free;
end;
end;
|
Как из Delphi влиять на реестр (Изменить заголовок корзины).
| - Что такое "Мелкие мягкие делишки для маленьких мягких окошечек"? - Microsoft Works for Microsoft Windows. |
Алгоритм взаимодействия Delphi с системным реестром весьма прост.
Для этого нужно:
В области uses объявить модуль Registry:
uses Registry; |
var a: TRegistry; |
a := TRegistry.Create; |
a.RootKey := HKEY_CLASSES_ROOT; |
a.OpenKey('\CLSID\{645FF040-5081-101B-9F08-00AA002F954E}', false);
|
В данном случае, мы хотим изменить заголовок корзины, т.е. хотим внести данные в реестр, данные строкового типа - поэтому используем метод WriteString:
a.WriteString('', 'Мусорка');
|
Методу нужно указать 2 параметра: сначала имя параметра, затем заносимое значение. В качестве имени параметра мы не указываем ничего, п.ч. в указанном нами ключе имя корзины - это параметр по умолчанию. В качестве значения можно указать всё, что угодно, например, 'Мусорка'.
После того как мы сделали своё грязное дело, нужно замести следы: сначала закрыть ключ:
a.CloseKey; |
А затем освободить выделенную нами память:
a.Free; |
ВСЁ! ТЕПЕРЬ МЫ МОЖЕТ СПОКОЙНО ГУЛЯТЬ ПО ВСЕМУ РЕЕСТРУ, И ДЕЛАТЬ ЖИЗНЬ БЕДНОГО ЛАМЕРА НЕВЫНОСИМОЙ!
Удобная загрузка местоположения формы.
Автор: Virtualik Если вы храните параметры местоположения(Top, Left, Width, Height) формы в реестре, то чтобы не загружать данные из нескольких ключей вы можете их записать в один, и из одного же прочитать ;)По сути, данные записывается в виде rесоrd'а. А как это примерно может выглядеть смотрите в примере.
var
Ini: TRegIniFile;
...
procedure TForm1.FormCreate(Sender: TObject);
var
Rct: TRect;
begin
Ini := TRegIniFile.Create('<Здесь вы пишете путь к вашим настройкам в
реестре > ');
// Если есть данные --> загружаем их
if Ini.ReadBinaryData('FormPosition', Rct, SizeOf(TRect)) > 0 then
BoundsRect := Rct;
...
end;
procedure TReply.FormDestroy(Sender: TObject);
var
Rct: TRect;
begin
// Сохранение данных на выходе
...
Rct := BoundsRect;
Ini.WriteBinaryData('MsgPos', Rct, SizeOf(TRect));
Ini.Free;
end;
|
Получить из регистров информацию о временной зоне (DST).
| 12 Заповедей от Админа. 1. Прав всегда Админ, ибо в трех лицах есть он единая власть высшая в классе дисплейном! 2. Неправ вечно юзер, ибо прав всегда Админ! 3. Не возжелай ни места, ни системника, ни профиля, ни монитора, ни мыши Админа своего, и да пребудет с тобой вечное благословение его! 4. И если вошел Юзер в систему без высшего на то дозволения (Админа) - горе ему, ибо порушится профиль его! 5. Да убоится юзер установить прогу неустановленную на комп казенный - ибо не дозволено сие! 6. Да не будет превышен профиль юзерский, ибо сказал Админ: "Аз воздам за то обрезанием... профиля твоего!" 7. Не возжелай войти под паролем чужим в систему, ибо надолго потом из дисплейки выйдешь ты! 8. А если кто разрешение на папку сменит - горе юзеру этому, ибо всемогущ в системе своей Админ! 9. Да убоятся пользователи толпиться на местах своих подобно стадам овец безмозглых, ибо всеведущ Админ! 10. И да убоится юзер качать вирусы, ибо админомерзкое занятие сие! 11. А если кто из юзеров возжелает порнухи или чата админа своего - горе и позор ему, ибо высшие удовольствия эти лишь Админу дозволены! 12. А тот юзер, который прочел строки эти и не проникся смирением и не осознал, что тварь он ламероидная и чайник нечищенный в сиянии славы высшего существа Админоподобного - горе ему, ибо навеки отлучены они будут от сети великой!!! Во имя отца Билли Гейтса, и сына его Microsofta, и святого духа админовского. |
Ок, попробую здесь описать бинарную структуру значения TZI:
int32 Bias; // Минуты от GMT
// (Сидней -600; 0xfffffda8;
// или a8, fd, ff, ff)
int32 StandardBias; // Смещение для стандартного времени (0)
int32 DaylightBias; // Смещение для летнего времени (-60
// или 0xffffffc4 )
int16 ?? // 0
int16 StandardStartMonth; // 3 => Март
int16 StandardStartDayOfWeek??; // 0 => Воскресенье
int16 StandardStartDOWoccurrence; // 1 => 1-й
int16 StandardStartHour; // 2 => 02:00:00.00
int16 StandardStartMins??; // 0 => 02:00:00.00
int16 StandardStartSecs??; // 0 => 02:00:00.00
int16 StandardStartHunds??; // 0 => 02:00:00.00
int16 ?? // 0
int16 DaylightStartMonth; // 0x0a (10) => Октябрь
int16 DaylightStartDayOfWeek??; // 0 => Воскресенье
int16 DaylightStartDOWoccurrence; // 5 => последний
int16 DaylightStartHour; // 2 => 02:00:00.00
int16 DaylightStartMins??; // 0 => 02:00:00.00
int16 DaylightStartSecs??; // 0 => 02:00:00.00
int16 DaylightStartHunds??; // 0 => 02:00:00.00
|
После внесения изменений в реестр, некоторые программы не видят их.
Автор: Олег КулабуховНеобходимо послать всем окнам сообщение WM_WININICHANGE с указанием полного адреса измененного адреса ключа.
procedure TForm1.Button1Click(Sender: TObject);
begin
SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0,
LongInt(PChar('RegistrySection')));
end;
|
Записать в реестр данные бинарного вида.
| Четыре стадии обнищания программиста: 4. Кормить кошку kitekat-ом. 3. Нет денег на хлеб. 2. Нет денег на женщин. 1. Нет денег на апгрейд. |
var
Reg: TRegistry;
buf : array [0..4] of byte;
i: Integer;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_CURRENT_USER;
if Reg.OpenKey('\Software', True) then begin
for i:=1 to 4 do buf[i]:=0;
buf[0]:=1;
Reg.WriteBinnaryData('Value', buf, sizeof(buf));
Reg.CloseKey;
end;
finally
Reg.Free;
inherited;
end;
{...}
end;
|
Исследование RegSnap v 2.8.
Оформил: DeeCo Автор: http://www.cracklab.narod.ru
Захотелось мне как-то поисследовать программку на VB :) и напоролся я на эту вот вешь. Она умеет делать снапшоты регистра форточек и чего-то там ещё, вобщем неважно. Приступим... Первым делом я поглядел на программку: 1) Огромный NAG при старте с некоторой задержкой при запуске; 2) Напоминательное окно с 3 батонами; 3) Проверка CRC (на изменение кода программы); 4) во-всю юзает (M)ada(F)u(C)ka(42).dll; Начнём с конца, т.е. отключим проверку CRC: - Любым HEX-редактором изменим пару байт в программе и запустим её: мы увидим сообщение "Program corupted" (messagebox) - Ставим бряк на messageboxA: bpx MessageboxA и опять запускаем прогу, при этом мы вывалимся где-то в системной библиотеке, а чтобы из неё выйти и опять попасть в модуль regsnap нужно нажать F12 4 раза, и когда мы это сделаем, то окажемся вот в этом месте::00406848 FF1588774100 Call dword ptr [00417788] <--вызов процедуры проверки CRC (в eax 0, если CRC нарушен и 1 - если всё ОК). :0040684E A1F4494200 mov eax, dword ptr [004249F4] :00406853 83C408 add esp, 00000008 :00406856 3BC7 cmp eax, edi <-- проверяем EAX :00406858 7520 jne 0040687A <-- ЕСЛИ всё ОК - прыгаем :0040685A 6AFF push FFFFFFFF :0040685C 57 push edi :00406862 E8DBDA0000 Call 00414342 <-- Вызов сообщения о нарушенном CRC :00406867 33C0 xor eax, eax <-- вот тут мы остановились :00406869 8B4DF4 mov ecx, dword ptr [ebp-0C] :0040686C 64890D00000000 mov dword ptr fs:[00000000], ecx :00406873 5F pop edi :00406874 5E pop esi :00406875 5B pop ebx :00406876 8BE5 mov esp, ebp :00406878 5D pop ebp :00406879 C3 retКак видите, по адресу 00406856 проверяют EAX, я предлягаю записать вместо этой команды mov eax,01 чтоюы для последующих проверок, если такие будут, всё было нормально, а вместо команды jne 0040687A вписать jmp 0040687A, чтобы в любом случае перепрыгивать ненужное окно и процедуру закрытия программы. ВНИМАНИЕ!!! команда mov eax,01 сожрёт 5 байт, в то время как cmp eax, edi всего 2 байта, поэтому будет использованы байты, выделенные под процедуру вывода сообщения об ошибке и процедуры закрытия программы, всё равно ведь мы эту процедуру перепрыгиваем и больше никогда использовать не будем!!! Итак, если вы всё сделали как я сказал, то больше программа не будет ругаться на то, что её кто-то изменял. И ещё, в программе реализован полиморфизм, т.е. при обнаружении CRC ошибки, она сама затирает некоторые куски кода другими опкодами, что делает все краки нерабочими, поэтому при внесении изменений, рекомендую делать эти изменения в абсолютно "чистой" версии regsnap.exe. 2)Лирическое отступление: Программа записывает в реестре в ключе:
HKEY_CURRENT_USER\Software\Vitas\regsnap\mainв параметре количество дней оставшегося триала. Для начала уберём Огромный NAG-screen при запуске: - ставим бряк на CreateWindowExA - запускаем прогу и почти сразу вываливаемся в айсе - Жмём F12 ровно 12 раз (какое совпадение :) пока не вернёмся в модуль regsnap.exe и оказываемся тут:
:0040687A E893DD0000 Call 00414612 <-- проверяет наличие OLE :0040687F 85C0 test eax, eax :00406881 751D jne 004068A0 <-- если нет таких - прыгаем на выход из проги ............... ...Поскипано... ............... :004068BA E841DD0000 Call 00414600 <-- проверяет необходимость NAG'a :004068BF 397D90 cmp dword ptr [ebp-70], edi :004068C2 740C je 004068D0 <-- если не надо - перепрыгиваем его :004068C4 397DE8 cmp dword ptr [ebp-18], edi :004068C7 7507 jne 004068D0 <-- то же самое :004068C9 B801000000 mov eax, 00000001 :004068CE EB02 jmp 004068D2 <-- а если надо - то прыгаем на нагЗдесь предлагаю вместо je 004068D0 написать jmp 004068D0 чтобы сразу перепрыгивать NAG и он нас больше не мучал :) Осталось разобраться с напоминающим окном "Trial Period"... 3) после :004068C2 jmp 004068D0 скролим то тех пор, пока не появится окно напоминания, это произойдёт в этом месте:
:00406D5D E856D20000 Call 00413FB8 <-- вызываем напоминающее окно :00406D62 83F801 cmp eax, 00000001 <-- смотрим: какую кнопку ты нажал :00406D65 7449 je 00406DB0 <-- если это кнопка "Try" - прыгаемздесь я поменял Call 00413FB8 на jmp 00406DB0, т.е. без вызова окна напоминания дал понять программе, что нажата кнопка "Try". Теперь больше не будет этого окна-напоминания и при старте будет сразу открываться главное окно! Последние штрихи... 4) Это необязательная, но самая приятная часть исследования - уберём все признаки незарегистрированности, т.е. надписи типа "This soft UnRgIsTred" Я зашёл в WDasm'e в String Reference и нашёл там строку "Registred to %S" кликнул на неё и оказался тут:
:00404616 6818E34100 push 0041E318 :0040461B 56 push esiподнялся чуть выше , вот сюда:
* Referenced by a CALL at Addresses: |:0040148F , :004051DD , :004113F7 | :004045D0 A188044200 mov eax, dword ptr [00420488] :004045D5 81EC00010000 sub esp, 00000100 :004045DB 85C0 test eax, eax <-- проверяеи зарегистрированны ли мы :004045DD 56 push esi :004045DE 7452 je 00404632 <-- если нет - прыгаем :004045E0 8BB42408010000 mov esi, dword ptr [esp+00000108] :004045E7 85F6 test esi, esi :004045E9 743A je 00404625 <-- если нет - прыгаем :004045EB 83C01D add eax, 0000001Dздесь я вместо mov eax, dword ptr [00420488] написал ret ( с тем соображением, что программа выйдет из процедуры присваивания имени ни с чем и будет надпись "Registred to: " и всё), но оказалось ещё круче: Появилась надпись "Registred to: Vitas Ramanchauskas" а в окне "О программе" как я и предполагал Вместо надписи "Registred to" ничего нет. //Можно написать вместо ret что-то типа mov eax,eax //тогда адрес строки с именем будет случайный, а т.к. программа проверяет //имя владельца лицензии после каждой операции, то наше имя будет меняться //каждый раз, причем имя будет иметь вид "№;%№;%№;%"№;%%::ВАПп" Прикольно!!! Осталось ещё убрать надпись "Trial" внизу программы: ищем эту надпись в HEX-редакторе и затираем её пробелами или например "fuck". ВсЁ! Ну и как всегда, готовый Крак:
-----------вырезать тут----------- RegSnap v 2.8 Crack by vallkor//PTDS REmoves All Nag's and limits!!! regsnap.exe 00006856: 3B B8 00006857: C7 01 00006858: 75 00 00006859: 20 00 0000685A: 6A 00 0000685B: FF EB 0000685C: 57 1D 000068C2: 74 EB 00006D5D: E8 EB 00006D5E: 56 51 000045D0: A1 C3 0001E4B8: 54 46 0001E4B9: 72 75 0001E4BA: 69 63 0001E4BB: 61 6B 0001E4BC: 6C 20 -----------вырезать тут------------Как всегда, с вами беседовал vallkor //PTDS e-mail: vallkor@chat.ru page: http://vallkor.chat.ru
Использование регулярных выражений в Delphi.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{
It is possible to use regular expressions in Delphi thanks to their
implementation inside "Microsoft(r) Windows(r) Script".
First of all I want to say that this article isn't a theoretical
analisys of the regular expressions but an explanation of how to use
them in Delphi.
First of all I suggest you to download the latest version of
"Microsoft(r) Windows(r) Script" at the following url:
http://msdn.microsoft.com/downloads/default.asp?URL=/downloads/sample.asp?
url=/msdn-files/027/001/733/msdncompositedoc.xml
Download the desired package.
Once downloaded, run it to install.
It will be installed Microsoft(r) Windows(r) Script wich containes:
Visual Basic(r) Script Edition (VBScript.) Version 5.6,
JScript(r) Version 5.6, Windows Script Components,
Windows Script Host 5.6,
Windows Script Runtime Version 5.6.
We are interested in the implementation of regular expressions,
which is in the file "vbscript.dll". Every time you will want to
run a program, wich exploits regular expressions by using
"Microsoft(r) Windows(r) Script", on a given computer, it will be needed to
copy the file "vbscript.dll" on the target computer and register it with the
following command line:
regsvr32 vbscript.dll
Note that the auto-installing package, you have downloaded from the
internet, automatically do it.
Now let's go to import the type library in Delphi:
In the delphi menu, select "Project" then "Import type library": it
shows a mask containing a list.
Inside the list select "Microsoft VBScript Regular Expressions"
(followed by a version number). It is possible that there are more then
one item with this name (it only changes the version number): in this
situation select the item with the higher version number.
In date September the 23th 2002, the package that can be downloaded
from Microsoft's internet site returns the following value:
"Microsoft VBScript Regular Expressions 5.5 (Version 5.5)"
This version supplies the following "Class Names"
}
TRegExp
TMatch
TMatchCollection
TSubMatches
{
Define the name of the pascal unit, wich will be the type library import unit, in
the edit box "Unit dir name".
Uncheck the checkbox "Generate Component Wrapper" (we are only interested in the
pascal source)
and press the button "Create Unit" to create the import unit.
Let's assume to have the latest available version in date
September the 23th i.e.
"Microsoft VBScript Regular Expressions 5.5 (Version 5.5)"
The following "interface" are declared:
}
IRegExp = interface;
IMatch = interface;
IMatchCollection = interface;
IRegExp2 = interface;
IMatch2 = interface;
IMatchCollection2 = interface;
ISubMatches = interface;
{
IRegExp and IRegExp2 are different versions (IRegExp2 is the latest)
of the same "interface". Idem for the other "interface".
Then there are the declarations of CoClasses defined in Type Library.
We map each CoClass to its Default Interface:
}
RegExp = IRegExp2;
Match = IMatch2;
MatchCollection = IMatchCollection2;
SubMatches = ISubMatches;
//IRegExp2 is the "main" "interface":
// 1) properties:
a) property Pattern: WideString read Get_Pattern
write Set_Pattern;
//regular expression
b) property IgnoreCase: WordBool read Get_IgnoreCase
write Set_IgnoreCase;
//"case insensitive" search (TRUE o FALSE)
c) property Global: WordBool read Get_Global write Set_Global;
//TRUE for global search on the input string of the method "Execute"
//FALSE if you want to stop after the first match
d) property Multiline: WordBool read Get_Multiline
write Set_Multiline;
//If the input string contains '\n' charachters, it contains several
//rows. If Multiline = FALSE (default value) then the regular
//expression must be tested distinctly on each row.
//If Multiline = TRUE the regular expression must be tested on the
//whole input string.
// 2) methods:
a) function Execute(const sourceString: WideString): IDispatch;
safecall;
//it returns a Matches collection object containing a match object
//for each succesfull match
b) function Test(const sourceString: WideString): WordBool;
safecall;
//it returns TRUE if the regular expression can succesfully be
//matched against the string
c) function Replace(const sourceString: WideString;
const replaceString: WideString): WideString;
safecall;
//it replaces all the matches, inside "sourceString" with the
//replace string "replaceString".
//You can use the values $1, $2, $3, ... in order to define a
//replace-string made by substrings of the pattern.
{
IMatchCollection2 collects all the matches
For example:
}
var
i: integer;
MatchesCollection: IMatchCollection2;
{...}
MatchesCollection := Execute(InputStr) as IMatchCollection2;
for i := 1 to MatchesCollection.Count - 1 do
begin
Memo1.Lines.Add((MatchesCollection.Item[i] as IMatch2).Value);
end;
{...}
{Remember that you can substitute the "interface" types with
the CoClass types:
RegExp (IRegExp2)
Match (IMatch2)
MatchCollection (IMatchCollection2)
SubMatches (ISubMatches)
The main properties of IMatchCollection2 are:}
a) property Item[index: Integer]: IDispatch read Get_Item;
default;
//Matches array; index in [0..n]
b) property Count: Integer read Get_Count;
//Number of matches
{The Item property returns "IMatch2" values
IMatch2 represents each succesfull match
The main properties are}
a) property Value: WideString read Get_Value;
//matched value or text
b) property FirstIndex: Integer read Get_FirstIndex;
//the position within the original string where the match occurred.
//Note that the first position in a string is 0
c) property Length: Integer read Get_Length;
//length of the matched string
d) property SubMatches: IDispatch read Get_SubMatches;
//substrings ($1, $2, $3, ...)
{ISubMatches collects the values of $1, $2, $3, ...
The main properties are}
a) property Item[index: Integer]: OleVariant read Get_Item;
default;
//for example Item[3] is $3; note that index values start from 0
property Count: Integer read Get_Count;
//number of substrings
{
Short description of $1, $2, $3, ...
They are defined in the following manner:
let's scan the pattern from left to right:
$1 is the substring from the first open parenthesis to the corrisponding
closed one.
$1 is the substring from the second open parenthesis to the corrisponding
closed one.
$1 is the substring from the third open parenthesis to the corrisponding
closed one.
....
For example: let's consider the following pattern
(FTP|HTTP)://([_a-z\d\-]+(\.[_a-z\d\-]+)+)((/[ _a-z\d\-\\\.]+)+)*
$1 = FTP|HTTP
$2 = [_a-z\d\-]+(\.[_a-z\d\-]+)+
$3 = \.[_a-z\d\-]+
$4 = (/[ _a-z\d\-\\\.]+)+
$5 = /[ _a-z\d\-\\\.]+
Finally a couple of examples:
Save an html file from the internet and name it "Test.htm".
Create a new delphi project: drop 2 buttons (btSearch e btReplace)
and a Memo (Memo1); of course include in the "uses" directive the
name of the import unit.
}
//returns all links in "Test.htm" and $1, $2, $3, etc...
procedure TForm1.btSearchClick(Sender: TObject);
var
i, j: integer;
FileStream: TFileStream;
InputStr, InputFile: string;
RegExp1: RegExp;
MatchCollection1: MatchCollection;
Match1: Match;
SubMatches1: ISubMatches;
begin
//
InputFile := 'Test.htm'; //input file
FileStream := TFileStream.Create(InputFile, fmOpenRead);
SetLength(InputStr, FileStream.Size);
FileStream.Read(InputStr[1], FileStream.Size);
//load "Test.htm" in InputString
RegExp1 := CoRegExp.Create;
with RegExp1 do
begin
//I want to search all links
Pattern := '(FTP|HTTP)://([_a-z\d\-]+(\.[_a-z\d\-]+)+)' +
'((/[ _a-z\d\-\\\.]+)+)*';
IgnoreCase := True; //"case insensitive" search
Global := True; //I want to search all the matches
MatchCollection1 := Execute(InputStr) as MatchCollection;
end;
for i := 0 to MatchCollection1.Count - 1 do
begin
Match1 := MatchCollection1.Item[i] as Match;
Memo1.Lines.Add(Match1.Value);
SubMatches1 := Match1.SubMatches as SubMatches;
for j := 0 to SubMatches1.Count - 1 do
begin
Memo1.Lines.Add(' ' + '$' + inttostr(j + 1) +
' = ' + VarToStr(SubMatches1.Item[j]));
end;
end;
RegExp1 := nil;
FileStream.Free;
end;
//I replace all links in "Test.htm" with a new string and
//save the result string in the new file "Test_out.htm"
procedure TForm1.btReplaceClick(Sender: TObject);
var
i: integer;
InFileStream, OutFileStream: TFileStream;
InputStr, OutputStr, InputFile, OutputFile: string;
RegExp1: RegExp;
MatchCollection1: MatchCollection;
Match1: Match;
SubMatches1: ISubMatches;
begin
InputFile := 'Test.htm';
OutputFile := 'Test_out.htm';
InFileStream := TFileStream.Create(InputFile, fmOpenRead);
SetLength(InputStr, InFileStream.Size);
InFileStream.Read(InputStr[1], InFileStream.Size);
InFileStream.Free;
RegExp1 := CoRegExp.Create;
with RegExp1 do
begin
Pattern := '(FTP|HTTP)://([_a-z\d\-]+(\.[_a-z\d\-]+)+)' +
'((/[ _a-z\d\-\\\.]+)+)*';
IgnoreCase := True;
Global := True;
OutputStr := Replace(InputStr, '$2');
end;
OutFileStream := TFileStream.Create(OutputFile, fmCreate);
SetLength(OutputStr, Length(OutputStr));
OutFileStream.Write(OutputStr[1], Length(OutputStr));
OutFileStream.Free;
RegExp1 := nil;
ShowMessage('replace completed');
end;
//Search on Google: "VBScript Regular Expressions"
Регистрация ActiveX.
Автор: Fantasist WEB-сайт: http://forum.vingrad.ru 1. Регистрация ActiveX:
function RegActiveX(FileName: string): HRESULT;
var
hMod: Integer;
RegProc: function: HRESULT; //HRESULT = Longint
begin
hMod := LoadLibrary(FileName);
if hMod = 0 then
raise Exception.Create('Unable to load library"' + FileName +
'". GetLastError = ' + IntToStr(GetLastError));
RegProc := GetProcAddress(hMod, 'DllRegisterServer');
if RegProc = nil then
raise Exception.Create('Unable to load "DllRegisterServer" function from "'
+ FileName + '". GetLastError = ' + IntToStr(GetLastError));
Result := RegProc;
end;
2. Регистрация Type Library:
procedure RegisterTypeLibrary(FileName: string);
var
Name: WideString;
HelpPath: WideString;
TypeLib: ITypeLib;
begin
if LoadTypeLib(PWideChar(WideString(FileName)), TypeLib) = S_OK then
begin
Name := FileName;
HelpPath := ExtractFilePath(ModuleName);
RegisterTypeLib(TypeLib, PWideChar(Name), PWideChar(HelpPath));
end;
end;
Здесь используется интерфейс ITypeLib и API функция RegisterTypeLib. И то и другое объявленно в модуле ActiveX, если я не ошибаюсь.
Hint: если вы регистрируете библиотеку типов изнутри модулчя, то его имя можно получить с помощью следующей функции:
function GetModuleFileName: string;
var
Buffer: array[0..261] of Char;
begin
SetString(Result, Buffer, Windows.GetModuleFileName(HInstance,
Buffer, SizeOf(Buffer)));
end;
Взять все расширения из реестра и их описание.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{
This Code will return the programs associated with each extension.
You can obviously modify it to search for a specific extension.
}
uses Registry;
procedure TForm1.Button1Click(Sender: TObject);
var
reg: TRegistry;
keys: TStringList;
i: Integer;
typename, displayname, server: string;
begin
memo1.Clear;
reg := TRegistry.Create;
try
reg.rootkey := HKEY_CLASSES_ROOT;
if reg.OpenKey('', False) then
begin
keys := TStringList.Create;
try
reg.GetKeyNames(keys);
reg.CloseKey;
{memo1.lines.addstrings(keys);}
for i := 0 to keys.Count - 1 do
begin
if keys[i][1] = '.' then
begin
{this is an extension, get its typename}
if reg.OpenKey(keys[i], False) then
begin
typename := reg.ReadString('');
reg.CloseKey;
if typename <> '' then
begin
if reg.OpenKey(typename, False) then
begin
displayname := reg.ReadString('');
reg.CloseKey;
end;
if reg.OpenKey(typename + '\shell\open\command', False) then
begin
server := reg.ReadString('');
memo1.Lines.Add(Format('Extension: "%s", Typename: "%s", Displayname:"%s"' +
#13#10' Server: %s',
[keys[i], typename, displayname, server]));
reg.CloseKey;
end;
end;
end;
end;
end;
finally
keys.Free;
end;
end;
finally
reg.Free
end;
end;
Прячем программу для TaskManager.
Автор: Subfire WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Прячет программу в TaskManager (по Ctrl+Alt+Del)
Фунция прячет программу для TaskManager, регестрируя ее как сервис.
Запускать из приложения.
Передаешь true для регистрации сервиса, false для снятия регистрации.
Возвращает true если успешно.
В win95-98-ME программа исчезнет из списка задач.
В NT/2000/XP просто нет RegisterServiceProcess и функция вернет
false без возникновения ошибки.
Зависимости: *
Автор: Subfire, subfire@mail.ru, ICQ:55161852, Санкт-Петербург
Copyright: Subfire
Дата: 3 октября 2002 г.
***************************************************** }
function RegisterAsService(Enable: Boolean): boolean;
type
TRSP = function(H: THandle; K: word): longword; stdcall;
var
RSP: TRSP;
begin
@RSP := GetProcAddress(GetModuleHandle(PChar('kernel32.dll')),
PChar('RegisterServiceProcess'));
Result := Assigned(@RSP);
if Result then
begin
if Enable then
Result := (RSP(0, 1) = 1)
else
Result := (RSP(0, 0) = 1);
end;
Пример использования:
// OnCreate RegisterAsService(True); // Спрятали // on ** RegisterAsService(False); // Показали
Помещение записи в одну из секций автозапуска реестра.
Автор: VID WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Помещение записи в одну из секций автозапуска реестра
Функция помещает параметр Name и значение параметра Data, в одну из секций
автозапуска, выбранного раздела реестра.
HkeyTarget:THkeyTarget - указываете раздел реестра, в одну из секций
автозапуска которого должна быть помещена запись:
htLocalMachine - раздел HKEY_LOCAL_MACHINE
htCurrentUser - раздел HKEY_CURRENT_USER
SectionTarget:TSectionTarget - указываете одну из секций автозапуска,
в которую должна быть помещена запись:
stRun - секция RUN
stRunOnce - секция RunOnce
stRunOnceEx - секция RunOnceEx
Name:String - имя параметра (например, 'myApplication')
Data:String - значение параметра (например, Application.Exename)
Зависимости: windows, registry
Автор: VID, vidsnap@mail.ru, ICQ:132234868, Махачкала
Copyright: VID
Дата: 23 мая 2002 г.
***************************************************** }
type
THKEYTarget = (htLocalMachine, htCurrentUser);
type
TSectionTarget = (stRun, stRunOnce, stRunOnceEx);
function StoreToRunSection(HKEYTarget: THKEYTarget;
SectionTarget: TSectionTarget; Name, Data: string): boolean;
var
Reg: TRegistry;
Section: string;
begin
Result := TRUE;
try
reg := TRegistry.Create;
if HKEYTarget = htLocalMachine then
reg.RootKey := HKEY_LOCAL_MACHINE;
if HKEYTarget = htCurrentUser then
reg.RootKey := HKEY_CURRENT_USER;
if SectionTarget = stRun then
Section := 'Run';
if SectionTarget = stRunOnce then
Section := 'RunOnce';
if SectionTarget = stRunOnceEx then
Section := 'RunOnceEx';
reg.LazyWrite := false;
reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\' + Section, false);
reg.WriteString(Name, Data);
reg.CloseKey;
reg.free;
except RESULT := FALSE;
end;
end;
// Пример использования:
begin
StoreToRunSection(htLocalMachine, stRun, 'Имя программы',
application.exename);
end;
Сохранение бинарного файла в реестре с последующим его извлечением.
Автор: Sergey WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Сохранение бинарного файла в реестре с последующим его извлечением
Функции позволяют разбить файл на блоки 16к и затем поместить бинарные
данные в реестр, а так же собрать эти данные обратно в файл при необходимости.
Не знаю зачем этот код нужен , но возможно он пригодится для скрытого
хранения данных . Не рекомендуется (!) сохранять слишком большие файлы
в реестре , потому что размеры реестра ограничены .
Зависимости: Registry,SysUtils
Автор: Sergey, gloom@imail.ru, Koenigsberg
Copyright: KosilkA
Дата: 4 декабря 2003 г.
***************************************************** }
//////////////////////////////////////////////////
// функция разбивки и сохранения файла в реестр:
function SaveToRegistry(RootKey: HKEY; FileName, KeyName: string): Bool;
//где RootKey-раздел реестра,
//FileName-путь к файлу ,
//KeyName-ключ реестра в который будем сохранять
var
FromF: file;
NumRead, i: Integer;
Buf: array[0..16383] of byte;
reg: tregistry;
begin
try
AssignFile(FromF, filename);
Reset(FromF, 1);
reg := tregistry.Create;
reg.RootKey := rootkey;
if reg.OpenKey(keyName, true) = false then //если невозможно
//открыть ключ с правами
//записи , то что то не так
begin
result := false;
reg.Free;
exit; //выходим
end;
i := 0;
repeat //читаем и записывае в цикле
BlockRead(FromF, Buf, SizeOf(Buf), NumRead); //читаем блок из файла
if numread <> 0 then
begin
reg.WriteBinaryData(inttostr(i), buf, numread); //сохраняем блок в реестр
inc(i);
end;
until (NumRead = 0);
CloseFile(FromF);
reg.CloseKey;
reg.Free;
result := true;
except
reg.CloseKey;
reg.Free;
result := false;
end;
end;
//////////////////////////////////////////////////
// функция сборки сохраненного файла:
function BuildFromRegistry(RootKey: HKEY; KeyName, ToFileName: string): Bool;
//где RootKey-раздел реестра,
//KeyName -ключ реестра ,
//ToFileName-имя выходного файла .
var
numwritten, i: integer;
ToF: file;
Buf: array[0..16383] of byte;
reg: tregistry;
begin
try
AssignFile(ToF, tofilename);
Rewrite(ToF, 1);
reg := tregistry.Create;
reg.RootKey := rootkey;
if reg.OpenKey(keyname, true) = false then
//если указанный ключ невозможно открыть - выходим
begin
result := false;
reg.Free;
exit;
end;
i := 0;
repeat
//в цикле находим значения
//начиная с "0" , читаем их
//и добавляем блоки к файлу
if reg.ValueExists(inttostr(i)) = true then
begin
reg.ReadBinaryData(inttostr(i), buf, reg.GetDataSize(inttostr(i)));
BlockWrite(ToF, Buf, reg.GetDataSize(inttostr(i)));
end;
inc(i);
until reg.ValueExists(inttostr(i)) = false;
CloseFile(ToF);
reg.CloseKey;
reg.Free;
result := true;
except
reg.CloseKey;
reg.Free;
result := false;
end;
end;
// Пример использования:
// сохранить:
SaveToRegistry(HKEY_CURRENT_USER, Application.ExeName, '\Software\MyData\test');
// извлечь:
BuildFromRegistry(HKEY_CURRENT_USER, '\Software\MyData\test', 'MyBuildApp.exe');
Регистрация классов.
unit InfoForm;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
StdCtrls, ExtCtrls, Buttons, Clipbrd, Comctrls, Db, Dbcgrids,
Dbctrls, Dbgrids, Dblookup, Dbtables, Ddeman, Dialogs,
Filectrl, Grids, Mask, Menus, Mplayer, Oleconst, Olectnrs,
Olectrls, Outline, Tabnotbk, Tabs;
type
TForm1 = class(TForm)
ListBox1: TListBox;
Label1: TLabel;
Edit1: TEdit;
Label2: TLabel;
ButtonShow: TButton;
Label3: TLabel;
Panel1: TPanel;
ComboBox1: TComboBox;
procedure FormCreate(Sender: TObject);
procedure ButtonShowClick(Sender: TObject);
procedure ComboBox1DblClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
type
TClassArray = array [1..140] of TPersistentClass;
const
ClassArray: TClassArray = (
TBitmap, TGraphic, TOutlineNode, TGraphicsObject,
TBrush, THeaderSection, TParams, TCanvas,
THeaderSections, TPen, TIcon, TPicture,
TIconOptions, TCollection, TCollectionItem, TColumn,
TStatusPanel, TColumnTitle, TStatusPanels, TClipboard,
TControlScrollBar, TListColumn, TStringList, TListItem,
TStrings, TListItems, TMetafile, TMetafileCanvas,
TTreeNode, TFont, TParaAttributes, TTreeNodes,
TApplication, TDDEServerItem, TPanel, TAutoIncField,
TDirectoryListBox, TPopupMenu, TBatchMove, TDrawGrid,
TPrintDialog, TBCDField, TDriveComboBox, TPrinterSetupDialog,
TBevel, TEdit, TProgressBar, TBitBtn,
TField, TQuery, TBlobField, TFileListBox,
TRadioButton, TBooleanField, TFilterComboBox, TRadioGroup,
TButton, TFindDialog, TReplaceDialog, TBytesField,
TFloatField, TCheckBox, TFontDialog,
TRichEdit, TColorDialog, TForm, TSaveDialog,
TComboBox, TGraphicField, TScreen, TCurrencyField,
TGroupBox, TScrollBar, TDatabase, THeader,
TScrollBox, TDataSource, THeaderControl, TSession,
TDateField, THotKey, TShape, TDateTimeField,
TImage, TSmallIntField, TDBCheckBox, TImageList,
TSpeedButton, TDBComboBox, TIntegerField, TStatusBar,
TDBCtrlGrid, TLabel, TStoredProc, TDBEdit,
TListBox, TStringField, TDBGrid, TListView,
TStringGrid, TDBImage, TMainMenu, TTabbedNotebook,
TDBListBox, TMaskEdit, TTabControl, TDBLookupCombo,
TMediaPlayer, TTable, TMemoField, TDBLookupComboBox,
TMemo, TTabSet, TDBLookupList, TTabSheet,
TDBLookupListBox, TMenuItem, TTimeField, TDBMemo,
TNotebook, TTable, TDBNavigator, TOleContainer,
TTimer, TDBRadioGroup, TOpenDialog, TTrackBar,
TDBText, TOutline, TTreeView, TDDEClientConv,
TOutline, TUpdateSQL, TDDEClientItem, TPageControl,
TUpDown, TDDEServerConv, TPaintBox, TVarBytesField,
TWordField);
procedure TForm1.FormCreate(Sender: TObject);
var
I: Integer;
begin
// register all of the classes
RegisterClasses (ClassArray);
// copy class names to the listbox
for I := Low (ClassArray) to High (ClassArray) do
ComboBox1.Items.Add (ClassArray [I].ClassName);
end;
procedure TForm1.ButtonShowClick(Sender: TObject);
var
MyClass: TClass;
begin
MyClass := GetClass (ComboBox1.Text);
if MyClass = nil then
Beep
else
begin
Edit1.Text := Format ('Name: %s - Size: %d bytes',
[MyClass.ClassName, MyClass.InstanceSize]);
with Listbox1.Items do
begin
Clear;
while MyClass.ClassParent <> nil do
begin
MyClass := MyClass.ClassParent;
Add (MyClass.ClassName);
end; // while
end; // with
end; // else
end;
procedure TForm1.ComboBox1DblClick(Sender: TObject);
begin
ButtonShowClick (Sender);
end;
end.
|
Загрузить весь проект
Считать значение REG_DWORD из реестра.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
uses
Registry;
// Read REG_DWORD
procedure TForm1.Button1Click(Sender: TObject);
var
Reg: TRegistry;
RegKey: DWORD;
Key: string;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_USERS;
Key := '.DEFAULT\Software\Microsoft\Windows\CurrentVersion\Internet Settings\URL History';
if Reg.OpenKeyReadOnly(Key) then
begin
if Reg.ValueExists('DaysToKeep') then
begin
RegKey := Reg.ReadInteger('DaysToKeep');
Reg.CloseKey;
ShowMessage(IntToStr(RegKey));
end;
end;
finally
Reg.Free
end;
end;
// Write REG_DWORD
procedure TForm1.Button2Click(Sender: TObject);
var
Reg: TRegistry;
Key: string;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_USERS;
Key := '.DEFAULT\Software\Microsoft\Windows\CurrentVersion\Internet Settings\URL History';
if Reg.OpenKey(Key, True) then
begin
Reg.WriteInteger('DaysToKeep', 20);
Reg.CloseKey;
end;
finally
Reg.Free
end;
end;
Перечислить измененные ключи реестра в определенный диапазон времени.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
unit Main;
interface
uses
Windows, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, Registry, StdCtrls, ComCtrls, ExtCtrls;
type
TFrmMain = class(TForm)
Memo1: TMemo;
btEnumReg: TButton;
dtBeginDate: TDateTimePicker;
dtEndDate: TDateTimePicker;
dtBeginTime: TDateTimePicker;
dtEndTime: TDateTimePicker;
Panel1: TPanel;
Label1: TLabel;
Label2: TLabel;
procedure btEnumRegClick(Sender: TObject);
private
{ Private declarations }
RegDate: TDateTime;
RegKeyInfo: TRegKeyInfo;
TimeZoneInfo: TTimeZoneInformation;
function DateTimeToLocalDateTime(DateTime: TDateTime): TDateTime;
procedure FileTimeToDateTime(ft: TFileTime; var dt: TDateTime);
public
{ Public declarations }
end;
var
FrmMain: TFrmMain;
implementation
{$R *.dfm}
function TFrmMain.DateTimeToLocalDateTime(DateTime: TDateTime): TDateTime;
begin
case GetTimeZoneInformation(TimeZoneInfo) of
TIME_ZONE_ID_STANDARD:
Result := DateTime - (TimeZoneInfo.Bias / 60 / 24);
TIME_ZONE_ID_DAYLIGHT:
Result := DateTime - ((TimeZoneInfo.Bias + TimeZoneInfo.DaylightBias) / 60 / 24);
else
Result := 0;
end;
end;
procedure TFrmMain.FileTimeToDateTime(ft: TFileTime; var dt: TDateTime);
var
SystemTime: TSystemTime;
FileTime: TFileTime;
begin
if FileTimeToLocalFileTime(ft, FileTime) then
begin
FileTimeToSystemTime(ft, SystemTime);
dt := SystemTimeToDateTime(SystemTime);
end;
end;
procedure TFrmMain.btEnumRegClick(Sender: TObject);
var
Inizio, Fine: TDateTime;
procedure EnumAllKeys(hkey: THandle; KeyName: string);
var
l: TStringList;
n: Integer;
KeyName_: string;
begin
KeyName_ := KeyName;
with TRegistry.Create do
try
RootKey := hkey;
OpenKey(EmptyStr, False);
l := TStringList.Create;
try
GetKeynames(l);
CloseKey;
for n := 0 to l.Count - 1 do
begin
if OpenKey(l[n], False) then
begin
GetKeyInfo(RegKeyInfo);
with RegKeyInfo do
begin
FileTimeToDateTime(FileTime, RegDate);
RegDate := DateTimeToLocalDateTime(RegDate);
end;
if (RegDate <= Fine) and (RegDate >= Inizio) then
memo1.Lines.Add(DateTimeToStr(RegDate) + ' --- ' + KeyName_ + '\' + l[n]);
EnumAllKeys(CurrentKey, KeyName_ + '\' + l[n]);
CloseKey;
end;
end;
finally
l.Free
end;
finally
Free;
end;
end;
begin
Memo1.Clear;
Memo1.Lines.BeginUpdate;
Inizio := int(dtBeginDate.DateTime) + frac(dtBeginTime.DateTime);
Fine := int(dtEndDate.Date) + frac(dtEndTime.DateTime);
try
EnumAllKeys(HKEY_CURRENT_USER, 'HKey_Current_User');
finally
Memo1.Lines.EndUpdate;
end;
MessageDlg('Enumeration ended', mtInformation, [mbOK], 0);
end;
end.
Экспортировать ветвь реестра.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
unit RegExpo;
interface
uses
Windows, rRegistry, Classes, SysUtils;
{$I-}
{$LONGSTRINGS ON}
{
Regexpo
Author : Arthur Hoornweg (arthur.hoornweg@email.de)
Version : 1.00, May 1998
O/S : Windows 95, 98, ME, NT, 2000, XP
Delphi 2+
Function :
This unit allows you to backup a branch of the registry into a *.REG file,
that is compatible with "regedit".
Double-clicking such a file in the explorer will import it.
Example:
ExportRegistryBranch(HKEY_LOCAL_MACHINE,'SOFTWARE\Borland\Delphi','A:\DELPHI.REG')
(c) 1998 A.M. Hoornweg. All rights reserved.
You may use this software for all purposes, both commercial and
noncommercial, as long as proper credit is given. The sourcecode may be distributed
freely, as long as this copyright is included and no more than a marginal fee is
asked.
Disclaimer:
I accept no responsibility whatsoever for any damages caused by these
routines. Use them at your own risk. If you find any bugs, please let me know.
}
procedure ExportRegistryBranch(Rootsection: Integer; regroot: string;
FileName: string);
implementation
function dblBackSlash(t: string): string;
var
k: longint;
begin
Result := t; {Strings are not allowed to have}
for k := Length(t) downto 1 do {single backslashes}
if Result[k] = '\' then Insert('\', Result, k);
end;
procedure ExportRegistryBranch(rootsection: Integer; Regroot: string;
FileName: string);
var
reg: TRegistry;
f: Textfile;
p: PChar;
procedure ProcessBranch(root: string); {recursive sub-procedure}
var
values, keys: TStringList;
i, j, k: longint;
s, t: string; {longstrings are on the heap, not on the stack!}
begin
Writeln(f); {write blank line}
case rootsection of
HKEY_CLASSES_ROOT: s := 'HKEY_CLASSES_ROOT';
HKEY_CURRENT_USER: s := 'HKEY_CURRENT_USER';
HKEY_LOCAL_MACHINE: s := 'HKEY_LOCAL_MACHINE';
HKEY_USERS: s := 'HKEY_USERS';
HKEY_PERFORMANCE_DATA: s := 'HKEY_PERFORMANCE_DATA';
HKEY_CURRENT_CONFIG: s := 'HKEY_CURRENT_CONFIG';
HKEY_DYN_DATA: s := 'HKEY_DYN_DATA';
end;
Writeln(f, '[' + s + '\' + root + ']'); {write section name in brackets}
reg.OpenKey(root, False);
try
values := TStringList.Create;
try
keys := TStringList.Create;
try
reg.GetValuenames(values); {get all value names}
reg.GetKeynames(keys); {get all sub-branches}
for i := 0 to values.Count - 1 do {write all the values first}
begin
s := values[i];
t := s; {s=value name}
if s = '' then s := '@' {empty means "default value", write as @}
else
s := '"' + s + '"'; {else put in quotes}
Write(f, dblbackslash(s) + '='); {write the name of the key to the file}
case reg.Getdatatype(t) of {What type of data is it?}
rdString, rdExpandString: {String-type}
Writeln(f, '"' + dblbackslash(reg.ReadString(t) + '"'));
rdInteger: {32-bit unsigned long integer}
Writeln(f, 'dword:' + IntToHex(reg.readinteger(t), 8));
{write an array of hex bytes if data is "binary." Perform a line feed
after approx. 25 numbers so the line length stays within limits}
rdBinary:
begin
Write(f, 'hex:');
j := reg.GetDataSize(t); {determine size}
GetMem(p, j); {Allocate memory}
reg.ReadBinaryData(t, p^, J); {read in the data, treat as pchar}
for k := 0 to j - 1 do
begin
Write(f, IntToHex(Byte(p[k]), 2)); {Write byte as hex}
if k <> j - 1 then {not yet last byte?}
begin
Write(f, ','); {then write Comma}
if (k > 0) and ((k mod 25) = 0) {line too long?} then
Writeln(f, '\'); {then write Backslash +lf}
end; {if}
end; {for}
FreeMem(p, j); {free the memory}
Writeln(f); {Linefeed}
end;
else
Writeln(f, '""'); {write an empty string if datatype illegal/unknown}
end;{case}
end; {for}
finally
reg.CloseKey;
end;
finally
{value names all done, no longer needed}
values.Free;
end;
{Now al values are written, we process all subkeys}
{Perform this process RECURSIVELY...}
for i := 0 to keys.Count - 1 do
ProcessBranch(root + '\' + keys[i]);
finally
keys.Free; {this branch is ready}
end;
end; { ProcessBranch}
begin
if RegRoot[Length(Regroot)] = '\' then {No trailing backslash}
SetLength(regroot, Length(Regroot) - 1);
Assignfile(f, FileName); {create a text file}
Rewrite(f);
if ioResult <> 0 then Exit;
Writeln(f, 'REGEDIT4'); {"magic key" for regedit}
reg := TRegistry.Create;
try
reg.Rootkey := Rootsection;
{Call the function that writes the branch and all subbranches}
ProcessBranch(Regroot);
finally
reg.Free; {ready}
Close(f);
end;
end;
end.
Получить количество вложенных ключей и значений ветви реестра.
Автор: ___Nikolay WEB-сайт: http://delphiworld.narod.ru
uses Registry;
// Количество вложенных ключей и значений
procedure TForm1.Button1Click(Sender: TObject);
const
sKey = '\SOFTWARE\Microsoft\Windows\CurrentVersion';
var
rReg: TRegistry;
ki: TRegKeyInfo;
begin
rReg := TRegistry.Create;
with rReg do
begin
RootKey := HKEY_LOCAL_MACHINE;
if KeyExists(sKey) then
begin
OpenKey(sKey, false);
GetKeyInfo(ki);
CloseKey;
lbSubkeys.Caption := IntToStr(ki.NumSubKeys);
lbValues.Caption := IntToStr(ki.NumValues);
end;
end;
rReg.Free;
end;
Перейти на определенный ключ в RegEdit.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
unit Unit1;
interface
uses
Windows, Messages, Classes, Controls, Forms, StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure JumpToKey(Key: string);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
uses
ShellAPI;
procedure TForm1.JumpToKey(Key: string);
var
i, n: Integer;
hWin: HWND;
ExecInfo: ShellExecuteInfoA;
begin
hWin := FindWindowA(PChar('RegEdit_RegEdit'), nil);
if hWin = 0 then
{if Regedit doesn't run then we launch it}
begin
FillChar(ExecInfo, 60, #0);
with ExecInfo do
begin
cbSize := 60;
fMask := SEE_MASK_NOCLOSEPROCESS;
lpVerb := PChar('open');
lpFile := PChar('regedit.exe');
nShow := 1;
end;
ShellExecuteExA(@ExecInfo);
WaitForInputIdle(ExecInfo.hProcess, 200);
hWin := FindWindowA(PChar('RegEdit_RegEdit'), nil);
end;
ShowWindow(hWin, SW_SHOWNORMAL);
hWin := FindWindowExA(hWin, 0, PChar('SysTreeView32'), nil);
SetForegroundWindow(hWin);
i := 30;
repeat
SendMessageA(hWin, WM_KEYDOWN, VK_LEFT, 0);
Dec(i);
until i = 0;
Sleep(500);
SendMessageA(hWin, WM_KEYDOWN, VK_RIGHT, 0);
Sleep(500);
i := 1;
n := Length(Key);
repeat
if Key[i] = '\' then
begin
SendMessageA(hWin, WM_KEYDOWN, VK_RIGHT, 0);
Sleep(500);
end
else
SendMessageA(hWin, WM_CHAR, Integer(Key[i]), 0);
i := i + 1;
until i = n;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
JumpToKey('HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Internet Explorer');
end;
end.
Считать значение REG_MULTI_SZ параметра реестра.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
uses
Registry;
procedure ReadREG_MULTI_SZ(const CurrentKey: HKey; const Subkey, ValueName: string;
Strings: TStrings);
var
valueType: DWORD;
valueLen: DWORD;
p, buffer: PChar;
key: HKEY;
begin
// Clear TStrings
// TStrings leeren
Strings.Clear;
// open the specified key
// CurrentKey Schlussel offnen
if RegOpenKeyEx(CurrentKey,
PChar(Subkey),
0, KEY_READ, key) = ERROR_SUCCESS then
begin
// retrieve the type and data for a specified value name
// Den Typ und Wert des Eintrags Ermitteln.
SetLastError(RegQueryValueEx(key,
PChar(ValueName),
nil,
@valueType,
nil,
@valueLen));
if GetLastError = ERROR_SUCCESS then
if valueType = REG_MULTI_SZ then
begin
GetMem(buffer, valueLen);
try
// receive the value's data (in an array).
// Ein Array von Null-terminierten Strings
// wird zuruckgegeben
RegQueryValueEx(key,
PChar(ValueName),
nil,
nil,
PBYTE(buffer),
@valueLen);
// Add values to stringlist
// Werte in String Liste einfugen
p := buffer;
while p^ <> #0 do
begin
Strings.Add(p);
Inc(p, lstrlen(p) + 1)
end
finally
FreeMem(buffer)
end
end
else
raise ERegistryException.Create('Stringlist expected/ String Liste erwartet...')
else
raise ERegistryException.Create('Cannot Read MULTI_SZ Value/'+
'Kann den MULTI_SZ Wert nicht lesen...');
end;
end;
// Test it, Testen:
procedure TForm1.Button1Click(Sender: TObject);
begin
ReadREG_MULTI_SZ(HKEY_CURRENT_USER, 'Software\XYZ', 'Test44', Memo1.Lines);
end;
{******************************************}
{2. by Ralph Friedman }
{
Question:
I want to read out the binary-value "problems" of the path
HKEY_DYN_DATA\Config Manager\Enum\[add the key of a hardware component] to
detect if a hardware component is troubled and not working right.
But I cannot handle the ReadBinaryData-Method of TRegistry correct.
Everytime I use it, it always returns "4" as content of the buffer.
How do I detect if the content of the binary-key "problems" is
not "00 00 00 00" but something else like "16 00 00 00" or such?
}
{Answer: Here's an example of ReadBinaryData }
procedure TFrmReadBinary.Button1Click(Sender: TObject);
const
CKeyName: string = 'System\Setup';
CValName: string = 'NetcardDlls';
var
keyGood: boolean;
p: integer;
regKey: TRegistry;
tmpStr: string;
vSize: integer;
begin
regKey := TRegistry.Create;
try
regKey.RootKey := HKEY_LOCAL_MACHINE;
keyGood := regKey.OpenKey(CKeyName, False);
if (keyGood) then
begin
vSize := regKey.GetDataSize(CValName);
if (vSize > 0) then
begin
SetLength(tmpStr, vSize);
regKey.ReadBinaryData(CValName, tmpstr[1], vSize);
repeat
p := Pos(#0, tmpStr);
if p <> 0 then
begin
Delete(tmpStr, p, 1);
Insert(#13#10,tmpStr,p);
end;
until p = 0;
(*StringReplace(tmpStr, #0, #13#10,[rfReplaceAll]);*)
ListBox1.Items.Text := tmpStr;
end;
end;
finally
regKey.Free;
end;
end;
{******************************************}
{3. by Michael Winter }
procedure RaiseWin32Error(Code: Cardinal);
var
Error: EWin32Error;
begin
Error := EWin32Error.CreateResFmt(@SWin32Error, [Code,
SysErrorMessage(Code)]);
Error.ErrorCode := Code;
raise Error;
end;
// Write REG_MULTI_SZ
procedure TForm1.Button1Click(Sender: TObject);
const
Str = 'multiple'#0'strings'#0'in one'#0'registry'#0'value'#0 ;
var
Reg: TRegistry;
Res: Integer;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_CURRENT_USER;
if not Reg.OpenKey('\Software\Test\RegMultiSzTest', true) then
raise Exception.Create('Can''t open key');
Res := RegSetValueEx(
Reg.CurrentKey, // handle of key to set value for
'TestValue', // address of value to set
0, // reserved
REG_MULTI_SZ, // flag for value type
PChar(Str), // address of value data
Length(Str) + 1); // size of value data
if Res <> ERROR_SUCCESS then
RaiseWin32Error(Res);
finally
Reg.Free;
end;
end;
// Read REG_MULTI_SZ
procedure TForm1.Button2Click(Sender: TObject);
var
Reg: TRegistry;
DataType: Cardinal;
DataSize: Cardinal;
Res: Integer;
Str: String;
i: Integer;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_CURRENT_USER;
if not Reg.OpenKeyReadOnly('\Software\Test\RegMultiSzTest') then
raise Exception.Create('Can''t open key');
DataSize := 0;
Res := RegQueryValueEx(
Reg.CurrentKey, // handle of key to query
'TestValue', // address of name of value to query
nil, // reserved
@DataType, // address of buffer for value type
nil, // address of data buffer
@DataSize); // address of data buffer size
if Res <> ERROR_SUCCESS then
RaiseWin32Error(Res);
if DataType <> REG_MULTI_SZ then
raise Exception.Create('Wrong data type');
SetLength(Str, DataSize - 1);
if DataSize > 1 then begin
Res := RegQueryValueEx(
Reg.CurrentKey, // handle of key to query
'TestValue', // address of name of value to query
nil, // reserved
@DataType, // address of buffer for value type
PByte(Str), // address of data buffer
@DataSize); // address of data buffer size
if Res <> ERROR_SUCCESS then
RaiseWin32Error(Res);
end;
for i := Length(Str) downto 1 do
if Str[i] = #0 then
Str[i] := #13;
ShowMessage(Str);
finally
Reg.Free;
end;
end;
Чтение строки из реестра без использования класса TRegistry.
Автор: Dimka Maslov WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Чтение строки из реестра без использования класса TRegistry
Входные параметры:
RootKey - идентификатор корневого раздела реестра, например
HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_LOCAL_MACHINE и т.д.
Key - имя раздела реестра,
Name - имя параметра, для чтения параметра "По умолчанию" ("Default"),
эта строка должна быть пустой
Success - (необязательный параметр) адрес логической переменной, в которую
будет Тгие в случае успеха или False в случае ошибки.
В случае успеха функция возвращает значение параметра, или
пустую строку при возникновении ошибки чтения из реестра
Зависимости: Windows
Автор: Dimka Maslov, mainbox@endimus.ru, ICQ:148442121, Санкт-Петербург
Copyright: Dimka Maslov
Дата: 13 мая 2002 г.
***************************************************** }
function RegQueryStr(RootKey: HKEY; Key, Name: string;
Success: PBoolean = nil): string;
var
Handle: HKEY;
Res: LongInt;
DataType, DataSize: DWORD;
begin
if Assigned(Success) then
Success^ := False;
Res := RegOpenKeyEx(RootKey, PChar(Key), 0, KEY_QUERY_VALUE, Handle);
if Res <> ERROR_SUCCESS then
Exit;
Res := RegQueryValueEx(Handle, PChar(Name), nil, @DataType, nil, @DataSize);
if (Res <> ERROR_SUCCESS) or (DataType <> REG_SZ) then
begin
RegCloseKey(Handle);
Exit;
end;
SetString(Result, nil, DataSize - 1);
Res := RegQueryValueEx(Handle, PChar(Name), nil, @DataType,
PByte(@Result[1]), @DataSize);
if Assigned(Success) then
Success^ := Res = ERROR_SUCCESS;
RegCloseKey(Handle);
end;
Пример использования:
procedure TForm1.Button1Click(Sender: TObject); begin edit1.Text := RegQueryStr(HKEY_CLASSES_ROOT, 'AVIFile\shell\open\command', ''); end;
Зарегистрировать или удалить OCX, ActiveX.
| Приходит жена программиста с работы, а муж весь расстроенный. - Миша, что случилось? - Мама умерла... да погоди радоваться, не моя - у компа.. |
{1.}
type
TDllRegisterServer = function: HResult; stdcall;
function RegisterOCX(FileName: string): Boolean;
var
OCXHand: THandle;
RegFunc: TDllRegisterServer;
begin
OCXHand := LoadLibrary(PChar(FileName));
RegFunc := GetProcAddress(OCXHand, 'DllRegisterServer');
if @RegFunc <> nil then
Result := RegFunc = S_OK
else
Result := False;
FreeLibrary(OCXHand);
end;
function UnRegisterOCX(FileName: string): Boolean;
var
OCXHand: THandle;
RegFunc: TDllRegisterServer;
begin
OCXHand := LoadLibrary(PChar(FileName));
RegFunc := GetProcAddress(OCXHand, 'DllUnregisterServer');
if @RegFunc <> nil then
Result := RegFunc = S_OK
else
Result := False;
FreeLibrary(OCXHand);
end;
{**********}
{2.}
function RegisterServer(const aDllFileName: string; aRegister: Boolean): Boolean;
type
TRegProc = function: HResult;
stdcall;
const
cRegFuncNameArr: array [Boolean] of PChar =
('DllUnregisterServer', 'DllRegisterServer');
var
vLibHandle: THandle;
vRegProc: TRegProc;
begin
Result := False;
vLibHandle := LoadLibrary(PChar(aDllFileName));
if vLibHandle = 0 then Exit;
@vRegProc := GetProcAddress(vLibHandle, cRegFuncNameArr[aRegister]);
if @vRegProc <> nil then
Result := vRegProc = S_OK;
FreeLibrary(vLibHandle);
end;
|
Использование реестра.
Оформил: DeeCo
Автор: Алексей Федоров.
Реестр - это центральное хранилище информации о параметрах системы и установленных программах. В версиях Windows до Windows 95 программисты сохраняли параметры программ либо в INI-файлах WIN.INI и SYSTEM.INI, либо в дополнительных INI-файлах. Хотя использование INI-файлов поддерживается и в Win32, Microsoft настоятельно рекомендует для хранения необходимых в работе программы параметров пользоваться реестром. Реестр представляет собой иерархическую базу данных, состоящую из секций, подсекций и элементов. Каждая секция имеет свое назначение. Хранить данные о пользовательских программах Microsoft рекомендует в секции HKEY_CURRENT_USER и подсекции Software. В этой подсекции вы создаете подсекцию, идентифицирующую вашу программу или фирму, и уже внутри нее располагаете данные.
Модуль RegistryДля упрощения работы с регистратором в состав Delphi (начиная с версии 2.0) входит модуль REGISTRY, содержащий реализацию трех классов, - TRegistry, TRegistryIniFile и TRegIniFile.
Внимание! Чтобы использовать свойства и методы классов TRegistry, TRegistryIniFile и TRegIniFile, необходимо включить в список uses модуль Registry.
TRegIniFileСобственно говоря, задача класса TRegIniFile - упростить перенос 16-битных программ в среду Windows 95. Методы этого класса эквивалентны методам класса TIniFile в 16-битной версии Delphi. Класс TRegIniFile позволяет обращаться к секции HKEY_CURRENT_USER, считывать и записывать строки (методы ReadString и WriteString), целочисленные значения (методы ReadInteger и WriteInteger), логические значения (методы ReadBool и WriteBool), секции (методы ReadSection, ReadSections и ReadSectionValues), удалять секции (метод EraseSection) и элементы (метод DeleteKey). Рассмотрим на примерах, как используются функции этого класса.
Microsoft рекомендует записывать данные, относящиеся к вашей программе, в подсекции секции HKEY_CURRENT_USER_Software. Предположим (не особенно фантазируя на эту тему), что ваша программа называется RegDemo, и данные для нее располагаются в секции Software\RegDemo. Ниже мы покажем, как поместить в регистратор строчные, целочисленные и логические данные, а затем считать их, - этих операций будет достаточно для того, чтобы сохранить в регистраторе параметры нашей программы, а затем считать их.
Прежде чем записать данные в определенную секцию, ее необходимо создать. Это происходит при вызове конструктора объекта TRegIniFile. В качестве параметра вы указываете название секции, и если таковой не существует, она создается:
RegFile := TRegIniFile.Create(SubKey);
После того как файл регистратора открыт (и создана определенная секция), мы можем записать данные. Поддерживаются три типа данных: целочисленные, логические и строчные данные. Для записи этих данных существуют методы WriteInteger, WriteBool и WriteString. В качестве параметров указываются:
название подсекции; название элемента; записываемые данные.Так, чтобы записать значение элемента MyIntVal в подсекции IntKey, следует выполнить код.
RegFile.WriteInteger(IntKey, 'Int_Val', 32000);
А для того чтобы прочесть значение, необходимо вызвать метод ReadInteger (в качестве параметров указываются название подсекции, название элемента и значение по умолчанию):
RegFile.ReadInteger(IntKey, 'Int_Val', 0));
Для чтения логических и строчных данных используются соответственно методы ReadBool и ReadStr, а для их записи – методы WriteBool и WriteString.
Расссмотрим пример использования перечисленных выше методов класса TRegIniFile. Расположим в форме компонент Memo, две группы GroupBox и шесть кнопок – три в группе Write и три в группе Read. Нажатие каждой кнопки в группе Write приведет к записи соответствующего значения в реестр, нажатие каждой кнопки в группе Read – к чтению этого значения.
Ниже приведен исходный текст модуля, в котором содержатся обработчики нажатия кнопок, использующие методы класса TRegIniFile.
unit RDUnit;
interfaceuses
Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, Registry;
type
TForm1 = class(TForm)
Memo1: TMemo;
GroupBox1: TGroupBox;
GroupBox2: TGroupBox;
Label1: TLabel;
Button1: TButton;
Button2: TButton;
Button3: TButton;
Button4: TButton;
Button5: TButton;
Button6: TButton;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure Button4Click(Sender: TObject);
procedure Button5Click(Sender: TObject);
procedure Button6Click(Sender: TObject);
procedure FormClose(Sender: TObject;
var Action: TCloseAction);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation{$R *.DFM}var
RegFile: TRegIniFile;
const
//Подсекция
SubKey: string = 'Software\RegDemo';
// Элемент для хранения логических данных
BoolKey: string = 'BoolKey';
// Элемент для хранения целочисленных данных
IntKey: string = 'IntKey';
// Элемент для хранения строчных данных
StrKey: string = 'StrKey';
procedure TForm1.FormCreate(Sender: TObject);
begin
// Создать экземпляр класса
RegFile := TRegIniFile.Create(SubKey);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
// Записать целочисленное значение
RegFile.WriteInteger(IntKey, 'Value', 1998);
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
// Записать булево значение
RegFile.WriteBool(BoolKey, 'Value', True);
end;
procedure TForm1.Button3Click(Sender: TObject);
begin
// Записать строку
RegFile.WriteString(StrKey, 'Value', 'Demo');
end;
procedure TForm1.Button4Click(Sender: TObject);
begin
// Считать целочисленное значение
Memo1.Lines.Add('Int Value = ' +
IntToStr(RegFile.ReadInteger(IntKey,
'Value', 0)));
end;
procedure TForm1.Button5Click(Sender: TObject);
begin
// Считать булево значение
if RegFile.ReadBool(BoolKey, 'Value', False) then
Memo1.Lines.Add('Bool Value = True')
else
Memo1.Lines.Add('Bool Value = False');
end;
procedure TForm1.Button6Click(Sender: TObject);
begin
// Считать строку
Memo1.Lines.Add(RegFile.ReadString(StrKey, 'Value', ''));
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
// Удалить секцию
RegFile.EraseSection(SubKey);
// Освободить память
RegFile.Free;
end;
end.
На приведенном ниже рисунке показано, как выглядит созданная нами подсекция в редакторе REGEDIT.
Отметим, что рассмотренных выше функций вполне достаточно для того чтобы обеспечить минимальную функциональность приложения. Если же вам требуется читать и записывать данные из других секций реестра, вы можете воспользоваться методами класса TRegistry или (что мене удобно) непосредственно функциями Win32 API.
Класс TRegistryПрежде чем рассмотреть пример использования свойств и методов класса TRegistry, давайте кратко перечислим их.
В следующей таблице перечислены свойства класса TRegistry.
| Свойство. | Описание. |
| CurrentKey. | Позволяет узнать текущую подсекцию, в которой проводятся операции по чтению и записи. Для изменения подсекции следует использовать методы OpenKey и OpenKeyReadOnly. |
| CurrentPath. | Позволяет узнать полное название текущей подсекции. |
| LazyWrite. | Задает способ обновления информации в реестре – непосредственно или после вызова метода CloseKey. |
| RootKey. | Задает корневую секцию в реестре. По умолчанию установлено значение HKEY_CURRENT_USER. |
В следующей таблице перечислены методы класса TRegistry.
| Метод. | Описание. |
| CloseKey. | Записывает внесенные изменения и закрывает текущую подсекцию. |
| Create. | Создает экземпляр класса TRegistry и задает значение корневой секции - HKEY_CURRENT_USER. |
| CreateKey. | Создает подсекцию. |
| DeleteKey. | Удаляет подсекцию. |
| DeleteValue. | Удаляет значение элемента. |
| Destroy. | Уничтожает ранее созданный экземпляр класса TRegistry. |
| GetDataInfo. | Возвращает тип данных для указанного элемента. |
| GetDataSize. | Возвращает размер данных для указанного элемента. |
| GetDataType. | Возвращает тип данных для указанного элемента. |
| GetKeyInfo. | Возвращает информацию о текущем элементе. |
| GetKeyNames. | Возвращает имена подсекций для указанной секции. |
| GetValueNames. | Возвращает названия элементов для указанной подсекции. |
| HasSubKeys. | Позволяет узнать, имеются ли подсекции для указанной секции. |
| KeyExists. | Позволяет узнать, существует ли элемент. |
| LoadKey. | Создает новую подсекцию и загружает в нее информацию из указанного файла. |
| MoveKey. | Перемещает указанную подсекцию и все вложенные подсекции в заданное место. |
| OpenKey. | Открывает подсекцию. |
| OpenKeyReadOnly. | Открывает подсекцию только для чтения. |
| ReadBinaryData. | Считывает данные в бинарном формате. |
| ReadBool. | Считывает данные в булевом формате. |
| ReadCurrency. | Считывает данные в формате валюты. |
| ReadDate. | Считывает данные в формате даты. |
| ReadDateTime. | Считывает данные в формате “дата/время”. |
| ReadFloat. | Считывает данные в формате с плавающей точкой. |
| ReadInteger. | Считывает данные в целочисленном формате. |
| ReadString. | Считывает данные в строчном формате. |
| ReadTime. | Считывает данные в формате времени. |
| RegistryConnect. | Устанавливает соединение с реестром на другом компьютере. |
| RenameValue. | Переименовывает элемент. |
| ReplaceKey. | Замещает значение элемента значениями из файла. |
| RestoreKey. | Восстанавливает значение элемента из файла. |
| SaveKey. | Сохраняет значение элемента в файле. |
| UnLoadKey. | Удаляет подсекцию, загруженную методом LoadKey. |
| ValueExists. | Позволяет узнать, существует ли значение у элемента. |
| WriteBinaryData. | Записывает данные в бинарном формате. |
| WriteBool. | Записывает данные в булевом формате. |
| WriteCurrency. | Записывает данные в формате валюты. |
| WriteDate. | Записывает данные в формате даты. |
| WriteDateTime. | Записывает данные в формате “дата/время”. |
| WriteExpandString. | Записывает данные в формате "расширенно" строки. |
| WriteFloat. | Записывает данные в формате с плавающей точкой. |
| WriteInteger. | Записывает данные в целочисленном формате. |
| WriteString. | Записывает данные в строчном формате. |
| WriteTime. | Записывает данные в формате времени. |
После того как мы кратко познакомились со свойствами и методами класса TRegistry, давайте рассмотрим несколько примеров их использования.
Инициализация.
Перед использованием свойств и методов класса TRegistry, необходимо создать экземпляр этого класса. Например:
var R: TRegistry; ...R := TRegistry.Create;
Задание корневой секции.
Если вы собираетесь работать с секцией, отличной от HKEY_CURRENT_USER (это значение задается по умолчанию), то после инициализации вы должны изменить значение свойства RootKey. Возможны следующие значения:
HKEY_CLASSES_ROOT HKEY_CURRENT_USER HKEY_LOCAL_MACHINE HKEY_USERS HKEY_PERFORMANCE_DATA HKEY_CURRENT_CONFIG HKEY_DYN_DATA Например: with R do begin RootKey := HKEY_LOCAL_MACHINE; // // Продолжаем работу с реестром // end;
Доступ к реестру Win9x и ME без WinAPI.
Оформил: DeeCo
Автор: Илья Маляренко.
Думаю, каждый пользователь Windows хоть раз сталкивался с необходимостью чтения данных из неактивных файлов реестра. Существует, как минимум, 2 варианта решения данной задачи: воспользоваться стандартной утилитой regedit, которая может экспортировать и импортировать данные из файлов реестра. Второй вариант: использовать очень добротную и аккуратно написанную программу regview (для MSDOS), с отличным пользовательским интерфейсом (http://paullee.ru/ - там же описание формата файлов реестра Win9x на русском). К сожалению, для работы в пакетном режиме подходит лишь regedit. При этом, скорость оставляет желать лучшего... Хочется поделиться с Вами, уважаемые, небольшим компонентом TRawRegistry для доступа к информации неактивных и активных файлов реестра формата Win9x/ME. Сразу оговорюсь: я не программист, и не собираюсь таковым быть, поэтому качество реализации оставляет желать лучшего (за неимением гербовой пишут на почтовой =) TRawRegistry - реализует все методы и свойства класса TRegistry, необходимые для чтения ключей и значений параметров из реестра. На данный момент существуют, минимум, две основные проблемы: работа с бинарными данными и общая скорость доступа к файлам. Из-за использования динамических массивов (что легко исправимо), компилируется, начиная с D4. В качестве примера прилагаю программу, использующую данный класс. Это аналог утилиты regedit, но без возможности записи какой бы то ни было информации в реестр.Скачать архив RawReg.zip (18K).
Запись строки в реестр без использования класса TRegistry.
Автор: Dimka Maslov WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Запись строки в реестр без использования класса TRegistry
Функция записывает в реестр информацию в виде строки.
Входные параметры:
RootKey - идентификатор корневого раздела реестра, например
HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_LOCAL_MACHINE и т.д.
Key - имя раздела реестра, если он не существует, то автоматически
создаётся
Name - имя параметра, для записи параметра "По умолчанию" ("Default"),
эта строка должна быть пустой
Value - значение параметра
В случае успеха функция возвращает True, или False при возникновении
ошибки записи в реестр
Зависимости: Windows
Автор: Dimka Maslov, mainbox@endimus.ru, ICQ:148442121, Санкт-Петербург
Copyright: Dimka Maslov
Дата: 13 мая 2002 г.
***************************************************** }
function RegWriteStr(RootKey: HKEY; Key, Name, Value: string): Boolean;
var
Handle: HKEY;
Res: LongInt;
begin
Result := False;
Res := RegCreateKeyEx(RootKey, PChar(Key), 0, nil, REG_OPTION_NON_VOLATILE,
KEY_ALL_ACCESS, nil, Handle, nil);
if Res <> ERROR_SUCCESS then
Exit;
Res := RegSetValueEx(Handle, PChar(Name), 0, REG_SZ, PChar(Value),
Length(Value) + 1);
Result := Res = ERROR_SUCCESS;
RegCloseKey(Handle);
end;
Относительный и полный пути файла.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{
Question:
Could anyone point me to any function that can receive
an HTML style relative path as its input and return a full path as its
output based on the exe's current location, e.g
Input: '..\..\test2.dat'
Output: C:\folder1\test2.dat
(assuming that the executable is running from
C:\folder1\folder2\folder3\Project1.exe)
}
{
Answer:
PathCombine() Concatenates two strings that represent properly
formed paths into one path, as well as any relative path pieces.
}
function PathCombine(lpszDest: PChar; const lpszDir, lpszFile: PChar):
PChar; stdcall; external 'shlwapi.dll' name 'PathCombineA';
function PathCombineA(lpszDest: PAnsiChar; const lpszDir, lpszFile:
PAnsiChar): PAnsiChar; stdcall; external 'shlwapi.dll';
function PathCombineW(lpszDest: PWideChar; const lpszDir, lpszFile:
PWideChar): PWideChar; stdcall; external 'shlwapi.dll';
{
Requires Windows 2000 (or Windows NT 4.0 with Internet Explorer 4.0 or later);
Requires Windows 98 (or Windows 95 with Internet Explorer 4.0 or later)
}
procedure TForm1.FormCreate(Sender: TObject);
var
dest: string;
BaseFile, RelativePath: String;
begin
BaseFile := 'C:\folder1\folder2\folder3\';
RelativePath := '..\..\test2.dat';
SetLength(dest, MAX_PATH);
PathCombine(@dest[1], PChar(ExtractFilePath(BaseFile)), PChar(RelativePath));
SetLength(dest, StrLen(@Dest[1]));
ShowMessage(dest);
end;
{
The ExtractRelativePath function takes a base directory but the
ExpandFilename function does the expansion based on the current
directory not a given base path.
}
RelativePath := ExtractRelativePath(ExtractFilePath(BaseFile), TargetFile);
Удаленная база данных.
Данные (файлы) удаленной базы данных находятся на удаленном компьютере. (Следует обратить внимание, что каталоги удаленного компьютера не могут рассматриваться как сетевые диски.) Программа работы с удаленной базой данных состоит из двух частей: клиентской и серверной. Клиентская часть программы, работающая на компьютере пользователя, обеспечивает взаимодействие с серверной программой: посредством запросов, передаваемых на удаленный компьютер, предоставляет доступ к данным. Серверная часть программы, работающая на удаленном компьютере, принимает запросы, выполняет их и пересылает данные клиентской программе. Запросы представляют собой команды, представленные на языке SQL (Structured Query Language) — языке структурированных запросов. Программа, работающая на удаленном сервере, проектируется таким образом, чтобы обеспечить одновременный доступ к информации нескольким пользователям. При этом для обеспечения доступа к данным вместо механизма блокировки файлов используют механизм транзакций. Транзакция — это некоторая последовательность действий, которая должна быть обязательно выполнена над данными перед тем, как они будут переданы. В случае обнаружения ошибки во время выполнения любого из действий вся последовательность действий, составляющая транзакцию, повторяется снова. Таким образом, механизм транзакций обеспечивает защиту от аппаратных сбоев. Он также обеспечивает возможность многопользовательского доступа к данным.Разработка программы работы с удаленной базы данных — сложная и трудоемкая задача. Ее решение предполагает наличие у разработчика глубоких знаний и большого опыта разработки программного обеспечения. Поэтому в данной книге задача разработки удаленных баз данных не рассматривается.
Использование Remote Debugging.
Оформил: DeeCo
Автор: Андрей Бороздин.
Довольно часто в КГ в рубрике "Программирование" можно встретить советы для начинающих программистов в среде Delphi. Однако порой газету читают и законченные программеры. Именно для них, а также для тех, кто уже имеет определенный опыт программирования, и предназначена эта статья. Не часто, но бывает так, что программа на твоем компьютере, где стоит среда разработки, запускается и работает замечательно, а вот на другой машине, например, на машине клиента, возникают какие-нибудь непонятные ошибки. Существует несколько способов отладки таких программ. Во-первых, можно поставить среду разработки пользователю на машину и там попробовать отладить программу. Однако этот вариант вряд ли можно считать удачным и отличающимся изяществом. К тому же пропадет чистота эксперимента: инсталляция Delphi может заменить какие-нибудь старые системные библиотеки Windows более новыми, после чего ошибка в программе может уже и не возникнуть. К тому же может помешать отсутствие свободного пространства на диске или нежелание пользователя. Следующий наиболее простой и незатейливый вариант — это в той части программы, где, как вы предполагаете, находится ошибка, расставить функции MessageBox (или ShowMessage) с каким-нибудь сообщением и, таким образом, более четко определить место возникновения ошибки. Этот вариант прост, как все гениальное, но обладает рядом существенных недостатков: 1. Это довольно долго и утомительно. Каждый раз приходится убирать старые функции и расставлять новые, перекомпилировать программу и копировать ее на машину клиента. 2. Ошибка может возникать в том месте, где поставить свою функцию весьма непросто. Например, в одном из стандартных модулей Delphi. 3. Ну и, наконец, можно просто банально забыть убрать какой-нибудь из МеssаgеВох'ов. Сам так не раз прокалывался. Однако в ряде случаев этот вариант может оказаться единственно возможным. Еще один вариант отладки таких программ предназначен для тех, у кого рабочая машина и машина клиента находятся в локальной сети. В состав инсталляции Delphi входит небольшая, но очень полезная утилита — Remote Debugging. Ее инсталляция находится в папке rdebug. Назначение Remote Debugging, как следует из названия, — это удаленная отладка программ. Как раз наш случай, лучше и не придумаешь. Но прежде чем воспользоваться всеми прелестями удаленной отладки программы в среде Delphi, Remote Debugging надо скопировать на машину пользователю, проинсталлировать и запустить. После чего в System Тrау'е появится изображение зеленого жучка. Вернемся к нашему проекту. В опциях проекта (Project|Options) необходимо произвести следующие изменения: 1. На вкладке Linker включить опцию Include remote debug symbols. 2. На вкладке Directories/Conditionals в поле Output directory необходимо указать путь к общедоступной папке на машине клиента (с именем машины). Если сделать это затруднительно, то можно указать папку на своей машине, а полученные после компиляции файлы с расширениями exe и rsm каждый раз копировать на машину клиента. 3. Нажмите кнопку ОК. Далее перейдем к параметрам, с которыми будет запускаться программа (Run|Parameters). На вкладке Remote необходимо указать следующие данные: 1. В поле Remote Path указать путь и имя файла на удаленной машине, где находится исполняемый файл, с сетевым именем удаленной машины. 2. В поле Remote Host надо указать сетевое имя удаленной машины или ее IP адрес. 3. Далее можно сделать следующее: Включить опцию Debug Project on remote machine и нажать кнопку ОК. Тогда после выполнения команды Run (F9) вы запустите сессию удаленной отладки. Или так: Нажать кнопку Load, чтобы сразу начать сессию удаленной отладки. Разумеется, на удаленной машине уже должны быть исполняемый файл (.exe) и файл для удаленной отладки (.rsm). После всех этих нехитрых манипуляций с настройками проекта и параметрами запуска на удаленной машине должна запуститься программа, а Delphi — перейти в состояние отладки. Далее удаленная отладка программы ничем не отличается от обычной отладки любой программы. Ну, вот, пожалуй, и все. Успешной отладки, господа программисты!
Переименование каталога.
uses
ShellApi;
procedure RenameDir(DirFrom, DirTo: string);
var
shellinfo: TSHFileOpStruct;
begin
with shellinfo do
begin
Wnd := 0;
wFunc := FO_RENAME;
pFrom := PChar(DirFrom);
pTo := PChar(DirTo);
fFlags := FOF_FILESONLY or FOF_ALLOWUNDO or
FOF_SILENT or FOF_NOCONFIRMATION;
end;
SHFileOperation(shellinfo);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
RenameDir('C:\Dir1', 'C:\Dir2');
end;
|
Добавить файлы в меню Reopen.
Оформил: DeeCo
Чтобы поместить в конец меню "Файл" список недавно отрывавшихся файлов можно создать список с этими файлами, процедуру обновления меню и процедуру открывания файла. Список файлов нужно заполнить при запуске программы. Здесь список файлов сохраняется в ini-файл. Процедура открытия файлов помещает название открываемого файла в начало списка с файлами и вызывает процедуру обновления. При закрытии программы список нужно сохранить на диске.
...
public
mi: array[0..9] of TMenuItem;
FilesCount: integer;
Files: TStringList;
procedure UpdateMenu;
procedure OpenFile(FileName: string);
procedure OnReopen(Sender: TObject);
end;
...
uses IniFiles;
procedure TForm1.UpdateMenu;
var
i: integer;
begin
for i := 0 to FilesCount - 1 do
mi[i].Destroy;
FilesCount := Files.Count;
for i := 0 to FilesCount - 1 do
begin
mi[i] := TMenuItem.Create(self);
mi[i].Caption := Files.Strings[i];
mi[i].OnClick := OnReopen;
miFile.Add(mi[i]);
end;
end;
procedure TForm1.OpenFile(FileName: string);
var
index: integer;
begin
Memo1.Lines.LoadFromFile(FileName);
index := Files.IndexOf(FileName);
if index <> 0 then
begin
if index < 0 then
Files.Insert(0, FileName)
else
Files.Exchange(0, index);
while Files.Count > 10 do
Files.Delete(10);
UpdateMenu;
end;
end;
procedure TForm1.OnReopen(Sender: TObject);
begin
OpenFile((Sender as TMenuItem).Caption);
end;
procedure TForm1.FormCreate(Sender: TObject);
var
ini: TIniFile;
i: integer;
begin
FilesCount := 0;
Files := TStringList.Create;
ini := TIniFile.Create(ExtractFilePath(ParamStr(0)) + 'files.ini');
ini.ReadSection('files', Files);
for i := 0 to Files.Count - 1 do
Files.Strings[i] := ini.ReadString('files',
Files.Strings[i], '');
ini.Destroy;
UpdateMenu;
end;
procedure TForm1.FormDestroy(Sender: TObject);
var
ini: TIniFile;
i: integer;
begin
ini := TIniFile.Create(ExtractFilePath(ParamStr(0)) +
'files.ini');
ini.EraseSection('files');
for i := 0 to Files.Count - 1 do
ini.WriteString('files', IntToStr(i),
Files.Strings[i]);
ini.Destroy;
Files.Destroy;
for i := 0 to FilesCount - 1 do
mi[i].Destroy;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenDialog1.Execute then
OpenFile(OpenDialog1.FileName);
end;
Изменение месторасположения .NET-файла во время работы.
Автор: Scott FrolichКто-нибудь знает как изменить месторасположение файла PDOXUSRS.NET во время выполнения программы?
DbiSetProp(hSessionHandle, sesNetFile, pchar('c:\newdir'));
|
Для получения дескриптора сеанса, если вы используете сессию по умолчанию, необходимо вызвать DbiGetCurrSession .
Как заменить или переместить файл, используемый другим приложением.
Автор: Marcus Neves.
В Windows NT 4/2000 есть такая API функция, имеющая очень интересный последний аргумент. Функция позволяет также переименовывать указанный файл или директорию.
MoveFileEx(ExistingFN, NewFN, MOVEFILE_REPLACE_EXISTING или MOVEFILE_DELAY_UNTIL_REBOOT |
Если задать MOVEFILE_DELAY_UNTIL_REBOOT в dwFlags (характерно для Windows NT 4/2000), то в реестр будет занесена специальная информация и после перезагрузки Windows сотрёт или перепишет указанный файл.
Параметры:
ExistingFN указатель на строку (null-terminated) , которая содержит имя нужного нам файла или директории. NewFN указатель на строку (null-terminated), содкржащую новое имя файла, указанного ExistingFN. Флаг MOVEFILE_REPLACE_EXISTING указывает функции заменить, если файл ExistingFN уже существует. Если указать в NewFN - nil, ExistingFN будет стёрт.Пример:
Перемещение файла:
MoveFileEx('c:\winnt\system32\kernel32.dll', 'd:\winnt.bak\system32\kernel32.dll',
MOVEFILE_REPLACE_EXISTING или MOVEFILE_DELAY_UNTIL_REBOOT
|
MoveFileEx('c:\winnt\system32\kernel32.dll', nil,
MOVEFILE_REPLACE_EXISTING или MOVEFILE_DELAY_UNTIL_REBOOT
|
Заменить запущенную DLL.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
function SystemErrorMessage: string;
var
P: PChar;
begin
if FormatMessage(Format_Message_Allocate_Buffer + Format_Message_From_System,
nil,
GetLastError,
0,
@P,
0,
nil) <> 0 then
begin
Result := P;
LocalFree(Integer(P))
end
else
Result := '';
end;
// Path to Original File
procedure TForm1.Button2Click(Sender: TObject);
begin
if Opendialog1.Execute then
edit1.Text := OpenDialog1.FileName;
end;
// Path to New File
procedure TForm1.Button3Click(Sender: TObject);
begin
if Opendialog2.Execute then
edit2.Text := OpenDialog2.FileName;
end;
// Replace the File.
procedure TForm1.Button1Click(Sender: TObject);
begin
if (Movefileex(PChar(Edit1.Text), PChar(Edit2.Text), MOVEFILE_DELAY_UNTIL_REBOOT) = False) then
ShowMessage(SystemErrorMessage)
else
begin
ShowMessage('Please Restart Windows to have these changes take effect');
halt;
end;
end;
Замена подстрок.
Автор: Сергею Шамайтис.
function ReplaceSub(str, sub1, sub2: string): string;
var
aPos: Integer;
rslt: string;
begin
aPos := Pos(sub1, str);
rslt := '';
while (aPos <> 0) do
begin
rslt := rslt + Copy(str, 1, aPos - 1) + sub2;
Delete(str, 1, aPos + Length(sub1) - 1);
aPos := Pos(sub1, str);
end;
Result := rslt + str;
end;
|
Заменяем текст в текстовом файле.
| Идут два мужика: один - сисадмин, другой - тоже козел. |
procedure FileReplaceString(const FileName, searchstring, replacestring: string);
var
fs: TFileStream;
S: string;
begin
fs := TFileStream.Create(FileName, fmOpenread or fmShareDenyNone);
try
SetLength(S, fs.Size);
fs.ReadBuffer(S[1], fs.Size);
finally
fs.Free;
end;
S := StringReplace(S, SearchString, replaceString, [rfReplaceAll, rfIgnoreCase]);
fs := TFileStream.Create(FileName, fmCreate);
try
fs.WriteBuffer(S[1], Length(S));
finally
fs.Free;
end;
end;
|
Заменить текст в документе Word.
uses
ComObj;
// Replace Flags
type
TWordReplaceFlags = set of (wrfReplaceAll, wrfMatchCase,
wrfMatchWildcards);
function Word_StringReplace(ADocument: TFileName; SearchString,
ReplaceString: string; Flags: TWordReplaceFlags): Boolean;
const
wdFindContinue = 1;
wdReplaceOne = 1;
wdReplaceAll = 2;
wdDoNotSaveChanges = 0;
var
WordApp: OLEVariant;
begin
Result := False;
{ Check if file exists }
if not FileExists(ADocument) then
begin
ShowMessage('Specified Document not found.');
Exit;
end;
{ Create the OLE Object }
try
WordApp := CreateOLEObject('Word.Application');
except
on E: Exception do
begin
E.Message := 'Word is not available.';
raise;
end;
end;
try
{ Hide Word }
WordApp.Visible := False;
{ Open the document }
WordApp.Documents.Open(ADocument);
{ Initialize parameters}
WordApp.Selection.Find.ClearFormatting;
WordApp.Selection.Find.Text := SearchString;
WordApp.Selection.Find.Replacement.Text := ReplaceString;
WordApp.Selection.Find.Forward := True;
WordApp.Selection.Find.Wrap := wdFindContinue;
WordApp.Selection.Find.Format := False;
WordApp.Selection.Find.MatchCase := wrfMatchCase in Flags;
WordApp.Selection.Find.MatchWholeWord := False;
WordApp.Selection.Find.MatchWildcards := wrfMatchWildcards in Flags;
WordApp.Selection.Find.MatchSoundsLike := False;
WordApp.Selection.Find.MatchAllWordForms := False;
{ Perform the search}
if wrfReplaceAll in Flags then
WordApp.Selection.Find.Execute(Replace := wdReplaceAll)
else
WordApp.Selection.Find.Execute(Replace := wdReplaceOne);
{ Save word }
WordApp.ActiveDocument.SaveAs(ADocument);
{ Assume that successful }
Result := True;
{ Close the document }
WordApp.ActiveDocument.Close(wdDoNotSaveChanges);
finally
{ Quit Word }
WordApp.Quit;
WordApp := Unassigned;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Word_StringReplace('C:\Test.doc','Old String','New String',
[wrfReplaceAll]);
end;
|
Word для генерации отчетов.
| Работающая над программой группа питает отвращение к еженедельной отчетности о достигнутых результатах, поскольку она слишком явно свидетельствует об отсутствии таковых. |
var
Word: Variant;
begin
Word := CreateOleObject('Word.Basic');
with Word do
begin {Затем следуют "чистые" команды WordBASIC...}
FileNew('Normal');
Insert('Это первая строчка'#13);
Insert('Это вторая строчка'#13);
FileSaveAs('c:\temp\test.txt', 3);
end;
end;
|
Резидентная программа.
| - Как бы вы поступили, если бы случайно оказались в одной камере с Гитлером, Саддамом Хусейном и Билли Гейтсом, и у вас, случайно, оказался с собой пистолет и два патрона? - Сначала два раза выстрелил бы в Гейтса, а потом рукояткой его, рукояткой. |
Почти для любого действия нам понадобится окно. Но видеть нам его не нужно. Поэтому, создадим невидимое окно. Для этого нужно зарегистрировать класс окна и создать его, но не показывать. Эти два действия происходят в функции CreateMyWnd. Чтобы было возможно общение пользователя с программой, можно сделать TrayIcon (иконку справа на панели задач). Она создается в процедуре CreateTray. Иконку я взял, наверное, не самую подходящую, но это для примера. Точно так же можно взять собственную иконку. Для tray также нужно всплывающее меню. Здесь оно создается в функции CreateMyMenu и состоит всего из одного пункта. Резидентные программы обычно отслеживают что-то. Для этой цели бывает необходим таймер. Создается он при помощи SetTimer. Чтобы наша программа не "тормозила" компьютер, приоритет программы лучше всего установить в самый низкий. Конечно, это хорошо не во всех случаях, но иногда это весьма полезно. Эта программа занимается тем, что запускает ScreenSaver при сдвиге курсора в левый верхний угол (координаты курсора проверяются каждую секунду) и при нажатии клавиши Pause (реализуются через HotKey). Задача, конечно, не самая актуальная. Присылайте, пожалуйста, ваши идеи по поводу задач для резидентной программы.
program MyResident;
uses
Windows,
ShellAPI,
Messages;
const
ClassName = 'MyResident'; { Имя класса }
WM_NOTIFYTRAYICON = WM_USER + 1; { Это сообщение будет
генерироваться при событиях с tray }
var
menu: hMenu; { Всплывающее меню }
mywnd: hWnd; { Окно программы }
function MyWndProc(wnd: hWnd; msg, wParam,
lParam: longint): longint; stdcall;
var
p: TPoint;
s: array [0..255] of char;
tray: TNotifyIconData;
begin
case msg of
WM_TIMER: begin { Событие таймера }
GetCursorPos(p);
if (p.x = 0) and (p.y = 0) then begin { Проверка координат курсора }
{ Если ScreenSaver еще не запущен - запустить: }
GetClassName(GetForegroundWindow, s, length(s));
if s <> 'WindowsScreenSaverClass'
then SendMessage(wnd, WM_SYSCOMMAND, SC_SCREENSAVE, 0);
end;
result := 0;
end;
WM_NOTIFYTRAYICON: begin { Событие tray }
{ Если нажата правая кнопка, показать меню: }
if lparam = WM_RBUTTONUP then begin
GetCursorPos(p);
TrackPopupMenu(menu, TPM_LEFTALIGN, p.x, p.x, 0, wnd, nil);
end;
result := 0;
end;
WM_COMMAND: begin { Выбран пункт меню }
{ Если выбран нулевой пункт (здесь - единственный) -
закрыть программу: }
if lo(lparam) = 0 then SendMessage(mywnd, WM_CLOSE, 0, 0);
result := 0;
end;
WM_HOTKEY: begin { Нажата горячая клавиша }
{ Запуск хранителя экрана: }
SendMessage(wnd, WM_SYSCOMMAND, SC_SCREENSAVE, 0);
result := 0;
end;
WM_DESTROY: begin { Закрытие программы }
{ Удаление tray: }
with tray do begin
cbSize := sizeof(TNotifyIconData);
wnd := mywnd;
uID := 0;
end;
Shell_NotifyIcon(NIM_DELETE, @tray);
PostQuitMessage(0);
result := 0;
end;
else Result := DefWindowProc(wnd, msg, WParam, LParam);
end;
end;
function CreateMyWnd: hWnd;
var
wc: WndClass;
begin
{ Гегистрация класса: }
wc.style := 0;
wc.lpfnWndProc := @MyWndProc;
wc.cbClsExtra := 0;
wc.cbWndExtra := 0;
wc.hInstance := hInstance;
wc.hIcon := 0;
wc.hCursor := 0;
wc.hbrBackground := COLOR_WINDOW;
wc.lpszMenuName := nil;
wc.lpszClassName := ClassName;
if RegisterClass(wc) = 0 then halt(0);
{ Создание окна: }
result := CreateWindowEx(WS_EX_APPWINDOW, ClassName,
'My Window', WS_POPUP, 0, 0, 0, 0, 0, 0, hInstance, nil);
if result = 0 then halt(0);
end;
procedure CreateTray;
var
tray: TNotifyIconData;
begin
{ Создание tray: }
with tray do begin
cbSize := sizeof(TNotifyIconData);
wnd := mywnd;
uID := 0;
uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP;
uCallBackMessage := WM_NOTIFYTRAYICON;
hIcon := LoadIcon(0, IDI_ASTERISK);
szTip := ('My Resident');
end;
Shell_NotifyIcon(NIM_ADD, @tray);
end;
function CreateMyMenu: hMenu;
begin
{ Создание меню: }
result := CreatePopupMenu;
if result = 0 then halt(0);
if not AppendMenu(result, MF_STRING, 0, 'Exit') then halt(0);
end;
var
msg: TMsg;
begin
mywnd := CreateMyWnd; // Создание окна
CreateTray; // Создание tray
menu := CreateMyMenu; // Создание меню
SetThreadPriority(GetCurrentThread, THREAD_PRIORITY_IDLE); { Установка
низкого приоритета }
RegisterHotKey(mywnd, 0, 0, VK_PAUSE); // Регистрация "горячей клавиши"
SetTimer(mywnd, 0, 1000, nil); // Создание таймера
while (GetMessage(msg, 0, 0, 0)) do begin
TranslateMessage(msg);
DispatchMessage(msg);
end;
KillTimer(mywnd, 0); // Уничтожение таймера
UnregisterHotKey(mywnd, 0); // "Уничтожение" горячей клавиши
end.
|
Резидентная программа и записная книжка.
| Автор: Даниил Карапетян WEB сайт: http://program.dax.ru |
| Занимаются любовью хакер и эпилептичка, тут у нее приступ эпилепсии ну а он думает о как ей хорошо, ну он закончил, а она все еще в приступе ну он говорит эй ты чего а она ноль внимания - у нее приступ. Тогда он звонит 03 и говорит у меня тут проблема , а его спрашивают в чем дело на что он отвечает Да по моему оргазм завис... |
В прошлом выпуске программа отслеживала координаты курсора и, если мышь была в левом верхнем углу экрана, запускала ScreenSaver. Чтобы при следующей проверке координат курсора не запускать ScreenSaver повторно, программа проверяла, какое окно сейчас активно. Дело в том, что стандартные хранители экрана в некоторых версиях Windows всегда создают окна с названием класса 'WindowsScreenSaverClass'. Но, поскольку работает это не всюду, я решил убрать эту функцию.
program Project1;
uses
Windows,
ShellAPI,
Messages;
const
ClassName = 'MyResident'; // Имя класса
WM_NOTIFYTRAYICON = WM_USER + 1; { Это сообщение будет
генерироваться при событиях с tray }
var
menu: hMenu; // Всплывающее меню
mywnd: hWnd; // Окно программы
memo: hWnd = 0; // Окно записной книжки
OldMemoProc: Pointer; // Стандартная оконная процедура Edit
// Оконная процедура записной книжки:
function MemoWndProc(wnd: hWnd; msg, wParam,
lParam: longint): longint; stdcall;
var
s: PChar;
len: integer;
F: File;
begin
case msg of
WM_DESTROY: begin // Окно закрывается
// Сохранение текста:
len := GetWindowTextLength(memo);
GetMem(s, len + 1);
GetWindowText(memo, s, len + 1);
AssignFile(F, 'memo.txt');
Rewrite(F, 1);
BlockWrite(F, s^, len);
CloseFile(F);
FreeMem(s);
result := 0;
memo := 0;
end;
WM_KEYUP: begin // Нажата клавиша
if wparam = VK_ESCAPE // Нажат Escape
then result := SendMessage(memo, WM_CLOSE, 0, 0)
else result := DefWindowProc(wnd, msg, wparam, lparam);
end;
// Иначе - вызвать старую оконную процедуру
else result := CallWindowProc(OldMemoProc, wnd, msg, wparam, lparam);
end;
end;
// Создание окна записной книжки:
procedure CreateMemo;
var
len: cardinal;
F: hFile;
s: PChar;
ReadBytes: cardinal;
begin
// Если записная книжка уже открыта - выход из процедуры:
if GetForegroundWindow = memo then Exit;
// Создание окна:
memo := CreateWindowEx(WS_EX_PALETTEWINDOW, 'EDIT', nil,
WS_POPUP or WS_SIZEBOX or WS_VSCROLL or
ES_MULTILINE or ES_AUTOVSCROLL,
GetSystemMetrics(SM_CXFULLSCREEN) div 2 - 200,
GetSystemMetrics(SM_CYFULLSCREEN) div 2 - 200,
400, 400, 0, 0, hinstance, nil);
// Установка шрифта:
SendMessage(memo, WM_SETFONT, GetStockObject(SYSTEM_FIXED_FONT), 0);
// Сохранение старой и установка новой оконной процедуры:
OldMemoProc := Pointer(GetWindowLong(memo, GWL_WNDPROC));
SetWindowLong(memo, GWL_WNDPROC, longint(@MemoWndProc));
{ Открытие файла (здесь удобнее воспользоваться функциями WinAPI): }
try
F := CreateFile('memo.txt', GENERIC_READ, FILE_SHARE_READ, nil,
OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0);
if F = INVALID_HANDLE_VALUE then Exit;
len := GetFileSize(F, nil);
if len = $FFFFFFFF then Exit;
GetMem(s, len + 1);
ReadFile(F, s^, len, ReadBytes, nil);
SetWindowText(memo, s);
CloseHandle(F);
FreeMem(s);
except SetWindowText(memo, 'Error') end;
// Показать окно:
ShowWindow(memo, SW_SHOW);
UpdateWindow(memo);
end;
// Главная оконная процедура:
function MyWndProc(wnd: hWnd; msg, wParam,
lParam: longint): longint; stdcall;
var
p: TPoint;
tray: TNotifyIconData;
ProgmanWnd: hWnd;
begin
case msg of
WM_NOTIFYTRAYICON: begin // Событие tray
// Если нажата правая кнопка, показать меню:
if lparam = WM_RBUTTONUP then begin
SetForegroundWindow(mywnd);
GetCursorPos(p);
TrackPopupMenu(menu, TPM_LEFTALIGN, p.x, p.x, 0, wnd, nil);
end;
result := 0;
end;
WM_COMMAND: begin // Выбран пункт меню
{ В зависимости от выбранного пункта меню открывается
записная книжка, запускается ScreenSaver, "усыпляется"
компьютер или закрывается программа: }
case loword(wparam) of
0: CreateMemo;
1: SendMessage(mywnd, WM_SYSCOMMAND, SC_SCREENSAVE, 0);
2: SetSystemPowerState(true, true);
4: SendMessage(mywnd, WM_CLOSE, 0, 0);
end;
result := 0;
end;
WM_HOTKEY: begin // Нажата горячая клавиша
case loword(lparam) of
// Нажата клавиша Pause:
0: SendMessage(wnd, WM_SYSCOMMAND, SC_SCREENSAVE, 0);
// Нажаты клавиши Alt+Pause:
MOD_ALT: begin
ProgmanWnd := FindWindow('Progman', 'Program Manager');
if ProgmanWnd <> 0
then SendMessage(ProgmanWnd, WM_CLOSE, 0, 0);
end;
// Нажаты клавиши Alt+Shift+Pause:
MOD_ALT or MOD_SHIFT: SetSystemPowerState(true, true);
// Иначе:
else CreateMemo;
result := 0;
end;
WM_ACTIVATEAPP: begin // Изменение активности приложения
{ Если приложение потеряло активность - закрыть (если нужно)
записную книжку: }
if (memo <> 0) and (wparam = 0)
then SendMessage(memo, WM_CLOSE, 0, 0);
result := 0;
end;
WM_DESTROY: begin // Закрытие программы
// Удаление tray:
with tray do begin
cbSize := sizeof(TNotifyIconData);
wnd := mywnd;
uID := 0;
end;
Shell_NotifyIcon(NIM_DELETE, @tray);
PostQuitMessage(0);
result := 0;
end;
else result := DefWindowProc(wnd, msg, WParam, LParam);
end;
end;
// Создание окна:
function CreateMyWnd: hWnd;
var
wc: WndClass;
begin
// Регистрация класса:
wc.style := CS_HREDRAW or CS_VREDRAW;
wc.lpfnWndProc := @MyWndProc;
wc.cbClsExtra := 0;
wc.cbWndExtra := 0;
wc.hInstance := hInstance;
wc.hIcon := LoadIcon(hinstance, IDI_ASTERISK);
wc.hCursor := LoadCursor(hinstance, IDC_ARROW);
wc.hbrBackground := COLOR_INACTIVECAPTION;
wc.lpszMenuName := nil;
wc.lpszClassName := ClassName;
if RegisterClass(wc) = 0 then halt(0);
// Создание окна:
result := CreateWindowEx(WS_EX_APPWINDOW, ClassName,
'My Window', WS_POPUP, 100, 100, 200, 200, 0, 0, hInstance, nil);
if result = 0 then halt(0);
end;
// Создание Tray:
procedure CreateTray;
var
tray: TNotifyIconData;
begin
with tray do begin
cbSize := sizeof(TNotifyIconData);
wnd := mywnd;
uID := 0;
uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP;
uCallBackMessage := WM_NOTIFYTRAYICON;
hIcon := LoadIcon(0, IDI_ASTERISK);
szTip := ('My Resident');
end;
Shell_NotifyIcon(NIM_ADD, @tray);
end;
// Создание всплывающего меню:
function CreateMyMenu: hMenu;
begin
result := CreatePopupMenu;
if result = 0 then Exit;
AppendMenu(result, MF_STRING, 0, 'Memo');
AppendMenu(result, MF_STRING, 1, 'ScreenSaver');
AppendMenu(result, MF_STRING, 2, 'Sleep');
AppendMenu(result, MF_SEPARATOR, 3, 'Exit');
AppendMenu(result, MF_STRING, 4, 'Exit');
end;
var
msg: TMsg;
begin
mywnd := CreateMyWnd; // Создание окна
CreateTray; // Создание tray
menu := CreateMyMenu; // Создание меню
// Установка низкого приоритета:
SetThreadPriority(GetCurrentThread, THREAD_PRIORITY_IDLE);
// Регистрация "горячих клавиш":
RegisterHotKey(mywnd, 0, 0, VK_PAUSE);
RegisterHotKey(mywnd, 1, MOD_ALT, VK_PAUSE);
RegisterHotKey(mywnd, 2, MOD_SHIFT, VK_PAUSE);
RegisterHotKey(mywnd, 3, MOD_ALT or MOD_SHIFT, VK_PAUSE);
// Распределение сообщений:
while (GetMessage(msg, 0, 0, 0)) do begin
TranslateMessage(msg);
DispatchMessage(msg);
end;
// "Уничтожение" горячих клавиш:
UnregisterHotKey(mywnd, 0);
UnregisterHotKey(mywnd, 1);
UnregisterHotKey(mywnd, 2);
end.
|
Момент окончания изменения размера или перемещения окна.
type
TForm1 = class(TForm)
private
{ Private declarations }
public
procedure WMEXITSIZEMOVE(var Message: TMessage);
message WM_EXITSIZEMOVE;
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.WMEXITSIZEMOVE(var Message: TMessage);
begin
Form1.Caption := 'Finished Moving and sizing';
end;
|
Изменение размеров колонок DBGrid.
| Если у тебя есть постоянная девушка, то на всех вечеринках приходится использовать установки "default" (по умолчанию). Можно попробовать переустановить "систему" в режиме "custom", но получаться те же самые Windows-совские глюки. Если ты Unix-оид, то у тебя, скорей всего, нет постоянной девушки. |
Вы можете изменить размер колонки во время выполнения программы, изменяя свойство DisplayWidth соответствующего поля компонента DBGrid...
MyTableMyField.DisplayWidth := Length(MyTableMyField.value); |
Если Вам действительно необходимо вычислить ширину всего DBGrid, используйте следующий код:
function NewTextWidth(fntFont: TFont; const sString: OpenString): integer;
var
fntSave: TFont;
begin
result := 0;
fntSave := Application.MainForm.Font;
Application.MainForm.Font := fntFont;
try
result := Application.MainForm.Canvas.TextWidth(sString);
finally
Application.MainForm.Font := fntSave;
end;
end;
{ вычисляем ширину табличной сетки, которую необходимо отобразить без }
{ горизонтальной полосы прокрутки и без дополнительного пространства между последней }
{ колонкой и вертикальной полосой прокрутки. Свойство Datasource у компонента DBGrid, }
{ как и свойство Dataset у Datasource должны быть назначены заранее, }
{ но таблица не должна быть открытой. Примечание: полученная ширина включает ширину }
{ вертикальной полосы прокрутки, полученной на основе базового режима }
{ отображения. Вычисленная ширина полностью занимает рабочую область компонента. }
function iCalcGridWidth(
dbg: TDBGrid { корректируемый компонент }
): integer; { "точная" ширина }
const
cMEASURE_CHAR = '0';
iEXTRA_COL_PIX = 4;
iINDICATOR_WIDE = 11;
var
i, iColumns, iColWidth, iTitleWidth, iCharWidth: integer;
begin
iColumns := 0;
result := GetSystemMetrics(SM_CXVSCROLL);
iCharWidth := NewTextWidth(dbg.Font, cMEASURE_CHAR);
with dbg.dataSource.dataSet do
for i := 0 to FieldCount - 1 do
with Fields[i] do
if visible then
begin
iColWidth := iCharWidth * DisplayWidth;
if dgTitles in dbg.Options then
begin
iTitleWidth := NewTextWidth(dbg.TitleFont, DisplayLabel);
if iColWidth < iTitleWidth then
iColWidth := iTitleWidth;
end;
inc(iColumns, 1);
inc(result, iColWidth + iEXTRA_COL_PIX);
end;
if dgIndicator in dbg.Options then
begin
inc(iColumns, 1);
inc(result, iINDICATOR_WIDE);
end;
if dgColLines in dbg.Options then
inc(result, iColumns)
else
inc(result, 1);
end;
|
Я должен использовать функцию NewTextWidth, а не Canvas.TextWith компонента DBGrid, так как Canvas еще не инициализирован во время вызова iCalcGridWidth.
При изменении размеров окна без заголовка сначала отрисовывается рамка будущих размеров.
Автор: i-s-v WEB-сайт: http://isv.iatp.org.uaВот пример для правого нижнего угла окна, в котором расположен Image1 (или еще что-нибудь).
...
const
MinHeight = 200;
MinWidth = 200; //Минимальная ширина и высота формы. При желании
можна и впихнуть максимальную
var
isResizing: boolean = false;
oldPos: TPoint;
WRect: TRect;
...
procedure TfrmMain.Image1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
isResizing := true;
oldPos := Mouse.CursorPos;
GetWindowRect(Handle, WRect); //получаем прямоугольник окна
DrawFocusRect(GetDC(0), WRect); //АПИ функция, рисующая рамку
end;
procedure TfrmMain.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
var
dx, dy: integer;
begin
if isResizing then
begin
DrawFocusRect(GetDC(0), WRect); //стираем предыдущую рамку
dx := Mouse.CursorPos.X - oldPos.X;
dy := Mouse.CursorPos.Y - oldPos.Y;
if (WRect.Right - WRect.Left + dx > MinWidth) and (WRect.Right + dx <
Screen.Width) then
WRect.Right := WRect.Right + dx;
if (WRect.Bottom - WRect.Top + dy > MinHeight) and (WRect.Bottom + dy <
Screen.Height) then
WRect.Bottom := WRect.Bottom + dy;
end;
oldPos := Mouse.CursorPos;
DrawFocusRect(GetDC(0), WRect);
end;
end;
procedure TfrmMain.Image1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if isResizing then
begin
DrawFocusRect(GetDC(0), WRect);
BoundsRect := WRect;
end;
isResizing := false;
end;
Изменить размер Jpeg и сохранить его в новый файл.
| В Интернете прошел первый конкурс красоты. Звание Мисс Интернет завоевала девушка В_21399КS.JРG. Поздравляем победительницу! |
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;
end;
|
Панель с изменяющимися размерами.
Привожу исходный код для создания панелей с изменяющимися размерами. Воровняйте панель по области клиента свойством alClient, расположите на ней несколько элементов управления и посмотрите как меняются размеры во время изменения размера формы при выполнении программы. Можно расширить код и запретить изменения размеров во время проектирования, но это я оставляю для вас. Данная технология может и не идеальна, поскольку я накропал код за считанные минуты, но для выполнения моих задач этого достаточно.
unit Elastic;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, ExtCtrls;
type
TElasticPanel = class(TPanel)
private
FHorz, FVert: boolean;
nOldWidth, nOldHeight: integer;
bResized: boolean;
protected
procedure WMSize(var message: TWMSize); message WM_SIZE;
public
nCount: integer;
constructor Create(AOwner: TComponent); override;
published
property ElasticHorizontal: boolean read FHorz write FHorz default
TRUE;
property ElasticVertical: boolean read FVert write FVert default
TRUE;
end;
procedure Register;
implementation
constructor TElasticPanel.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FHorz := TRUE;
FVert := TRUE;
nOldWidth := Width;
nOldHeight := Height;
bResized := FALSE;
end;
procedure TElasticPanel.WMSize(var message: TWMSize);
var
bResize: boolean;
xRatio: real;
i: integer;
ctl: TWinControl;
begin
Inc(nCount);
if Align = alNone then
bResize := TRUE
else
bResize := bResized;
if not (csDesigning in ComponentState) and bResize then
begin
if FHorz then
begin
xRatio := Width / nOldWidth;
for i := 0 to ControlCount - 1 do
begin
ctl := TWinControl(Controls[i]);
ctl.Left := Round(ctl.Left * xRatio);
ctl.Width := Round(ctl.Width * xRatio);
end;
end;
if FVert then
begin
xRatio := Height / nOldHeight;
for i := 0 to ControlCount - 1 do
begin
ctl := TWinControl(Controls[i]);
ctl.Top := Round(ctl.Top * xRatio);
ctl.Height := Round(ctl.Height * xRatio);
end;
end;
end
else
begin
nOldWidth := Width;
nOldHeight := Height;
end;
bResized := TRUE;
nOldWidth := Width;
nOldHeight := Height;
end;
procedure Register;
begin
RegisterComponents('Additional', [TElasticPanel]);
end;
end.
|
Ограничение на изменение размера формы по размеру панели на ней.
Автор: Xavier Pacheco
{
Copyright © 1999 by Delphi 5 Developer's Guide - Xavier Pacheco and Steve Teixeira
}
unit BlueBackFrm;
interface
uses
SysUtils, Windows, Messages, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Buttons, ExtCtrls;
type
TBlueBackForm = class(TForm)
pnlMain: TPanel;
bbtnOK: TBitBtn;
bbtnCancel: TBitBtn;
procedure FormResize(Sender: TObject);
private
procedure CenterPanel;
{ Create a message handler for the WM_WINDOWPOSCHANGING message }
procedure WMWindowPosChanging(var Msg: TWMWindowPosChanging);
message WM_WINDOWPOSCHANGING;
end;
var
BlueBackForm: TBlueBackForm;
implementation
uses Math;
{$R *.DFM}
procedure TBlueBackForm.CenterPanel;
{ This procedure centers the main panel horizontally and
vertically inside the form's client area
}
begin
{ Center horizontally }
if pnlMain.Width < ClientWidth then
pnlMain.Left := (ClientWidth - pnlMain.Width) div 2
else
pnlMain.Left := 0;
{ Center vertically }
if pnlMain.Height < ClientHeight then
pnlMain.Top := (ClientHeight - pnlMain.Height) div 2
else
pnlMain.Top := 0;
end;
procedure TBlueBackForm.WMWindowPosChanging(var Msg: TWMWindowPosChanging);
var
CaptionHeight: integer;
begin
{ Calculate the caption height }
CaptionHeight := GetSystemMetrics(SM_CYCAPTION);
{ This procedure does not take into account the width and
height of the form's frame. You can use
GetSystemMetrics() to obtain these values. }
// Prevent window from shrinking smaller then MainPanel's width
Msg.WindowPos^.cx := Max(Msg.WindowPos^.cx, pnlMain.Width + 20);
// Prevent window from shrinking smaller then MainPanel's width
Msg.WindowPos^.cy := Max(Msg.WindowPos^.cy, pnlMain.Height + 20 +
CaptionHeight);
inherited;
end;
procedure TBlueBackForm.FormResize(Sender: TObject);
begin
CenterPanel; // Center MainPanel when the form is resized.
end;
end.
Различные разрешения - различные размеры шрифтов.
Я также долго мучился над проблемой решения этого вопроса, и ниже я излагаю свои выводы на основании моих многочисленных экспериментов. Свойство, отвечающее за размер шрифта важно, но не менее важны в этом вопросе и другие характеристики. Я получал безобразные результаты при изменении резолюции, пока я не начал задавать размер шрифта в пикселях (pixels) вместо точек (points). Вы можете установить font.height, и вы можете установить font.size. Я обнаружил, что установка значения font.height дает значительно лучшие результаты, поскольку данное свойство определяет количество пикселей, и размер шрифта меняется пропорционально изменению размера пиксела. Также, вы можете обнаружить, что шрифт по-умолчанию не может быть ниже определенной высоты. Будет гораздо лучше, если вместо SYSTEM вы выберите шрифт MS sans-serif. У формы имеется свойство, названное "scaling" (взял из памяти, надеюсь верно). Я обнаружил, что лучше его иметь выключенным. Если свойство включено, Delphi или Windows пытаются при изменении размера формы все соответствено смаштабировать. Все это хорошо только для сохранения относительных позиций элементов, так что я выключил свойство, и больше о нем не вспоминал. Если свойство выключено, а форма ваша максимизирована, вы обнаружите, что все ваши компоненты устремились вслед за левым верхним углом формы. Где не желателен этот эффект, я получал разрешение экрана (Screen.Height и Screen.Width) и прислаивал свойствам компонентов Left и Тор скорректированные свойства прежде, чем форма успевала появиться (в методе OnCreate, во время выполения приложения).В целом же, завершая рассказ, следует подчеркнуть, что выключенное свойство scaling и использование пикселей вместо точек для изменения размеров шрифта, дает вполне приемлимый результат.
Как из своего приложения определить загрузку ресурсов GDI и USER.
| Автор: Nomadic |
| Подходит фидошник к ларьку с надписью "ПИРОЖКИ". - Мне два сабжа пожалуйста. |
{$APPTYPE CONSOLE}
// индикатор ресурсов
program res;
function MyGetFreeSystemResources32(Id: integer): integer;
stdcall; external 'rsrc32' name '_MyGetFreeSystemResources32@4';
const
rSystem = 0;
rGDI = 1;
rUSER = 2;
begin
writeln('free resources');
writeln('System:', MyGetFreeSystemResources32(rSystem), '%');
writeln('GDI:', MyGetFreeSystemResources32(rGDI), '%');
writeln('USER:', MyGetFreeSystemResources32(rUSER), '%');
end.
|
Пример ресурсной таблицы строк.
Автор: Ralph Friedman Как мне создать ресурсную таблицу строк (Resource String Table), про которую упоминается в функции FmtLoadStr, но не сказано как создать эту таблицу, про это вообще нигде не сказано! Создайте файл в приведенном ниже формате и обзовите его, скажем (подойдите к этому творчески), strings.rc:
STRINGTABLE LOADONCALL MOVEABLE DISCARDABLE
{
1, "UNPACK.INI"
2, "AcrobatClass"
3, "ACROEXCH.EXE"
4, "^.PDF"
5, "Extensions"
6, "ACROEXCH.EXE"
7, "PDF"
8, "AABSETUP.EXE"
9, "DelFiles-"
10, "INI-"
11, "UNPACK.INI"
12, "ACROSRCH.DLL"
13, "Regedit"
14, "ACROREAD.EXE"
15, "ACRO_LE.EXE"
}
Затем, с помощью компилятора ресурсов Borland (BRCC.EXE в вашем каталоге Delphi\Bin), скомпилируйте это в файл ресурсов: BRCC strings.rc
Вы получите файл с именем strings.res. В вашем .DPR-файле после строки {$R *.RES} добавьте строку {$R STRINGS.RES}, после этого строковые ресурсы будут компилироваться с вашим exe-файлом.
Поимей Resource Scrutator version 1.21 by CitruSoft Laboratory нахаляву.
Оформил: DeeCo Автор: http://www.cracklab.narod.ru
Автор: vallkor (vallkor@ukr.net) Эта программа просматривает ресурсы программ, но сохранять эти ресурсы можно только при регистрации. Программа довольно таки плохенькая, для 35 баксов (для сравнения Ресторатор стоит 20 баков, но выглядит удачнее). Ну да ладно, все равно у меня лишних 35 баксов не было, а сохранять ресурсы ой как хочется... И тут меня осенило: ведь если можно запустить программу, её можно сломать, как говорил орк! Приступим... Зайдём в Help->Register Resource Scrutator и что мы там видим:имя/е-mail/RegIDвсё как везде, исключая мыло. Может оно для понта? поживем увидим. Я ввожу vallkor/vallkor@ukr.net/123321 открываю SoftIce (далее айс) и ставлю брекпоинт
GetDlgItemTextA GetWindowTextAне работает...
bpx MessageboxAне пашет - на верное написано на Делфи, подумал Штирлиц. Мда, ладно, тогда ставим брекпоинт bpx LoadIconA (это загрузка иконки в сообщении о неверном СН) Ура! работает, мда! Теперь поишем в памяти наш номер:
s ds:0 l ffffffff "123321"у меня был найден по адресу 0167:00СЗСЧСЧ теперь проверим на наличие самой распространенной ошибки: когда сгенерен правильный СН он не затирается, а остается в памяти причем очень близко от неправильного (стек то не резиновый :) ). Так оно и получилось, в окне просмотра данных на две строчки вверх я увидел свой СН: 780420182321. Вот и всё, в принципе. Безболезненное излечение. ЗЫ: уважаемые, если хотите получать за программы по 35 баков, то делайте защиту получше.
Перезапустить свою программу.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
procedure TForm1.Button1Click(Sender: TObject); var FullProgPath: PChar; begin FullProgPath := PChar(Application.ExeName); // ShowWindow(Form1.handle,SW_HIDE); WinExec(FullProgPath, SW_SHOW); // Or better use the CreateProcess function Application.Terminate; // or: Close; end;
Восстановление размера окна.
Автор: Mike Orriss Существует ли какой-либо способ получения координат формы, которые она должна иметь при восстановлении с максимально распахнутого состояния?Используйте API Функцию GetPlacement. Следующая выдержка из кода моего компонента TBag демонстрирует это:
procedure TBag.SetFormPlace(AName: string; AForm: TForm);
var
s: string[99];
Place: TWindowPlacement;
begin
Place.length := SizeOf(TWindowPlacement);
if not GetWindowPlacement(AForm.Handle, @Place) then
exit;
with Place do
begin
s := IntToStr(Flags);
s := AppendS(s, ShowCmd);
s := AppendS(s, ptMinPosition.X);
s := AppendS(s, ptMinPosition.Y);
s := AppendS(s, ptMaxPosition.X);
s := AppendS(s, ptMaxPosition.Y);
s := AppendS(s, rcNormalPosition.Left);
s := AppendS(s, rcNormalPosition.Top);
s := AppendS(s, rcNormalPosition.Right);
s := AppendS(s, rcNormalPosition.Bottom);
end;
SetString(AName, s);
end;
|
Восстанавление длинных имен файлов по известным коротким.
| Автор: Boris |
| Мой Windows понима~1 длинны~1 имена, а твой? |
//---------------------------------------------------------------------
// Восстанавливает длинные имена файлов по известным коротким (8.3)
// В качестве аргумента принимает полный или неполный (в т.ч. относительный)
// путь к файлу, например 'C:\WINDОWS\РАБОЧИ~1\ИТАКДА~1.LNK' или
// '..\..\COMMON~1\BORLAN~1\BDE\BDEREA~1.TXT'. Понимает сетевые имена.
// Возвращает полный(!) путь типа 'C:\Windоws\Рабочий стол\и так далее.lnk',
// 'C:\Program Files\Common Files\Borland Shared\BDE\bdereadme.txt',
// '\\Computer\resource\Folder with long name\File with long name.ext'
//---------------------------------------------------------------------
function RestoreLongName(fn: string): string;
function LookupLongName(const filename: string): string;
var
sr: TSearchRec;
begin
if FindFirst(filename, faAnyFile, sr) = 0 then
Result := sr.Name
else
Result := ExtractFileName(filename);
SysUtils.FindClose(sr);
end;
function GetNextFN: string;
var
i: integer;
begin
Result := '';
if Pos('\\', fn) = 1 then
begin
Result := '\\';
fn := Copy(fn, 3, length(fn) - 2);
i := Pos('\', fn);
if i <> 0 then
begin
Result := Result + Copy(fn, 1, i);
fn := Copy(fn, i + 1, length(fn) - i);
end;
end;
i := Pos('\', fn);
if i <> 0 then
begin
Result := Result + Copy(fn, 1, i - 1);
fn := Copy(fn, i + 1, length(fn) - i);
end
else
begin
Result := Result + fn;
fn := '';
end;
end;
var
name: string;
begin
fn := ExpandFileName(fn);
Result := GetNextFN;
repeat
name := GetNextFN;
Result := Result + '\' + LookupLongName(Result + '\' + name);
until length(fn) = 0;
end;
|
Возврат курсора по умолчанию после выполнения запроса.
Почему мышиный курсор не возвращается обратно (не становится обычной стрелкой) после выполнения запроса?При выполнении открытого запроса, Delphi изменяет для вас курсор, и произойти это может даже в середине события, как, например, при нажатии на кнопку. Приведенный ниже пример отобразит курсор в виде иконки песочных часов (SQL Hourglass Icon) после того, как вы закроете окно с сообщением. При этом мышь будет вести себя так, как будто находится в режиме "стрелки".
// Добавьте к обработчику события нажатия кнопки, // использование запроса при этом не имеет значения // Select * from Customer (в IBLocal) with query1 do begin close; open; showmessage(IntToStr(RecordCount)); end; // with |
Для решения этой проблемы нужно добавить Application.ProcessMessages прежде, чем форма будет показана, это позволит обработать все сообщения, скопившиеся в очереди (и очистить ее), после чего мышиный курсор вновь пример нормальную форму.
// Добавьте к обработчику события нажатия кнопки, // использование запроса при этом не имеет значения // Select * from Customer (в IBLocal) with query1 do begin close; open; application.ProcessMessages; // Добавьте эту строку. showmessage(IntToStr(RecordCount)); end; // with |
Перевернуть строку 3.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
function ReverseString1(const s: string): string;
var
i, len: Integer;
begin
len := Length(s);
SetLength(Result, len);
for i := len downto 1 do
begin
Result[len - i + 1] := s[i];
end;
end;
function ReverseString2(const Str: string): string;
// by Ido Kanner
var
ch: Char;
i, Size: Integer;
begin
Result := Str;
Size := Length(Result);
if (Size >= 2) then
// 2 or more chars
begin
// For 1 to middle of the string
for i := 1 to (Size div 2) do
begin
// Lets get the charecter of the current place in the string
ch := Result[i];
// Place the Current pos of the char
// with the char of it's mirror place...
Result[i] := Result[Size - (i - 1)];
// In the mirror place we will put char of the
// Original place... And we switched places !!!
Result[Size - (i - 1)] := ch;
end
end;
end;
function ReverseString3(S: string): string;
// by Rudy Velthuis
var
P, Q: PChar;
C: Char;
begin
Result := S;
if Length(Result) = 0 then Exit;
P := PChar(Result);
Q := P + Length(Result) - 1;
while P < Q do
begin
C := P^;
P^ := Q^;
Q^ := C;
Inc(P);
Dec(Q);
end;
end;
procedure ReverseString4(var S: string);
// by Rudy Velthuis
var
P, Q: PChar;
C: Char;
begin
if Length(S) = 0 then Exit;
P := PChar(S);
Q := P + Length(S) - 1;
while P < Q do
begin
C := P^;
P^ := Q^;
Q^ := C;
Inc(P);
Dec(Q);
end;
end;
Перевернуть строку.
| Автор: ___Nikolay WEB-сайт: http://delphiworld.narod.ru |
// Перевернуть строку
function ReverseString(s: string): string;
var
i: integer;
begin
Result := '';
if Trim(s) <> '' then
for i := Length(s) downto 1 do
Result := Result + s[i];
end;
Перевернуть строку 2.
Автор: Profit Manson.
function ReverseString(s: string): string;
var
i: integer;
c: char;
begin
if s <> '' then
for i := 1 to Length(s) div 2 do
begin
c := s[i];
s[i] := s[Length(s) + 1 - i];
s[Length(s) + 1 - i] := c;
end;
Result := s;
end;
Поместить более 64 KB в TRichEdit.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{
By default, a TRichedit's text is limited to 64 KB.
Setting the Maxlength property to $7FFFFFF0 allows you to have approx.
2GB of text.
Standardmassig ist der Text im Richedit auf 64 KB beschrankt.
Indem man die Maxlength auf $7FFFFFF0 setzt, kann man ungefahr 2 GB
Text im TRichEdit haben.
}
procedure TForm1.Button1Click(Sender: TObject);
begin
RichEdit11.MaxLength := $7FFFFFF0;
end;
//oder:
//or:
procedure TForm1.Button1Click(Sender: TObject);
begin
SendMessage(RichEdit1.Handle, EM_EXLIMITTEXT, 0, $7FFFFFF0);
end;
Выполнить обратный поиск строки в TRichEdit.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{+------------------------------------------------------------
| Function FindTextBackwards
|
| Parameters :
| findWhat: text to find
| inString: string to find it in
| startAt : character index to start at (1-based)
| caseSensitive: determines whether search is case-sensitive
| words : if true the characters immediately surrounding
| a found location must not be alphanumeric
| Returns :
| character index (1-based) of first character of a found
| location, or 0, if the text was not found.
| Description:
| Performs a simple sequential search for a string in a larger
| string, starting at the specified position and working towards
| the start of the string.
| Error Conditions: none
| Created: 27.02.99 by P. Below
+------------------------------------------------------------}
function FindTextBackwards(findWhat, inString : string;
startAt : integer;
caseSensitive, words : boolean): integer;
var
i, patternlen, findpos : integer;
lastchar, firstchar : char;
begin
Result := 0; { assume failure }
patternlen := Length(findWhat);
{ Do a few sanity checks on the parameters }
if (patternlen = 0) or
(startAt < patternlen) or
(Length(inString) < patternlen) then
Exit;
if not caseSensitive then
begin
{ convert both strings to lower case }
findWhat := AnsiLowercase(findWhat);
inString := AnsiLowercase(inString);
end; { If }
i := startAt;
lastchar := findWhat[patternlen];
firstchar := findWhat[1];
while (Result = 0) and (i >= patternlen) do
begin
if inString[i] = lastchar then
begin
findPos := i - patternlen + 1;
if inString[findPos] = firstchar then
begin
{ We have a candidate. Compare the substring of length
patternlen starting at findPos with findWhat. With
AnsiStrLComp we can do that without having to copy
the substring to a temp string first. }
if AnsiStrLComp(@findWhat[1], @inString[findPos],
patternlen) = 0 then
begin
{ We have a match! }
Result := findPos;
if words then
begin
{ Check the characters surrounding the hit. For the hit
to constitute a word they must not be alphanumeric. }
if (findPos > 1) and
IsCharAlphanumeric(inString[findPos - 1]) then
begin
{ Not a match after all, <sigh>. }
Result := 0;
end { If }
else
begin
if (i < Length(inString)) and
IsCharAlphanumeric(inString[i + 1]) then
begin
{ Not a match after all, <sigh>. }
Result := 0;
end; { If }
end; { Else }
end; { If }
end; { If }
end; { If }
end; { If }
Dec(i);
end; { While }
end; { FindTextBackwards }
procedure TForm1.Button1Click(Sender : TObject);
var
findPos : integer;
begin
findPos := FindTextBackwards(findEdit.Text,
richedit1.Text,
richedit1.selstart + 1,
caseCheckbox.Checked,
wordsCheckbox.Checked);
if findPos > 0 then
begin
with richedit1 do
begin
selstart := findPos - 1;
sellength := findEdit.GetTextLen;
Perform(em_scrollcaret, 0, 0);
SetFocus;
end;
end
else
ShowMessage('Text not found');
end;
Получить первую или последнюю видимую строку в TRichEdit.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
function RE_GetLastVisibleLine(RichEdit: TRichEdit): Integer;
const
EM_EXLINEFROMCHAR = WM_USER + 54;
var
r: TRect;
i: Integer;
begin
{
The EM_GETRECT message retrieves the formatting rectangle
of an edit control.
}
RichEdit.Perform(EM_GETRECT, 0, Longint(@r));
r.Left := r.Left + 1;
r.Top := r.Bottom - 2;
{
The EM_CHARFROMPOS message retrieves information about the character
closest to a specified point in the client area of an edit control
}
i := RichEdit.Perform(EM_CHARFROMPOS, 0, Integer(@r.topleft));
{
The EM_EXLINEFROMCHAR message determines which
line contains the specified character in a rich edit control
}
Result := RichEdit.Perform(EM_EXLINEFROMCHAR, 0, i);
end;
{
Sending the EM_GETFIRSTVISIBLELINE message to a multi-line edit control
finds out which line is the first line visible.
This is the line that is currently displayed at the top of the control.
}
function RE_GetFirstVisibleLine(RichEdit: TRichEdit): Integer;
begin
Result := RichEdit.Perform(EM_GETFIRSTVISIBLELINE, 0, 0);
end;
Подсветить HTML теги в RichEdit.
procedure HTMLSyntax(RichEdit: TRichEdit; TextCol,
TagCol, DopCol: TColor);
var
i, iDop: Integer;
s: string;
Col: TColor;
isTag, isDop: Boolean;
begin
iDop := 0;
isDop := False;
isTag := False;
Col := TextCol;
RichEdit.SetFocus;
for i := 0 to Length(RichEdit.Text) do
begin
RichEdit.SelStart := i;
RichEdit.SelLength := 1;
s := RichEdit.SelText;
if (s = '<') or (s = '{') then isTag := True;
if isTag then
if (s = '"') then
if not isDop then
begin
iDop := 1;
isDop := True;
end
else
isDop := False;
if isTag then
if isDop then
begin
if iDop <> 1 then Col := DopCol;
end
else
Col := TagCol
else
Col := TextCol;
RichEdit.SelAttributes.Color := Col;
iDop := 0;
if (s = '>') or (s = '}') then isTag := False;
end;
RichEdit.SelLength := 0;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
RichEdit1.Lines.BeginUpdate;
HTMLSyntax(RichEdit1, clBlue, clRed, clGreen);
RichEdit1.Lines.EndUpdate;
end;
|
Задать расстояние между строк для TRichEdit.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
uses RichEdit; procedure RE_SetLineSpacing(ARichEdit: TRichEdit; lineSpacing: Byte); var pf2: ParaFormat2; begin FillChar(pf2, SizeOf(pf2), 0); pf2.cbSize := SizeOf(PARAFORMAT2); pf2.dwMask := PFM_LINESPACING; pf2.bLineSpacingRule := lineSpacing; SendMessage(ARichEdit.Handle, EM_SETPARAFORMAT, 0, Longint(@pf2)); end; //Example: Setlinespacing to 1: procedure TForm1.Button1Click(Sender: TObject); begin RE_SetLineSpacing(RichEdit1, 1); end;
Сделать предварительный просмотр для TRichEdit.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
unit RichEditPreview;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, Printers, RichEdit, Menus, ComCtrls, ToolWin;
type
TPageOffset = record
mStart, mEnd: Integer;
rendRect: TRect;
end;
TPreviewForm = class(TForm)
Panel1: TPanel;
Panel2: TPanel;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormResize(Sender: TObject);
private
{ Private-Deklarationen }
public
{ Public-Deklarationen }
PreviewPanel: TPanel;
procedure DrawRichEdit;
end;
TPreviewPanel = class(TPanel)
private
public
constructor Create(Owner: TComponent); override;
destructor Destroy; override;
procedure Paint; override;
property Canvas;
end;
var
PreviewForm: TPreviewForm;
implementation
uses Unit1, RxRichEd;
{$R *.dfm}
procedure TPreviewForm.FormCreate(Sender: TObject);
begin
PreviewPanel := TPreviewPanel.Create(Self);
PreviewPanel.Parent := Self;
PreviewPanel.Color := clWhite;
end;
procedure TPreviewForm.FormDestroy(Sender: TObject);
begin
if PreviewPanel <> nil then PreviewPanel.Free
end;
// We want the TPreviewPanel to approximate the scaled dimensions of the printed page.
// Whenever the parent
// form is resized, we need to rescale and center the panel on the form.
// To do this, add an OnResize event to
// the form and add the following code:
procedure TPreviewForm.FormResize(Sender: TObject);
var
wPage, hPage, wClient, hClient: integer;
begin
// get the printer dimensions
wPage := GetDeviceCaps(Printer.Handle, PHYSICALWIDTH);
hPage := GetDeviceCaps(Printer.Handle, PHYSICALHEIGHT);
// get the client window dimensions.
hClient := Panel2.ClientHeight;
// initially adjust width to match height
wClient := MulDiv(Panel2.ClientHeight, wPage, hPage);
// if that doesn't fit, then do it the other way
if wClient > Panel2.ClientWidth then
begin
wCLient := Panel2.ClientWidth;
hClient := MulDiv(Panel2.ClientWidth, hPage, wPage);
// center the page in the window
PreviewPanel.Top := ((Panel2.ClientHeight - hClient) div 2) - Panel1.Height;
end
else
begin
// center the page in the window
PreviewPanel.Left := (Panel2.ClientWidth - wClient) div 2;
PreviewPanel.Top := Panel1.Height;
end;
// now set size of panel
PreviewPanel.Width := wClient;
PreviewPanel.Height := hClient
end;
// The DrawRichEdit() method renders the contents of
// the control on the preview panel.
// Much of the code is
// very close to the code used to print the control in Part 2.
// The first part of the method is identical to
// the printing code:
procedure TPreviewForm.DrawRichEdit;
var
wPage, hPage, xPPI, yPPI, wTwips, hTwips, currPage: integer;
pageRect, rendRect, frameRect: TRect;
po: TPageOffset;
fr: TFormatRange;
lastOffset, xOffset, yOffset, xPrinterOffset, yPrinterOffset: integer;
FPageOffsets: array of TPageOffset;
TextLenEx: TGetTextLengthEx;
hdcDesktop, hdcCanvas, hdcPrinter, xDesktopPPI, yDesktopPPI,
xFactor, yFactor: integer;
begin
wPage := GetDeviceCaps(Printer.Handle, PHYSICALWIDTH);
hPage := GetDeviceCaps(Printer.Handle, PHYSICALHEIGHT);
xPPI := GetDeviceCaps(Printer.Handle, LOGPIXELSX);
yPPI := GetDeviceCaps(Printer.Handle, LOGPIXELSY);
wTwips := MulDiv(wPage, 1440, xPPI);
hTwips := MulDiv(hPage, 1440, yPPI);
with pageRect do
begin
Left := 0;
Top := 0;
Right := wTwips;
Bottom := hTwips
end;
with rendRect do
begin
Left := 0;
Top := 0;
Right := pageRect.Right - (1440 * 4);
Bottom := pageRect.Bottom - (1440 * 4)
end;
po.mStart := 0;
// We will be using several device contexts (DCs),
// so let's go ahead and create variables for them.
hdcDesktop := GetWindowDC(GetDesktopWindow);
hdcCanvas := TPreviewPanel(PreviewPanel).Canvas.Handle;
hdcPrinter := Printer.Handle;
// Next, define and initialize a FORMATRANGE structure.
fr.hdc := hdcDesktop;
fr.hdcTarget := hdcPrinter;
fr.chrg.cpMin := po.mStart;
fr.chrg.cpMax := -1;
// We will need the size of the text in the control.
if RichEditVersion >= 2 then
begin
with TextLenEx do
begin
flags := GTL_DEFAULT;
codepage := CP_ACP;
end;
lastOffset := SendMessage(Form1.Editor.Handle, EM_GETTEXTLENGTHEX,
wParam(@TextLenEx), 0)
end
else
lastOffset := SendMessage(Form1.Editor.Handle, WM_GETTEXTLENGTH, 0, 0);
// Clear the control's formatting buffer before rendering.
SendMessage(Form1.Editor.Handle, EM_FORMATRANGE, 0, 0);
// Here is the tricky part.
// We need to scale the rendering DC to match the size of the printed page in
// printer device units.
SaveDC(hdcCanvas);
SetMapMode(hdcCanvas, MM_TEXT);
SetMapMode(hdcCanvas, MM_ANISOTROPIC);
SetMapMode(hdcPrinter, MM_TEXT);
SetWindowExtEx(hdcCanvas, pageRect.Right, pageRect.Bottom, nil);
xDesktopPPI := GetDeviceCaps(hdcDesktop, LOGPIXELSX);
yDesktopPPI := GetDeviceCaps(hdcDesktop, LOGPIXELSY);
ScaleWindowExtEx(hdcCanvas, xDesktopPPI, 1440, yDesktopPPI, 1440, nil);
SetViewportExtEx(hdcCanvas, PreviewPanel.ClientWidth, PreviewPanel.ClientHeight, nil);
// Apparently, the Rich Edit control reduces the width of the
// rendering area by the amount of the left
// offset to the printable portion of the page when printing.
// This is a little odd to me because none of
// the Windows API GDI functions care whether you are printing
// within the printable portion of the page.
// Further, this occurs even though the rendering rectangle is
// already within the printable portion of the
// page. Anyway, this does not seem to happen when the rendering
// DC is the screen so we need to manually
// adjust the rectangle ourselves.
xPrinterOffset := MulDiv(GetDeviceCaps(hdcPrinter, PHYSICALOFFSETX), 1440, xPPI);
yPrinterOffset := MulDiv(GetDeviceCaps(hdcPrinter, PHYSICALOFFSETY), 1440, yPPI);
rendRect.Left := rendRect.Left + (xPrinterOffset shr 1);
rendRect.Right := rendRect.Right - xPrinterOffset - (xPrinterOFfset shr 1);
rendRect.Top := rendRect.Top + (yPrinterOffset shr 1);
rendRect.Bottom := rendRect.Bottom - yPrinterOffset - (yPrinterOFfset shr 1);
// Remember that we are hardcoding two-inch margins.
xOffset := MulDiv(PreviewPanel.ClientWidth shl 1, 1440, pageRect.Right);
yOffset := MulDiv(PreviewPanel.ClientHeight shl 1, 1440, pageRect.Bottom);
SetViewportOrgEx(hdcCanvas, xOffset, yOffset, nil);
// Now we build the table of offsets.
// Note that we save the rendering rectangle returned by the format
// call. When the rendering and target devices are the same
// (or the target device is set to zero), the
// returned rectangle is not really needed.
// In that case, you can simply ask the control to print to the
// original rendering rectangle. However, when the devices are different,
// the returned rendering rectangle
// is sometimes larger than the requested rectangle.
// This must be a bug in the Rich Edit control. We deal
// with it by saving the returned value to use when
// we actually render the control to the screen.
while ((fr.chrg.cpMin <> -1) and (fr.chrg.cpMin < lastOffset)) do
begin
fr.rc := rendRect;
fr.rcPage := pageRect;
po.mStart := fr.chrg.cpMin;
fr.chrg.cpMin := SendMessage(Form1.Editor.Handle, EM_FORMATRANGE, 0, Longint(@fr));
po.mEnd := fr.chrg.cpMin - 1;
po.rendRect := fr.rc;
if High(FPageOffsets) = -1 then SetLength(FPageOffsets, 1)
else
SetLength(FPageOffsets, Length(FPageOffsets) + 1);
FPageOffsets[High(FPageOffsets)] := po
end;
// If we were writing a fully working preview function,
// we could use FPageOffsets.size() to determine how
// many pages had been formatted.
// We would then set currPage (below) to the page that we wanted to
// display.
// In this example, however, we are going to display only the first page.
currPage := 0;
// Now we set the rendering device to the panel's canvas.
// Since we have not cleared the formatting buffer,
// the target device is not needed, so we set it to zero.
// Then we fill in the remaining parts of the
// FORMATRANGE structure with the values we saved in FPageOffsets.
// Finally, we render the text to the
// screen (WPARAM is non-zero).
fr.hdc := hdcCanvas;
fr.hdcTarget := 0;
fr.rc := FPageOffsets[currPage].rendRect;
fr.rcPage := pageRect;
fr.chrg.cpMin := FPageOffsets[currPage].mStart;
fr.chrg.cpMax := FPageOffsets[currPage].mEnd;
fr.chrg.cpMin := SendMessage(Form1.Editor.Handle, EM_FORMATRANGE, 1, Longint(@fr));
// As I mentioned, the text may be drawn outside of the rendering rectangle.
// To make that easier to see,
// let's draw a rectangle that shows where the rendering rectangle should be
SetMapMode(hdcCanvas, MM_TEXT);
SetViewportOrgEx(hdcCanvas, 0, 0, nil);
frameRect := rendRect;
OffsetRect(frameRect, 1440 + 1440, 1440 + 1440);
xFactor := MulDiv(PreviewPanel.ClientWidth,
(pageRect.Right - rendRect.Right) shr 1, pageRect.Right);
yFactor := MulDiv(PreviewPanel.ClientHeight,
(pageRect.Bottom - rendRect.Bottom) shr 1, pageRect.Bottom);
frameRect.Left := xFactor;
frameRect.Right := PreviewPanel.ClientWidth - xFactor;
frameRect.Top := yFactor;
frameRect.Bottom := PreviewPanel.ClientHeight - yFactor;
Windows.FrameRect(hdcCanvas, frameRect, GetStockObject(BLACK_BRUSH));
// To wrap up, we restore the panel's canvas to the original state,
// release the desktop DC, clear the Rich
// Edit control's formatting buffer, empty the page offset table,
and Close the DrawRichEdit() method.RestoreDC(hdcCanvas, - 1);
ReleaseDC(GetDesktopWindow, hdcDesktop);
SendMessage(Form1.Editor.Handle, EM_FORMATRANGE, 0, 0);
Finalize(FPageOffsets);
end;
(*****************************************************)
(* Alles uber den Nachfahren von TPanel *)
(*****************************************************)
constructor TPreviewPanel.Create(Owner: TComponent);
begin
inherited Create(Owner);
end;
destructor TPreviewPanel.Destroy;
begin
inherited Destroy
end;
procedure TPreviewPanel.Paint;
begin
inherited Paint;
PreviewForm.DrawRichEdit;
end;
end.
Изменить цвет выделения для TRichEdit.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
uses
RichEdit;
procedure RE_SetSelBgColor(RichEdit: TRichEdit; AColor: TColor);
var
Format: CHARFORMAT2;
begin
FillChar(Format, SizeOf(Format), 0);
with Format do
begin
cbSize := SizeOf(Format);
dwMask := CFM_BACKCOLOR;
crBackColor := AColor;
Richedit.Perform(EM_SETCHARFORMAT, SCF_SELECTION, Longint(@Format));
end;
end;
// Example: Set clYellow background color for the selected text.
procedure TForm1.Button1Click(Sender: TObject);
begin
RE_SetSelBgColor(RichEdit1, clYellow);
end;
Показывать значки элементов списка в TRichEdit.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
uses
RichEdit;
procedure TForm1.Button1Click(Sender: TObject);
var
fmt: TParaformat2;
begin
FillChar(fmt, SizeOf(fmt), 0);
fmt.cbSize := SizeOf(fmt);
// The PARAFORMAT2 structure is used to set the numbering style.
// This is done through the following structure members:
fmt.dwMask := PFM_NUMBERING or PFM_NUMBERINGSTART or PFM_NUMBERINGSTYLE or
PFM_NUMBERINGTAB;
// Set the following values (bitwise-or them together) to identify
// which of the remaining structure members are valid:
// PFM_NUMBERING, PFM_NUMBERINGSTART, PFM_NUMBERINGSTYLE, and PFM_NUMBERINGTAB
fmt.wNumbering := 2;
//0 no numbering or bullets
//1 (PFN_BULLET) uses bullet character
//2 Uses Arabic numbers (1, 2, 3, ...).
//3 Uses lowercase letters (a, b, c, ...).
//4 Uses uppercase letters (A, B, C, ...).
//5 Uses lowercase Roman numerals (i, ii, iii, ...).
//6 Uses uppercase Roman numerals (I, II, III, ...).
//7 Uses a sequence of characters beginning with the Unicode
// character specified by the wNumberingStart member.
fmt.wNumberingStart := 1;
// Starting value for numbering.
fmt.wNumberingStyle := $200;
// Styles for numbering:
// 0 : Follows the number with a right parenthesis. 1)
// $100 : Encloses the number in parentheses. (1)
// $200 : Follows the number with a period. 1.
// $300 : Displays only the number. 1
// $400 : Continues a numbered list without applying the next number or bullet.
// $8000 : Starts a new number with wNumberingStart.
fmt.wNumberingTab := 1440 div 4;
// Minimum space between a paragraph number and the paragraph text, in twips
RichEdit1.Perform(EM_SETPARAFORMAT, 0, lParam(@fmt));
end;
Использовать SubScript или SuperScript в TRichEdit.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
// yOffset values
type
TCharacterFormat = (CFM_Superscript, CFM_Subscript, CFM_Normal);
procedure RE_SetCharFormat(RichEdit: TRichEdit; CharacterFormat: TCharacterFormat);
var
// The CHARFORMAT structure contains information about
// character formatting in a rich edit control.
Format: TCharFormat;
begin
FillChar(Format, SizeOf(Format), 0);
with Format do
begin
cbSize := SizeOf(Format);
dwMask := CFM_OFFSET;
// Character offset, in twips, from the baseline.
// If the value of this member is positive,
// the character is a superscript;
// if it is negative, the character is a subscript.
case CharacterFormat of
CFM_Superscript: yOffset := 60;
CFM_Subscript: yOffset := -60;
CFM_Normal: yOffset := 0;
end;
end;
// The EM_SETCHARFORMAT message sets character formatting in a rich edit control.
// SCF_SELECTION: Applies the formatting to the current selection
Richedit.Perform(EM_SETCHARFORMAT, SCF_SELECTION, Longint(@Format));
end;
// Examples:
// Beispiele:
// Apply Superscript to the current selection
// Markierte Zeichen hoch stellen
procedure TForm1.Button1Click(Sender: TObject);
begin
RE_SetCharFormat(RichEdit1, CFM_Superscript);
end;
// Apply Subscript to the current selection
// Markierte Zeichen tief stellen
procedure TForm1.Button2Click(Sender: TObject);
begin
RE_SetCharFormat(RichEdit1, CFM_Subscript);
end;
Выравнивание текста в TRichEdit.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
uses
RichEdit;
// Using the Paragraph property
procedure RE_AlignText1(ARichEdit: TRichEdit; alignment: TAlignment);
begin
ARichEdit.Paragraph.Alignment := alignment;
end;
// Using PARAFORMAT2; nonVCL
procedure RE_AlignText2(ARichEdit: TRichEdit; alignment: TAlignment);
var
pf2: PARAFORMAT2;
begin
FillChar(pf2, SizeOf(pf2), 0);
pf2.cbSize := SizeOf(PARAFORMAT2);
SendMessage(ARichEdit.Handle, EM_GETPARAFORMAT, 0, Longint(@pf2));
pf2.dwMask := PFM_ALIGNMENT;
case alignment of
taLeftJustify: pf2.wAlignment := PFA_LEFT;
taCenter: pf2.wAlignment := PFA_CENTER;
taRightJustify: pf2.wAlignment := PFA_RIGHT;
end;
SendMessage(ARichEdit.Handle, EM_SETPARAFORMAT, 0, Longint(@pf2));
end;
// Example: Right align text
// Beispiel: Text rechtsbundig ausrichten
procedure TForm1.Button1Click(Sender: TObject);
begin
RE_AlignText2(RichEdit1, taRightJustify);
end;
Как скопировать содержимое одного RichEdit в другой.
TMemoryStream это самый простой инструмент взаимодействия между всеми VCL компонентами:
procedure TForm1.Button1Click(Sender: TObject);
var
MemoryStream: TMemoryStream;
begin
MemoryStream := TMemoryStream.Create;
try
RichEdit1.Lines.SaveToStream(MemoryStream);
MemoryStream.Seek(0, soFromBeginning);
RichEdit2.Lines.LoadFromStream(MemoryStream);
finally
MemoryStream.Free;
end;
end;
|
Использовать различные стили подчеркивания для TRichEdit.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
uses
RichEdit;
// Underline styles
const
CFU_UNDERLINETHICK = 9;
CFU_UNDERLINEWAVE = 8;
CFU_UNDERLINEDASHDOTDOT = 7;
CFU_UNDERLINEDASHDOT = 6;
CFU_UNDERLINEDASH = 5;
CFU_UNDERLINEDOTTED = 4;
CFU_UNDERLINE = 1;
CFU_UNDERLINENONE = 0;
procedure RE_SetCharFormat(ARichEdit: TRichEdit; AUnderlineType: Byte; AColor: Word);
var
// The CHARFORMAT2 structure contains information about
// character formatting in a rich edit control.
Format: CHARFORMAT2;
begin
FillChar(Format, SizeOf(Format), 0);
with Format do
begin
cbSize := SizeOf(Format);
dwMask := CFM_UNDERLINETYPE;
bUnderlineType := AUnderlineType or AColor;
ARichEdit.Perform(EM_SETCHARFORMAT, SCF_SELECTION, Longint(@Format));
end;
end;
// Underline the current selection with a CFU_UNDERLINEWAVE line style (color red);
procedure TForm1.Button1Click(Sender: TObject);
begin
RE_SetCharFormat(RichEdit1, CFU_UNDERLINEWAVE, $50);
end;
Подсветить ссылки в TRichEdit.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{
So what we need:
1. drop on your form a RichEdit component from win32 page of component
palette
2. in OnCreate event of your form write the next code:
}
procedure TForm1.FormCreate(Sender: TObject);
var
mask: Word;
begin
mask := SendMessage(Handle, EM_GETEVENTMASK, 0, 0);
SendMessage(RichEdit1.Handle, EM_SETEVENTMASK, 0, mask or ENM_LINK);
SendMessage(RichEdit1.Handle, EM_AUTOURLDETECT, Integer(True), 0);
RichEdit1.Text := 'SwissDelphiCenter.com: '#13#10 +
' Site is located at www.SwissDelphiCenter.com';
end;
{
After that your Richedit will convert automatically any URLs in highlighted
(blue color and underlined). Even if you'll start to enter any text directly
in Richedit, any begings for URL will be converted too (not only existing
text string but new too)
}
// 3. now we must detect mouse clicks in URL range. For this task we must
// override WndProc method of our form:
type
TForm1 = class(TForm)
protected
procedure WndProc(var Message: TMessage); override;
end;
// 4. the implementation looks like this:
procedure TForm1.WndProc(var Message: TMessage);
var
p: TENLink;
strURL: string;
begin
if (Message.Msg = WM_NOTIFY) then
begin
if (PNMHDR(Message.lParam).code = EN_LINK) then
begin
p := TENLink(Pointer(TWMNotify(Message).NMHdr)^);
if (p.Msg = WM_LBUTTONDOWN) then
begin
SendMessage(RichEdit1.Handle, EM_EXSETSEL, 0, Longint(@(p.chrg)));
strURL := RichEdit1.SelText;
ShellExecute(Handle, 'open', PChar(strURL), 0, 0, SW_SHOWNORMAL);
end
end
end;
inherited;
end;
{
5. Now you can compile your project (don't forget to include Richedit and
ShellAPI units in uses clause).
}
Как конвертировать RFC1123 в TDateTime.
Автор: http://www.swissdelphicenter.ch
function RFC1123ToDateTime(Date: string): TDateTime;
var
day, month, year: Integer;
strMonth: string;
Hour, Minute, Second: Integer;
begin
try
day := StrToInt(Copy(Date, 6, 2));
strMonth := Copy(Date, 9, 3);
if strMonth = 'Jan' then
month := 1
else if strMonth = 'Feb' then
month := 2
else if strMonth = 'Mar' then
month := 3
else if strMonth = 'Apr' then
month := 4
else if strMonth = 'May' then
month := 5
else if strMonth = 'Jun' then
month := 6
else if strMonth = 'Jul' then
month := 7
else if strMonth = 'Aug' then
month := 8
else if strMonth = 'Sep' then
month := 9
else if strMonth = 'Oct' then
month := 10
else if strMonth = 'Nov' then
month := 11
else if strMonth = 'Dec' then
month := 12;
year := StrToInt(Copy(Date, 13, 4));
hour := StrToInt(Copy(Date, 18, 2));
minute := StrToInt(Copy(Date, 21, 2));
second := StrToInt(Copy(Date, 24, 2));
Result := 0;
Result := EncodeTime(hour, minute, second, 0);
Result := Result + EncodeDate(year, month, day);
except
Result := now;
end;
end;
function DateTimeToRFC1123(aDate: TDateTime): string;
const
StrWeekDay: string = 'MonTueWedThuFriSatSun';
StrMonth: string = 'JanFebMarAprMayJunJulAugSepOctNovDec';
var
Year, Month, Day: Word;
Hour, Min, Sec, MSec: Word;
DayOfWeek: Word;
begin
DecodeDate(aDate, Year, Month, Day);
DecodeTime(aDate, Hour, Min, Sec, MSec);
DayOfWeek := ((Trunc(aDate) - 2) mod 7);
Result := Copy(StrWeekDay, 1 + DayOfWeek * 3, 3) + ', ' +
Format('%2.2d %s %4.4d %2.2d:%2.2d:%2.2d',
[Day, Copy(StrMonth, 1 + 3 * (Month - 1), 3),
Year, Hour, Min, Sec]);
end;
Преобразовать RGB в TColor и наоборот.
// RGB to TColor Values
procedure TForm1.Button1Click(Sender: TObject);
begin
Edit1.Color := RGB(58, 110, 165);
end;
// TColor to RGB values
procedure TForm1.Button2Click(Sender: TObject);
var
Color: Longint;
r, g, b: Byte;
begin
Color := ColorToRGB(Edit1.Color);
r := Color;
g := Color shr 8;
b := Color shr 16;
label1.Caption := ' Red : ' + IntToStr(r) +
' Green: ' + IntToStr(g) +
' Blue : ' + IntToStr(b);
end;
|
Преобразовать RGB в COLORREF (BGR).
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
function RGB2BGR(R, G, B: Byte): COLORREF; overload; begin Result := (Integer(B) shl 16) + (Integer(G) shl 8) + R; end; function RGB2BGR(RGB: Integer): COLORREF; overload; var R, G, B: Integer; begin R := RGB div $10000; G := ((RGB mod $10000) div $100) shl 8; B := (RGB mod $100) shl 16; Result := B + G + R; end;
Как преобразовать цвета RGB в CMYK и обратно.
Ниже представлены две функции RGBTOCMYK() и CMYKTORGB(), которые позволяют преобразовывать набор цветов RGB и CMYK.Замечание: В цвете CMY чёрные тона достигаются путём одинаковых значений Циана, Магенты и Жёлтого чернил. Чёрные чернила используются только при чисто чёрных точках, для повышения контрастности и экономии цветных чернил. Как раз для этого предназначена третья функция ColorCorrectCMYK().
procedure RGBTOCMYK(R: byte;
G: byte;
B: byte;
var C: byte;
var M: byte;
var Y: byte;
var K: byte);
begin
C := 255 - R;
M := 255 - G;
Y := 255 - B;
if C < M then
K := C
else
K := M;
if Y < K then
K := Y;
if k > 0 then
begin
c := c - k;
m := m - k;
y := y - k;
end;
end;
procedure CMYKTORGB(C: byte;
M: byte;
Y: byte;
K: byte;
var R: byte;
var G: byte;
var B: byte);
begin
if (Integer(C) + Integer(K)) < 255 then
R := 255 - (C + K)
else
R := 0;
if (Integer(M) + Integer(K)) < 255 then
G := 255 - (M + K)
else
G := 0;
if (Integer(Y) + Integer(K)) < 255 then
B := 255 - (Y + K)
else
B := 0;
end;
procedure ColorCorrectCMYK(var C: byte;
var M: byte;
var Y: byte;
var K: byte);
var
MinColor: byte;
begin
if C < M then
MinColor := C
else
MinColor := M;
if Y < MinColor then
MinColor := Y;
if MinColor + K > 255 then
MinColor := 255 - K;
C := C - MinColor;
M := M - MinColor;
Y := Y - MinColor;
K := K + MinColor;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
R: byte;
G: byte;
B: byte;
C: byte;
M: byte;
Y: byte;
K: byte;
begin
R := 151;
G := 81;
B := 55;
Memo1.Lines.Add('R = ' + IntToStr(R));
Memo1.Lines.Add('G = ' + IntToStr(G));
Memo1.Lines.Add('B = ' + IntToStr(B));
Memo1.Lines.Add('-------------------');
RGBTOCMYK(R, G, B, C, M, Y, K);
Memo1.Lines.Add('C = ' + IntToStr(C));
Memo1.Lines.Add('M = ' + IntToStr(M));
Memo1.Lines.Add('Y = ' + IntToStr(Y));
Memo1.Lines.Add('K = ' + IntToStr(K));
Memo1.Lines.Add('-------------------');
CMYKTORGB(C, M, Y, K, R, G, B);
Memo1.Lines.Add('R = ' + IntToStr(R));
Memo1.Lines.Add('G = ' + IntToStr(G));
Memo1.Lines.Add('B = ' + IntToStr(B));
Memo1.Lines.Add('-------------------');
RGBTOCMYK(R, G, B, C, M, Y, K);
c := c + 2;
m := m + 2;
y := y + 2;
ColorCorrectCMYK(C, M, Y, K);
Memo1.Lines.Add('C = ' + IntToStr(C));
Memo1.Lines.Add('M = ' + IntToStr(M));
Memo1.Lines.Add('Y = ' + IntToStr(Y));
Memo1.Lines.Add('K = ' + IntToStr(K));
end;
|
Как преобразовать RGB-цвет в оттенки серого.
function RgbToGray(RGBColor: TColor): TColor;
var
Gray: byte;
begin
Gray := Round((0.30 * GetRValue(RGBColor)) +
(0.59 * GetGValue(RGBColor)) +
(0.11 * GetBValue(RGBColor )));
Result := RGB(Gray, Gray, Gray);
end;
procedure TForm1.Button1Click(Sender: TObject);
var
h, w: integer;
begin
for w := 0 to Image1.Width-1 do
for h := 0 to Image1.Height-1 do
Image2.Canvas.Pixels[w, h] :=
RgbToGray(Image2.Canvas.Pixels[w, h]);
end;
|
Как конвертировать RGB в TColor.
function RGBToColor(R, G, B: Byte): TColor; begin Result := B shl 16 or G shl 8 or R; end; |
Получить доступ к элементам TRadioGroup.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{
Die Eigenschaft Controls fuhrt alle untergeordneten Komponenten eines Steuerelements
(Hier z.B TRadioGroup) auf.
Controls ist hilfreich, wenn auf die untergeordneten Steuerelemente mit einer Zahl und
nicht mit ihrem Namen Bezug genommen werden soll.
So kann Controls beispielsweise verwendet werden, um in einer TRadioGroup Eigenschaften
der RadioButtons zu manipulieren (Hints anzeigen, verstecken,...)
}
{
The property Controls lists all child controls of a Control.(Here a TRadioGroup)
Controls is an array of all the child controls.
The Controls property is convenient for referring to the children of a control
by number rather than name.
For example, Controls may be used to change properties of the Radiobuttons in a
TRadioGroup (showing hints, hiding items,...)
}
{1. *******************************************************}
// Deactivates/activates a specified item of a TRadioGroup
// Deaktiviert/aktiviert in einer TRadioGroup ein bestimmtes Item
procedure RGB_EnableItem(RadioGroup: TRadioGroup; ItemIndex: Byte; bEnabled: Boolean);
begin
RadioGroup.Controls[ItemIndex].Enabled := bEnabled;
end;
// Example: Deactivates the 2. Item (Index starts at 0)
// Beispiel: 2. Item deaktivieren (Index beginnt bei 0)
procedure TForm1.Button1Click(Sender: TObject);
begin
RGB_EnableItem(RadioGroup1, 1, False);
end;
{2. *******************************************************}
// Hides/Shows a specified item of a TRadioGroup
// Versteckt oder zeigt ein bestimmtes Item in einer TRadioGroup an.
procedure RGB_ShowItem(RadioGroup: TRadioGroup; ItemIndex: Byte; bVisible: Boolean);
begin
RadioGroup.Controls[ItemIndex].Visible := bVisible;
end;
// Example: Hides the 2. Item (Index starts at 0)
// Beispiel: 2. Item verstecken (Index beginnt bei 0)
procedure TForm1.Button2Click(Sender: TObject);
begin
RGB_ShowItem(RadioGroup1, 1, False);
end;
{3. *******************************************************}
// Show Hints for TRadioGroup items
// Hints fur die Items in der TRadioGroup anzeigen
procedure TForm1.Button3Click(Sender: TObject);
var
i: Byte;
begin
for i := 0 to RadioGroup1.ControlCount - 1 do
begin
RadioGroup1.Controls[i].ShowHint := True;
RadioGroup1.Controls[i].Hint := (Radiogroup1.Controls[i] as TRadiobutton).Caption;
end;
end;
{4. *******************************************************}
// Focus a specified Radiobutton in a TRadioGroup
// Ein bestimmter Radiobutton einer TRadioGroup fokussieren
procedure RGB_FocusItem(RadioGroup: TRadioGroup; ItemIndex: Byte);
var
RadiogroupClick: TNotifyEvent;
begin
if ItemIndex >= 0 then
begin
RadioGroup.OnClick := nil;
(RadioGroup.Controls[1] as TRadiobutton).SetFocus;
RadioGroup.OnClick := RadiogroupClick;
end;
end;
// Example: Focus the 2. Radiobutton
// Beispiel: Den 2. Radiobutton fokussieren
procedure TForm1.Button4Click(Sender: TObject);
begin
RGB_FocusItem(RadioGroup1, 1);
end;
Richedit сам меняет язык при перемещении.
| Автор: Максим Гуменюк |
| Заходит негр в компьютерную фирму и говорит: - Здравствуйте, я ищу работу. У меня степень доктора наук по компьютерам. Ему отвечают: - Хорошо, мы вас возьмем. Для начала мы дадим вам 100 тысяч долларов в год, мы же вас пока плохо знаем. Согласны? - Согласен. - Да, мы вам дадим автомобиль, но покамест только "опель", потом что-нибудь лучше дадим. Согласны? - Согласен. - И еще мы вам дадим квартиру в хорошем районе, но пока только однокомнатную. Вас это устраивает? Тут негр не выдерживает: - Послушайте! Вы что, надо мной прикалываетесь?! - Но ты же первый начал. |
Вот что из этого получилось. Имеем исправленный компонент VCL с дополнительным событием.
unit RichEditEx;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ComCtrls;
type
TLangChangeEvent = procedure(Sender: TObject; Lang: HKL) of object;
TRichEditEx = class(TRichEdit)
private
FOnLangChange: TLangChangeEvent;
procedure WMLangRequest(var M: TMessage); message WM_INPUTLANGCHANGEREQUEST;
procedure WMLangChange(var M: TMessage); message WM_INPUTLANGCHANGE;
{ Private declarations }
protected
{ Protected declarations }
public
{ Public declarations }
published
property OnLangChange: TLangChangeEvent read FOnLangChange write
FOnLangChange;
{ Published declarations }
end;
procedure Register;
implementation
procedure tricheditex.WMLangRequest(var M: TMessage);
begin
if assigned(FOnLangChange) then
FOnLangChange(self, m.LParam);
inherited;
end;
procedure tricheditex.WMLangChange(var M: TMessage);
begin
m.Result := 1;
end;
procedure Register;
begin
RegisterComponents('Samples', [TRichEditEx]);
end;
end.
|
Перейти на строку в RichEdit.
with Richedit1 do
begin
selstart := perform( EM_LINEINDEX, linenumber, 0 );
perform( EM_SCROLLCARET, 0, 0 );
end;
{
The EM_LINEINDEX message returns the character index of the first character
on a given line, assigning that to selstart moves the caret to that position.
The control will only automatically scroll the caret into view if it has
the focus, thus the EM_SCROLLCARET.
}
|
Печать из RichEdit.
Автор: Nomadic.
procedure TForm1.Button1Click(Sender: TObject);
var
lst: TextFile;
sc: Integer;
begin
//Printer.Orientation:=poPortraite
AssignFile(lst,'prn');
Rewrite(lst);
sc:=0;
for sc:=0 to RichEdit1.Lines.Count-1 do
writeln(lst,StrToOem(RichEdit1.Lines[sc]));
System.CloseFile(lst);
end;
|
RichEdit замена текста.
| Штирлиц считает зарплату в рейхсмарках: 1022, 1023, 1024... "KB MEMORY OK", - подумал Штирлиц. |
// This example doesn't use TReplaceDialog
// Ohne Benutzung von TReplaceDialog
function Search_And_Replace(RichEdit: TRichEdit;
SearchText, ReplaceText: string): Boolean;
var
startpos, Position, endpos: integer;
begin
startpos := 0;
with RichEdit do
begin
endpos := Length(RichEdit.Text);
Lines.BeginUpdate;
while FindText(SearchText, startpos, endpos, [stMatchCase])<>-1 do
begin
endpos := Length(RichEdit.Text) - startpos;
Position := FindText(SearchText, startpos, endpos, [stMatchCase]);
Inc(startpos, Length(SearchText));
SetFocus;
SelStart := Position;
SelLength := Length(SearchText);
richedit.clearselection;
SelText := ReplaceText;
end;
Lines.EndUpdate;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Search_And_Replace(Richedit1, 'OldText', 'NewText');
end;
|
RichEdit поиск текста.
| Лев ходит по пустыне. В свое время физики предложили свою подборку методов решения задачи о поимке льва в пустыне и помещении его в клетку. А как решают ту же задачу различные деятели эпохи информационных технологий? Программист на Паскале Просматривает пустыню полным перебором. Обнаружив льва, строит вокруг него клетку. Продвинутый программист на Паскале Сортирует пустыню по возрастанию, после чего ищет льва двоичным поиском и строит вокруг него клетку. Если в процессе строительства лев уходит, бросает работу с криком "Range Check Error". Программист на Си Ищет в пустыне камень и помещает его в клетку. Присваивает камню значение "лев". Продвинутый программист на Си Присваивает пустыне значение "клетка". Программист на Си++ Проектирует клетку таким образом, чтобы лев был ее составной частью. При инициализации клетки лев автоматически генерируется внутри. Программист на Аде Говорит, что лев и клетка - это объекты разных типов, и нечего морочить ему голову некорректными задачами. Программист на Дельфи Пишет во все конференции: "Народ, где взять компонент, который ищет в пустыне льва и помещает его в клетку?" Железячник Покупает в зоопарке львицу, делает ей операцию по смене пола и долго пытается запихнуть ее в клетку для канарейки. Геймер-асtiоn'ер Вооружается супершотганом, плазмаганом, рэйлганом, нэйлганом, шестиствольным пулеметом и бензопилой. Прочесывает пустыню, разнося все на своем пути. Ищет среди убитых льва и пытается обнаружить у него в животе желтый ключ. Если находит, отпирает им клетку и ждет награды. Геймер-квестовик Ищет по всей пустыне льва, находит, кладет в карман. Затем ищет по всей пустыне клетку, попутно пытаясь засунуть льва в чайник, башмак, телевизор, ведро с краской и другие попадающиеся на пути емкости. Геймер-стратег Поднимает по всей пустыне налоги, чтобы получить деньги на строительство клетки и охотничьих юнитов. К моменту окончания строительства все львы дохнут от голода. Пользователь интернета Заходит в свой любимый поисковик, пишет в строке Search "пустыня", ищет в найденном "лев в клетке". Если не находит, говорит, что задача неразрешима. Вебмастер Заходит в свой любимый поисковик и пишет в строке Search "пустыня + лев". Создает документ клетка.html и прописывает в нем ссылку на найденное. Спамер Рассылает по всей пустыне множество клеток, к каждой из которых привязана бумажка: "Если вы лев, пожалуйста, зайдите внутрь и закройтесь изнутри". Троянщик Делает то же, что и спамер, но вместо бумажки снаружи вешает внутри клетки картинку с голой львицей. Админ Выкапывает вокруг клетки ров, заполняет его концентрированной кислотой, устанавливает вдоль берега противотанковые ежи и противопехотные мины, все это опутывает колючей проволокой. К проволоке и прутьям клетки подключает провода от генератора высокого напряжения. Вешает на клетку 10 кодовых и 12 амбарных замков. Заходит внутрь, запирается на все замки, пускает ток, ключи проглатывает, коды забывает и говорит, что теперь ему никакой лев не страшен. Хакер Нейтрализует кислоту щелочью, перекусывает проволоку, проползает под ежами, перепрыгивает с шестом через мины, отключает ток, взламывает замки и входит в клетку. Не обнаружив внутри льва, матерится с досады, дает пинка админу и уходит обратно в пустыню. |
function SearchForText_AndSelect(RichEdit: TRichEdit; SearchText: string): Boolean;
var
StartPos, Position, Endpos: Integer;
begin
StartPos := 0;
with RichEdit do
begin
Endpos := Length(RichEdit.Text);
Lines.BeginUpdate;
while FindText(SearchText, StartPos, Endpos, [stMatchCase])<>-1 do
begin
Endpos := Length(RichEdit.Text) - startpos;
Position := FindText(SearchText, StartPos, Endpos, [stMatchCase]);
Inc(StartPos, Length(SearchText));
SetFocus;
SelStart := Position;
SelLength := Length(SearchText);
end;
Lines.EndUpdate;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
SearchForText_AndSelect(RichEdit1, 'Some Text');
end;
|
Предел на размер текста в RichEdit.
Автор: Richard Shotbolt Я разместил на форме компонент TRichEdit, присвоил ему большой (104Кб) текст, но все попытки его редактирования свелись только в сторону уменьшения размера текста. Это проблема распределения памяти? Есть решение этой проблемы?Я думаю что ответ на этот вопрос нужно искать в WIN95 API:
SendMessage(MyRichEdit.Handle, EM_EXLIMITTEXT, 0, NewBigSize); |
Подсчет слов в Richedit.
function GetWord: boolean;
var
s: string; {предположим что слова не содержат>255 символов}
c: char;
begin
result := false;
s := ' ';
while not eof(f) do
begin
read(f, c);
if not (c in ['a'..'z', 'A'..'Z' {,... и т.д, и т.п.}]) then
break;
s := s + c;
end;
result := (s <> ' ');
end;
procedure GetWordCount(TextFile: string);
begin
Count := 0;
assignfile(f, TextFile);
reset(f);
while not eof(f) do
if GetWord then
inc(Count);
closefile(f);
end;
|
Получить слово под курсором в RichEdit.
uses
RichEdit;
procedure TForm1.RichEdit1MouseMove(Sender: TObject; Shift: TShiftState;
X, Y: Integer);
var
iCharIndex, iLineIndex, iCharOffset, i, j: Integer;
Pt: TPoint;
s: string;
begin
with TRichEdit(Sender) do
begin
Pt := Point(X, Y);
// Get Character Index from word under the cursor
iCharIndex := Perform(Messages.EM_CHARFROMPOS, 0, Integer(@Pt));
if iCharIndex < 0 then Exit;
// Get line Index
iLineIndex := Perform(EM_EXLINEFROMCHAR, 0, iCharIndex);
iCharOffset := iCharIndex - Perform(EM_LINEINDEX, iLineIndex, 0);
if Lines.Count - 1 < iLineIndex then Exit;
// store the current line in a variable
s := Lines[iLineIndex];
// Search the beginning of the word
i := iCharOffset + 1;
while (i > 0) and (s[i] <> ' ') do Dec(i);
// Search the end of the word
j := iCharOffset + 1;
while (j <= Length(s)) and (s[j] <> ' ') do Inc(j);
// Display Text under Cursor
Caption := Copy(s, i, j - i);
end;
end;
|
Как отловить правый Enter (NumPad).
| Автор: Full WEB-сайт: http://full.hotmail.ru |
| Заходит в лифт программист и вспоминает что ему надо попасть на 12-ый этаж. Что делать? Ну, нажимает он "1", потом нажимает "2" и начинает судорожно искать кнопку "ENTER" |
Для этого можно воспользоваться функцией GetHeapStatus:
procedure TForm1.WMKeyDown(var message: TWMKeyDown);
begin
inherited;
case message.CharCode of
VK_RETURN:
begin
if (message.KeyData and $1000000 <> 0) then
begin
{ ENTER on numeric keypad }
end
else
begin
{ ENTER on the standard keyboard }
end;
end;
end;
end;
|
Как правильно печатать любую информацию (растровые и векторные изображения), а также как сделать режим предварительного просмотра.
| Автор: Nomadic |
| Как известно, смертоносный вирус "Я люблю тебя" видоизменился, приняв новые обличья. Он последовательно мутировал в вирусы: "Ты мне нравишься" "Ты, конечно, мне нравишься, но давай просто будем друзьями" "Послушай, я просто хотела познакомиться..." "Ладно, я думаю, нам нужно прервать всякие отношения!" "Да я была просто пьяная!" "Перестань мне звонить, идиот!" "Ну все! Ты козел, папа твой козел и мама твоя дура!" и, наконец, в вирус "Пошел на...! |
Решили пункт 1.
procedure SetKoeffMeta; // установить коэф-ты
var
PrevMetafile: TMetafile;
MetaCanvas: TMetafileCanvas;
begin
PrevMetafile := nil;
MetaCanvas := nil;
try
PrevMetaFile := TMetaFile.Create;
try
MetaCanvas := TMetafileCanvas.Create(PrevMetafile, 0);
kScale := GetDeviceCaps(Printer.Handle, LOGPIXELSX) /
Screen.PixelsPerInch;
MetaCanvas.Font.Assign(oGrid.Font);
MetaCanvas.Font.Size := Round(oGrid.Font.Size * kScale);
kW := MetaCanvas.TextWidth('W') / oGrid.Canvas.TextWidth('W');
kH := MetaCanvas.TextHeight('W') / oGrid.Canvas.TextHeight('W');
finally
MetaCanvas.Free;
end;
finally
PrevMetafile.Free;
end;
end;
|
Решаем 2.
...
var
PrevMetafile: TMetafile;
MetaCanvas: TMetafileCanvas;
begin
PrevMetafile := nil;
MetaCanvas := nil;
try
PrevMetaFile := TMetaFile.Create;
PrevMetafile.Width := oWidth;
PrevMetafile.Height := oHeight;
try
MetaCanvas := TMetafileCanvas.Create(PrevMetafile, 0);
// здесь должен быть ваш код - с учетом масштабирования.
// я эту вещь вынес в ассигнуемую процедуру, и данный блок
// вызываю лишь для отрисовки целой страницы.
см.PS1.
finally
MetaCanvas.Free;
end;
...
PS1.Код, который используется для отрисовки.oCanvas - TCanvas метафайла.
...
var
iHPage: integer; // высота страницы
begin
with oCanvas do
begin
iHPage := 3000;
// залили область метайфайла белым - для дальнейшей работы
Pen.Color := clBlack;
Brush.Color := clWhite;
FillRect(Rect(0, 0, 2000, iHPage));
// установили шрифты - с учетом их дальнейшего масштабирования
oCanvas.Font.Assign(oGrid.Font);
oCanvas.Font.Size := Round(oGrid.Font.Size * kScale);
...
xEnd := xBegin;
iH := round(RowHeights[iRow] * kH);
for iCol := 0 to ColCount - 1 do
begin
x := xEnd;
xEnd := x + round(ColWidths[iCol] * kW);
Rectangle(x, yBegin, xEnd, yBegin + iH);
r := Rect(x + 1, yBegin + 1, xEnd - 1, yBegin + iH - 1);
s := Cells[iCol, iRow];
// выписали в полученный квадрат текст
DrawText(oCanvas.Handle, PChar(s), Length(s), r, DT_WORDBREAK or
DT_CENTER);
|
Главное, что важно помнить на этом этапе - это не забывать, что все выводимые объекты должны пользоваться описанными коэф-тами (как вы их получите - это уже ваше дело). В данном случае - я работаю с переделанным TStringGrid, который сделал для многостраничной печати. Последний пункт - надо сформированный метафайл или bmp напечатать.
...
var
Info: PBitmapInfo;
InfoSize: Integer;
Image: Pointer;
ImageSize: DWORD;
Bits: HBITMAP;
DIBWidth, DIBHeight: Longint;
PrintWidth, PrintHeight: Longint;
begin
...
case ImageType of
itMetafile:
begin
if Picture.Metafile <> nil then
Printer.Canvas.StretchDraw(Rect(aLeft, aTop, aLeft + fWidth, aTop +
fHeight), Picture.Metafile);
end;
itBitmap:
begin
if Picture.Bitmap <> nil then
begin
with Printer, Canvas do
begin
Bits := Picture.Bitmap.Handle;
GetDIBSizes(Bits, InfoSize, ImageSize);
Info := AllocMem(InfoSize);
try
Image := AllocMem(ImageSize);
try
GetDIB(Bits, 0, Info^, Image^);
with Info^.bmiHeader do
begin
DIBWidth := biWidth;
DIBHeight := biHeight;
end;
PrintWidth := DIBWidth;
PrintHeight := DIBHeight;
StretchDIBits(Canvas.Handle, aLeft, aTop, PrintWidth,
PrintHeight, 0, 0, DIBWidth, DIBHeight, Image, Info^,
DIB_RGB_COLORS, SRCCOPY);
finally
FreeMem(Image, ImageSize);
end;
finally
FreeMem(Info, InfoSize);
end;
end;
end;
end;
end;
|
Кстати, когда мы работаем с Bmp, то для просмотра используем следующий хинт - записываем битовый образ через такую процедуру:
w:=MulDiv(Bmp.Width,GetDeviceCaps(Printer.Handle,LOGPIXELSX),Screen.PixelsPerInch); h:=MulDiv(Bmp.Height,GetDeviceCaps(Printer.Handle,LOGPIXELSY),Screen.PixelsPerInch); PrevBmp.Width:=w; PrevBmp.Height:=h; PrevBmp.Canvas.StretchDraw(Rect(0,0,w,h),Bmp); aPicture.Assign(PrevBmp); |
PPS. Прошу прощения за возможные стилистические неточности - время вышло, охрана уже ругается. Но код - выдран из работающих исходников.
Как научить Delphi делать правильное округление дробных чисел.
| Автор: Lonely Wanderer |
| Чем отличается законченный программист от простого пользователя? Пользователь думает, что в килобайте 1000 байт, а Программист думает, что в километре 1024 метра. |
function RoundStr(Zn: Real; kol_zn: Integer): Real;
var
snl, s, s0, s1, s2: string;
n, n1: Real;
nn, i: Integer;
begin
s := FloatToStr(Zn);
if (Pos(',', s) > 0) and (Zn > 0) and
(Length(Copy(s, Pos(',', s) + 1, length(s))) > kol_zn) then
begin
s0 := Copy(s, 1, Pos(',', s) + kol_zn - 1);
s1 := Copy(s, 1, Pos(',', s) + kol_zn + 2);
s2 := Copy(s1, Pos(',', s1) + kol_zn, Length(s1));
n := StrToInt(s2) / 100;
nn := Round(n);
if nn >= 10 then
begin
snl := '0,';
for i := 1 to kol_zn - 1 do
snl := snl + '0';
snl := snl + '1';
n1 := StrToFloat(Copy(s, 1, Pos(',', s) + kol_zn)) + StrToFloat(snl);
s := FloatToStr(n1);
if Pos(',', s) > 0 then
s1 := Copy(s, 1, Pos(',', s) + kol_zn);
end
else
s1 := s0 + IntToStr(nn);
if s1[Length(s1)] = ',' then
s1 := s1 + '0';
Result := StrToFloat(s1);
end
else
Result := Zn;
end;
|
Или.
function RoundEx(X: Double; Precision: Integer ): Double;
{
Precision :
1 - до целых
10 - до десятых
100 - до сотых
...
}
var
ScaledFractPart, Temp: Double;
begin
ScaledFractPart := Frac(X) * Precision;
Temp := Frac(ScaledFractPart);
ScaledFractPart := Int(ScaledFractPart);
if Temp >= 0.5 then
ScaledFractPart := ScaledFractPart + 1;
if Temp then
ScaledFractPart := ScaledFractPart - 1;
RoundEx := Int(X) + ScaledFractPart / Precision;
end;
|
Округление дробных чисел с точностью i - количество знаков после запятой, S - дробное число в строковом виде.
function FormatData(s: String; i: Integer): String; begin Result:=FloatToStr(Round(StrToFloat(s)*exp(i*ln(10)))/(exp(i*ln(10)))); end;
Меню с правой стороны.
| Для выхода в меню нажмите Reset. |
Главное меню окна – до боли знакомая вещь. Какое же извращение придумать с ним?..
Весьма необычно будет, если какой-нибудь пункт меню будет обособленно располагаться с правой стороны окна! (или несколько пунктов меню). Как же это сделать? Для этого нужно иметь: компонент MainMenu – 1 штука, форма – 1 штука, клава – 2 штуки (одна для того, чтобы набить ту чушь, что расположена ниже, а другая, являющаяся особой женского пола – для одних только вам известных забав). Начнём с первой (тем более, что кончить на второй всегда успеем!).
Всё что нужно сделать для этого – это создать главное меню, например, показанное на рисунке, и по созданию окна (событие OnCreate) написать следующий код:
procedure TForm1.FormCreate(Sender: TObject); begin ModifyMenu(MainMenu1.Handle, 3, mf_ByPosition or mf_Popup or mf_Help, Help1.Handle, PChar(Help1.Caption)); end; |
Как в TEdit расположить текст справа.
| Новая серия книг Издательства Piter-press: Windows 98: баг за багом. |
Идея заключается в том, как сделать правое выравнивание текста в TEdit, не прибегая к написанию нового компонента.
Для этого можно воспользоваться канвасом. Так как TEdit не имеет канваса, то сперва мы создадим TControlCanvas а затем, прикрепим TEdit к этому канвасу.
Теперь нам доступны все свойства и методы TControlCanvas, поэтому мы спокойно можем настраивать в нём текст. Ниже приведёна процедура, реализующая всё вышесказанное.
procedure RJustifyEdit(var ThisEdit : TEdit);
var
Left, Width: Integer;
GString: string;
Rgn: TRect;
TheCanvas: TControlCanvas;
begin
TheCanvas := TControlCanvas.Create;
try
TheCanvas.Control := ThisEdit;
GString := ThisEdit.Text;
Rgn := ThisEdit.ClientRect;
TheCanvas.FillRect(Rgn);
Width := TheCanvas.TextWidth(GString);
Left := Rgn.Right - Width - 1;
TheCanvas.TextRect(Rgn, Left, 0, GString);
finally
TheCanvas.Free;
end;
end;
|
Как в TEdit расположить текст справа 2.
| Женится один программист. Друг его спрашивает: - Ну, как невеста, хороша? - Как топ-модель! - Что, 90х60х90? - Обижаешь: 128х64х128! |
TEdit не поддерживает выравниваение текста по центру и по правой стороне - лучше использовать компонент TMemo. Вам понадобится запретить пользователю нажимать Enter, Ctrl-Enter и всевозможные комбинации клавиш со стрелками, чтобы избежать появления нескольких сторк в Memo. Этого можно добиться и просматривая содержимое текста в TMemo в поисках кода возврата каретки (13) и перевода строки(10) на событиях TMemo Change и KeyPress. Можно также заменять код возврата каретки на пробел - для того чтобы позволять вставку из буфера обмена многострочного текста в виде одной строки.
procedure TForm1.FormCreate(Sender: TObject);
begin
Memo1.Alignment := taRightJustify;
Memo1.MaxLength := 24;
Memo1.WantReturns := false;
Memo1.WordWrap := false;
end;
procedure MultiLineMemoToSingleLine(Memo : TMemo);
var
t: string;
begin
t := Memo.Text;
if Pos(#13, t) > 0 then
begin
while Pos(#13, t) > 0 do
delete(t, Pos(#13, t), 1);
while Pos(#10, t) > 0 do
delete(t, Pos(#10, t), 1);
Memo.Text := t;
end;
end;
procedure TForm1.Memo1Change(Sender: TObject);
begin
MultiLineMemoToSingleLine(Memo1);
end;
procedure TForm1.Memo1KeyPress(Sender: TObject; var Key: Char);
begin
MultiLineMemoToSingleLine(Memo1);
end;
|
Окно в виде кольца.
Умея создавать окно эллипсовидной формы, для вас не составит большого труда слепить что-нибудь наподобие того, что показано на рисунке. Всё, что вам нужно сделать - это создать не один, а два региона и объединить их, используя функцию CombineRgn, т.е. теперь по созданию окна можно написать что-то вроде этого:
procedure TForm1.FormCreate(Sender: TObject); var hsWindowRegion, hsWindowRegion2: Integer; begin hsWindowRegion := CreateEllipticRgn(50, 50, 350, 200); hsWindowRegion2:=CreateEllipticRgn(80, 80, 200, 150); CombineRgn(hsWindowRegion, hsWindowRegion, hsWindowRegion2, RGN_DIFF); SetWindowRgn(Handle, hsWindowRegion, true); end; |
Мы уже знаем какую функцию нужно использовать для объединения регионов, но как же она действует и что же ей нужно указывать?
Вводятся следующие параметры:
Дескриптор региона назначения, Дескриптор первого региона источника, Дескриптор второго региона источника, Режим взаимодействия регионов источников.В качестве режима мы указали константу RGN_DIFF, а использовать можем:
RGN_AND - Создает пересечение из двух смешанных областей, RGN_COPY - Создает копию области, идентифицированной дескриптором первой области источника, RGN_DIFF - Выводит части первой области источника, которые не пересекаются со второй, RGN_OR - Создает объединение двух смешанных областей, RGN_XOR - Создает объединение двух смешанных областей за исключением зоны перекрытия.Римские в арабские и наоборот.
Автор: Gua WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Конвертация : Римские -> арабские ; Арабские->Римские
Зависимости:
Автор: Gua, fbsdd@ukr.net, ICQ:141585495, Simferopol
Copyright:
Дата: 03 мая 2002 г.
***************************************************** }
const
R: array[1..13] of string[2] =
('I', 'IV', 'V', 'IX', 'X', 'XL', 'L', 'XC', 'C', 'CD', 'D', 'CM', 'M');
A: array[1..13] of Integer =
(1, 4, 5, 9, 10, 40, 50, 90, 100, 400, 500, 900, 1000);
..............
function ArabicToRoman(N: Integer): string; //Арабские в римские
var
i: Integer;
begin
Result := '';
i := 13;
while N > 0 do
begin
while A[i] > N do
Dec(i);
Result := Result + R[i];
Dec(N, A[i]);
end;
end;
function RomanToArabic(S: string): Integer; //Римские в арабские
var
i, p: Integer;
begin
Result := 0;
i := 13;
p := 1;
while p <= Length(S) do
begin
while Copy(S, p, Length(R[i])) <> R[i] do
begin
Dec(i);
if i = 0 then
Exit;
end;
Result := Result + A[i];
p := p + Length(R[i]);
end;
end;
Определить корень слова (для поиска похожих слов).
| Автор: ___Nikolay WEB-сайт: http://delphiworld.narod.ru |
// Поиск по корню слова
function RootOfWord(s: string): string;
label
start;
const
sGlas = 'аеёиоуыэюяаеiои'; // With english letters
sSoglas = 'бвгджзйклмнпрстфхцчшщъь';
sCompletions1 = 'й ь s';
sCompletions2 = 'ам ям ом ем ин ём ся ет ит ут ют ат ят ыв ив ев ан ян ов ев ог ег ир ер ых ок ющ ущ er ed';
sCompletions3 = 'енн овл евл ённ анн ост ест';
sAttachments1 = 'в с';
sAttachments2 = 'на за ис из до по вы во со';
sAttachments3 = 'при рас пре про под';
sAttachments4 = 'пере';
var
sResult: string;
i, iCnt, iGlasCount, iCheckCount: integer;
begin
sResult := AnsiLowerCase(Trim(s));
iCheckCount := 0;
start:
// "ся"
if Length(sResult) > 3 then
if sResult[Length(sResult) - 1] + sResult[Length(sResult)] = 'ся' then
Delete(sResult, Length(sResult) - 1, 2);
(* E N G L I S H *)
// "ing"
if Length(sResult) > 4 then
if sResult[Length(sResult) - 2] + sResult[Length(sResult) - 1] + sResult[Length(sResult)] = 'ing' then
Delete(sResult, Length(sResult) - 2, 3);
// --
// Гласные
if Length(sResult) > 3 then
begin
iGlasCount := 0;
for i := Length(sResult) downto 1 do
if Pos(sResult[i], sGlas) <> 0 then // Если последний символ - гласная
inc(iGlasCount)
else
break;
if iGlasCount <> 0 then
begin
iGlasCount := iGlasCount - 1;
Delete(sResult, Length(sResult) - iGlasCount, iGlasCount + 1);
end;
end;
// Окончания
if Length(sResult) > 3 then
if Pos(sResult[Length(sResult)], sCompletions1) <> 0 then
Delete(sResult, Length(sResult), 1);
// "ся"
if Length(sResult) > 3 then
if sResult[Length(sResult) - 1] + sResult[Length(sResult)] = 'ся' then
Delete(sResult, Length(sResult) - 1, 2);
if Length(sResult) > 3 then
while Pos(sResult[Length(sResult) - 2] + sResult[Length(sResult) - 1] +
sResult[Length(sResult)], sCompletions3) <> 0 do
begin
if Length(sResult) > 3 then
Delete(sResult, Length(sResult) - 1, 3)
else
break;
end;
if Length(sResult) > 3 then
while Pos(sResult[Length(sResult) - 1] + sResult[Length(sResult)], sCompletions2) <> 0 do
begin
if Length(sResult) > 3 then
Delete(sResult, Length(sResult) - 1, 2)
else
break;
end;
// Гласные
if Length(sResult) > 3 then
begin
iGlasCount := 0;
for i := Length(sResult) downto 1 do
if Pos(sResult[i], sGlas) <> 0 then // Если последний символ - гласная
inc(iGlasCount)
else
break;
if iGlasCount <> 0 then
begin
iGlasCount := iGlasCount - 1;
Delete(sResult, Length(sResult) - iGlasCount, iGlasCount + 1);
end;
end;
// Приставки
iCnt := 4;
if Length(sResult) > iCnt then
if Pos(Copy(sResult, 1, iCnt), sAttachments4) <> 0 then
Delete(sResult, 1, iCnt);
iCnt := 3;
if Length(sResult) > iCnt then
if Pos(Copy(sResult, 1, iCnt), sAttachments3) <> 0 then
Delete(sResult, 1, iCnt);
iCnt := 2;
if Length(sResult) > iCnt then
if Pos(Copy(sResult, 1, iCnt), sAttachments2) <> 0 then
Delete(sResult, 1, iCnt);
iCnt := 1;
if Length(sResult) > iCnt then
if Pos(Copy(sResult, 1, iCnt), sAttachments1) <> 0 then
Delete(sResult, 1, iCnt);
inc(iCheckCount);
if iCheckCount < 2 then
goto start;
Result := sResult;
end;
Повернуть 2D точку.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
const PIDiv180 = 0.017453292519943295769236907684886; procedure Rotate(RotAng: Double; x, y: Double; var Nx, Ny: Double); var SinVal: Double; CosVal: Double; begin RotAng := RotAng * PIDiv180; SinVal := Sin(RotAng); CosVal := Cos(RotAng); Nx := x * CosVal - y * SinVal; Ny := y * CosVal + x * SinVal; end; (* End Of Rotate Cartesian Point*)
Как повернуть Bitmap на любой угол.
const
PixelMax = 32768;
type
pPixelArray = ^TPixelArray;
TPixelArray = array [0..PixelMax-1] of TRGBTriple;
procedure RotateBitmap_ads(SourceBitmap: TBitmap;
out DestBitmap: TBitmap; Center: TPoint; Angle: Double);
var
cosRadians : Double;
inX : Integer;
inXOriginal : Integer;
inXPrime : Integer;
inXPrimeRotated : Integer;
inY : Integer;
inYOriginal : Integer;
inYPrime : Integer;
inYPrimeRotated : Integer;
OriginalRow : pPixelArray;
Radians : Double;
RotatedRow : pPixelArray;
sinRadians : Double;
begin
DestBitmap.Width := SourceBitmap.Width;
DestBitmap.Height := SourceBitmap.Height;
DestBitmap.PixelFormat := pf24bit;
Radians := -(Angle) * PI / 180;
sinRadians := Sin(Radians);
cosRadians := Cos(Radians);
for inX := DestBitmap.Height-1 downto 0 do
begin
RotatedRow := DestBitmap.Scanline[inX];
inXPrime := 2*(inX - Center.y) + 1;
for inY := DestBitmap.Width-1 downto 0 do
begin
inYPrime := 2*(inY - Center.x) + 1;
inYPrimeRotated := Round(inYPrime * CosRadians - inXPrime * sinRadians);
inXPrimeRotated := Round(inYPrime * sinRadians + inXPrime * cosRadians);
inYOriginal := (inYPrimeRotated - 1) div 2 + Center.x;
inXOriginal := (inXPrimeRotated - 1) div 2 + Center.y;
if (inYOriginal >= 0) and (inYOriginal <= SourceBitmap.Width-1) and
(inXOriginal >= 0) and (inXOriginal <= SourceBitmap.Height-1) then
begin
OriginalRow := SourceBitmap.Scanline[inXOriginal];
RotatedRow[inY] := OriginalRow[inYOriginal]
end
else
begin
RotatedRow[inY].rgbtBlue := 255;
RotatedRow[inY].rgbtGreen := 0;
RotatedRow[inY].rgbtRed := 0
end;
end;
end;
end;
{Usage:}
procedure TForm1.Button1Click(Sender: TObject);
var
Center : TPoint;
Bitmap : TBitmap;
begin
Bitmap := TBitmap.Create;
try
Center.y := (Image.Height div 2)+20;
Center.x := (Image.Width div 2)+0;
RotateBitmap_ads(
Image.Picture.Bitmap,
Bitmap,
Center,
Angle);
Angle := Angle + 15;
Image2.Picture.Bitmap.Assign(Bitmap);
finally
Bitmap.Free;
end;
end;
|
Как повернуть Bitmap на любой угол 2.
procedure RotateBitmap(Bitmap: TBitmap; Angle: Double; BackColor: TColor);
type TRGB = record
B, G, R: Byte;
end;
pRGB = ^TRGB;
pByteArray = ^TByteArray;
TByteArray = array[0..32767] of Byte;
TRectList = array [1..4] of TPoint;
var x, y, W, H, v1, v2: Integer;
Dest, Src: pRGB;
VertArray: array of pByteArray;
Bmp: TBitmap;
procedure SinCos(AngleRad: Double; var ASin, ACos: Double);
begin
ASin := Sin(AngleRad);
ACos := Cos(AngleRad);
end;
function RotateRect(const Rect: TRect; const Center: TPoint; Angle: Double): TRectList;
var DX, DY: Integer;
SinAng, CosAng: Double;
function RotPoint(PX, PY: Integer): TPoint;
begin
DX := PX - Center.x;
DY := PY - Center.y;
Result.x := Center.x + Round(DX * CosAng - DY * SinAng);
Result.y := Center.y + Round(DX * SinAng + DY * CosAng);
end;
begin
SinCos(Angle * (Pi / 180), SinAng, CosAng);
Result[1] := RotPoint(Rect.Left, Rect.Top);
Result[2] := RotPoint(Rect.Right, Rect.Top);
Result[3] := RotPoint(Rect.Right, Rect.Bottom);
Result[4] := RotPoint(Rect.Left, Rect.Bottom);
end;
function Min(A, B: Integer): Integer;
begin
if A < B then Result := A
else Result := B;
end;
function Max(A, B: Integer): Integer;
begin
if A > B then Result := A
else Result := B;
end;
function GetRLLimit(const RL: TRectList): TRect;
begin
Result.Left := Min(Min(RL[1].x, RL[2].x), Min(RL[3].x, RL[4].x));
Result.Top := Min(Min(RL[1].y, RL[2].y), Min(RL[3].y, RL[4].y));
Result.Right := Max(Max(RL[1].x, RL[2].x), Max(RL[3].x, RL[4].x));
Result.Bottom := Max(Max(RL[1].y, RL[2].y), Max(RL[3].y, RL[4].y));
end;
procedure Rotate;
var x, y, xr, yr, yp: Integer;
ACos, ASin: Double;
Lim: TRect;
begin
W := Bmp.Width;
H := Bmp.Height;
SinCos(-Angle * Pi/180, ASin, ACos);
Lim := GetRLLimit(RotateRect(Rect(0, 0, Bmp.Width, Bmp.Height), Point(0, 0), Angle));
Bitmap.Width := Lim.Right - Lim.Left;
Bitmap.Height := Lim.Bottom - Lim.Top;
Bitmap.Canvas.Brush.Color := BackColor;
Bitmap.Canvas.FillRect(Rect(0, 0, Bitmap.Width, Bitmap.Height));
for y := 0 to Bitmap.Height - 1 do begin
Dest := Bitmap.ScanLine[y];
yp := y + Lim.Top;
for x := 0 to Bitmap.Width - 1 do begin
xr := Round(((x + Lim.Left) * ACos) - (yp * ASin));
yr := Round(((x + Lim.Left) * ASin) + (yp * ACos));
if (xr > -1) and (xr < W) and (yr > -1) and (yr < H) then begin
Src := Bmp.ScanLine[yr];
Inc(Src, xr);
Dest^ := Src^;
end;
Inc(Dest);
end;
end;
end;
begin
Bitmap.PixelFormat := pf24Bit;
Bmp := TBitmap.Create;
try
Bmp.Assign(Bitmap);
W := Bitmap.Width - 1;
H := Bitmap.Height - 1;
if Frac(Angle) <> 0.0
then Rotate
else
case Trunc(Angle) of
-360, 0, 360, 720: Exit;
90, 270: begin
Bitmap.Width := H + 1;
Bitmap.Height := W + 1;
SetLength(VertArray, H + 1);
v1 := 0;
v2 := 0;
if Angle = 90.0 then v1 := H
else v2 := W;
for y := 0 to H do VertArray[y] := Bmp.ScanLine[Abs(v1 - y)];
for x := 0 to W do begin
Dest := Bitmap.ScanLine[x];
for y := 0 to H do begin
v1 := Abs(v2 - x)*3;
with Dest^ do begin
B := VertArray[y, v1];
G := VertArray[y, v1+1];
R := VertArray[y, v1+2];
end;
Inc(Dest);
end;
end
end;
180: begin
for y := 0 to H do begin
Dest := Bitmap.ScanLine[y];
Src := Bmp.ScanLine[H - y];
Inc(Src, W);
for x := 0 to W do begin
Dest^ := Src^;
Dec(Src);
Inc(Dest);
end;
end;
end;
else Rotate;
end;
finally
Bmp.Free;
end;
end;
// Использование
RotateBitmap(Image1.Picture.Bitmap, StrToInt(Edit1.Text), clWhite);
|
Вращать Bitmap вокруг точки.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
// Vektor von FromP nach ToP
// Vector from FromP to ToP
function TForm1.Vektor(FromP, Top: TPoint): TPoint;
begin
Result.x := Top.x - FromP.x;
Result.y := Top.y - FromP.y;
end;
// neue x Komponente des Verktors
// new x-component of the vector
function TForm1.xComp(Vektor: TPoint; Angle: Extended): Integer;
begin
Result := Round(Vektor.x * cos(Angle) - (Vektor.y) * sin(Angle));
end;
// neue Y-Komponente des Vektors
// new y-component of the vector
function TForm1.yComp(Vektor: TPoint; Angle: Extended): Integer;
begin
Result := Round((Vektor.x) * (sin(Angle)) + (vektor.y) * cos(Angle));
end;
function TForm1.RotImage(srcbit: TBitmap; Angle: Extended; FPoint: TPoint;
Background: TColor): TBitmap;
{
srcbit: TBitmap; // Bitmap dass gedreht werden soll ; Bitmap to be rotated
Angle: extended; // Winkel in Bogenma?, angle
FPoint: TPoint; // Punkt um den gedreht wird ; Point to be rotated around
Background: TColor): TBitmap; // Hintergrundfarbe des neuen Bitmaps ;
// Backgroundcolor of the new bitmap
}
var
highest, lowest, mostleft, mostright: TPoint;
topoverh, leftoverh: integer;
x, y, newx, newy: integer;
begin
Result := TBitmap.Create;
// Drehwinkel runterrechnen auf eine Umdrehung, wenn notig
// Calculate angle down on one rotation, if necessary
while Angle >= (2 * pi) do
begin
angle := Angle - (2 * pi);
end;
// neue Ausma?e festlegen
// specify new size
if (angle <= (pi / 2)) then
begin
highest := Point(0,0); //OL
Lowest := Point(Srcbit.Width, Srcbit.Height); //UR
mostleft := Point(0,Srcbit.Height); //UL
mostright := Point(Srcbit.Width, 0); //OR
end
else if (angle <= pi) then
begin
highest := Point(0,Srcbit.Height);
Lowest := Point(Srcbit.Width, 0);
mostleft := Point(Srcbit.Width, Srcbit.Height);
mostright := Point(0,0);
end
else if (Angle <= (pi * 3 / 2)) then
begin
highest := Point(Srcbit.Width, Srcbit.Height);
Lowest := Point(0,0);
mostleft := Point(Srcbit.Width, 0);
mostright := Point(0,Srcbit.Height);
end
else
begin
highest := Point(Srcbit.Width, 0);
Lowest := Point(0,Srcbit.Height);
mostleft := Point(0,0);
mostright := Point(Srcbit.Width, Srcbit.Height);
end;
topoverh := yComp(Vektor(FPoint, highest), Angle);
leftoverh := xComp(Vektor(FPoint, mostleft), Angle);
Result.Height := Abs(yComp(Vektor(FPoint, lowest), Angle)) + Abs(topOverh);
Result.Width := Abs(xComp(Vektor(FPoint, mostright), Angle)) + Abs(leftoverh);
// Verschiebung des FPoint im neuen Bild gegenuber srcbit
// change of FPoint in the new picture in relation on srcbit
Topoverh := TopOverh + FPoint.y;
Leftoverh := LeftOverh + FPoint.x;
// erstmal mit Hintergrundfarbe fullen
// at first fill with background color
Result.Canvas.Brush.Color := Background;
Result.Canvas.pen.Color := background;
Result.Canvas.Fillrect(Rect(0,0,Result.Width, Result.Height));
// Start des eigentlichen Rotierens
// Start of actual rotation
for y := 0 to srcbit.Height - 1 do
begin // Zeilen ; Rows
for x := 0 to srcbit.Width - 1 do
begin // Spalten ; Columns
newX := xComp(Vektor(FPoint, Point(x, y)), Angle);
newY := yComp(Vektor(FPoint, Point(x, y)), Angle);
newX := FPoint.x + newx - leftoverh;
// Verschieben wegen der neuen Ausma?e
newy := FPoint.y + newy - topoverh;
// Move beacause of new size
Result.Canvas.Pixels[newx, newy] := srcbit.Canvas.Pixels[x, y];
// auch das Pixel daneben fullen um Leerpixel bei Drehungen zu verhindern
// also fil lthe pixel beside to prevent empty pixels
if ((angle < (pi / 2)) or
((angle > pi) and
(angle < (pi * 3 / 2)))) then
begin
Result.Canvas.Pixels[newx, newy + 1] := srcbit.Canvas.Pixels[x, y];
end
else
begin
Result.Canvas.Pixels[newx + 1,newy] := srcbit.Canvas.Pixels[x, y];
end;
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
mybitmap, newbit: TBitMap;
begin
if OpenDialog1.Execute then
begin
mybitmap := TBitmap.Create;
mybitmap.LoadFromFile(OpenDialog1.FileName);
newbit := RotImage(mybitmap, DegToRad(45),
Point(mybitmap.Width div 2, mybitmap.Height div 2), clBlack);
Image1.Canvas.Draw(0,0, newBit);
end;
end;
end;
Переворачиваем рабочий стол.
Автор: William EggeВесёлая программка, которая позволяет подшутить над Вашими друзьями:-]. Пример переворачивает десктоп и держит его в таком положение, до тех пор пока не кликнуть по нему мышкой. По мимо этого код содержит в себе довольно интересные моменты.
В примере используется TDesktopCanvas, который получить доступ к десктопу через объект TCanvas. Так же в примере используется TQuickPixel, который позволяет увеличить скорость доступа к пикселям.Скачайте исходник, откомпилируйте его, и поместите программку в папку "Автозагрузка" на компьютере Вашего друга и смело идите по своим делам :-).
Для завершения работы программки достаточно кликнуть по перевёрнутому экрану.
А теперь давайте разберёмся с исходником:
Класс TQuickPixel был сделан для быстрого доступа к пикселям, чтобы не возиться со строками развёртки. Для увеличения производительности, данный класс кэширует строки развёртки. Единственный недостаток данного класса заключается в том, что он устанавливает Ваш Bitmap в 24 бита.
Ниже представлен собственно сам код TQuickPixel.
unit QuickPixel;
interface
uses
Windows, Graphics;
type
TQuickPixel = class
private
FBitmap: TBitmap;
FScanLines: array of PRGBTriple;
function GetPixel(X, Y: Integer): TColor;
procedure SetPixel(X, Y: Integer; const Value: TColor);
function GetHeight: Integer;
function GetWidth: Integer;
public
constructor Create(const ABitmap: TBitmap);
property Pixel[X, Y: Integer]: TColor read GetPixel write SetPixel;
property Width: Integer read GetWidth;
property Height: Integer read GetHeight;
end;
implementation
{ TQuickPixel }
constructor TQuickPixel.Create(const ABitmap: TBitmap);
var
I: Integer;
begin
inherited Create;
FBitmap:= ABitmap;
FBitmap.PixelFormat:= pf24bit;
SetLength(FScanLines, FBitmap.Height);
for I:= 0 to FBitmap.Height-1 do
FScanLines[I]:= FBitmap.ScanLine[I];
end;
function TQuickPixel.GetHeight: Integer;
begin
Result:= FBitmap.Height;
end;
function TQuickPixel.GetPixel(X, Y: Integer): TColor;
var
P: PRGBTriple;
begin
P:= FScanLines[Y];
Inc(P, X);
Result:= (P^.rgbtBlue shl 16) or (P^.rgbtGreen shl 8) or P^.rgbtRed;
end;
function TQuickPixel.GetWidth: Integer;
begin
Result:= FBitmap.Width;
end;
procedure TQuickPixel.SetPixel(X, Y: Integer; const Value: TColor);
var
P: PRGBTriple;
begin
P:= FScanLines[Y];
Inc(P, X);
P^.rgbtBlue:= (Value and $FF0000) shr 16;
P^.rgbtGreen:= (Value and $00FF00) shr 8;
P^.rgbtRed:= Value and $0000FF;
end;
end.
|
Ну, надеюсь, вы с ним разобрались, перейдём же к самому проекту. Свойство окна BorderStyle установите в bsNone, свойство FormStyle - в fsStayOnTop, а свойству WindowState задайте значение wsMaximized. Вынесите на форму компонент TImage, его свойство Align выставьте в alClient, по нажатию на TImage напишите:
Close; |
Затем следующим образом опишите обработчик создания окна [событие OnCreate()]:
procedure TForm1.FormCreate(Sender: TObject);
var
B: TBitmap;
Desktop: TDesktopCanvas;
QP: TQuickPixel;
X, Y: Integer;
EndCopyIndex: Integer;
Temp: TColor;
begin
Left:= 0;
Top:= 0;
Width:= Screen.Width;
Height:= Screen.Height;
B:= nil;
Desktop:= nil;
try
Desktop:= TDesktopCanvas.Create;
B:= TBitmap.Create;
B.Width:= Screen.Width;
B.Height:= Screen.Height;
B.Canvas.CopyRect(Rect(0, 0, B.Width, B.Height),
Desktop, Rect(0, 0, B.Width, B.Height));
B.PixelFormat:= pf24bit;
QP:= TQuickPixel.Create(B);
try
for Y:= 0 to (QP.Height div 2)-1 do
begin
EndCopyIndex:= (QP.Height-1)-Y;
for X:= 0 to QP.Width-1 do
begin
Temp:= QP.Pixel[X, Y];
QP.Pixel[X, Y]:= QP.Pixel[X, EndCopyIndex];
QP.Pixel[X, EndCopyIndex]:= Temp;
end;
end;
finally
QP.Free;
end;
with Image1.Picture.Bitmap do
begin
Width:= Image1.Width;
Height:= Image1.Height;
Canvas.CopyRect(Rect(0, 0, Width, Height), B.Canvas,
Rect(0, 0, Width, Height));
end;
finally
B.Free;
Desktop.Free;
end;
end;
|
Проверьте, все ли модули у вас подключены. Раздел uses должен выглядеть так:
uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, DesktopCanvas, QuickPixel; |
Повернуть DIB-изображение.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
function RotateBitmap(var hDIB: HGlobal; radang: Double; clrBack: TColor): Boolean;
// (c) Copyright original C Code: Code Guru
var
lpDIBBits: Pointer;
lpbi, hDIBResult: PBitmapInfoHeader;
bpp, nColors, nWidth, nHeight, nRowBytes: Integer;
cosine, sine: Double;
x1, y1, x2, y2, x3, y3, minx, miny, maxx, maxy, ti, x, y, w, h: Integer;
nResultRowBytes, nHeaderSize: Integer;
i, len: longint;
lpDIBBitsResult: Pointer;
dwBackColor: DWORD;
PtrClr: PRGBQuad;
RbackClr, GBackClr, BBackClr: Word;
sourcex, sourcey: Integer;
mask: Byte;
PtrByte: PByte;
dwpixel: DWORD;
PtrDWord: PDWord;
hDIBResInfo: HGlobal;
begin;
// Get source bitmap info
lpbi := PBitmapInfoHeader(GlobalLock(hdIB));
nHeaderSize := lpbi^.biSize + lpbi^.biClrUsed * SizeOf(TRGBQUAD);
lpDIBBits := Pointer(Longint(lpbi) + nHeaderSize);
bpp := lpbi^.biBitCount; // Bits per pixel
ncolors := lpbi^.biClrUsed; // Already computed when bitmap was loaded
nWidth := lpbi^.biWidth;
nHeight := lpbi^.biHeight;
nRowBytes := ((((nWidth * bpp) + 31) and (not 31)) shr 3);
// Compute the cosine and sine only once
cosine := cos(radang);
sine := sin(radang);
// Compute dimensions of the resulting bitmap
// First get the coordinates of the 3 corners other than origin
x1 := ceil(-nHeight * sine); // Originally floor at all places
y1 := ceil(nHeight * cosine);
x2 := ceil(nWidth * cosine - nHeight * sine);
y2 := ceil(nHeight * cosine + nWidth * sine);
x3 := ceil(nWidth * cosine);
y3 := ceil(nWidth * sine);
minx := min(0, min(x1, min(x2, x3)));
miny := min(0, min(y1, min(y2, y3)));
maxx := max(0, max(x1, max(x2, x3)));// added max(0,
maxy := max(0, max(y1, max(y2, y3)));// added max(0,
w := maxx - minx;
h := maxy - miny;
// Create a DIB to hold the result
nResultRowBytes := ((((w * bpp) + 31) and (not 31)) div 8);
len := nResultRowBytes * h;
hDIBResInfo := GlobalAlloc(GMEM_MOVEABLE, len + nHeaderSize);
if hDIBResInfo = 0 then
begin
Result := False;
Exit;
end;
hDIBResult := PBitmapInfoHeader(GlobalLock(hDIBResInfo));
// Initialize the header information
CopyMemory(hDIBResult, lpbi, nHeaderSize);
//BITMAPINFO &bmInfoResult = *(LPBITMAPINFO)hDIBResult ;
hDIBResult^.biWidth := w;
hDIBResult^.biHeight := h;
hDIBResult^.biSizeImage := len;
lpDIBBitsResult := Pointer(Longint(hDIBResult) + nHeaderSize);
// Get the back color value (index)
ZeroMemory(lpDIBBitsResult, len);
case bpp of
1:
begin //Monochrome
if (clrBack = RGB(255, 255, 255)) then
FillMemory(lpDIBBitsResult, len, $ff);
end;
4,
8:
begin //Search the color table
PtrClr := PRGBQuad(Longint(lpbi) + lpbi^.bisize);
RBackClr := GetRValue(clrBack);
GBackClr := GetGValue(clrBack);
BBackClr := GetBValue(clrBack);
for i := 0 to nColors - 1 do // Color table starts with index 0
begin
if (PtrClr^.rgbBlue = BBackClr) and
(PtrClr^.rgbGreen = GBackClr) and
(PtrClr^.rgbRed = RBackClr) then
begin
if (bpp = 4) then //if(bpp==4) i = i | i<<4;
ti := i or (i shl 4)
else
ti := i;
FillMemory(lpDIBBitsResult, ti, len);
break;
end;
Inc(PtrClr);
end;// If not match found the color remains black
end;
16:
begin
(* When the Compression field is set to BI_BITFIELDS,
Windows 95 supports
only the following 16bpp color masks: A 5-5-5 16-bit image, where the blue mask
is $001F, the green mask is $03E0, and the red mask is $7C00; and a 5-6-5
16-bit image, where the blue mask is $001F, the green mask is $07E0,
and the red mask is $F800. *)
PtrClr := PRGBQuad(Longint(lpbi) + lpbi^.bisize);
if (PtrClr^.rgbRed = $7c00) then // Check the Red mask
begin // Bitmap is RGB555
dwBackColor := ((GetRValue(clrBack) shr 3) shl 10) +
((GetRValue(clrBack) shr 3) shl 5) +
(GetBValue(clrBack) shr 3);
end
else
begin // Bitmap is RGB565
dwBackColor := ((GetRValue(clrBack) shr 3) shl 11) +
((GetRValue(clrBack) shr 2) shl 5) +
(GetBValue(clrBack) shr 3);
end;
end;
24,
32:
begin
dwBackColor := ((GetRValue(clrBack)) shl 16) or
((GetGValue(clrBack)) shl 8) or
((GetBValue(clrBack)));
end;
end;
// Now do the actual rotating - a pixel at a time
// Computing the destination point for each source point
// will leave a few pixels that do not get covered
// So we use a reverse transform - e.i. compute the source point
// for each destination point
for y := 0 to h - 1 do
begin
for x := 0 to w - 1 do
begin
sourcex := floor((x + minx) * cosine + (y + miny) * sine);
sourcey := floor((y + miny) * cosine - (x + minx) * sine);
if ((sourcex >= 0) and (sourcex < nWidth) and
(sourcey >= 0) and (sourcey < nHeight)) then
begin // Set the destination pixel
case bpp of
1:
begin //Monochrome
mask := PByte(Longint(lpDIBBits) +
nRowBytes * sourcey +
(sourcex div 8))^ and ($80 shr
(sourcex mod 8));
if mask <> 0 then
mask := $80 shr (x mod 8);
PtrByte := PByte(Longint(lpDIBBitsResult) +
nResultRowBytes * y + (x div
8));
PtrByte^ := PtrByte^ and (not ($80 shr (x mod
8)));
PtrByte^ := PtrByte^ or mask;
end;
4:
begin
if ((sourcex and 1) <> 0) then
mask := $0f
else
mask := $f0;
mask := PByte(Longint(lpDIBBits) +
nRowBytes * sourcey +
(sourcex div 2))^ and mask;
if ((sourcex and 1) <> (x and 1)) then
begin
if (mask and $f0) <> 0 then
mask := (mask shr 4)
else
mask := (mask shl 4);
end;
PtrByte := PByte(Longint(lpDIBBitsResult) +
nResultRowBytes * y + (x div
2));
if ((x and 1) <> 0) then
PtrByte^ := PtrByte^ and (not $0f)
else
PtrByte^ := PtrByte^ and (not $f0);
PtrByte^ := PtrByte^ or Mask;
end;
8:
begin
mask := PByte(Longint(lpDIBBits) +
nRowBytes * sourcey +
sourcex)^;
PtrByte := PByte(Longint(lpDIBBitsResult) +
nResultRowBytes * y + x);
PtrByte^ := mask;
end;
16:
begin
dwPixel := PDWord(Longint(lpDIBBits) +
nRowBytes * sourcey +
sourcex * 2)^;
PtrDword := PDWord(Longint(lpDIBBitsResult) +
nResultRowBytes * y + x * 2);
PtrDword^ := Word(dwpixel);
end;
24:
begin
dwPixel := PDWord(Longint(lpDIBBits) +
nRowBytes * sourcey +
sourcex * 3)^ and $ffffff;
PtrDword := PDWord(Longint(lpDIBBitsResult) +
nResultRowBytes * y + x * 3);
PtrDword^ := PtrDword^ or dwPixel;
end;
32:
begin
dwPixel := PDWord(Longint(lpDIBBits) +
nRowBytes * sourcey +
sourcex * 4)^;
PtrDword := PDWord(Longint(lpDIBBitsResult) +
nResultRowBytes * y + x * 4);
PtrDword^ := dwpixel;
end;
end; // Case
end
else
begin
// Draw the background color. The background color
// has already been drawn for 8 bits per pixel and less
case bpp of
16:
begin
PtrDWord := PDWord(Longint(lpDIBBitsResult) +
nResultRowBytes * y + x * 2);
PtrDword^ := Word(dwBackColor);
end;
24:
begin
PtrDWord := PDWord(Longint(lpDIBBitsResult) +
nResultRowBytes * y + x * 3);
PtrDword^ := PtrDword^ or dwBackColor;
end;
32:
begin
PtrDWord := PDWord(Longint(lpDIBBitsResult) +
nResultRowBytes * y + x * 4);
PtrDword^ := dwBackColor;
end;
end;
end;
end;
end;
GlobalUnLock(hDIBResInfo);
GlobalUnLock(hDIB);
GlobalFree(hDIB);
hDIB := hDIBResInfo;
Result := True;
end;
Алгоритм поворота изображения.
| Сколько в Гейтса тортом не кидай, Windows лучше не станет. |
Вот алгоритм поворота изображения. Пусть:
O - это центр поворота, M - некая точка исходного изображения.Для каждой точки M нужно найти угол alpha между отрезком OM и горизонталью и длину r отрезка OM. Теперь, чтобы повернуть изображение на угол beta, нужно каждой точке M присвоить цвет точки исходного изображения с координатами x,y, где.
x = xo + r * cos(alpha + beta) y = yo + r * sin(alpha + beta) |
Важно именно каждой точке нового изображения сопоставлять точку старого изображения, а не наоборот, так как иначе некоторые точки нового изображения останутся не закрашенными.
Эту программу можно сильно ускорить, если исходное изображение записать в массив и обращаться к реальной переменной, а не к свойству Canvas.Pixels.
uses
Math;
procedure TForm1.Button1Click(Sender: TObject);
var
bm, bm1: TBitMap;
x, y: integer;
r, a: single;
xo, yo: integer;
s, c: extended;
begin
bm := TBitMap.Create;
bm.LoadFromFile('ex.bmp');
xo := bm.Width div 2;
yo := bm.Height div 2;
bm1 := TBitMap.Create;
bm1.Width := bm.Width;
bm1.Height := bm.Height;
a := 0;
repeat
for y := 0 to bm.Height - 1 do
begin
for x := 0 to bm.Width - 1 do
begin
r := sqrt(sqr(x - xo) + sqr(y - yo));
SinCos(a + arctan2((y - yo), (x - xo)), s, c);
bm1.Canvas.Pixels[x,y] := bm.Canvas.Pixels[
round(xo + r * c), round(yo + r * s)];
end;
Application.ProcessMessages;
end;
Form1.Canvas.Draw(xo, yo, bm1);
a := a + 0.05;
Application.ProcessMessages;
until
Form1.Tag <> 0;
bm.Destroy;
bm1.Destroy;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Form1.Tag := 1;
end;
|
Вращение объектов.
Автор: Айткулов Павел WEB-сайт: http://rax.ru/click?apg67108864.narod.ru/
Здесь я бы хотел рассказать не о том, как работать с DelphiX, OpenGL или Direct, а о том, как можно вращать многогранники с помощью простых действий: moveto и lineto.
Здесь рассмотрим пример вращения куба. Будем рисовать на Canvase (например Listbox). Сначала нарисуем врашающийся квадрат (точнее 2 квадрата и соединим их). Пусть q - угол поворота квадрата, который мы рисуем. Очевидно, что нам надо задать координаты вершин квадрата - a:array [1..5,1..2] of integer. 1..4+1 - количество вершин квадрата (почему +1 будет объяснено позже). 1..2 - координата по X и Y. Кто учился в школе, наверное помнит, что уравнение окружности: X^2+Y^2=R^2, кто хорошо учился в школе, возможно вспомнит уравнение эллипса: (X^2)/(a^2)+ (Y^2)/(b^2)=1. Но это нам не надо. Нам понадобится уравнение эллипса в полярных координатах: x=a*sin(t); y=a*cos(t);t=0..2*PI; (учащиеся университетов и институтов ликуют).
С помощью данного уравнения мы заполняем массив с координатами.
for i:=1 to 5 do begin // координата по Х; q+i*pi/2 - угол поворота // i-той вершины квадрата. a[i,1]:=trunc(80*sin(q+i*pi/2)); // координата по Y; знак минус - потому что координаты // считаются с верхнего левого угла a[i,1]:=trunc(-30*cos(q+i*pi/2)); end; |
Сейчас будем рисовать квадрат:
for i:=1 to 4 do begin moveto(100+a[i,1],50+a[i,2]); //Встаем на i-ую точку квадрата. lineto(100+a[i+1,1],50+a[i+1,2]); //Рисуем линию к i+1-ой точке. |
Вот почему array[1..5,1..2], иначе - выход за границы. end;
Затем рисуем второй такой же квадрат, но пониже (или повыше). Соединяем линиями первый со вторым:
for i:=1 to 4 do begin moveto(100+a[i,1],50+a[i,2]); lineto(100+a[i,1],130+a[i,2]); end; |
Осталось очистить Listbox, увеличить q и сделать сначала. Все!!!
Можно также скрывать невидимые линии - когда q находится в определенном интервале. Также можно поизвращаться: повернуть куб в другой плоскости - поворот осей(для тех, кто знает формулу).
Вот что у нас получилось:
Исходник Готовая программаТакие же вращающиеся кубики (додекаэдр, икосаэдр и 3 других (не знаю названия)) находятся здесь.
Как вращать текст.
procedure TextOutAngle(x,y,aAngle,aSize: integer; txt: string);
var
hFont, Fontold: integer;
DC: hdc;
Fontname: string;
begin
if length(txt) = 0 then
Exit;
DC:= Screen.ActiveForm.Canvas.handle;
SetBkMode(DC, transparent);
Fontname:= Screen.ActiveForm.Canvas.Font.name;
hFont:= CreateFont(-aSize,0, aAngle*10,0, fw_normal,0, 0,
0,1,4,$10,2,4,PChar(Fontname));
Fontold:= SelectObject(DC, hFont);
TextOut(DC,x,y,PChar(txt), length(txt));
SelectObject(DC, Fontold);
DeleteObject(hFont);
end;
|
Как вращать текст 2.
{ Эта процедура устанавливает угол вывода текста
для указанного Canvas, угол в градусах
Шрифт должен быть TrueType }
procedure CanvasSetTextAngle(c: TCanvas; d: single);
var
LogRec: TLOGFONT; { Информация о шрифте }
begin
{Читаем текущюю инф. о шрифте }
GetObject(c.Font.Handle,SizeOf(LogRec) ,Addr(LogRec) );
{ Изменяем угол }
LogRec.lfEscapement := round(d*10);
{ Устанавливаем новые параметры }
c.Font.Handle := CreateFontIndirect(LogRec);
end;
|
Как вращать текст 3.
Для того чтобы вывести текст под углом, вытянуть или сжать его нужно воспользоваться структурой LOGFONT. Здесь показаны не все ее возможности, но, на мой взгляд, самые интересные.
procedure TForm1.FormPaint(Sender: TObject);
var
lf: TLogFont;
begin
FillChar(lf, SizeOf(lf), 0);
with lf do
begin
// Высота буквы
lfHeight := 15;
// Ширина буквы
lfWidth := 20;
// Угол наклона в десятых градуса
lfEscapement := 100;
// Жирность 0..1000, 0 - по умолчанию
lfWeight := 1000;
// Курсив
lfItalic := 0;
// Подчеркнут
lfUnderline := 1;
// Зачеркнут
lfStrikeOut := 1;
// CharSet
lfCharSet := RUSSIAN_CharSet;
// Название шрифта
StrCopy(lfFaceName, 'Arial');
end;
with Form1.Canvas do
begin
FillRect(ClipRect);
Font.Handle := CreateFontIndirect(lf);
TextOut(0, 100, 'It is a text string');
end;
end;
Рисование кнопок с кругленными краями.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
unit RVButton;
interface
uses
SysUtils, Classes, Controls, Messages, Graphics, Windows;
const
iOffset = 3;
type
TRVButton = class(TGraphicControl)
private
FCaption : string;
FButtonColor: TColor;
FLButtonDown: boolean;
FBtnPoints : array[1..2] of TPoint;
FKRgn : HRgn;
procedure SetCaption(Value: string);
procedure SetButtonColor(Value: TColor);
procedure FreeRegion;
protected
procedure Paint; override;
procedure DrawCircle;
procedure MoveButton;
procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property ButtonColor: TColor read FButtonColor write SetButtonColor;
property Caption: string read FCaption write SetCaption;
property Enabled;
property Font;
property ParentFont;
property ParentShowHint;
property ShowHint;
property Visible;
property OnClick;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Samples', [TRVButton]);
end;
{ TRVButton }
constructor TRVButton.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := [csClickEvents,csCaptureMouse];
Width := 50;
Height := 50;
FButtonColor := clBtnFace;
FKRgn := 0;
FLButtonDown := False;
end;
destructor TRVButton.Destroy;
begin
if FKRgn <> 0 then FreeRegion;
inherited Destroy;
end;
procedure TRVButton.DrawCircle;
begin
FBtnPoints[1] := Point(iOffset,iOffset);
FBtnPoints[2] := Point(Width - iOffset,Height - iOffset);
FKRgn := CreateEllipticRgn(FBtnPoints[1].x,FBtnPoints[1].y,FBtnPoints[2].x,FBtnPoints[2].y);
Canvas.Brush.Color := FButtonColor;
FillRgn(Canvas.Handle,FKRgn,Canvas.Brush.Handle);
MoveButton;
end;
procedure TRVButton.FreeRegion;
begin
if FKRgn <> 0 then DeleteObject(FKRgn);
FKRgn := 0;
end;
procedure TRVButton.MoveButton;
var
Color1: TColor;
Color2: TColor;
begin
with Canvas do
begin
if not FLButtonDown then
begin
Color1 := clBtnHighlight;
Color2 := clBtnShadow;
end
else
begin
Color1 := clBtnShadow;
Color2 := clBtnHighLight;
end;
Pen.Width := 1;
if FLButtonDown then Pen.Color := clBlack
else Pen.Color := Color2;
Ellipse(FBtnPoints[1].x - 2,FBtnPoints[1].y - 2,FBtnPoints[2].x + 2,FBtnPoints[2].y + 2);
if not FLButtonDown then Pen.Width := 2
else Pen.Width := 1;
Pen.Color := Color1;
Arc(FBtnPoints[1].x,FBtnPoints[1].y,FBtnPoints[2].x,FBtnPoints[2].y,
FBtnPoints[2].x,FBtnPoints[1].y,FBtnPoints[1].x,FBtnPoints[2].y);
Pen.Color := Color2;
Arc(FBtnPoints[1].x,FBtnPoints[1].y,FBtnPoints[2].x,FBtnPoints[2].y,
FBtnPoints[1].x,FBtnPoints[2].y,FBtnPoints[2].x,FBtnPoints[1].y);
end;
SetCaption('');
end;
procedure TRVButton.Paint;
begin
inherited Paint;
FreeRegion;
DrawCircle;
end;
procedure TRVButton.SetButtonColor(Value: TColor);
begin
if Value <> FButtonColor then
begin
FButtonColor := Value;
Invalidate;
end;
end;
procedure TRVButton.SetCaption(Value: string);
var
X: Integer;
Y: Integer;
begin
if ((Value <> FCaption) and (Value <> '')) then
begin
FCaption := Value;
end;
with Canvas.Font do
begin
Name := Font.Name;
Size := Font.Size;
Style := Font.Style;
if Self.Enabled then Color := Font.Color
else
Color := clDkGray;
end;
X := (Width div 2) - (Canvas.TextWidth(FCaption) div 2);
Y := (Height div 2) - (Canvas.TextHeight(FCaption) div 2);
Canvas.TextOut(X, Y, FCaption);
// Invalidate;
end;
procedure TRVButton.WMLButtonDown(var Message: TWMLButtonDown);
begin
if not PtInRegion(FKRgn,Message.xPos,Message.yPos) then exit;
FLButtonDown := True;
MoveButton;
inherited;
end;
procedure TRVButton.WMLButtonUp(var Message: TWMLButtonUp);
begin
if not FLButtonDown then exit;
FLButtonDown := False;
MoveButton;
inherited;
end;
end.
Элементы управления с закругленными краями.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
procedure MakeRounded(Control: TWinControl);
var
R: TRect;
Rgn: HRGN;
begin
with Control do
begin
R := ClientRect;
rgn := CreateRoundRectRgn(R.Left, R.Top, R.Right, R.Bottom, 20, 20);
Perform(EM_GETRECT, 0, lParam(@r));
InflateRect(r, - 5, - 5);
Perform(EM_SETRECTNP, 0, lParam(@r));
SetWindowRgn(Handle, rgn, True);
Invalidate;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
// TMemo:
Memo1.BorderStyle := bsNone;
MakeRounded(Memo1);
// TEdit:
Edit2.BorderStyle := bsNone;
MakeRounded(Edit2);
// TPanel:
MakeRounded(Panel1);
// TStaticText:
MakeRounded(StaticText1);
// TForm
Form1.BorderStyle := bsNone;
MakeRounded(Form1);
end;
Округление чисел до определенной степени.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
function Rounder(var Value: Double; Decimals: Integer): Double;
var
j: Integer;
A: Double;
begin
A := 1;
case Decimals of
0: A := 1;
1: A := 10;
else
for j := 1 to Decimals do
A := A * 10;
end;
Result := Int((Value * A) + 0.5) / A;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Value: Double;
begin
Value := 23.56784;
//Result is 23.57
label1.Caption := FloatToStr(Rounder(Value, 2));
end;
Округление денежного значения.
Автор: Сергей WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Округление денежного значения
Округление денежного значения
Зависимости: ???
Автор: Сергей, nfkazak@inbox.ru, Краснодар
Copyright: VIP BANK
Дата: 11 сентября 2002 г.
***************************************************** }
function RoundCurrency(value: currency): currency;
var
x, y: Double;
begin
x := int(value * 100);
y := Frac(value * 100);
if y >= 0.5 then
x := x + 1;
result := x / 100;
end;
Округление дробного числа до N знаков после запятой.
Автор: Perceptron.
function RoundEx(chislo: double; Precision: Integer): string;
var
ChisloInStr: string;
ChisloInCurr: currency;
begin
ChisloInCurr := chislo;
Str(ChisloInCurr: 20: Precision, ChisloInStr);
ChisloInStr[Pos('.', ChisloInStr)] := ',';
RoundEx := Trim(ChisloInStr);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Edit1.Text := RoundEx(StrToFloat(Edit1.Text), 2);
end;
Округление до ближайшего кратного.
Автор: Dimka Maslov WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> «Округление» до ближайшего кратного
Функция возвращает ближайшее к Value число, которое без
остатка делится на N. Если Value находится посередине
между двумя кратными, функция вернёт большее значение.
Зависимости: нет
Автор: Dimka Maslov, mainbox@endimus.ru, ICQ:148442121, Санкт-Петербург
Copyright: Dimka Maslov
Дата: 20 февраля 2003 г.
***************************************************** }
function RoundTo(Value, N: Integer): Integer;
asm
push ebx
mov ebx, eax
mov ecx, edx
cdq
idiv ecx
imul ecx
add ecx, eax
mov edx, ebx
sub ebx, eax
jg @@10
neg ebx
@@10:
sub edx, ecx
jg @@20
neg edx
@@20:
cmp ebx, edx
jl @@30
mov eax, ecx
@@30:
pop ebx
end;
Округление реальных типов.
| Автор: Steve Schafer |
| Компьютер позволяет решать все те проблемы, которые до изобретения компьютера не существовали |
Если вам необходимо округлить число, то наиболее общее решение выглядит следующим образом:
function RoundFloat(R: Extended; Decimals: Integer): Extended; var Factor: Extended; begin Factor := Int(Exp(Decimals * Ln(10))); Result := Round(Factor * R) / Factor; end; |
Округление времени.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
function RoundTime(ADate: string; Rounding: Integer; bRound: Boolean): string;
var
Year, Month, Day, Hour, Min, Sec, MSec: Word;
tmpDate: TDateTime;
Res, Diff: string;
M: integer;
begin
tmpDate := StrToDateTime(ADate);
DecodeTime(tmpDate, Hour, Min, Sec, MSec);
if (Rounding > 0) and (bRound = True) then
begin
if Min mod Rounding = 0 then
Res := IntToStr(Min)
else
Res := IntToStr(Round(Min / Rounding) * Rounding);
M := StrToInt(Copy(ADate, Length(ADate) - 1, 2));
Diff := IntToStr(StrToInt(Res) - M);
if Copy(Diff, 1, 1) = '-' then
begin
Diff := Copy(Diff, 2, Length(Diff) - 1);
Result := FormatDateTime('dd.mm.yy hh:mm', (tmpDate - StrToTime('00:00' + Diff)));
end
else
Result := FormatDateTime('dd.mm.yy hh:mm', (tmpDate + StrToTime('00:00' + Diff)));
end
else
Result := ADate;
end;
// Example:
procedure TForm1.Button1Click(Sender: TObject);
begin
Edit1.Text := FormatDateTime('dd.mm.yy hh:mm', Now);
Edit2.Text := RountTime(Edit1.Text, SpinEdit1.Value, Checkbox1.Checked);
// Example: RoundTime('07.08.02 10:41', '15', True) -- > 07.08.02 10:45
end;
Как показать округлённое окошко подсказки в Tray в Windows2000.
В Windows 2000, формат структуры NotifyIconData, которая используется для работы с иконками в Трее (которая, кстати, называется "The Taskbar Notification Area" :) значительно отличается от предыдущий версий Windows. Однако, эти изменения НЕ отражены в юните ShellAPI.pas в Delphi 5.Итак, нам понадобится преобразованный SHELLAPI.H, в котором присутствуют все необходимые объявления:
uses Windows;
type
NotifyIconData_50 = record // определенная в shellapi.h
cbSize: DWORD;
Wnd: HWND;
uID: UINT;
uFlags: UINT;
uCallbackMessage: UINT;
hIcon: HICON;
szTip: array[0..MAXCHAR] of AnsiChar;
dwState: DWORD;
dwStateMask: DWORD;
szInfo: array[0..MAXBYTE] of AnsiChar;
uTimeout: UINT; // union with uVersion: UINT;
szInfoTitle: array[0..63] of AnsiChar;
dwInfoFlags: DWORD;
end {record};
const
NIF_INFO = $00000010;
NIIF_NONE = $00000000;
NIIF_INFO = $00000001;
NIIF_WARNING = $00000002;
NIIF_ERROR = $00000003;
|
А это набор вспомогательных типов:
type
TBalloonTimeout = 10..30 {seconds};
TBalloonIconType = (bitNone, // нет иконки
bitInfo, // информационная иконка (синяя)
bitWarning, // иконка восклицания (ж¸лтая)
bitError); // иконка ошибки (краснаа)
|
Теперь мы готовы приступить к созданию округлённых подсказок! Для этого воспользуемся следующей функцией:
uses SysUtils, Windows, ShellAPI;
function DZBalloonTrayIcon(const Window: HWND; const IconID: Byte;
const Timeout: TBalloonTimeout; const BalloonText, BalloonTitle:
string; const BalloonIconType: TBalloonIconType): Boolean;
const
aBalloonIconTypes: array[TBalloonIconType] of
Byte = (NIIF_NONE, NIIF_INFO, NIIF_WARNING, NIIF_ERROR);
var
NID_50: NotifyIconData_50;
begin
FillChar(NID_50, SizeOf(NotifyIconData_50), 0);
with NID_50 do begin
cbSize := SizeOf(NotifyIconData_50);
Wnd := Window;
uID := IconID;
uFlags := NIF_INFO;
StrPCopy(szInfo, BalloonText);
uTimeout := Timeout * 1000;
StrPCopy(szInfoTitle, BalloonTitle);
dwInfoFlags := aBalloonIconTypes[BalloonIconType];
end; {with}
Result := Shell_NotifyIcon(NIM_MODIFY, @NID_50);
end;
|
DZBalloonTrayIcon(Form1.Handle, 1, 10, 'this is the balloon text', 'title', bitWarning);Иконка, должна быть предварительно добавлена с темже дескриптором окна и IconID (в данном примере Form1.Handle и 1). Можете попробовать все три типа иконок внутри всплывающей подсказки.
P.S. На всякий случай, ниже представлены функции для добавление/удаления иконок в трее:
uses SysUtils, Windows, ShellAPI;
{добавление иконки}
function DZAddTrayIcon(const Window: HWND; const IconID: Byte; const Icon:
HICON; const Hint: string = ''): Boolean;
var
NID: NotifyIconData;
begin
FillChar(NID, SizeOf(NotifyIconData), 0);
with NID do begin
cbSize := SizeOf(NotifyIconData);
Wnd := Window;
uID := IconID;
if Hint = '' then begin
uFlags := NIF_ICON;
end {if} else begin
uFlags := NIF_ICON or NIF_TIP;
StrPCopy(szTip, Hint);
end {else};
hIcon := Icon;
end {with};
Result := Shell_NotifyIcon(NIM_ADD, @NID);
end;
{добавляет иконку с call-back сообщением}
function DZAddTrayIconMsg(const Window: HWND; const IconID: Byte;
const Icon: HICON; const Msg: Cardinal; const Hint: string = ''): Boolean;
var
NID: NotifyIconData;
begin
FillChar(NID, SizeOf(NotifyIconData), 0);
with NID do begin
cbSize := SizeOf(NotifyIconData);
Wnd := Window;
uID := IconID;
if Hint = '' then begin
uFlags := NIF_ICON or NIF_MESSAGE;
end {if} else begin
uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP;
StrPCopy(szTip, Hint);
end {else};
uCallbackMessage := Msg;
hIcon := Icon;
end {with};
Result := Shell_NotifyIcon(NIM_ADD, @NID);
end;
{удаляет иконку}
function DZRemoveTrayIcon(const Window: HWND; const IconID: Byte): Boolean;
var
NID: NotifyIconData;
begin
FillChar(NID, SizeOf(NotifyIconData), 0);
with NID do begin
cbSize := SizeOf(NotifyIconData);
Wnd := Window;
uID := IconID;
end {with};
Result := Shell_NotifyIcon(NIM_DELETE, @NID);
end;
|
Несколько заключительных замечаний:
Нет необходимости использовать большую структуру NotifyIconData_50 для добавления или удаления иконок, старая добрая структура NotifyIconData прекрасно подойдёт для этого. Для callback сообщения можно использовать WM_APP + что-нибудь. Используя различные IconID, легко можно добавить несколько различных иконок из одного родительского окна и работать с ними по их IconID.Как округлять до сотых в большую сторону.
Автор: Vit WEB-сайт: http://forum.vingrad.ru
uses Math; // Прибавляешь 0.5 затем округляешь: function RoundMax(Num: real; prec: integer): real; begin result := roundto(num + Power(10, prec - 1) * 5, prec); end; // До сотых соответственно будет: function RoundMax100(Num: real): real; begin result := round(num * 100 + 0.5) / 100; end;
Механизм вызова удаленных процедур - RPC.
| Программист рассуждает: - Автостанция - место, где стоят автобусы. Лодочная станция - место, где стоят лодки. А у меня на столе - рабочая станция. |
Программы, общающиеся через сеть, нуждаются в механизме связи. На нижнем уровне по поступлении пакетов подается сигнал, обрабатываемый сетевой программой обработки сигналов. На верхнем уровне работает механизм rendezvous (рандеву), принятый в языке Ада. В NFS используется механизм вызова удаленных процедур (RPC), в котором клиент взаимодействует с сервером (см. Рисунок 1). В соответствии с этим процессом клиент сначала обращается к процедуре, посылающей запрос на сервер. По прибытии пакета с запросом сервер вызывает процедуру его вскрытия, выполняет запрашиваемую услугу, посылает ответ, и управление возвращается клиенту.
Интерфейс RPC можно представить состоящим из трех уровней:
Верхний уровень полностью "прозрачен". Программа этого уровня может, например, содержать обращение к процедуре rnusers(), возвращающей число пользователей на удаленной машине. Вам не нужно знать об использовании механизма RPC, поскольку вы делаете обращение в программе. Средний уровень предназначен для наиболее общих приложений. RPC-вызовами на этом уровне занимаются подпрограммы registerrpc() и callrpc(): registerrpc() получает общесис темный код, а callrpc() исполняет вызов удаленной процедуры. Вызов rnusers() реализуется с помощью этих двух подпрограмм. Нижний уровень используется для более сложных задач, изменяющих умолчания на значения параметров процедур. На этом уровне вы можете явно манипулировать гнездами, используемыми для передачи RPC-сообщений.Как правило, вам следует пользоваться верхним уровнем и избегать использования нижних уровней без особой необходимости.
Несмотря на то, что в данном руководстве мы рассматриваем интерфейс только на Си, обращение к удаленным процедурам может быть сделано из любого языка. Работа механизма RPC для организации взаимодействия между процессами на разных машинах не отличается от его работы на одной машине.
RPC (Remote Procedure Call, Сервис вызова удаленных процедур) представляет собой интерфейс между удаленными пользователями и определенными программами хоста, которые запускаются по запросам этих пользователей. Сервис RPC какого-либо хоста, как правило, предоставляет клиентам комплекс программ. Каждая из таких программ состоит, в свою очередь, из одной или нескольких удаленных процедур. Например, сервис удаленной файловой системы NFS, который построен на вызовах RPC, может состоять только из двух программ: например, одна программа взаимодействует с высокоуровневыми пользовательскими интерфейсами, а другая - с низкоуровневыми функциями ввода-вывода.
В каждом вызове удаленной процедуры участвуют две стороны: активный клиент, который отправляет запрос вызова процедуры на сервер, и сервер, который отправляет клиенту ответ.
Примечание. Следует иметь в виду, что термины "клиент" и "сервер" в данном случае относятся к определенной транзакции Конкретный хост или программное обеспечение (процесс или программа) могут работать как в роли клиента, так и в роли сервера. Например, программа, которая обеспечивает работу сервиса удаленных процедур, в то же время может быть клиентом в работе с сетевой файловой системой.
Протокол RPC построен на модели вызовов удаленных процедур, подобному механизму вызовов локальных процедур. При вызове локальной процедуры вы помещаете аргументы в определенное место памяти, в стек или переменные окружения и передаете управление процессом по определенному адресу. После завершения работы вы читаете результаты по конкретному адресу и продолжаете свой процесс.
В случае работы с удаленной процедурой, основное отличие состоит в том, что вызов удаленной функции обслуживают два процесса: клиентский процесс и серверный процесс.
Процесс клиента отправляет серверу сообщение, в которое включены параметры вызываемой процедуры и ожидает ответного сообщения с результатами ее работы. При получении ответа результат считывается, и процесс продолжает работу. Со стороны сервера процесс-обработчик вызовов находится в состоянии ожидания, и, при поступлении сообщения, считывает параметры процедуры, выполняет ее, отправляет ответ и становится в состояние ожидания следующего вызова.
RPC-протокол не накладывает каких-либо требований на дополнительные связи между процессами и не требует синхронности выполняемых функций, т. е. вызовы могут быть асинхронными и взамонезависимыми, так что клиент во время ожидания ответа может выполнять другие процедуры. Сервер RPC может выделять для каждой функции отдельный процесс или виртуальную машину, поэтому, не дожидаясь окончания работы предыдущих запросов, сразу же может принимать следующие.
Однако между вызовами локальных и удаленных процедур есть несколько важных отличий:
Обработка ошибок. Клиент в любом случае должен получать уведомление об ошибках, возникающих при вызовах удаленных процедур на сервере или в сети. Глобальные переменные. Поскольку сервер не имеет доступа к адресному пространству клиента, при вызовах удаленных процедур нельзя использовать скрытые параметры в виде глобальных переменных. Производительность. Скорость выполнения удаленных процедур, как правило на один или два порядка ниже скорости выполнения аналогичных локальных процедур. Аутентификация. Поскольку вызовы удаленных процедур происходят по сети, необходимо использовать механизмы аутентификации клиента.Принципы построения протокола.
Протокол RPC может использовать несколько различных транспортных протоколов. В обязанности RPC-протокола входит только обеспечение стандартов и интерпретация передачи сообщений. Достоверность и надежность передачи сообщений целиком обеспечивается транспортным уровнем.
Однако RPC может контролировать выбор и некоторые функции транспортного протокола. В качестве примера взаимодействия между RPC и транспортным протоколом рассмотрим процедуру назначения RPC-порта работы прикладного процесса через RPC - Portmapper.
Эта функция динамически (по запросу) назначает соединению RPC определенный порт. Функция Portmapper используется довольно часто, поскольку набор зарезервированных для RPC транспортных портов ограничен, а количество процессов, которые потенциально могут одновременно работать очень высоко. Portmapper, например, вызывается при выборе портов взаимодействия клиента и сервера системы NFS.
Сервис Portmapper использует механизм широковещательных сообщений RPC на определенный порт - III. На этот порт клиент отправляет широковещательное сообщение запроса порта определенного сервиса RPC. Сервис Portmapper обрабатывает таксе сообщение, определяет адрес локального сервиса RPC и отправляет клиенту ответ. Сервис RPC Portmapper может работать как с TCP, так и с UDP-протоколами.
RPC может работать с различными транспортными протоколами, но никогда не дублирует их функции, т. е. если RPC работает поверх TCP, все заботы о надежности и достоверности соединения RPC возлагает на TCP. Однако, если протокол RPC установлен поверх UDP, он может обеспечивать дополнительные собственные функции обеспечения гарантированной доставки сообщений.
Примечание. Прикладные задачи могут рассматривать RPC-протокол как определенную процедуру вызова функции по сети JSR (Jump Subroutine Instruction).
Для работы RPC-протокола необходимо выполнение следующих условий:
Уникальная идентификации всех удаленно вызываемых процедур на данном хосте. RPC-запросы содержат три поля идентификаторов - номер удаленной программы (сервиса), номер версии удаленной программы и номер удаленной процедуры указанной программы. Номер программы назначается производителем сервиса, номер процедуры указывает на конкретную функцию данного сервиса Идентификация версии RPC-протокола. RPC-сообщения содержат поле версии RPC-протокола. Она используется для согласования форматов передаваемых параметров при работе клиента с различными версиями RPC. Предоставление механизмов аутентификации клиента на сервере. RPC-протокол обеспечивает процедуру аутентификации клиента в сервисе, и, в случае необходимости, при каждом запросе или отправке ответа клиенту. Кроме того, RPC позволяет использовать различные дополнительные механизмы безопасности.RPC может использовать четыре типа механизмов аутентификации:
AUTH_NULL - без использования аутентификации AUTH_UNIX - аутентификация по стандарту UNIX AUTH_SHORT - аутентификация по стандарту UNIX с собственной структурой кодирования AUTH_DES - аутентификация по стандарту DES Идентификация сообщений ответа на соответствующие запросы. Ответные сообщения RPC содержат идентификатор запроса, на основании которого они были построены. Этот идентификатор можно назвать идентификатором транзакции вызова RPC. Данный механизм особенно необходим при работе в асинхронном режиме и при выполнении последовательности из нескольких RPC-вызовов. Идентификация ошибок работы протокола. Все сетевые или серверные ошибки имеют уникальные идентификаторы, по которым каждый из участников соединения может определить причину сбоя в работе.Структуры сообщений протокола
При передаче RPC-сообщений поверх транспортного протокола, несколько RPC-сообщений могут располагаться внутри одного транспортного пакета. Для того чтобы отделять одно сообщение от другого, используется маркер записи (RM - Record Marker). Каждое RPC-сообщение "маркируется" ровно одним RM.
RPC-сообщение может состоять из нескольких фрагментов. Каждый фрагмент состоит из четырех байт заголовка и (от 0 до 2**31-1) данных. Первый бит заголовка указывает, является ли данный фрагмент последним, а остальные 31 бит указывают длину пакета данных.
Структура RPC формально описана на языке описания и представления форматов данных - XDR с дополнениями, касающимися описания процедур. Можно даже сказать, что язык описания RPC является расширением XDR, дополненным работой с процедурами.
Структура RPC-пакета выглядит следующим образом:
struct rpc_msg {
unsigned int xid;
union switch (msg_type mtype) {
case CALL:
call_body cbody;
case REPLY:
reply body rbody;
} body;
};
|
Где.
xid - идентификатор текущей транзакции, call_body - пакет запроса, reply_body - пакет ответа.Структура запроса выглядит примерно так:
struct call body {
unsigned int rpcvers;
unsigned int prog;
unsigned int vers;
unsigned int proc;
opaque_auth cred;
opaque_auth verf;
/* procedure parameters */
};
|
Структура ответа (reply_body) может содержать либо структуру, передаваемую в случае ошибки (тогда она содержит код ошибки), либо структуру успешной обработки запроса (тогда она содержит возвращаемые данные).
Программный интерфейс высокого уровня.
Использование подпрограмм в программе - традиционный способ структурировать задачу, сделать ее более ясной. Наиболее часто используемые подпрограммы собираются в библиотеки, где могут использоваться различными программами. В данном случае речь идет о локальном (местном) вызове, т. е. и вызывающий, и вызываемый объекты работают в рамках одной программы на одном компьютере.
В случае удаленного вызова процесс, выполняющийся на одном компьютере, запускает процесс на удаленном компьютере (т. е. фактически запускает код процедуры на удаленном компьютере). Очевидно, что удаленный вызов процедуры существенным образом отличается от традиционного локального, однако с точки зрения программиста такие отличия практически отсутствуют, т. е. архитектура удаленного вызова процедуры позволяет сымитировать вызов локальной.
Однако если в случае локального вызова программа передает параметры в вызываемую процедуру и получает результат работы через стек или общие области памяти, то в случае удаленного вызова передача параметров превращается в передачу запроса по сети, а результат работы находится в пришедшем отклике.
Данный подход является возможной основой создания распределенных приложений, и хотя многие современные системы не используют этот механизм, основные концепции и термины во многих случаях сохраняются. При описании механизма RPC мы будем традиционно называть вызывающий процесс - клиентом, а удаленный процесс, реализующий процедуру, - сервером.
Удаленный вызов процедуры включает следующие шаги:
Программа-клиент производит локальный вызов процедуры, называемой заглушкой (stub). При этом клиенту "кажется", что, вызывая заглушку, он производит собственно вызов процедуры-сервера. И действительно, клиент передает заглушке необходимые параметры, а она возвращает результат. Однако дело обстоит не совсем так, как это себе представляет клиент. Задача заглушки - принять аргументы, предназначаемые удаленной процедуре, возможно, преобразовать их в некий стандартный формат и сформировать сетевой запрос. Упаковка аргументов и создание сетевого запроса называется сборкой (marshalling). Сетевой запрос пересылается по сети на удаленную систему. Для этого в заглушке используются соответствующие вызовы, например, рассмотренные в предыдущих разделах. Заметим, что при этом могут быть использованы различные транспортные протоколы, причем не только семейства TCP/IP. На удаленном хосте все происходит в обратном порядке. Заглушка сервера ожидает запрос и при получении извлекает параметры - аргументы вызова процедуры. Извлечение (unmarshalling) может включать необходимые преобразования (например, изменения порядка расположения байтов). Заглушка выполняет вызов настоящей процедуры-сервера, которой адресован запрос клиента, передавая ей полученные по сети аргументы. После выполнения процедуры управление возвращается в заглушку сервера, передавая ей требуемые параметры. Как и заглушка клиента; заглушка сервера преобразует возвращенные процедурой значения, формируя сетевое сообщение-отклик, который передается по сети системе, от которой пришел запрос. Операционная система передает полученное сообщение заглушке клиента, которая, после необходимого преобразования, передает значения (являющиеся значениями, возвращенными удаленной процедурой) клиенту, воспринимающему это как нормальный возврат из процедуры.Таким образом, с точки зрения клиента, он производит вызов удаленной процедуры, как он это сделал бы для локальной. То же самое можно сказать и о сервере: вызов процедуры происходит стандартным образом, некий объект (заглушка сервера) производит вызов локальной процедуры и получает возвращенные ею значения. Клиент воспринимает заглушку как вызываемую процедуру-сервер, а сервер принимает собственную заглушку за клиента.
Таким образом, заглушки составляют ядро системы RPC, отвечая за все аспекты формирования и передачи сообщений между клиентом и удаленным сервером (процедурой), хотя и клиент и сервер считают, что вызовы происходят локально. В этом-то и состоит основная концепция RPC - полностью спрятать распределенный (сетевой) характер взаимодействия в коде заглушек. Преимущества такого подхода очевидны: и клиент и сервер являются независимыми от сетевой реализации, оба они работают в рамках некой распределенной виртуальной машины, и вызовы процедур имеют стандартный интерфейс.
Передача параметров
Передача параметров-значений не вызывает особых трудностей. В этом случае заглушка клиента размещает значение параметра в сетевом запросе возможно, выполняя преобразования к стандартному виду (например, изменяя порядок следования байтов). Гораздо сложнее обстоит дело с передачей указателей, когда параметр представляет собой адрес данных, а не их значение. Передача в запросе адреса лишена смысла, так как удаленная процедура выполняется в совершенно другом адресном пространстве. Самым простым решением, применяемым в RPC, является запрет клиентам передавать параметры иначе, как по значению, хотя это, безусловно, накладывает серьезные ограничения.
Связывание (binding)
Прежде чем клиент сможет вызвать удаленную процедуру, необходимо связать его с удаленной системой, располагающей требуемым сервером. Таким образом, задача связывания распадается на две:
Нахождение удаленного хоста с требуемым сервером Нахождение требуемого серверного процесса на данном хостеДля нахождения хоста могут использоваться различные подходы. Возможный вариант - создание некоего централизованного справочника, в котором хосты анонсируют свои серверы, и где клиент при желании может выбрать подходящие для него хост и адрес процедуры.
Каждая процедура RPC однозначно определяется номером программы и процедуры. Номер программы определяет группу удаленных процедур, каждая из которых имеет собственный номер. Каждой программе также присваивается номер версии, так что при внесении в программу незначительных изменений (например, при добавлении процедуры) отсутствует необходимость менять ее номер. Обычно несколько функционально сход-ных процедур реализуются в одном программном модуле, который при запуске становится сервером этих процедур, и который идентифицируется номером программы.
Таким образом, когда клиент хочет вызвать удаленную процедуру, ему необходимо знать номера программы, версии и процедуры, предоставляющей требуемый сервис.
Для передачи запроса клиенту также необходимо знать сетевой адрес хоста и номер порта, связанный с программой-сервером, обеспечивающей требуемые процедуры. Для этого используется демон portmap(IM) (в некоторых системах он называется rpcbind(IM)). Демон запускается на хосте, который предоставляет сервис удаленных процедур, и использует общеизвестный номер порта. При инициализации процесса-сервера он регистрирует в portmap(IM) свои процедуры и номера портов. Теперь, когда клиенту требуется знать номер порта для вызова конкретной процедуры, он посылает запрос на сервер portmap(IM), который, в свою очередь, либо возвращает номер порта, либо перенаправляет запрос непосредственно серверу удаленной процедуры и после ее выполнения возвращает клиенту отклик. В любом случае, если требуемая процедура существует, клиент получает от сервера portmap(IM) номер порта процедуры, и дальнейшие запросы может делать уже непосредственно на этот порт.
Обработка особых ситуаций (exception)
Обработка особых ситуаций при вызове локальных процедур не представляет особой проблемы. UNIX обеспечивает обработку ошибок процессов таких как деление на ноль, обращение к недопустимой области памяти и т. д. В случае вызова удаленной процедуры вероятность возникновения ошибочных ситуаций увеличивается. К ошибкам сервера и заглушек добавляются ошибки, связанные, например, с получением ошибочного сетевого сообщения.
Например, при использовании UDP в качестве транспортного протокола производится повторная передача сообщений после определенного тайм-аута. Клиенту возвращается ошибка, если, спустя определенное число попыток, отклик от сервера так и не был получен. В случае, когда используется протокол TCP, клиенту возвращается ошибка, если сервер оборвал TCP-соединение.
Семантика вызова
Вызов локальной процедуры однозначно приводит к ее выполнению после чего управление возвращается в головную программу. Иначе дело обстоит при вызове удаленной процедуры. Невозможно установить, когда конкретно будет выполняться процедура, будет ли она выполнена вообще, а если будет, то какое число раз? Например, если запрос будет получен удаленной системой после аварийного завершения программы сервера, процедура не будет выполнена вообще. Если клиент при неполучении отклика после определенного промежутка времени (тайм-аута) повторно посылает запрос, то может создаться ситуация, когда отклик уже передается по сети, а повторный запрос вновь принимается на обработку удаленной процедурой. В этом случае процедура будет выполнена несколько раз.
Таким образом, выполнение удаленной процедуры можно характеризовать следующей семантикой:
Один и только один раз. Данного поведения (в некоторых случаях наиболее желательного) трудно требовать ввиду возможных аварий сервера. Максимум раз. Это означает, что процедура либо вообще не была выполнена, либо была выполнена только один раз. Подобное утверждение можно сделать при получении ошибки вместо нормального отклика. Хотя бы раз. Процедура наверняка была выполнена один раз, но возможно и больше. Для нормальной работы в такой ситуации удаленная процедура должна обладать свойством идемпотентности (от англ. idemponent). Этим свойством обладает процедура, многократное выполнение которой не вызывает кумулятивных изменений. Например, чтение файла идемпотентно, а добавление текста в файл - нет.Представление данных
Когда клиент и сервер выполняются в одной системе на одном компьютере, проблем с несовместимостью данных не возникает. И для клиента и для сервера данные в двоичном виде представляются одинаково. В случае удаленного вызова дело осложняется тем, что клиент и сервер могут выполняться на системах с различной архитектурой, имеющих различное представление данных (например, представление значения с плавающей точкой, порядок следования байтов и т. д.).
Большинство реализаций системы RPC определяют некоторые стандартные виды представления данных, к которым должны быть преобразованы все значения, передаваемые в запросах и откликах.
Например, формат представления данных в RPC фирмы Sun Microsystems следующий:
Порядок следования байтов - Старший - последний Представление значений с плавающей точкой - IEEE Представление символа - ASCIIСеть
По своей функциональности система RPC занимает промежуточное место между уровнем приложения и транспортным уровнем. В соответствии с моделью OSI этому положению соответствуют уровни представления и сеанса. Таким образом, RPC теоретически независим от реализации сети, в частности, от сетевых протоколов транспортного уровня.
Программные реализации системы, как правило, поддерживают один или два протокола. Например, система RPC разработки фирмы Sun Microsystems поддерживает передачу сообщений с использованием протоколов TCP и UDP. Выбор того или иного протокола зависит от требований приложения. Выбор протокола UDP оправдан для приложений, обладающих следующими характеристиками:
Вызываемые процедуры идемпотентны Размер передаваемых аргументов и возвращаемого результата меньше размера пакета UDP - 8 Кбайт. Сервер обеспечивает работу с несколькими сотнями клиентов. Поскольку при работе с протоколами TCP сервер вынужден поддерживать соединение с каждым из активных клиентов, это занимает значительную часть его ресурсов. Протокол UDP в этом отношении является менее ресурсоемкимС другой стороны, TCP обеспечивает эффективную работу приложений со следующими характеристиками:
Приложению требуется надежный протокол передачи Вызываемые процедуры неидемпонентны Размер аргументов или возвращаемого результата превышает 8 КбайтВыбор протокола обычно остается за клиентом, и система по-разному организует формирование и передачу сообщений. Так, при использовании протокола TCP, для которого передаваемые данные представляют собой поток байтов, необходимо отделить сообщения друг от друга. Для этого например, применяется протокол маркировки записей, описанный в RFC1057 "RPC: Remote Procedure Call Protocol specification version 2", при котором в начале каждого сообщения помещается 32-разрядное целое число, определяющее размер сообщения в байтах.
По-разному обстоит дело и с семантикой вызова. Например, если RPC выполняется с использованием ненадежного транспортного протокола (UDP), система выполняет повторную передачу сообщения через короткие промежутки времени (тайм-ауты). Если приложение-клиент не получает отклик, то с уверенностью можно сказать, что процедура была выполнена ноль или большее число раз. Если отклик был получен, приложение может сделать вывод, что процедура была выполнена хотя бы однажды. При использовании надежного транспортного протокола (TCP) в случае получения отклика можно сказать, что процедура была выполнена один раз. Если же отклик не получен, определенно сказать, что процедура выполнена не была, нельзяЗ.
Как это работает?
По существу, собственно система RPC является встроенной в программу-клиент и программу-сервер. Отрадно, что при разработке распределенных приложений, не придется вникать в подробности протокола RPC или программировать обработку сообщений. Система предполагает существование соответствующей среды разработки, которая значительно облегчает жизнь создателям прикладного программного обеспечения. Одним из ключевых моментов в RPC является то, что разработка распределенного приложения начинается с определения интерфейса объекта - формального описания функций сервера, сделанного на специальном языке. На основании этого интерфейса затем автоматически создаются заглушки клиента и сервера. Единственное, что необходимо сделать после этого, - написать фактический код процедуры.
В качестве примера рассмотрим RPC фирмы Sun Microsystems. Система состоит из трех основных частей:
rpcgen(1) - RPC-компилятор, который на основании описания интерфейса удаленной процедуры генерирует заглушки клиента и сервера в виде программ на языке С. Библиотека XDR (eXternal Data Representation), которая содержит функции для преобразования различных типов данных в машинно-независимый вид, позволяющий производить обмен информацией между разнородными системами. Библиотека модулей, обеспечивающих работу системы в целом.Рассмотрим пример простейшего распределенного приложения для ведения журнала событий. Клиент при запуске вызывает удаленную процедуру записи сообщения в файл журнала удаленного компьютера.
Для этого придется создать как минимум три файла: спецификацию интерфейсов удаленных процедур log.x (на языке описания интерфейса), собственно текст удаленных процедур log.c и текст головной программы клиента main ( ) - client.c (на языке С) .
Компилятор rpcgen(l) на основании спецификации log.x создает три файла: текст заглушек клиента и сервера на языке С (log clnt.c и log svc.c) и файл описаний log.h, используемый обеими заглушками.
Итак, рассмотрим исходные тексты программ.
log.x
В этом файле указываются регистрационные параметры удаленной процедуры - номера программы, версии и процедуры, а также определяется интерфейс вызова - входные аргументы и возвращаемые значения. Таким образом, определена процедура RLOG, в качестве аргумента принимающая строку (которая будет записана в журнал), а возвращаемое значение стандартно указывает на успешное или неудачное выполнение заказанной операции.
program LOG_PROG {
version LOG_VER {
int RLOG (string) = 1;
} = 1;
} = 0хЗ1234567;
|
Компилятор rpcgen(l) создает файл заголовков log.h, где, в частности, определены процедуры:
log.h
/* Please do not edit this file. It was generated using rpcgen. */ #ifndef _LOG_H_RPCGEN #define _LOG_H_RPCGEN #include <rpc/rpc.> /* Номер программы*/ #define LOG_PROG ((unsigned long) (0хЗ1234567)) #define LOG_VER ((unsigned long) (1)) /*Номер версии*/ #define RLOG ((unsigned long) (1)) /*Номер процедуры*/ extern int *rlog_l () ; /*Внутренняя процедура - нам ее использовать не придется*/ extern int log_prog_l_freeresult(); #endif /* !_LOG_H_RPCGEN */ |
Рассмотрим этот файл внимательно. Компилятор транслирует имя RLOG определенное в файле описания интерфейса, в rlog_1, заменяя прописные символы на строчные и добавляя номер версии программы с подчеркиванием. Тип возвращаемого значения изменился с int на int *. Таково правило - RPC позволяет передавать и получать только адреса объявленных при описании интерфейса параметров. Это же правило касается и передаваемой в качестве аргумента строки. Хотя из файла print.h это не следует, на самом деле в качестве аргумента функции rlog_l ( ) также передается адрес строки.
Помимо файла заголовков компилятор rpcgen(l) создает модули заглушки клиента и заглушки сервера. По существу, в тексте этих файлов заключен весь код удаленного вызова.
Заглушка сервера является головной программой, обрабатывающей все сетевое взаимодействие с клиентом (точнее, с его заглушкой). Для выполнения операции заглушка сервера производит локальный вызов функции, текст которой необходимо написать:
log.c
#include <rpc/rpc.>
#include <sys/types.>
#include <sys/stat.>
#include "log.h"
int *rlog_1 (char **arg)
{
/*Возвращаемое значение должно определяться как static*/
static int result;
int fd; /*Файловый дескриптор журнала*/
int len;
result = 1;
/*0ткроем файл журнала (создадим, если он не существует),
в случае неудачи вернем код ошибки result == 1.*/
if ((fd=open( "./server .log",
O_CREAT | O_RDWR | O_APPEND)) return (&result);
len = strlen(*arg);
if (write(fd, *arg, strlen(*arg)) != len)
result = 1;
else
result = 0;
close (fd);
return(&result); /*Возвращаем результат - адрес result*/
}
|
Заглушка клиента принимает аргумент, передаваемый удаленной процедуре, делает необходимые преобразования, формирует запрос на сервер portmap(1M), обменивается данными с сервером удаленной процедуры и, наконец, передает возвращаемое значение клиенту. Для клиента вызов удаленной процедуры сводится к вызову заглушки и ничем не отличается от обычного локального вызова.
Client.c.
#include <rpc/rpc.>
#include "log.h"
main(int argc, char *argv[])
{
CLIENT *cl;
char *server, *mystring, *clnttime;
time_t bintime;
int *result;
if (argc != 2) {
fprintf(stderr, "Формат вызова: %s Адрес_хоста\n",
argv [0]);
exit (1) ;
}
server = argv [1];
/*Получим дескриптор клиента. В случае неудачи - сообщим о
невозможности установления связи с сервером*/
if ( (с1 = clnt_create (server,
LOG_PROG, LOG_VER, "udp")) == NULL) {
clnt_pcreateerror (server);
exit (2);
}
/*Выделим буфер для строки*/
mystring = (char * )malloc (100);
/*Определим время события*/
bintime = time ((time_t * ) NULL);
clnttime = ctime(&bintime);
sprintf (mystring, "%s - Клиент запущен", clnttime);
/*Передадим сообщение для журнала - время начала работы клиента.
В случае неудачи - сообщим об ошибке*/
if ( (result = rlog_l(&mystring, cl)) == NULL) {
fprintf(stderr, "error2\n");
clnt_perror(cl, server);
exit(3);
}
/*B случае неудачи на удаленном компьютере сообщим об ошибке*/
if (*result !=0 )
fprintf(stderr, "Ошибка записи в журнал\n");
/*0свободим дескриптор*/
cint destroy(cl);
exit (0);
}
|
Заглушка клиента log_clnt.c компилируется с модулем client.c для получения исполняемой программы клиента.
cc -о rlog client.c log_clnt.c -Insl |
Заглушка сервера log_svc.c и процедура log.c компилируются для получения исполняемой программы сервера.
cc -о logger log_svc.c log.c -Insl |
Теперь на некотором хосте server.nowhere.ru необходимо запустить серверный процесс:
$ logger |
После чего при запуске клиента rlog на другой машине сервер добавит соответствующую запись в файл журнала.
Схема работы RPC в этом случае приведена на рис. 1. Модули взаимодействуют следующим образом:
Когда запускается серверный процесс, он создает сокет UDP и связывает любой локальный порт с этим сокетом. Далее сервер вызывает библиотечную функцию svc_register(3N) для регистрации номеров программы и ее версии. Для этого функция обращается к процессу portmap(IM) и передает требуемые значения. Сервер portmap(IM) обычно запускается при инициализации системы и связывается с некоторым общеизвестным портом. Теперь portmap(3N) знает номер порта для нашей программы и версии. Сервер же ожидает получения запроса. Заметим, что все описанные действия производятся заглушкой сервера, созданной компилятором rpcgen(IM). Когда запускается программа rlog, первое, что она делает, - вызывает библиотечную функцию clnt_create(3N), указывая ей адрес удаленной системы, номера программы и версии, а также транспортный протокол. Функция направляет запрос к серверу portmap(IM) удаленной системы server.nowhere.m и получает номер удаленного порта для сервера журнала. Клиент вызывает процедуру rlog_1 ( ) , определенную в заглушке клиента, и передает управление заглушке. Та, в свою очередь, формирует запрос (преобразуя аргументы в формат XDR) в виде пакета UDP и направляет его на удаленный порт, полученный от сервера portmap(IM). Затем она некоторое время ожидает отклика и в случае неполучения повторно отправляет запрос. При благоприятных обстоятельствах запрос принимается сервером logger (модулем заглушки сервера). Заглушка определяет, какая именно функция была вызвана (по номеру процедуры), и вызывает функцию rlog_1 ( ) модуля log.c. После возврата управления обратно в заглушку последняя преобразует возвращенное функцией rlog_1 ( ) значение в формат XDR, и формирует отклик также в виде пакета UDP. После получения отклика заглушка клиента извлекает возвращенное значение, преобразует его и возвращает в головную программу клиентаCOM технология.
Оформил: DeeCo
Из цикла "COM vs. CORBA" Автор: Чистяков В.Ю. Источник: «Технология Клиент-Сервер»CORBA – это концепция, разрабатываемая от стандарта к реализации большим количеством организаций. СОМ – частная концепция Microsoft, исходящая из потребностей прикладного программиста и оформляемая в законченный стандарт. По существу, COM является стандартом "де-факто", изложенным корпорацией Microsoft в нескольких спецификациях.
CORBA – это технология, базирующаяся на спецификациях, создаваемых путем всенародного обсуждения и выливающихся в формальный бумажный стандарт, на базе которого делаются физические реализации. CORBA предназначена для стандартизации одной области программирования – общих принципов построения брокеров объектных запросов, что подразумевает наличие неких серверов и технологий взаимодействия с ними.
СОМ – общая технология взаимодействия объектов стандартизующая как сами объекты, так и методы их взаимодействия. Это спецификация, строящаяся на базе эталонных реализаций.
И то, и другое – стандарты. Оба они, как стандарты, переносимы и независимы от платформы. Преимущество стандарта Microsoft в том, что он создается одной мощной компанией, являющейся крупнейшим игроком на конкурентном рынке программного обеспечения. Мiсгоsоft старается сделать универсальной и переносимой реализацию, выполненную для конкретных нужд. Для этого Microsoft использует другие открытые стандарты и участвует в работе стандартообразующих организаций, в том числе OMG. Следствием является то, что эталонная реализация сама по себе становится спецификацией. OMG принципиально не располагает такой возможностью. Отсутствие эталонных реализаций CORBA приводит к тому, что для физической совместимости ORB разных производителей необходимо производить отладку и вносить специфический код для каждого из них. СОМ же, позволяя производить отладку на эталонной реализации, гарантирует совместимость приложений разных разработчиков. Если бы OMG кроме стандарта создавала эталонную реализацию, Microsoft проигрывал бы по всем статьям. Но поскольку это не так, подход Microsoft производительнее и создает меньше конфликтных ситуаций.
При сравнении CORBA и COM на память приходит ситуация с IBM PC образца первой половины восьмидесятых. Большая и известная IBM, решив выйти на новый рынок, создала реализацию персонального компьютера. Это не было стандартом, это даже не воспринималось всерьез. Многие конкуренты в то время считали эту реализацию избыточной и обвиняли IBM в переносе своих суперкомпьютерных привычек на устройство, предназначенной для решения примитивных задач. В сравнении с серьезными по тем временам (например, UNIX-совместимыми) компьютерными платформами, IBM РС не представляла интереса в силу явной маломощности. Фирмы производители таких систем громко заявляли, что РС никогда не сможет решать серьезных задач. Но, поскольку IBM располагала огромными ресурсами и авторитетом, эта модель персонального компьютера быстро завоевала рынок, а открытость архитектуры породила огромное количество клонов и привела к тому, что IBM РС стала стандартом "де-факто". Забавно, что теперь появляются стандарты на физическую реализацию РС, например, РС-99, не имеющие никакого отношения к IBM, а выдвигаемые Microsoft, монополистом в области ОС.
Очень похожая ситуация складывается с COM. COM был создан в процессе разработки технологии OLE 2. Но замах при создании COM был куда больше, чем требовалось для спецификации OLE 2. COM разрабатывался, как архитектура взаиможействия между объектами, причем заранее предполагалось, что взаимодействующие объекты могут находиться как в одном процессе, так и в разных. Для первой стадии, OLE 2, достаточно было взаимодействия процессов на одном компьютере. Но COM изначально не был ограничен рамками одного компьютера. Идеология с самого начала строилась так, чтобы в дальнейшем гладко перейти к сетевому взаимодействию. Именно в этом, то есть в исходно локальной природе COM, и пытаются упрекнуть Microsoft его конкуренты. Эти заявления основаны на реальных фактах, но аппелируют к фактам, не относящимся к обсуждаемой проблеме. По большому счету, это демагогия. Посмотрите, насколько эти заявления похожи на обвинения, звучавшие в адрес IBM.
Очень часто в споре о превосходстве той или иной технологии начинаются безосновательные заявления, а зачастую и попыткам необоснованно унизить конкурирующую технологию и их создателей. Основным недостатком, приписываемым COM, обычно является его Мiсrоsоft'овское происхождение (в стиле Маздай95). Это простительно для компьютерной прессы, но неприемлемо для технологического диспута, который должен демонстрировать преимущества и недостатки каждой из технологий, как концептуальные, так и технические. Что же касается Microsoft, то, конечно, Microsoft близок к положению монополиста – но на уровне ОС и офисных приложений, а не в объектных технологиях. Здесь у него есть несколько серьезных конкурентов, в число которых, кстати, не входит OMG, но входят некоторые его участники (например, Sun).
То, что на рынке компонентных технологий распределенных вычислений имеется конкуренция, в нашем случае – COM и CORBA, приводит к повышению качества продуктов, что нам с вами исключительно на руку.
Конкуренция производителей CORBA-систем никак не влияет на качество самой спецификации. В это же время конкуренция COM, EJB и CORBA через рыночные механизмы приводит к тому, что Microsoft и Sun, как игроки конкурентного рынка, вынуждены совершенствовать свои технологии и форсировать выпуск своих продуктов на рынок. Если еще раз вспомнить ситуацию с IBM РС, то сейчас мы находимся где-то на уровне поколения 386 процессора. Именно тогда Compaq выпустил компьютер на базе этого процессора раньше, чем IBM. Соответственно, именно сейчас у Microsoft есть возможность либо сделать COM открытым стандартом, либо монополизировать его окончательно и бесповоротно. К счастью, сейчас события развиваются по первому сценарию. Создана организация OpenGroup, занимающаяся вопросами стандартизации COM и переносом его на другие платформы. Стоит заметить, что многие компании одновременно входят и в OMG, и в Open Group.
Многие (например, автор CORBA-раздела этой публикации) глубоко убеждены, что COM и CORBA – диаметрально противоположные вещи. Простой взгляд на реализации этих технологий показывает, что они очень похожи, предназначены для решения одних и тех же задач, и, более того, иногда для реализации поддержки одной технологии используется другая. Так, например, поддержка CORBA в Delphi реализована на базе COM, то есть, базовый CORBA-класс реализует интерфейс IDispatch со всеми вытекающими из этого последствиями. При этом CORBA-интерфейс по существу становится и COM-интерфейсом тоже. В тех же Delphi и C++ Builder существует замечательное средство Midas, позволяющее работать с БД в мноугоровневой среде. Хотя это средство и базируется на COM, транспортом для передачи курсоров по сети может служить метод любого CORBA-интерфейса. При этом данные из SAFEARRAY помещаются в тип Any из CORBA.
Стандарт CORBA 3 во многом описывает вещи, уже присутствующие в COM, например, поддержку нескольких интерфейсов одним объектом. Судя по произведению Inprise (VisiBrocker), одинаковы у них и скоростные характеристики. Так что в COM и CORBA больше похожего, чем различий.
Что такое COMCOM является платформно-независимой, объектно-ориентированной технологией, позволяющей создавать бинарные компоненты. Эти компоненты можно использовать как локально, так и в распределенном сетевом окружении. COM служит основой для: OLE (технология составных документов), ActiveX-объектов и элементов управления ActiveX, DCOM, COM+.
На базе COM создано большинство новейших продуктов (MS Office, MTS, …) и технологий Windows (Automation, Drag & Drop, ...).
Целью этой статьи является сравнение COM и Corba, и, так как Corba на сегодня является технологией используемой, в основном, для организации распределенных вычислений, то и COM мы будем рассматривать с тех же позиций. Поэтому по умолчанию под «COM» будет подразумеваться DCOM и COM+.
DCOM (Distributed COM) – это расширение COM, делающее эту модель распределенной, то есть позволяющей вызывать COM-объекты, находящиеся на другом компьютере в сети.
MTS (Microsoft Transaction Server) – это сервер приложений позволяющий создавать распределенные приложения, поддерживающие транзакции. Вопреки распространенному мнению, хотя слово «транзакция» входит в название этого сервера, приложения создаваемые на базе MTS совершенно не обязаны использовать предоставляемый механизм транзакций.
COM+ – это эволюция COM и MTS. COM+ полностью встроен в Windows 2000. Он существенно расширяет возможности своих предшественников. COM+ обратно совместим с DCOM, MTS и COM, и позволяет создавать распределенные приложения, клиентские части которых можно запускать на старых ОС (Windows 9x и Windows NT).
COM – это технология, позволяющая объектам взаимодействовать, несмотря на границы процесса или машины, так же легко, как и объектам внутри одного процесса. COM обеспечивает такое взаимодействие, определяя, что единственный путь управления данными, ассоциированными с объектом, лежит через интерфейс объекта. Термин «интерфейс», о котором речь пойдет чуть ниже, означает реализацию в коде COM-совместимого двоичного интерфейса, ассоциированного с объектом.
COM-объектCOM-объект можно сравнить с объектом в понимании С++, VB или Java. Объект СОМ – это некоторая сущность, имеющая состояние и методы доступа, позволяющие изменять это состояние. СОМ-объекты можно создавать прямым вызовом специальных функций, но напрямую уничтожить его невозможно. Вместо прямого уничтожения используется механизм самоуничтожения, основанный на подсчете ссылок. Самым близким аналогом в объектно-ориентированных языках программирования является понятие объекта в языке Java.
Так, в COM присутствует понятие класса. Класс в COM носит название CoClass.
CoClassCoClass – это класс, поддерживающий набор методов и свойств (один или более), с помощью которых можно взаимодействовать с объектами этого класса. Такой набор методов и свойств называется интерфейсом (Interface).
Каждый CoClass имеет два идентификатора – один из них, текстовый, называется ProgID и предназначен для человека, а второй, бинарный, называется CLSID.
CLSID является глобально уникальным идентификатором (GUID). GUID имеет размер 128 бит и уникален в пространстве и времени. Его уникальность достигается путем внедрения в него информации об уникальных частях компьютера, на котором он был создан, таких, как номер сетевой карты, и времени создания с точностью до миллисекунд. Эта технология, как и большинство других базовых концепций в СОМ, позаимствована из OSF DCE RPC. С помощью CLSID можно точно указать, какой именно объект требуется. Тип данных GUID применяется и для идентификации COM-интерфейсов. В этом случае он называется IID. Сгенерировать новое значение типа GUID можно с помощью API-функции Win32 CoCreateGuid. На практике использовать эту функцию приходится не часто, так как современные средства разработки полностью автоматизируют эту задачу, а VB вообще скрывает от программиста такие тонкости, как работу с CLSID и IID.
Для создания экземпляра объекта используется CLSID. Если имеется только ProgID CoClass’а или CLSID в строковом виде ("{XXXXXXXX-XXXX-XXXX-XXXX-XXXXXXXXXXXX} ", где X – шестнадцатеричная цифра), то CLSID можно получить, вызвав функцию CLSIDFromString. Для случая с ProgID информация о CoClass’е должна содержаться в реестре машины, на которой производится вызов функции. В реестр информация заносится автоматически при регистрации объекта (во время процедуры инсталляции или при компиляции).
Перевести CLSID, IID или любой другой GUID в строку можно с помощью функции StringFromGUID2. Как уже говорилось выше, практически все необходимые GUID генерируются автоматически, но при необходимости можно сгенерировать GUID вручную, с помощью утилиты guidgen.
Программист никогда не взаимодействует с объектом и его данными напрямую. Для этого используются интерфейсы объектов.
СОМ-интерфейсCOM проводит фундаментальное различие между определением интерфейса и его реализацией. Это свойство СОМ аналогично подходам, принятым в OSF DCE RPC и CORBA. По степени абстракции СОМ ближе к первому из них, так как CORBA менее требовательна к неизменности и уникальности интерфейсов во времени и пространстве.
В понимании СОМ интерфейс – это контракт, состоящий из списка связанных прототипов функций, чье назначение определено, а реализация – нет. Эти прототипы функций эквивалентны абстрактным базовым классам С++, то есть классам, имеющим только виртуальные методы, описания без реализации. Определение интерфейса описывает функции-члены интерфейса, называемые методами, типы их возвращаемого значения, число и типы их параметров, а также описывает, что они, собственно, должны делать. Напрямую с интерфейсом не ассоциировано никакой реализации.
Реализация интерфейса (interface implementation) – это код, который программист создает для выполнения действий, оговоренных в определении интерфейса. Реализации интерфейсов, помещенные в COM-библиотеки или exe-модули, могут использоваться при создании объектно-ориентированных приложений. Разумеется, программист может игнорировать эти реализации и создать собственные. Интерфейсы ассоциируются с CoClass’ами. Чтобы воспользоваться реализацией функциональности интерфейса, нужно создать экземпляр объекта соответствующего класса, и запросить у этого объекта ссылку на соответствующий интерфейс.
Например, для описания взаимодействия с некоторым абстрактным стеком можно определить интерфейс IStack (в COM стало доброй традицией начинать названия интерфейсов с «I»). Этот интерфейс может содержать два метода, скажем, Push и Pop. Вызов метода Pop возвращает значения, заложенные до этого методом Push в стек, но в обратном порядке. Это определение интерфейса не говорит, как функции будут реализованы в коде. Один программист может реализовать стек как массив, а методы Push и Pop – как методы доступа к этому массиву. Другому же взбредет в голову использовать связанный список и соответствующую реализацию методов. Независимо от конкретной реализации методов, представление в памяти указателя на интерфейс IStack, и, соответственно, его использование клиентом полностью специфицируется определением интерфейса.
Простые объекты могут поддерживать только один интерфейс. Более сложные объекты, как правило, поддерживают несколько интерфейсов. Это свойство позволяет реализовать полиморфизм на уровне компонентной модели.
Слово «интерфейс» используется в COM не в том смысле, что в С++. Интерфейс в С++ ссылается на все функции, поддерживаемые классом. COM-интерфейс ссылается на предварительно оговоренную группу связанных функций, реализуемых COM-классом, но не обязательно на ВСЕ функции, поддерживаемые классом.
В CORBA на сегодня не реализована поддержка множества интерфейсов одним объектом. Это приводит к тому, что CORBA-интерфейс практически определяет класс объекта. СОМ же, наоборот, поддерживает реализацию нескольких интерфейсов в одном объекте, и поэтому требует отдельного определения класса объекта (см. "CoClass"). В третьей версии спецификации CORBA должна появиться поддержка множества интерфейсов для одного объекта, что должно еще больше сблизить эти технологии.
Java-программистам концепция СОМ-интерфейсов будет понятна сразу, без объяснений – в Java интерфейсы выглядят точно так же, как в COM.
Для описания интерфейсов в COM, как и в CORBA, применяется язык IDL. В отличие от CORBA использование IDL не обязательно (СОМ является практически бинарным стандартом).
MIDLДля описания COM-интерфейсов используется MIDL (MS Interface Definition Language). При создании COM-объектов на C++ использование MIDL является стандартной практикой. Некоторые среды программирования (Delphi, VB) обходятся без MIDL. Delphi имеет свой, Паскале-подобный синтаксис, а в VB любой класс априори является COM-объектом и дополнительное описание не требуется. MIDL является развитием OSF DCE IDL и имеет обратную совместимость с ним.
Как видно из примера, MIDL-описание очень похоже на C++. Главные отличия MIDL от C++ в том, что MIDL позволяет задать только описание интерфейса, и в том, что MIDL содержит дополнительные атрибуты, помещаемые в квадратные скобки. Самым главным атрибутом интерфейса является uuid. Он задает IID интерфейса.
Ниже приведен пример описания интерфейса на MIDL.
[
uuid(F3792A83-69C9-11D2-AC8C-525400DDA17A),
helpstring("Этот интерфейс определяет методы работы со стеком.")
]
interface IStack : IUnknown
{
HRESULT Push([in] VARIANT Val);
HRESULT Pop([out, retval] VARIANT *pVal);
}
Экземпляр «реализации интерфейса» на самом деле является указателем на массив указателей на методы (таблицу функций, ссылающуюся на реализации всех методов, определенных в интерфейсе, также называемую виртуальной таблицей – VTbl). Объекты с несколькими интерфейсами могут предоставлять указатели на несколько таблиц функций. Любой код, содержащий указатель, через который он имеет доступ к массиву, может вызывать методы этого интерфейса.
Все это очень длинно и косноязычно, так что указатель на таблицу функций интерфейса, который должен иметь другой объект для вызовов методов этого интерфейса, называют просто указателем на интерфейс. Можно создать таблицы функций на С вручную, или почти автоматически на С++ и других объектно-ориентированных языках. Некоторые языки программирования (например, VB) имеют специальные синтаксические расширения, позволяющие сделать этот процесс простым и наглядным.
Если компилятор позволяет (что типично для С/С++), клиент может вызвать метод интерфейса по имени, а не позиции в массиве. Поскольку интерфейс – это тип, зная имена методов, компилятор может проверить типы параметров и возвращаемого значения каждого из методов интерфейса. Напротив, такая проверка типов недоступна даже в С/С++, если клиент использует схему вызова по позиции. К счастью, все современные средства разработки (C++, VB, Delphi, Java, ...) позволяют вызывать методы интерфейсов по имени. Вызов методов интерфейсов по позиции может понадобиться только при формировании COM-вызова, что называется, на лету. Естественно, в повседневной работе прикладного программиста такое практически не случается. На практике для реализации динамического связывания используется специальный интерфейс IDispatch, но о нем речь пойдет позже (в разделе «Динамическое связывание»).
Интерфейс имеет свое имя. Как мы уже говорили, каждый интерфейс – это неизменяемый контракт, во время исполнения определяемый по глобально уникальному идентификатору интерфейса, IID. IID, это особая разновидность GUID, позволяет клиентам точно и без ненужных сложностей, узнать у объекта, поддерживает ли он некоторый интерфейс. Идентификация интерфейсов по IID решает проблему неуникальности имен интерфейсов. Это необходимо, поскольку разработка COM-объектов ведется одновременно во всех частях света, и никто не гарантирует, что объекты с одноименными, но разными интерфейсами не встретятся в один прекрасный момент на каком-нибудь компьютере.
В COM нет нужды в том, что в Corba называется строковым связыванием или объектной ссылкой, записанной в строку. В отличие от CORBA-объектов, объекты COM не живут после смерти. Поэтому ссылки нужно получать только на загруженный в память экземпляр объекта (вернее на один из его интерфейсов). Получить ссылку на объект можно, попросту создав его, или запросив эту ссылку у другого объекта. Есть некоторые особенности при передаче указателей на интерфейс другому потоку того же приложения. Эта тема рассматривается в разделе "Управление потоками".
Интересной задачей является определение того, указывают ли два указателя на интерфейсы разных объектов или одного и того же . Сделать это очень просто. Надо запросить от каждого из них указатель на IUnknown (см. ниже) и просто сравнить их. Если они равны, значит, они получены от одного и того же объекта. Это верно даже в случае, если указатели получались через дюжину компьютеров, а сам объект находится на другой стороне земного шара. Не меняет этого правила даже то, что объект был получен агрегированием и на самом деле создан из нескольких других. Главное, чтобы указатели на интерфейс были получены легальными путями.
IUnknown и наследование интерфейсовНаследование в COM не означает повторного использования кода, как это обычно бывает в объектно-ориентированных языках программирования. Оно означает только, что ассоциированный с интерфейсом контракт наследуется в манере чисто виртуального базового класса С++ и изменяется добавлением новых методов или дальнейшим уточнением допустимого использования методов. В COM отсутствует избирательное наследование. Если один интерфейс наследует от другого, он включает все методы, определяемые другим интерфейсом.
Наследование в стандартных COM-интерфейсах используется довольно скупо. Все интерфейсы должны быть унаследованы от интерфейса IUnknown. IUnknown содержит три жизненно важных для COM метода: QueryInterface, AddRef и Release. Все COM-объекты должны реализовать интерфейс IUnknown, поскольку он обеспечивает возможность получать поддерживаемые объектом интерфейсы с помощью QueryInterface, и управлять сроком жизни объекта через AddRef и Release.
Высокоуровневые средства разработки (такие, как VB) полностью скрывают реализацию IUnknown, облегчая тем самым работу программиста. Низкоуровневые средства разработки (например, VC++) напротив, дают полный доступ к исходным текстам, реализующим IUnknown. На C++ или Delphi можно самостоятельно реализовать IUnknown. Но проще воспользоваться стандартными реализациями. Для C++ самый удобный, но в тоже время гибкий и очень компактный способ реализации IUnknown – воспользоваться библиотекой ATL (Active Template Library). ATL – это библиотека, главным образом состоящая из набора шаблонов C++. ATL упрощает работу с COM, предоставляя реализации для многих стандартных интерфейсов. Эта библиотека входит в поставку MS VC++ и Borland C++ Builder. В сочетании с визуальными средствами разработки этих сред ATL позволяет очень быстро создавать сложные приложения, базирующиеся на COM.
Экземпляр СОМ-объектаЧтобы воспользоваться функциональностью COM-объекта, нужно создать его экземпляр (instance).
Экземпляр COM-объекта аналогичен объекту в C++ или VB, за тем исключением, что он может быть создан в другом процессе или на другом компьютере.
Для создания экземпляра COM-объекта на C++ применяются функции CoCreateInstance, CoCreateInstanceEx, CoGetObject, CoGetClassObject, CoGetInstanceFromFile, CoGetInstanceFromIStorage, OleLoadFromStream и некоторые другие, всех и не упомнишь. На VB все немного проще. Там есть две универсальные функции, CreateObject и GetObject, и оператор new. Все объекты VB являются COM-объектами.
Чаще всего применяются функции CoCreateInstance, CoCreateInstanceEx, CreateObject и оператор new .
Чтобы создать экземпляр объекта с помощью CoCreateInstance, этой функции необходимо передать: CLSID требуемого объекта, контекст создаваемого объекта, IID требующегося интерфейса, и указатель, в который и будет возвращен указатель на интерфейс созданного объекта.
Контекст создаваемого объекта – это информация о том, где должен создаваться объект: в том же процессе (адресном пространстве EXE-модуля), в другом процессе того же компьютера, на удаленном сервере, или как локальная заглушка для удаленного объекта.
У этой функции есть еще один параметр, pUnkOuter, предназначенный для агрегации объектов, но об этом речь пойдет в разделе "Агрегация".
Функция CoCreateInstance была создана на заре существования COM-модели и предназначена для локального COM. Она не позволяет создавать объекты на конкретном удаленном сервере, вместо этого она берет информацию о сервере из реестра. Информацию о местонахождении сервера и атрибуты защиты можно настроить с помощью утилиты DCOMCNFG или средств администрирования MTS или COM+. К недостаткам CoCreateInstance можно отнести также то, что при ее использовании нет возможности задать учетную запись (и пароль), от имени которой будет создаваться объект, и то, что она позволяет получить указатель только на один интерфейс создаваемого объекта. Для локально создаваемого объекта эти ограничения не существенны – атрибуты защиты при этом не работают (имеется прямой доступ к объекту), а указатель на другой интерфейс можно молниеносно получить с помощью вызова метода IUnknown::QueryInterface (ведь по принципам COM любой COM-интерфейс должен быть унаследован от IUnknown). Вызов же QueryInterface у удаленного объекта приводит к передаче данных по сети, что значительно медленней локального вызова.
Всех этих недостатков лишена новая версия этой функции – CoCreateInstanceEx.
Остальные функции позволяют создать объект, загрузив его состояние из разных источников (OleLoadFromStream, CoGetInstanceFromFile, CoGetInstanceFromIStorage), или создать объект с помощью моникера и строки параметра (CoGetObject).
Моникер – это COM-объект, умеющий создавать другой объект. ОС сама (по префиксу в строковом параметре) находит необходимый моникер, тот в свою очередь создает необходимый объект там, где ему необходимо, и возвращает указатель на интерфейс созданного объекта.
С некоторой натяжкой можно сказать, что моникер – это аналог Службы имен в CORBA, по существу, он позволяет получать указатель на интерфейс конкретного экземпляра объекта по строковому параметру.
Создание моникера – задача сложная, и по плечу она не каждому. Спасает то, что имеется много стандартных реализаций моникеров. Так, через них делается связывание документов в OLE, создание Queued-объектов (асинхронно работающих объектов повышенной надежности, о них речь пойдет дальше), и получение указателей на WMI-объекты, интерфейс новой технологии Windows 2000 – Active Directory. Существует интересная разновидность моникеров – URL-моникеры, которые позволяют получить указатель на объект, основываясь на URL.
Экземпляр СОМ-объекта можно сравнить с экземпляром CORBA-объекта, сопоставленного с конкретным сервантом. Его, однако, нельзя сравнивать с экземпляром CORBA-объекта, так как последний может виртуально существовать после смерти его серванта и воскреснуть в новом облике с другим сервантом.
Инициализация и сохранение объектовCOM-объекты не имеют конструкторов, привычных для объектно-ориентированных языков программирования. Вместо этого можно инициализировать объекты (или загружать в них заранее сохраненное состояние) с помощью стандартных IPersistXXX COM-интерфейсов. Вот список этих интерфейсов: IPersistStream, IPersistStreamInit, IPersistStorage, IPersistFile, IPersistMemory, IPersistPropertyBag. Всех их объединяет то, что они унаследованы от интерфейса IPersist, а назначение каждого понятно из его названия. Хотелось бы обратить внимание на два интерфейса – IPersistStreamInit и IPersistPropertyBag. Первый имеет метод InitNew, предназначенный для инициализации новых объектов, а второй позволяет сохранять информацию в виде читабельного текста. IE и VB используют эти интерфейсы для сохранения и загрузки состояния элементов управления ActiveX, встроенных в html-странички и в VB-формы. Эти интерфейсы можно использовать и для сохранения/загрузки объектов в БД на удаленном сервере или для передачи COM-объектов через параметры методов удаленных объектов по значению (в CORBA аналогичная возможность носит название ValueType).
Сервер и клиентВ отличие от интерфейса, COM-объект – это не абстракция, и его код должен где-то храниться. Можно, конечно, создавать и использовать COM-объекты в одном исполняемом файле, но значительно интересней помещать COM-объекты в независимые модули. COM позволяет помещать COM-объекты в DLL- или EXE-модули и подгружать их при необходимости. Причем программисту даже не надо следить за подгрузкой необходимых модулей. За него это делает COM. Программист просто говорит, что ему надо загрузить некоторый объект, а COM лезет в реестр той машины, на которой надо создать объект, берет оттуда нужную информацию, загружает необходимый модуль (если он еще не загружен), создает объект и возвращает ссылку на него.
Загруженный процесс, в котором создан объект, и называется сервером. Процесс же, в который передается указатель на интерфейс, и из которого будут производиться вызовы, называется клиентом. В сущности, это может быть один и тот же процесс.
Здесь есть одна тонкость. Как известно, новый процесс создается только при загрузке EXE-модуля, а DLL грузится в адресное пространство того процесса, в котором требуется его функциональность. Значит, компоненты, помещенные в DLL-модули, не могут создаваться удаленно. Это именно так, но не все так плохо... Если создать COM-объект в одном процессе, то ничто ни мешает передать указатель на его интерфейс в другой процесс. Это достигается реализацией одного COM-объекта как EXE-сервера. У этого объекта создается метод, который получает на вход CLSID объекта (объект должен быть зарегистрирован на той же машине, где создан первый COM-объект) и IID интерфейса (который изначально требуется от второго объекта). Ему же нужно передать указатель, через который будет возвращен интерфейс создаваемого объекта. В общем, метод первого объекта должен походить на функцию CoCreateInstance. Вызывая этот метод, можно удаленно создавать объекты, расположенные в DLL-модулях на другом компьютере. Процесс, в который загружается DLL на удаленном компьютере, называется суррогатным процессом. Можно даже скрыть все эти ухищрения от программиста, специальным образом зарегистрировав объект на вызывающей машине.
Именно это и сделано в MTS и COM+, причем так искусно, что создание объекта таким образом ничем не отличается от создания объектов традиционным для DCOM образом.
Более того, MTS и, особенно, COM+ предоставляют множество дополнительных функций и упрощают создание и внедрение распределенных приложений.
Подсчет ссылокДля каждой реализации интерфейса ведется подсчет ссылок (Reference counting). Любой код, который хочет хранить указатель (ссылку) на интерфейс, должен увеличить счетчик ссылок этого интерфейса. Сделать это можно, вызвав у интерфейса метод AddRef (Помните? Каждый COM-интерфейс унаследован от IUnknown.). Пока у объекта счетчик ссылок не равен нулю, этот объект не будет уничтожен. Чтобы уменьшить счетчик, надо вызвать метод Release того же интерфейса. COM-объект жив, пока хотя бы у одного интерфейса счетчик ссылок больше нуля. Обычно сразу после создания объекта имеется только один указатель на его интерфейс со счетчиком ссылок, установленным в единицу. Так что, если в этот момент вызвать у его интерфейса метод Release, объект автоматически уничтожится.
Есть строгие правила, описывающие, когда и кому надо вызывать AddRef и Release. Эти правила описаны в спецификации COM. Самым главным правилом является то, что если какая-нибудь функция возвращает указатель на интерфейс, то она должна увеличивать счетчик ссылок этого интерфейса. Этому правилу подчиняются даже CoCreateInstance и QueryInterface. Если же указатель передается в функцию, и ей не надо сохранять его для использования после выхода из этой функции, то она может не увеличивать счетчик ссылок на этот интерфейс.
Подсчет ссылок позволяет эффективно управлять временем жизни COM-объекта в распределенной среде. Счетчик ссылок необходим еще и потому, что СОМ является компонентной моделью, в которой компоненты могут параллельно использоваться любым количеством других компонентов. Если в такой среде применять физическое удаление, такая система не бужет жизнеспособна из-за невозможности обеспечения правильного срока жизни объектов. Единственная альтернатива – сохранение объекта в живых до завершения работы сервера. При таком подходе, во-первых, пришлось бы управлять сроком жизни самого сервера, а во-вторых, это привело бы к перерасходу бесценных системных ресурсов.
В распределенных системах DCOM берет на себя управление подсчетом ссылок на удаленные объекты. Даже если клиент потерпит крах и не сможет самостоятельно освободить сделанные им ссылки, DCOM через некоторое время сделает это за него. Чтобы избежать чрезмерной услужливости DCOM, proxy объектов, создаваемые тем же DCOM, регулярно сообщают о своем существовании, производя так называемый ping. Однако есть две проблемы, которые портят радужную картину.
Первая – это то, что если следить за ссылками вручную, довольно-таки просто ошибиться и забыть сделать AddRef или Release. Лишний AddRef приведет к тому, что объект не освободится до закрытия клиентского приложения. Лишний Release приведет к появлению неверных указателей в клиентском приложении, что, в свою очередь, приводит к его краху. Как уже говорилось, сетевым подсчетом ссылок занимается сам DCOM, и проблема со ссылками в клиентском приложении не может повлиять на работоспособность сервера. В некоторых языках проблема подсчета ссылок в клиентском приложении решена путем встраивания механизма автоматического подсчета ссылок в сам язык. Так сделано в VB и Delphi. А в C++ эта проблема может быть решена средствами самого языка. Для ее решения используются три свойства языка.
Автоматический вызов деструктора при уничтожении переменных. Автоматическое уничтожение стековых переменных. Поддержка шаблонов. Используя две предыдущие возможности, можно создать классы-обертки для интерфейсов, которые автоматически вызывают Release при своем уничтожении. Но такую обертку пришлось бы писать для каждого интерфейса. Шаблоны позволяют написать одну реализацию такого класса-обертки, а компилятор сам создаст реализацию для каждого интерфейса.В сочетании с перегружаемыми операторами классы-обертки практически полностью снимают проблему подсчета ссылок в C++. Лучшей реализацией такого класса-обертки является шаблон CComPtr<*> из библиотеки ATL. Переменная, созданная на базе такого класса-обертки, называется Smart Pointer, то есть «умный указатель». Объявив вместо простого указателя на интерфейс (например, IStak * pIStak) Smart Pointer, (CComPtr<IStak> * spIStak), можно не заботится о правильности подсчета ссылок.
Вторая проблема – это то, что если два объекта делают ссылки друг на друга, то они попадают в deadlock, взаимно блокируя друг друга. Эта ситуация возникает нечасто, но если уж возникает, ее решение отнимает много нервов и времени. Есть два пути решения этой проблемы. Один – нарушить соглашения COM, и не делать увеличения счетчика ссылок одному из объектов. При этом время жизни объекта, которому не делается увеличение счетчика, должно быть заведомо больше, чем время, на которое требуется указатель на его интерфейс. Этот путь опасен и не всегда работает в сетевом окружении. Второй путь – создать промежуточный (третий) объект, который и подсунуть объекту, приводящему к взаимоблокировке. При этом на третий объект делается две ссылки, а на первый ссылок не делается вообще. В момент, когда первый объект уничтожается, он отпускает первый и третий. Далее уничтожается второй, и, в свою очередь, отпускает третий, что приводит к уничтожению третьего объекта. Второй способ избежания взаимоблокировок является более предпочтительным, но требует дополнительного кода. Очень плохо, что COM не взял на себя решение проблем с взаимоблокировкой.
БиблиотекиCOM-объекты помещаются в библиотеки. Чаще всего это файл с расширением DLL, но иногда библиотеки помещаются в EXE- или OCX-модули. Расширение OCX всего лишь говорит о том, что в библиотеке находится элементы управления ActiveX, по существу это тоже DLL. EXE-формат (исполняемый файл) используется в двух случаях: 1) когда надо создать отдельный COM-сервер, не требующий при своей работе наличия MTS или COM+, 2) когда создается настольное Windows-приложение, которое должно поддерживать Automation (выставлять некоторую объектную модель, доступную из других приложений).
Так вот, кроме того, что библиотека должна быть помещена в какой-нибудь исполняемый файл, она еще должна быть специальным образом описана и зарегистрирована на компьютере, где ее предполагается использовать. В MIDL такое описание выглядит так:
[
uuid(96479D03-B2D5-11D3-AE78-004095E1F072),
version(1.0),
helpstring("Stack Type Library v 1.0")
]
library StackLib
{
[
uuid(95F3208B-F9AC-11d3-A6AD-0050BAC0EF0F),
helpstring("Iauaeo Stack")
]
coclass Stack
{
[default] interface IStack;
};
}
В теле библиотеки содержится описание входящих в нее объектов. На основании такого описания MIDL генерирует библиотеку типов. Как и другие объекты в COM, библиотеки должны иметь свой уникальный идентификатор (GUID). В применении к библиотеке он называется LibID. В случае DLL библиотека типов прилинковывается к DLL, а в случае с EXE обычно поставляется отдельно в файле с расширением TLB или OLB. Как бы там ни было, библиотека типов регистрируется в системе, и с ее помощью можно получать информацию о любом элементе библиотеки. С помощью библиотеки типов можно даже сгенерировать MIDL-описание для всех элементов библиотеки. В поставку MS Visual Studio входит утилита «OLE View», позволяющая просматривать библиотеки типов и получать MIDL-описание.
Создание простого COM-объектаСоздавать COM-объекты очень просто. Однако для создания проекта COM-библиотеки на C++ нужно написать довольно много одинакового (повторяющегося из проекта в проект и занудного) кода. Чтобы не делать этого каждый раз, лучше всего воспользоваться библиотекой ATL (о ней уже говорилось ранее) и соответствующими визардами (речь идет про Microsoft VC и Borland C++ Builder). На VB вообще надо только выбрать тип проекта «ActiveX DLL». При этом VB создаст класс. Любой метод или свойство этого класса, не помеченный как Private, будет являться методом или свойством COM-объекта. Пример, который далее будет реализован на C++, на VB будет выглядеть так:
Public Function Summa(ByVal P1 As Long, ByVal P2 As Long)
Summa = P1 + P2
End Function
В C++ (и на VC и на C++ Builder) надо создать проект. В VC надо выбрать меню «File\New» и в появившемся визарде на закладке «Projects» вбить имя проекта, путь к нему, и нажать Enter. Назовем проект «VCTest1». На следующей странице достаточно еще раз нажать Enter, так как ее установки полностью нас удовлетворяют. Появится окно, перечисляющее, какие файлы будут созданы. Это последний шанс отменить создание проекта. Еще раз нажмем Enter.
Рис. 1Итак, что же создает этот визард?
VCTest1.dsp – DLL-проект VC. VCTest1.cpp и VCTest1.h – файлы библиотеки. Они отвечают за саморегистрацию библиотеки и за создание объектов. VCTest1.idl – IDL-описание нашей библиотеки. Пока что этот файл содержит пустое описание библиотеки типов. VCTest1ps.mk – make-файл, создающий DLL, содержащую proxy и stub для интерфейсов, входящих в нашу библиотеку. Если библиотека будет отвечать требованиям Automation, то DLL, создаваемая этим make-файлом, да и сам make-файл нам никогда не понадобятся. Иначе для маршалинга придется использовать proxy/stub DLL. При создании проекта можно заставить ATL-визард объединять proxy/stub с основной DLL-библиотекой.Если скомпилировать проект, получится VCTest1.dll, не содержащая ни одного объекта. Поэтому вместо компиляции добавим COM-объект.
Для этого из меню Insert нужно выбрать пункт «New ATL Object». Появится «ATL Object Wizard». Надо выбрать «Objects\Simple Objects» и нажать кнопку «Next >» (см. Рис.1).
На этом шаге визард попросит задать имя объекта. Сделать это можно в поле «Short Name». Введем в него строку «VCTestObj» (см. рис.2).
Рис. 2Остальные параметры можно оставить по умолчанию, так что нажмем Enter. При этом к проекту добавятся три файла:
VCTestObj.h – содержащий описание C++-объекта (CVCTestObj), являющегося реализацией нашего COM-объекта; VCTestObj.cpp – сейчас он пуст (в будущем в него будет добавляться код для объекта CVCTestObj); VCTestObj.rgs – файл, содержащий описание – информацию, которую надо занести в реестр.В IDL-файл при этом добавилось описание нового объекта и нового интерфейса.
Осталось добавить метод, и можно компилировать проект.
Для этого следует переключиться на закладку «ClassView» в окне «Workspace», щелкнуть правой кнопкой мыши по имени интерфейса (IVCTestObj) и в контекстном меню выбрать пункт «Add Method» (см. Рис.3).
В появившемся диалоге надо ввести имя метода и описание его параметров, как это показано на Рис.4.
После нажатия Enter в описании интерфейса (файл VCTest1.idl) и в описании объекта C++ (файлы VCTestObj.h и VCTestObj.cpp) добавится описание нового метода. Осталось перейти к новому методу и внести необходимый код:
*piResult = iP1 + iP2;
Теперь можно собрать проект, нажав кнопку F7. При сборке проекта происходит автоматическая регистрация библиотеки. Так что после завершения можно сразу приступать к тестированию проекта.
Единственное, что необычно в приведенном примере – это то, что результат возвращается через параметр, а не как возвращаемое значение функции. Это вызвано тем, что возвращаемое значение в методах COM-объекта зарезервировано для возврата кода ошибки (см. «Обработка ошибок»).
Установление связи с удаленным объектом Создание экземпляра объекта и вызов методаВ отличие от CORBA, в СОМ не предусмотрено специальных средств получения указателей на интерфейсы конкретных объектов. Поэтому стандартным способом установления связи с COM-объектом является его создание. Как уже говорилось, есть несколько методик, позволяющих имитировать разные подходы, в том числе и привычные для CORBA. Ниже приведен C++ код консольного приложения, создающий COM-объект и вызывающий его метод.
#include "stdafx.h"
#include <stdio.h>
#include <conio.h>
#include "objbase.h"
#include "..\VCTest1.h"
#include "..\VCTest1_i.c"
int main(int argc, char* argv[])
{
// Инициализируем COM
CoInitialize(NULL);
IVCTestObj * pIVCTestObj;
// Создаем объект - VCTestObj
HRESULT hr = CoCreateInstance(CLSID_VCTestObj,
NULL, CLSCTX_SERVER,
IID_IVCTestObj, (void**)&pIVCTestObj);
if(SUCCEEDED(hr))
{
// Если объект создан...
int iP1 = 1, iP2 = 2, iResult = 0;
// Вызываем метод COM-объекта...
hr = pIVCTestObj->Summa(iP1, iP2, &iResult);
// Освобождаем ссылку на COM-объект...
pIVCTestObj->Release();
printf("Call 'Summa(%d, %d)' return %d.\n", iP1, iP2, iResult);
}
printf( "\n\nError code: 0x%08x\n\n"
"Press eny key to continue...\n", hr);
_getch(); // Ожидаем ввода символа (для удобства отладки)
CoUninitialize(); // Деинициализируем COM
return 0;
}
В этом примере, CLSID объекта, IID и описание интерфейса берутся из сгенерированных компилятором MIDL для первого проекта (см. «Создание простого COM-объекта») файлов (VCTest1.h и VCTest1_i.c).
Такой способ удобно применять, если и объект и вызывающее его приложение созданы на C++ и доступны описания в текстовом виде. Если же вам доступна только бинарная библиотека, то можно воспользоваться расширением C++ – директивой «#import». Это расширение сделано Microsoft. Если я не ошибаюсь, оно доступно начиная с пятой версии VC. Чтобы получить результат, аналогичный включению файлов VCTest1.h и VCTest1_i.c, надо использовать следующий синтаксис:
#import "..\Debug\VCTest1.dll" \
no_implementation no_namespace \
named_guids raw_interfaces_only
С помощью директивы «#import» также можно создать классы-обертки, позволяющие упростить работу с включенными в библиотеку компонентами. Подробнее об этой директиве можно узнать в документации по VC.
В C++ Builder тоже реализована поддержка «#import», но, к сожалению, криво. В документации предлагается для взаимодействия с COM-объектами пользоваться импортом библиотек типов. Для этого нужно в меню «Project» выбрать пункт «Import Type Library», найти в списке необходимую библиотеку типов и нажать кнопку «Install». При этом создаются файлы описания и классы-обертки. После перекомпиляции пакеджа (в который происходит импорт) в палитре компонентов, на закладке «ActiveX» появятся новые компоненты, в нашем случае один «VCTestObj». Если поместить один из них на форму, то с его помощью можно будет производить вызовы методов COM-объекта. Вот как выглядит вызов метода нашего тестового объекта:
VCTestObj1->Connect();
ShowMessage("Summa(1, 2) = " + String(VCTestObj1->Summa(1, 2)));
VCTestObj1->Disconnect();
Метод Connect создает экземпляр объекта, а Disconnect освобождает ссылку (вызовом Release). Таким образом, объект создается и, после вызова метода Summa, уничтожается. Если надо обеспечить жизнь объекта на протяжении всей жизни формы, то можно вместо вызова Connect установить свойство AutoConnect в True во время разработки. Это приведет к тому, что COM-объект создастся при загрузке формы. Метод Disconnect в этом случае тоже можно проигнорировать, при уничтожении формы ссылка на COM-объект будет освобождена автоматически.
Этот механизм C++ Builder позаимствовал у Delphi. Сравните код Delphi с приведенным ранее.
VCTestObj1.Connect();
ShowMessage('Summa(1, 2) = ' + IntToStr(VCTestObj1.Summa(1, 2)));
VCTestObj1.Disconnect();
Еще одна полезная черта «оберток» заключается в том, что они преобразуют обработку ошибок «в стиле COM» в схему, принятую для базового языка.
Еще меньше приходится делать в VB. В нем надо только зарегистрировать ссылку, объявить переменную и вызвать метод. Если впоследствии в библиотеке, содержащей вызываемый объект, произойдут изменения, VB сам их отследит. Вот код вызова метода нашего тестового компонента:
Dim obj As New VCTestObj
MsgBox "Summa(1, 2) = " & obj.Summa(1, 2)
В приведенных выше примерах предполагается, что сервер соответствующим образом зарегистрирован. По умолчанию DLL-библиотека, в которую помещен COM-объект, регистрируется как внутрипроцессный (in-process) сервер. Это приводит к тому, что DLL будет грузиться внутрь каждого процесса, который попытается создать находящийся в ней объект. Чтобы с объектами из этой DLL-библиотеки можно было работать по сети, необходимо зарегистрировать ее в COM+ или MTS. Вот как выглядит эта операция.
Первое что необходимо сделать, это открыть COM+ Component Services (MTS Explorer) и добраться до папки «My Computer». В ней необходимо выбрать папку «COM+ Applications» и создать (или открыть, если оно уже существует) новое приложение COM+. Создать новое приложение можно, выбрав из меню «Action» (или из контекстного меню) пункт «New\Applications».
В приложение COM+ необходимо добавить компоненты. Это делается аналогично созданию приложения, с той лишь разницей, что в этот раз надо выбрать папку «Components» приложения. Результат регистрации должен быть похож на Рис. 6.
В одно приложение можно помещать компоненты из разных библиотек. Приложение олицетворяет процесс, в котором будут загружаться и исполняться компоненты. Если есть необходимость загружать компоненты в разных процессах, то нужно помещать их в разные приложения COM+.
COM+ Component Services (для Windows NT 4.0 – MTS Explorer) позволяют не только производить первичную регистрацию компонентов, но и дают возможность настраивать их характеристики, производить отладку компонентов, осуществлять их мониторинг и даже создавать инсталляторы для распределенных приложений.
Чтобы зарегистрировать приложение COM+ на клиентской машине, необходимо с помощью COM+ Component Services (MTS Explorer) создать proxy-инсталлятор. Затем нужно прогнать этот инсталлятор на каждой клиентской машине. Деинсталляция COM+-приложения, как и любого другого Windows-приложения, доступна через «Control Panel» – «Add\Remove Programs».
Не-СОМ+-приложения можно зарегистрировать и администрировать с помощью утилиты DCOMCNFG.
Управление объектами АгрегацияС помощью COM можно создавать объекты, реализация которых состоит из нескольких других объектов. Такой составной объект выглядит как единый. Агрегация – лучший в COM-модели способ повторного использования бинарных компонентов, не приводящий к потерям производительности. Его слабой стороной является то, что нельзя перехватывать и по-своему обрабатывать отдельные методы интерфейсов агрегируемых объектов. Можно только подставлять свою реализацию целого интерфейса.
Использовать функциональность других компонентов, но не давать им при этом свободы действий, можно с помощью делегации.
ДелегацияЭто простое включение объекта внутрь и передача (делегация) ему для обработки некоторых вызовов другого объекта. Этот способ обеспечивает наибольшую гибкость, но проигрывает по эффективности агрегации, так как производятся лишние вызовы.
Управление временем жизни экземпляров COM-объектовВремя жизни COM-объекта ограничено временем жизни серверного приложения, в котором создан этот объект. К тому же объект самоуничтожается при освобождении (вызовом метода Release) последней ссылки на него. Тем не менее, на практике это не приводит к каким-нибудь ограничениям. Если логическое время жизни объекта должно превышать время жизни экземпляра объекта в оперативной памяти, можно просто сохранить в файл или в поле БД его состояние перед уничтожением, а когда он понадобится, загрузить его вновь. Сохраненный объект может путешествовать между компьютерами, например, через параметр удаленного объекта или в электронном письме. На нужном компьютере надо просто создать новый экземпляр нужного класса и инициализировать его состояние пришедшими данными.
Сохранение и загрузку объектов можно инкапсулировать в методах другого удаленного объекта. Например, можно создать объект с методами Save и Load, передавая им в качестве параметров идентификатор БД или имя файла и указатель на интерфейс сохраняемого (загружаемого) объекта. Часто для этого применяются моникеры. OLE DB и ADO позволяют записывать в БД объекты, поддерживающие стандартные интерфейсы IPersistXXX (см. «Инициализация и сохранение объектов»).
COM+ даже позволяет вызывать методы объектов на выключенном компьютере. Эти возможности освещается в разделе «Асинхронное взаимодействие между объектами».
Количество экземпляров объектовПри вызове CoCreateInstance вы не обязательно получаете указатель на новый объект. Вполне возможно, что вы получите указатель на уже созданный, разделяемый объект. Такой объект называется singleton. За то, как выполняется операция создания экземпляра COM-объекта, отвечает так называемая фабрика классов. Ее реализация находится в том же модуле, что и реализация объектов создаваемых этой фабрикой.
Если для создания COM-объектов вы используете ATL, то для реализации singleton-объекта надо добавить одну строчку в код вашего объекта:
DECLARE_CLASSFACTORY_SINGLETON(CMyClass)
Где CMyClass это имя вашего класса.
Singleton-объекты удобны, когда необходимо организовать управление общими ресурсами. Такие объекты похожи на Corba-объекты, использующие сервант по умолчанию.
В COM не реализован сервис имен (Naming Services), аналогичный CORBA. Этот Corba-сервис позволяет получать ссылку на конкретный экземпляр объекта, созданный на сервере. Идентификация объекта при этом происходит по имени.
Обычно необходимость такой функциональности встречается редко, так как COM придерживается отличных от Corba принципов взаимодействия с объектами. Но если такая функциональность вам необходима, то можно создать свой сервис имен. Для этого удобно воспользоваться функциональностью Singleton-объектов. Singleton-объект создает другие объекты и помещает их в массив, статический в простом случае, и динамический, или мап (объект, позволяющий ассоциировать одни значения с другими – в нашем случае имена объектов с указателями на их интерфейс) в более сложном случае. Один из методов этого Singleton-объекта принимает в качестве входного параметра имя и возвращает ассоциированный с ним объект. Простой пример, того, как это можно сделать с помощью ATL, находится на нашем сайте в электронной версии этой статьи. Там же приведен и Corba-вариант, использующий сервис имен.
Экземпляры и EXE-серверыЕсли объект реализован в DLL, то, в принципе, его экземпляры можно создавать внутри нескольких EXE-серверов, но регистрировать в COM+ или MTS их можно только один раз (на одной машине). Если есть необходимость создавать такие COM-объекты в разных EXE-модулях, то их или вовсе не надо регистрировать в COM+/MTS, или нужно регистрировать как библиотечное приложение (библиотечный пакет в MTS). При этом создание экземпляров и передачу указателей на их интерфейсы необходимо делегировать другим объектам, зарегистрированным в COM+/MTS.
Если создается монолитный EXE-сервер, то тем, будет или нет загружаться новая копия EXE-модуля при создании нового объекта (и некоторыми другими аспектами), можно управлять через один из параметров функции CoRegisterClassObject. ATL использует эту функцию при загрузке EXE-модуля для регистрации реализуемых им компонентов.
Использование нестандартных типов данных в методах удаленного объекта Два путиВ COM есть два варианта организации обработки нестандартных (user-defined или сконструированных) типов данных. Первый – это уровень компилятора MIDL и C/++. Второй – использование стандартных для COM и совместимых с Automation универсальных типов данных и соответствующей техники.
Оба варианта позволяют использовать базовые типы (long, byte, ...), перечисления (enum) и структуры. Разница заключается в требованиях и ограничениях, предъявляемых обоими вариантами.
Первый вариант является более низкоуровневым и обычно приводит к тому, что методы, описанные с использованием хитрых MIDL-атрибутов, начинают неправильно восприниматься (или вообще становятся недоступными) в высокоуровневых языках типа VB. Еще одной особенностью первого варианта является то, что при его использовании не задействуются библиотеки типов. Маршалинг (запаковка параметров, передача их по сети и распаковка на другом компьютере) при этом выполняется создаваемой MIDL-компилятором заглушкой – специальной DLL-библиотекой, которая определенным образом регистрируется на взаимодействующих компьютерах.
Все универсальные типы данных, применяемые во втором варианте, созданы с помощью низкоуровневых средств. Но, поскольку эти типы стандартны, о них знают и умеют с ними работать высокоуровневые языки типа VB. А так, как поддержка этих типов осуществляется с ОС, заботиться о создании и регистрации заглушек не надо, они устанавливается при установке ОС. Второй вариант обеспечивает поддержку метаописаний объектов в библиотеке типов, и совместим со всеми средствами разработки. К тому же он спасает от возни с заглушками, что ускоряет время разработки и бережет нервы.
Главное преимущество первого варианта заключается в том, что он позволяет «протащить через проволоку» практически любые типы данных, но если есть возможность, лучше пользоваться вторым подходом.
Если создавать приложения на VB, просто нет никакого выбора, кроме использования второго подхода. Собственно, VB все делает сам, и полностью обходится без MIDL-компилятора, да впрочем, и без самого IDL. Зато VB генерирует библиотеку типов, по которой впоследствии может быть создано описание для любого языка.
Второй вариант можно использовать и при создании приложений на С++. Надо только выполнять некоторые требования и не использовать низкоуровневые MIDL-конструкции.
Основные возможности низкоуровневого МIDL/С++ варианта МассивыДля передачи по сети массивов MIDL использует атрибуты size_is() и length_is(). При этом метод, передающий массив, будет выглядеть так:
HRESULT Method1(
[in] short iLength,
[in, length_is(iLength)] short asNumbers[10]);
HRESULT Method2(
[in] short iLength,
[in] short iSize,
[in, length_is(iLength), size_is(iSize)] short * asNumbers);
Атрибут size_is определяет, сколько памяти будет занято RPC-заглушкой, а length_is определяет, сколько данных надо реально передавать. Так, в первом методе на вызываемой (так как все параметры типа "in") стороне всегда будет заниматься память для десяти элементов (10 * sizeof(short) = 20 байт) массива, но передаваться по сети будет iLength элементов. Во втором случае динамически будут определяться оба параметра. Если объем занимаемой памяти равен передаваемому, то можно пользоваться только атрибутом size_is. В работе с чисто входными (in) и чисто выходными параметрами (out) есть несколько нюансов, но рассказ об этом может занять слишком много места. За подробностями можно обратиться к MSDN. В одном из номеров нашего журнала (3 квартал 1998 года, статья «Visual C++ 6.0 в составе Microsoft Visual Studio» ) была статья, посвященная этой теме.
Работа со строкамиMIDL позволяет использовать заканчивающиеся нулем строки. Правила работы со строками те же, что и в C/C++. Поддерживаются как обычные, так и двухбайтные строки. Чтобы сообщить MIDL, что некоторый параметр рассматривается, как строка, нужно пометить его специальным атрибутом – string. VB не поддерживает этот атрибут. Для работы со строками в нем применяется специальный тип – BSTR. Используя атрибуты size_is() и length_is(), можно передавать строки, содержащие в своем теле несколько NULL-символов.
UnionЕще одной интересной особенностью MIDL является поддержка им объединений (union), аналогичных объединениям в С++. Расширенный атрибут switch_is позволяет задать переменную, используемую для определения элемента объединения, имеющего смысл в данный момент времени. Обычно объединение (вернее, его описание и переменную, созданную на базе этого объединения) помещают в структуру. Одно из полей этой структуры и используется в атрибуте switch_is.
Ручная запаковка и распаковкаСамым радикальным случаем при работе с MIDL является так называемый wire marshaling. Этот тип маршалинга преобразует сложный тип в простой с помощью пользовательских функций. Суть его вкратце можно описать так. У вас есть тип данных, который по каким-то причинам нельзя переслать по сети в качестве параметра функции или в составе другого типа данных. Примером может служить указатель на объект C++ или тип данных, содержащий ссылки на локальные ресурсы. В этом случае вы объявляете этот тип в IDL с помощью атрибута wire_marshal или user_marshal. При этом вы задаете исходный тип и так называемый wire-тип. Wire-тип – это некоторый базовый тип, который априори может передаваться по сети, например, массив байтов. Далее надо реализовать четыре функции:
_UserSize – Вычисляет размер, необходимый для буфера данных RPC. Этот метод вызывается перед передачей данных на другой компьютер. _UserMarshal – Запаковывает данные в Wire-тип. _UserUnmarshal – Распаковывает данные из Wire-типа. _UserFree – Освобождает память, занятую при распаковке. Вызывается RPC-заглушкой на стороне клиента, позволяя тем самым освободить данные, на которые ссылается исходный тип.На основе IDL-описания и кода этих функций MIDL-компилятор создает специальную заглушку, используемую RPC-подсистемой ОС для передачи по сети того, что иначе не передается.
Листинг 1. IDL-файл примера «работа со структурами и массивами»
// RemTest1.idl : IDL source for RemTest1.dll
//
// Этот файл будет обработан MIDL для
// создания библиотеки типов (RemTest1.tlb) и кода маршаллинга.
import "oaidl.idl";
import "ocidl.idl";
[
uuid(421D531D-A54F-4137-93E8-7006448611B7),
version(1.0),
helpstring("RemTest1 1.0 Type Library")
]
library REMTEST1Lib
{
importlib("stdole32.tlb");
importlib("stdole2.tlb");
typedef [uuid(7EF6E5F1-ACF8-49a5-B49B-A92349F27157), version(1.0)]
enum SomeEnum
{
Some,
Some1,
Some2,
Some3
}SomeEnum;
typedef [uuid(080C357D-EE8D-40b0-AD0A-5667995BB186), version(1.0)]
struct SomeStruct
{
int i;
BSTR str;
SomeEnum se;
}SomeStruct;
[
object,
uuid(153450BE-9F71-4193-9A00-95C58175FD8F),
version(1.0),
dual,
nonextensible,
pointer_default(unique),
oleautomation
]
interface IO : IDispatch
{
[id(1)] HRESULT M1([in,out] SomeStruct * ss);
[id(2)] HRESULT M2([in,out] SAFEARRAY(SomeStruct) * ssbs);
[id(3)] HRESULT M3([in] long len, [in, size_is(len)] SomeStruct * ssa);
};
[uuid(51ABF99E-4583-4DF1-85F5-51DE0EB57CDC)]
coclass O
{
[default] interface IO;
};
};
Листинг 2. Заголовочный фал примера «работа со структурами и массивами»
// O.h : Declaration of the CO
#ifndef __O_H_
#define __O_H_
#include "resource.h" // main symbols
/////////////////////////////////////////////////////////////////////////////
// CO
class ATL_NO_VTABLE CO :
public CComObjectRootEx<CComSingleThreadModel>,
public CComCoClass<CO, &CLSID_O>,
public ISupportErrorInfo,
public IDispatchImpl<IO, &IID_IO, &LIBID_REMTEST1Lib>
{
public:
CO(){}
DECLARE_REGISTRY_RESOURCEID(IDR_O)
DECLARE_PROTECT_FINAL_CONSTRUCT()
BEGIN_COM_MAP(CO)
COM_INTERFACE_ENTRY(IO)
COM_INTERFACE_ENTRY(IDispatch)
COM_INTERFACE_ENTRY(ISupportErrorInfo)
END_COM_MAP()
// ISupportsErrorInfo
STDMETHOD(InterfaceSupportsErrorInfo)(REFIID riid);
// IO
public:
STDMETHOD(M3)(/*[in]*/ long len, /*[in, size_is(len)]*/ SomeStruct * ssa);
STDMETHOD(M2)(/*[in,out]*/ SAFEARRAY ** ssbs);
STDMETHOD(M1)(/*[in,out]*/ SomeStruct * ss);
};
#endif //__O_H_
Концепция этого варианта очень проста: вы не можете использовать низкоуровневые средства MIDL. Вместо этого вы используете стандартные (их еще называют Automation-совместимыми) типы данных, структуры и перечисления.
VB делает это автоматически.
Ниже приведено краткое описание Automation-совместимых типов:
VARIANT_BOOL – Логический тип. Может иметь значение True (-1) или False (0). BYTE – 8-битное целое число без знака. int – Целое число со знаком. На 32-хбитных платформах имеет размер 32-бита. long – 32-битное целое число со знаком. short – 16-битное целое число со знаком. double – 64-битное число с плавающей точкой. float – 32-битное число с плавающей точкой. CURRENCY – 64-битное число, с фиксированной точкой. DECIMAL – 96-битный (12 байтов) тип, предназначенный для хранения чисел со знаком и переменной плавающей точкой (от 0 до 28 разрядов). DATE – 64-битное число с плавающей точкой, используемое для хранения даты. IDispatch * – Указатель на disp- или dual-интерфейс. IUnknown * – Указатель на IUnknown. Используется для передачи обыкновенных интерфейсов (не disp- или dual-интерфейсов). BSTR – basic-строка или бинарная срока, на Win32-платформах указатель на строку Unicode-символов. Переменная этого типа хранит не только саму строку, но и ее длину. Это позволяет помещать в тело строки любые символы, в том числе неограниченное количество NULL-символов. VARIANT – тип, позволяющий создать переменную, тип которой определяется во время выполнения программы и может изменяться с течением времени. Поддерживаются все типы, доступные для Automation, за исключением самого VARIANT’а. По существу, VARIANT – это структура, содержащая поле vt, определяющее тип, и поле, созданное на базе объединения, содержащего доступные типы данных. VARIANT позволяет хранить в себе даже структуру (VT_RECORD), массив (VT_ARRAY) или указатель на интерфейс. Использование массивов VARIANT’ов и массивов структур позволяет создавать модели данных любой сложности. Единственная проблема типа VARIANT – размер. VARIANT занимает 16 байт. Впрочем, по сравнению с типом данных Any (из CORBA), он просто малютка. SAFEARRAY – так называемый безопасный массив. С его помощью можно создавать динамические много- и одномерные массивы. Как и в случае с типом VARIANT, в качестве типа ячейки SAFEARRAY’я можно использовать любой Automation-тип, включая сам SAFEARRAY. В отличие от типа VARIANT, SAFEARRAY не приводит к перерасходу оперативной памяти, даже когда хранит в себе структуры (тип VT_RECORD). При объявлении массивов типа SAFEARRAY в MIDL используется синтаксис – SAFEARRAY(elementtype) *arrayname. Здесь elementtype – это тип элемента массива. SAFEARRAY может быть многомерным, но все его размерности должны быть одного типа. Типа «структура» как такового не существует. Структуры являются чисто сконструированным типом данных, и, похожи на структуры в языке С, за тем исключением, что здесь в структуры нельзя включать поля, являющиеся указателями на функции. Структуры могут содержать любые перечисленные типы данных, перечисления и другие структуры, определенные в этой же или импортированной (оператором importlib) библиотеке.Не обязательно, но очень рекомендуется добавлять к определенным пользователям типам (структурам и перечислениям) уникальный идентификатор (в атрибуте uuid). Эти идентификаторы сделают описания типов уникальными (по крайней мере, в пределах нашей планеты ;-)) и позволят получать их описание с помощью таких API-функций, как GetRecordInfoFromGuids.
Эта функция возвращает указатель на интерфейс IRecordInfo. С его помощью можно создавать новые экземпляры пользовательских типов данных, получать их описание и производить над ними другие операции.
Структуры в массивах и с переменной типа VARIANTС хранением структур в VARIANT или SAFEARRAY есть некоторая тонкость. Хотя в библиотеке типов можно указать, что в поле структуры или параметре функции может содержаться массив (SAFEARRAY) конкретных структур, во время работы приложения все равно приходится иметь дело с VARIANT’ом и SAFEARRAY’ем. Даже то, что у них можно узнать, что в них лежит структура (VT_RECORD), не дает никакого представления о том, что это за структура. А раз неизвестно, какая структура лежит, то и взаимодействовать с ней затруднительно. Как уже говорилось ранее, COM придерживается стратегии идентификации объектов, с которыми он взаимодействует, при помощи GUID. И если с некоторым объектом, в данном случае со структурой, не ассоциирован GUID, то COM не может поместить ее в VARIANT или SAFEARRAY. Поэтому при описании структуры, которую необходимо поместить в SAFEARRAY, надо задавать GUID. Зато после выполнения этого нехитрого требования вам становится доступна вся информация о структуре, хранящейся в ячейке массива SAFEARRAY или переменной типа VARIANT. Вы можете проверить, какого типа структура лежит в массиве, динамически получить информацию о полях структуры, считать или установить значение отдельного поля (по имени) и многое другое. Вы также можете просто узнать количество записей в массиве, получить указатель на данные, привести его к указателю на нужную структуру и заняться обработкой данных.
Листинг 3. cpp-файл примера «работа со структурами и массивами».
// O.cpp : Implementation of CO
#include "stdafx.h"
#include "RemTest1.h"
#include "O.h"
/////////////////////////////////////////////////////////////////////////////
// CO
STDMETHODIMP CO::InterfaceSupportsErrorInfo(REFIID riid)
{
static const IID* arr[] =
{
&IID_IO
};
for (int i=0; i < sizeof(arr) / sizeof(arr[0]); i++)
{
if (InlineIsEqualGUID(*arr[i],riid))
return S_OK;
}
return S_FALSE;
}
STDMETHODIMP CO::M1(SomeStruct *ss)
{
if(!ss)
return E_INVALIDARG;
ss->i = 111;
ss->se = Some3;
return S_OK;
}
STDMETHODIMP CO::M2(SAFEARRAY ** ssbs)
{
HRESULT hr = S_OK;
// Проверяем, что в масиве лежат структуры...
if(FADF_RECORD != (*ssbs)->fFeatures)
return E_INVALIDARG;
// С помощью IRecordInfo можно получать различную информацию о структуре
CComPtr<IRecordInfo> spIRecordInfo;
hr = SafeArrayGetRecordInfo(*ssbs, &spIRecordInfo);
if(FAILED(hr))
return hr;
// Проверяем, та ли структура лежит в массиве...
GUID RecordGuid;
spIRecordInfo->GetGuid(&RecordGuid);
GUID SomeStructGuid;
// Переводим взятый из IDL-файла строковый GUID в бинарный GUID
CLSIDFromString(OLESTR("{080C357D-EE8D-40b0-AD0A-5667995BB186}"),
&SomeStructGuid);
// Если GUID-ы не совпали, значит, нам подсунули массив не тех структур
if(RecordGuid != SomeStructGuid)
return E_INVALIDARG;
// Если вы уверены, что получаете правильный массив, то предыдущий код
// не нужен. Дальше начинается код, меняющий первый элемент в массиве
SomeStruct * pss;
// Блокируем массив
if(SUCCEEDED(SafeArrayLock(*ssbs)))
{// Теперь можно производить доступ к его элементам
// Получаем доступ к элементу 1
LONG iIndex = 1;
hr = SafeArrayPtrOfIndex(*ssbs, &iIndex, (void**)&pss);
if(FAILED(hr))
return hr;
// Изменяем значения полей...
pss->i = 987654321;
SysFreeString(pss->str);
pss->str = SysAllocString(OLESTR("Изменено на C++"));
pss->se = Some3;
// Отпускаем массив
return SafeArrayUnlock(*ssbs);
}
return S_OK;
}
STDMETHODIMP CO::M3(long len, SomeStruct * ssa)
{
if(len < 2)
return S_FALSE;
ssa[1].i = 555;
ssa[1].se = Some2;
return S_OK;
}
В Листингах 1, 2 и 3 приведена реализация COM-объекта, демонстрирующего работу с отдельной структурой (метод M1), с массивом структур через SAFEARRAY (метод M2), и работа с массивом, описанным средствами MIDL (метод M3). Под Windows 2000 этот пример не требует создания и регистрации заглушки, но так как метод M3 содержит прямое обращение к не-Automation типу, на других платформах этот пример может потребовать компиляции и регистрации заглушки. Чтобы избежать этого, можно изменить описания метода M3 так, чтобы использовались только типы VARIANT и SAFEARRAY.
Код метода M2 перегружен. Но, во-первых, основную его часть занимают проверки, которые на практике не нужны. Во-вторых, можно сделать шаблонный класс, который принимал бы в качестве параметра тип структуры и эмулировал простой массив. Сделать это можно, скрыв блокировку и ее снятие в конструкторе и деструкторе, а эмулировать массив – перегрузив оператор [ ].
Клиентское приложение, взаимодействующее с объектом из примера, можно создать на C++ (например, выбрав проект MFC EXE) или на VB. В Листинге 4 приведен пример на VB.
Листинг 4. VB-клиент примера «работа со структурами и массивами»
'Не забудьте подключить ссылку на эту библиотеку
Dim rem1 As New REMTEST1Lib.O
Private Sub Command1_Click()
Dim SS As SomeStruct
SS.i = 12345
SS.se = Some1
SS.Str = "Изменено на VB"
MsgBox "i = " & SS.i & " SS.se = " & SS.se & " str = " & SS.Str
rem1.M1 SS
MsgBox "i = " & SS.i & " SS.se = " & SS.se & " str = " & SS.Str
End Sub
Private Sub Command2_Click()
Dim ssa(10) As SomeStruct
Dim ssa1() As SomeStruct
For i = 0 To 10
ssa(i).i = i
ssa(i).se = Some1
ssa(i).Str = "Str " & 1
Next
ssa1 = ssa
MsgBox " ssa1(1).se = " & ssa1(1).se & " ssa1(1).Str = " & ssa1(1).Str
rem1.M2 ssa1
MsgBox " ssa1(1).se = " & ssa1(1).se & " ssa1(1).Str = " & ssa1(1).Str
End Sub
Интерфейсы COM по умолчанию поддерживают статическое связывание. Для динамического связывания используется специальный интерфейс IDispatch. В принципе объект может поддерживать только IDispatch-интерфейс. Такой интерфейс называется disp-интерфейсом. Этот подход применялся во времена VB третьей версии. Сейчас чаще всего применяются так называемые dual-интерфейсы, но об этом позже.
Disp-интерфейсы и IDispatchКак уже говорилось, IDispatch применяется в тех случаях, где нужна интерпретация, то есть при применении OLE Automation или скриптовых языков, таких, как VBScript и JScript. Хотя один объект и может поддерживать более одного disp-интерфейса, скриптовые языки могут воспользоваться только одним из них.
Вызовы методов disp-интерфейса производятся по номеру называемому DISPID. Отображением имен методов в DISPID занимается GetIDsOfNames.
Вот полный перечень методов, входящих в IDispatch:
GetTypeInfoCount – Возвращает число поддерживаемых TypeInfo (всегда равен 0 или 1, практического интереса не представляет). GetTypeInfo – возвращает информацию о типах для текущего интерфейса (см. «Метаданные объектов»). GetIDsOfNames – Позволяет получить список DISPID по заданному списку имен. Invoke – это главный метод в IDispatch. С его помощью и производится вызов. Ему передаются DISPID (номер) метода или свойства и список параметров. Параметры помещаются в массив вариантов. После окончания вызова в этот же массив помещаются значения [out]-параметров. Если вызываемый метод является функцией или производится считывание значения свойства, то значение возвращается через параметр pVarResult.Производительность Invoke ниже, чем прямого вызова интерфейса с теми же параметрами. Главным образом разница в скорости объясняется необходимостью запаковки и последующей распаковки параметров в VARIANT. При сетевом вызове разница в скорости вызова метода disp-интерфейса и метода простого интерфейса становится менее значимой. Однако большинство высокоуровневых средств (типа VB и Delphi) при вызове удаленного метода кроме Invoke вызывают GetIdsOfNames, причем норовят сделать это при каждом вызове, без какой бы ни было оптимизации. Так как GetIdsOfNames выливается в отдельный сетевой вызов, на методах с небольшим числом маленьких по размеру параметров производительность вызовов методов через IDispatch может быть медленнее статического вызова в 4 раза.
Для вызова методов disp-интерфейсов в VB, Delphi и Java используется стандартный синтаксис этих языков. На C++ для этого применяются dispatch-драйверы, специальные классы-обертки.
На C++ более удобно и производительно использовать VTBL-часть dual-интерфейсов.
dual-интерфейсыЭто интерфейсы, поддерживающие как IDispatch, так и прямой вызов через VTBL.
Dual-интерфейсы совмещают скорость обыкновенных интерфейсов с гибкостью disp-интерфейсов. Именно поэтому Microsoft рекомендует использовать их везде, где это возможно.
Практически все среды разработки позволяют легко создавать dual-интерфейсы. VB позволяет создавать только dual-интерфейсы, хотя использовать может и обыкновенные, и disp-интерфейсы. Если нормальный интерфейс описан вне VB (например, в библиотеке типов, созданной с помощью MIDL), то на VB можно создать реализацию этого интерфейса, воспользовавшись ключевым словом Implements.
Вызов Idispatch-части при вызове методов dual-интерфейсов еще больше снижает производительность, так как на стороне сервера этот вызов превращается в нормальный VTBL-вызов, что приводит к ненужным расходам на работу с библиотекой типов. Dual-интерфейсы защищены гораздо лучше, чем чистые disp-интерфейсы, поскольку при конвертации, о которой говорилось выше, производится контроль и приведение типов параметров вызванного метода.
Обработка ошибок HRESULTПо спецификации COM каждый метод COM-объекта должен возвращать специальное 32-х битное число, называемое HRESULT. В нем вызывающей стороне возвращается код ошибки (отрицательное значение), информация об успехе (константа S_OK, равная нулю) или предупреждение (значение, большее нуля).
Обычно COM-объект имеет определенный набор кодов возврата, но так как объекты могут транслировать сообщения об ошибке, полученные от вызываемых ими других методов, то не всегда можно гарантировать, что список значений неизменен. Чтобы определить, был ли вызов успешен или произошла ошибка, можно воспользоваться макросами: SUCCEEDED() – успех и FAILED() – неудача.
Для передачи дополнительной информации об ошибках в COM используется специальный объект, ассоциируемый с потоком, в котором произошла ошибка.
Возврат информации об ошибкахОбъект, содержащий дополнительную информацию об ошибках, может быть ассоциирован с потоком, в котором происходит цепочка СОМ-вызовов. Любой метод в этой цепочке может считать информацию из этого объекта или записать в него свою. Этот объект беспрепятственно преодолевает границы процесса и границы компьютеров. Если ошибка не была обработана на сервере, то информация о ней становится доступна клиентскому компьютеру.
Чтобы записать в этот объект собственную информацию, необходимо выполнить следующие шаги:
Для объекта, в котором инициируется ошибка, реализовать интерфейс ISupportErrorInfo. Для создания объекта, описывающего ошибку, вызвать функцию CreateErrorInfo. Для задания атрибутов этого объекта воспользоваться методами ICreateErrorInfo. Для ассоциации объекта, сообщающего об ошибке, с текущим логическим потоком, вызвать функцию SetErrorInfo. Получение информации об ошибкахЧтобы получить информацию об ошибках, необходимо выполнить следующие шаги:
Следует проверить, может ли объект обработать ошибку, соответствующую возвращенному значению. Для этого через IUnknown::QueryInterface запрашивается указатель на интерфейс ISupportErrorInfo, а затем – InterfaceSupportsErrorInfo, для проверки того, что ошибка случилась именно с тем объектом, который возвратил ее, и что объект, сообщающий об ошибке, относится именно к этой ошибке, а не к предыдущему вызову. Затем нужно вызвать функцию GetErrorInfo, чтобы получить указатель на объект, описывающий ошибку. В принципе, если вас не интересует, кто записал информацию об ошибке, шаг 2 можно пропустить. Чтобы получить информацию от объекта, вызываются методы IErrorInfo.Если объект не готов обработать ошибку, а нуждается в передаче информации о ней дальше по цепи вызова, он должен просто возвратить полученный код ошибки. Так как функция GetErrorInfo стирает информацию об ошибке, ассоциированную с потоком, то её должен вызывать только объект, обрабатывающий ошибку.
В многоуровневой архитектуре сообщение об ошибке может проходить через большое количество методов различных объектов. Можно вынимать сообщение об ошибке, дописывать его к собственному и закладывать обратно, но со своим кодом ошибки. На практике такая техника выглядит, например, так:
В объекте доступа к данным (например, OLE DB) происходит ошибка «нарушение ссылочной целостности». Объект доступа к данным закладывает соответствующее сообщение и возвращает код ошибки. Если это сообщение в неизменном виде дойдет до клиента, тот ни за что не поймет, что же случилось... Промежуточный компонент, управляющий бизнес-логикой, вынимает это сообщение, закладывает сообщение о том, что «Операция добавления данных о клиенте не удалась, так как:» и дописывает сообщение, присланное объектом доступа к данным. Далее компонент, управляющий бизнес-логикой, закладывает свой код ошибки и возвращает управление вызвавшему его методу. Пункт три может повторяться до тех пор, пока управление не получит клиентское приложение, инициировавшее всю цепочку вызовов. Клиентское приложение вынимает сообщение и показывает его пользователю.При такой схеме пользователь получит не только сообщение, что произошло «нарушение ссылочной целостности», но и контекст, в котором произошла эта ошибка. Это позволит пользователю более точно понять возникшую ситуацию и правильно отреагировать на нее. Некоторые уровни в этой схеме могут сами интерпретировать происходящую ситуацию и дописывать комментарии, помогающие ее разрешить. В нашем примере таким уточнением может стать предложение проверить правильность введенных атрибутов, имеющих ссылочный тип.
Прямую работу с IErrorInfo можно встретить только в коде, написанном на C/C++. Да и то обычно его пытаются «завернуть» в обработку исключений C++. VB, например, берет на себя обработку COM-ошибок, скрывая от программиста работу с HRESULT и IErrorInfo в специальном объекте «Err».
Прямая обработка ошибок на C++ позволяет создавать более строгий и производительный код, а также дает лучший контроль над процессом обработки ошибок.
Метаданные объектовКаждый COM-интерфейс, каждый COM-класс и, в принципе, любой элемент COM-библиотеки могут иметь бинарное описание их параметров и атрибутов. Такое описание хранится в библиотеке типов, которая (как уже говорилось) обычно прилинковывается к DLL-модулю или поставляется в отдельном TLB-файле.
Библиотеки типов используются для получения информации об объектах, интерфейсах и пользовательских типах данных. Они также позволяют избавиться от proxy/stub при маршалинге. Создавать библиотеки типов можно с помощью MIDL или программно. VB тоже создает библиотеки типов, но при этом они неразрывно связаны с создаваемыми на нем компонентами. Естественно, VB позволяет использовать библиотеки типов, созданные другими средствами.
Для создания библиотек типов «вручную» используется специальный объект, реализующий интерфейс ICreateTypeLib[2]. Для создания такого объекта используется API-функция CreateTypeLib[2].
Прочитать содержимое библиотеки типов можно с помощью интерфейса ITypeLib. Получить указатель на этот интерфейс можно, вызвав API-функции LoadTypeLib или LoadRegTypeLib.
Для всех интерфейсов, описанных в этом разделе, поддерживается маршалинг, что позволяет получать информацию о типах через сеть.
Disp-интерфейсы (как и dual-интерфейсы) позволяют получить их описание через свой метод IDispatch::GetTypeInfo. На нашем сайте в электронной версии этой статьи можно найти пример, показывающий, как получить информацию о типе содержимого VARIANT’а. Хотя в этом примере речь описывается техника работы с типом VARIANT, часть этого примера можно использовать как общее описание работы с библиотеками типов и интерфейсом ITypeInfo. Там же можно найти и CORBA-аналог этого проекта.
Управление потокамиМногопоточные приложения имеют два основных подводных камня: взаимоблокировки (deadlocks) и гонки (races). Взаимоблокировка происходит, когда один поток ожидает от другого каких-то действий, а тот, в свою очередь, ждет некоторых действий от первого. Состояние гонок возникает, если один поток заканчивает свою работу раньше, чем другой, от которого он зависит. Из-за этого первый поток получает мусор вместо результатов, ибо второй еще не предоставил верных.
COM помогает предотвратить взаимоблокировки вызовов объектов. Существуют и некоторые функции, созданные для предотвращения состояния гонок во внепроцессных серверах.
Хотя COM и поддерживает старую модель, предполагающую наличие одного потока на процесс, создание кода, использующего преимущества многопоточности, делает возможным создание более эффективных приложений, давая возможность потоку работать, пока другой поток ожидает завершения длительной операции.
Стоит сказать и том, что многопоточность сама по себе не гарантирует лучшей производительности. Поскольку создание и синхронизация потоков – сложные задачи, использование многопоточности часто порождает проблемы производительности. Несколько потоков следует использовать только в том случае, когда вы твердо знаете, что делаете.
Самый простой путь понять архитектуру потоков, принятую в COM – это представить, что все COM-объекты в процессе разделены на группы, называемые апартаментами (apartments). COM-объекты всегда живут в одном апартаменте, в том смысле, что их методы могут быть легально вызваны только потоком, принадлежащим этому апартаменту. Любой другой поток, желающий вызвать объект, должен делать это через proxy.
Существует два типа апартаментов: однопоточные апартаменты (single-threaded apartments, STA) и многопоточные апартаменты (multi-threaded apartments, MTA).
Однопоточный апартамент (STA) – это апартамент, содержащий только один поток. COM синхронизирует все обращения к методам COM-объекта, находящегося в STA. Делается это через очередь сообщений Windows. Каждый поток клиентского процесса или внепроцессного (EXE) сервера, желающий работать в отдельном апартаменте, должен вызвать CoInitialize или CoInitializeEx с параметром dwCoInit, равным COINIT_APARTMENTTHREADED (эти вызовы и приводят к инициализации потока и выделению ему синхронизирующей очереди сообщений). Внутрипроцессные объекты, располагающиеся в DLL (в том числе COM+/MTS-объекты), регистрируют свою поточную модель в реестре с помощью именованного значения ThreadingModel внутри ключа InprocServer32. При передаче указателей на интерфейсы между разными STA, или между STA и MTA, должен обязательно производиться маршалинг. При передаче указателя на интерфейс как параметра метода какого-нибудь интерфейса, или при создании нового COM-объекта, маршалинг делается автоматически. Если необходимо вручную (без использования COM, например, через общую область памяти) передать указатель на интерфейс другому потоку, необходимо произвести «ручной» маршалинг.
Для «ручного» маршалинга используется функция CoMarshalInterThreadInterfaceInStream (пожалуй, эта функция – рекордсмен среди Win32 API-функций по длине имени). В качестве первого параметра ей передается IID интерфейса. В качестве второго – указатель на этот интерфейс. В качестве третьего – указатель на интерфейс IStream, в который и будет записана информация о передаваемом интерфейсе. Перед вызовом этой функции необходимо создать объект, реализующий интерфейс IStream. Самый простой способ сделать это – воспользоваться API-функцией CreateStreamOnHGlobal, создающей Stream, базирующийся на оперативной памяти. Последнее, что необходимо сделать – это из другого потока выполнить обратный маршалинг. Для этого необходимо вызвать CoGetInterfaceAndReleaseStream. Ручной маршалинг очень редко применяется на практике. Если же возникнет необходимость делать его часто, то можно создать простой класс-обертку, или воспользоваться глобальной (для процесса) таблицей интерфейсов. Она похожа на AOM (Active Object Map) в Corba. Управление глобальной таблицей интерфейсов производится через стандартный интерфейс IGlobalInterfaceTable. Указатель на него можно получить, создав COM-объект с CLSID CLSID_StdGlobalInterfaceTable. Еще один способ избавиться от «ручного маршалинга» – агрегировать специальный объект FreeThreadedMarshaler. Для создания такого объекта используется функция CoCreateFreeThreadedMarshaler. ATL Wizard позволяет автоматизировать всю работу по созданию и агрегированию ThreadedMarshaler.
При использовании STA нет необходимости в ручной синхронизации, ведь все вызовы и так происходят строго последовательно.
Процесс может содержать любое количество STA.
Многопоточный апартамент (MTA) – это апартамент, содержащий несколько потоков. MTA еще называют свободно-поточным. Маршалинг указателей на интерфейсы в MTA-апартаменте не производится, а любой компонент может получать вызовы своего метода из любого другого потока, входящего в этот же MTA. При этом вызовы методов компонента могут осуществляться параллельно. Параллелизм многопоточных объектов обеспечивает высочайшую производительность и полностью использует преимущества многопроцессорного аппаратного обеспечения. Он позволяет пользователям работать, не дожидаясь окончания длительных операций, выполняемых другими пользователями. Однако синхронизация, и вообще все, что связано с потокобезопасностью, возлагается на код вызываемого компонента. Для синхронизации при этом можно использовать стандартные средства Windows (Мьютексы, Семафоры, События и, конечно, оконные очереди). Создание корректно работающего многопоточного ПО – задача не из простых. Многопоточная отладка, пожалуй, самая неудобная сторона современного программирования, но получаемые преимущества зачастую перевешивают трудности.
Процесс может содержать только один MTA.
Все процессы имеют апартаментную модель, просто некоторые апартаменты содержат один поток, а некоторые – несколько. Поточная модель применима к апартаменту, а не к процессу. Она также может быть применима к CoClass’у но не к DLL-модулю. Разные классы в одной DLL могут иметь разные модели потоков. Но, все же, ATL позволяет определять так называемую глобальную потоковую модель, влияющую на потоковые характеристики всех входящих в модуль объектов.
Процесс, содержащий два или более STA, и не содержащий MTA, называется процессом с апартаментной моделью (apartment model process).
Процесс с одним потоком является частным случаем STA-модели. Такой процесс называется однопоточным (single-threaded process).
Процесс, содержащий MTA и один или более STA, называется процессом со смешанной моделью (mixed model process).
Процесс, содержащий MTA и не содержащий STA, называется свободно-поточным процессом (free-threaded process).
Главным апартаментом процесса считается тот, который был первым проинициализирован. В однопоточном процессе он остается единственным.
Модели потоков в COM предоставляют механизм совместной работы клиентов и серверов, использующие различные архитектуры потоков. Поддерживаются вызовы между объектами с разными моделями потоков как в разных процессах, так и внутри одного. С точки зрения вызывающего объекта все вызовы объектов вне процесса выглядят одинаково, неважно, какие потоки использует вызываемый объект, и наоборот.
В СОМ не существует аналогичной CORBA сессионной идеологии работы с потокками, когда все вызовы от одного клиента выполняются в одном потоке, а другого – в другом. Но если каждый клиент будет создавать отдельную копию STA-компонента, то внешне это будет похоже на сессионный метод CORBA. Единственное отличие заключается в том, что если двум таким компонентам взбредет в голову обратиться друг к другу, или к общему STA-компоненту, то в COM эти методы будут автоматически синхронизированы.
Выбор поточной модели для объекта зависит от назначения этого объекта. Объекту, управляющему некоторым общим ресурсом, (объекту, к которому производятся частые параллельные обращения), лучше поддерживать многопоточность. Это обеспечит максимальную эффективность при обслуживании клиентов. С другой стороны, объект, взаимодействующий с одним пользователем, может поддерживать STA для синхронизации вызовов.
Межпроцессная и межпоточная модели похожи. Если нужно передать указатель на интерфейс объекту в другом апартаменте (или потоке) в этом же процессе, используется такая же модель маршалинга, что и для объектов в разных процессах. С помощью указателя на стандартный объект маршалинга можно произвести маршалинг указателей на интерфейсы через границы потока (апартамента) так же, как и между процессами.
На сегодня большинство языков программирования позволяют создавать COM-объекты в STA-архитектуре, но только C++ позволяет создавать многопоточные компоненты. Библиотека ATL позволяют существенно облегчить эту непростую задачу. Скоро должна появиться седьмая версия VB. Разработчики обещают ввести в эту версию поддержку режима свободных потоков.
Масштабируемость Организация пула объектов.Организация пула объектов – сервис COM+, позволяющий создавать пул загруженных в память экземпляров объектов, готовых к использованию любым клиентом. Пул для компонента можно настраивать, задавая такие характеристики, как размер пула и значение таймаута. Пока приложение работает, COM+ управляет этим пулом, деталями активации и повторного использования объектов согласно заданным вами критериям. Пул объектов может существенно повысить производительность распределенного приложения. Когда клиент пытается создать новый объект, COM+, вместо того, чтобы лазить по реестру и загружать что-то в память, выделяет клиенту готовый объект из пула. После завершения клиентом работы с объектом и освобождения ссылки, COM+ не уничтожает объект, а снова возвращает его в пул.
Just-in-Time (JIT) -активацияJust-in-Time (JIT)-активация – предоставляемый COM+ сервис, помогающий более эффективно использовать ресурсы сервера, особенно при использовании большого количества транзакций. Если компонент сконфигурирован, как JIT-активируемый, COM+ будет порой деактивировать его экземпляр, несмотря на то, что клиент по-прежнему имеет активную ссылку на объект. При следующем вызове метода объекта клиентом, считающим объект активным, COM+ снова активирует объект прозрачно для клиента.
Преимущество такого подхода состоит в том, что клиент держит ссылку на объект столько времени, сколько ему нужно, не тратя ресурсов сервера, например, памяти.
Shared Property ManagerС помощью Shared Property Manager (SPM) можно в пределах одного COM+-приложения организовать набор свойств, хранящих общие данные для нескольких компонентов. Это позволяет получить простой способ передачи данных между компонентами, реализованными в разных DLL-библиотеках. При доступе к этим свойствам SPM автоматически осуществляет синхронизацию.
Обеспечение безопасностиБезопасность в COM основывается на службах безопасности Windows NT и Windows 2000, и механизме безопасности RPC. Базовыми понятиями являются аутентификация (процесс определения прав пользователя) и авторизация (процесс определения, имеет ли пользовать право делать то, что ему требуется). Два основных типа безопасности в COM – безопасность активации (activation security) и безопасность вызова (call security). Безопасность активации определяет, имеет ли клиент право запустить сервер. После запуска сервера вы можете использовать безопасность вызова для контроля доступа к серверным объектам.
Начиная с Windows NT 4.0, средства безопасности COM были значительно расширены. В новой модели серверы управляют объектами и защищают их, клиенты получают доступ к объектам через серверы, а серверы могут получать доступ от лица клиента.
В Windows 2000 реализованы протокол аутентификации Kerberos v5 и пакет средств безопасности SChannel. Появились такие возможности, как имперсонация на уровне делегирования (delegate-level impersonation), взаимная аутентификация (для протокола Kerberos), возможность устанавливать уровни аутентификации для AppID реестра, и маскировка (cloacking). Используя средства безопасности COM, можно реализовать объекты, способные выполнять привилегированные операции без ущерба для безопасности.
Два главных интерфейса, IClientSecurity и IServerSecurity, позволяют программно управлять безопасностью на уровне вызова.
Безопасность в COM+COM+ предоставляет средства безопасности, которые можно использовать для защиты приложений COM+. COM+ позволяет управлять защитой как с помощью визуального задания через Component Services атрибутов защиты, так и программно, вызывая в коде специальные API-функции. Вот краткое перечисление расширений стандартных механизмов защиты NT, появившихся в COM+:
Декларативная ролевая (основанная на ролях) безопасность. Программно реализуемая ролевая безопасность. Службы аутентификации. Заимствование прав/делегирование (Impersonation/delegation). Автоматически предоставляемые COM+ службы – ролевая безопасность и аутентификация – позволяют вынести всю функциональность, связанную с безопасностью, за пределы ваших компонентов. Достаточно включить и настроить соответствующие сервисы, и COM+ возьмет на себя детали обеспечения указанной политики безопасности.Какие механизмы использовать для каждого конкретного случая, зависит от требований приложения. Некоторые варианты могут повлиять на создание компонентов, некоторые – на весь дизайн приложения. Комбинацию средств безопасности следует подбирать, исходя из общих требований и назначения приложения – требований к производительности, доступа к данным и так далее.
Ролевая безопасность – главное средство безопасности приложений COM+. Используя роли, можно автоматически создать политику авторизации, указывая (если нужно, вплоть до уровня метода), кому какие ресурсы доступны. Кроме этого, ролевую безопасность можно применять программно, если приложение требует более тщательного контроля доступа.
Аутентификация – прежде, чем авторизовать клиентов для доступа к ресурсам, следует убедиться, что они – именно те, за кого себя выдают. Это и делают службы аутентификации COM+. Вы просто административно включаете сервис аутентификации, работающий прозрачно для приложения.
Заимствование прав/делегирование (Impersonation/Delegation) – иногда приложению нужно выполнить некие действия от имени клиента, используя права клиента, например, при доступе к БД, аутентифицирующей клиента. Это называется заимствованием прав, или имперсонацией. Возможны разные уровни имперсонации. Чтобы задействовать ее, следует, во-первых, административно ее настроить, и, во-вторых, прописать её поддержку в коде компонентов приложения.
Сегодня реально существуют три уровня имперсонации: идентификация (identify), имперсонация (impersonate), и делегация (delegate). До появления W2K их было два – идентификация и имперсонация. В W2K появился третий, делегация.
На уровне идентификации (RPC_C_IMP_LEVEL_IDENTIFY), используемом системой по умолчанию, сервер может получить атрибуты защиты клиента. Сервер может использовать эти атрибуты защиты для проверок ACL. На уровне имперсонации (RPC_C_IMP_LEVEL_IMPERSONATE), сервер может имитировать контекст безопасности клиента, действуя от его лица. Сервер может работать с локальными ресурсами как клиент. Если это локальный сервер, он может от имени клиента обращаться к сетевым ресурсам. Если же удаленный, то он может работать только с ресурсами той машины, где он находится. Уровень делегации – наиболее мощный уровень имперсонации. При выборе этого уровня сервер (локальный или удаленный) также имитирует контекст безопасности клиента, действуя от его лица. В процессе имперсонации и локальные, и сетевые права клиента могут быть переданы любому количеству машин.Для работы на уровне делегации нужно выполнять следующие требования:
Клиент должен установить уровень имперсонации RPC_C_IMP_LEVEL_DELEGATE. Учетная запись клиента не должна быть помечена как "Account is sensitive and cannot be delegated" в Active Directory Service. Учетная запись сервера должна быть помечена в Active Directory Service атрибутом "Trusted for delegation". Все задействованные компьютеры должны работать под W2K и в домене W2K (поскольку требуется протокола Kerberos).Выбором уровня имперсонации клиент сообщает серверу, как далеко тот может зайти. Клиент задает уровень имперсонации через proxy, используемую для связи с сервером.
Контрольный журнал (Audit Trails) – ролевая безопасность позволяет отслеживать обращения к вашему компоненту, вплоть до ведения детальных логов.
Безопасность активацииБезопасность активации (называемая также безопасностью запуска) контролирует, кто имеет право запускать сервер. Эту службу автоматически исполняет Service Control Manager (SCM) конкретной машины. При получении запроса на активацию объекта от клиента, SCM проверяет запрос на основе информации, хранящейся в его реестре (в том числе и для вызовов, поступающих с этой же машины).
W2K, определяя права клиента при активации, проверяет, установлен ли клиентом флаг маскировки. Клиент может сделать это, вызвав CoInitializeSecurity. Если да, то для идентификации клиента используется маркер потока (если он имеется). Если маскировка выключена, вместо маркера потока используется маркер процесса.
Windows 9х и MacOS не поддерживают безопасности активации.
Маскировка (Cloaking)Маскировка определяет, от чьего имени клиент обращается к серверу в процессе имперсонации. Если включить маскировку, промежуточный сервер будет предъявлять вызываемому серверу права пользователя, от имени которого делается вызов. В сущности, личность клиента, видимая серверу – это клиент, ассоциированный с proxy. Права proxy определяются несколькими факторами, один из которых – заданный тип маскировки.
Безопасность в Windows 95 и Windows 98Если сеть построена из машин под Windows 9х, важно, имеется ли в сети домен Windows NT/W2K. Если домен присутствует, то Windows 9х может обеспечить аутентификацию и авторизацию через сквозной механизм безопасности. Если же нет, то проверка безопасности при вызовах невозможна.
Поскольку по умолчанию COM пытается выполнить проверку безопасности, то для успешного вызова COM-сервера клиентом в сети Win9х нужно изменить настройки COM, отключив проверку безопасности.
Устойчивость к сбоям ContextСам по себе контекст не имеет отношения ни к устойчивости к сбоям, ни к другим возможностям COM+, но именно через него производится управление сервисами, ответственными за это.
Context – новинка MTS, COM+ и Windows 2000. Каждый COM-объект создается с ассоциированным контекстом. В случае объектов, не использующих служб COM+, контекст в значительной степени игнорируется. Но для приложений, сконфигурированных в COM+, контексты – это основа, на которой обеспечивается сервис COM+.
Контекст – это, в сущности, набор runtime-свойств одного или нескольких объектов. Каждый COM-объект во время исполнения (то есть, между его активацией и деактивацией) ассоциирован с единственным контекстом. Каждый контекст существует в единственном апартаменте COM, но в одном апартаменте могут сосуществовать несколько контекстов. В одном контексте могут исполняться несколько объектов. (Следует пояснить, что объекты, агрегирующие Free Threaded Marshaller, являются исключением – они исполняются в любом контексте).
COM+ использует контекстные свойства как основу предоставляемых run-time служб. Эти свойства содержат состояние, которое определяет, как среда исполнения будет осуществлять сервис для объектов в контексте. Изменяя эти свойства, можно влиять на состояние и поведение run-time служб СОМ+.
Каждому контексту соответствует ассоциированный объект, ObjectContext, следящий за его свойствами. Вы можете получить доступ к ObjectContext, вызвав CoGetObjectContext. Получив ObjectContext, вы можете воспользоваться его интерфейсом IObjectContext для работы с контекстными свойствами.
Кроме IObjectContext есть еще несколько специализированных интерфейсов для доступа к контекстным свойствам: IObjectContextInfo, IContextState и IObjectContextActivity.
ТранзакцииMTS и COM+ поддерживают так называемый «механизм автоматических транзакций». Транзакции выполняются на уровне компонентов, т.е. каждый компонент, участвующий в транзакции необходимо специальным образом пометить. Это можно сделать как визуально, так и программно. Run-time система COM+ считывает эту информацию и исходя из нее, создает для компонента новую транзакцию или помещает компонент в уже существующую. Компонент может управлять транзакцией с помощью контекста компонента (см. «Context»).
Compensating Resource ManagerCompensating Resource Managers (CRM) – эта особенность Component Services позволяет просто интегрировать ресурсы приложений с транзакциями Microsoft Distributed Transaction Coordinator (MS DTC). Это альтернатива разработке полного менеджера ресурсов Microsoft Transaction Services. С помощью пары COM-компонентов и реализации специфичных интерфейсов ресурсы вашего приложения могут влиять на результат транзакции и получать оповещение о ее результате.
CRM – это пара компонентов COM – CRM Worker и CRM Compensator. CRM Worker отвечает за основную часть работы CRM и реализует COM-интерфейс, характерный для выполняемой им задачи. Инфраструктура CRM предоставляет интерфейс к CRM Worker, через который CRM Worker может помещать записи в лог-файл. Эти записи применяются для правильного восстановления данных в случае сбоя.
CRM Compensator – компонент, создаваемый инфраструктурой CRM после завершения транзакции. Он реализует определенный интерфейс, через который инфраструктура CRM может передать уведомления о завершении транзакции и записи в лог-файле, сделанные CRM Worker.
Использование кластеров серверовW2K Advanced Server и Data Center позволяют организовать кластеры из нескольких серверов. Это обеспечивает дополнительную устойчивость серверных COM+-приложений за счет автоматического переключения на другой сервер в случае сбоя одного из них. Использование продукта Microsoft AppCenter Server позволяет распределять нагрузку между серверами с помощью CLB (COM+ Load Balancing), что дает возможность запуска компонентов на наименее загруженном сервере. Это повышает производительность и доступность приложения.
Асинхронное взаимодействие между объектами Queued Components QC-компоненты являются модификацией COM+/MTS-компонентов. QC-компоненты отвечают требованиям механизма Store-and-Forward. Клиентское приложение может использовать QC-компоненты, так же, как любой другой COM-объект. Они основаны на COM, но в качестве транспортного протокола вместо RPC используют MSMQ-сервис (сервис асинхронной работы с очередями сообщений от Microsoft). Классический DCOM использует синхронный RPC для передачи информации от одного компьютера другому посредством заместителей (proxy) и заглушек (stub).QC взаимодействует между клиентским proxy и stub сервера с помощью MSMQ.
Во время активизации QC-объекта, клиент подключается не к COM-объекту, а к Са11 Recorder’у. Клиентское приложение производит вызовы как обычно, но они не отправляются немедленно через RPC. Вместо этого информация о них записывается в очередь MSMQ. Когда клиент деактивирует компонент (вызывает Release()), QC использует MSMQ для асинхронной посылки последовательности вызовов серверу, на котором создается реальный компонент. Сервер читает сообщения из MSMQ-очереди, содержащей эту последовательность, активизирует компонент Player (исполнитель) и передает ему информацию о вызовах. Player создает реальный объект и воспроизводит на нем вызовы.
Достоинства QC:
QC является высокоуровневой технологией. С его помощью проще программировать, чем при прямом использовании MSMQ. Не нужно учитывать мелкие технологические детали. Создаваемые разработчиком COM-компоненты могут быть использованы асинхронно как через QC сервис, так и синхронно, через DCOM.С помощью QC-компонентов можно реализовать режим работы off-line и добиться полной независимости клиента от сервера. Их единственным недостатком является то, что они доступны только на W2K.
COM+ EventsРаспределенные приложения, в которых сервер должен оповещать клиентов об изменениях важной для них информации, встречаются довольно часто. В таком приложении трудно понять, кто является сервером, а кто – клиентом. Клиенты в момент получения уведомлений сами становятся серверами. Чтобы избежать путаницы, следуя примеру Microsoft, назовем программу, рассылающую сообщения «Издателем» (Publisher), а приложения, заинтересованные в получении уведомлений – «Подписчиками» (Subscriber).
Система поддержки событий COM+ – это служба операционной системы, предоставляющая базовые сервисы поддержки событийного механизма. Событие в этой системе описывается как метод некоторого COM-интерфейса. Интерфейс необходимо поместить в «COM+»-объект, который в свою очередь специальным образом зарегистрировать в системе поддержки событий. Не правда ли, очень похоже на сказку про Василису прекрасную – «Смерть кощеева на конце иглы, игла в яйце, яйцо в утке, утка в зайце...». Рассылка событий – процесс, инициируемый издателем и осуществляющий уведомление подписчиков о случившемся событии. Издатель – любая программа, инициирующая событие посредством вызова метода интерфейса, принадлежащего событийному объекту. Подписчик – «COM+»-объект, реализующий тот же самый событийный интерфейс, что и событийный класс. Подписчик должен быть зарегистрирован как обычный «COM+»-компонент. Для того чтобы получать уведомления о событиях необходимо, чтобы для этого подписчика была оформлена (создана) подписка. Подписка – формальная регистрация производящаяся на компьютере где установлен класс событий. Сама подписка производится в ветке subscriptions на зарегистрированном здесь же подписчике. Класс событий (или Событийный класс) – «COM+»-объект, содержащий событийный интерфейс. Этот объект должен быть специальным образом зарегистрирован в системе поддержки событий. Ни одного экземпляра этого класса никогда не создается. При попытке создания экземпляра этого класса система поддержки событий создает специальный событийный объект, указатель на который и передается Издателю. Событийный объект – квази-компонент создаваемый на базе описания событийного интерфейса, взятого из событийного класса. Событийный интерфейс – интерфейс, который должны реализовать все подписчики, которые хотят получать уведомления о событиях. Вызов методов этого событийного интерфейса и инициирует рассылку сообщений. Заметьте, что подписка может быть осуществлена на конкретный метод этого интерфейса, но реализовать интерфейс придется полностью. Это не проблема, так как VB скрывает сложности реализации интерфейсов, а в VC есть визард, автоматизирующий эту операцию.
Подписчик реализует интерфейс как COM-сервер; издатель делает вызовы как COM-клиент. Единственным отличием от классического COM является выступающая посредником между издателем и подписчиком система поддержки событий, которая отслеживает подписчиков, желающих получать уведомления и направляет им эти вызовы. При этом система поддержки событий не нуждается в каких-либо специфических знаниях об издателе.
Издатель создает событийный объект вызовом функции CreateObject (CoCreateInstance – для C++).
Через вызов необходимого метода событийного интерфейса издатель инициирует рассылку уведомлений о событии (на языке американских программистов – производит Firing).
Система поддержки событий просматривает базу данных (COM+ каталог) в поисках зарегистрированных подписчиков (на соответствующий интерфейс или метод). Она связывается с подписчиками (создавая их напрямую, через моникер или Queued-компонент, как указано в базе данных подписки («COM+»-каталоге)) и уведомляет их о событиях, вызывая у них соответствующий метод событийного интерфейса.
Регистрируя класс событий, мы сообщаем системе поддержки событий, какие интерфейсы и методы содержит класс событий. Описание класса событий хранится в COM+-каталоге. Произвести регистрацию можно либо с помощью средств администрирования COM+, либо программным способом.
В системе поддержки событий подписку производит наделенное администраторскими правами лицо (через консоль Component Services) или программа. Подписка – это структура данных, снабжающая сервис событий информацией о подписчике. Она определяет, кто и от кого будет получать уведомления. Естественно, в терминах COM «кто и от кого» определяются через CLSID соответствующих объектов. Кроме CLSID подписчика можно вдобавок указывать и имя компьютера, на котором необходимо создавать объект-подписчик.
Подписка может быть постоянной (persistent) или временной (transient). В случае постоянной подписки COM+ сам создает объект подписчика (на машине подписчика) так же, как и в случае с QC. Transient-объект должен быть создан вручную и подключен через соответствующий API. Вышесказанное означает, что постоянный объект можно регистрировать визуально, но он не может загружаться в адресное пространство клиентского приложения. Постоянный объект может переживать перезагрузку компьютера. Transient-объект не переживает перезагрузки, но может быть создан внутри любого приложения. Как издатель, так и подписчик могут быть Queued-компонентами и, соответственно, работать асинхронно.
Подробнее о COM+ Events можно прочесть в номере нашего журнала за 4 квартал 1999 года.
Асинхронные вызовыВ W2K появилась возможность осуществлять асинхронные вызовы компонентов без использования Queued-подсистемы. При этом асинхронность достигается за счет вызовов в отдельных потоках. Подробнее об этой технологии вы можете прочесть в статье «Асинхронные вызовы методов COM-компонентов в Windows 2000» в этом номере журнала.
Впервые статья была опубликована в журнале <Технология Клиент-Сервер>. Эту и множество других статей по программированию, разработке БД, многоуровневым технологиям (COM, CORBA, .Net, J2EE) и CASE-средствам вы можете найти на сайте http://www.optim.ru/ и на страницах журнала. Ваши предложения и замечания вы можете посылать по адресу tcs@optim.ru.
Загрузка нескольких RTF файлов в RichEdit.
Автор: McAndrews
//Кидаем на форму RichEdit1, Button1, OpenDialog1
//и по клику кнопки создаём следующую процедуру:
procedure TForm1.Button1Click(Sender: TObject);
var
i, nFiles: integer;
FileNames, UnitedText, Separator, Tmp: string;
TextStream: TStringStream;
begin
TextStream := TStringStream.Create('');
Separator := '\par \par \par '; // это разеделитель между выводимыми
// файлами, в данном случае - 3 параграфа
UnitedText := '';
OpenDialog1.Options := OpenDialog1.Options
// что бы можно было выбрать несколько
+ [ofAllowMultiSelect]; // файлов
RichEdit1.MaxLength := $7FFFFFF0; // предусмотрительно увеличиваем максимальный
// объём загружаемых данных в RichEdit1
try // а вдруг что..
if OpenDialog1.Execute then
begin
nFiles := OpenDialog1.Files.count - 1;
for i := 0 to nFiles do
begin
FileNames := OpenDialog1.Files.Strings[i];
RichEdit1.Lines.LoadFromFile(FileNames);
// открываем каждый файл поочереди
// в RichEdit1
RichEdit1.Lines.SaveToStream(TextStream);
// и записываем данные уже от туда в
// поток TextStream,
Tmp := TextStream.DataString; // а из потока во временную
// переменную Tmp типа String,
TextStream.Position := 0; // ставим указатель в потоке на 0,
if i = 0 then // проверяем - является ли данный
Tmp := copy(Tmp, 0, length(Tmp) - 5) // файл первый, последним, или
else if i = nFiles then // или между ними, в зависимости
Tmp := Separator + copy(Tmp, 2, length(Tmp))
// от этого удаляем управляющие
else // символы начала или окончания
Tmp := Separator + copy(Tmp, 2, length(Tmp) - 5);
// RTF-файла и всталяем разделитель.
// дело в том, что каждый RTF-файл
// начинаетсz c символа '{' и заканчивается '}'.
UnitedText := UnitedText + Tmp; // записываем всё в переменную UnitedText
end;
TextStream.WriteString(UnitedText);
// помещаем уже объеденённый текст в поток
TextStream.Position := 0; // ставим указатель на 0
RichEdit1.Lines.LoadFromStream(TextStream);
// и записываем потом в RichEdit1
end;
finally
TextStream.Free;
end;
end;
Формат Rich Text (RTF).
| Встречаются вирус и FAT. - Привет, ты кто? - Я? Вирус. - A я AFT, то есть TAF, то есть FTA, черт, совсем запутался... |
Данный формат был определен фирмой Microsoft как стандартный формат для обмена текстовыми документами. Следовательно, по назначению этот формат подобен SYLK-формату для электронных таблиц. RTF поддерживается многими продуктами фирмы Microsoft. Так, например, начиная с версии 2.0, он введен в Windows в качестве Clipboard-формата, благодаря чему возможен обмен данными между различными прикладными программами Windows. Кроме того, RT-формат поддерживается программами WORD для Macintosh, начиная с версии 3.X, и WORD для PC, начиная с версии 4. X.
В RTF для обмена документами используются только представимые символами коды из ASCII-, MAC- и PC-символьного набора. Кроме текста, файл в RT-формате в читаемой форме содержит команды управления.
Документ состоит преимущественно из команд управления настройки программы чтения файлов в RTF-формате. Эти команды можно разделить на управляющие слова (control words) и управляющие символы (control symbols).
Управляющее слово представляет собой последовательность символов с разделителем (delimiter) в конце:
\lettersequence <delimiter> |
Перед управляющим словом вводится обратная косая черта "\" (backslash). В качестве разделяющих могут использоваться следующие символы:
Ш Пробел (space), причем этот символ относится к управляющему слову; Цифра или знак "-". После этих символов должен следовать параметр с разделителем. В качестве разделителя может быть использован пробел или другие символы, кроме цифр и букв;Все символы, отличные от цифр и букв. Эти символы не относятся к управляющему слову.
В RT-формате для задания управляющей последовательности используются буквы от "А" до "Z" и от "а" до "z", а также цифры от "0" до "9". Национальные символы к управляющей информации не относятся.
В качестве, управляющих символов используются отдельные буквы. Перед каждым управляющим символом вводится обратная косая черта "\":
\control symbol |
В настоящее время определены только некоторые из этих символов. Поэтому при чтении неизвестные символы могут быть пропущены.
В RT-формате существует возможность объединять отдельные последовательности в группы при помощи скобок:
{ начало группы } конец группыТакие группы создаются, например, при описании сносок, колонтитулов и т.п. Если необходимо разместить символы "\", "{" или "}" внутри обычного текста, то перед ними надлежит поставить обратную косую черту:
\\ \{ \}.Это позволяет программе, читающей RTF-последовательность, распознать, что символ не следует интерпретировать как управляющий.
В RT-формате используются также некоторые символьные коды для управления печатью.
| Код | Значение |
| 09Н | Табулятор |
| 0АН | Символ CR |
| 0СН | Символ LF |
Символы CR и LF, расположенные внутри текста, будут пропущены. Microsoft использует эти символы для большей наглядности при представлении RTF-файла. Внутри управляющих слов символы CR и LF могут иметь особое значение, подробнее об этом будет сказано при описании команд.
Специальные управляющие слова (special control words).
В RTF имеются управляющие слова специального назначения. Ниже приведены эти слова и их назначение.
\chpgn Управляющее слово change page number выводит текущий номер страницы. \chftn Управляющее слово change footnote активизирует автоматическую нумерацию сносок. \chdate С помощью change date можно вывести текущую дату. \chtime С помощью change time можно вывести текущее время. \chatn Ссылка на примечание (текст следует в группе). \chftnsep Свидетельствует об изменении линии, отделяющей сноски от текста. \/ С помощью данной последовательности вводится текст формулы. \: Обозначает подпункт индекса. \* Текст может быть пропущен при чтении RTF-формата. \~ Задает жесткий (неразрываемый) пробел между двумя словами, т.е. в этой позиции предложение не может быть разделено при переносе на следующую строку. \- Символ обозначает мягкий перенос (nonrequired hyphen). \_ Символ обозначает неразрываемый перенос (nonbreaking hyphen), на месте которого слово не может быть разделено. \'hh Последовательность позволяет прямой ввод в тексте шестнадцатеричных чисел. Они задаются вместо символов hh. \page Данная последовательность задает переход на новую страницу. \line Эта последовательность вызывает переход на новую строку в тексте. \раг С помощью данной последовательности в тексте отмечается конец абзаца. Последовательность \раг может заменяться последовательностью \10 или \13. При этом \10 соответствует ASCII-символу с кодом 10 (carriage return). Непосредственно ввести ASCII-код 10 (CR) нельзя, т.к. он игнорируется программой чтения. \sect Эта последовательность обозначает конец текстового фрагмента или текстового абзаца. \tab Данная последовательность заменяет табулятор. Можно также непосредственно задавать ASCII-код 09Н. \се11 Конец таблицы (столбец). \row Конец таблицы (строка).Операторы настройки (destination control words).
С помощью описанных ниже управляющих слов можно произвести основную настройку программы чтения RTF. Они могут встречаться только в начале документа или в начале группы. Все операторы вместе с параметрами должны быть заключены в скобки, например:
{\rtf0\pc.......}
|
Ниже описан формат некоторых операторов.
\rtf <параметр> |
Задает метку начала файла. В качестве параметра программа, при помощи которой создается файл, может указывать номер версии. Например:
{\rtf0.......}
|
Метка должна стоять в начале файла. После этого оператора могут следовать другие операторы или закрывающая скобка.
Установка вида кодировки для сохраняемого текста осуществляется с помощью следующих операторов:
\ansi: текст хранится в стандартном ASCII-формате. Этот формат используется, например, в Windows. \mac:. текст хранится в кодировке Macintosh \рс: для вывода текста используется кодировка символов IBM-PC. \рса: IBM-PC Code Page 850 (модель PS\2).Для передачи текстов между различными системами должна использоваться кодировка \ansi.
\colortblWindows и другие программы пользуются палитрами для определения используемых цветов. Чаще всего палитра состоит из 16 различных цветов, получаемых путем комбинации основных цветов - красного, зеленого и синего. Команда \colortbl позволяет изменить отдельные определения в палитре. Для каждого цвета в таблице указывается величина красной, зеленой и синей составляющей. Каждый цвет описывается тремя параметрами:
\red000 \green000 \blue000Вместо 000 указывается величина доли цвета в диапазоне от 0 до 255. Пример: в таблице, состоящей из 16 цветов, должны быть заново определены цвета 0-й и 2-й. Для переопределения цветов может быть задана следующая последовательность:
{ \colortbl \redl28\green64\bluel28\;;\red0\green64\bluel2 8; }
|
Определение цвета завершается точкой с запятой. Поскольку 1-й цвет остается без изменений, в последовательности два символа ";" следуют один за другим. Последовательность завершается закрывающей скобкой.
Оператор \cfn определяет цвет фона (при стандартной настройке n=0), а оператор \cbn - цвет символа (при стандартной настройке n=0).
\fonttblДанный оператор используется для построения таблицы шрифтов и соотносит имя шрифта (группы шрифтов) с номером шрифта. При определении шрифта можно использовать следующие операторы:
\fnil: имя группы шрифтов неизвестно. При выводе должен использоваться стандартный шрифт. \froman: должны использоваться шрифты группы Roman (например, Times Roman) \fswiss: этот оператор предписывает использование шрифтов из группы Swiss (Helvetica, Swiss и т.д.) \fmodern: могут использоваться шрифты Pica, Elite и Courier. \fscript: используются курсивные шрифты группы Script. \fdecor: при указании этого оператора шрифты должны выбираться из группы Decor (Old English и т.д.). \ftech: выбор группы шрифтов с техническими и математическими символами (SYMBOL и т.д.).Команда для создания группы шрифтов может состоять из таких операторов:
{\fonttbl\f0\fnil default;}
{\fl\froman roman h;}
{\f2\fswiss helvetica;}
|
После ключевого слова \fonttbl следует первый номер шрифта \f0. Далее идет определение группы шрифтов. Здесь после номера 0 указано \fnil, т.е. имя группы неизвестно. Следующий параметр обозначает имя выбираемого шрифта (например, roman h). Указание default говорит считывающей программе о том, что следует использовать стандартный шрифт. После имени шрифта стоит точка с запятой. В приведенном примере определены только шрифты с номерами 1 и 2. Вся последовательность может быть объединена фигурными скобками в группу.
Таблица шрифтов должна быть заполнена значениями до того, как встретится оператор \stylesheet или текст. Стандартный шрифт вводится оператором \deffn.
\stylesheetЭтот оператор определяет шрифт абзаца, т.е. размер, начертание и имя гарнитуры, а также способ выравнивания текста абзаца. При этом используются два ключевых параметра:
\sbasedon000: вместо символов 000 указывается номер вида шрифта, который используется в качестве текущего. \snext000: назначает номер следующего вида шрифта (style), который - станет текущим.Оператор может иметь, например, следующий вид:
{\stylesheet\s0\f3\fs20\qj Normal;}
{\sl\f3\fs30\b\qc Heading Level 3;}
|
Шрифты нумеруются числами от 0 до n (\s0...). В первой строке стилю абзаца 0 (\s0) предписывается имя Normal. Вывод текста выполняется шрифтом 3 (\f3), размером 10 пунктов (\fs20). Параметр \qj говорит о том, что надпись должна выравниваться по формату. Вторая строка определяет стиль шрифта 1, который получает имя Heading Level 3. Шрифт имеет размер 15 пунктов, жирное начертание (\Ь = bold) и при выводе надпись центрируется (\qc).
\pictЭтот оператор используется при описании рисунка в формате битовой карты (bitmap). Следующие параметры содержат описание рисунка в виде шестнадцатеричных значений. Параметры могут быть выборочно использованы для определения геометрии рисунка или его формата:
\pich000: оператор указывает высоту рисунка в пикселях. Вместо трех нулей подставляется числовое значение. Если оператор отсутствует, высота рисунка определяется из текущих графических данных. С помощью параметра можно задать для рисунка определенную высоту. \piw000: оператор задает ширину рисунка в пикселях. Справедливо все, сказанное о предыдущем операторе. \picscaled: с помощью этого оператора рисунок масштабируется таким образом, чтобы он точно заполнял отведенную для него область. \ wmetafilen: параметр указывает, что данные хранятся в формате Windows-метафайла. Параметр n определяет тип метафайла (1 = ММ-текст). \macpict: параметр указывает, что данные хранятся в Macintosh-формате Quick-Draw. \bin000:. параметр определяет количество байтов. Вместо трех нулей записывается шестнадцатеричное число. \wbitmapn: параметр определяет формат bitmap-рисунка. Параметр n задает тип (0 соответствует логической битовой карте). \brdrs: определяет простую рамку для рисунка \brdrdb: определяет двойную рамку для рисунка. \brdrth: определяет жирную линию для рамки рисунка. \brdrsh: определяет затененную рамку для рисунка \brdrdot: определяет для рисунка пунктирную линию. \brdrhair: определяет тонкую линию для рамки рисунка. \picwGoaln: задает желаемую ширину рисунка в twips \pichGoaln: задает желаемую высоту рисунка в twips. \picscalexn: задает горизонтальное масштабирование (n может принимать значения от 1 до 100, по умолчанию -10). \picscaleyn: задает вертикальное масштабирование (n может принимать значения от 1 до 100, по умолчанию - 10). \piccroptn: описывает верхнее поле рисунка в twips. При положительных значениях параметра n верхняя часть рисунка обрезается. Отрицательные значения n дают возможность построить вокруг рисунка рамку. Стандартное значение n равно 0. \рiссгорьп: описывает нижнее поле рисунка в twips. При положительных значениях параметра n нижняя часть рисунка обрезается. Отрицательные значения n дают возможность построить вокруг рисунка рамку. Стандартное значение n равно 0. \рiссгоргn: описывает правое поле рисунка в twips. При положительных значениях параметра n рисунок обрезается справа. Отрицательные значения n дают возможность построить вокруг рисунка рамку. Стандартное значение n равно 0. \piccropln: описывает левое поле рисунка в twips. При положительных значениях параметра п рисунок обрезается слева. Отрицательные значения п дают возможность построить вокруг рисунка рамку. Стандартное значение п равно 0. \wbmbitspixeln: определяет количество битов, приходящихся на пиксел, для bitmap-рисунка (стандартное значение равно 1). \ wbmplanesn: определяет количество битовых плоскостей (стандартное значение равно 1). \wbmwidtbbytesn: определяет длину битовой карты в байтах. \footnote Оператор должен следовать непосредственно после отметки сноски и относиться к тексту. \header Оператор определяет верхний колонтитул текущего фрагмента текста и поэтому должен указываться в начале текста. \headerl Оператор определяет верхний колонтитул четной страницы (left hand header), на которой колонтитул выводится с выравниванием влево. \headerr Оператор устанавливает верхний колонтитул нечетной страницы, на которой колонтитул выводится с выравниванием вправо (right hand header). \headerf Оператор устанавливает верхний колонтитул первой страницы (first page header). \footer Оператор устанавливает нижний колонтитул текущего фрагмента и должен указываться перед началом текста. \footerl Оператор устанавливает нижний колонтитул четной страницы (left hand footer), на которой колонтитул выводится с выравниванием влево. \footerr Оператор устанавливает нижний колонтитул нечетной страницы, на которой он выводится с левосторонним выравниванием (right hand footer). \footerf Оператор устанавливает нижний колонтитул первой страницы (first page footer). \ftnsep Оператор определяет символ-разделитель для сносок. \ftnsepc Оператор определяет разделитель для сноски, которая продолжается на следующей странице (continued footnote). \ftncn Этот оператор применяется для обозначения продолжения текста сноски. \info С помощью данного ключевого слова в начале документа открывается информационный блок. Он может содержать информацию о заголовке документа, дате его составления и т.д. Внутри информационного блока, который начинается оператором \info, могут встречаться следующие операторы: \title \subject \operator \author \keywords \doccomm \version \nextfile Перечисленные команды позволяют передавать вспомогательную информацию о документе, например, имя автора, версию текста, заголовок и т.д. Программа чтения RTF-данных не обязана обрабатывать команды информационного блока. \vern000 Вместо 000 в операторе записывается номер версии программы, в которой составлен документ. \creatim С помощью данного ключевого слова определяется дата и время создания документа. Эти данные кодируются с помощью таких операторов: \угО00: год создания документа \тоО00: месяц создания документа \dy000: день создания документа \hr000: время создания документа в часах \min000: время создания документа в минутах \sec000: время создания документа в секундах \revtim Определяет время и дату последней корректировки документа. Оба параметра задаются так, как указано в описании оператора \creatim. \printtim Определяет время и дату последней распечатки документа. Оба параметра задаются так, как указано в описании оператора \creatim. \buptim Определяет время и дату последнего сохранения документа (backup). Оба параметра задаются так, как указано в описании оператора \creatim. \edmins000 Хранит длительность (в минутах) последнего сеанса редактирования. \nofpages000 \nofwords000 \nofchars000 \id000 Вышеуказанные операторы содержат уточняющую информацию о документе (количество страниц, количество слов и количество символов), а также внутренний идентификационный номер. \comment В заголовке может встретиться текст, помеченный ключевым словом \comment. В этом случае речь идет о комментарии в тексте, который пропускается программой чтения данных в RTF-формате. \field Имеется группа операторов, при помощи которых описываются поля, вставляемые в WORD. Группа начинается ключевым словом \field, за которым могут следовать такие операторы: \flddirty: поле было изменено во время последней актуализации \fldedit: текст был отредактирован во время последней актуализации \fldlock: поле закрыто для доступа и не может быть актуализировано \fldpriv: результат не сообщается (например, рисунок) \xe Эта группа операторов начинается последовательностью символов \xe и может содержать следующие ключевые слова: \ьхе: для номеров страниц задается жирное начертание (bold). \ixe: для номеров страниц задается курсивное начертание (italic). \txe text: вместо номера страницы используется текст. \гхе bookmark: генерация номеров страниц для области, содержащей закладку (bookmark). \tc Группа содержит элементы данных для таблиц и может состоять из следующих ключевых слов: \tcfn: передается тип таблицы (n может иметь значения от А до Z, значение по умолчанию - С). \tcln: номер уровня (стандартное значение n = 1). В группу операторов, определяющих закладки, входят только два оператора: \*\bkmkstart: начало области \*\bkmkend: конец областиОператоры форматирования (document formatting).
В следующую группу входят команды для форматирования текста. Эти команды могут быть разделены на подгруппы:
команды, действие которых распространяется на весь текст, команды, изменяющие формат только текущего абзаца, команды, которые относятся к текущему выводу текста.В этом разделе описываются операторы форматирования всего документа.
\paperw000 Команда задает ширину листа в twips (1 twip равен 1/20 пункта или 1/1440 дюйма). Значение ширины указывается вместо 000. Если команда отсутствует, то ширина листа устанавливается равной 12240 twips. \рарегhО00 Команда задает высоту листа в twips. Значение высоты указывается вместо 000. Если команда отсутствует, то высота листа устанавливается разной 15840 twips. \margl000 С помощью этой команды можно установить ширину левого поля при печати в twips. Стандартная ширина поля равна 1800 twips. \margr000 С помощью этой команды можно установить ширину правого поля при печати в twips. Стандартная ширина поля равна 1800 twips. \margt000 С помощью этой команды можно установить ширину верхнего поля (margin top) при печати в twips. Стандартная ширина поля равна 1440 twips. \margb000 С помощью этой команды можно установить ширину нижнего поля (margin bottom) при печати в twips. Стандартная ширина поля равна 1440 twips. \facingp Оператор facing page определяет внешний вид страницы. Он устанавливает например, печатается колонтитул на четных или на нечетных страницах. Если з; оператором следует параметр 0, то вывод подавляется. \gutter000 С помощью этого оператора можно установить ширину поля подшивки (gutter внутри facing page. \deftab000 Команда определяет величину табулятора. Стандартное значение составляет 72 twips. \widowctrl Оператор включает wido-контроль. Если за оператором следует параметр 0, то контроль снова отключается. \endnotes Если в документе указан этот параметр, то тексты сносок размещаются в конце фрагмента. \ftobj По умолчанию тексты сносок выводятся в конце страницы (footnotes bottom justified). Данный оператор позволяет переключиться с установки, заданной опер тором \endnotes, на стандартную установку. \ftntj Тексты сносок выводятся в тексте (footnotes top justified). \ftnstart000 Вместо 000 команда содержит начальный номер первой сноски. Стандартное значение номера равно 1. \ftnrestart При указании этого оператора нумерация сносок на каждой странице начинается с 1. Параметр 0 отключает эту установку. \pgnstart000 Вместо 000 команда содержит номер начальной страницы. Стандартное значение номера равно 1. \linestart000 Значение, указанное вместо 000, задает номер начальной строки. Стандартное значение номера равно 1. \landscape Команда позволяет задать альбомную ориентацию (landscape). При указании параметра 0 восстанавливается книжная ориентация. \byphhotz Определяет область, которая обозначается как - Hyphenation hot zone. \ftnsep Определяет разделитель, который отделяет сноски от текста. \ftnsepc Определяет разделитель, который отделяет сноски, продолжающиеся на следующую страницу, от текста. \ftncn Отметка для следующей сноски. \enddoc Сноска в конце документа. \*\nextfile Передает (в скобках {}) имя файла вывода или индексного файла. \*\template После оператора в скобках {} указано имя файла шаблона (template), если оно отличается от принятого по умолчанию. \makeback Автоматическое создание Backup-файла, если документ защищен. \defformat Сообщает программе чтения RTF-данных о том, что документ должен быть защищен. \revison Включает отметку об изменениях. \margmirror Указывает на необходимость зеркально отобразить описания для левого и правого полей. \геvргорn Значение параметра n задает начертание и способ выделения символов при создании редакторских примечаний. Значение n, равное 0, соответствует нормальному начертанию, 1 - жирному, 2 - курсиву, 3 - подчеркиванию (стандартная настройка), 4 - двойному подчеркиванию. \геvьагn В зависимости от значения параметра n, задается способ выделения вертикальными линиями текста редакторских примечаний: 0 - не отмечается, 1 - отмечается левый край текста, 2 - отмечается правый край текста, 3 - отметка располагается за пределами текста (стандартная настройка) по краю страницы.Форматирование секции (section formatting).
Вторая группа операторов управляет форматом секции (section) и состоит из следующих команд.
\sectd Оператор устанавливает стандартную настройку параметров секции. \sbknone Оператор подавляет переход на новую страницу перед началом секции (section break continuous). \sbkcol При указании этой команды в начале секции осуществляется переход на новую колонку (section break new column). \sbkpage При указании этой команды (section break new page) в начале секции происходит переход к новой странице. \sbkeven При указании этой команды в начале секции выполняется переход к новой странице, если номер страницы четный (section break even). \sbkodd При указании этой команды в начале секции выполняется переход к новой странице, если номер страницы нечетный (section break odd). \pgostartsn Нумерация страниц начинается с номера n. \pgnrestart Команда устанавливает временную нумерацию страниц, начиная со значения 1. Параметр 0 восстанавливает прежний порядок нумерации. \pgndec Номера страниц выводятся в десятичном формате. \pgnucrm Номера страниц выводятся большими римскими цифрами (upper case roman). \pgnlcrm Номера страниц выводятся маленькими римскими цифрами (lower case roman). \pgncont Сквозная нумерация страниц (стандартная настройка). \pgnucltr Номера страниц выводятся прописными символами (upper case letter). \pgnlcltr Номера страниц выводятся строчными символами (lower case letter). \pgnx000 С помощью этой команды задается X-координата номера страницы при автоматической нумерации. Значение указывается относительно верхнего левого угла страницы и по умолчанию устанавливается равным 720 twips. \pgny000 С помощью этой команды задается Y-координата номера страницы при автоматической нумерации. Значение указывается относительно верхнего левого угла страницы и по умолчанию устанавливается равным 720 twips. \linemod000 Оператор устанавливает величину интервала при нумерации строк. \linex000 Оператор устанавливает расстояние между строками. По умолчанию оно равно 360 twips. \linestartn Нумерация строк начинается со значения n. \linerestart Возвращает номер строки к значению 1. Команда устанавливает, что нумерация строк начинается с 1. \linepage На каждой странице нумерация строк начинается со значения 1. \linecont Нумерация строк продолжается с предыдущей секции (предыдущей главы). \headery000 Команда задает Y-координату верхнего колонтитула. Значение указывается относительно верхнего края страницы и по умолчанию принимается равным 720 twips. \footery000 Команда задает Y-координату нижнего колонтитула. Значение указывается относительно нижнего края страницы и по умолчанию принимается равным 720 twips. \vertalt Текст по вертикали выравнивается к верхнему краю страницы. Текст располагается в верхней части страницы (vertically align at top of page). \vertalc Текст размещается посредине страницы. Вертикальное выравнивание текста выполняется по центру страницы (vertical align centered). \vertalj Текст по вертикали размещается так, чтобы заполнить всю страницу (vertical align justified). \vertalb Вертикальное выравнивание текста выполняется по нижнему краю страницы (vertical align bottom). \cols000 С помощью этой команды можно задать количество столбцов в строке. Стандартное значение равно 1. \colsx000 С помощью этой команды устанавливается расстояние между двумя столбцами в twips. Стандартное значение равно 720 twips. \endnhere При указании этого оператора послетекстовые сноски выводятся в конце секции. Такой вывод можно подавить путем задания параметра 0. \titlepg Оператор задает вывод титульной страницы. Параметр 0 подавляет вывод титульной страницы.Форматирование абзаца (paragraph formatting).
Следующие команды управляют форматированием абзаца (paragraph).
\pard Оператор устанавливает стандартную настройку для абзаца. \s000 Команда определяет шрифт для данного абзаца. С помощью подставляемого вместо 000 значения осуществляется выбор в таблице шрифтов. \ql При задании команды quad left текст выравнивается по левому краю страницы. \qr При задании команды quad right текст выравнивается по правому краю страницы. \qc При задании команды quad centered текст размещается по центру страницы. \qj При задании команды quad justified текст выравнивается по формату страницы. \fi000 Оператор определяет величину отступа первой строки абзаца (first line indent). Стандартное значение равно 0. \li000 Оператор определяет величину втяжки абзаца слева (left indent). Стандартное значение равно 0. \ri000 Оператор определяет величину втяжки абзаца справа (right indent). Стандартное значение равно 0. \sb000 Оператор задает количество пустых строк, вставляемых перед абзацем (spaces before). Стандартное значение равно 0. \sa000 Оператор задает количество пустых строк, вставляемых после абзаца (spaces after). Стандартное значение равно 0. \sl000 Команда устанавливает расстояние между строками в пунктах. Стандартное значение равно одной строке (12 пунктам). Команда \sl000 включает auto line mode. \intbl Абзац является частью некоторой таблицы. \keep При указании этой команды фиксируется принадлежность текста к текущему абзацу. Команда отключается указанием параметра 0. \кеерn При указании этой команды текст ставится в соответствие следующему (next) абзацу. Команда отключается указанием параметра 0. \sbys Указанием этого оператора может быть включен режим side by side. При задании параметра 0 режим отключается. \pagebb Указанием этого оператора может быть включена команда page break before. При задании параметра 0 команда отключается. \nо1inе При задании этой команды отключается нумерация строк. Указание параметра 0 подавляет команду. \brdrt Задает линию над абзацем (boarder top). \brdrb Задает линию под абзацем (boarder bottom).. \brdrl Задает линию слева от абзаца (boarder left). \brdrr Задает линию справа от абзаца (boarder right). \box Задает рамку вокруг абзаца. \brdrs Задает нормальную линию (single thickness) для рамки. \brdrtb Задается толстую (thick) линию для рамки. \brdsu Задает оттененную рамку (boarder). \brdrdb Задается двойную рамку (boarder). \brdrdot Рамка обозначается пунктирной линией. \brdrbair Рамка обозначается тонкой линией. \brspn Расстояние в twips между рамкой и объектом. \tqr Обозначает табулятор, относительно которого текст выравнивается вправо (right flush tab). \tgc Обозначает табулятор, относительно которого текст выравнивается по центру (centered tab). \tqdec Обозначает десятичный табулятор (decimal aligned tab). \tldot Обозначает табулятор, для которого пустое пространство заполняется точками (tab leader dot). \tibypben Обозначает табулятор, для которого пустое пространство заполняется дефисами (tab leader hyphen). \tlul Обозначает табулятор, для которого пустое пространство заполняется символами подчеркивания (tab leader underline). \tith Обозначает табулятор, для которого пустое пространство заполняется жирной чертой (tab leader thick line). \ \tx000 С помощью этой команды задается положение табулятора. \tb000 С помощью команды задается положение вертикального табулятора. При этом по всей длине текущего абзаца проводится вертикальная линия.Следующие команды позволяют разместить абзац в определенной позиции листа.
\posxn Позиционирует абзац на расстоянии n twips от левого края. \posxc Абзац по горизонтали размещается по центру относительно указанного элемента (страницы, колонки). \posxi Абзац по горизонтали размещается внутри указанного элемента. \posxl Абзац по горизонтали размещается слева относительно указанного элемента. \posxo Абзац по горизонтали размещается вне указанного элемента. \posxr Абзац по горизонтали размещается справа относительно указанного элемента. \posysi Позиционирует абзац на расстоянии "n" twips от верхнего края. \posyil Позиционирует абзац в текущей позиции (inline). \posyt Абзац по вертикали размещается в верхней части указанного элемента (страницы, колонки). \posyc Абзац по вертикали размещается в центре указанного элемента. \posyb Абзац по вертикали размещается в нижней части указанного элемента. \abswn Абсолютная ширина текста абзаца в twips. \dxfrtextn Расстояние в twips по горизонтали между основным текстом и абсолютно позиционированным объектом (рамкой с текстом или рисунком). \pvmrg Позиция по вертикали относительно полей. \pvpg Позиция по вертикали относительно страницы. \phmrg Позиция по горизонтали относительно полей. \рhрg Позиция по горизонтали относительно страницы. \рhсо1 Позиция по горизонтали относительно столбца.Для форматирования таблиц определены следующие команды.
\clbrdrb Нижний край таблицы. \clbrdrt Верхний край таблицы. \clbrdrl Левый край таблицы. \clbrdrr Правый край таблицы. \trowd Устанавливает стандартные значения строк таблицы. \trql Левостороннее выравнивание при размещении строк таблицы (с учетом столбцов). \trqr Правостороннее выравнивание при размещении строк таблицы (с учетом столбцов). \trqc Центрирование строк таблицы (с учетом столбцов). \trgapho Половина расстояния между ячейками таблицы (в twips). \trrbn Высота строки в twips. \trleftm Расположение левого угла таблицы. \cellxn Смещение правой границы таблицы. \clmgf Объединение (merge) первой ячейки с остальными ячейками таблицы. \clmrg Объединение ячейки с предыдущей ячейкой.Форматирование символов (character formatting).
Данная группа операторов используется для форматирования символов (жирное начертание, подчеркивание и т.д.).
\plain С помощью этой команды устанавливаются стандартные параметры форматирования. \b Установка жирного начертания (bold) для печатаемого текста. Для отмены необходимо указать параметр 0. \i Задание курсивного начертания (italic) для печатаемого текста. Установка отменяется указанием параметра 0. \strike Печатаемый текст будет зачеркнутым (strikethrough). Для отмены следует выбрать параметр 0. \outl Установка контурного шрифта (outline) для печатаемого текста. Для отмены надлежит выбрать параметр 0. \shad Печатаемый текст будет оттенен. Для отмены необходимо установить параметр 0. \scaps Установка печати текста строчными буквами (small caps). Для отмены нужно выбрать параметр 0. \caps Установка печати текста прописными и строчными буквами. Для отмены необходимо выбрать параметр 0. \v Печатаемый текст будет заменен пробелами (invisible). Для отмены следует установить параметр 0. \f000 Установка настройки шрифта с указанием в качестве параметра номера фонта. \fs000 Оператор в качестве параметра содержит высоту символов, заданную в единицах по 1/2 пункта. Стандартное значение высоты равно 24 единицам (12 пунктам). \expnd000 Параметр позволяет изменить расстояние между символами путем указания количества интервалов величиной по 1/4 пункта каждый. \ul Установка режима подчеркивания текста. Для отмены необходимо выбрать параметр 0. \ulw Оператор позволяет задать подчеркивание только слов. \uld Задание пунктирного подчеркивания текста (dotted underline). \uldb Установка режима двойного подчеркивания текста (double underline). \ulnone Отмена подчеркивания текста. \up000 Установка режима надстрочного написания символов (superscript). Размер задается в единицах 1/2 пункта. \dn000 Установка режима подстрочного написания символов (subscript). Размер задается в единицах 1/2 пункта. \cf000 Указание номера цвета в палитре. \сьО00 Задание цвета фона путем указания номера в палитре. \revisedПоследующие версии RT-формата могут быть дополнены новыми командами. Если программа не распознает команду, то она может быть пропущена. Конец каждой команды отмечается одним из описанных выше разделяющих символов (чаще всего -точкой с запятой).
Загрузить RTF текст из файла ресурса в TRichEdit.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
(*
Load RTF file from resource:
You can store any kind of file as a RCDATA resource.
The following example shows this with an RTF file.
Create a text file called textres.rc and put the
following line in it:
TESTDOC RCDATA "textdoc.rtf"
Next, compile that using the Borland Resource Compiler,
which is provided with Delphi.
brcc32.exe textres.rc
Your next step is to include the compiled resource (.RES) file into
your executable, which can be done with the {$R} compiler directive.
*)
(*
Man kann eine beliebige Datei als RCDATA Ressource in eine
Exe-Datei einbinden.
Das folgende Beispiel zeigt, wie man einen RTF-Text aus
einer Ressource ladt und in einem TRichEdit anzeigt.
Erstelle zuerst eine Datei "textres.rc" mit folgendem Inhalt:
TESTDOC RCDATA "textdoc.rtf"
Kompiliere diese mit brcc32.exe:
brcc32.exe textres.rc
Es wurde nun eine textres.res Datei erzeugt.
*)
implementation
{$R *.dfm}
{$R textres.res} // <---- your resource file!
procedure TForm1.Button1Click(Sender: TObject);
var
rs: TResourceStream;
begin
rs := TResourceStream.Create(hinstance, 'TESTDOC', RT_RCDATA);
try
Richedit1.PlainText := False;
TempStream.Position := 0;
Richedit1.Lines.LoadFromStream(rs);
finally
rs.Free;
end;
end;
Распечатать RTF-файл и определить диапазон страницы для печати.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, RichEdit, RxRichEd, ExtCtrls, Printers;
type
TPageOffset = record
mStart,
mEnd: Integer;
rendRect: TRect;
end;
TForm1 = class(TForm)
Panel1: TPanel;
Editor: TRxRichEdit;
PrintBtn: TButton;
PreviewBtn: TButton;
CloseBtn: TButton;
procedure PrintBtnClick(Sender: TObject);
procedure PreviewBtnClick(Sender: TObject);
procedure CloseBtnClick(Sender: TObject);
procedure FormShow(Sender: TObject);
private
{ Private-Deklarationen }
public
{ Public-Deklarationen }
end;
var
Form1: TForm1;
implementation
uses Unit2;
{$R *.dfm}
procedure TForm1.PrintBtnClick(Sender: TObject);
var
wPage, hPage, xPPI, yPPI, wTwips, hTwips: integer;
pageRect, rendRect: TRect;
po: TPageOffset;
fr: TFormatRange;
lastOffset, currPage, pageCount: integer;
xOffset, yOffset: integer;
FPageOffsets: array of TPageOffset;
TextLenEx: TGetTextLengthEx;
firstPage: boolean;
begin
//First, get the size of a printed page in printer device units
wPage := GetDeviceCaps(Printer.Handle, PHYSICALWIDTH);
hPage := GetDeviceCaps(Printer.Handle, PHYSICALHEIGHT);
//Next, get the device units per inch for the printer
xPPI := GetDeviceCaps(Printer.Handle, LOGPIXELSX);
yPPI := GetDeviceCaps(Printer.Handle, LOGPIXELSY);
//Convert the page size from device units to twips
wTwips := MulDiv(wPage, 1440, xPPI);
hTwips := MulDiv(hPage, 1440, yPPI);
//Save the page size in twips
with pageRect do
begin
Left := 0;
Top := 0;
Right := wTwips;
Bottom := hTwips
end;
//Next, calculate the size of the rendering rectangle in twips
//Rememeber - two inch margins are hardcoded, so the below code
//reduces the width of the output by four inches
with rendRect do
begin
Left := 0;
Top := 0;
Right := pageRect.Right - (1440 * 4);
Bottom := pageRect.Bottom - (1440 * 4)
end;
//Define a single page and set starting offset to zero
po.mStart := 0;
//Define and initialize a TFormatRange structure. This structure is passed
//to the TRichEdit with a request to format as much text as will fit on a
//page starting with the chrg.cpMin offset and ending with the chrg.cpMax.
//Initially, we tell the RichEdit control to start at the beginning
//(cpMin = 0) and print as much as possible (cpMax = -1). We also tell it
//to render to the printer
with fr do
begin
hdc := Printer.Handle;
hdcTarget := Printer.Handle;
chrg.cpMin := po.mStart;
chrg.cpMax := -1;
end;
//In order to recognize when the last page is rendered, we need to know how
//much text is in the control.
if RichEditVersion >= 2 then
begin
with TextLenEx do
begin
flags := GTL_DEFAULT;
codepage := CP_ACP;
end;
lastOffset := SendMessage(Editor.Handle, EM_GETTEXTLENGTHEX, wParam(@TextLenEx), 0)
end
else
lastOffset := SendMessage(Editor.Handle, WM_GETTEXTLENGTH, 0, 0);
//As a precaution, clear the formatting buffer
SendMessage(Editor.Handle, EM_FORMATRANGE, 0, 0);
//Printers frequently cannot print at the absolute top-left position on the
//page. In other words, there is usually a minimum margin on each edge of the
//page. When rendering to the printer, RichEdit controls adjust the top-left
//corner of the rendering rectangle for the amount of the page that is
//unprintable. Since we are printing with two-inch margins, we are presumably
//already within the printable portion of the physical page.
SaveDC(fr.hdc);
SetMapMode(fr.hdc, MM_TEXT);
xOffset := GetDeviceCaps(Printer.Handle, PHYSICALOFFSETX);
yOffset := GetDeviceCaps(Printer.Handle, PHYSICALOFFSETY);
xOffset := xOffset + MulDiv(1440 + 1440, xPPI, 1440);
yOffset := yOffset + MulDiv(1440 + 1440, yPPI, 1440);
SetViewportOrgEx(fr.hdc, xOffset, yOffset, nil);
//Now we build a table of page entries, one entry for each page that would be
//printed.
while ((fr.chrg.cpMin <> -1) and (fr.chrg.cpMin < lastOffset)) do
begin
fr.rc := rendRect;
fr.rcPage := pageRect;
po.mStart := fr.chrg.cpMin;
fr.chrg.cpMin := SendMessage(Editor.Handle, EM_FORMATRANGE, 0, Longint(@fr));
po.mEnd := fr.chrg.cpMin - 1;
po.rendRect := fr.rc;
if High(FPageOffsets) = -1 then SetLength(FPageOffsets, 1)
else
SetLength(FPageOffsets, Length(FPageOffsets) + 1);
FPageOffsets[High(FPageOffsets)] := po
end;
pageCount := Length(FPageOffsets);
ShowMessage(Format('Es wurde %d Seiten ermittelt', [pageCount]));
SendMessage(Editor.Handle, EM_FORMATRANGE, 0, 0);
RestoreDC(fr.hdc, - 1);
//Now, we are almost ready to actually print.
Printer.BeginDoc;
fr.hdc := Printer.Handle;
fr.hdcTarget := Printer.Handle;
SaveDC(fr.hdc);
SetViewportOrgEx(fr.hdc, xOffset, yOffset, nil);
//Ok, here we go to print
firstPage := True;
//At this point you can select from page and to page
currPage := 0; //Print from the first page
pageCount := 1; //Only One page for testing
while (currPage < pageCount) do
begin
if firstPage then firstPage := False
else
Printer.NewPage;
SetViewportOrgEx(fr.hdc, xOffset, yOffset, nil);
fr.rc := FPageOffsets[currPage].rendRect;
fr.rcPage := pageRect;
fr.chrg.cpMin := FPageOffsets[currPage].mStart;
fr.chrg.cpMax := FPageOffsets[currPage].mEnd;
fr.chrg.cpMin := SendMessage(Editor.Handle, EM_FORMATRANGE, 1, Longint(@fr));
Inc(currPage);
end;
//At this point, we have finished rendering the contents of the RichEdit
//control. Now we restore the printer's HDC settings and tell Windows that
//we are through printing this document
RestoreDC(fr.hdc, - 1);
Printer.EndDoc;
//Finally, we clear the RichEdit control's formatting buffer and delete
//the saved page table information
fr.chrg.cpMin := SendMessage(Editor.Handle, EM_FORMATRANGE, 0, 0);
Finalize(FPageOffsets);
//That's it
end;
procedure TForm1.PreviewBtnClick(Sender: TObject);
begin
PreviewForm.ShowModal
end;
procedure TForm1.CloseBtnClick(Sender: TObject);
begin
Close
end;
procedure TForm1.FormShow(Sender: TObject);
begin
Editor.Lines.LoadFromFile('Exceltabelle.rtf');
end;
end.
Исправление загрузки RTF текста через поток.
| Автор: Лагонский Сергей Николаевич |
| Я после дня игры в X-COM стал думать как мне поменьше ходов потратить, идя по комнате, чтобы потом хватило дверь открыть! |
1. Исходный текст.
procedure TRichEditStrings.LoadFromStream(Stream: TStream);
var
EditStream: TEditStream;
Position: Longint;
TextType: Longint;
StreamInfo: TRichEditStreamInfo;
Converter: TConversion;
begin
StreamInfo.Stream := Stream;
if FConverter <> nil then
Converter := FConverter
else
Converter := RichEdit.DefaultConverter.Create;
StreamInfo.Converter := Converter;
try
with EditStream do
begin
dwCookie := LongInt(Pointer(@StreamInfo));
pfnCallBack := @StreamLoad;
dwError := 0;
end;
Position := Stream.Position;
if PlainText then
TextType := SF_TEXT
else
TextType := SF_RTF;
SendMessage(RichEdit.Handle, EM_STREAMIN, TextType, Longint(@EditStream));
if (TextType = SF_RTF) and (EditStream.dwError <> 0) then
begin
Stream.Position := Position;
! if PlainText then
TextType := SF_RTF
!
else
TextType := SF_TEXT;
SendMessage(RichEdit.Handle, EM_STREAMIN, TextType, Longint(@EditStream));
if EditStream.dwError <> 0 then
raise EOutOfResources.Create(sRichEditLoadFail);
end;
finally
if FConverter = nil then
Converter.Free;
end;
end;
|
2. Текст с исправлением:
procedure TRichEditStrings.LoadFromStream(Stream: TStream);
var
EditStream: TEditStream;
Position: Longint;
TextType: Longint;
StreamInfo: TRichEditStreamInfo;
Converter: TConversion;
begin
StreamInfo.Stream := Stream;
if FConverter <> nil then
Converter := FConverter
else
Converter := RichEdit.DefaultConverter.Create;
StreamInfo.Converter := Converter;
try
with EditStream do
begin
dwCookie := LongInt(Pointer(@StreamInfo));
pfnCallBack := @StreamLoad;
dwError := 0;
end;
Position := Stream.Position;
if PlainText then
TextType := SF_TEXT
else
TextType := SF_RTF;
SendMessage(RichEdit.Handle, EM_STREAMIN, TextType, Longint(@EditStream));
if (TextType = SF_RTF) and (EditStream.dwError <> 0) then
begin
Stream.Position := Position;
! if PlainText then
TextType := SF_TEXT
!
else
TextType := SF_RTF;
SendMessage(RichEdit.Handle, EM_STREAMIN, TextType, Longint(@EditStream));
if EditStream.dwError <> 0 then
raise EOutOfResources.Create(sRichEditLoadFail);
end;
finally
if FConverter = nil then
Converter.Free;
end;
end;
|
Как сохранить RTF в TBlobField.
| Иисус изменил твою жизнь. Сохранить? (Да/Нет) |
В этом примере поле 'Table1Memo' это paradox 'formatted memo'. Оно так же может быть полем blob.
Через TBlobStream содержимое контрола RichEdit можно загружать или сохранять в базу данных:
procedure TForm1.BtnGetClick(Sender: TObject);
var
bs: TBlobStream;
begin
bs := nil;
with Table1 do
try
open;
first;
bs := TBlobStream.Create(table1memo, bmread);
Richedit1.plaintext := false;
Richedit1.Lines.Loadfromstream(bs);
finally
bs.free;
close;
end;
end;
procedure TForm1.BtnPutClick(Sender: TObject);
var
bs: TBlobStream;
begin
bs := nil;
with Table1 do
try
open;
first;
edit;
bs := TBlobStream.Create(table1memo, bmwrite);
Richedit1.plaintext := false;
Richedit1.Lines.Savetostream(bs);
post;
finally
bs.free;
close;
end;
end;
|
Копировать RTF-текст в буфер обмена.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
How can I copy a text formatted as RTF ({\rtf1\ansi ....) on the Clipboard?
{
You have to dig into the Rich Text Format if you want to copy text to the
clipboard that has format information embedded. The application you paste
this text into has to understand RTF, or the formatting will not show up.
OK, the first step is to register a clipboard format for RTF, since this is
not a predefined format:
}
Var
CF_RTF : Word;
CF_RTF := RegisterClipboardFormat('Rich Text Format');
{
The format name has to appear as typed above, this is the name used by MS
Word for Windows and similar MS products.
NOTE: The Richedit Unit declares a constant CF_RTF, which is NOT the
clipboard format handle but the string you need to pass to RegisterClipboard
format! So you can place Richedit into your uses clause and change the line
above to
}
CF_RTF := RegisterClipboardFormat(Richedit.CF_RTF);
{
The next step is to build a RTF string with the embedded format information.
You will get a shock if you inspect the mess of RTF stuff W4W will put into
the clipboard if you copy just a few characters (the app below allows you to
inspect the clipboard), but you can get away with a lot less. The bare
minimum would be something like this (inserts an underlined 44444):
}
const
testtext: PChar = '{\rtf1\ansi\pard\plain 12{\ul 44444}}';
{
The correct balance of opening and closing braces is extremely important, one
mismatch and the target app will not be able to interpret the text
correctly. If you want to control the font used for the pasted text you need
to add a fonttable (the default font is Tms Rmn, not the active font in the
target app!). See example app below, testtext2. If you want more info, the
full RTF specs can be found on www.microsoft.com, a subset is also described
in the Windows help compiler docs (hcw.hlp, comes with Delphi).
}
unit Clipfmt1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TForm1 = class(TForm)
MemFormats: TMemo;
label1: TLabel;
BtnShowFormats: TButton;
BtnGetRTF: TButton;
BtnSetRTF: TButton;
MemExample: TMemo;
procedure FormCreate(Sender: TObject);
procedure BtnShowFormatsClick(Sender: TObject);
procedure BtnGetRTFClick(Sender: TObject);
procedure BtnSetRTFClick(Sender: TObject);
private
public
CF_RTF: Word;
end;
var
Form1: TForm1;
implementation
uses Clipbrd;
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
// register clipboard format rtf
CF_RTF := RegisterClipboardFormat('Rich Text Format');
if CF_RTF = 0 then
begin
ShowMessage('Unable to register the Rich Text clipboard format!');
Application.Terminate;
end;
BtnShowFormats.Click;
end;
// show clipboard formats
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 := 'private format';
$0300..$03FF: Name := 'GDI object';
else
Name := 'unknown format';
end;
MemFormats.Lines.Add(Name);
end;
end;
end;
// get rtf code from clipboard
procedure TForm1.BtnGetRTFClick(Sender: TObject);
var
MemHandle: THandle;
begin
with Clipboard do
begin
Open;
try
if HasFormat(CF_RTF) then
begin
MemHandle := GetAsHandle(CF_RTF);
MemExample.SetTextBuf(GlobalLock(MemHandle));
GlobalUnlock(MemHandle);
end
else
MessageDlg('The clipboard contains no RTF text!',
mtError, [mbOK], 0);
finally
Close;
end;
end;
end;
// set rtf code to the clipboard
procedure TForm1.BtnSetRTFClick(Sender: TObject);
const
testtext: PChar = '{\rtf1\ansi\pard\plain 12{\ul 44444}}';
testtext2: PChar = '{\rtf1\ansi' +
'\deff4\deflang1033{\fonttbl{\f4\froman\fcharset0\fprq2 Times New Roman;}}' +
'\pard\plain 12{\ul 44444}}';
flap: Boolean = False;
var
MemHandle: THandle;
rtfstring: PChar;
begin
with Clipboard do
begin
if flap then
rtfstring := testtext2
else
rtfstring := testtext;
flap := not flap;
MemHandle := GlobalAlloc(GHND or GMEM_SHARE, StrLen(rtfstring) + 1);
if MemHandle <> 0 then
begin
StrCopy(GlobalLock(MemHandle), rtfstring);
GlobalUnlock(MemHandle);
Open;
try
AsText := '1244444';
SetAsHandle(CF_RTF, MemHandle);
finally
Close;
end;
end
else
MessageDlg('Global Alloc failed!',
mtError, [mbOK], 0);
end;
end;
end.
Массив констант во время выполнения приложения.
Автор: Peter Below...хорошо, непосредственно это синтаксис не поддерживает, поскольку массив констант Array of Const подобен открытым массивам, главным образом в части характеристик времени компиляции. Но вы можете обойти этот неприятный момент, обладая хотя бы начальными знаниями того, как реализован открытый массив. Что нам для этого необходимо: динамически размещенный массив array of TVarRec, который "принимает" ваши параметры, и "псевдоним" (alias) функции Format, позволяющий работать с таким массивом без "ругани" со стороны компилятора.
type
{ объявляем тип для динамического массива array of TVarRecs }
TVarArray = array[0..High(Word) div Sizeof(TVarRec) - 1] of TVarRec;
PVarArray = ^TVarArray;
{ Объявляем alias-тип для функции Format. Передаваемые параметры будут иметь
в стеке тот же самый порядок вызова, что и при нормальном вызове Format }
FormatProxy = function(const aFormatStr: string; var aVarRec: TVarRec;
highIndex: Integer): string;
{ AddVarRecs копирует параметры, передаваемые в массиве A в pRecs^, начиная
с pRecs^[atIndex]. highIndex - самый большой доступный индекс pRecs, число
распределенных элементов - 1. }
procedure AddVarRecs(pRecs: PVarArray; atIndex, highIndex: Integer; const A:
array of const);
var
i: Integer;
begin
if pRecs <> nil then
for i := 0 to High(A) do
begin
if atIndex <= highIndex then
begin
pRecs^[atIndex] := A[i];
Inc(atIndex);
end { If }
else
Break;
end; { For }
end; { AddVarRecs }
procedure TScratchMain.SpeedButton2Click(Sender: TObject);
var
p: PVarArray;
S: string;
Proxy: FormatProxy;
begin
{ распределяем массив для четырех параметров, индексы - 0..3 }
GetMem(p, 4 * Sizeof(TVarRec));
try
{ добавляем параметры последующими вызовами AddVarRecs }
AddVarRecs(p, 0, 3, [12, 0.5, 'Шаблон']);
AddVarRecs(p, 3, 3, ['Тест']);
{ получаем полномочия Format }
@Proxy := @SysUtils.Format;
{ Вызов с динамически сгенерированным массивом параметров.
Естественно, строка формата может также быть сформирована
и во время выполнения программы. }
S := Proxy('Целое: %d, Реальное: %4.2f, Строки: %s, %s', p^[0], 3);
{ выводим результат }
ShowMessage(S);
finally
FreeMem(p, 4 * Sizeof(TVarRec));
end;
end;
|
Тестировалось только в Delphi 1.0!
Как присвоить событие в run-time.
Автор: Vit WEB-сайт: http://forum.vingrad.ru
type
TForm1 = class(TForm)
Button1: TButton;
procedure FormCreate(Sender: TObject);
private
procedure Click(Sender: TObject);
end;
var
Form1: TForm1;
implementation
procedure TForm1.Click(Sender: TObject);
begin
// do something
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
button1.OnClick := Click;
end;
end.
А как сделать чтобы "procedure Click" была не методом класса, а отдельно стоящей функцией
Дополнил: Le Taon
procedure Click(Self: TObject; Sender: TObject);
begin
...
end;
var
evhandler: TNotifyEvent;
TMethod(evhandler).Code := @Click;
TMethod(evhandler).Data := nil;
Button1.OnClick := evhandler;
// Без извращений можно так:
TDummy = class
class procedure Click(Sender: TObject);
end;
Button1.OnClick := TDummy.Click;
По идее, при вызове OnClick первым параметром будет запихнут указатель на экземпляр того класса который в этом OnClick хранится . Я в низкоуровневой реализации не силен, но кажись, так как параметры в процедурах в Delphi передаются через регистры, то ничего страшного не произойдет.
Еще дополнение от: Fantasist
procedure C(Self: pointer; Sender: TObject); begin TButton(Sender).Caption := 'ee'; end; procedure TForm1.FormCreate(Sender: TObject); begin @Button1.OnClick := @c; end;
Self тут у нас будет равен nil, а Sender как раз и получается Sеndеr'ом.
Дублирование компонентов и их потомков во время выполнения приложения.
| Учитывая пожелания пользователей, фирма Microsoft объявила, что она внесёт изменение в название Windows 2000, теперь эта операционная система будет называться Windows 2000 beta ДВАДЦАТЬ ПЯТЬ. P.S. (А чё? Ведь существует-же W2000 beta 3 RELEASE CANDIDATE 1) |
Данная функция может оказаться весьма полезной в случае наличия нескольких одинаковых областей на форме с необходимостью синхронизации изменений в течение некоторого промежутка времени. Процедура создания дубликата проста до безобразия: разместите на TPanel или на другом родительском компоненте необходимые элементы управления и сделайте: "newpanel := DuplicateComponents(designedpanel)".
uses
SysUtils, Windows, Messages, Classes, Graphics, Controls,
Forms, Dialogs, ExtCtrls, StdCtrls, IniFiles, TypInfo, Debug;
type
TUniqueReader = class(TReader)
LastRead: TComponent;
procedure ComponentRead(Component: TComponent);
procedure SetNameUnique(
Reader: TReader;
Component: TComponent;
var Name: string
);
end;
implementation
procedure TUniqueReader.ComponentRead(Component: TComponent);
begin
LastRead := Component;
end;
// Задаем уникальное имя считываемому компоненту, например,
// "Panel2", если "Panel1" уже существует
procedure TUniqueReader.SetNameUnique(
Reader: TReader;
Component: TComponent; // Считываемый компонент
var Name: string // Имя компонента для дальнейшей модификации
);
var
i: Integer;
tempname: string;
begin
i := 0;
tempname := Name;
while Component.Owner.FindComponent(Name) <> nil do
begin
Inc(i);
Name := Format('%s%d', [tempname, i]);
end;
end;
function DuplicateComponents(
AComponent: TComponent // исходный компонент
): TComponent; // возвращаемся к созданию нового компонента
procedure RegisterComponentClasses(
AComponent: TComponent
);
var
i: integer;
begin
RegisterClass(TPersistentClass(AComponent.ClassType));
if AComponent is TWinControl then
if TWinControl(AComponent).ControlCount > 0 then
for i := 0 to
(TWinControl(AComponent).ControlCount - 1) do
RegisterComponentClasses(TWinControl(AComponent).Controls[i]);
end;
var
Stream: TMemoryStream;
UniqueReader: TUniqueReader;
Writer: TWriter;
begin
result := nil;
UniqueReader := nil;
Writer := nil;
try
Stream := TMemoryStream.Create;
RegisterComponentClasses(AComponent);
try
Writer := TWriter.Create(Stream, 4096);
Writer.Root := AComponent.Owner;
Writer.WriteSignature;
Writer.WriteComponent(AComponent);
Writer.WriteListEnd;
finally
Writer.Free;
end;
Stream.Position := 0;
try
// создаем поток, перемещающий данные о компоненте в конструктор
UniqueReader := TUniqueReader.Create(Stream, 4096);
UniqueReader.OnSetName := UniqueReader.SetNameUnique;
UniqueReader.LastRead := nil;
if AComponent is TWinControl then
UniqueReader.ReadComponents(
// считываем компоненты и суб-компоненты
TWinControl(AComponent).Owner,
TWinControl(AComponent).Parent,
UniqueReader.ComponentRead
)
else
UniqueReader.ReadComponents(
// читаем компоненты
AComponent.Owner,
nil,
UniqueReader.ComponentRead
);
result := UniqueReader.LastRead;
finally
UniqueReader.Free;
end;
finally
Stream.Free;
end;
end;
|
Содержание.
- Узнать, поддерживает ли принтер PostScript.
- Сохранить установки принтера в файл.
- Как печатать растровые и векторные изображения и делать режим предварительного просмотра.
- Как узнать края печати в Win16 и Win32.
- Построчная печать.
- Распечатать Canvas.
- Печать ячеек.
- Пример вывода текста на печать, используя COM порт.
- Печать содержимого DBGrid через QuickReport.
- Печать конверта.
- Распечатать Excel файл.
- Печать всей формы.
- Печать всей формы 2.
- Печать содержимого TMemo или TListBox.
- Как производить Печать из WebBrowsera.
- Как напечатать изображение.
- Печать текста в обход Windows.
- Печать на любом принтере.
- Печать структуры таблицы Paradox.
- Как распечатать картинку.
- Распечатать файл через порт принтера.
- Распечатать файл через порт принтера 2.
- Как изменить размер страницы при печати.
- Распечатать только выделенный в TRichEdit текст.
- Печать повернутого текста.
- Печать повернутого текста 2.
- Печать повернутого текста 3.
- Печать повернутого текста 4.
- Размер полей при печати.
- Печать через спулер на матричный принтер.
- Печать StringGrid.
- Печать TMemo, TStringList или TStrings.
- Как определить количество заданий на печать.
- Распечатать текст.
- Сброс на печать текстового файла.
- Вывод текста на печать, используя com порт.
- Распечатать TImage.
- Распечатать TImage 2.
- Реализация команды PrintTo.
- Печать Dos-файла в порт напрямую.
- Распечатать TStringList.
- Распечатать TStrings на принтере по умолчанию.
- Показать диалог печати и распечатать текстовый файл.
- Как распечатать WEB страничку при помощи HTML контрола.
- Как печатать без TPrinter.
- Как печатать в цвете.
- Как распечатать PRN файл.
- Процедурные типы.
- Unit с полезными функциями для работы с процессами.
- Обработка исключительных ситуаций.
- Обработка исключительных ситуаций 2.
- Для чего нужен ProcessMessages.
- Как обработать ошибку прежде, чем программа уведомит об этом пользователя.
- Выполнение процедуры по адресу.
- Вызов процедуры, имя которой содержится в переменной.
- Вызов процедуры, имя которой содержится в переменной 2.
- Добавить процедурный тип в TList.
- Программа для работы с точечной графикой.
- Программа - камикадзе.
- Как добавить группу в Program Manager.
- Получение данных из Program Manager через DDE.
- Управление Program Manager в Win95 с помощью DDE.
- Как при выполнении долгой операции в Oracle показать прогресс бар.
- Создать ProgressBar в колонке TListView.
- Как вставить ProgressBar в StatusBar.
- Как вставить ProgressBar в StatusBar 2.
- ProgressBar с невидимой рамкой.
- Отображать движение TProgressBar при помощи фонового потока.
- Структура проекта Delphi.
- Публикация во FrontPage.
- Свойства в Delphi.
- Создание свойства-массива компонентов.
- Пропорциональное отображение в TScrollBar или TStringGrid.
- Как получить контекст свойства по его целочисленному значению.
- Как получить значение свойства в виде варианта по тексту имени свойства.
- Редактор свойства Color с заданными ограничениями.
- Способ защиты программы от несанкционированного копирования.
- Как защитить запись в DBGrid от удаления.
- Доступ к защищенным свойствам.
- Защита программ от взлома.
- Программа A4 Proxy для проверки анонимности Proxy.
- Проверка попадания точки в прямоугольник (TPoint в TRect).
- Находится ли точка внутри многоугольника.
- Запись буфера BDE на диск.
- Как поместить картинку в заголовок TListView.
- В DBGrid напротив некоторых строк можно поставить галочку.
- Имплантация таймера в компонент.
- Квадратное уравнение.
- Качественно уменьшить изображение.
- Модуль, позволяющий в Delphi осуществить форму запроса для компонентов DBGrid.
- Параметризованные запросы.
- Проблемы со шрифтами у QuickReport.
- Заголовок окна предварительного просмотра QuickReport.
- Как сохранить QuickReport в stream.
- Функция для быстрого копирования таблиц вместе со всеми дополнительными файлами.
- Быстрый поиск в базах данных.
- Пример быстрой работы с графикой.
- Быстрый поиск в списке.
- Быстрая сортировка.
- Группа радиокнопок и ActiveControl.
- Инициализация исключительной ситуации.
- Как получить неповторяющиеся случайные числа.
- Как выбрать случайную запись.
- Нарисовать случайным образом кривую Безье.
- Случайные пароли.
- Формат архивного файла RAR.
- RAS API для непродвинутых.
- RAS API программирование.
- Работа с отчетами Rave Report в режиме RunTime.
- Показать TRadioButtons в TListView.
- Модуль для RC5 шифрования.
- Модуль для RC6 шифрования.
- Использование команды RDTSC процессора Pentium для работы с малыми временными интервалам.
- Readln для более чем 255 символов.
- Читаем файл Access используя ADO.
- Читаем Adobe Acrobat PDF файлы из нашего приложения.
- Прочитать данные из другого дочернего окна.
- Чтение бинарного файла.
- Как прочитать байт из параллельного порта.
- Как прочитать байт из параллельного порта 2.
- Как динамически прочитать информацию о классе.
- Как читать файлы Outlook Express (DBX).
- Чтение сложных OLE-документов.
- Следить за изменениями в каталоге.
- Прочесть текстовый файл DOS.
- Считать данные из ячеек Excel.
- Читаем заголовок exe файла.
- Access to table disabled because of previous error - Read failure.
- Как прочесть атрибут файла Last Accessed (последний доступ).
- Чтение из файла длинной строки.
- Чтение из файла.
- Как прочитать из модема.
- Читаем из файла, открытого другим приложением.
- Прочитать и изменить текстовый файл строка за строкой.
- Чтение OLE из Blob поля Paradox.
- Прочитать адрес отправителя сообщения для MS Outlook.
- Установка атрибута Только для чтения у столбцов компонента StringGrid.
- Чтение из открытого файла.
- Чтение из открытого файла 2.
- Чтение из открытого файла 3.
- Как прочитать очередь печати.
- Как прочитать свойство напрямую из его ресурса.
- Чтение текста RichEdit из базы данных.
- Прочитать ROM-BIOS.
- Как прочитать русский текст MS-DOS.
- Как прочитать русский текст MS-DOS 2.
- Как прочитать русский текст MS-DOS 3.
- Как прочитать русский текст MS-DOS 4.
- Считать строковые значения из ресурса.
- Запись и чтение чисел в Blob-поле.
- Чтение и запись компонента.
- Чтение и запись файлов.
- Как читать-писать в I-O порты.
- Запись и чтение из файла массива записей.
- Запись и чтение из файла массива записей 2.
- Чтение и запись звука.
- Скопировать строку в Буфер и прочитать её.
- Реализация событий COM+ в среде Delphi.
- Сравнение чисел с плавающей точкой.
- Окно в виде кольца с изогнутой заголовочной полосой.
- Преобразование дробной и целой части REAL-числа в два целых.
- Как завершить сеанс работы или перезагрузить Windows NT.
- Сколько времени прошло с момента перезагрузки.
- Как пересчитать все вычисляемые поля (Calculated fields) без переоткрытия TDataSet.
- RecCount в таблицах ASCII.
- Недавно использовавшиеся файлы в главном меню.
- Получение имени обработчика события.
- Как получить номер записи в dBASE или Paradox.
- Запись RecNo из RecordCount.
- Перекодирование.
- Как можно перекодировать сообщение (содержание) из Win в КОИ8-Р для отправки по EMail.
- Перекодировка текста DOS-Windows-Koi8.
- Перекодировка текста из Win1251 в KOI8-R и наоборот.
- Распознавание кодировки. Перекодировка.
- Передача массива записей символов в Memo.
- Присвоить значение полям записи с помощью Assemblera.
- При обращении клиента, к уже редактируемой записи другим клиентом, выдаётся сообщение.
- Запись nnn из nnn.
- Запись звука.
- Нарушение уникальности записи.
- Запись с помощью MediaPlayer.
- Восстановление поврежденных таблиц.
- Как бороться с квадратичностью Image.
- Проверка пересечения двух прямоугольников (TRect).
- Рекурсивные механизмы спуска по дереву.
- Рекурсия и опережающее описание.
- Класс для рекурсивного обхода дерева каталогов.
- Рекурсивное удаление файлов и подкаталогов.
- Ищем файл рекурсивно.
- Получить количество файлов в корзине и их общий размер.
- Использовать Запись для сохранения информации из свойств различных классов.
- Переопределить параметры формы при её создании.
- FTP - докачка файлов.
- Как заставить перерисоваться все окна.
- Как уменьшить размер EXE-файла.
- Можно ли как-то уменьшить мерцание при перерисовке компонента.
- Обновление вычисляемых полей.
- Как заставить Рабочий Стол обновится.
- Как заставить Рабочий Стол обновится 2.
- Как заставить Рабочий Стол обновится 3.
- Обновить рабочий стол.
- Обновить список дисков TDriveComboBox с сетевыми дсками и Plug&Play.
- Обновление файла после перезагрузки системы.
- Как обновить TQuery не потеряв при этом текущей записи.
- Обновить иконки на экране.
- Перегенерировать все индексы с истекшей датой.
- Регионарные стандарты.
- Как зарегистрировать ActiveX-компонент (OCX-файл) на компьютере пользователя.
- Регистрация компонент.
- Зарегистрировать новый тип файлов.
- Как зарегистрировать OCX.
- Регистрация редактора свойства.
- Регистрация WinZip 7.0 (beta).
- Регистры - доступ и использование вместо WIN.INI.
- Как работать с реестром, используя только WinAPI.
- Браузер по реестру.
- Экспорт и импорт из реестра.
- Как можно определить доступные сервера приложений на этой машине через Registry.
- Как из Delphi влиять на реестр (Изменить заголовок корзины).
- Удобная загрузка местоположения формы.
- Получить из регистров информацию о временной зоне (DST).
- После внесения изменений в реестр, некоторые программы не видят их.
- Записать в реестр данные бинарного вида.
- Исследование RegSnap v 2.8.
- Использование регулярных выражений в Delphi.
- Регистрация ActiveX.
- Взять все расширения из реестра и их описание.
- Прячем программу для TaskManager.
- Помещение записи в одну из секций автозапуска реестра.
- Сохранение бинарного файла в реестре с последующим его извлечением.
- Регистрация классов.
- Считать значение REG_DWORD из реестра.
- Перечислить измененные ключи реестра в определенный диапазон времени.
- Экспортировать ветвь реестра.
- Получить количество вложенных ключей и значений ветви реестра.
- Перейти на определенный ключ в RegEdit.
- Считать значение REG_MULTI_SZ параметра реестра.
- Чтение строки из реестра без использования класса TRegistry.
- Зарегистрировать или удалить OCX, ActiveX.
- Использование реестра.
- Доступ к реестру Win9x и ME без WinAPI.
- Запись строки в реестр без использования класса TRegistry.
- Относительный и полный пути файла.
- Удаленная база данных.
- Использование Remote Debugging.
- Переименование каталога.
- Добавить файлы в меню Reopen.
- Изменение месторасположения .NET-файла во время работы.
- Как заменить или переместить файл, используемый другим приложением.
- Заменить запущенную DLL.
- Замена подстрок.
- Заменяем текст в текстовом файле.
- Заменить текст в документе Word.
- Word для генерации отчетов.
- Резидентная программа.
- Резидентная программа и записная книжка.
- Момент окончания изменения размера или перемещения окна.
- Изменение размеров колонок DBGrid.
- При изменении размеров окна без заголовка сначала отрисовывается рамка будущих размеров.
- Изменить размер Jpeg и сохранить его в новый файл.
- Панель с изменяющимися размерами.
- Ограничение на изменение размера формы по размеру панели на ней.
- Различные разрешения - различные размеры шрифтов.
- Как из своего приложения определить загрузку ресурсов GDI и USER.
- Пример ресурсной таблицы строк.
- Поимей Resource Scrutator version 1.21 by CitruSoft Laboratory нахаляву.
- Перезапустить свою программу.
- Восстановление размера окна.
- Восстанавление длинных имен файлов по известным коротким.
- Возврат курсора по умолчанию после выполнения запроса.
- Перевернуть строку 3.
- Перевернуть строку.
- Перевернуть строку 2.
- Поместить более 64 KB в TRichEdit.
- Выполнить обратный поиск строки в TRichEdit.
- Получить первую или последнюю видимую строку в TRichEdit.
- Подсветить HTML теги в RichEdit.
- Задать расстояние между строк для TRichEdit.
- Сделать предварительный просмотр для TRichEdit.
- Изменить цвет выделения для TRichEdit.
- Показывать значки элементов списка в TRichEdit.
- Использовать SubScript или SuperScript в TRichEdit.
- Выравнивание текста в TRichEdit.
- Как скопировать содержимое одного RichEdit в другой.
- Использовать различные стили подчеркивания для TRichEdit.
- Подсветить ссылки в TRichEdit.
- Как конвертировать RFC1123 в TDateTime.
- Преобразовать RGB в TColor и наоборот.
- Преобразовать RGB в COLORREF (BGR).
- Как преобразовать цвета RGB в CMYK и обратно.
- Как преобразовать RGB-цвет в оттенки серого.
- Как конвертировать RGB в TColor.
- Получить доступ к элементам TRadioGroup.
- Richedit сам меняет язык при перемещении.
- Перейти на строку в RichEdit.
- Печать из RichEdit.
- RichEdit замена текста.
- RichEdit поиск текста.
- Предел на размер текста в RichEdit.
- Подсчет слов в Richedit.
- Получить слово под курсором в RichEdit.
- Как отловить правый Enter (NumPad).
- Как правильно печатать любую информацию (растровые и векторные изображения), а также как сделать режим предварительного просмотра.
- Как научить Delphi делать правильное округление дробных чисел.
- Меню с правой стороны.
- Как в TEdit расположить текст справа.
- Как в TEdit расположить текст справа 2.
- Окно в виде кольца.
- Римские в арабские и наоборот.
- Определить корень слова (для поиска похожих слов).
- Повернуть 2D точку.
- Как повернуть Bitmap на любой угол.
- Как повернуть Bitmap на любой угол 2.
- Вращать Bitmap вокруг точки.
- Переворачиваем рабочий стол.
- Повернуть DIB-изображение.
- Алгоритм поворота изображения.
- Вращение объектов.
- Как вращать текст.
- Как вращать текст 2.
- Как вращать текст 3.
- Рисование кнопок с кругленными краями.
- Элементы управления с закругленными краями.
- Округление чисел до определенной степени.
- Округление денежного значения.
- Округление дробного числа до N знаков после запятой.
- Округление до ближайшего кратного.
- Округление реальных типов.
- Округление времени.
- Как показать округлённое окошко подсказки в Tray в Windows2000.
- Как округлять до сотых в большую сторону.
- Механизм вызова удаленных процедур - RPC.
- COM технология.
- Загрузка нескольких RTF файлов в RichEdit.
- Формат Rich Text (RTF).
- Загрузить RTF текст из файла ресурса в TRichEdit.
- Распечатать RTF-файл и определить диапазон страницы для печати.
- Исправление загрузки RTF текста через поток.
- Как сохранить RTF в TBlobField.
- Копировать RTF-текст в буфер обмена.
- Массив констант во время выполнения приложения.
- Как присвоить событие в run-time.
- Дублирование компонентов и их потомков во время выполнения приложения.