Как "быструю подсказку" (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?
|
Invalidate |
весь объект перерисовывается заново; обычно перерисовывается только часть бывшая перед этим закрытой |
|
|
|
|
Update |
незамедлительная перерисовка |
|
|
|
|
Refresh |
Invalidate + Update |
Как сделать отступ в 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;
