Как "быструю подсказку" (Hints) сделать многострочной?

Необходимо создать соответствующую компоненту которая показывает "быструю подсказку" (Hints) с более чем одной строкой. Компонента наследуется от TComponent и называется TMHint. Hint-текст можно задавать следующим образом: "Строка 1@Строка 2@Строка 3". Символ '@' используется как разделитель строк. Если Вам нравится другой символ - измените свойство Separator. Свойство Active указывает на активность (TRUE) или неактивность (FALSE) "многострочности".

unit MHint;

interface

uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs;

type TMHint = class(TComponent) private ScreenSize: Integer; FActive: Boolean; FSeparator: Char; FOnShowHint: TShowHintEvent; protected procedure SetActive(Value: Boolean); procedure SetSeparator(Value: char); procedure NewHintInfo(var HintStr: string; var CanShow: Boolean; var HintInfo: THintInfo); public constructor Create(AOwner: TComponent); override; published property Active: Boolean read FActive write SetActive; property Separator: Char read FSeparator write SetSeparator; end;

procedure Register;

implementation

constructor TMHint.Create(AOwner: TComponent);

begin inherited Create(AOwner); FActive := True; FSeparator := '@'; Application.OnShowHint := NewHintInfo; ScreenSize := GetSystemMetrics(SM_CYSCREEN); end;

procedure TMHint.SetActive(Value: Boolean);

begin FActive := Value; end;

procedure TMHint.SetSeparator(Value: Char);

begin FSeparator := Value; end;

procedure TMHint.NewHintInfo(var HintStr: string; var CanShow: Boolean; var HintInfo: THintInfo);

var I: Byte;

begin if FActive then begin I := Pos(FSeparator, HintStr); while I > 0 do begin HintStr[I] := #13; I := Pos(FSeparator, HintStr); end; if HintInfo.HintPos.Y+10 > ScreenSize then HintInfo.HintPos.Y := ScreenSize-11; end; end;

procedure Register;

begin RegisterComponents('MyComponents', [TMHint]); end;

end.

Или вот ещё .

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

Чтобы найти и сделать видимыми, например, компоненты с именами от "Label1" и до "Label5" можно использовать следующий вариант:

for t := 1 to 5 do

FindComponent('Label' + IntToStr(t)).Visible := TRUE;

Как эффективно организовать объявление глобальных переменных?

Один из эффективных способов организации глобальных переменных - создать отдельный Unit и в Interface-части объявить все необходимые переменные (и, естесственно, константы ежели таковые имеются). Если теперь в других модулях записать этот Unit в uses раздел, то все глобальные переменные можно использовать в рамках целого проекта (или проектов).

Как экспортировать таблицу базы данных в ASCII-файл?

procedure TMyTable.ExportToASCII;

var

I: Integer; Dlg: TSaveDialog; ASCIIFile: TextFile; Res: Boolean;

begin

if Active then

if (FieldCount > 0) and (RecordCount > 0) then

begin

Dlg := TSaveDialog.Create(Application); Dlg.FileName := FASCIIFileName; Dlg.Filter := 'ASCII-Fiels (*.asc)|*.asc'; Dlg.Options := Dlg.Options+[ofPathMustExist, ofOverwritePrompt, ofHideReadOnly]; Dlg.Title := 'Экспоритровать данные в ASCII-файл'; try

Res := Dlg.Execute; if Res then

FASCIIFileName := Dlg.FileName; finally

Dlg.Free; end; if Res then

begin

AssignFile(ASCIIFile, FASCIIFileName); Rewrite(ASCIIFile); First; if FASCIIFieldNames then

begin

for I := 0 to FieldCount-1 do

begin

Write(ASCIIFile, Fields[I].FieldName); if I <> FieldCount-1 then

