InfoCity

Графика

    Работа с палитрой

    Заполнить Canvas рисунком с рабочего стола

    Список графических файлов с их изображениями

    Как из Delphi рисовать в любой части экрана или в чужом окне

    Написание текста под углом

    Преобразование цвета RGB у HLS (яркость,насыщенность,оттенок)

    Число цветов у данного компьютера

    Копирование экрана

    Нарисовать "неактивный"(disable) текст

    Как менять разрешение экрана по ходу выполнения программы

    Как поместить картинку из базы данных, например MsSQL, в компонент TIMAGE ?

От авторов

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

Как работать с палитрой в Delphi? На форме установлен TImage и видна картинка (*.BMP файл), как изменить у него палитру цветов ?

Палитра в TBitmap и TMetaFile доступна через property Palette. Если палитра имеется (что совсем необязательно), то Palette<>0:

procedure TMain.BitBtnClick(Sender: TObject);var Palette : HPalette; PaletteSize : Integer; LogSize: Integer; LogPalette: PLogPalette; Red : Byte;begin Palette := Image.Picture.Bitmap.ReleasePalette; // здесь можно использовать просто Image.Picture.Bitmap.Palette, но я не // знаю, удаляются ли ненужные палитры автоматически if Palette=0 then exit; //Палитра отсутствует PaletteSize := 0; if GetObject(Palette, SizeOf(PaletteSize), @PaletteSize) = 0 then Exit; // Количество элементов в палитре = paletteSize if PaletteSize = 0 then Exit; // палитра пустая // определение размера палитры LogSize := SizeOf(TLogPalette) + (PaletteSize - 1) * SizeOf(TPaletteEntry); GetMem(LogPalette, LogSize); try // заполнение полей логической палитры with LogPalette^ do begin palVersion := $0300; palNumEntries := PaletteSize; GetPaletteEntries(Palette, 0, PaletteSize, palPalEntry); // делаете что нужно с палитрой, например: Red := palPalEntry[PaletteSize-1].peRed; Edit1.Text := 'Красная составляющего последнего элемента палитры ='+IntToStr(Red); palPalEntry[PaletteSize-1].peRed := 0; //....................................... end; // завершение работы Image.Picture.Bitmap.Palette := CreatePalette(LogPalette^); finally FreeMem(LogPalette, LogSize); // я должен позаботиться сам об удалении Released Palette DeleteObject(Palette); end;end;

{ Этот модуль заполняет фон формы рисунком bor6.bmp (256 цветов) и меняет его палитру при нажатии кнопки }

unit bmpformu;interfaceuses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;type TBmpForm = class(TForm) Button1: TButton; procedure FormDestroy(Sender: TObject); procedure FormPaint(Sender: TObject); procedure Button1Click(Sender: TObject); procedure FormCreate(Sender: TObject); private Bitmap: TBitmap; procedure ScrambleBitmap; procedure WMEraseBkgnd(var m: TWMEraseBkgnd); message WM_ERASEBKGND;end;var BmpForm: TBmpForm;implementation{$R *.DFM}procedure TBmpForm.FormCreate(Sender: TObject);begin Bitmap := TBitmap.Create; Bitmap.LoadFromFile('bor6.bmp');end;procedure TBmpForm.FormDestroy(Sender: TObject);begin Bitmap.Free;end;// since we're going to be painting the whole form, handling this// message will suppress the uneccessary repainting of the background// which can result in flicker.procedure TBmpform.WMEraseBkgnd(var m : TWMEraseBkgnd);begin m.Result := LRESULT(False);end;procedure TBmpForm.FormPaint(Sender: TObject);var x, y: Integer;begin y := 0; while y < Height do begin x := 0; while x < Width do begin Canvas.Draw(x, y, Bitmap); x := x + Bitmap.Width; end; y := y + Bitmap.Height; end;end;procedure TBmpForm.Button1Click(Sender: TObject);begin ScrambleBitmap; Invalidate;end;// scrambling the bitmap is easy when it's has 256 colors:// we just need to change each of the color in the palette// to some other value.procedure TBmpForm.ScrambleBitmap;var pal: PLogPalette; hpal: HPALETTE; i: Integer;begin pal := nil; try GetMem(pal, sizeof(TLogPalette) + sizeof(TPaletteEntry) * 255); pal.palVersion := $300; pal.palNumEntries := 256; for i := 0 to 255 do begin pal.palPalEntry[i].peRed := Random(255); pal.palPalEntry[i].peGreen := Random(255); pal.palPalEntry[i].peBlue := Random(255); end; hpal := CreatePalette(pal^); if hpal <> 0 then Bitmap.Palette := hpal; finally FreeMem(pal); end;end;end.

Заполняет Canvas рисунком с рабочего стола, учитывая координаты.

Function PaintDesktop(HDC) : boolean;
Например: PaintDesktop(form1.Canvas.Handle);

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

Для этого необходимо установить в инспекторе объектов поле Style в lbOwnerDrawFixed, при фиксированной высоте строки, или в lbOwnerDrawVariable, при переменной, и установить собственный обработчик события для OnDrawItem. В этом обработчике и надо рисовать растровое изображение.
Пример:
Рисуются изображения размером 32*16 (размер стандартного глифа для Delphi). Очень полезно при поиске нужного изображения для кнопок!
Установить в инспекторе объектов для ListBox поле ItemHeight = 19, а поле Color = clBtnFace.

{ Загрузить список файлов в ListBox1 при нажатии на кнопку Load (например)}procedure TForm1.bLoadClick(Sender: TObject);VAR S : String; begin ListBox1.Clear; {чистим список} S := '*.bmp'#0; {задаем шаблон} ListBox1.Perform(LB_DIR, DDL_ReadWrite, Longint(@S[1])); {заполняем список} end; ............ {Отобразить изображения и имена файлов в ListBox}procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer; Rect: TRect; State: DrawState); VAR Bitmap : TBitmap; Offset : Integer; BMPRect: TRect; begin WITH (Control AS TListBox).Canvas DO BEGIN FillRect(Rect); Bitmap := TBitmap.Create; Bitmap.LoadFromFile(ListBox1.Items[Index]); Offset := 0; IF Bitmap <> NIL THEN BEGIN BMPRect := Bounds(Rect.Left+2, Rect.Top+2, (Rect.Bottom-Rect.Top-2)*2, Rect.Bottom-Rect.Top-2); {StretchDraw(BMPRect, Bitmap); Можно просто нарисовать, но лучше сначала убрать фон} BrushCopy(BMPRect,Bitmap, Bounds(0, 0, Bitmap.Width, Bitmap.Height), Bitmap.Canvas.Pixels[0, Bitmap.Height-1]); Offset := (Rect.Bottom-Rect.Top+1)*2; END; TextOut(Rect.Left+Offset, Rect.Top, ListBox1.Items[Index]); Bitmap.Free; END; end;

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

Можно ли из Delphi рисовать в любой части экрана или в чужом окне?

Для этого надо воспользоваться функциями API. Получить контекст чужого окна, либо всего экрана:
function GetDC(Wnd: HWnd): HDC;
где Wnd - указатель на нужное окно, или 0 для получения контекста всего экрана.
И далее, пользуясь функциями API, нарисовать все что надо.
Пример:
PROCEDURE DrawOnScreen; VAR ScreenDC: hDC; BEGIN ScreenDC := GetDC(0); {получить контекст экрана} Ellipse(ScreenDC, 0, 0, 200, 200); {нарисовать} ReleaseDC(0,ScreenDC); {освободить контекст} END;

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

Написание текста под углом

