|
Programming: Delphi
Советы программистов (Часть 4)
- Часть 1
- Часть 2
- Часть 3
- Обзор сети (типа Network Neighborhood)
- Как узнать доступные сетевые ресурсы?
- Список пользователей в Windows NT/2000
- Цветная кнопка
- Денежное поле редактирования в TEdit
- «Бегущая» строка
- Множественный выбор в ListBox
- Динамическое добавление пунктов меню
- Слияние MDI-меню
- Динамическое создание пункта всплывающего меню
- Использование шрифтов и стилей в TMemo
- Индикатор хода выполнения в строке состояния
- TTrackBar для эстетов
- Чтение текста RichEdit из базы данных
- Исправление загрузки текста RTF через поток
- Динамическое создание компонента TTable
- Различные цвета строк в DBCtrlGrid
- Использование опции MultiSelect в DBGrid
- Сортировка колонок в DBGrid
- DBGrid с цветными ячейками
- TDBGrid -– копирование в буфер обмена
- Заголовок в DBGrid
- Отображение логотипа при запуске приложения
- Поддержка команд Cut, Copy, Paste
Обзор сети (типа Network Neighborhood)
Пример может служить отправной точкой для создания рабочего варианта.
<![CDATA[
unit netres_main_unit;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, ComCtrls, StdCtrls, Buttons, Menus, ExtCtrls;
type
TfrmMain = class(TForm)
tvResources: TTreeView;
btnOK: TBitBtn;
btnClose: TBitBtn;
Label1: TLabel;
barBottom: TStatusBar;
popResources: TPopupMenu;
mniExpandAll: TMenuItem;
mniCollapseAll: TMenuItem;
mniSaveToFile: TMenuItem;
mniLoadFromFile: TMenuItem;
grpListType: TRadioGroup;
grpResourceType: TRadioGroup;
dlgOpen: TOpenDialog;
dlgSave: TSaveDialog;
procedure FormCreate(Sender: TObject);
procedure btnCloseClick(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure mniExpandAllClick(Sender: TObject);
procedure mniCollapseAllClick(Sender: TObject);
procedure mniSaveToFileClick(Sender: TObject);
procedure mniLoadFromFileClick(Sender: TObject);
procedure btnOKClick(Sender: TObject);
private
ListType, ResourceType: DWORD;
procedure ShowHint(Sender: TObject);
procedure DoEnumeration;
procedure DoEnumerationContainer(NetResContainer: TNetResource);
procedure AddContainer(NetRes: TNetResource);
procedure AddShare(TopContainerIndex: Integer; NetRes: TNetResource);
procedure AddShareString(TopContainerIndex: Integer; ItemName: String);
procedure AddConnection(NetRes: TNetResource);
end;
var
frmMain: TfrmMain;
implementation
{$R *.DFM}
procedure TfrmMain.ShowHint(Sender: TObject);
begin
barBottom.Panels.Items[0].Text := Application.Hint;
end;
procedure TfrmMain.FormCreate(Sender: TObject);
begin
Application.OnHint := ShowHint;
barBottom.Panels.Items[0].Text := '';
end;
procedure TfrmMain.btnCloseClick(Sender: TObject);
begin
Close;
end;
{ Перечисляем все сетевые ресурсы }
procedure TfrmMain.DoEnumeration;
var
NetRes: Array[0..2] of TNetResource;
Loop: Integer;
r, hEnum, EntryCount, NetResLen: DWORD;
begin
case grpListType.ItemIndex of
{ Подключенные ресурсы: }
1: ListType := RESOURCE_CONNECTED;
{ Возобновляемые ресурсы: }
2: ListType := RESOURCE_REMEMBERED;
{ Глобальные: }
else ListType := RESOURCE_GLOBALNET;
end;
case grpResourceType.ItemIndex of
{ Дисковые ресурсы: }
1: ResourceType := RESOURCETYPE_DISK;
{ Принтерные ресурсы: }
2: ResourceType := RESOURCETYPE_PRINT;
{ Все: }
else ResourceType := RESOURCETYPE_ANY;
end;
Screen.Cursor := crHourGlass;
try
{ Удаляем любые старые элементы из дерева }
for Loop := tvResources.Items.Count - 1 downto 0 do
tvResources.Items[Loop].Delete;
except
end;
{ Начинаем перечисление: }
r := WNetOpenEnum(ListType, ResourceType, 0, nil, hEnum);
if r <> NO_ERROR then begin
if r = ERROR_EXTENDED_ERROR then
MessageDlg('Невозможно сделать обзор сети.' + #13
+ 'Произошла сетевая ошибка.', mtError, [mbOK], 0)
else
MessageDlg('Невозможно сделать обзор сети.', mtError, [mbOK], 0);
Exit;
end;
try
{ Мы получили правильный дескриптор перечисления; опрашиваем ресурсы }
while (1 = 1) do begin
EntryCount := 1;
NetResLen := SizeOf(NetRes);
r := WNetEnumResource(hEnum, EntryCount, @NetRes, NetResLen);
case r of
0: begin { Это контейнер, организуем итерацию: }
if NetRes[0].dwUsage = RESOURCEUSAGE_CONTAINER then
DoEnumerationContainer(NetRes[0])
else { Здесь получаем подключенные и возобновляемые ресурсы }
if ListType in [RESOURCE_REMEMBERED, RESOURCE_CONNECTED] then
AddConnection(NetRes[0]);
end;
ERROR_NO_MORE_ITEMS: { Получены все ресурсы: }
Break;
else begin { Другие ошибки: }
MessageDlg('Ошибка опроса ресурсов.', mtError, [mbOK], 0);
break;
end;
end;
end;
finally
Screen.Cursor := crDefault;
{ Закрываем дескриптор перечисления: }
WNetCloseEnum(hEnum);
end;
end;
{ Перечисление заданного контейнера. Эта функция обычно вызывается рекурсивно }
procedure TfrmMain.DoEnumerationContainer(NetResContainer: TNetResource);
var
NetRes: Array[0..10] of TNetResource;
TopContainerIndex: Integer;
r, hEnum, EntryCount, NetResLen: DWORD;
begin
{ Добавляем имя контейнера к найденным сетевым ресурсам }
AddContainer(NetResContainer);
{ Делаем этот элемент текущим корневым уровнем }
TopContainerIndex := tvResources.Items.Count-1;
{ Начинаем перечисление: }
if ListType = RESOURCE_GLOBALNET then
{ Перечисляем глобальные объекты сети: }
r := WNetOpenEnum(ListType, ResourceType, RESOURCEUSAGE_CONTAINER,
@NetResContainer, hEnum)
else
{ Перечисляем подключаемые и возобновляемые ресурсы
(другие получить здесь невозможно) }
r := WNetOpenEnum(ListType, ResourceType, RESOURCEUSAGE_CONTAINER, nil, hEnum);
{ Невозможно перечислить ресурсы данного контейнера, выводим соответствующее
предупреждение и едем дальше }
if r <> NO_ERROR then begin
AddShareString(TopContainerIndex, '<Не могу опросить ресурсы (Ошибка #'
+ IntToStr(r) + '>');
WNetCloseEnum(hEnum);
Exit;
end;
{ Мы получили правильный дескриптор перечисления; опрашиваем ресурсы }
while (1 = 1) do begin
EntryCount := 1;
NetResLen := SizeOf(NetRes);
r := WNetEnumResource(hEnum, EntryCount, @NetRes, NetResLen);
case r of
0: begin { Другой контейнер для перечисления,
необходим рекурсивный вызов }
if (NetRes[0].dwUsage = RESOURCEUSAGE_CONTAINER)
or (NetRes[0].dwUsage=10) then
DoEnumerationContainer(NetRes[0])
else
case NetRes[0].dwDisplayType of
{ Верхний уровень }
RESOURCEDISPLAYTYPE_GENERIC,
RESOURCEDISPLAYTYPE_DOMAIN,
RESOURCEDISPLAYTYPE_SERVER: AddContainer(NetRes[0]);
{ Ресурсы общего доступа: }
RESOURCEDISPLAYTYPE_SHARE:
AddShare(TopContainerIndex, NetRes[0]);
end;
end;
ERROR_NO_MORE_ITEMS: Break;
else begin
MessageDlg('Ошибка #' + IntToStr(r) + ' при перечислении ресурсов.',
mtError, [mbOK], 0);
Break;
end;
end;
end;
{ Закрываем дескриптор перечисления }
WNetCloseEnum(hEnum);
end;
procedure TfrmMain.FormShow(Sender: TObject);
begin
DoEnumeration;
end;
{ Добавляем элементы дерева; помечаем, что это контейнер }
procedure TfrmMain.AddContainer(NetRes: TNetResource);
var
ItemName: String;
begin
ItemName := Trim(String(NetRes.lpRemoteName));
if Trim(String(NetRes.lpComment))<>'' then begin
if ItemName <> '' then ItemName := ItemName + ' ';
ItemName := ItemName + '(' + String(NetRes.lpComment) + ')';
end;
tvResources.Items.Add(tvResources.Selected,ItemName);
end;
{ Добавляем дочерние элементы к контейнеру, обозначенному как текущий
верхний уровень }
procedure TfrmMain.AddShare(TopContainerIndex: Integer; NetRes: TNetResource);
var
ItemName: String;
begin
ItemName := Trim(String(NetRes.lpRemoteName));
if Trim(String(NetRes.lpComment)) <> '' then begin
if ItemName <> '' then ItemName := ItemName + ' ';
ItemName := ItemName + '(' + String(NetRes.lpComment) + ')';
end;
tvResources.Items.AddChild(tvResources.Items[TopContainerIndex], ItemName);
end;
{ Добавляем дочерние элементы к контейнеру, обозначенному как текущий верхний
уровень; это просто добавляет строку для таких задач, как, например, перечисление
контейнера. То есть некоторые контейнерные ресурсы общего доступа нам не
доступны. }
procedure TfrmMain.AddShareString(TopContainerIndex: Integer; ItemName: String);
begin
tvResources.Items.AddChild(tvResources.Items[TopContainerIndex], ItemName);
end;
{ Добавляем соединения к дереву. По большому счету, к этому моменту все сетевые
ресурсы типа возобновляемых и текущих соединений уже отображены. }
procedure TfrmMain.AddConnection(NetRes: TNetResource);
var
ItemName: String;
begin
ItemName := Trim(String(NetRes.lpLocalName));
if Trim(String(NetRes.lpRemoteName)) <> '' then begin
if ItemName <> '' then ItemName := ItemName + ' ';
ItemName := ItemName + '-> ' + Trim(String(NetRes.lpRemoteName));
end;
tvResources.Items.Add(tvResources.Selected, ItemName);
end;
{ Раскрываем все контейнеры дерева }
procedure TfrmMain.mniExpandAllClick(Sender: TObject);
begin
tvResources.FullExpand;
end;
{ Схлопываем все контейнеры дерева }
procedure TfrmMain.mniCollapseAllClick(Sender: TObject);
begin
tvResources.FullCollapse;
end;
{ Записываем дерево в выбранный файл }
procedure TfrmMain.mniSaveToFileClick(Sender: TObject);
begin
if dlgSave.Execute then tvResources.SaveToFile(dlgSave.FileName);
end;
{ Загружаем дерево из выбранного файла }
procedure TfrmMain.mniLoadFromFileClick(Sender: TObject);
begin
if dlgOpen.Execute then tvResources.LoadFromFile(dlgOpen.FileName);
end;
{ Обновляем }
procedure TfrmMain.btnOKClick(Sender: TObject);
begin
DoEnumeration;
end;
end.
]]>
Как узнать доступные сетевые ресурсы?
Решение:
<![CDATA[
type
PNetResourceArray = ^TNetResourceArray;
TNetResourceArray = array[0..MaxInt div SizeOf(TNetResource) - 1]
of TNetResource;
procedure EnumResources(LpNR: PNetResource);
var
NetHandle: THandle;
I, BufSize, NetResult: Integer;
NetResources: PNetResourceArray;
NewItem: TListItem;
Count, Size: DWORD;
begin
if WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY, 0, LpNR,
NetHandle) <> NO_ERROR then Exit;
try
BufSize := 50 * SizeOf(TNetResource);
GetMem(NetResources, BufSize);
try
while True do begin
Count := $FFFFFFFF;
Size := BufSize;
NetResult := WNetEnumResource(NetHandle, Count, NetResources, Size);
if NetResult = ERROR_MORE_DATA then begin
BufSize := Size;
ReallocMem(NetResources, BufSize);
Continue;
end;
if NetResult <> NO_ERROR then Exit;
for I := 0 to Count-1 do begin
with NetResources^[I] do begin
if RESOURCEUSAGE_CONTAINER = (DwUsage and RESOURCEUSAGE_CONTAINER) then
EnumResources(@NetResources^[I]);
if dwDisplayType = RESOURCEDISPLAYTYPE_SHARE then begin
// ^^^^^^^^^^^^^^^^^^^^^^^^^ - ресурс
// RESOURCEDISPLAYTYPE_SERVER - компьютер
// RESOURCEDISPLAYTYPE_DOMAIN - рабочая группа
// RESOURCEDISPLAYTYPE_GENERIC - сеть
NewItem := Form1.ListView1.Items.Add;
NewItem.Caption := LpRemoteName;
end;
end;
end;
end;
finally
FreeMem(NetResources, BufSize);
end;
finally
WNetCloseEnum(NetHandle);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
OldCursor: TCursor;
begin
OldCursor := Screen.Cursor;
Screen.Cursor := crHourGlass;
with ListView1.Items do begin
BeginUpdate;
Clear;
EnumResources(nil);
EndUpdate;
end;
Screen.Cursor := OldCursor;
end;
]]>
[Nomadic]
Примечание
Добавляем в uses модуль ComCtrls.
Список пользователей в Windows NT/2000
Решение:
<![CDATA[
unit Func;
interface
uses
SysUtils, Classes, StdCtrls, ComCtrls, Graphics, Windows;
{$EXTERNALSYM NetUserEnum}
function NetUserEnum(servername: LPWSTR; level, filter: DWORD; bufptr: Pointer;
prefmaxlen: DWORD; entriesread, totalentries, resume_handle: LPDWORD): DWORD;
stdcall; external 'NetApi32.dll' Name 'NetUserEnum';
function NetApiBufferFree(Buffer: Pointer{LPVOID}): DWORD; stdcall;
external 'NetApi32.dll' Name 'NetApiBufferFree';
procedure GetLocalUserList(ulist: TStringList);
implementation
// возвращает список пользователей локального хоста
procedure GetLocalUserList(ulist: TStringList);
const
NERR_SUCCESS = 0;
FILTER_TEMP_DUPLICATE_ACCOUNT = $0001;
FILTER_NORMAL_ACCOUNT = $0002;
FILTER_PROXY_ACCOUNT = $0004;
FILTER_INTERDOMAIN_TRUST_ACCOUNT = $0008;
FILTER_WORKSTATION_TRUST_ACCOUNT = $0010;
FILTER_SERVER_TRUST_ACCOUNT = $0020;
type
TUSER_INFO_10 = record
usri10_name,
usri10_comment,
usri10_usr_comment,
usri10_full_name: PWideChar;
end;
PUSER_INFO_10 = ^TUSER_INFO_10;
var
dwERead, dwETotal, dwRes, res: DWORD;
inf: PUSER_INFO_10;
info: Pointer;
p: PChar;
i: Integer;
begin
if ulist = nil then Exit;
ulist.Clear;
info := nil;
dwRes := 0;
res := NetUserEnum(nil, 10, FILTER_NORMAL_ACCOUNT, @info, 65536, @dwERead,
@dwETotal, @dwRes);
if (res <> NERR_SUCCESS) or (info = nil) then Exit;
p := PChar(info);
for i:=0 to dwERead - 1 do begin
inf := PUSER_INFO_10(p + i * SizeOf(TUSER_INFO_10));
ulist.Add(WideCharToString(PWideChar((inf^).usri10_name)));
end;
NetApiBufferFree(info);
end;
end.
]]>
[Кондратюк Виталий]
Цветная кнопка
В книгах Калверта, Свана и других авторов можно найти текст, смысл которого сводится примерно к следующему: «Изменить цвет кнопок Button, BitBtn нельзя, т. к. их рисует Windows». Если нельзя, но очень нужно, то можно.
Небольшой компонент ColorBtn дает возможность создавать цветные кнопки. Кроме того, представлено новое свойство – Frame3D, позволяющее получить более реалистичный вид нажатой кнопки. В отличие от API, при изменении значения свойства Frame3D не требуется переоткрытие компонента.
<![CDATA[
unit ColorBtn;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Buttons;
type
TColorBtn = class(TButton)
private
IsFocused: boolean;
FCanvas: TCanvas;
F3DFrame: boolean;
FButtonColor: TColor;
procedure Set3DFrame(Value: boolean);
procedure SetButtonColor(Value: TColor);
procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM;
procedure WMLButtonDblClk(var Message: TWMLButtonDblClk);
message WM_LBUTTONDBLCLK;
procedure DrawButtonText(const Caption: string; TRC: TRect;
State: TButtonState;
BiDiFlags: Longint);
procedure CalcuateTextPosition(const Caption: string; var TRC: TRect;
BiDiFlags: Longint);
protected
procedure CreateParams(var Params: TCreateParams); override;
procedure SetButtonStyle(ADefault: boolean); override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property ButtonColor: TColor read FButtonColor write SetButtonColor
default clBtnFace;
property Frame3D: boolean read F3DFrame write Set3DFrame default False;
end;
procedure Register;
implementation
{ TColorBtn }
constructor TColorBtn.Create(AOwner: TComponent);
begin
Inherited Create(AOwner);
FCanvas := TCanvas.Create;
FButtonColor := clBtnFace;
F3DFrame := False;
end;
destructor TColorBtn.Destroy;
begin
FCanvas.Free;
Inherited Destroy;
end;
procedure TColorBtn.CreateParams(var Params: TCreateParams);
begin
Inherited CreateParams(Params);
with Params do Style := Style or BS_OWNERDRAW;
end;
procedure TColorBtn.Set3DFrame(Value: boolean);
begin
if F3DFrame <> Value then F3DFrame := Value;
end;
procedure TColorBtn.SetButtonColor(Value: TColor);
begin
if FButtonColor <> Value then begin
FButtonColor := Value;
Invalidate;
end;
end;
procedure TColorBtn.WMLButtonDblClk(var Message: TWMLButtonDblClk);
begin
Perform(WM_LBUTTONDOWN, Message.Keys, Longint(Message.Pos));
end;
procedure TColorBtn.SetButtonStyle(ADefault: Boolean);
begin
if IsFocused <> ADefault then IsFocused := ADefault;
end;
procedure TColorBtn.CNDrawItem(var Message: TWMDrawItem);
var
RC: TRect;
Flags: Longint;
State: TButtonState;
IsDown, IsDefault: Boolean;
DrawItemStruct: TDrawItemStruct;
begin
DrawItemStruct := Message.DrawItemStruct^;
FCanvas.Handle := DrawItemStruct.HDC;
RC := ClientRect;
with DrawItemStruct do begin
IsDown := ItemState and ODS_SELECTED <> 0;
IsDefault := ItemState and ODS_FOCUS <> 0;
if not Enabled then State := bsDisabled
else if IsDown then State := bsDown
else State := bsUp;
end;
Flags := DFCS_BUTTONPUSH or DFCS_ADJUSTRECT;
if IsDown then Flags := Flags or DFCS_PUSHED;
if DrawItemStruct.ItemState and ODS_DISABLED <> 0 then
Flags := Flags or DFCS_INACTIVE;
if IsFocused or IsDefault then begin
FCanvas.Pen.Color := clWindowFrame;
FCanvas.Pen.Width := 1;
FCanvas.Brush.Style := bsClear;
FCanvas.Rectangle(RC.Left, RC.Top, RC.Right, RC.Bottom);
InflateRect(RC, -1, -1);
end;
if IsDown then begin
FCanvas.Pen.Color := clBtnShadow;
FCanvas.Pen.Width := 1;
FCanvas.Rectangle(RC.Left, RC.Top, RC.Right, RC.Bottom);
InflateRect(RC, -1, -1);
if F3DFrame then begin
FCanvas.Pen.Color := FButtonColor;
FCanvas.Pen.Width := 1;
DrawFrameControl(DrawItemStruct.HDC, RC, DFC_BUTTON, Flags);
end;
end else
DrawFrameControl(DrawItemStruct.HDC, RC, DFC_BUTTON, Flags);
FCanvas.Brush.Color := FButtonColor;
FCanvas.FillRect(RC);
InflateRect(RC, 1, 1);
if IsFocused then begin
RC := ClientRect;
InflateRect(RC, -1, -1);
end;
if IsDown then OffsetRect(RC, 1, 1);
FCanvas.Font := Self.Font;
DrawButtonText(Caption, RC, State, 0);
if IsFocused and IsDefault then begin
RC := ClientRect;
InflateRect(RC, -4, -4);
FCanvas.Pen.Color := clWindowFrame;
Windows.DrawFocusRect(FCanvas.Handle, RC);
end;
FCanvas.Handle:= 0;
end;
procedure TColorBtn.CalcuateTextPosition(const Caption: string; var TRC: TRect;
BiDiFlags: Integer);
var
TB: TRect;
TS, TP: TPoint;
begin
with FCanvas do begin
TB := Rect(0, 0, TRC.Right + TRC.Left, TRC.Top + TRC.Bottom);
DrawText(Handle, PChar(Caption), Length(Caption), TB,
DT_CALCRECT or BiDiFlags);
TS := Point(TB.Right - TB.Left, TB.Bottom - TB.Top);
TP.X := ((TRC.Right - TRC.Left) - TS.X + 1) div 2;
TP.Y := ((TRC.Bottom - TRC.Top) - TS.Y + 1) div 2;
OffsetRect(TB, TP.X + TRC.Left, TP.Y + TRC.Top);
TRC := TB;
end;
end;
procedure TColorBtn.DrawButtonText(const Caption: string; TRC: TRect;
State: TButtonState; BiDiFlags: Integer);
begin
with FCanvas do begin
CalcuateTextPosition(Caption, TRC, BiDiFlags);
Brush.Style := bsClear;
if State = bsDisabled then begin
OffsetRect(TRC, 1, 1);
Font.Color := clBtnHighlight;
DrawText(Handle, PChar(Caption), Length(Caption), TRC,
DT_CENTER or DT_VCENTER or BiDiFlags);
OffsetRect(TRC, -1, -1);
Font.Color := clBtnShadow;
DrawText(Handle, PChar(Caption), Length(Caption), TRC,
DT_CENTER or DT_VCENTER or BiDiFlags);
end else
DrawText(Handle, PChar(Caption), Length(Caption), TRC,
DT_CENTER or DT_VCENTER or BiDiFlags);
end;
end;
procedure Register;
begin
RegisterComponents('Controls', [TColorBtn]);
end;
end.
]]>
[VS]
Примечание
Кнопку по-прежнему рисует Windows, а раскрашивает ее компонент ColorBtn.
Денежное поле редактирования в TEdit
Решение:
<![CDATA[
unit CurrEdit;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Menus,
Forms, Dialogs, StdCtrls;
type
TCurrencyEdit = class(TCustomMemo)
private
DispFormat: string;
FieldValue: Extended;
procedure SetFormat(A: string);
procedure SetFieldValue(A: Extended);
procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
procedure CMExit(var Message: TCMExit); message CM_EXIT;
procedure FormatText;
procedure UnFormatText;
protected
procedure KeyPress(var Key: Char); override;
procedure CreateParams(var Params: TCreateParams); override;
public
constructor Create(AOwner: TComponent); override;
published
property Alignment default taRightJustify;
property AutoSize default True;
property DisplayFormat: string read DispFormat write SetFormat;
property Value: Extended read FieldValue write SetFieldValue;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Additional', [TCurrencyEdit]);
end;
constructor TCurrencyEdit.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
AutoSize := True;
Alignment := taRightJustify;
Width := 121;
Height := 25;
DispFormat := '$,0.00;($,0.00)';
FieldValue := 0.0;
AutoSelect := False;
WantReturns := False;
WordWrap := False;
FormatText;
end;
procedure TCurrencyEdit.SetFormat(A: String);
begin
if DispFormat <> A then begin
DispFormat := A;
FormatText;
end;
end;
procedure TCurrencyEdit.SetFieldValue(A: Extended);
begin
if FieldValue <> A then begin
FieldValue := A;
FormatText;
end;
end;
procedure TCurrencyEdit.UnFormatText;
var
TmpText: String;
Tmp: Byte;
IsNeg: Boolean;
begin
IsNeg := (Pos('-', Text) > 0) or (Pos('(', Text) > 0);
TmpText := '';
for Tmp := 1 to Length(Text) do
if Text[Tmp] in ['0'..'9','.'] then TmpText := TmpText + Text[Tmp];
try
FieldValue := StrToFloat(TmpText);
if IsNeg then FieldValue := -FieldValue;
except
MessageBeep(mb_IconAsterisk);
end;
end;
procedure TCurrencyEdit.FormatText;
begin
Text := FormatFloat(DispFormat, FieldValue);
end;
procedure TCurrencyEdit.CMEnter(var Message: TCMEnter);
begin
SelectAll;
inherited;
end;
procedure TCurrencyEdit.CMExit(var Message: TCMExit);
begin
UnformatText;
FormatText;
Inherited;
end;
procedure TCurrencyEdit.KeyPress(var Key: Char);
begin
if not (Key in ['0'..'9', '.', '-']) then Key := #0;
inherited KeyPress(Key);
end;
procedure TCurrencyEdit.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
case Alignment of
taLeftJustify: Params.Style := Params.Style or ES_LEFT and Not ES_MULTILINE;
taRightJustify: Params.Style := Params.Style or ES_RIGHT and Not ES_MULTILINE;
taCenter: Params.Style := Params.Style or ES_CENTER and Not ES_MULTILINE;
end;
end;
end.
]]>
«Бегущая» строка
Как создать бегущую строку?
С помощью TLabel и TTimer.
<![CDATA[
procedure TForm1.Timer1Timer(Sender: TObject);
const
LengthGoString = 10;
GoString = 'В конце стpоку желательно повтоpить,'
+ ' чтобы получить эффект кольцевого движения! В конце строки';
i: Integer = 1;
begin
Label1.Caption := Copy(GoString, i, LengthGoString);
Inc(i);
if Length(GoString) - LengthGoString < i then i := 1;
end;
]]>
[Nikolaev Igor]
Примечание
«Окно» просмотра задается константой LengthGoString, скорость – параметром Interval компонента TTimer.
Множественный выбор в ListBox
Данный пример выводит сообщение для каждого элемента ListBox, выбранного пользователем.
<![CDATA[
procedure TForm1.Button1Click(Sender: TObject);
var
Loop: Integer;
begin
for Loop := 0 to ListBox1.Items.Count - 1 do begin
if ListBox1.Selected[Loop] then
ShowMessage(ListBox1.Items.Strings[Loop]);
end;
end;
]]>
Примечание
Необходимо в Object Inspector для ListBox1 установить свойство MultiSelect в True.
Динамическое добавление пунктов меню
Пример программы, создающей структуру меню большой вложенности двумя различными способами. Она даст вам пищу для размышлений. Форма содержит компонент MainMenu.
<![CDATA[
unit Istopmnu;
interface
uses
Windows, SysUtils, Messages, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Menus;
type
TForm1 = class(TForm)
MainMenu1: TMainMenu;
procedure AClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.AClick(Sender: TObject);
var
TM: TMenuItem;
Lev: Word;
begin
MessageBeep(0);
TM := Sender as TMenuItem;
if TM.Count > 0 then Caption := 'подменю'
else Caption := 'элемет меню';
Caption := Caption + ' с именем "' + TM.Name + '"';
Lev := 0;
while (TM.Parent <> NIL) and (TM.Parent is TMenuItem) do begin
TM := TM.Parent;
Inc(Lev);
end;
case Lev of
1: Caption := 'Верхний уровень ' + Caption;
2: Caption := '2-й уровень ' + Caption;
3: Caption := '3-й уровень ' + Caption;
else Caption := Format('%d-й уровень %s', [Lev, Caption]);
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
TM: TMenuItem;
N: Integer;
begin
TM := MainMenu1.Items;
TM.Add(NewItem('&Элемент', 0, False, True, AClick, 0, 'MenuItem2'));
for N := 2 to 5 do begin
TM.Add(TMenuItem.Create(nil));
TM := TM.Items[TM.Count - 1];
TM.Caption := '&Меню';
TM.Name := 'SubMenu' + IntToStr(N);
TM.OnClick := AClick;
TM.Add(NewItem('&Элемент', 0, False, True, AClick, 0, 'MenuItem' +
IntToStr(N + 1)));
end;
MainMenu1.Items.Add(NewSubMenu('Меню&2', 0, 'SM1',
[NewItem('&Элемент', 0, False, True, AClick,0,'MI2'),
NewSubMenu('&Меню', 0, 'SM2',
[NewItem('&Элемент', 0, False, True, AClick,0,'MI3'),
NewSubMenu('&Меню', 0, 'SM3',
[NewItem('&Элемент', 0, False, True, AClick, 0, 'MI4'),
NewSubMenu('&Меню', 0, 'SM4',
[NewItem('&Элемент', 0, False, True, AClick, 0, 'MI5'),
NewSubMenu('&Меню', 0, 'SM5',
[NewItem('&Элемент', 0, False, True, AClick, 0, 'MI6')])])])])]));
TM := MainMenu1.Items[1];
while True do begin
TM.OnClick := AClick;
if TM.Count < 2 then Break;
TM := TM.Items[1];
end;
end;
end.
]]>
[News Group]
Слияние MDI-меню
Delphi не совсем корректно выполняет объединение меню в MDI-приложениях. Если окно MDIChild максимально развернуто и добавляется другое окно MDIChild, управляющее меню MDIChild (родительское основное меню) или исчезает совсем, или делает это в момент нажатия на него.
По всей видимости, для слияния меню Delphi использует функцию InsertMenu() с параметром MF_POSITION. Тем не менее, если дочернее MDI-окно максимально развернуто, всплывающее (pop-up) меню, называемое еще контекстным, добавляется к меню MDI-приложения, на одну позицию дальше, чем необходимо. Это стандартное поведение системы, поскольку системное меню активного дочернего окна включается в первую позицию панели меню MDI-окна.
Согласно WinSDK, если активное дочернее окно максимально развертывается, вставляется новое всплывающее меню. При этом к значению позиции добавляется 1 (единица).
Динамическое создание пункта всплывающего меню
Как динамически создать пункт всплывающего меню?
Для динамического создания пункта меню необходимо создать процедуру в объекте (частный метод формы), примерно так:
<![CDATA[
procedure MyClick(Sender: TObject);]]>
Затем, при создании нового пункта меню, назначить ему собственное событие OnClick следующим образом:
<![CDATA[
NewItem := TMenuItem.Create(Self);
NewItem.Caption := 'Пункт меню';
NewItem.OnClick := MyClick;
]]>
Использование шрифтов и стилей в TMemo
Кто-нибудь знает, как использовать различные шрифты и стили в TMemo?
Создайте собственный TxxxMemo. Наследуйте от стандартного TMemo и перекройте метод Paint.
Пример, изменяющий цвет каждой строки:
<![CDATA[
unit Todrmemo;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls;
type
TOwnerDrawMemo = class(TMemo)
private
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
end;
procedure Register;
implementation
procedure TOwnerDrawMemo.WMPaint(var Message: TWMPaint);
var
Buffer: Array[0..255] of Char;
PS: TPaintStruct;
DC: HDC;
i: Integer;
X, Y, Z: Word;
OldColor: LongInt;
begin
DC := Message.DC;
if DC = 0 then DC := BeginPaint(Handle, PS);
try
X := 1;
Y := 1;
SetBkColor(DC, Color);
SetBkMode(DC, Transparent);
OldColor := Font.Color;
for i:=0 to Pred(Lines.Count) do begin
if odd(i) then SetTextColor(DC, clRed)
else SetTextColor(DC, OldColor);
Z := Length(Lines[i]);
StrPCopy(Buffer, Lines[i]);
Buffer[Z] := #0; { реально не нужно }
TextOut(DC, X,Y, Buffer, Z);
Inc(Y, abs(Font.Height));
end;
finally
if Message.DC = 0 then EndPaint(Handle, PS);
end;
end;
procedure Register;
begin
RegisterComponents('Controls', [TOwnerDrawMemo]);
end;
end.
]]>
[News Group]
Примечание
Пример написан для Delphi 1, поэтому желающие могут, разобравшись в написанном, адаптировать его к более современным версиям. А я рекомендую использовать RichEdit.
Индикатор хода выполнения в строке состояния
Решение:
<![CDATA[
procedure TForm1.Button1Click(Sender: TObject);
var
pb: TProgressBar;
begin
...
pb := TProgressBar.Create(Self);
with pb do begin
Parent := StatusBar1;
Position := 30;
Top := 2;
Left := 0;
Height := StatusBar1.Height - Top;
Width := StatusBar1.Panels[0].Width - Left;
end;
pb.Visible := True;
...
end;
]]>
[Лихолетов Алексей]
Примечание
Для работы необходимо создать хотя бы одну панель (StatusPanel) в StatusBar.
TTrackBar для эстетов
В стандартном компоненте всегда присутствует диапазон выбора (см. на рисунке нижний TTrackBar). К сожалению, в Delphi не предусмотрена возможность его отключения. Если нет необходимости в использовании диапазона выбора, то поможет небольшая доработка компонента.
<![CDATA[
unit NTrackBar;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ComCtrls, CommCtrl;
type
TNTrackBar = class(TTrackBar)
private
FSelRangeVisible: Boolean;
procedure SetSelRangeVisible(const Value: Boolean);
protected
procedure CreateParams(var Params: TCreateParams); override;
public
constructor Create(AOwner: TComponent); override;
published
property SelRangeVisible: Boolean read FselRangeVisible
write SetSelRangeVisible;
end;
procedure Register;
implementation
{ TNTrackBar }
constructor TNTrackBar.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FSelRangeVisible := False;
ThumbLength := 18;
end;
procedure TNTrackBar.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params do begin
if not FSelRangeVisible then Style := Style xor TBS_ENABLESELRANGE
else Style := Style or TBS_ENABLESELRANGE;
end;
end;
procedure TNTrackBar.SetSelRangeVisible(const Value: Boolean);
begin
if FSelRangeVisible <> Value then begin
FSelRangeVisible := Value;
RecreateWnd;
end;
end;
procedure Register;
begin
RegisterComponents('Controls', [TNTrackBar]);
end;
end.
]]>
[VS]
Чтение текста RichEdit из базы данных
Запись RichEdit в файл и сохранение этого файла в базе данных является наиболее простым способом сохранения текста компонента в таблице, но тот же способ может быть достигнут и без использования промежуточного файла, а именно с помощью TBlobStream. Пример, приведенный ниже, демонстрирует чтение текста RTF из таблицы.
<![CDATA[
procedure ReadRichEditFromTable(Table: TTable; var RichEdit: TRichEdit);
var
BlobStream: TBlobStream;
begin
try
BlobStream := TBlobStream.Create(Table.FieldByName('BODY') as TBlobField,
bmRead);
if (not Table.FieldByName('BLOBFieldName').IsNull) then begin
RichEdit.Lines.LoadFromStream(BlobStream);
end;
finally
BlobStream.Free;
end;
end;
]]>
[Лагонский Сергей]
Исправление загрузки текста RTF через поток
В версии Borland Delphi 3 Client/Server обнаружено, что при загрузке текста формата RTF методом LoadFromStream в компонент TRichEdit он не интерпретируется как RTF, а отображается полностью (со всеми управляющими символами). Ниже приведен исправленный текст реализации метода TRichEditStrings.LoadFromStream (измененные строки отмечены комментарием {!}):
<![CDATA[
procedure TRichEditStrings.LoadFromStream(Stream: TStream);
var
EditStream: TEditStream;
Position: Longint;
TextType: Longint;
StreamInfo: TRichEditStreamInfo;
Converter: TConversion;
begin
StreamInfo.Stream := Stream;
if FConverter <> nil then Converter := FConverter
else Converter := RichEdit.DefaultConverter.Create;
StreamInfo.Converter := Converter;
try
with EditStream do begin
dwCookie := LongInt(Pointer(@StreamInfo));
pfnCallBack := @StreamLoad;
dwError := 0;
end;
Position := Stream.Position;
if PlainText then TextType := SF_TEXT
else TextType := SF_RTF;
SendMessage(RichEdit.Handle, EM_STREAMIN, TextType, Longint(@EditStream));
if (TextType = SF_RTF) and (EditStream.dwError <> 0) then begin
Stream.Position := Position;
{!} if PlainText then TextType := SF_TEXT
{!} else TextType := SF_RTF;
SendMessage(RichEdit.Handle, EM_STREAMIN, TextType, Longint(@EditStream));
if EditStream.dwError <> 0 then
raise EOutOfResources.Create(sRichEditLoadFail);
end;
finally
if FConverter = nil then Converter.Free;
end;
end;
]]>
[Лагонский Сергей]
Динамическое создание компонента TTable
Решение 1
Любой компонент можно создать и без (вне) формы или любого другого дочернего компонента. Для этого в методе Create надо указать параметр nil:
<![CDATA[
FSession := TSession.Create(nil);
FDatabase := TDatabase.Create(nil);
FSession.SessionName := 'DBSession'
FDatabase.Connected := False;
FDatabase.AliasName := Database;
FDatabase.DatabaseName := USER_DATABASE;
FDatabase.SessionName := FSession.SessionName;
FUserTBL := TTable.Create(nil);
FUserTBL.DatabaseName := FDatabase.DatabaseName;
FUserTBL.SessionName := FSession.SessionName;
FUserTBL.TableName := USERTBL;
FUserTBL.IndexName := USERSpIndex;
FUserSource := TDataSource.Create(nil);
FUserSource.DataSet := FUserTBL;
]]>
Решение 2
Можно использовать TTable, не размещая компонент на форме:
<![CDATA[
function TForm1.TotalPopulation: double;
var
Tbl: TTable;
begin
Result := 0.0;
Tbl := TTable.Create(nil);
try
Tbl.DatabaseName := 'DBDEMOS';
Tbl.TableName := 'COUNTRY';
Tbl.Open;
Tbl.First;
while not Tbl.EOF do begin
Result := Result + Tbl.FieldByName('Population').AsFloat;
Tbl.Next;
end;
Tbl.Close;
finally
Tbl.Free;
end;
end;
]]>
Различные цвета строк в DBCtrlGrid
Как изменить цвета строк в DBCtrlGrid?
Используйте событие PaintPanel:
<![CDATA[
procedure TForm1.DBCtrlGrid1PaintPanel(DBCtrlGrid: TDBCtrlGrid; Index: Integer);
begin
with DataModule2.Table1 do begin
if FieldByName('INDUSTRY').AsInteger > 3600 then
DBText2.Font.Color := clGreen
else
DBText2.Font.Color := clYellow;
if FieldByName('CUR_PRICE').AsInteger > 50 then
DBText3.Font.Color := clBlue
else
DBText3.Font.Color := clAqua;
if (CompareStr(FieldByName('RCMNDATION').AsString, 'BUY') = 0) then
DBText4.Font.Color := clLime
else if (CompareStr(FieldByName('RCMNDATION').AsString, 'HOLD') = 0) then
DBText4.Font.Color := clRed
else
DBText4.Font.Color := clFuchsia;
end;
end;
]]>
Использование опции MultiSelect в DBGrid
Данный пример реализует множественный выбор записей в табличной сетке и отображение второго поля набора данных.
Метод DisableControls применяется для того, чтобы DBGrid не обновлялся во время изменения набора данных. Последняя позиция набора данных сохраняется как Bookmark.
Метод IndexOf вызывается для проверки существования вкладки. Решение о выборе метода IndexOf (или Refresh) должно определяться спецификой приложения.
<![CDATA[
procedure TForm1.SelectClick(Sender: TObject);
var
x: word;
TempBookmark: TBookMark;
begin
DBGrid1.DataSource.DataSet.DisableControls;
with DBGrid1.SelectedRows do
if Count <> 0 then begin
TempBookmark := DBGrid1.DataSource.DataSet.GetBookmark;
for x := 0 to Count - 1 do begin
if IndexOf(Items[x]) > -1 then begin
DBGrid1.DataSource.DataSet.Bookmark := Items[x];
ShowMessage(DBGrid1.DataSource.DataSet.Fields[1].AsString);
end;
end;
end;
DBGrid1.DataSource.DataSet.GotoBookmark(TempBookmark);
DBGrid1.DataSource.DataSet.FreeBookmark(TempBookmark);
DBGrid1.DataSource.DataSet.EnableControls;
end;
]]>
[News Group]
Сортировка колонок в DBGrid
Многие профессиональные приложения отображают данные в полях табличной сетки и разрешают сортировать любую колонку, просто щелкая по ее заголовку. То, что здесь изложено – не наилучший путь для решения задачи, данная технология не что иное, как простая имитация такого поведения компонента.
Главное препятствие в решении задачи – сам DBGrid. Проблема в отсутствии событий OnClick или OnMouseDown, позволяющих реагировать на элементарные манипуляции с заголовком. Правда, существует событие OnDoubleClick, но для данной цели оно не слишком изящно. Нам нужно лишь создать заголовок, реагирующий на однократный щелчок мышью. Обратимся к компоненту THeaderControl.
Этот компонент, введенный в палитру компонентов еще в Delphi 2.0, обеспечивает необходимые нам функции. Главное достоинство – реакция компонента при щелчке по отдельным панелям. Панели также обеспечивают визуальное отображение подобно кнопке (могут вдавливаться и отжиматься). Нам необходимо «прицепить» THeaderControl к DBGrid. Вот как это сделать:
Во-первых, создайте новое приложение. Положите THeaderControl на форму. Он автоматически выровняется по верхнему краю формы. Затем поместите на форму DBGrid и присвойте свойству Align значение alClient. Затем добавьте компоненты TTable и TDataSource. В компоненте TTable присвойте свойству DatabaseName значение DBDEMOS, а свойству TableName значение EVENTS.DB. В TDataSource укажите в свойстве DataSet на компонент Table1, а в TDBGrid в свойстве DataSource на DataSource1. Если свойство Active компонента TTable равно True, выключите его (значение False).
Сделаем так, чтобы компонент THeaderControl выглядел похожим на заголовок компонента DBGrid. Произведем необходимые манипуляции в момент создания формы. Дважды щелкните на событии OnCreate формы и введите следующий код:
<![CDATA[
procedure TForm1.FormCreate(Sender: TObject);
var
TheCap: String;
TheWidth, a: Integer;
begin
DBGrid1.Options := DBGrid1.Options - [dgTitles];
HeaderControl1.Sections.Add;
HeaderControl1.Sections.Items[0].Width := 12;
Table1.Active := False;
Table1.Exclusive := True;
Table1.Active := True;
for a := 1 to DBGrid1.Columns.Count do begin
with DBGrid1.Columns.Items[a - 1] do begin
TheCap := Title.Caption;
TheWidth := Width;
end;
with HeaderControl1.Sections do begin
Add;
Items[a].Text := TheCap;
Items[a].Width := TheWidth + 1;
Items[a].MinWidth := TheWidth + 1;
Items[a].MaxWidth := TheWidth + 1;
end;
try
Table1.AddIndex(TheCap, TheCap, []);
except
HeaderControl1.Sections.Items[a].AllowClick := False;
end;
end;
Table1.Active := False;
Table1.Exclusive := False;
Table1.Active := True;
end;
]]>
После того как THeaderControl заменил стандартный заголовок DBGrid, в первую очередь мы сбрасываем (устанавливаем в False) флаг dgTitles в свойстве Options компонента DBGrid. Затем мы добавляем колонку в HeaderControl и устанавливаем ее ширину равной 12. Это будет пустой колонкой, которая имеет ту же ширину, что и левая колонка статуса в DBGrid.
Затем нужно убедиться, что таблица открыта для эксклюзивного доступа (никакие другие пользователи работать с ней могут). Причина будет объяснена немного позже.
Теперь добавляем секции в HeaderControl. Для каждой добавленной колонки мы создаем в заголовке тот же текст, что и в соответствующей колонке DBGrid. В цикле мы проходим по всем колонкам DBGrid и повторяем текст заголовка колонки и его высоту. Мы также устанавливаем для HeaderControl значения свойств MinWidth и MaxWidth равным ширине соответствующей колонки в DBGrid. Это предохранит колонки от изменения их ширины. Для изменяющих размер колонок нужно дополнительное кодирование. Этот вопрос читателю предлагается решить самостоятельно.
Теперь самое интересное. Мы собираемся создать индекс для каждой колонки в DBGrid. Имя индекса будет таким же, как и название колонки. Данный код мы должны заключить в конструкцию try..finally, поскольку существуют некоторые поля, которые не могут быть проиндексированы (например, поля Blob и Memo). При попытке индексации этих полей генерируется исключительная ситуация. Мы перехватываем это исключение и не допускаем возможности щелчка в данной колонке. Это означает, что колонки, содержащие неиндексированные поля, не будут реагировать на щелчок мышью. Создание этих индексов объясненяет, почему таблица должна быть открыта в режиме эксклюзивного (монопольного) доступа. И в заключение мы закрываем таблицу, сбрасываем флаг эксклюзивности и снова делаем таблицу активной.
Последний шаг. При щелчке на HeaderControl нам необходимо включить правильный индекс таблицы. Создадим обработчик события OnSectionClick компонента HeaderControl как показано ниже:
<![CDATA[
procedure TForm1.HeaderControl1SectionClick(HeaderControl: THeaderControl;
Section: THeaderSection);
begin
Table1.IndexName := Section.Text;
end;
]]>
После щелчка в заголовке колонки значение свойства таблицы IndexName становится равным заголовку компонента HeaderControl.
Просто и красиво. Тем не менее, есть масса мест, требующих улучшения. Например, вторичный щелчок должен возобновлять порядок сортировки. Или возможность изменения размера самих колонок.
Улучшения
Здесь приведен код, улучшенный по сравнению с предыдущей версией «Совета», он заключается в использовании в качестве имени индекса имя поля вместо заголовка.
Это улучшает гибкость.
<![CDATA[
procedure TForm1.FormCreate(Sender: TObject);
var
TheCap: String;
TheFn: String;
TheWidth: Integer;
a: Integer;
begin
Table1.Active := True;
DBGrid1.Options := DBGrid1.Options - [DGTitles];
HeaderControl1.Sections.Add;
HeaderControl1.Sections.Items[0].Width := 12;
for a := 1 to DBGrid1.Columns.Count do begin
with DBGrid1.Columns.Items[a - 1] do begin
TheFn := FieldName;
TheCap := Title.Caption;
TheWidth := Width;
end;
with Headercontrol1.Sections do begin
Add;
Items[a].Text := TheCap;
Items[a].Width := TheWidth + 1;
Items[a].MinWidth := TheWidth + 1;
Items[a].MaxWidth := TheWidth + 1;
end;
try
{ Используем индексы с тем же именем, что и имя поля }
{ Пробуем задать имя индекса }
(DataSource1.Dataset as TTable).IndexName := TheFn;
except
HeaderControl1.Sections.Items[a].AllowClick := False; { Индекс недоступен }
end;
end;
end;
]]>
Используем свойство FieldName компонента DBGrid для задания индекса с тем же именем, что и имя поля.
<![CDATA[
procedure TfrmDoc.HeaderControl1SectionClick(HeaderControl: THeaderControl;
Section: THeaderSection);
begin
(DataSource1.Dataset as TTable).IndexName :=
DBGrid1.Columns.Items[Section.Index - 1].FieldName;
end;
]]>
Примечание
Работу этой программы можно еще улучшить, если предусмотреть реакцию на изменение размеров формы и работу с полосами прокрутки.
DBGrid с цветными ячейками
Есть ли какой-либо способ придать ячейке DBGrid другой цвет? Мне хотелось бы выделить отдельные ячейки строки по определенному признаку. Типа флага, который, если счет просрочен свыше 90 дней, делает строчку красной.
Решение 1
Здесь показано, как изменить цвет отдельных ячеек GBGrid без создания нового компонента.
Создайте форму, поместите на нее компонент TTable и укажите ему на таблицу EMPLOYEE.DB в базе данных DBDEMOS. Затем разместите на форме DataSource и DBGrid, «соедините» их и вы получите «живые» данные.
Для демонстрации данной технологии выбрано поле Номер служащего в таблице EMPLOYEE.DB «покрашены» ячейки с нечетными числами. То есть, если число нечетное, красим ячейку в зеленый цвет.
Единственный код расположился в обработчике события OnDrawColumnCell компонента DBGrid и выглядел он так:
<![CDATA[
procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect;
DataCol: Integer; Column: TColumn; State: TGridDrawState);
var
holdColor: TColor;
begin
holdColor := DBGrid1.Canvas.Brush.Color; { сохраняем оригинальный цвет }
if Column.FieldName = 'EmpNo' then
{ "раскрашиваем" ячейки только для поля EmpNo }
if (Column.Field.AsInteger mod 2 <> 0) then begin
DBGrid1.Canvas.Brush.Color := clGreen;
DBGrid1.DefaultDrawColumnCell(Rect, DataCol, Column, State);
DBGrid1.Canvas.Brush.Color := holdColor;
end;
end;
]]>
В данном случае вызывается метод DefaultDrawColumnCell компонента TCustomDBGrid, являющийся родителем для TDBGrid. Он раскрашивает зеленым цветом нечетные ячейки поля EmpNo.
Решение 2
Обработайте событие OnDrawDataCell. Вот пример, который использует демонстрационную таблицу COUNTRY и выводит текст красным цветом во всех строках, содержащих страны с населением свыше 10 миллионов человек:
<![CDATA[
procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const Rect: TRect;
Field: TField; State: TGridDrawState);
begin
if Table1.FieldByName('Population').AsFloat > 10000000 then
DBGrid1.Canvas.Font.Color := clRed;
dbGrid1.DefaultDrawDataCell(Rect, Field, State);
end;
]]>
Примечание
Borland не рекомендует использовать в новых разработках обработчик события OnDrawDataCell, которому пришел на смену обработчик OnDrawColumnCell. Старый вызов сохранен для совместимости.
TDBGrid -– копирование в буфер обмена
Простая процедура копирования информации из DBGrid в Clipboard может существенно облегчить жизнь при реализации требований экспорта выборок данных во внешние приемники:
<![CDATA[
unit UnGridToClb;
interface
uses
Windows, SysUtils, Classes, Dialogs, Grids, DBGrids, Db, DBTables, ClipBrd;
procedure CopyGRDToClb(dbg :TDBGrid);
// Копирует DBGrid в буфер обмена, после чего данные отлично переносятся
// как в простой текстовый редактор, так и в Excel
implementation
procedure CopyGRDToClb(dbg: TDBGrid);
var
bm: TBookMark;
pch, pch1: PChar;
s, s2: string;
i, j: integer;
begin
s := '';
for j := 0 to dbg.Columns.Count - 1 do
s := s + dbg.Columns.Items[j].Title.Caption +#9 ;
s := s + #13 + #10;
if not dbg.DataSource.DataSet.active then begin
ShowMessage('Нет выборки!!!');
Exit;
end;
try
dbg.Visible := False; // Делаем сетку невидимой, чтобы не уходило время
// на ее перерисовку при прокрутке DataSet
bm := dbg.DataSource.DataSet.GetBookmark; // чтобы не потерять текущую запись
dbg.DataSource.DataSet.First;
while not dbg.DataSource.DataSet.EOF do begin
s2 := '';
for j := 0 to dbg.Columns.Count - 1 do begin
s2 := s2 + dbg.Columns.Items[j].Field.AsString + #9;
end;
s := s + s2 + #13 + #10;
dbg.DataSource.DataSet.Next;
end;
// Переключаем клавиатуру "в русский режим", иначе - проблемы с кодировкой
GetMem(pch, 100);
GetMem(pch1, 100);
GetKeyboardLayoutName(pch);
StrCopy(pch1, pch);
while pch <> '00000419' do begin
ActivateKeyboardLayout(HKL_NEXT, 0);
GetKeyboardLayoutName(pch);
if StrComp(pch, pch1) = 0 then
// Круг замкнулся - нет такого языка '00000419'
StrCopy(pch, '00000419');
end;
Clipboard.AsText := s; // Данные - в буфер!!!
while strComp(pch, pch1) <> 0 do begin // Возвращаем режим клавиатуры
ActivateKeyboardLayout(HKL_NEXT, 0);
GetKeyboardLayoutName(pch);
end;
FreeMem(pch);
FreeMem(pch1);
dbg.DataSource.DataSet.GotoBookmark(bm);
// ShowMessage('Данные успешно скопированы в буфер обмена.');
finally
dbg.Visible := True;
end;
end;
end.
]]>
[Беличенко Б]
Заголовок в DBGrid
Как создать шапку в DBGrid?
Решение:
<![CDATA[
unit bdbgrid;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Grids,
DBGrids, Math;
type
TOnDrawTitleEvent = procedure(ACol: integer; ARect: TRect;
var TitleText: string) of object;
TBitDBGrid = class(TDBGrid)
private
FBitmapBrowse: TBitmap;
FBitmapEdit: TBitmap;
FBitmapInsert: TBitmap;
FBitmapFill: TBitmap;
FRealTitleFont: TFont;
FOnDrawTitle: TOnDrawTitleEvent;
FResizeFlag: boolean;
procedure SetRealTitleFont(Value : TFont);
procedure UpdateTitlesHeight;
protected
procedure DrawCell(ACol, ARow: Longint; ARect: TRect;
AState: TGridDrawState); override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
public
constructor Create(AOwner : TComponent);override;
destructor Destroy; override;
published
property OnDrawTitle : TOnDrawTitleEvent read FOnDrawTitle write FOnDrawTitle;
property RealTitleFont : TFont read FRealTitleFont write SetRealTitleFont;
end;
procedure Register;
implementation
var
DrawBitmap: TBitmap;
function Max(X, Y: Integer): Integer;
begin
Result := Y;
if X > Y then Result := X;
end;
procedure WriteText(ACanvas: TCanvas; ARect: TRect; DX, DY: Integer;
const Text: string; Alignment: TAlignment);
const
AlignFlags: array [TAlignment] of Integer =
(DT_LEFT or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX,
DT_RIGHT or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX,
DT_CENTER or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX);
var
B, R: TRect;
begin
with DrawBitmap, ARect do begin
Width := Max(Width, Right - Left);
Height := Max(Height, Bottom - Top);
R := Rect(DX, DY, Right - Left - 1, Bottom - Top - 1);
B := Rect(0, 0, Right - Left, Bottom - Top);
end;
with DrawBitmap.Canvas do begin
DrawBitmap.Canvas.CopyRect(B, ACanvas, ARect);
Font := ACanvas.Font;
Font.Color := ACanvas.Font.Color;
Brush := ACanvas.Brush;
SetBkMode(Handle, TRANSPARENT);
DrawText(Handle, PChar(Text), Length(Text), R, AlignFlags[Alignment]);
end;
ACanvas.CopyRect(ARect, DrawBitmap.Canvas, B);
end;
constructor TBitDBGrid.Create(AOwner: TComponent);
begin
inherited Create(Aowner);
FRealTitleFont := TFont.Create;
FResizeFlag := false;
end;
destructor TBitDBGrid.Destroy;
begin
FRealTitleFont.Free;
inherited Destroy;
end;
procedure TBitDBGrid.UpdateTitlesHeight;
var
Loop: integer;
MaxTextHeight: integer;
RRect: TRect;
begin
MaxTextHeight := 0;
for loop := 0 to Columns.Count - 1 do begin
RRect := CellRect(0, 0);
RRect.Right := Columns[Loop].Width;
RRect.Left := 0;
Canvas.Font := RealTitleFont;
MaxTextHeight := Max(MaxTextHeight, DrawText(Canvas.Handle,
PChar(Columns[Loop].Title.Caption),
Length(Columns[Loop].Title.Caption), RRect,
DT_CALCRECT + DT_WORDBREAK));
end;
if TitleFont.Height <> - MaxTextHeight then TitleFont.Height := - MaxTextHeight;
end;
procedure TBitDBGrid.MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
if MouseCoord(X, Y).Y = 0 then FResizeFlag := True;
inherited MouseDown(Button, Shift, X, Y);
end;
procedure TBitDBGrid.MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
inherited MouseUp(Button, Shift, X, Y);
if FResizeFlag then begin
FResizeFlag := False;
UpdateTitlesHeight;
end;
end;
procedure TBitDBGrid.DrawCell(ACol, ARow: Longint; ARect: TRect;
AState: TGridDrawState);
var
TitleText: string;
Al: TAlignment;
begin
if not ((gdFixed in AState) and ((ARow = 0) and (dgTitles in Options)
and (ACol <> 0))) then inherited DrawCell(ACol, ARow, ARect, AState)
else begin
if DefaultDrawing then begin
DrawEdge(Canvas.Handle, ARect, BDR_RAISEDINNER, BF_BOTTOMLEFT);
DrawEdge(Canvas.Handle, ARect, BDR_RAISEDINNER, BF_TOPRIGHT);
InflateRect(ARect, -1, -1);
Canvas.Brush.Color := FixedColor;
Canvas.FillRect(ARect);
end;
TitleText := Columns[ACol - 1].Title.Caption;
if Assigned(OnDrawTitle) then OnDrawTitle(ACol, ARect, TitleText);
if DefaultDrawing and (TitleText <> '') then begin
Canvas.Brush.Style := bsClear;
Canvas.Font := RealTitleFont;
if ACol > 0 then Al := Columns[ACol - 1].Title.Alignment
else Al := Columns[0].Title.DefaultAlignment;
WriteText(Canvas, ARect, 2, 2, TitleText, Al);
end;
end;
end;
procedure TBitDBGrid.SetRealTitleFont(Value: TFont);
begin
FRealTitleFont.Assign(Value);
Repaint;
end;
procedure Register;
begin
RegisterComponents('Andre VCL', [TBitDBGrid]);
end;
initialization
DrawBitmap := TBitmap.Create;
finalization
DrawBitmap.Free;
end.
]]>
Отображение логотипа при запуске приложения
Решение:
<![CDATA[
program Project1;
uses
Forms,
Unit1 in 'Unit1.pas' {Form1};
ULogo in 'ULogo.pas' {LogoForm};
{$R *.RES}
begin
Application.Initialize; {до этого момента никаких изменений}
with TLogoForm.Create(Application) do
try
Show;
Update;
Application.CreateForm(TForm1, Form1);
{ GProgress.AddProgress(1); - здесь можно двигать прогресс, если TGauge или
TProgressBar лежат на TLogoForm, если есть еще формы, то
Application.CreateForm(TForm2, Form2); и т.д.}
finally
Free;
end;
Application.Run;
end.
]]>
[Алексей]
Поддержка команд Cut, Copy, Paste
Решение 1
Предлагаем следующие процедуры. Вызывайте их при выборе соответствующих пунктов меню. Это будет работать со всеми «редактируемыми» элементами управления. Но для TTree нужно использовать специальные сообщения редактирования.
<![CDATA[
procedure TForm1.CopyClick(Sender: TObject);
var
Mes: TWMCopy;
begin
Mes.Msg := WM_COPY;
Screen.ActiveControl.Dispatch(Mes);
end;
procedure TForm1.CutClick(Sender: TObject);
var
Mes: TWMCut;
begin
Mes.Msg := WM_CUT;
Screen.ActiveControl.Dispatch(Mes);
end;
procedure TForm1.PasteClick(Sender: TObject);
var
Mes: TWMPaste;
begin
Mes.Msg := WM_PASTE;
Screen.ActiveControl.Dispatch(Mes);
end;
procedure TForm1.UndoClick(Sender: TObject);
var
Mes: TWMUndo;
begin
Mes.Msg := WM_UNDO;
Screen.ActiveControl.Dispatch(Mes);
end;
]]>
[Shejchenko Andrij]
Решение 2
Свойство формы ActiveControl позволяет получить ссылку на активный в данный момент элемент управления. Но не все элементы управления могут работать с буфером обмена. Если хотите работать только с компонентами Edit и Memo, то самый простой метод для CopyToClipboard:
<![CDATA[
ActiveControl.Perform(WM_COPY, 0, 0);
Для PasteFromClipboard:
ActiveControl.Perform(WM_PASTE, 0, 0);
]]>
Если элемент управления «не понимает» посланных сообщений, то это никак не скажется на его работе, он просто проигнорирует их.
Другим способом является проверка типа во время выполнения приложения:
<![CDATA[
if ActiveControl is TCustomEdit then
TCustomEdit(ActiveControl).CopyToClipboard;
]]>
[News Group]
Решение 3
Реализация команд Cut, Copy и Paste средствами WinAPI:
<![CDATA[
SendMessage(GetFocus, WM_CUT, 0, 0);
SendMessage(GetFocus, WM_COPY, 0, 0);
SendMessage(GetFocus, WM_PASTE, 0, 0);
]]>
[News Group]
Решение 4
Есть два шага, положенных в основу работы с буфером обмена . Во-первых, нужно знать, какие пункты меню Правка должны быть в данный момент активизированы. Во-вторых, необходимо работать с тем элементом управления, который в данный момент выбран.
<![CDATA[
procedure TForm1.Edit1Click(Sender: TObject);
begin
if ActiveControl is TCustomEdit then begin
with TCustomEdit(ActiveControl) do begin
Cut1.Enabled := SelLength > 0;
Copy1.Enabled := SelLength > 0;
Paste1.Enabled := ClipBoard.HasFormat(CF_TEXT);
end;
end else begin
Cut1.Enabled := False;
Copy1.Enabled := False;
Paste1.Enabled := False;
end;
end;
procedure TForm1.Cut1Click(Sender: TObject);
begin
if ActiveControl is TDBEdit then
with TDBEdit(ActiveControl).DataSource.DataSet do Edit;
TCustomEdit(ActiveControl).CutToClipboard;
if ActiveControl is TDBEdit then
with TDBEdit(ActiveControl).DataSource.DataSet do Post;
end;
procedure TForm1.Copy1Click(Sender: TObject);
begin
TCustomEdit(ActiveControl).CopyToClipboard;
end;
procedure TForm1.Paste1Click(Sender: TObject);
begin
if ActiveControl is TDBEdit then
with TDBEdit(ActiveControl).DataSource.DataSet do Edit;
TCustomEdit(ActiveControl).PasteFromClipboard;
if ActiveControl is TDBEdit then
with TDBEdit(ActiveControl).DataSource.DataSet do Post;
end;
]]>
Edit1 – меню редактирования верхнего уровня. Если по нему щелкают, то прежде чем меню «вывалится» вниз, необходимо проверить, принадлежит ли текущий активный элемент управления некоторым типам редактирования. Если это условие выполняется, активизируются пункты меню Вырезать и Копировать и, если есть текст в буфере обмена, то и пункт Вставить. Если нет, то все три пункта будут недоступны.
Для копирования содержимого элемента редактирования достаточно просто вызвать CopyToClipboard; это не проблема. Для вырезания и вставки необходимо «изменить» содержимое активного элемента редактирования – если это DBEdit, необходимо перейти в режим редактирования и после манипуляций с данными буфера обмена сохранить измененные данные.
Назад к части 3
При перепечатке любого материала
с сайта, видимая ссылка на источник www.warayg.narod.ru
и все имена, ссылки авторов обязательны.
© 2005
|