Write(ASCIIFile, FASCIISeparator); end; Write(ASCIIFile, #13#10); end; while not EOF do

begin

for I := 0 to FieldCount-1 do

begin

Write(ASCIIFile, Fields[I].Text); if I <> FieldCount-1 then

Write(ASCIIFile, FASCIISeparator); end; Next; if not EOF then

Write(ASCIIFile, #13#10); end; CloseFile(ASCIIFile); if IOResult <> 0 then

MessageDlg('Ошибка при создании или переписывании '+ 'в ASCII-файл', mtError, [mbOK], 0); end; end

else

MessageDlg('Нет данных для экспортирования.', mtInformation, [mbOK], 0) else

MessageDlg('Таблица должна быть открытой, чтобы данные '+ 'можно было экспортировать в ASCII-формат.', mtError, [mbOK], 0); end;

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

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

function CopyClipToBuf(DC: HDC; Left, Top, Width, Height: Integer; Rop: LongInt; var CopyDC: HDC; var CopyBitmap: HBitmap): Boolean;

var

TempBitmap: HBitmap;

begin

Result := False; CopyDC := 0; CopyBitmap := 0; if DC <> 0 then

begin

CopyDC := CreateCompatibleDC(DC); if CopyDC <> 0 then

begin

CopyBitmap := CreateCompatibleBitmap(DC, Width, Height); if CopyBitmap <> 0 then

begin

TempBitmap := CopyBitmap; CopyBitmap := SelectObject(CopyDC, CopyBitmap); Result := BitBlt(CopyDC, 0, 0, Width, Height, DC, Left, Top, Rop); CopyBitmap := TempBitmap; end; end; end; end;

function CopyBufToClip(DC: HDC; var CopyDC: HDC; var CopyBitmap: HBitmap; Left, Top, Width, Height: Integer; Rop: LongInt; DeleteObjects: Boolean): Boolean;

var

TempBitmap: HBitmap;

begin

Result := False; if (DC <> 0) and

(CopyDC <> 0) and

(CopyBitmap <> 0) then

begin

TempBitmap := CopyBitmap; CopyBitmap := SelectObject(DC, CopyBitmap); Result := BitBlt(DC, Left, Top, Width, Height, CopyDC, 0, 0, Rop); CopyBitmap := TempBitmap; if DeleteObjects then

begin

DeleteDC(CopyDC); DeleteObject(CopyBitmap); end; end; end;

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

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

Variable := GetFreeSystemResources(GFSR_SYSTEMRESOURCES);

Другие функции опроса параметров системы (описаны в системе помощи): GetWinFlags, SystemParametersInfo, GetDeviceCaps и GetFreeSpace.

Для 32-bit систем необходимо вызывать GetSystemMetrics, GetSystemInfo и SystemParametersInfo.

Как перейти к указанной записи в БД?

Демонстрация перехода к указанной записи через задание номера записи.

function TBDEDirect.GoToRecord(RecNo: LongInt): Boolean; var RecCount: LongInt; Bookmark: TBookmark; Res: DBIResult; begin Result := False; if CheckDatabase then begin if RecNo < 1 then RecNo := 1; RecCount := GetRecordCount; if RecNo > RecCount then RecNo := RecCount; Res := DbiSetToRecordNo(FDataLink.DataSource.DataSet.Handle, RecNo); if Res = 0 then begin Bookmark := StrAlloc(GetBookmarkSize); DbiGetBookmark(FDataLink.DataSource.DataSet.Handle, Bookmark); FDataLink.DataSource.DataSet.GoToBookmark(Bookmark); FDataLink.DataSource.DataSet.FreeBookmark(Bookmark); Result := True; end else Check(Res); end; end;

Как проверять корректность доступа к базе данных?

Следующая функция проверяет доступ к базе данных и выдает возможные причины, если доступ не удается осуществить. Функция возвращает значение True в случае успешной операции и False в противном случае.

function TBDEDirect.CheckDatabase: Boolean; var

DS: TDataSource; begin

Result := False; DS := GetDataSource; if DS = nil then

begin

MessageDlg('Не установлена связь с элементом-источником данных.'+ 'Проверьте установку свойства DataSource.', mtError, [mbOK], 0); Exit; end; if DS.DataSet = nil then

begin

MessageDlg('Доступ к базе данных невозможен.', mtError, [mbOK], 0); Exit; end; if TDBDataSet(DS.DataSet).Database = nil then

begin

MessageDlg('Доступ к базе данных невозможен.', mtError, [mbOK], 0); Exit; end; if TDBDataSet(DS.DataSet).Database.Handle = nil then

begin

MessageDlg('Дескриптор (Handle) БД недоступен.', mtError, [mbOK], 0); Exit; end; if DS.DataSet.Handle = nil then

begin

MessageDlg('Дескриптор курсора (Cursor-Handle) недоступен.', mtError, [mbOK], 0); Exit; end; Result := True; end;

Как различаются между собой Paint-события: Invalidate, Update и Refresh?

Как сделать отступ в Memo?

С помощью API-функции SendMessage можно задать поля в Memo-компоненте. Если необходимо, например, сделать отступ в 20 пикселей слева то можно это сделать следующим образом:

var Rect: TRect; begin SendMessage( Memo1.Handle, EM_GETRECT, 0, LongInt(@Rect)); Rect.Left:= 20; SendMessage(Memo1.Handle, EM_SETRECT, 0, LongInt(@Rect)); Memo1.Refresh; end;

Как сделать возможным передвижение

В следующем примере показано как можно передвигать форму если пользователь "захватил" Client-пространство. Наиболее простое решение - "обмануть" Windows и Client-пространство выдать за заголовок окна.

unit DragMain;

interface

uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCrtls;

type TForm1 = class(TForm) Button1: TButton; procedure ButtonClick(Sender: TObject); private procedure WMNCHitTest(var M: TWMNCHitTest); message wm_NCCHitTest; end;

var Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1. WMNCHitTest(var M: TWMNCHitTest);

begin inherited; if M.Result = htClient then M.Result := htCaption; end;

procedure TForm1.Button1Click(Sender: TObject);

begin Close; end;

end.

Как скрыть форму при старте приложения?

К сожалению при создании окна приложения ни в одном из первых событий (OnCreate, OnShow, OnActivate) нет доступа к свойству Visible. Использование функции ShowWindow с параметром SW_HIDE в OnActivate-событии решает проблему (но при этом не избежать кратковременного мерцания окна перед "исчезновением"):

procedure TForm1.OnActivate(Sender: TObject); begin

ShowWindow(Handle, SW_HIDE); end;

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

ShowWindow(Handle, SW_SHOW);

Если Вам лень пользовать API-функции или неприятно видеть мерцание, то есть другой, весьма интересный способ сокрыть окно приложения от любопытствующих глаз:

procedure TForm1.OnCreate(Sender: TObject); begin

Left := Screen.Width; end;

Окно создается видимым, но находится за пределами экрана!

Как скрыть свойства объекта?

В иерархии VCL в большинстве случаев существует уровень объектов-"предшественников" (TCustomXXXX), в которых многие свойства скрыты. Для унаследованных от таких "предшественников" объектов можно "открывать" на выбор те или иные свойства. А как можно сокрыть свойства, которые объявлены в published-области от Object Inspector'а, но при этом оставить возможность доступа во время работы программы? Решение состоит в объявлении свойства "по новой" в public-области. В примере скрытым будет у объекта TMyControl свойство Height.

TMyControl = class(TWinControl) protected procedure SetHeight(Value: Integer); function GetHeight: Integer; public property Height: Integer read GetHeight write SetHeight; end;

procedure TMyControl.SetHeight(Value: Integer); begin inherited Height := Value; end;

function TMyControl.GetHeight; begin Result := inherited Height; end;

Как создать и использовать новую форму курсора?

Для этого необходимо создать новый курсор(ы) в подходящем для этого редакторе ресурсов (например борландовский Resource Workshop). При этом надо обратить внимание на то что имена в редакторе ресурсов (особенно в том, который поставляется с Delphi) надо писать заглавными буквами. После этого "перед внутренним употреблением" (лучше всего в процедуре обработки события OnCreate главной формы) необходимо загрузить курсор(ы) из res-файла как указано ниже:

{$I CURSOR.RES}

Screen.Cursors[1] := LoadCursor(hInstance, 'CURSOR_1'); Button1.Cursor := 1;

Обратите внимание на то, что системные курсоры в Screen.Cursors начинаются с нуля и идут в минусовом направлении. Поэтому при создании новых курсоров лучше выбирать положительные числа (лучше не слишком большие :-)).

Более удобный вариант - это объявить постоянную (равную например 12):

const

CUR_HAND = 12;

...

Screen.Cursors[CUR_HAND] := LoadCursor(hInstance, 'CURSOR_HAND'); Button1.Cursor := CUR_HAND;

Как создать и вызвать модальный формуляр?

Модальные формуляры довольно часто выгоднее (с точки зрения использования памяти) временно создавать, и после того, как формуляр был вызван, отработан и закрыт, - освободить его из памяти. В противном случае Delphi-приложение может быть настоящим "пожирателем памяти". Примерно так может выглядеть вызов такого формуляра:

ModalForm := TModalForm.Create(Self); try

ModalForm.ShowModal; finally

ModalForm.Free; end;

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

По умолчанию ini-файл создается в Windows-директории (например: TIniFile.Create('FOO.INI' )), что приводит к "захламлению" оной. Более (эко-)логично (за исключением случаев, когда программа делается для CD-ROM) если ini-файл создается в той же директории что и главная программа. Это достигается с помощью одной строки:

IniFile := TIniFile.Create(ChangeFileExt(ParamStr(0),'.INI'));

Как сравнить bookmarks в таблице?

function TBDEDirect.CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Boolean;

var

Res: DBIResult; CompareRes: Word;

begin

Result := False; if CheckDatabase then

begin

Res := DbiCompareBookmarks(FDataLink.DataSource.DataSet.Handle, Bookmark1, Bookmark2, CompareRes); if Res = 0 then

if CompareRes = 0 then

Result := True else

else

Check(Res); end; end;

Как управлять табуляцией в Memo-компоненте?

Для этого необходимо поставить свойство "WantTabs" в "True". Теперь для управления штртной табуляции необходимо вызвать API-функцию SendMessage. В последнем параметре функция ожидает указатель на массив с элементами типа Word, в котором указаны позиции в единицах экрана. Для примера вызов функции с указанием двух позиций табуляции:

procedure TForm1.FormCreate(Sender:TObject); const Tabs: array[0..1] of Word = (4, 8); begin SendMessage(Memo1.Handle, EM_SetTabStops, 2, LongInt(@Tabs)); end;

Как ускорить навигацию по исходному тексту?

Весьма удобно при работе с текстами больше двух-трех страниц использовать метки (bookmarks).

Чтобы установить подобную метку - необходимо нажать компбинацию клавиш: CTRL+SHIFT+Число, где "Число" находится в пределах от 0 до 9. После этого можно с любого места "прыгнуть" на эту метку. Для этого необходимо нажать комбинацию CTRL+Число.

Примечание: Чтобы убрать метку - необходимо второй раз нажать CTRL+SHIFT+Число, а чтобы передвинуть метку на другое место - необходимо нажать ту же комбинацию в необходимом месте.

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

Если свойство BorderStyle установленно в значение bsSizeable, то размер формуляра можно уменьшать или увеличивать. Иногда, чтобы показывать все необходимые элементы на форме, необходимо установить минимальные размеры формуляра? Следующая процедура позволяет ограничить размеры формуляра.

type TForm1 = class(TForm) procedure wmGetMinMaxInfo(var Msg : TMessage); message wm_GetMinMaxInfo;

procedure TForm1.wmGetMinMaxInfo(var Msg : TMessage);

begin PMinMaxInfo(Msg.lParam)^.ptMinTrackSize.X := 600; PMinMaxInfo(Msg.lParam)^.ptMinTrackSize.Y := 350; end;

Как узнать, находится ли дискета в дисководе?

type

TDriveState(DS_NO_DISK, DS_UNFORMATTED_DISK, DS_EMPTY_DISK, DS_DISK_WITH_FILES);

function DriveState(DrvLetter: Char): TDriveState;

var

Mask: String[6]; SearchRec: TSearchRec; oldMode: Cardinal; ReturnCode: Integer;

begin

oldMode: = SetErrorMode(SEM_FAILCRITICALERRORS); Mask:= '?:\*.*'; Mask[1] := DrvLetter; {$I-} { отключить обработку исключительных ситуаций }

ReturnCode := FindFirst(Mask, faAnyfile, SearchRec); FindClose(SearchRec);

{$I+}

case ReturnCode of

{ как минимум один файл был найден }

0: Result := DS_DISK_WITH_FILES; { файлов не найдено и дискета в порядке }

-18: Result := DS_EMPTY_DISK; { DS_NO_DISK для DOS, ERROR_NOT_READY для WinNT, ERROR_PATH_NOT_FOUND для Win 3.1 }

-21, -3: Result := DS_NO_DISK; else

{ дискета лежит в дисководе но она не форматировнная }

Result := DS_UNFORMATTED_DISK; end; SetErrorMode(oldMode); end; { DriveState }

Как узнать содержание активной записи в БД?

Следующая функция возвращает в виде указателя на строку содержание активной записи в БД.

function TBDEDirect.GetCurRecord(Lock: DBILockType): PChar;

var

Res: DBIResult; RecSize: Word; RecBuf: PChar; Bookmark: TBookmark;

begin

Result := StrNew(''); if CheckDatabase then

begin

RecSize := GetPhysicalRecSize; RecBuf := StrAlloc(RecSize+1); FillChar(RecBuf^, RecSize+1, #0); Bookmark := FDataLink.DataSource.DataSet.GetBookmark; DbiSetToBookmark(FDataLink.DataSource.DataSet.Handle, Bookmark); FDataLink.DataSource.DataSet.FreeBookmark(Bookmark); Res := DbiGetRecord(FDataLink.DataSource.DataSet.Handle, Lock, RecBuf, nil); if Res = 0 then

Result := RecBuf else

Check(Res); end; end;

Как выдать текст под наклоном?

Чтобы вывести под любым углом текст необходимо использовать TrueType Fonts (например "Arial"). Например:

var LogFont : TLogFont;

... GetObject(Canvas.Font.Handle, SizeOf(TLogFont), @LogFont); { Вывести текст 1/10 градуса против часовой стрелки }

LogFont.lfEscapement := Angle*10; Canvas.Font.Handle := CreateFontIndirect(LogFont);

(3кб)

Как выделить окошко DBGrid другим цветом?

Необходимо обработать событие "OnDrawCellData". Например для того, чтобы пометить выбранное окошко красным фоном, необходимо сделать следующее:

procedure TForm1.DBGridDrawDataCell(Sender:TObject; const Rect:TRect; Field:TField; State:TGridDrawState);

begin

if gdFocused in State then

with (Sender as TDBGrid).Canvas do

begin

Brush.Color := clRed; FillRect(Rect); TextOut(Rect.Left, Rect.Top, Field.AsString); end; end;

Как выяснить дату последнего изменения файла?

Для выяснения даты последнего изменения файла можно воспользоваться следующей функцией:

function GetFileDate(FileName: string): string;

var

FHandle: Integer;

begin

FHandle := FileOpen(FileName, 0); try

Result := DateTimeToStr(FileDateToDateTime(FileGetDate(FHandle))); finally

FileClose(FHandle); end; end;

Как выяснить положение курсора в МЕМО?

Необходимо вызвать дважды API-функцию "SendMessage":

var xChr, xRow, xCol: LongInt; ...

xRow := SendMessage(Memo1.Handle, EM_LINEFROMCHAR, Memo1.SelStart, 0); xChr := SendMessage(Memo1.Handle, EM_LINEINDEX, Zeile, 0); xCol := Memo1.SelStart - xChr + 1;

Как выяснить размер BLOB-поля?

Следующая функция поможет определить размер BLOB-поля.

Function GetBlobSize(Field: TBlobField): LongInt;

begin

with TBlobStream.Create(Field, bmRead) do try

Result := Seek(0, 2); finally

Free; end; end;

Как вывести главное окно справочной системы?

В 16-битных версиях справочной системы необходимо было вызывать начальное (главное) окно помощи с параметром HELP_CONTENTS в комманде HelpCommand. В 32-битном варианте это осуществляется следующим образом:

Application.HelpCommand(HELP_FINDER, 0);

Примечание: Для того, чтобы показывались "книжки" (или главные темы) - необходимо создать .CNT-файл.

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

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

...

private

procedure CreateParams(var Params: TCreateParams); override;

...

procedure TForm2.CreateParams(var Params: TCreateParams);

begin

inherited CreateParams(Params); Params.WndParent := GetDesktopWindow; end;

Как выводить формуляр в центр экрана?

Часто встречающийся вопрос начинающего программиста. Чтобы вывести формуляр в центре экрана необходимо (в самом простом случае) изменить свойство формы Position. Значение должно быть установленно в poScreenCenter. Причем это можно делать как в Object Inspector, так и во время работы программы.

Как вызвать подсказку к подсказке?

В Delphi-приложении можно вызвать помощь в пользовании системой помощи следующим образом:

Application.HelpCommand(Help_HelpOnHelp, 0);

Как закрыть окно подсказки если пользователь закончил приложение?

В следующем примере показано как закрыть окно помощи если пользователь закончил приложение.

procedure TMainForm.FormClose(Sender: TObject; var Action: TCloseAction);

begin

Winhelp(Handle, 'WINHELP.HLP', HELP_QUIT, 0); Action := caFree; end;

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

Для этого необходимо перехватить сообщение "WM_QUERYOPEN". Для этого необходимо объявить соответствующую процедуру в private-области.

{ объявление процедуры в классе TMainForm }

procedure WMQueryOpen(var Msg: TWMQueryOpen); message WM_QUERYOPEN;

{ ... и ее реализация }

procedure TMainForm.WMQueryOpen(var Msg: TWMQueryOpen); begin Msg.Result := 0; end;

---

---

Invalidate	весь объект перерисовывается заново; обычно перерисовывается только часть бывшая перед этим закрытой
Update	незамедлительная перерисовка
Refresh	Invalidate + Update