{ Эта процедура устанавливает угол вывода текста для указанного 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;

Преобразование цвета RGBуHLS

{ Максимальные значения }Const HLSMAX = 240; RGBMAX = 255; UNDEFINED = (HLSMAX*2) div 3;Var H, L, S : integer; { H-оттенок, L-яркость, S-насыщенность } R, G, B : integer; { цвета }procedure RGBtoHLS;Var cMax,cMin : integer; Rdelta,Gdelta,Bdelta : single;Begin cMax := max( max(R,G), B); cMin := min( min(R,G), B); L := round( ( ((cMax+cMin)*HLSMAX) + RGBMAX )/(2*RGBMAX) ); if (cMax = cMin) then begin S := 0; H := UNDEFINED; end else begin if (L <= (HLSMAX/2)) then S := round( ( ((cMax-cMin)*HLSMAX) + ((cMax+cMin)/2) ) / (cMax+cMin) ) else S := round( ( ((cMax-cMin)*HLSMAX) + ((2*RGBMAX-cMax-cMin)/2) ) / (2*RGBMAX-cMax-cMin) ); Rdelta := ( ((cMax-R)*(HLSMAX/6)) + ((cMax-cMin)/2) ) / (cMax-cMin); Gdelta := ( ((cMax-G)*(HLSMAX/6)) + ((cMax-cMin)/2) ) / (cMax-cMin); Bdelta := ( ((cMax-B)*(HLSMAX/6)) + ((cMax-cMin)/2) ) / (cMax-cMin); if (R = cMax) then H := round(Bdelta - Gdelta) else if (G = cMax) then H := round( (HLSMAX/3) + Rdelta - Bdelta) else H := round( ((2*HLSMAX)/3) + Gdelta - Rdelta ); if (H < 0) then H:=H + HLSMAX; if (H > HLSMAX) then H:= H - HLSMAX; end; if S<0 then S:=0; if S>HLSMAX then S:=HLSMAX; if L<0 then L:=0; if L>HLSMAX then L:=HLSMAX;end;procedure HLStoRGB;Var Magic1,Magic2 : single; function HueToRGB(n1,n2,hue : single) : single; begin if (hue < 0) then hue := hue+HLSMAX; if (hue > HLSMAX) then hue:=hue -HLSMAX; if (hue < (HLSMAX/6)) then result:= ( n1 + (((n2-n1)*hue+(HLSMAX/12))/(HLSMAX/6)) ) else if (hue < (HLSMAX/2)) then result:=n2 else if (hue < ((HLSMAX*2)/3)) then result:= ( n1 + (((n2-n1)*(((HLSMAX*2)/3)-hue)+(HLSMAX/12))/(HLSMAX/6))) else result:= ( n1 ); end;begin if (S = 0) then begin B:=round( (L*RGBMAX)/HLSMAX ); R:=B; G:=B; end else begin if (L <= (HLSMAX/2)) then Magic2 := (L*(HLSMAX + S) + (HLSMAX/2))/HLSMAX else Magic2 := L + S - ((L*S) + (HLSMAX/2))/HLSMAX; Magic1 := 2*L-Magic2; R := round( (HueToRGB(Magic1,Magic2,H+(HLSMAX/3))*RGBMAX + (HLSMAX/2))/HLSMAX ); G := round( (HueToRGB(Magic1,Magic2,H)*RGBMAX + (HLSMAX/2)) / HLSMAX ); B := round( (HueToRGB(Magic1,Magic2,H-(HLSMAX/3))*RGBMAX + (HLSMAX/2))/HLSMAX ); end; if R<0 then R:=0; if R>RGBMAX then R:=RGBMAX; if G<0 then G:=0; if G>RGBMAX then G:=RGBMAX; if B<0 then B:=0; if B>RGBMAX then B:=RGBMAX;end;

Число цветов (цветовая палитра) у данного компьютера

Эта функция возвращает число бит на точку у данного компьютера. Так, например, 8 - 256 цветов, 4 - 16 цветов ...

function GetDisplayColors : integer;var tHDC : hdc;begin tHDC:=GetDC(0); result:=GetDeviceCaps(tHDC, 12)* GetDeviceCaps(tHDC, 14); ReleaseDC(0, tHDC);end;

Копирование экрана

unit ScrnCap;interfaceuses WinTypes, WinProcs, Forms, Classes, Graphics, Controls; { Копирует прямоугольную область экрана }function CaptureScreenRect(ARect : TRect) : TBitmap; { Копирование всего экрана }function CaptureScreen : TBitmap; { Копирование клиентской области формы или элемента }function CaptureClientImage(Control : TControl) : TBitmap; { Копирование всей формы элемента }function CaptureControlImage(Control : TControl) : TBitmap;{===============================================================}implementationfunction GetSystemPalette : HPalette;var PaletteSize : integer; LogSize : integer; LogPalette : PLogPalette; DC : HDC; Focus : HWND;begin result:=0; Focus:=GetFocus; DC:=GetDC(Focus); try PaletteSize:=GetDeviceCaps(DC, SIZEPALETTE); LogSize:=SizeOf(TLogPalette)+(PaletteSize-1)*SizeOf(TPaletteEntry); GetMem(LogPalette, LogSize); try with LogPalette^ do begin palVersion:=$0300; palNumEntries:=PaletteSize; GetSystemPaletteEntries(DC, 0, PaletteSize, palPalEntry); end; result:=CreatePalette(LogPalette^); finally FreeMem(LogPalette, LogSize); end; finally ReleaseDC(Focus, DC); end;end;function CaptureScreenRect(ARect : TRect) : TBitmap;var ScreenDC : HDC;begin Result:=TBitmap.Create; with result, ARect do begin Width:=Right-Left; Height:=Bottom-Top; ScreenDC:=GetDC(0); try BitBlt(Canvas.Handle, 0,0,Width,Height,ScreenDC, Left, Top, SRCCOPY ); finally ReleaseDC(0, ScreenDC); end; Palette:=GetSystemPalette; end;end;function CaptureScreen : TBitmap;begin with Screen do Result:=CaptureScreenRect(Rect(0,0,Width,Height));end;function CaptureClientImage(Control : TControl) : TBitmap;begin with Control, Control.ClientOrigin do result:=CaptureScreenRect(Bounds(X,Y,ClientWidth,ClientHeight));end;function CaptureControlImage(Control : TControl) : TBitmap;begin with Control do if Parent=Nil then result:=CaptureScreenRect(Bounds(Left,Top,Width,Height)) else with Parent.ClientToScreen(Point(Left, Top)) do result:=CaptureScreenRect(Bounds(X,Y,Width,Height));end;end.

Draw disable text

{************************ Draw Disabled Text ************** ***** This function draws text in "disabled" style. ***** ***** i.e. the text is grayed . ***** **********************************************************}function DrawDisabledText (Canvas : tCanvas; Str: PChar; Count: Integer; var Rect: TRect; Format: Word): Integer;begin SetBkMode(Canvas.Handle, TRANSPARENT); OffsetRect(Rect, 1, 1); Canvas.Font.color:= ClbtnHighlight; DrawText (Canvas.Handle, Str, Count, Rect,Format); Canvas.Font.Color:= ClbtnShadow; OffsetRect(Rect, -1, -1); DrawText (Canvas.Handle, Str, Count, Rect, Format);end;

Как менять разрешение экрана по ходу выполнения программы

function SetFullscreenMode:Boolean;var DeviceMode : TDevMode;begin with DeviceMode do begin dmSize:=SizeOf(DeviceMode); dmBitsPerPel:=16; dmPelsWidth:=640; dmPelsHeight:=480; dmFields:=DM_BITSPERPEL or DM_PELSWIDTH or DM_PELSHEIGHT; result:=False; if ChangeDisplaySettings(DeviceMode,CDS_TEST or CDS_FULLSCREEN) <> DISP_CHANGE_SUCCESSFUL then Exit; Result:=ChangeDisplaySettings(DeviceMode,CDS_FULLSCREEN) = DISP_CHANGE_SUCCESSFUL; end;end;procedure RestoreDefaultMode;var T : TDevMode absolute 0;begin ChangeDisplaySettings(T,CDS_FULLSCREEN);end;procedure TForm1.Button1Click(Sender: TObject);begin if setFullScreenMode then begin sleep(7000); RestoreDefaultMode; end;end;

Наверх

Как поместить картинку из базы данных, например MsSQL, в компонент TIMAGE ?

1) Предполагается, что поле BLOB (например, Pict)
2) в запросе Query.SQL пишется что-то вроде
'select Pict from sometable where somefield=somevalue'
3) запрос открывается
4) делается "присваивание":
Image1.Picture.Assing(TBlobField(Query.FieldByName('Pict'))
или, если известно, что эта картинка - Bitmap, то можно
Image1.Picture.Bitmap.Assing(TBlobField(Query.FieldByName('Pict'))

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


InfoCity

Маленькие хитрости с большой пользой

Зайцев О.В. и Владимиров А.М.

Вопросы - ответы - советы

  • Графика (Написание текста под углом, преобразование цвета, как менять разрешение экрана по ходу выполнения программы...)
  • Система (Регистрация программ в меню "Пуск", как проинсталлировать свои шрифты, вставить какую-нибудь программу внутрь EXE файла, инсталляторы, хранитель экрана, включение/выключение клавиатуры, мыши и монитора...)
  • Реестр (Добавление элементов в контекстное меню "Создать", новые звуковые события, деинсталяция, работа с реестром, INI-файлы...)
  • Прочее (Перехват клавиатуры от других программ, создание отчета в MS Word, заставка для программы, как создать свою кнопку в заголовке формы, сводка функций модуля Math...)

От авторов

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

Замечания и предложения можно присылать по адресу: MerlinTwi@chat.ru


InfoCity

Прочее

  • Как получить горизонтальную прокрутку (scrollbar) в ListBox?
  • Поиск строки в ListBox
  • Как вставить несколько строк в середину StringGrid или после определенной строки?
  • Пример получения позиции курсора из компоненты TMemo.
  • Функция Undo в TMemo
  • Как прокрутить текст в Tmemo или в TRichEdit
  • Как определить работает ли уже данное приложение или это первая его копия?
  • Пример вывода сообщения одной командой и ввода строки тоже одной командой.
  • Перетаскивание формы за ее поле.
  • Обработка событий от клавиатуры (перехват клавиатуры от других программ !)
  • Как сделать так, что при нажатии на Enter происходил переход к следующему элементу формы
  • Вставка и удаление компонент в форму в design-time
  • Создание отчета в MS Word
  • Перетаскивание файла drag-drop
  • Привлечение внимания к окну
  • Заставка для программы (splash form)
  • Прозрачная форма !
  • Как получить короткий путь файла если имеется длинный ("c:\Program Files" ==> "c:\progra~1")
  • Как создать свою кнопку в заголовке формы (на Caption Bar)
  • Преобразование текста OEM у Ansi
  • Состояние кнопки insert (Insert/Overwrite)
  • Сводка функций модуля Math
  • Внутри конструктора Create компонента создаю другой компонент, но Delphi помещает запись о втором компоненте в dfm-файл!
  • Как вставить иконку (или bitmap) в TRichEdit, причем так, чтобы пользователь мог ее удалить нажатием клавиши Del (как это сделано в Microsoft Word)?
Глюки
  • TImage
  • QReport

От авторов

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

Как получить горизонтальную прокрутку (scrollbar) в ListBox?

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

procedure TForm1.FormCreate(Sender: TObject);begin  ListBox1.Perform(LB_SETHORIZONTALEXTENT, 1000, Longint(0));end;
Второй параметр в вызове - ширина прокрутки в точках.

Поиск строки в ListBox

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

procedure TForm1.Button1Click(Sender: TObject);var S  : string;begin S:='1.'; with ListBox1 do    ItemIndex := Perform(LB_SELECTSTRING, ItemIndex, LongInt(S));end;
Более подробную информацию о работе команды LB_SELECTSTRING можно узнать из Help-а Win32.

Пример получения позиции курсора из компоненты TMemo.

procedure TForm1.Memo1KeyUp(Sender: TObject; var Key: Word;  Shift: TShiftState);begin Memo1Click(Self);end;procedure TForm1.Memo1Click(Sender: TObject);VAR  LineNum : LongInt;  CharNum : LongInt;begin  LineNum := Memo1.Perform(EM_LINEFROMCHAR, Memo1.SelStart, 0);  CharNum := Memo1.Perform(EM_LINEINDEX, LineNum, 0);  Label1.Caption := IntToStr(LineNum+1)+' : '+IntToStr((Memo1.SelStart-CharNum)+1);end;procedure TForm1.FormCreate(Sender: TObject);begin  Memo1Click(Self);end;

Функция Undo в TMemo

В компоненте TMemo предусмотрена функция отмены последней правки (Undo). Ее можно вызвать следующим образом:
Memo1.Perform(EM_UNDO,0,0);
Узнать о том, возможна ли отмена (т.е. есть ли что отменять) можно следующим образом:
UndoEnabled:=(Memo1.Perform(EM_CAUNDO,0,0)<>0);

Как прокрутить текст в Tmemo или в TRichEdit

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

Примерно так:
SendMessage(Memo1.Handle, EM_LINESCROLL, 0, Memo1.Lines.Count-1);

Как определить работает ли уже данное приложение или это первая его копия?

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

procedure TForm1.FormCreate(Sender: TObject); begin   {Проверяем есть ли указатель на предыдущую копию приложения}  IF hPrevInst <> 0 THEN BEGIN     {Если есть, то выдаем сообщение и выходим}    MessageDlg('Программа уже запущена!', mtError, [mbOk], 0);     Halt;   END;   {Иначе - ничего не делаем (не мешаем созданию формы)}end;
P.S. Для выхода необходимо использовать Halt, а не Close, как хотелось бы, так как форма еще не создана и закрывать нечего.
Есть и другой способ - по списку загруженных приложений
procedure TForm1.FormCreate(Sender: TObject);VAR Wnd : hWnd; buff : ARRAY[0.. 127] OF Char;Begin Wnd := GetWindow(Handle, gw_HWndFirst); WHILE Wnd <> 0 DO BEGIN  IF (Wnd <> Application.Handle) AND (GetWindow(Wnd, gw_Owner) = 0)  THEN BEGIN   GetWindowText (Wnd, buff, sizeof (buff ));   IF StrPas (buff) = Application.Title THEN    BEGIN    MessageDlg('Приложение уже загружено', mtWarning, [mbOk], 0);    Halt;   END;  END;  Wnd := GetWindow (Wnd, gw_hWndNext); END;End;
Еще один интересный способ для Win32. Дело в том, что можно в памяти создавать временные файлы. При перезагрузке они теряются, а так существуют. Кстати, этот метод можно использовать и для обмена информацией между вашими приложениями.
Пример:
program Project1;uses  Windows, // Обязательно  Forms,  Unit1 in 'Unit1.pas' {Form1};{$R *.RES}Const MemFileSize = 1024; MemFileName = 'one_inst_demo_memfile';Var MemHnd : HWND;begin  { Попытаемся создать файл в памяти }  MemHnd := CreateFileMapping(HWND($FFFFFFFF),                              nil,                              PAGE_READWRITE,                              0,                              MemFileSize,                              MemFileName);  { Если файл не существовал запускаем приложение }  if GetLastError<>ERROR_ALREADY_EXISTS then  begin   Application.Initialize;   Application.CreateForm(TForm1, Form1);   Application.Run;  end;  CloseHandle(MemHnd);end.
Часто при работе у пользователя может быть открыто 5-20 окон и сообщение о том, что программа уже запущено приводит к тому, что он вынужден полчаса искать ранее запущенную копию. Выход из положения - найдя копию программы активировать ее, для чего в последнем примере перед HALT необходимо добавить строку :
SetForegroundWindow(Wnd);
Например так:
program Project0;uses  Windows,  // !!!  Forms,  Unit0 in 'Unit0.pas' {Form1};var  Handle1 : LongInt;  Handle2 : LongInt;{$R *.RES}begin  Application.Initialize;  Handle1 := FindWindow('TForm1',nil);  if handle1 = 0 then    begin      Application.CreateForm(TForm1, Form1);      Application.Run;    end  else    begin      Handle2 := GetWindow(Handle1,GW_OWNER);       //Чтоб заметили :)      ShowWindow(Handle2,SW_HIDE); ShowWindow(Handle2,SW_RESTORE);       SetForegroundWindow(Handle1); // Активизируем    end;end.

Пример вывода сообщения одной командой и ввода строки тоже одной командой.

Вывод сообщения: ShowMessage('сообщение');
Ввод текста от пользователя: S:=InputBox('Заголовок', 'Сообщение', S{строка по умолчанию});

unit Unit1;interfaceuses   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms,  Dialogs, StdCtrls;type  TForm1 = class(TForm)    Button1: TButton;    Button2: TButton;    Button3: TButton;    procedure Button1Click(Sender: TObject);    procedure Button2Click(Sender: TObject);    procedure Button3Click(Sender: TObject);end;var  Form1: TForm1;implementation{$R *.DFM}procedure TForm1.Button1Click(Sender: TObject);begin  ShowMessage('Пример простого сообщения.'+#10+  'Данное сообщение выводится всегда в центре экрана.');end;procedure TForm1.Button2Click(Sender: TObject);begin  ShowMessagePos('Пример сообщения с указанием его положения на экране.',    Form1.Left+Button2.Left, Form1.Top+Button2.Top);end;procedure TForm1.Button3Click(Sender: TObject);begin  Button3.Caption := InputBox('Delphi для всех',  'Введите строку:', Button3.Caption);end;end.

Перетаскивание формы за ее поле

procedure TForm1.MouseDown(Sender: TObject; Button: TMouseButton;                            Shift: TShiftState; X, Y: Integer);const  SC_DragMove = $F012;  { a magic number }begin  ReleaseCapture;  perform(WM_SysCommand, SC_DragMove, 0);end;

Обработка событий от клавиатуры

I. Эмуляция нажатия клавиши.
Внутри приложения это выполняется достаточно просто с помощью вызова функции Windows API SendMessage() (можно воспользоваться и методом Perform того объекта (или формы), кому посылается сообщение о нажатой клавише).
Код
Memo1.Perform(WM_CHAR, Ord('A'), 0);
или
SendMessage(Memo1.Handle, WM_CHAR, Ord('A'), 0);
приведет к печати символа "A" в объекте Memo1.

II. Перехват нажатий клавиши внутри приложения.
Задача решается очень просто. Можно у формы установить свойство KeyPreview в True и обрабатывать событие OnKeyPress. Второй способ - перехватывать событие OnMessage для объекта Application.

III. Перехват нажатия клавиши в Windows.
Существуют приложения, которым необходимо перехватывать все нажатия клавиш в Windows, даже если в данный момент активно другое приложение. Это может быть, например, программа, переключающая раскладку клавиатуры, резидентный словарь или программа, выполняющая иные действия по нажатию "горячей" комбинации клавиш. Перехват всех событий в Windows (в том числе и событий от клавиатуры) выполняется с помощью вызова функции SetWindowsHook(). Данная функция регистрирует в системе Windows ловушку (hook) для определенного типа событий/сообщений. Ловушка - это пользовательская процедура, которая будет обрабатывать указанное событие. Основное здесь то, что эта процедура должна всегда присутствовать в памяти Windows. Поэтому ловушку помещают в DLL и загружают эту DLL из программы. Пока хоть одна программа использует DLL, та не может быть выгружена из памяти. Приведем пример такой DLL и программы, ее использующей. В примере ловушка перехватывает нажатие клавиш на клавиатуре, проверяет их и, если это клавиши "+" или "-", посылает соответствующее сообщение в конкретное приложение (окно). Окно ищется по имени его класса ("TForm1") и заголовку (caption, "XXX").
{текст библиотеки}library SendKey;uses WinTypes, WinProcs, Messages;const {пользовательские сообщения} wm_NextShow_Event = wm_User + 133; wm_PrevShow_Event = wm_User + 134; {handle для ловушки} HookHandle: hHook = 0;var SaveExitProc : Pointer;{собственно ловушка}function Key_Hook(Code: integer; wParam: word; lParam: Longint): Longint; export;var H: HWND;begin {если Code>=0, то ловушка может обработать событие} if Code >= 0 then  begin   {это те клавиши?}   if ((wParam = VK_ADD)or(wParam = VK_SUBTRACT)) and (lParam and $40000000 = 0)    then begin     {ищем окно по имени класса и по заголовку}      H := FindWindow('TForm1', 'XXX');     {посылаем сообщение}     if wParam = VK_ADD then       SendMessage(H, wm_NextShow_Event, 0, 0)     else       SendMessage(H, wm_PrevShow_Event, 0, 0);   end;  {если 0, то система должна дальше обработать это событие}  {если 1 - нет}  Result:=0; end else   {если Code<0, то нужно вызвать следующую ловушку}   Result := CallNextHookEx(HookHandle,Code, wParam, lParam);end;{при выгрузке DLL надо снять ловушку}procedure LocalExitProc; far;begin if HookHandle<>0 then  begin   UnhookWindowsHookEx(HookHandle);   ExitProc := SaveExitProc; end;end;{инициализация DLL при загрузке ее в память}begin {устанавливаем ловушку}  HookHandle := SetWindowsHookEx(wh_Keyboard, Key_Hook, 						   hInstance, 0); if HookHandle = 0 then    MessageBox(0, 'Unable to set hook!', 'Error', mb_Ok) else begin  SaveExitProc := ExitProc;  ExitProc := @LocalExitProc; end;end.
Размер такой DLL в скомпилированном виде будет около 3Кб, поскольку в ней не используются объекты из VCL.

Далее приведен код модуля в Delphi, который загружает DLL и обрабатывает сообщения от ловушки, просто отображая их в Label1.
unit Unit1;interfaceuses SysUtils,WinTypes,WinProcs,Messages,Classes,Graphics,Controls,Forms,Dialogs,StdCtrls;{пользовательские сообщения}const wm_NextShow_Event = wm_User + 133; wm_PrevShow_Event = wm_User + 134;type  TForm1 = class(TForm)    Label1: TLabel;    procedure FormCreate(Sender: TObject);  private	{обработчики сообщений}    procedure WM_NextMSG (Var M : TMessage); message wm_NextShow_Event;    procedure WM_PrevMSG (Var M : TMessage); message wm_PrevShow_Event;  end;var  Form1: TForm1;  P : Pointer;implementation{$R *.DFM}{загрузка DLL}function Key_Hook : Longint; far; external 'SendKey';procedure TForm1.WM_NextMSG (Var M : TMessage);begin  Label1.Caption:='Next message';end;procedure TForm1.WM_PrevMSG (Var M : TMessage); begin  Label1.Caption:='Previous message';end;procedure TForm1.FormCreate(Sender: TObject);begin  {если не использовать вызов процедуры из DLL в программе,    то компилятор удалит загрузку DLL из программы}  P:=@Key_Hook;end;end.
Конечно, свойство Caption в этой форме должно быть установлено в "XXX".

Как сделать так, что при нажатии на Enter происходил переход к следующему элементу формы

Ставите у формы KeyPreview = true и создаете событие KeyPress следующего вида:

procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char);begin if (Key = #13) then begin  Key:=#0;  Perform(WM_NEXTDLGCTL,0,0); end;end;

Вставка и удаление компонент в форму в design-time

Вопрос:
Каким образом можно отследить вставку и удаление компонент в форму в design-time? Такая информация могла бы пригодится, если моя компонента имеет ссылки на другие компоненты (например, как в связке TDateSource,TTable и др.)
Ответ:
Для получения такой информации предназначен метод
procedure Notification (AComponent: TComponent; Operation: TOperation); virtual;
класса TComponent. Перекрыв его в своей компоненты Вы можете произвести необходимые действия, в зависимости от значения параметра Operation типа
TOperation = (opInsert, opRemove);
объявленного в модуле Classes. Параметр AComponent - компонента, соответственно вставлемая или удаляемая, в зависимости от Operation.

Создание отчета в MS Word

(Пример для Delphi 1.0 поскольку в Delphi 2-3 лучше использовать:
var MsWord : variant;
MsWord := CreateOleObject('Word.Basic'); Для Delphi 3, пример ниже)

Создавать отчет в программе Word удобно если отчет имеет сложную структуру (тогда его быстрее создать в Word, чем в Qreport от Delphi, кроме того, этот QReport имеет "глюки"), либо, если после создания отчета его нужно будет изменять. Итак, первым делом в Word создается шаблон будущего отчета, это самый обыкновенный не заполненный отчет. А в места куда будет записываться информация нужно поставить метки. Например (для наглядности метки показаны зеленым цветом, реально они конечно не видны):

Накладная № Num
№ | Поставщик | Наименование товара | Код товара | Кол-во | Цена | Сумма
Table |  |  |  |  |  |
Сдал_______________________          Принял________________________             М.П.                                    М.П.

Далее в форму, откуда будут выводиться данные, вставляете компоненту DdeClientConv из палитры System. Назовем ее DDE1. Эта компонента позволяет передавать информацию между программами методом DDE. Свойства:
ConnectMode : ddeManual - связь устанавливаем вручную
DdeService : (winword) - с кем устанавливается связь
ServiceApplication : C:\MSOffice\Winword\WINWORD.EXE - полный путь доступа к программе. (Вот здесь можно наступить на грабли. Ведь Word может лежать в любой папке! Поэтому путь доступа к нему лучше взять из реестра, а еще лучше использовать OLE см.начало раздела)

Теперь пишем процедуру передачи данных:
{ Печать накладной }procedure Form1.PrintN;Var    S          : string;    i          : integer;    Sum        : double;  {итоговая сумма, кстати,совет: не пользуйтесь типом real!}    Tv, Ss     : PChar;begin S:=GetCurrentDir+'\Накладная.doc'; { имя открываемого документа } DDE1.OpenLink; { устанавливаем связь } Tv:=StrAlloc(20000); Ss:=StrAlloc(300); { выделяем память }  { даем команду открыть документ и установить курсор в начало документа } StrPCopy(Tv, '[FileOpen "'+S+'"][StartOfDocument]'); S:=NNakl.Text; { номер накладной }  { записываем в позицию Num номер накладной } StrCat(Tv, StrPCopy(SS, '[EditBookmark .Name = "Num", .Goto][Insert "'+S+'"]'+ '[EditBookmark .Name = "Table", .Goto]'); { и переходим к заполнению таблицы }  { передаем данные в Word } if not DDE1.ExecuteMacro(Tv, false) then    begin { сообщаем об ошибке и выход }    MessageDlg('Ошибка связи с Microsoft Word.', mtError, [mbOk], 0);     StrDispose(Tv); StrDispose(Ss);    exit;   end;  { Заполняем таблицу } Sum:=0; Nn:=0; for i:=0 to TCount do begin  inc(Nn);  { предполагаем, что данные находятся в массиве T }  StrPCopy(Tv, '[Insert "'+IntToStr(Nn)+'"][NextCell][Insert "'+T[i].Company+'"]'+   '[NextCell][Insert "'+T.TName+'"][NextCell][Insert "'+T.Cod+'"][NextCell]'+   '[Insert "'+IntToStr(T.Count)+'"][NextCell]'+   '[Insert "'+FloatToStr(T.Cena)+'"][NextCell]'+   '[Insert "'+FloatToStr(T.Count*T.Cena)*+'"][NextCell]'));  inc(Nn);  Sum:=Sum+(T.Count*T.Cena); { итоговая сумма }  if not DDE1.ExecuteMacro(Tv, false)   then begin    MessageDlg('Ошибка связи с Microsoft Word.', mtError, [mbOk], 0);    exit;   end; end; { Записываем итоговую сумму } StrPCopy(Tv,  '[NextCell][Insert "Итого"][NextCell][NextCell][NextCell]'+  '[Insert "'+FloatToStr(Sum)+'"]')); if not DDE1.ExecuteMacro(Tv, false)  then MessageDlg('Ошибка связи с Microsoft Word.', mtError, [mbOk], 0)  else MessageDlg('Акт удачно создан. Перейдите в Microsoft Word.',         mtInformation, [mbOk], 0); StrDispose(Tv); StrDispose(Ss);end;
Для Delphi 2 и выше=== Cut Пример by Sergey Arkhipov 2:5054/88.10 ===Пример проверен только на русском Word 7.0! Может, поможет...unit InWord;interfaceuses  ... ComCtrls; // Delphi3  ... OLEAuto;  // Delphi2[skip]procedure TPrintForm.MPrintClick(Sender: TObject);var W: Variant;    S: String;begin  S:=IntToStr(Num);   try // А вдруг где ошибка :)    W:=CreateOleObject('Word.Basic');    // Создаем документ по шаблону MyWordDot    // с указанием пути если он не в папке шаблонов Word    W.FileNew(Template:='C:\MyPath\DB\MyWordDot',NewTemplate:=0);    // Отключение фоновой печати (на LJ5L без этого был пустой лист)    W.ToolsOptionsPrint(Background:=0);    // Переходим к закладке Word'a 'Num'    W.EditGoto('Num'); W.Insert(S);    //Сохранение    W.FileSaveAs('C:\MayPath\Reports\MyReport')    W.FilePrint(NumCopies:='2'); // Печать 2-х копий  finally    W.ToolsOptionsPrint(Background:=1);    W:=UnAssigned;  end;end;{.....}=== Cut Конец примера ===

Спасибо Сергею :) И еще, как определить установлен ли на компьютере Word, запустить его и загрузить в него текст из программы?

Пример:

var MsWord: Variant;...try // Если Word уже запущен MsWord := GetActiveOleObject('Word.Application'); // Взять ссылку на запущенный OLE объект except  try  // Word не запущен, запустить  MsWord := CreateOleObject('Word.Application');  // Создать ссылку на зарегистрированный OLE объект  MsWord.Visible := True;   except    ShowMessage('Не могу запустить Microsoft Word');    Exit;   end;  end; end;...MSWord.Documents.Add; // Создать новый документMsWord.Selection.Font.Bold := True; // Установить жирный шрифтMsWord.Selection.Font.Size := 12; // установить 12 кегльMsWord.Selection.TypeText('Текст');

По командам OLE Automation сервера см. help по Microsoft Word Visual Basic.

Ну вот и все.

Перетаскивание файла

{ На эту форму можно бросить файл (например из проводника)   и он будет открыт }unit Unit1;interfaceuses  Windows, Messages, SysUtils, Classes, Graphics,   Controls, Forms, Dialogs,StdCtrls,   ShellAPI {обязательно!};type  TForm1 = class(TForm)    Memo1: TMemo;    FileNameLabel: TLabel;    procedure FormCreate(Sender: TObject);    procedure FormDestroy(Sender: TObject);  protected   {Это и есть самая главная процедура}    procedure WMDropFiles(var Msg: TMessage); message wm_DropFiles; end;var  Form1: TForm1;implementation{$R *.DFM}procedure TForm1.WMDropFiles(var Msg: TMessage);var    Filename: array[0 .. 256] of Char;   Count   : integer;begin  { Получаем количество файлов (просто пример) }   nCount := DragQueryFile( msg.WParam, $FFFFFFFF,      acFileName, cnMaxFileNameLen);  { Получаем имя первого файла }  DragQueryFile( THandle(Msg.WParam),     0, { это номер файла }     Filename,SizeOf(Filename) ) ;  { Открываем его }  with FileNameLabel do begin   Caption := LowerCase(StrPas(FileName));   Memo1.Lines.LoadfromFile(Caption);  end;  { Отдаем сообщение о завершении процесса }  DragFinish(THandle(Msg.WParam));end;procedure TForm1.FormCreate(Sender: TObject);begin { Говорим Windows, что на нас можно бросать файлы } DragAcceptFiles(Handle, True); end;procedure TForm1.FormDestroy(Sender: TObject);begin { Закрываем за собой дверь золотым ключиком} DragAcceptFiles(Handle, False); end;end.

Привлечение внимания к окну

Часто возникает проблема - в многооконном приложении необходимо обратить внимание пользователя на то, что какое-то из окон требует внимания (например, к нему пришло сообщение по DDE, в нем завершился какой-либо процесс, произошла ошибка ...). Это легко сделать, используя команду API FlashWindow:

procedure TForm1.Timer1Timer(Sender: TObject);begin FlashWindow(Handle,true);end;
В данном примере FlashWindow вызывается по таймеру ежесекундно, что приводит к миганию заголовка окна.

Заставка для программы

Сведения о программе, авторские права и т.д., лучше оформить в виде отдельной формы и показывать ее при запуске программы (как это сделано в Word).
Сделать это не сложно:
1. Создаете форму (например SplashForm).
2. Объявляете ее свободной (availableForms).
3. В Progect Source вставляете следующее (например):

    program Splashin;	uses		Forms,		Main in 'MAIN.PAS',		Splash in 'SPLASH.PAS'	{$R *.RES}	begin        try		SplashForm := TSplashForm.Create(Application);		SplashForm.Show;		SplashForm.Update;		Application.CreateForm(TMainForm, MainForm);		SplashForm.Hide;        finally		SplashForm.Free;        end;		Application.Run;	end.

И форма SplashForm держится на экране пока выполняется Create в главной форме. Но иногда она появляется и пропадает очень быстро, поэтому нужно сделать задержку:
1. Добавляете на форму таймер с событием:

    procedure TSplashForm.Timer1Timer(Sender: TObject);    begin      Timer1.Enabled := False;    end;
2. Событие onCloseQuery для формы:
    procedure TSplashForm.FormCloseQuery(Sender: TObject; var CanClose: Boolean);    begin      CanClose := Not Timer1.Enabled;    end;
3. И перед SplashForm.Hide; ставите цикл:
    repeat      Application.ProcessMessages;    until SplashForm.CloseQuery;
4. Все! Осталось установить на таймере период задержки 3-4 секунды.
5. На последок, у такой формы желательно убрать Caption:
SetWindowLong (Main.Handle,GWL_STYLE, GetWindowLong(Main.Handle, GWL_STYLE) AND NOT WS_CAPTION OR WS_SIZEBOX);

Прозрачная форма

Эта форма имет прозрачный фон !!!unit unit1;interfaceuses  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,  StdCtrls;type  TForm1 = class(TForm)  Button1: TButton;  Button2: TButton;    // это просто кнопка на форме - для демонстрации  protected    procedure RebuildWindowRgn;    procedure Resize; override;  public    constructor Create(AOwner: TComponent); override;  end;var  Form1 : TForm1;implementation// ресурс этой формы{$R *.DFM}{ Прозрачная форма }constructor TForm1.Create(AOwner: TComponent);begin  inherited;  // убираем сколлбары, чтобы не мешались  // при изменении размеров формы  HorzScrollBar.Visible:= False;  VertScrollBar.Visible:= False;  // строим новый регион  RebuildWindowRgn;end;procedure TForm1.Resize;begin  inherited;  // строим новый регион  RebuildWindowRgn;end;procedure TForm1.RebuildWindowRgn;var  FullRgn, Rgn: THandle;  ClientX, ClientY, I: Integer;begin  // определяем относительные координаты клиенской части  ClientX:= (Width - ClientWidth) div 2;  ClientY:= Height - ClientHeight - ClientX;  // создаем регион для всей формы  FullRgn:= CreateRectRgn(0, 0, Width, Height);  // создаем регион для клиентской части формы  // и вычитаем его из FullRgn  Rgn:= CreateRectRgn(ClientX, ClientY, ClientX + ClientWidth, ClientY +ClientHeight);  CombineRgn(FullRgn, FullRgn, Rgn, rgn_Diff);  // теперь добавляем к FullRgn регионы каждого контрольного элемента  for I:= 0 to ControlCount -1 do    with Controls[I] do begin      Rgn:= CreateRectRgn(ClientX + Left, ClientY + Top, ClientX + Left +Width, ClientY + Top + Height);      CombineRgn(FullRgn, FullRgn, Rgn, rgn_Or);    end;  // устанавливаем новый регион окна  SetWindowRgn(Handle, FullRgn, True);end;end.
А как Вам понравится эта форма ?
unit rgnu;interfaceuses  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,  Buttons, Menus;type  TForm1 = class(TForm)    procedure FormCreate(Sender: TObject);    procedure Button1Click(Sender: TObject);    procedure FormPaint(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;  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 := 'OOOH! Doughnuts!';  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.Button1Click(Sender: TObject);begin  Close;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 < RR 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;end.

Как получить короткий путь файла если имеется длинный ("c:\Program Files" ==> "c:\progra~1")

GetShortPathName()

Как создать свою кнопку в заголовке формы (на Caption Bar)

Непосредственно такой функции вроде нет, но можно изловчиться. Нарисовать там кнопку вручную и обрабатывать команды нажатия мышки на Caption Bar.
Пример.

unit Main;interfaceuses  Windows, Buttons, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;type  TForm1 = class(TForm)    procedure FormResize(Sender: TObject);  private    CaptionBtn : TRect;    procedure DrawCaptButton;    procedure WMNCPaint(var Msg : TWMNCPaint); message WM_NCPaint;    procedure WMNCActivate(var Msg : TWMNCActivate); message WM_NCACTIVATE;    procedure WMSetText(var Msg : TWMSetText); message WM_SETTEXT;    procedure WMNCHitTest(var Msg : TWMNCHitTest); message WM_NCHITTEST;    procedure WMNCLButtonDown(var Msg : TWMNCLButtonDown); message WM_NCLBUTTONDOWN;  public    { Public declarations }  end;var  Form1: TForm1;implementationconst  htCaptionBtn = htSizeLast + 1;{$R *.DFM}procedure TForm1.DrawCaptButton;var  xFrame,  yFrame,  xSize,  ySize  : Integer;  R : TRect;begin  //Dimensions of Sizeable Frame  xFrame := GetSystemMetrics(SM_CXFRAME);  yFrame := GetSystemMetrics(SM_CYFRAME);  //Dimensions of Caption Buttons  xSize  := GetSystemMetrics(SM_CXSIZE);  ySize  := GetSystemMetrics(SM_CYSIZE);  //Define the placement of the new caption button  CaptionBtn := Bounds(Width - xFrame - 4*xSize + 2,                       yFrame + 2, xSize - 2, ySize - 4);  //Get the handle to canvas using Form's device context  Canvas.Handle := GetWindowDC(Self.Handle);  Canvas.Font.Name := 'Symbol';  Canvas.Font.Color := clBlue;  Canvas.Font.Style := [fsBold];  Canvas.Pen.Color := clYellow;  Canvas.Brush.Color := clBtnFace;  try    DrawButtonFace(Canvas, CaptionBtn, 1, bsAutoDetect, False, False, False);    //Define a smaller drawing rectangle within the button    R := Bounds(Width - xFrame - 4 * xSize + 2,                       yFrame + 3, xSize - 6, ySize - 7);    with CaptionBtn do      Canvas.TextRect(R, R.Left + 2, R.Top - 1, 'W');  finally    ReleaseDC(Self.Handle, Canvas.Handle);    Canvas.Handle := 0;  end;end;procedure TForm1.WMNCPaint(var Msg : TWMNCPaint);begin  inherited;  DrawCaptButton;end;procedure TForm1.WMNCActivate(var Msg : TWMNCActivate);begin  inherited;  DrawCaptButton;end;procedure TForm1.WMSetText(var Msg : TWMSetText);begin  inherited;  DrawCaptButton;end;procedure TForm1.WMNCHitTest(var Msg : TWMNCHitTest);begin  inherited;  with Msg do    if PtInRect(CaptionBtn, Point(XPos - Left, YPos - Top)) then      Result := htCaptionBtn;end;procedure TForm1.WMNCLButtonDown(var Msg : TWMNCLButtonDown);begin  inherited;  if (Msg.HitTest = htCaptionBtn) then    ShowMessage('You hit the button on the caption bar');end;procedure TForm1.FormResize(Sender: TObject);begin  //Force a redraw of caption bar if form is resized  Perform(WM_NCACTIVATE, Word(Active), 0);end;end.

Преобразование текста OEM у Ansi

Эта версия работает под любым Delphi.
(Начиная с Delphi 2, это можно записать короче с использованием AnsiToOem и OemToAnsi.)
Здесь все просто.

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 }

Состояние кнопки insert (Insert/Overwrite)

{------------------------------------------}{ Returns the status of the Insert key.    }{------------------------------------------}function InsertOn: Boolean;begin  if LowOrderBitSet(GetKeyState(VK_INSERT))   then InsertOn := true   else InsertOn := falseend;

Сводка функций модуля Math

Здесь я привожу полный список всех функций и процедур модуля Math. При переходе от Delphi 2 к Delphi 3 модуль Math почти не изменился, фирма Borland ввела в него только три новые функции: MaxIntVal ue, MInIntValue и Sumint. Эти функции отличаются от своих прототипов (MaxValue, MI nVal ue и Sum) лишь тем, что работают исключительно с целыми числами, не принимая и не возвращая величин с плавающей точкой. Что касается остальных функций, то большинство из них вполне очевидно. Если вам покажется иначе - что ж, садитесь за исследования. И не надейтесь, что все тайны Delphi достанутся вам на блюдечке в виде help-файла!
Тригонометрические функции и процедуры
ArcCos - Арккосинус
ArcCosh - Пиперболический арккосинус
ArcSIn - Арксинус
ArcSInh - Гиперболический арксинус
ArcTahn - Гиперболический арктангенс
ArcTan2 - Арктангенс с учетом квадранта (функция ArcTan, не учитывающая квадрант, находится в модуле System)
Cosh - Гиперболический косинус
Cotan - Котангенс
CycleToRad - Преобразование циклов в радианы
DegToRad - Преобразование градусов в радианы
GradToRad - Преобразование градов в радианы
Hypot - Вычисление гипотенузы прямоугольного треугольника по длинам катетов
RadToCycle - Преобразование радианов в циклы
RadToDeg - Преобразование радианов в градусы
RacIToGrad - Преобразование радианов в грады
SinCos - Вычисление синуса и косинуса угла. Как и в случае SumAndSquares и MeanAndStdDev, одновременная генерация обеих величин происходит быстрее
Sinh - Гиперболический синус
Tan - Тангенс
Tanh - Гиперболический тангенс

Арифметические функции и процедуры
Cell - Округление вверх
Floor - Округление вниз
Frexp - Вычисление мантиссы и порядка заданной величины
IntPower - Возведение числа в целую степень. Если вы не собираетесь пользоваться экспонентами с плавающей точкой, желательно использовать эту функцию из-за ее скорости
Ldexp - Умножение Х на 2 в заданной степени
LnXPI - Вычисление натурального логарифма Х+1. Рекомендуется для X, близких к нулю
LogN - Вычисление логарифма Х по основанию N
LogIO - Вычисление десятичного логарифмах
Log2 - Вычисление двоичного логарифмах
Power - Возведение числа в степень. Работает медленнее IntPower, но для операций с плавающей точкой вполне приемлемо

Финансовые функции и процедуры
DoubleDecliningBalance - Вычисление амортизации методом двойного баланса
FutureValue - Будущее значение вложения
InterestPayment - Вычисление процентов по ссуде
InterestRate - Норма прибыли, необходимая для получения заданной суммы
InternalRateOfReturn - Вычисление внутренней скорости оборота вложения для ряда последовательных выплат
NetPresentValue - Вычисление чистой текущей стоимости вложения для ряда последовательных выплат с учетом процентной ставки
NumberOf Periods - Количество периодов, за которое вложение достигнет заданной величины
Payment - Размер периодической выплаты, необходимой для погашения ссуды, при заданном числе периодов, процентной ставке, а также текущем и будущем значениях ссуды
PerlodPayment - Платежи по процентам за заданный период
PresentValue - Текущее значение вложения
SLNDepreclatlon - Вычисление амортизации методом постоянной нормы
SYDepreclatlon - Вычисление амортизации методом весовых коэффициентов

Статистические функции и процедуры
MaxIntValue - Максимальное значение в наборе целых чисел. Функция появилась в Delphi 3. ее не существует в Delphi 2
MaxValue - Максимальное значение в наборе чисел. В Delphi 2 функция возвращает минималъное значение
Mean - Среднее арифметическое для набора чисел
MeanAndStdDev - Одновременное вычисление среднего арифметического и стандартного отклонения для набора чисел. Вычисляется быстрее, чем обе величины по отдельности
MinIntValLie - Минимальное значение в наборе целых чисел. Функция появилась в Delphi 3, ее не существует в Delphi 2
MInValue - Минимальное значение в наборе чисел. В Delphi 2 функция возвращает максимальное значение
MoiiientSkewKurtosIs - Статистические моменты порядков с первого по четвертый, а также асимметрия (skew) и эксцесс (kurtosis) для набора чисел
Norm - Норма для набора данных (квадратный корень из суммы квадратов)
PopnStdDev - Выборочное стандартное отклонение. Отличается от обычного стандартного отклонения тем, что при вычислениях используется выборочное значение дисперсии, PopnVarl апсе (см. ниже)
PopnVarlance - Выборочная дисперсия. Использует "смещенную" формулу TotalVanance/n
RandG - Генерация нормально распределенных случайных чисел с заданным средним значением и среднеквадратическим отклонением
StdDev - Среднеквадратическое отклонение для набора чисел
Sum - Сумма набора чисел
SLimsAndSquares - Одновременное вычисление суммы и суммы квадратов для набора чисел. Как и в других функциях модуля Math, обе величины вычисляются быстрее, чем по отдельности
Sumint - Сумма набора целых чисел. Функция появилась в Delphi 3, ее не существует в Delphi 2
SLimOfSquares - Сумма квадратов набора чисел
Total Variance - "Полная дисперсия" для набора чисел. Это сумма квадратов расстояний всех величин от их среднего арифметического
Variance - Выборочная дисперсия для набора чисел. Функция использует "несмещенную" формулу TotalVanапсе/ (п -1)

Глюки TImage

При увеличении размера компонента TImage в RunTime пытаюсь рисоватьзаново на всем поле, но отображается только часть компонента (прежнегоразмера). В чем дело?
Ответ: Нужно при инициализации выполнить SetBounds(), с максимальными размерами.

Глюки QReport

Обнаружил, что компонент QReport никак не реагирует на установки принтера PrinterSetup диалога, вызываемого нажатием кнопочкисобственного Preview!
В QuickReport есть собственный объект TQRPrinter, установки которого он использует при печати, а стандартные установки принтеров на него не влияют. В диалоге PrinterSetup, вызываемом из Preview можно лишь выбрать принтер на который нужно печатать (если, конечно, установлено несколько принтеров).

Советую поставить обновление QReport на 2.0J с www.qusoft.com.

Перед печатью (не только из QReport) программно установите требуемый драйвер принтера текущим для Windows

function SetDefPrn(const stDriver : string) : boolean;begin  SetPrinter(nil).Free;  Result := WriteProfileString('windows', device', PChar( stDriver));end;
После печати восстановите установки.

Имеется StringGrid с n-ым количеством строк. Как вставить еще несколько строк в середину StringGrid или после определенной строки?

По-видимому, надо добавить строк в конец, изменив Grid.RowCount, а потом раздвинуть строки циклом снизу вверх:
Grid.Rows.Strings[i] := Grid.Rows.Strings[i - 1];

Или я бы сделал метод рисования этой таблицы, а данные хранил бы в отдельном stringList-е, там есть методы вставки, а вообще-то для этих целей предпочитаю DrawGrid: переопределяю метод onDrawCell, всё же объектная модель лучше и данные проще контролировать.

Внутри конструктора Create компонента создаю другой компонент, но Delphi помещает запись о втором компоненте в dfm-файл!

У меня такая проблема: я пишу компонент, который внутри себя создаёт другой компонент. Конструктор первого компонента выглядит примерно так:

constructor TFirstComp.Create(AOwner:TComponent);begin inherited Create(AOwner); SecondComp:=TSecondComp.Create(Owner)end;

Проблема заключается в том, что при помещении первого компонента на форму в dfm-файл записывается информация и о втором компоненте тоже. А в pas-файл - только о первом. Это приводит к конфликтам. Для меня принципиально, чтобы хозяин у второго компонента был тот же, что и у первого. Как не дать Delphi поместить запись о TSecondComp в dfm-файл?

Попробуйте сделать так:

constructor TFirstComp.Create(AOwner:TComponent);begin inherited Create(AOwner); SecondComp:=TSecondComp.Create(SELF);end;

Т.е. дочернему компоненту в качастве владельца передавайте его непосредственного хозяина.

Как вставить иконку (или bitmap) в TRichEdit, причем так, чтобы пользователь мог ее удалить нажатием клавиши Del (как это сделано в Microsoft Word)?

Посмотрите компонент RichEdit98 (полностью бесплатный). ftp://ftp.bcsmi.minsk.by/alex/


Delphi 4. Использование реестра

Алексей Федоров

Реестр - это центральное хранилище информации о параметрах системы и установленных программах. В версиях Windows до Windows 95 программисты сохраняли параметры программ либо в INI-файлах WIN.INI и SYSTEM.INI, либо в дополнительных INI-файлах. Хотя использование INI-файлов поддерживается и в Win32, Microsoft настоятельно рекомендует для хранения необходимых в работе программы параметров пользоваться реестром. Реестр представляет собой иерархическую базу данных, cостоящую из секций, подсекций и элементов. Каждая секция имеет свое назначение. Хранить данные о пользовательских программах 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;

interface

uses
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;

Чтение данных

Для чтения данных в том или ином формате используются методы ReadXXX, перечисленные в приведенной выше таблице. Здесь нет каких-либо тонкостей, за исключением случая, когда данные представлены в формате binary data. Пример таких данных приведен для элемента Capabilities на следующем рисунке.

Как прочитать такие данные? Вспомним, что в нашем распоряжении есть метод GetDataType, позволяющий определить тип данных, метод GetDataSize, возвращающий размер данных и метод ReadBinaryData для чтения данных. Так как нам известен размер данных, мы можем воспользоваться динамическим массивом, устанавливая его размер с помощью метода SetLength. После считывания бинарных данных каждый элемент массива будет хранить один элемент данных. Нам останется только выполнить цикл, в каждой интерации которого мы будем извлекать один элемент данных, форматировать его и отображать на экране.

Ниже показан пример получения данных для элемента Capabilities.

procedure
  TForm1.Button1Click(Sender: TObject);
const
Key : String = '\Enum\Network\Family\0000\';
Val : String = 'Capabilities';
var
Data : Array of Byte; // Динамический массив!
S : String;
sz : Word;
I : Word;
begin
R := TRegistry.Create;
with R do
begin
//
// Задать корневую секцию
//
RootKey :=
  HKEY_LOCAL_MACHINE;
//
// Открыть подсекцию
//
OpenKey(Key, False);
//
// Если это – бинарные данные
//
if GetDataType(Val) =
  rdBinary
then
begin
//
// Определить их размер
//
sz := GetDataSize(Val);
if sz > 0 then
begin
//
// Установить размер динамического массива
//
SetLength(Data, sz);
//
// Прочитать данные в массив
//
ReadBinaryData(Val, Data[0], sz);
S := Val + ' = ';
for I := 0 to sz - 1 do
begin
//
// Сформатировать
//
S := S + Format('%2x',[Data[I]]);
end;
//
// Показать
//
Edit1.Text := S;
end;
end;
Free;
end;
end;

Чтение всей подсекции

Иногда бывает необходимо прочитать всю подсекцию. Для выполнения этой задачи мы должны воспользоваться методами GetValueNames и уже занкомыми нам методами GetDataType и GetDataSize. После того как мы получили имена элементов подсекции, мы, в цикле, определяем тип хранимой в элементе информации и считываем ее. На приведенном ниже примере показано, как это сделать для секции, приведенной на рисунке в разделе "Чтение бинарных данных".

procedure
  TForm1.Button1Click(Sender: TObject);
const
Key : String = '\Enum\Network\Family\0000\';
var
Data : Array of Byte;
L : TStringList;
S : String;
sz : Word;
I,J : Word;
begin
R := TRegistry.Create;
L := TStringList.Create;
with R do
begin
//
// Задать корневую секцию
//
RootKey :=
  HKEY_LOCAL_MACHINE;
//
// Открыть подсекцию
//
OpenKey(Key, False);
//
// Получить названия элементов
//
GetValueNames(L);
If L.Count > 0 Then
begin
for I := 0 to L.Count - 1 do
begin
//
// Узнать тип данных каждого элемента
//
case GetDataType(L[I]) of
// Строка?
rdString,
rdExpandString :
S := '"' + ReadString(L[I]) + '"';
// Цедочисленный?
rdInteger :
S := IntToStr(ReadInteger(L[I]));
// Бинарный?
rdBinary :
begin
sz := GetDataSize(L[I]);
SetLength(Data, sz);
ReadBinaryData(L[I], Data[0], sz);
S := '';
for J := 0 to sz - 1 do
begin
S := S + Format('%2x',[Data[I]]);
end;
end;
// Неизвестный?
rdUnknown :
S := 'Unknown';
end;
Memo1.Lines.Add(L[I] + #9'' + S);
end;
end;
Free;
end;
L.Free;
end;

Запись бинарных данных

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

Ниже показан пример записи бинарных данных с использованием метода WriteBinaryData.

procedure
  TForm1.Button1Click(Sender: TObject);
var
B : Array [0..15] of Byte;
I : Byte;
Const
SubKey : String = 'Software\RegDemo';
begin
R := TRegistry.Create;
with R do
begin
//
// Инициализировать данные случайным образом
//
for I := 0 to 15 do
B[I] := Random(255);
//
// Создать подсекцию
//
OpenKey(SubKey +
  '\BinKey', True);
//
// Записать данные
//
WriteBinaryData('Value', B, SizeOf(B));
Free;
end;
end;

Сохранение подсекции в файле

Для сохранения подсекции (и всех ее вложенных подсекций) в файле мы используем метод SaveKey. Например:

var
R : TRegistry;
Const
SubKey : String = 'Software\RegDemo\';

procedure TForm1.Button1Click(Sender: TObject);

begin
R := TRegistry.Create;
If R.SaveKey(SubKey, 'savedemo') then
ShowMessage('Подсекция сохранена')
else
ShowMessage('Ошибка сохранения подсекции');
R.Free;
end;

Получение информации о подсекции

Для получения информации о подсекции мы можем использовать функцию GetKeyInfo. Данная функция заполняет структуру типа TRegKeyInfo, из полей которой можно узнать:

  • число вложенных подсекций;
  • самое длинное название подсекции (в символах);
  • число элементов;
  • самое длинное название элемента;
  • максимальный размер элемента;
  • время последней записи подсекции/элемента.

Пример использования GetKeyInfo функции показан ниже.

var
R : TRegistry;
KI : TRegKeyInfo;
const
Key : String = '\Enum\Network\Family\0000\';

procedure TForm1.Button1Click(Sender: TObject);
begin
R := TRegistry.Create;
with R do
begin
//
// Задать корневую секцию
//
RootKey :=
  HKEY_LOCAL_MACHINE;
//
// Открыть подсекцию
//
OpenKey(Key, False);
//
if GetKeyInfo(KI) then
begin
with KI do
begin
Memo1.Lines.Add(CurrentPath + #13#10);
Memo1.Lines.Add('MaxSubKeyLen' + #9 +
IntToStr(MaxSubKeyLen));
Memo1.Lines.Add('NumValues' + #9 +
IntToStr(NumValues));
Memo1.Lines.Add('MaxValueLen' + #9 +
IntToStr(MaxValueLen));
Memo1.Lines.Add('MaxDataLen' + #9 +
IntToStr(MaxDataLen));
Memo1.Lines.Add('FileTime' + #9#9 +
DateTimeToStr(FileTime.dwLowDateTime));
end;
end;
end;
end;

Использование программы REGEDIT

Если вам необходимо занести какие-то значения в системный реестр или просто создать пустую подсекцию - такие функции, например, могут быть возложены на программу установки, — то можно воспользоваться программой REGEDIT. Для этого необходимо создать специальный текстовый файл и указать его в качестве параметра при вызове программы REGEDIT. Для нашего примера (создание подсекции) этот файл может выглядеть следующим образом:

REGEDIT4

[HKEY_CURRENT_USER\Software\RegDemo]

Ниже показана подпрограмма, которая создает данный файл и вызывает REGEDIT для обновления содержимого реестра.

{///////////////////////////////////////////////////////////////
Подпрограмма REGUPDATE - создание файла REGDEMO.REG и обновление
содержимого регистратора через вызов программы REGEDIT
///////////////////////////////////////////////////////////////}

Procedure TForm1.RegUpdate;
Const
RegID : String = 'REGEDIT4'+#13#10;
RegPath : String = '[HKEY_LOCAL_MACHINE\SOFTWARE\';
Var
RegFile : TFileStream;
RegItem : String;
RegCmd : String;
P : PChar;
RegWnd : hWnd;
Begin
// Создать регистрационный файл
RegFile := TFileStream.Create('REGDEMO.REG', fmCreate);
RegItem := RegPath + 'RegDemo]'+#13#10;
RegFile.Write(RegID[1], Length(RegID));
RegFile.Write(RegItem[1], Length(RegItem));
RegFile.Free;
// Вызвать REGEDIT и обновить реестр
RegCmd := 'REGEDIT /s'+'REGDEMO.REG';
StrPCopy(P, RegCmd);
WinExec(P, SW_MINIMIZE);
// Завершающие действия
If FileExists('REGDEMO.REG') Then
DeleteFile('REGDEMO.REG');
End;


InfoCity

Система

  • Советы для написания программ-инсталляторов
    • Регистрация программ в меню "Пуск" Windows 95
    • Как программно создать ярлык?
    • Затенить кнопку закрыть в заголовке формы
    • Копирование файлов
    • Как скопировать все файлы вместе с подкаталогами
    • Удаление каталога со всем содержимым
    • Определение системной информации
    • Как проинсталлировать свои шрифты?
    • Вставить какую-нибудь программу внутрь EXE файла
    • Хочется создать ну очень маленький инсталлятор
    • Рисую две иконки 32х32 и 16х16, но под NT 32х32 не показывается!
  • Работа с принтером
  • Система
    • Хранитель экрана
    • Включение/выключение клавиатуры, мыши и монитора!
    • Переключение языка из программы на Delphi
    • Как отловить нажатия клавиш для всех процессов в системе?
    • Информация о состоянии клавиатуры
    • Управление питанием ЭВМ из Delphi
    • Пример получения списка запущенных приложений.
    • Как отключить показ кнопки программы в TaskBar и по Alt-Tab и в Ctrl-Alt-Del
    • Добавление программы в автозапуск
    • Удалить файл в корзину? Запросто!
    • Добавить ссылку на мой файл в меню Пуск|Документы
    • Устанавливаем свой WallPaper для Windows
    • Как запретить кнопку Close [x] в заголовке окна.
    • Каким образом можно изменить системное меню формы?
    • Запуск внешней программы и ожидание ее завершения
    • Как узнать местоположение специальных папок у Windows?
    • Как воспроизвести wav-файл из ресурса (в EXE) ?
    • Как скрыть таскбар?
    • События нажатия на системные кнопки формы (минимизация, закрытие...)
  • Сети. Как подключить и отключить сетевой дисковод из своей программы?
  • Внешние модули (DLL), нити
    • Надо подключить DLL и использовать некоторые ее функции.
    • Как передать при создании нити (Tthread) ей некоторое значение?
    • CGI-програма должна выдавать в браузер Gif изображение.

От авторов

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

Регистрация программ в меню "Пуск" Windows 95.

Подобная проблема возникает при создании инсталляторов и деинсталляторов. Наиболее простой и гибкий путь - использование DDE. При этом посылаются запросы к PROGMAN. Для этого необходимо поместить на форму компонент для посылки DDE запросов - объект типа TDdeClientConv. Для определенности назовем его DDEClient. Затем добавим метод для запросов к PROGMAN:

Function TForm2.ProgmanCommand(Command:string):boolean; var  macrocmd:array[0..88] of char; begin  DDEClient.SetLink('PROGMAN','PROGMAN');  DDEClient.OpenLink; { Устанавливаем связь по DDE }  strPCopy(macrocmd,'['+Command+']'); { Подготавливаем ASCIIZ строку }  ProgmanCommand :=DDEClient.ExecuteMacro(MacroCmd,false);  DDEClient.CloseLink; { Закрываем связь по DDE } end;
При вызове ProgmanCommand возвращает true, если посылка макроса была успешна. Система команд (основных) приведена ниже:
Create(Имя группы, путь к GRP файлу)
Создать группу с именем "Имя группы", причем в нем могут быть пробелы и знаки препинания. Путь к GRP файлу можно не указывать, тогда он создастся в каталоге Windows.
Delete(Имя группы)
Удалить группу с именем "Имя группы"
ShowGroup(Имя группы, состояние)
Показать группу в окне, причем состояние - число, определяющее параметры окна:
1-нормальное состояние + активация
2-миним.+ активация
3-макс. + активация
4-нормальное состояние
5-Активация
AddItem(командная строка, имя раздела, путь к иконке, индекс иконки (с 0), Xpos,Ypos, рабочий каталог, HotKey, Mimimize)
Добавить раздел к активной группе. В командной строке, имени размера и путях допустимы пробелы, Xpos и Ypos - координаты иконки в окне, лучше их не задавать, тогда PROGMAN использует значения по умолчанию для свободного места. HotKey - виртуальный код горячей клавиши. Mimimize - тип запуска, 0-в обычном окне, <>0 - в минимизированном.
DeleteItem(имя раздела)
Удалить раздел с указанным именем в активной группе
Пример использования:
ProgmanCommand('CreateGroup(Комплекс программ для каталогизации литературы,)');
ProgmanCommand('AddItem('+path+'vbase.hlp,Справка по VBase,'+ path +' vbase.hlp, 0, , , '+ path + ',,)');
где path - строка типа String, содержащая полный путь к каталогу ('C:\Catalog\');

Копирование файлов

Копирование методом TurboPascal

Type   TCallBack=procedure (Position,Size:Longint); {Для индикации процесса копирования}  procedure FastFileCopy(Const InfileName, OutFileName: String; CallBack: TCallBack); Const BufSize = 3*4*4096; { 48Kbytes дает прекрасный результат } Type   PBuffer = ^TBuffer;   TBuffer = array [1..BufSize] of Byte; var   Size             : integer;   Buffer           : PBuffer;   infile, outfile  : File;   SizeDone,SizeFile: Longint; begin   if (InFileName <> OutFileName) then   begin    buffer := Nil;    AssignFile(infile, InFileName);    System.Reset(infile, 1);    try      SizeFile := FileSize(infile);      AssignFile(outfile, OutFileName);      System.Rewrite(outfile, 1);      try        SizeDone := 0; New(Buffer);        repeat          BlockRead(infile, Buffer^, BufSize, Size);          Inc(SizeDone, Size);          CallBack(SizeDone, SizeFile);          BlockWrite(outfile,Buffer^, Size)        until Size < BufSize;        FileSetDate(TFileRec(outfile).Handle,          FileGetDate(TFileRec(infile).Handle));      finally       if Buffer <> Nil then Dispose(Buffer);       System.close(outfile)      end;    finally      System.close(infile);    end;  end else   Raise EInOutError.Create('File cannot be copied into itself'); end;
Копирование методом потока
  Procedure FileCopy(Const SourceFileName, TargetFileName: String); Var   S,T   : TFileStream; Begin  S := TFileStream.Create(sourcefilename, fmOpenRead );  try   T := TFileStream.Create(targetfilename, fmOpenWrite or fmCreate);   try     T.CopyFrom(S, S.Size ) ;     FileSetDate(T.Handle, FileGetDate(S.Handle));   finally    T.Free;   end;  finally   S.Free;  end; end;
Копирование методом LZExpand
  uses LZExpand; procedure CopyFile(FromFileName, ToFileName  : string); var   FromFile, ToFile: File; begin   AssignFile(FromFile, FromFileName);   AssignFile(ToFile, ToFileName);   Reset(FromFile);   try    Rewrite(ToFile);    try     if LZCopy(TFileRec(FromFile).Handle, TFileRec(ToFile).Handle)<0 then      raise Exception.Create('Error using LZCopy')    finally     CloseFile(ToFile);    end;   finally    CloseFile(FromFile);   end; end;
Копирование методами Windows
  uses ShellApi; // !!! важно  function WindowsCopyFile(FromFile, ToDir : string) : boolean; var F : TShFileOpStruct; begin   F.Wnd := 0; F.wFunc := FO_COPY;   FromFile:=FromFile+#0; F.pFrom:=pchar(FromFile);   ToDir:=ToDir+#0; F.pTo:=pchar(ToDir);   F.fFlags := FOF_ALLOWUNDO or FOF_NOCONFIRMATION;   result:=ShFileOperation(F) = 0; end;  // пример копирования procedure TForm1.Button1Click(Sender: TObject); begin  if not WindowsCopyFile('C:\UTIL\ARJ.EXE', GetCurrentDir) then    ShowMessage('Copy Failed'); end;

Как скопировать все файлы вместе с подкаталогами

uses ShellApi;  procedure TForm1.Button1Click(Sender: TObject); var   OpStruc: TSHFileOpStruct;   frombuf, tobuf: Array [0..128] of Char; Begin  FillChar( frombuf, Sizeof(frombuf), 0 );  FillChar( tobuf, Sizeof(tobuf), 0 );  StrPCopy( frombuf, 'h:\hook\*.*' );  StrPCopy( tobuf, 'd:\temp\brief' );  With OpStruc DO Begin   Wnd:= Handle;   wFunc:= FO_COPY;   pFrom:= @frombuf;   pTo:=@tobuf;   fFlags:= FOF_NOCONFIRMATION or FOF_RENAMEONCOLLISION;   fAnyOperationsAborted:= False;   hNameMappings:= Nil;   lpszProgressTitle:= Nil;  end;  ShFileOperation( OpStruc ); end;

Удаление каталога со всем содержимым

{ Удалить каталог со всем содержимым } function DeleteDir(Dir  : string)  : boolean; Var  Found  : integer;  SearchRec : TSearchRec; begin   result:=false;   if IOResult<>0 then ;   ChDir(Dir);   if IOResult<>0 then begin    ShowMessage('Не могу войти в каталог: '+Dir); exit;   end;   Found := FindFirst('*.*', faAnyFile, SearchRec);   while Found = 0 do   begin    if (SearchRec.Name<>'.')and(SearchRec.Name<>'..') then     if (SearchRec.Attr and faDirectory)<>0 then begin      if not DeleteDir(SearchRec.Name) then exit;     end else      if not DeleteFile(SearchRec.Name) then begin       ShowMessage('Не могу удалить файл: '+SearchRec.Name); exit;      end;     Found := FindNext(SearchRec);   end;   FindClose(SearchRec);   ChDir('..'); RmDir(Dir);   result:=IOResult=0; end;

Определение системной информации

Часто при создании систем привязки программ к компьютеру или окон типа System Info или About Box необходимо определить данные о пользователе и о системе. Это можно сделать следующим образом (из примеров по Delphi - программа COA):

Procedure GetInfo; Var  WinVer, WinFlags : LongInt;		{ Версия Windows и флаги }  hInstUser, Fmt : Word;			{ Дескриптор  }  Buffer : ARRAY[0..30] OF Char;	{ Буфер под ASCIIZ строку } begin  hInstUser := LoadLibrary('USER');	{ Открыли библиотеку User }  LoadString(hInstUser, 514, Buffer, 30);  LabelUserName.Caption := StrPas(Buffer);	{ Имя пользователя }  LoadString(hInstUser, 515, Buffer, 30);  FreeLibrary(hInstUser);  LabelCompName.Caption := StrPas(Buffer);	{ Компания }  WinVer := GetVersion;  LabelWinVer.Caption := Format('Windows %u.%.2u',	{ Версия Windows }         [LoByte(LoWord(WinVer)), HiByte(LoWord(WinVer))]);  LabelDosVer.Caption := Format('DOS %u.%.2u',	{ Версия DOS }         [HiByte(HiWord(WinVer)), LoByte(HiWord(WinVer))]);  WinFlags := GetWinFlags;  IF WinFlags AND WF_ENHANCED > 0 THEN    LabelWinMode.Caption := '386 Enhanced Mode'  { Режим }  ELSE IF WinFlags AND WF_PMODE > 0 THEN    LabelWinMode.Caption := 'Standard Mode'  ELSE LabelWinMode.Caption := 'Real Mode';  IF WinFlags AND WF_80x87 > 0 THEN            { Сопроцессор }   ValueMathCo.Caption := 'Present'  ELSE ValueMathCo.Caption := 'Absent';   Fmt := GetFreeSystemResources(GFSR_SYSTEMRESOURCES);  ValueFSRs.Caption := Format('%d%% Free', [Fmt1]);	{ Свободно ресурсов } { Свободно памяти}  ValueMemory.Caption := FormatFloat(',#######', MemAvail DIV 1024) + ' KB Free';	 end;

Как проинсталлировать свои шрифты?

Добавить фонт (.fon, .fot, .fnt, .ttf) в систему можно след. образом:

{$IFDEF WIN32}     AddFontResource( PChar( my_font_PathName { AnsiString } ) ); {$ELSE} var     ss  : array [ 0..255 ] of Char;      AddFontResource ( StrPCopy ( ss, my_font_PathName )); {$ENDIF}     SendMessage ( HWND_BROADCAST, WM_FONTCHANGE, 0, 0 );  Убрать его по окончании работы:  {$IFDEF WIN32}     RemoveFontResource ( PChar(my_font_PathName) ); {$ELSE}     RemoveFontResource ( StrPCopy ( ss, my_font_PathName )); {$ENDIF}     SendMessage ( HWND_BROADCAST, WM_FONTCHANGE, 0, 0 );
При этом не надо никаких перезагрузок и прочего, после добавления фонт сразу можно использовать. my_font_PathName : string ( не string[nn] для D2+) - содержит полный путь с именем и расширением необходимого фонта. После удаления фонта форточки о нем забывают. Если его не удалить, он (кажется) так и останется проинсталенным, во всяком случае, я это не проверял.

Вставить какую-нибудь программу внутрь EXE файла
1. Пишем в блокноте RC-файл, куда прописываем все нужные нам программы, например:
ARJ EXEFILE C:\UTIL\ARJ.EXE
2. Компилируем его в ресурс при помощи Brcc32.exe. Получаем RES-файл.
3. Далее в тексте нашей программы:
implementation {$R *.DFM} {$R test.res} //Это наш RES-файл  procedure ExtractRes(ResType, ResName, ResNewName : String); var   Res : TResourceStream; begin   Res := TResourceStream.Create(Hinstance, Resname, Pchar(ResType));   Res.SavetoFile(ResNewName);   Res.Free; end;  procedure TForm1.BitBtn1Click(Sender: TObject); begin  // Записывает в текущую папку arj.exe  ExtractRes('EXEFILE', 'ARJ', 'ARJ.EXE'); end;

Как написать маленький инсталлятор ?

Мне понравился следующий вариант: главное приложение само выполняет функции инсталлятора. Первоначально файл называется Setup.exe. При запуске под этим именем приложение устанавливает себя, после установки программа переименовывает себя и перестает быть инсталлятором.
Пример:

 Application.Initialize;  if UpperCase(ExtractFileName(Application.ExeName))='SETUP.EXE'    then Application.CreateForm(TSetupForm, SetupForm) // форма инсталлятора   else Application.CreateForm(TMainForm, MainForm);  // форма основной программы  Application.Run;

Работа с принтером.

Delphi имеет стандартный объект для доступа к принтеру - TPRINTER, находящийся в модуле PRINTERS. В этом модуле имеется переменная Printer:Tpinter, что избавляет от необходимости описывать свою. Он позволяет выводить данные на печать и управлять процессом печати. Правда, в некоторых версиях Delphi 1 он имеет "глюк" - не работают функции Draw и StrethDraw. Но эта проблема поправима - можно использовать функции API. Далее приведены основные поля и методы объекта Printers :
PROPERTY
Aborted:boolean - Показывает, что процесс печати прерван
Canvas:Tcanvas - Стандартный Canvas, как у любого графического объекта. Он позволяет рисовать на листе бумаге графику, выводить текст ... . Тут есть несколько особенностей, они описаны после описания объекта.
Fonts:Tstrings - Возвращает список шрифтов, поддерживаемых принтером
Handle:HDS - Получить Handle на принтер для использования функций API (см. Далее)
Orientation:TprinterOrientation - Ориентация листа при печати : (poPortrait, poLandscape)
PageHeight:integer - Высота листа в пикселах
PageNumber:integer - Номер страницы, увеличивается на 1 при каждом NewPage
PageWidth:integer - Ширина листа в пикселах
PrinterIndex:integer - Номер используемого принтера по списку доступных принтеров Printers
Printers:Tstrings - Список доступных принтеров
Printing:boolean - Флаг, показывающий, что сейчас идет процесс печати
Title:string - Имя документа или приложения. Под этим именем задание на печать регистрируется в диспетчере печати

METODS
AssignPrn(f:TextFile) - Связать текстовый файл с принтером. Далее вывод информации в этот файл приводит к ее печати. Удобно в простейших случаях.
Abort - Сбросить печать
BeginDoc - Начать печать
NewPage - Начать новую страницу
EndDoc - Завершить печать.

Пример :

Procedure TForm1.Button1Click(Sender: TObject); Begin  With Printer do Begin   BeginDoc; { Начало печати }   Canvas.Font:=label1.font; { Задали шрифт }   Canvas.TextOut(100,100,'Это тест принтера !!!'); { Печатаем текст }   EndDoc; { Конец печати }  end; end;

Особенности работы с TPrinter

1. После команды BeginDoc шрифт у Canvas принтера сбрасывается и его необходимо задавать заново
2. Все координаты даны в пикселах, а для нормальной работы необходимы миллиметры (по двум очевидным причинам: очень трудно произвести разметку страницы в пикселах (особенно если необходима точность), и , главное, при изменении разрешающей способности принтера будет изменяться число точек на дюйм, и все координаты "поедут".
3. У TPrinter информация о принтере, по видимому, определяются один раз - в момент запуска программы (или смены принтера). Поэтому изменение настроек принтера в процессе работы программы может привести к некорректной работе, например, неправильной печать шрифтов True Type.

Определение параметров принтера через API

Для определения информации о принтере (плоттере, экране) необходимо знать Handle этого принтера, а его можно узнать объекта TPrinter - Printer.Handle. Далее вызывается функция API (unit WinProcs) : GetDevice(Handle:HDC; Index:integer):integer;
Index - код параметра, который необходимо вернуть. Для Index существует ряд констант :
DriverVersion - вернуть версию драйвера
Texnology - Технология вывода, их много, основные
dt_Plotter - плоттер
dt_RasPrinter - растровый принтер
dt_Display - дисплей
HorzSize - Горизонтальный размер листа (в мм)
VertSize - Вертикальный размер листа (в мм)
HorzRes - Горизонтальный размер листа (в пикселах)
VertRes - Вертикальный размер листа (в пикселах)
LogPixelX - Разрешение по оси Х в dpi (пиксел /дюйм)
LogPixelY - Разрешение по оси Y в dpi (пиксел /дюйм)
Кроме перечисленных еще около сотни, они позволяют узнать о принтере практически все.
Параметры, возвращаемые по LogPixelX и LogPixelY очень важны - они позволяют произвести пересчет координат из миллиметров в пиксели для текущего разрешения принтера. Пример таких функций:

Procedure TForm1.GetPrinterInfo; { Получить информацию о принтере } begin   PixelsX:=GetDeviceCaps(printer.Handle,LogPixelsX);   PixelsY:=GetDeviceCaps(printer.Handle,LogPixelsY); end;  Function TForm1.PrinterCoordX(x:integer):integer; { переводит координаты из мм в пиксели } begin  PrinterCoordX:=round(PixelsX/25.4*x); end;  Function TForm1.PrinterCoordY(Y:integer):integer; { переводит координаты из мм в пиксели } begin  PrinterCoordY:=round(PixelsY/25.4*Y); end; --------------------------------- GetPrinterInfo; Printer.Canvas.TextOut(PrinterCoordX(30), PrinterCoordY(55),  'Этот текст печатается с отступом 30 мм от левого края и '+  '55 мм от верха при любом разрешении принтера');
Данную методику можно с успехом применять для печати картинок - зная размер картинки можно пересчитать ее размеры в пикселах для текущего разрешения принтера, масштабировать, и затем уже распечатать. Иначе на матричном принтере (180 dpi) картинка будет огромной, а на качественном струйнике (720 dpi) - микроскопической.

Хранитель экрана

1.В файл проекта (*.DPR) добавить строку {$D SCRNSAVE <название хранителя>} после строки подключения модулей (Uses...).
2.У окна формы убрать системное меню, кнопки и придать свойству WindowState значение wsMaximize.
3.Предусмотреть выход из хранителя при нажатии на клавиши клавиатуры, мыши и при перемещении курсора мыши.
4.Проверить параметры с которым был вызван хранитель и если это /c - показать окно настройки хранителя, а иначе (можно проверять на /s, а можно и не проверять) сам хранитель. /p - для отображения в окне установок хранителя экрана.
5.Скомпилировать хранитель экрана.
6.Переименовать *.EXE файл в файл *.SCR и скопировать его в каталог WINDOWS\SYSTEM\.
7.Установить новый хранитель в настройках системы!

Название хранителя может состоять из нескольких слов с пробелами, на любом языке.
При работе хранителя необходимо прятать курсор мыши, только не забывайте восстанавливать его после выхода.
Все параметры и настройки храните в файле .INI, так как хранитель и окно настройки не связаны друг с другом напрямую.
Старайтесь сделать свой хранитель как можно меньше и быстрее. Иначе ваши долго работающие (в фоновом режиме) приложения будут работать еше дольше!

{в файле *.DPR}
{$D SCRNSAVE Пример хранителя экрана}

{проверить переданные параметры}
IF (ParamStr(1) = '/c') OR (ParamStr(1) = '/C') THEN

{скрыть курсор мыши}
ShowCursor(False);

{восстановить курсор мыши}
ShowCursor(True);

Более подробно о создании хранителя экрана "по всем правилам"
Screen Saver in Win95

Главное о чем стоит упомянуть это, что ваш хранитель экрана будет работать в фоновом режиме и он не должен мешать работе других запущенных программ. Поэтому сам хранитель должен быть как можно меньшего объема. Для уменьшения объема файла в описанной ниже программе не используется визуальные компоненты Delphi, включение хотя бы одного из них приведет к увеличению размера файла свыше 200кб, а так, описанная ниже программа, имеет размер всего 20кб!!!
Технически, хранитель экрана является нормальным EXE файлом (с расширением .SCR), который управляется через командные параметры строки. Например, если пользователь хочет изменить параметры вашего хранителя, Windows выполняет его с параметром "-c" в командной строке. Поэтому начать создание вашего хранителя экрана следует с создания примерно следующей функции:

Procedure RunScreenSaver; Var S : String; Begin   S := ParamStr(1);   If (Length(S) > 1) Then Begin     Delete(S,1,1); { delete first char - usally "/" or "-" }     S[1] := UpCase(S[1]);   End;   LoadSettings; { load settings from registry }   If (S = 'C') Then RunSettings   Else If (S = 'P') Then RunPreview   Else If (S = 'A') Then RunSetPassword   Else RunFullScreen; End;

Поскольку нам нужно создавать небольшое окно предварительного просмотра и полноэкранное окно, их лучше объединить используя единственный класс окна. Следуя правилам хорошего тона, нам также нужно использовать многочисленные нити. Дело в том, что, во-первых, хранитель не должен переставать работать даже если что-то "тяжелое" случилось, и во-вторых, нам не нужно использовать таймер.
Процедура для запуска хранителя на полном экране - приблизительно такова:

Procedure RunFullScreen; Var   R          : TRect;   Msg        : TMsg;   Dummy      : Integer;   Foreground : hWnd; Begin   IsPreview := False;  MoveCounter := 3;     Foreground := GetForegroundWindow;   While (ShowCursor(False) > 0) do ;   GetWindowRect(GetDesktopWindow,R);   CreateScreenSaverWindow(R.Right-R.Left,R.Bottom-R.Top,0);   CreateThread(nil,0,@PreviewThreadProc,nil,0,Dummy);   SystemParametersInfo(spi_ScreenSaverRunning,1,@Dummy,0);   While GetMessage(Msg,0,0,0) do Begin     TranslateMessage(Msg);     DispatchMessage(Msg);   End;   SystemParametersInfo(spi_ScreenSaverRunning,0,@Dummy,0);   ShowCursor(True);   SetForegroundWindow(Foreground); End;

Во-первых, мы проинициализировали некоторые глобальные переменные (описанные далее), затем прячем курсор мыши и создаем окно хранителя экрана. Имейте в виду, что важно уведомлять Windows, что это - хранителя экрана через SystemParametersInfo (это выводит из строя Ctrl-Alt-Del чтобы нельзя было вернуться в Windows не введя пароль). Создание окна хранителя:

Function CreateScreenSaverWindow(Width,Height : Integer;     ParentWindow : hWnd) : hWnd; Var WC : TWndClass; Begin   With WC do Begin     Style := cs_ParentDC;     lpfnWndProc := @PreviewWndProc;     cbClsExtra := 0;  cbWndExtra := 0; hIcon := 0; hCursor := 0;     hbrBackground := 0; lpszMenuName := nil;      lpszClassName := 'MyDelphiScreenSaverClass';     hInstance := System.hInstance;   end;   RegisterClass(WC);   If (ParentWindow  0) Then     Result := CreateWindow('MyDelphiScreenSaverClass','MySaver',        ws_Child Or ws_Visible or ws_Disabled,0,0,        Width,Height,ParentWindow,0,hInstance,nil)   Else Begin     Result := CreateWindow('MyDelphiScreenSaverClass','MySaver',        ws_Visible or ws_Popup,0,0,Width,Height, 0,0,hInstance,nil);     SetWindowPos(Result,hwnd_TopMost,0,0,0,0,swp_NoMove or swp_NoSize or swp_NoRedraw);   End;   PreviewWindow := Result; End;

Теперь окна созданы используя вызовы API. Я удалил проверку ошибки, но обычно все проходит хорошо, особенно в этом типе приложения.
Теперь Вы можете погадать, как мы получим handle родительского окна предварительного просмотра ? В действительности, это совсем просто: Windows просто передает handle в командной строке, когда это нужно. Таким образом:

Procedure RunPreview; Var   R             : TRect;   PreviewWindow : hWnd;   Msg           : TMsg;   Dummy         : Integer; Begin   IsPreview := True;   PreviewWindow := StrToInt(ParamStr(2));   GetWindowRect(PreviewWindow,R);   CreateScreenSaverWindow(R.Right-R.Left,R.Bottom-R.Top,PreviewWindow);   CreateThread(nil,0,@PreviewThreadProc,nil,0,Dummy);   While GetMessage(Msg,0,0,0) do Begin     TranslateMessage(Msg); DispatchMessage(Msg);   End; End;

Как Вы видите, window handle является вторым параметром (после "-p").
Чтобы "выполнять" хранителя экрана - нам нужна нить. Это создается с вышеуказанным CreateThread. Процедура нити выглядит примерно так:

Function PreviewThreadProc(Data : Integer) : Integer; StdCall; Var R : TRect; Begin   Result := 0; Randomize;   GetWindowRect(PreviewWindow,R);   MaxX := R.Right-R.Left;  MaxY := R.Bottom-R.Top;   ShowWindow(PreviewWindow,sw_Show); UpdateWindow(PreviewWindow);   Repeat     InvalidateRect(PreviewWindow,nil,False);     Sleep(30);   Until QuitSaver;   PostMessage(PreviewWindow,wm_Destroy,0,0); End;

Нить просто заставляет обновляться изображения в нашем окне, спит на некоторое время, и обновляет изображения снова. А Windows будет посылать сообщение WM_PAINT на наше окно (не в нить !). Для того, чтобы оперировать этим сообщением, нам нужна процедура:

Function PreviewWndProc(Window : hWnd; Msg,WParam,   LParam : Integer): Integer; StdCall; Begin   Result := 0;   Case Msg of     wm_NCCreate  : Result := 1;     wm_Destroy   : PostQuitMessage(0);     wm_Paint     : DrawSingleBox; { paint something }     wm_KeyDown   : QuitSaver := AskPassword;     wm_LButtonDown, wm_MButtonDown, wm_RButtonDown, wm_MouseMove :                     Begin                      If (Not IsPreview) Then Begin                        Dec(MoveCounter);                        If (MoveCounter <= 0) Then QuitSaver := AskPassword;                      End;                    End;      Else Result := DefWindowProc(Window,Msg,WParam,LParam);   End; End;

Если мышь перемещается, кнопка нажала, мы спрашиваем у пользователя пароль:

Function AskPassword : Boolean; Var   Key   : hKey;   D1,D2 : Integer; { two dummies }   Value : Integer;   Lib   : THandle;   F     : TVSSPFunc; Begin   Result := True;   If (RegOpenKeyEx(hKey_Current_User,'Control Panel\Desktop',0,        Key_Read,Key) = Error_Success) Then    Begin     D2 := SizeOf(Value);     If (RegQueryValueEx(Key,'ScreenSaveUsePassword',nil,@D1,          @Value,@D2) = Error_Success) Then      Begin       If (Value  0) Then Begin         Lib := LoadLibrary('PASSWORD.CPL');         If (Lib > 32) Then Begin           @F := GetProcAddress(Lib,'VerifyScreenSavePwd');           ShowCursor(True);           If (@F  nil) Then Result := F(PreviewWindow);           ShowCursor(False);           MoveCounter := 3; { reset again if password was wrong }           FreeLibrary(Lib);         End;       End;     End;     RegCloseKey(Key);   End; End;

Это также демонстрирует использование registry на уровне API. Также имейте в виду как мы динамически загружаем функции пароля, используюя LoadLibrary. Запомните тип функции?
TVSSFunc ОПРЕДЕЛЕН как:

Type
TVSSPFunc = Function(Parent : hWnd) : Bool; StdCall;

Теперь почти все готово, кроме диалога конфигурации. Это запросто:

Procedure RunSettings; Var Result : Integer; Begin   Result := DialogBox(hInstance,'SaverSettingsDlg',0,@SettingsDlgProc);   If (Result = idOK) Then SaveSettings; End;

Трудная часть -это создать диалоговый сценарий (запомните: мы не используем здесь Delphi формы!). Я сделал это, используя 16-битовую Resource Workshop (остался еще от Turbo Pascal для Windows). Я сохранил файл как сценарий (текст), и скомпилированный это с BRCC32:

SaverSettingsDlg DIALOG 70, 130, 166, 75 STYLE WS_POPUP | WS_DLGFRAME | WS_SYSMENU CAPTION "Settings for Boxes" FONT 8, "MS Sans Serif" BEGIN     DEFPUSHBUTTON "OK", 5, 115, 6, 46, 16     PUSHBUTTON "Cancel", 6, 115, 28, 46, 16 	CTEXT "Box &Color:", 3, 2, 30, 39, 9     COMBOBOX 4, 4, 40, 104, 50, CBS_DROPDOWNLIST | CBS_HASSTRINGS     CTEXT "Box &Type:", 1, 4, 3, 36, 9     COMBOBOX 2, 5, 12, 103, 50, CBS_DROPDOWNLIST | CBS_HASSTRINGS     LTEXT "Boxes Screen Saver for Win32 Copyright (c) 1996 Jani            Jдrvinen.", 7, 4, 57, 103, 16,            WS_CHILD | WS_VISIBLE | WS_GROUP END

Почти также легко сделать диалоговое меню:

Function SettingsDlgProc(Window : hWnd; Msg,WParam,LParam : Integer): Integer; StdCall; Var S : String; Begin   Result := 0;   Case Msg of     wm_InitDialog : Begin                       { initialize the dialog box }                       Result := 0;                     End;     wm_Command    : Begin                       If (LoWord(WParam) = 5) Then EndDialog(Window,idOK)                       Else If (LoWord(WParam) = 6) Then EndDialog(Window,idCancel);                     End;     wm_Close      : DestroyWindow(Window);     wm_Destroy    : PostQuitMessage(0);     Else Result := 0;   End; End;

После того, как пользователь выбрал некоторые установочные параметры, нам нужно сохранить их.

Procedure SaveSettings; Var   Key   : hKey;   Dummy : Integer; Begin   If (RegCreateKeyEx(hKey_Current_User,                      'Software\SilverStream\SSBoxes',                      0,nil,Reg_Option_Non_Volatile,                      Key_All_Access,nil,Key,                      @Dummy) = Error_Success) Then Begin     RegSetValueEx(Key,'RoundedRectangles',0,Reg_Binary,       @RoundedRectangles,SizeOf(Boolean));     RegSetValueEx(Key,'SolidColors',0,Reg_Binary, @SolidColors,SizeOf(Boolean));     RegCloseKey(Key);   End; End;
Загружаем параметры так:
Procedure LoadSettings; Var   Key   : hKey;   D1,D2 : Integer; { two dummies }   Value : Boolean; Begin   If (RegOpenKeyEx(hKey_Current_User,                    'Software\SilverStream\SSBoxes',0,                    Key_Read,                    Key) = Error_Success) Then Begin     D2 := SizeOf(Value);     If (RegQueryValueEx(Key,'RoundedRectangles',nil,@D1,         @Value, @D2) = Error_Success) Then      Begin          RoundedRectangles := Value;     End;     If (RegQueryValueEx(Key,'SolidColors',nil,@D1,         @Value,@D2) = Error_Success) Then      Begin       SolidColors := Value;     End;     RegCloseKey(Key);   End; End;

Легко? Нам также нужно позволить пользователю, установить пароль. Я честно не знаю почему это оставлено разработчику приложений ? Тем не менее:

Procedure RunSetPassword; Var   Lib : THandle;   F   : TPCPAFunc; Begin   Lib := LoadLibrary('MPR.DLL');   If (Lib > 32) Then Begin     @F := GetProcAddress(Lib,'PwdChangePasswordA');     If (@F  nil) Then F('SCRSAVE',StrToInt(ParamStr(2)),0,0);     FreeLibrary(Lib);   End; End;

Мы динамически загружаем (недокументированную) библиотеку MPR.DLL, которая имеет функцию, чтобы установить пароль хранителя экрана, так что нам не нужно беспокоиться об этом.
TPCPAFund ОПРЕДЕЛЕН как:

Type
TPCPAFunc = Function(A : PChar; Parent : hWnd; B,C : Integer) : Integer; StdCall;

(Не спрашивайте меня что за параметры B и C) Теперь единственная вещь, которую нам нужно рассмотреть, - самая странная часть: создание графики. Я не великий ГУРУ графики, так что Вы не увидите затеняющие многоугольники, вращающиеся в реальном времени. Я только сделал некоторые ящики.

Procedure DrawSingleBox; Var   PaintDC  : hDC;   Info     : TPaintStruct;   OldBrush : hBrush;   X,Y      : Integer;   Color    : LongInt; Begin   PaintDC := BeginPaint(PreviewWindow,Info);   X := Random(MaxX); Y := Random(MaxY);   If SolidColors Then     Color := GetNearestColor(PaintDC,RGB(Random(255),Random(255),Random(255)))   Else Color := RGB(Random(255),Random(255),Random(255));   OldBrush := SelectObject(PaintDC,CreateSolidBrush(Color));   If RoundedRectangles Then     RoundRect(PaintDC,X,Y,X+Random(MaxX-X),Y+Random(MaxY-Y),20,20)   Else Rectangle(PaintDC,X,Y,X+Random(MaxX-X),Y+Random(MaxY-Y));   DeleteObject(SelectObject(PaintDC,OldBrush));   EndPaint(PreviewWindow,Info); End;

Чтобы закончить создание хранителя, я даю Вам некоторые детали. Первые, глобальные переменные:

Var   IsPreview         : Boolean;   MoveCounter       : Integer;   QuitSaver         : Boolean;   PreviewWindow     : hWnd;   MaxX,MaxY         : Integer;   RoundedRectangles : Boolean;   SolidColors       : Boolean;
Затем исходная программа проекта (.dpr). Красива, а!?
program MySaverIsGreat; uses    windows, messages, Utility; { defines all routines } {$R SETTINGS.RES} begin   RunScreenSaver;  end.

Ох, чуть не забыл: Если, Вы используете SysUtils в вашем проекте (StrToInt определен там) Вы получаете большой EXE чем обещанный 20k. Если Вы хотите все же иметь20k, Вы не можете использовать SysUtils так, или Вам нужно написать вашу собственную StrToInt программу.
Конец.

Use Val... ;-)
перевод: Владимиров А.М.
От переводчика. Если все же очень трудно обойтись без использования Delphi-форм, то можно поступить как в случае с вводом пароля: форму изменения параметров хранителя сохранить в виде DLL и динамически ее загружать при необходимости. Т.о. будет маленький и шустрый файл самого хранителя экрана и довеска DLL для конфигурирования и прочего (там объем и скорость уже не критичны).

Включение и выключение устройств ввода/вывода из программы на Delphi

Иногда может возникнуть необходимость в выключении на время устройств ввода - клавиатуры и мыши. Например, это неплохо сделать на время выполнения кода системы защиты от копирования, в играх, или в качестве "наказания" при запуске программы по истечению срока ее бесплатного использования ... . Однако наилучшее ее применение - отключение клавиатуры и мыши на время работы демонстрационки, основанной на воспроизведении записанных заранее перемещений мышки и клавиатурного ввода (см. об этом отдельный раздел этой книги). Это элементарно сделать при помощи API:
EnableHadwareInput(Enable:boolean): boolean;
Enable - требуемое состояние устройств ввода (True - включены, false - выключены). Если ввод заблокирован, то его можно разблокировать вручную - нажать Ctrl + Alt + Del, при появлении меню "Завершение работы программы" ввод разблокируется.

А вот еще интересный прикол.
Включение/выключение монитора программным способом.

Предупреждаю сразу! После того, как вы отключите монитор, просто так вы его уже не включите (хотя это может быть зависит от монитора, я, во всяком случае, не смог). Только после перезагрузки компьютера.

Отключить :
SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, 0);

Включить :
SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, -1);

Переключение языка из программы

Для переключения языка применяется вызов LoadKeyboardLayout:

var russian, latin: HKL;    russian:=LoadKeyboardLayout('00000419', 0);  latin:=LoadKeyboardLayout('00000409', 0);  -- -- -- -- -- где то в  программе --- --- ---    SetActiveKeyboardLayout(russian);

Как отловить нажатия клавиш для всех процессов в системе?

Вот, может поможет:
>1. Setup.bat  === Cut === @echo off copy HookAgnt.dll %windir%\system copy kbdhook.exe %windir%\system start HookAgnt.reg === Cut ===  >2.HookAgnt.reg === Cut === REGEDIT4  [HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Run] "kbdhook"="kbdhook.exe" === Cut ===  >3.KbdHook.dpr === Cut === program cwbhook; uses Windows, Dialogs; var   hinstDLL: HINST;   hkprcKeyboard: TFNHookProc;   msg: TMsg; begin   hinstDLL := LoadLibrary('HookAgnt.dll');   hkprcKeyboard := GetProcAddress(hinstDLL, 'KeyboardProc');   SetWindowsHookEx(WH_KEYBOARD, hkprcKeyboard, hinstDLL, 0);   repeat until not GetMessage(msg, 0, 0, 0); end. === Cut ===  >4.HookAgnt.dpr === Cut === library HookAgent; uses Windows, KeyboardHook in 'KeyboardHook.pas'; exports KeyboardProc; var   hFileMappingObject: THandle;   fInit: Boolean;  procedure DLLMain(Reason: Integer); begin   if Reason = DLL_PROCESS_DETACH then begin     UnmapViewOfFile(lpvMem);     CloseHandle(hFileMappingObject);   end; end;  begin   DLLProc := @DLLMain;   hFileMappingObject := CreateFileMapping(     THandle($FFFFFFFF), // use paging file     nil,                // no security attributes     PAGE_READWRITE,     // read/write access     0,                  // size: high 32 bits     4096,               // size: low 32 bits     'HookAgentShareMem' // name of map object   );   if hFileMappingObject = INVALID_HANDLE_VALUE then begin     ExitCode := 1;     Exit;   end;   fInit := GetLastError() <> ERROR_ALREADY_EXISTS;   lpvMem := MapViewOfFile(     hFileMappingObject, // object to map view of     FILE_MAP_WRITE,     // read/write access     0,                  // high offset: map from     0,                  // low offset:  beginning     0);                 // default: map entire file   if lpvMem = nil then begin     CloseHandle(hFileMappingObject);     ExitCode := 1;     Exit;   end;   if fInit then FillChar(lpvMem, PASSWORDSIZE, #0); end. === Cut ===  >5.KeyboardHook.pas === Cut === unit KeyboardHook; interface uses Windows; const PASSWORDSIZE = 16; var   g_hhk: HHOOK;   g_szKeyword: array[0..PASSWORDSIZE-1] of char;   lpvMem: Pointer;  function KeyboardProc(nCode: Integer; wParam: WPARAM; lParam: LPARAM ): LRESULT; stdcall; implementation uses SysUtils, Dialogs; function KeyboardProc(nCode: Integer; wParam: WPARAM; lParam: LPARAM ): LRESULT; var   szModuleFileName: array[0..MAX_PATH-1] of Char;   szKeyName: array[0..16] of Char;   lpszPassword: PChar; begin   lpszPassword := PChar(lpvMem);   if (nCode = HC_ACTION) and (((lParam shr 16) and KF_UP) = 0) then begin     GetKeyNameText(lParam, szKeyName, sizeof(szKeyName));     if StrLen(g_szKeyword) + StrLen(szKeyName) >= PASSWORDSIZE then       lstrcpy(g_szKeyword, g_szKeyword + StrLen(szKeyName));     lstrcat(g_szKeyword, szKeyName);     GetModuleFileName(0, szModuleFileName, sizeof(szModuleFileName)); >    if (StrPos(StrUpper(szModuleFileName),'__ТО_ЧЕГО_НАДО__') <> nil) and        (strlen(lpszPassword) + strlen(szKeyName) < PASSWORDSIZE) then       lstrcat(lpszPassword, szKeyName);     if StrPos(StrUpper(g_szKeyword), 'GOLDENEYE') <> nil then     begin       ShowMessage(lpszPassword);       g_szKeyword[0] := #0;     end;     Result := 0;   end   else Result := CallNextHookEx(g_hhk, nCode, wParam, lParam); end; end. === Cut ===

Информация о состоянии клавиатуры

Я хотел бы узнать, при запуске моего приложения, нажата ли клавиша Ctrl. Просто хочется сделать, что-то вроде пароля.

О состоянии клавиатуры дают информацию следующие функции:
GetKeyState, GetAsyncKeyState, GetKeyboardState.
Чтобы упростить себе жизнь и не возиться с этими функциями снова и снова я написал маленькие функции:

function AltKeyDown : boolean; begin  result:=(Word(GetKeyState(VK_MENU)) and $8000)<>0; end; function CtrlKeyDown : boolean; begin  result:=(Word(GetKeyState(VK_CONTROL)) and $8000)<>0; end; function ShiftKeyDown : boolean; begin  result:=(Word(GetKeyState(VK_SHIFT)) and $8000)<>0; end;  А заодно и для клавиш переключателей:  function CapsLock : boolean; begin  result:=(GetKeyState(VK_CAPITAL) and 1)<>0; end; function InsertOn : boolean; begin  result:=(GetKeyState(VK_INSERT) and 1)<>0; end; function NumLock : boolean; begin  result:=(GetKeyState(VK_NUMLOCK) and 1)<>0; end; function ScrollLock : boolean; begin  result:=(GetKeyState(VK_SCROLL) and 1)<>0; end;

Управление питанием из программы на Delphi

При написании разнообразны программ типа заставок, менеджеров управления компьютером ... возникает необходимость переводить компьютер в режим "спячки". Для включения этого режима в Windows 95 (и только в ней !!) предусмотрена команда API:
SetSystemPowerState(Suspended, Mode: Boolean):boolean;
Suspended должно быть TRUE для ухода в спячку.
Mode - режим входа в спячку. Если TRUE, то всем программам и драйверам посылается Message PBT_APMSUSPEND, по которому они должны немедленно прекратить работу. Если FALSE, то посылается Message PBT_APMQUERYSUSPEND запроса на спячку, и драйвера в ответ могут дать отказ на включение режима спячки.
Возврат функции SetSystemPowerState: TRUE - режим включен.

Пример получения списка запущенных приложений.

procedure TForm1.Button1Click(Sender: TObject); VAR   Wnd : hWnd;   buff: ARRAY [0..127] OF Char; begin   ListBox1.Clear;   Wnd := GetWindow(Handle, gw_HWndFirst);   WHILE Wnd <> 0 DO BEGIN {Не показываем:}     IF (Wnd <> Application.Handle) AND {-Собственное окно}        IsWindowVisible(Wnd) AND {-Невидимые окна}        (GetWindow(Wnd, gw_Owner) = 0) AND {-Дочернии окна}        (GetWindowText(Wnd, buff, sizeof(buff)) <> 0){-Окна без заголовков}     THEN BEGIN       GetWindowText(Wnd, buff, sizeof(buff));       ListBox1.Items.Add(StrPas(buff));     END;     Wnd := GetWindow(Wnd, gw_hWndNext);   END;   ListBox1.ItemIndex := 0; end;

Как отключить показ кнопки программы в TaskBar и по Alt-Tab и в Ctrl-Alt-Del

Внеся изменения (выделенные цветом) в свой проект вы получите приложение, которое не видно в TaskBar и на него нельзя переключиться по Alt-Tab

program Project1; uses   Forms,   Windows,   Unit1 in 'Unit1.pas' {Form1}; {$R *.RES} var  ExtendedStyle : integer; begin   Application.Initialize;   ExtendedStyle:=GetWindowLong(application.Handle, GWL_EXSTYLE);   SetWindowLong(Application.Handle, GWL_EXSTYLE,     ExtendedStyle or WS_EX_TOOLWINDOW {AND NOT WS_EX_APPWINDOW});   Application.CreateForm(TForm1, Form1);   Application.Run; end.

Если включить синий коментарий, то получите очень интересное приложение. Оно не видно в TaskBar и на него нельзя переключиться по Alt-Tab, но когда приложение минимизируется оно остается на рабочем столе в виде свернутого заголовка (прямо как в старом добром Windows 3.11)

Только сpазу пpедупpеждаю пpо гpабли, на котоpые я наступал:
Будь готов к тому, что если пpи попытке закpытия пpиложения в OnCloseQuery или OnClose выводится вопpос о подтвеpждении, то могут быть пpоблемы с автоматическим завеpшением пpогpаммы пpи shutdown - под Win95 пpосто зависает, под WinNT не завеpшается. Очевидно, что сообщение выводится, но его не видно (пpичем SW_RESTORE не сpабатывает). Решение - ловить WM_QueryEndSession и после всяких завеpшающих действий и вызова CallTerminateProcs выдавать Halt.

А вот как отрубить показ файла в Ctrl-Alt-Del

function RegisterServiceProcess(dwProcessID, dwType: Integer): Integer; stdcall;    external 'KERNEL32.DLL';  implementation  procedure TForm1.Button1Click(Sender: TObject); begin //Hide  if not (csDesigning in ComponentState) then   RegisterServiceProcess(GetCurrentProcessID, 1); end;  procedure TForm1.Button2Click(Sender: TObject); begin //Show  if not (csDesigning in ComponentState) then   RegisterServiceProcess(GetCurrentProcessID, 0); end;

Добавление программы в автозапуск

sProgTitle: Название для программы sCmdLine: Имя EXE файла с путем доступа bRunOnce:  Запустить только один раз или постоянно при загрузке Windows  procedure RunOnStartup(sProgTitle, sCmdLine : string; bRunOnce : boolean ); var   sKey : string;   reg  : TRegIniFile; begin   if( bRunOnce )then sKey := 'Once'   else sKey := '';   reg := TRegIniFile.Create( '' );   reg.RootKey := HKEY_LOCAL_MACHINE;   reg.WriteString(     'Software\Microsoft'     + '\Windows\CurrentVersion\Run'      + sKey + #0,     sProgTitle,     sCmdLine );   reg.Free; end;  // Например RunOnStartup('Title of my program','MyProg.exe',False );
Примечание. Этот пример удобно использовать при написании деинсталляторов - добавить однократный вызов деинсталлятора и запросить от пользователя перезагрузку. Этот прием позволит безболезненно удалять DLL и им подобные файлы, которые обычном способом удалить невозможно (они загружены в силу того, что использовались деинсталлируемой программой или работают в момент деинсталляции).

Удаляет файл в корзину

uses ShellAPI;  function DeleteFileWithUndo( sFileName : string ) : boolean; var fos : TSHFileOpStruct; begin  sFileName:= sFileName+#0;   FillChar( fos, SizeOf( fos ), 0 );   with fos do begin     wFunc  := FO_DELETE;     pFrom  := PChar( sFileName );     fFlags := FOF_ALLOWUNDO or FOF_NOCONFIRMATION or FOF_SILENT;   end;   Result := ( 0 = ShFileOperation( fos ) ); end;

Добавить ссылку на мой файл в меню Пуск|Документы

uses ShellAPI, ShlOBJ; procedure AddToStartDocumentsMenu( sFilePath : string ); begin   SHAddToRecentDocs(  SHARD_PATH, PChar( sFilePath ) ); end;  // Например AddToStartDocumentsMenu( 'c:\windows\MyWork.txt' );

Устанавливаем свой WallPaper для Windows

program wallpapr; uses Registry, WinProcs;  procedure SetWallpaper(sWallpaperBMPPath : String; bTile : boolean ); var   reg : TRegIniFile; begin // Изменяем ключи реестра // HKEY_CURRENT_USER //   Control Panel\Desktop //     TileWallpaper (REG_SZ) //     Wallpaper (REG_SZ)   reg := TRegIniFile.Create('Control Panel\Desktop' );   with reg do begin     WriteString( '', 'Wallpaper',         sWallpaperBMPPath );     if( bTile )then     begin       WriteString('', 'TileWallpaper', '1' );     end else begin       WriteString('', 'TileWallpaper', '0' );     end;   end;   reg.Free; // Оповещаем всех о том, что мы  // изменили системные настройки SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, Nil, SPIF_SENDWININICHANGE ); end;  begin  // пример установки WallPaper по центру рабочего стола  SetWallpaper('c:\winnt\winnt.bmp', False ); end.

Как запретить кнопку Close [x] в заголовке окна.

procedure TForm1.FormCreate(Sender: TObject); var Style: Longint; begin   Style := GetWindowLong(Handle, GWL_STYLE);   SetWindowLong(Handle, GWL_STYLE, Style And Not WS_SYSMENU); end;  procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); begin   if (Key = VK_F4) and (ssAlt in Shift) then begin     MessageBeep(0); Key := 0;   end; end;

Каким образом можно изменить системное меню формы?

Hе знаю как насчет акселераторов, надо поискать, а вот добавить Item - пожалуйста

type    TMyForm=class(TForm)    procedure wmSysCommand(var Message:TMessage); message WM_SYSCOMMAND;    end; const ID_ABOUT  = WM_USER+1; ID_CALENDAR=WM_USER+2; ID_EDIT  =  WM_USER+3; ID_ANALIS = WM_USER+4;  implementation  procedure TMyForm.wmSysCommand; begin  case Message.wParam of   ID_CALENDAR:DatBitBtnClick(Self) ;   ID_EDIT  :EditBitBtnClick(Self);   ID_ANALIS:AnalisButtonClick(Self);  end;  inherited; end;  procedure TMyForm.FormCreate(Sender: TObject); var SysMenu:THandle; begin  SysMenu:=GetSystemMenu(Handle,False);  InsertMenu(SysMenu,Word(-1),MF_SEPARATOR,ID_ABOUT,'');  InsertMenu(SysMenu,Word(-1),MF_BYPOSITION,ID_Calendar, 'Calendar');  InsertMenu(SysMenu,Word(-1),MF_BYPOSITION,ID_Analis, 'Analis');  InsertMenu(SysMenu,Word(-1),MF_BYPOSITION,ID_Edit, 'Edit'); end;

Запуск внешней программы и ожидание ее завершения

procedure TForm1.Button1Click(Sender: TObject); var   si : Tstartupinfo;   p  : Tprocessinformation; begin  FillChar( Si, SizeOf( Si ) , 0 );  with Si do begin   cb := SizeOf( Si);   dwFlags := startf_UseShowWindow;   wShowWindow := 4;  end;  Application.Minimize;  Createprocess(nil,'notepad.exe',nil,nil,false,Create_default_error_mode,nil,nil,si,p);  Waitforsingleobject(p.hProcess,infinite);  Application.Restore; end;

Как узнать местоположение специальных папок у Windows?

var    FolderPath :string;  Registry := TRegistry.Create; try  Registry.RootKey := HKey_Current_User;  Registry.OpenKey('Software\Microsoft\Windows\'+   'CurrentVersion\Explorer\Shell Folders', False);  FolderName := Registry.ReadString('StartUp');     {Cache, Cookies, Desktop, Favorites,      Fonts, Personal, Programs, SendTo, Start Menu, Startp} finally  Registry.Free; end;

Как засунуть в исполняемый файл wav-файл, и затем проиграть этот звук?

В файл MyWave.rc пишешь:    MyWave RCDATA LOADONCALL MyWave.wav  Затем компилируешь    brcc32.exe MyWave.rc, получаешь MyWave.res.     В своей программе пишешь:     {$R MyWave.res} procedure RetrieveMyWave; var   hResource: THandle;   pData: Pointer; begin   hResource:=LoadResource( hInstance, FindResource(hInstance, 'MyWave', RT_RCDATA));   try     pData := LockResource(hResource);     if pData = nil then raise Exception.Create('Cannot read MyWave');     // Здесь pData указывает на MyWave     // Теперь можно, например, проиграть его (Win32):     PlaySound('MyWave', 0, SND_MEMORY);   finally     FreeResource(hResource);   end; end;

Как скрыть таскбар?

procedure TForm1.Button1Click(Sender: TObject); var   hTaskBar : THandle; begin   hTaskbar := FindWindow('Shell_TrayWnd', Nil);   ShowWindow(hTaskBar, SW_HIDE); end;  procedure TForm1.Button2Click(Sender: TObject); var   hTaskBar : THandle; begin   hTaskbar := FindWindow('Shell_TrayWnd', Nil);   ShowWindow(hTaskBar, SW_SHOWNORMAL); end;

События нажатия на системные кнопки формы (минимизация, закрытие...)

Хотелось бы чтобы при нажатии на кнопку minimize программа исчезала из таскбара.
При нажатии на эти кнопки происходит сообщение WM_SYSCOMMAND, его то и надо перехватить.
При этом:
uCmdType = wParam; // type of system command requested
xPos = LOWORD(lParam); // horizontal postion, in screen coordinates
yPos = HIWORD(lParam); // vertical postion, in screen coordinates

Пример:  Type TMain = class(TForm)  ....  protected   Procedure WMGetSysCommand(var Message :TMessage); message WM_SYSCOMMAND;  end;  ..... //------------------------------------------------------------------------ //   Обработка сообщения WM_SYSCOMMAND (перехват минимизации окна) //------------------------------------------------------------------------ Procedure TForm1.WMGetSysCommand(var Message : TMessage) ; Begin  IF (Message.wParam = SC_MINIMIZE) Then Form1.Visible:=False  Else Inherited; End;

Подключение и отключение сетевых дисководов

Для работы с сетевыми дисководами (и ресурсами типа LPT порта) в WIN API 16 и WIN API 32 следующие функции:

1.Подключить сетевой ресурс
WNetAddConnection(NetResourse,Password,LocalName:PChar):longint;
где NetResourse - имя сетевого ресурса (например '\\P166\c')
Password - пароль на доступ к ресурсу (если нет пароля, то пустая строка)
LocalName - имя, под которым сетевой ресурс будет отображен на данном компьютере (например 'F:')

Пример подключения сетевого диска WNetAddConnection('\\P166\C','','F:');
Функция возвращает код ошибки. Для всех кодов предописаны константы, наиболее часто используемые :
NO_ERROR - Нет ошибок - успешное завершение
ERROR_ACCESS_DENIED - Ошибка доступа
ERROR_ALREADY_ASSIGNED - Уже подключен. Наиболее часто возникает при повторном вызове данной функции с теми-же параметрами.
ERROR_BAD_DEV_TYPE - Неверный тип устройства.
ERROR_BAD_DEVICE - Неверное устройство указано в LocalName
ERROR_BAD_NET_NAME - Неверный сетевой путь или сетевое имя
ERROR_EXTENDED_ERROR - Некоторая ошибка сети (см. функцию WNetGetLastError для подробностей)
ERROR_INVALID_PASSWORD - Неверный пароль
ERROR_NO_NETWORK - Нет сети

2.Отключить сетевой ресурс
WNetCancelConnection(LocalName:PChar;ForseMode:Boolean):Longint;
где
LocalName - имя, под которым сетевой ресурс был подключен к данному компьютеру (например 'F:')
ForseMode - режим отключения :
False - корректное отключение. Если отключаемый ресурс еще используется, то отключения не произойдет (например, на сетевом диске открыт файл)
True - скоростное некорректное отключение. Если ресурс используется, отключение все равно произойдет и межет привести к любым последствиям (от отсутствия ошибок до глухого повисания)

Функция возвращает код ошибки. Для всех кодов предописаны константы, наиболее часто используемые :
NO_ERROR - Нет ошибок - успешное завершение
ERROR_DEVICE_IN_USE - Ресурс используется
ERROR_EXTENDED_ERROR - Некоторая ошибка сети (см. функцию WNetGetLastError для подробностей)
ERROR_NOT_CONNECTED - Указанное ус-во не является сетевым
ERROR_OPEN_FILES - На отключаемом сетевом диске имеются открытые файлы и параметр ForseMode=false

Рекомендация: при отключении следует сначала попробовать отключить ус-во с параметром ForseMode=false и при ошибке типа ERROR_OPEN_FILES выдать запрос с сообщением о том, что ус-во еще используется и предложением отключить принудительно, и при согласии пользователя повторить вызов с ForseMode=true

Надо подключить DLL и использовать некоторые ее функции

Есть первый вариант:  procedure procname1(param1:type1; param2:type2... и т.д.) external 'dllname.dll' name 'procname_in_dllfile';

Но тут есть один нюанс: при отсутствии DLL модуля, либо при отсутствии в нем указанной процедуры будет выдаваться ошибка и запуск программы будет отменен.

Второй вариант:

Type  prc1 = procedure (param1:type1; param2:type2... и т.д.) ;  var proc1 : prc1; head : integer ; // или что-то в этом роде  ..... var p : pointer; begin head:= loadlibrary ('DLLFile.DLL'); // загружаем модуль в память if head=0 then  begin   // Сообщаем о том что модуль не найден  end else  begin   // Ищем в модуле наши процедуры и функции   p:=getprocaddress ('Имя_Искомой_Процедуры');      // Тут посмотри точно название этой     // функции в хелпе по LoadLibrary.     // Имя_Искомой_Процедуры должно     // быть один в один с именем процедуры     // в библиотеке с учетом регистров.   if p=nil then   begin    // Процедура не найдена   end else proc1:=prc1(p); end;

Как передать при создании нити (Tthread) ей некоторое значение?

К примеру, функция "прослушивает" каталог на предмет файлов. Если находит, то создает нить, которая будет обрабатывать файл. Потомку надо передать имя файла, а вот как?

Странный вопрос. Я бы понял, если бы требовалось передавать данные во время работы нити. А так обычно поступают следующим образом.
В объект нити, происходящий от TThread дописывают поля. Как правило, в секцию PRIVATE. Затем переопределяют конструктор CREATE, который, принимая необходимые параметры заполняет соответствующие поля. А уже в методе EXECUTE легко можно пользоваться данными, переданными ей при его создании.
Например:

...... TYourThread = class(TTHread) private  FFileName: String; protected  procedure Execute; overrided; public  constructor Create(CreateSuspennded: Boolean;  const AFileName: String); end; ..... constructor TYourThread.Create(CreateSuspennded: Boolean;   const AFileName: String); begin  inherited Create(CreateSuspennded);  FFIleName := AFileName; end;  procedure TYourThread.Execute; begin  try   ....   if FFileName = ...   ....  except   ....  end; end; .... TYourForm = class(TForm) .... private  YourThread: TYourThread;  procedure LaunchYourThread(const AFileName: String);  procedure YourTreadTerminate(Sender: TObject); .... end; .... procedure TYourForm.LaunchYourThread(   const AFileName: String); begin  YourThread := TYourThread.Create(True, AFileName);  YourThread.Onterminate := YourTreadTerminate;  YourThread.Resume end; .... procedure TYourForm.YourTreadTerminate(Sender: TObject); begin  .... end; .... end.

Имею тег <img src="cgi-bin/proga.exe" border=...> Программа должна выдавать в браузер изображение. Прочитать JPeg, указать ContentType=Image/jpeg и выдать изображение в SaveToStream умею. Как сделать тоже самое для файлов GIF, в особенности анимационных? Если можно просто перелить дисковый файл (пусть он хоть трижды GIF) в Response CGI-програмы, то как это сделать?

Выдайте из скрипта следующее:

Content-type: image/gif

<содержимое gif-файла>

Рисую две иконки 32х32 и 16х16, но под NT 32х32 не показывается!

С помощью Image Editor из комплекта Delphi3 создаю ресурс содержащий иконки и добавляю его в свой проект. Как известно, одна иконка в ресурсе может иметь два вида 32х32 и 16х16, которые отображаются соответственно при выборе крупных и мелких значков. Я создаю оба изображения, но после компиляции отображается только 16х16 (при крупных значках оно растягивается). Как мне сделать так, чтобы отображались обе иконки?

1. Такая штука работает только под Win 95-98, а в NT вторая икона не учитывается
2. Для редактирования подобных иконок лучше использовать либо Borlad Resourse Workshop или Visual C++ (для иконок годится но для всего остального, извините!)

Как программно создать ярлык?

uses ShlObj, ComObj, ActiveX;      procedure CreateLink(const PathObj, PathLink, Desc, Param: string);   var     IObject: IUnknown;     SLink: IShellLink;     PFile: IPersistFile;   begin     IObject := CreateComObject(CLSID_ShellLink);     SLink := IObject as IShellLink;     PFile := IObject as IPersistFile;     with SLink do begin       SetArguments(PChar(Param));       SetDescription(PChar(Desc));       SetPath(PChar(PathObj));     end;     PFile.Save(PWChar(WideString(PathLink)), FALSE);   end;

Затенить кнопку закрыть в заголовке формы

Следующий текст убирает команду закрыть из системного меню и одновременно делает серой кнопку закрыть в заголовке формы:

procedure TForm1.FormCreate(Sender: TObject);  var hMenuHandle:HMENU;  begin   hMenuHandle := GetSystemMenu(Handle, FALSE);   IF (hMenuHandle <> 0) THEN    DeleteMenu(hMenuHandle, SC_CLOSE, MF_BYCOMMAND);  end;