I would like to show in a DBGRID as follows:
Imagine "Grid" as follows:
ID - DESCRIPTION
1 - Line 1 of the grid
2 - Line 2 of the grid
3 - Line 3 of the grid
Now, suppose the size of the DESCRIPTION column is changed and no longer appear the words "GRID";
I would like to stay as well DBGRID
ID - DESCRIPTION
1 - Line 1 of the
grid
2 - Line 2 of the
grid
3 - Line 3 of the
grid
is there any possibility that ??
Not what you're asking, but might help... I once used this code to show complete Memo fields in the standard DBGrid:
TMyForm = class(TForm)
...
private
FormMemoRect: TRect;
MemoGrid: TDBGrid;
BMemo: TBitBtn;
...
Procedure TMyForm.FormMemoDeactivate(Sender: TObject);
Begin
(Sender As TForm).Close;
Sender.Free;
End;
Procedure TMyForm.BMemoClick(Sender: TObject);
Var FormMemo: TForm;
Begin
MemoGrid.SetFocus;
FormMemo := TForm.Create(Self);
With TMemo.Create(FormMemo) Do Begin
Parent := FormMemo;
Align := alClient;
ReadOnly := True;
WordWrap := True;
ScrollBars := ssVertical;
Lines.Text := MemoGrid.DataSource.DataSet.Fields[TComponent(Sender).Tag].AsString;
End;
With FormMemo Do Begin
OnDeactivate := FormMemoDeactivate;
Left := FormMemoRect.Left;
Top := FormMemoRect.Top;
Width := Max(FormMemoRect.Right - FormMemoRect.Left, 300);
Height := FormMemoRect.Bottom - FormMemoRect.Top;
BorderStyle := bsNone;
Show;
End;
End;
Procedure TMyForm.GrdMemoDrawColumnCell(Sender: TObject; Const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState);
Begin
If (gdFocused In State) Then Begin
If Column.Field.DataType In [ftBlob, ftMemo] Then Begin
{Desenha botão para visualização do Memo}
FormMemoRect.Left := TWinControl(Sender).ClientToScreen(Rect.TopLeft).X;
FormMemoRect.Right := TWinControl(Sender).ClientToScreen(Rect.BottomRight).X;
FormMemoRect.Top := TWinControl(Sender).ClientToScreen(Rect.BottomRight).Y;
FormMemoRect.Bottom := FormMemoRect.Top + 100;
If Not Assigned(BMemo) Then
BMemo := TBitBtn.Create(Self);
BMemo.Parent := TWinControl(Sender).Parent;
BMemo.Width := 16;
BMemo.Height := 16;
BMemo.Caption := '...';
BMemo.OnClick := BMemoClick;
BMemo.Tag := Column.Field.Index;
BMemo.Left := TWinControl(Sender).Left + Rect.Right - BMemo.Width + 1;
BMemo.Top := TWinControl(Sender).Top + Rect.Top + 2;
MemoGrid := TDBGrid(Sender);
End
Else
FreeAndNil(BMemo);
End;
End;
For Blob/Memo Fields, you may also find it useful to do some custom GetText to show something directly in the Grid:
Procedure TMyForm.DataSetMemoGetText(Sender: TField; var Text: String; DisplayText: Boolean);
Begin
Text := Copy(Sender.AsString, 1, 50);
If Text <> Sender.AsString Then
Text := Text + '...';
End;
This is how the result looks like.
PS: Sorry for non-standard code style.
Related
I'd like to add DBLookupComboboxes to certain columns in a DBGrid. There is a nice article on About.com on how to do this here. The problem is that with a table having many columns, if you select from the DBLookupCombobox in one column and then try to scroll left, the combobox will move left too as shown in the included images. How can the About.com code can be changed to prevent this behavior? A web search showed two others complaining of the exact same problem with no solution. Note that I want to use a DBLookupCombobox to show a name but enter the id, so using a simple picklist will not do.
procedure TForm1.DBGrid1ColExit(Sender: TObject);
begin
if DBGrid1.SelectedField.FieldName = DBLookupComboBox1.DataField then
DBLookupComboBox1.Visible := False
end;
procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect;
DataCol: Integer; Column: TColumn; State: TGridDrawState);
begin
if (gdFocused in State) then
begin
if (Column.Field.FieldName = DBLookupComboBox1.DataField) then
with DBLookupComboBox1 do
begin
Left := Rect.Left + DBGrid1.Left + 2;
Top := Rect.Top + DBGrid1.Top + 2;
Width := Rect.Right - Rect.Left;
Width := Rect.Right - Rect.Left;
Height := Rect.Bottom - Rect.Top;
Visible := True;
end;
end
end;
procedure TForm1.DBGrid1KeyPress(Sender: TObject; var Key: Char);
begin
if (key = Chr(9)) then Exit;
if (DBGrid1.SelectedField.FieldName = DBLookupComboBox1.DataField) then
begin
DBLookupComboBox1.SetFocus;
SendMessage(DBLookupComboBox1.Handle, WM_Char, word(Key), 0);
end
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
with DBLookupComboBox1 do
begin
DataSource := DataSource1; // -> AdoTable1 -> DBGrid1
ListSource := DataSource2;
DataField := 'resource_id'; // from AdoTable1 - displayed in the DBGrid
KeyField := 'id';
ListField := 'resource_name; id';
Visible := False;
end;
DataSource2.DataSet := AdoQuery1;
AdoQuery1.Connection := AdoConnection1;
AdoQuery1.SQL.Text := 'SELECT id,resource_name FROM resources';
AdoQuery1.Open;
end;
Here is one solution using a neat hack from François.
type
// Hack to redeclare your TDBGrid here without the the form designer going mad
TDBGrid = class(DBGrids.TDBGrid)
procedure WMHScroll(var Msg: TWMHScroll); message WM_HSCROLL;
end;
TForm1 = class(TForm)
[...]
procedure TDBGrid.WMHScroll(var Msg: TWMHScroll);
begin
if Form1.DBGrid1.SelectedField.FieldName = Form1.DBLookupComboBox1.DataField then begin
case Msg.ScrollCode of
SB_LEFT,SB_LINELEFT,SB_PAGELEFT: begin
Form1.DBGrid1.SelectedIndex := Form1.DBGrid1.SelectedIndex-1;
Form1.DBLookupComboBox1.Visible := False;
end;
SB_RIGHT,SB_LINERIGHT,SB_PAGERIGHT: begin
Form1.DBGrid1.SelectedIndex := Form1.DBGrid1.SelectedIndex+1;
Form1.DBLookupComboBox1.Visible := False;
end;
end;
end;
inherited; // to keep the expected behavior
end;
i wanto dynamic add 5 TLable in my iOS app.
like this
Procedure Form1.FormCreate(Sender: TObject)
var
I: Integer;
begin
for I := 1 to 5 do
begin
with TLabel.Create(Self) do
begin
Parent := self;
Align := TAlignLayout.Top;
Height := 50;
Text := IntToStr(I);
end;
end;
end;
i think the order is 12345, but I get 15432.
What can I do to get the desired results?
You must give a chance to the aligning algorithm to do what you want.
procedure TForm1.FormCreate(Sender: TObject);
var
I: Integer;
begin
for I := 1 to 5 do
begin
with TLabel.Create(Self) do
begin
Parent := self;
Align := TAlignLayout.alTop;
Height := 50;
Position.Y := I*Height; //add this line
Text := IntToStr(I);
end;
end;
end;
In Delphi XE2 or XE3, How can I make a list box similar to Outlook 2013 list of emails ?
or is the list in Outlook 2013 something else ?
how can I achieve a similar one in Delphi XE2 or XE3 ?
Thanks
You can do something similar with a TListView and ListGroups. There's an example of using the ListGroups in the Delphi documentation (link for XE4, but works in XE2 and XE3 as well). It doesn't give you the image you're looking for, but it demonstrates using them, and you should be able to take it from there.
(Note the code below is not a direct copy/paste of the code from that link, as that code has errors and omissions. I've corrected, compiled, and run it first to fix those before posting it here.)
Drop a TListView and TImageList on a new VCL forms application. Change the name of the TImageList to DigitsLetters, and then add the following code to the form (create the FormCreate and FormDestroy in the Object Inspector as usual, and paste the code into the event handlers, and just add the declaration of GetImageFromAscii to the private section of the form declaration):
procedure TForm1.FormCreate(Sender: TObject);
var
Group: TListGroup;
ListItem: TListItem;
Image: TBitmap;
c: Char;
begin
{ align the list view to the form }
ListView1.Align := alClient;
{ center and stretch the form to fit the screen }
Self.Position := poScreenCenter;
Self.Height := 600;
Self.Width := 800;
{
change the view style of the list view
such that the icons are displayed
}
ListView1.ViewStyle := vsIcon;
{ enable group view }
ListView1.GroupView := True;
{ create a 32 by 32 image list }
DigitsLetters := TImageList.CreateSize(32, 32);
{
generate the DigitsLetters image list with the digits,
the small letters and the capital letters
}
GetImagesFromASCII('0', '9');
GetImagesFromASCII('a', 'z');
GetImagesFromASCII('A', 'Z');
{
add an empty image to the list
used to emphasize the top and bottom descriptions
of the digits group
}
Image := TBitmap.Create;
Image.Height := 32;
Image.Width := 32;
DigitsLetters.Add(Image, nil);
Image.Destroy;
{ create a title image for the small letters category }
Image := TBitmap.Create;
Image.Height := 32;
Image.Width := 32;
Image.Canvas.Brush.Color := clYellow;
Image.Canvas.FloodFill(0, 0, clYellow, fsBorder);
Image.Canvas.Font.Name := 'Times New Roman';
Image.Canvas.Font.Size := 14;
Image.Canvas.Font.Color := clRed;
Image.Canvas.TextOut(3, 5, 'a..z');
DigitsLetters.Add(Image, nil);
Image.Destroy;
{ create a title image for the capital letters category }
Image := TBitmap.Create;
Image.Height := 32;
Image.Width := 32;
Image.Canvas.Brush.Color := clYellow;
Image.Canvas.FloodFill(0, 0, clYellow, fsBorder);
Image.Canvas.Font.Name := 'Times New Roman';
Image.Canvas.Font.Size := 13;
Image.Canvas.Font.Color := clRed;
Image.Canvas.TextOut(2, 5, 'A..Z');
DigitsLetters.Add(Image, nil);
Image.Destroy;
{ associate the image list with the list view }
ListView1.LargeImages := DigitsLetters;
ListView1.GroupHeaderImages := DigitsLetters;
{ set up the digits group }
Group := ListView1.Groups.Add;
Group.State := [lgsNormal, lgsCollapsible];
Group.Header := 'Digits';
Group.HeaderAlign := taCenter;
Group.Footer := 'End of the Digits category';
Group.FooterAlign := taCenter;
Group.Subtitle := 'The digits from 0 to 9';
{
use the empty image as the title image
to emphasize the top and bottom descriptions
}
Group.TitleImage := DigitsLetters.Count - 3;
{ create the actual items in the digits group }
for c := '0' to '9' do
begin
// add a new item to the list view
ListItem := ListView1.Items.Add;
// ...customize it
ListItem.Caption := c + ' digit';
ListItem.ImageIndex := Ord(c) - Ord('0');
// ...and associate it with the digits group
ListItem.GroupID := Group.GroupID;
end;
{ set up the small letters group }
Group := ListView1.Groups.Add;
Group.State := [lgsNormal, lgsCollapsible];
Group.Header := 'Small Letters';
Group.HeaderAlign := taRightJustify;
Group.Footer := 'End of the Small Letters category';
Group.FooterAlign := taLeftJustify;
Group.Subtitle := 'The small letters from ''a'' to ''z''';
Group.TitleImage := DigitsLetters.Count - 2;
{ create the actual items in the small letters group }
for c := 'a' to 'z' do
begin
// add a new item to the list view
ListItem := ListView1.Items.Add;
// ...customize it
ListItem.Caption := 'letter ' + c;
ListItem.ImageIndex := Ord(c) - Ord('a') + 10;
// ...and associate it with the small letters group
ListItem.GroupID := Group.GroupID;
end;
{
to see how the NextGroupID property can be used,
the following lines of code show how an item can be associated
with a group ID, prior to creating the group
}
{ create the actual items in the capital letters group }
for c := 'A' to 'Z' do
begin
// add a new item to the list view
ListItem := ListView1.Items.Add;
// ...customize it
ListItem.Caption := 'letter ' + c;
ListItem.ImageIndex := Ord(c) - Ord('A') + 36;
// ...and associate it with the capital letters group
ListItem.GroupID := ListView1.Groups.NextGroupID;
end;
{ set up the capital letters group }
Group := ListView1.Groups.Add;
Group.State := [lgsNormal, lgsCollapsible];
Group.Header := 'Capital Letters';
Group.HeaderAlign := taRightJustify;
Group.Footer := 'End of the Capital Letters category';
Group.FooterAlign := taLeftJustify;
Group.Subtitle := 'The capital letters from ''A'' to ''Z''';
Group.TitleImage := DigitsLetters.Count - 1;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
{ remove the image list from memory }
DigitsLetters.Destroy;
end;
{
Generates a series of images for the characters
starting with ASCII code First and ending with Last.
All images are added to the DigitsLetters variable.
}
procedure TForm1.GetImagesFromASCII(First, Last: Char);
var
Image: TBitmap;
c: Char;
begin
for c := First to Last do
begin
Image := TBitmap.Create;
Image.Height := 32;
Image.Width := 32;
Image.Canvas.Font.Name := 'Times New Roman';
Image.Canvas.Font.Size := 22;
Image.Canvas.TextOut((Image.Width - Image.Canvas.TextWidth(c)) div 2, 0, c);
DigitsLetters.Add(Image, nil);
Image.Destroy;
end;
end;
Results (shown with the Digits and Small Letters groups collapsed):
The control in Outlook is not a standard list box. In Outlook 2010, it's a window with class "SUPERGRID," and I imagine Outlook 2013 is similar.
You can do as the Outlook developers did and write your own control, but that might be a bigger project than you're really interested in. A simpler task is to instead use an ordinary TListBox and handle its OnDrawItem event. If you want items to have variable heights, then you can also handle the OnMeasureItem event.
If you want your control to include expandable and collapsible groups of items, then you might want to start with a tree control instead. TTreeView can be custom-drawn, too. For more customizability, you could try TVirtualStringTree.
I found this code which is the Best to do the work I need :)
It's a perfect looking to the image above.
unit Unit1;
interface
uses
Contnrs,
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ImgList, ComCtrls;
type
TGroupItem = class
private
fItems : TObjectList;
fCaption: string;
fListItem: TListItem;
fExpanded: boolean;
function GetItems: TObjectList;
public
constructor Create(const caption : string; const numberOfSubItems : integer);
destructor Destroy; override;
procedure Expand;
procedure Collapse;
property Expanded : boolean read fExpanded;
property Caption : string read fCaption;
property Items : TObjectList read GetItems;
property ListItem : TListItem read fListItem write fListItem;
end;
TItem = class
private
fTitle: string;
fValue: string;
public
constructor Create(const title, value : string);
property Title: string read fTitle;
property Value : string read fValue;
end;
TForm1 = class(TForm)
lvGroups: TListView;
listViewImages: TImageList;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure lvGroupsAdvancedCustomDrawItem(Sender: TCustomListView;
Item: TListItem; State: TCustomDrawState; Stage: TCustomDrawStage;
var DefaultDraw: Boolean);
procedure lvGroupsDblClick(Sender: TObject);
private
procedure ClearListViewGroups;
procedure FillListViewGroups;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.ClearListViewGroups;
var
li : TListItem;
qng : TGroupItem;
begin
for li in lvGroups.Items do
begin
if TObject(li.Data) is TGroupItem then
begin
qng := TGroupItem(li.Data);
FreeAndNil(qng);
end;
end;
lvGroups.Clear;
end;
procedure TForm1.FillListViewGroups;
procedure AddGroupItem(gi : TGroupItem);
var
li : TListItem;
begin
li := lvGroups.Items.Add;
li.Caption := gi.Caption;
li.ImageIndex := 1; //collapsed
li.Data := gi;
gi.ListItem := li; //link "back"
end;
begin
ClearListViewGroups;
AddGroupItem(TGroupItem.Create('Group A', 3));
AddGroupItem(TGroupItem.Create('Group B', 1));
AddGroupItem(TGroupItem.Create('Group C', 4));
AddGroupItem(TGroupItem.Create('Group D', 5));
AddGroupItem(TGroupItem.Create('Group D', 5));
AddGroupItem(TGroupItem.Create('Group D', 5));
AddGroupItem(TGroupItem.Create('Group D', 5));
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
FillListViewGroups;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
ClearListViewGroups;
end;
procedure TForm1.lvGroupsAdvancedCustomDrawItem(Sender: TCustomListView;
Item: TListItem; State: TCustomDrawState; Stage: TCustomDrawStage;
var DefaultDraw: Boolean);
begin
//bold group items
if TObject(item.Data) is TGroupItem then
begin
lvGroups.Canvas.Font.Style := lvGroups.Canvas.Font.Style + [fsBold];
end;
end;
//handles TListView OnDblClick even
procedure TForm1.lvGroupsDblClick(Sender: TObject);
var
hts : THitTests;
gi : TGroupItem;
begin
inherited;
hts := lvGroups.GetHitTestInfoAt(lvGroups.ScreenToClient(Mouse.CursorPos).X, lvGroups.ScreenToClient(Mouse.CursorPos).y);
if (lvGroups.Selected <> nil) then
begin
if TObject(lvGroups.Selected.Data) is (TGroupItem) then
begin
gi := TGroupItem(lvGroups.Selected.Data);
if NOT gi.Expanded then
gi.Expand
else
gi.Collapse;
end;
end;
end;
{$region 'TGroupItem'}
procedure TGroupItem.Collapse;
var
li : TListItem;
begin
if NOT Expanded then Exit;
ListItem.ImageIndex := 1;
fExpanded := false;
li := TListView(ListItem.ListView).Items[ListItem.Index + 1];
while (li <> nil) AND (TObject(li.Data) is TItem) do
begin
TListView(ListItem.ListView).Items.Delete(li.Index);
li := TListView(ListItem.ListView).Items[ListItem.Index + 1];
end;
end;
constructor TGroupItem.Create(const caption: string; const numberOfSubItems : integer);
var
cnt : integer;
begin
fCaption := caption;
for cnt := 1 to numberOfSubItems do
begin
Items.Add(TItem.Create(caption + ' item ' + IntToStr(cnt), IntToStr(cnt)));
end;
end;
destructor TGroupItem.Destroy;
begin
FreeAndNil(fItems);
inherited;
end;
procedure TGroupItem.Expand;
var
cnt : integer;
item : TItem;
begin
if Expanded then Exit;
ListItem.ImageIndex := 0;
fExpanded := true;
for cnt := 0 to -1 + Items.Count do
begin
item := TItem(Items[cnt]);
with TListView(ListItem.ListView).Items.Insert(1 + cnt + ListItem.Index) do
begin
Caption := item.Title;
SubItems.Add(item.Value);
Data := item;
ImageIndex := -1;
end;
end;
end;
function TGroupItem.GetItems: TObjectList;
begin
if fItems = nil then fItems := TObjectList.Create(true);
result := fItems;
end;
{$endregion}
{$region 'TItem' }
constructor TItem.Create(const title, value: string);
begin
fTitle := title;
fValue := value;
end;
{$endregion}
end.
I've wrote a TDBGrid descendant component which is displaying the content of different blob fields for the current row selected, each one in a TJvDBRichEdit. The DrawColumnCell code for displaying the content of the blob fields:
procedure TMyDBGrid.DrawColumnCell(const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState);
var iPos,iNr,iTop:Integer;
begin
// RBA 01/04/2013 12:10
if not (csDesigning in ComponentState) then
if FDisplayBlobAsRTF then //property to show the blob fields or not
begin
if (gdSelected in State) then
begin
if Column.Field.isblob then
begin
ipos := 0;
iNr := 0;
while (iPos <= Column.Field.DataSet.FieldCount-1)and(Column.Field.DataSet.Fields[ipos].FieldName <> Column.Field.FieldName ) do
begin
if Column.Field.DataSet.Fields[ipos].IsBlob then
inc(iNr);
inc(iPos);
end;
with TJvDBRichEdit(FRichEditList[inr]) do//FRichEditList - TObjectList which contains all the TJvDBRichEdit components, and release them on destroy
begin
Left := Rect.Left + Self.Left + 1;
iTop := Rect.Top + Self.Top + 1;
if iTop + Height > Self.Height then
iTop := iTop - Height;
Top := iTop;
Width := Rect.BottomRight.X - Rect.left;
Visible := true;
end;
end;
end
end;
inherited;
end;
overrided LayoutChanged routine
procedure TMyDBGrid.LayoutChanged;
var iPos : Integer;
dtDataset : TDataSet;
jvDbRichEdit : TJvDBRichEdit;
begin
if not (csDesigning in ComponentState) then
if FDisplayBlobAsRTF then
begin
dtDataset := GetDataset;//get the dataset assigned to the grid
if dtDataset <> nil then
if dtDataset.State <> dsInactive then
begin
FRichEditList.Clear;
for iPos := 0 to dtDataset.FieldCount-1 do
if dtDataset.Fields[iPos].IsBlob then
begin
jvDbRichEdit := TJvDBRichEdit.Create(nil);
jvDbRichEdit.Parent := Self;
jvDbRichEdit.DataSource := Self.DataSource;
jvDbRichEdit.DataField := dtDataset.Fields[iPos].FieldName;
jvDbRichEdit.Visible := false;
FRichEditList.Add(jvDbRichEdit);
end;
end;
end;
end;
the problem appears when I make a scroll on the last displayed grid row :
How can I redraw the grid behind? I've tried with repainting the hole grid, but it is flickering.
LE: this is not intended to modify the content in the richedtis, only to display them.
I am trying to display a table using ShowMessage that looks like this:
short | Description for "short"
verylongtext | Description for "verylongtext"
How do I get two correctly aligned columns like that in a simple message dialog?
I tried to align the columns using spaces, but the font of ShowMessage is variable. Then I tried to align them using tab characters, but I do not know how to calculate the proper tab count for each row.
Is there a reliable way to calculate the tab count?
PS: I would like to avoid writing a custom dialog for this purpose.
You could use a list view in a custom dialog box, as well.
My class supports the standard Windows icons (and sounds): information, warning, error, confirmation, none. Here is the icon-less version:
It is easy to use:
TTableDialog.ShowTable
(
Self,
'Audio Properties',
['Duration', 'Samples per channel', 'Total data size', 'Channels', 'Bits per sample', 'Sample rate', 'Bitrate'],
['1 h 15 min 0 s', '216 000 000', '824 MB', '1', '32', '48 kHz', '1 536 kbit/sec'],
mtInformation
)
It supports DPI scaling (high DPI) and all Windows versions from Windows XP (it might work on Windows 2000 as well, I just haven't tested that) to Windows 10:
The table is a list view, so you get all its benefits, like a scrollbar, truncation ellipses, and tooltips:
You can also specify the dialog's size to make it fit the contents:
TTableDialog.ShowTable
(
Self,
'Audio Properties',
['Duration', 'Samples per channel', 'Total data size', 'Channels', 'Bits per sample', 'Sample rate', 'Bitrate', 'Maximum fractional sample value'],
['1 h 15 min 0 s', '216 000 000', '824 MB', '1', '32', '48 kHz', '1 536 kbit/sec', '0.1'],
mtInformation,
360,
240
)
Of course, the OK button is both Default and Cancel, so you can dismiss the dialog with Enter or Escape.
Finally, pressing Ctrl+C will copy the table to clipboard.
Full source code:
uses
ComCtrls, Math, Clipbrd;
type
TTableDialog = class
strict private
type TFormData = class(TComponent)
public
ListView: TListView;
IconKind: PWideChar;
Icon: HICON;
LIWSD: Boolean;
end;
class function Scale(X: Integer): Integer;
class procedure FormShow(Sender: TObject);
class procedure FormDestroy(Sender: TObject);
class procedure FormPaint(Sender: TObject);
class procedure FormKeyPress(Sender: TObject; var Key: Char);
class procedure LVToClipboard(AListView: TListView);
public
class procedure ShowTable(AOwner: TCustomForm; const ACaption: string;
const ANames, AValues: array of string;
ADialogType: TMsgDlgType = mtInformation;
const AWidth: Integer = 360; const AHeight: Integer = 200);
end;
class procedure TTableDialog.FormShow(Sender: TObject);
var
FormData: TFormData;
ComCtl: HMODULE;
LoadIconWithScaleDown: function(hinst: HINST; pszName: LPCWSTR; cx: Integer;
cy: Integer; var phico: HICON): HResult; stdcall;
begin
if not (Sender is TForm) then
Exit;
if not (TObject(TForm(Sender).Tag) is TFormData) then
Exit;
TForm(Sender).OnShow := nil;
FormData := TFormData(TForm(Sender).Tag);
if FormData.IconKind = nil then
Exit;
ComCtl := LoadLibrary('ComCtl32.dll');
if ComCtl <> 0 then
begin
try
LoadIconWithScaleDown := GetProcAddress(ComCtl, 'LoadIconWithScaleDown');
if Assigned(LoadIconWithScaleDown) then
FormData.LIWSD := Succeeded(LoadIconWithScaleDown(0, FormData.IconKind,
Scale(32), Scale(32), FormData.Icon));
finally
FreeLibrary(ComCtl);
end;
end;
if not FormData.LIWSD then
FormData.Icon := LoadIcon(0, FormData.IconKind);
end;
class procedure TTableDialog.FormDestroy(Sender: TObject);
var
FormData: TFormData;
begin
if not (Sender is TForm) then
Exit;
if not (TObject(TForm(Sender).Tag) is TFormData) then
Exit;
FormData := TFormData(TForm(Sender).Tag);
if (FormData.Icon <> 0) and FormData.LIWSD then
DestroyIcon(FormData.Icon);
end;
class procedure TTableDialog.FormKeyPress(Sender: TObject; var Key: Char);
var
FormData: TFormData;
begin
if not (Sender is TForm) then
Exit;
if not (TObject(TForm(Sender).Tag) is TFormData) then
Exit;
FormData := TFormData(TForm(Sender).Tag);
case Key of
^C:
LVToClipboard(FormData.ListView);
end;
end;
class procedure TTableDialog.FormPaint(Sender: TObject);
var
FormData: TFormData;
Frm: TForm;
Y: Integer;
begin
if not (Sender is TForm) then
Exit;
if not (TObject(TForm(Sender).Tag) is TFormData) then
Exit;
Frm := TForm(Sender);
FormData := TFormData(TForm(Sender).Tag);
Y := Frm.ClientHeight - Scale(25 + 8 + 8);
Frm.Canvas.Brush.Color := clWhite;
Frm.Canvas.FillRect(Rect(0, 0, Frm.ClientWidth, Y));
Frm.Canvas.Pen.Color := $00DFDFDF;
Frm.Canvas.MoveTo(0, Y);
Frm.Canvas.LineTo(Frm.ClientWidth, Y);
if FormData.Icon <> 0 then
DrawIconEx(Frm.Canvas.Handle, Scale(8), Scale(8), FormData.Icon,
Scale(32), Scale(32), 0, 0, DI_NORMAL);
end;
class procedure TTableDialog.LVToClipboard(AListView: TListView);
function GetRow(AIndex: Integer): string;
begin
if InRange(AIndex, 0, AListView.Items.Count - 1) and (AListView.Items[AIndex].SubItems.Count = 1) then
Result := AListView.Items[AIndex].Caption + #9 + AListView.Items[AIndex].SubItems[0]
else
Result := '';
end;
var
S: string;
i: Integer;
begin
if AListView = nil then
Exit;
S := GetRow(0);
for i := 1 to AListView.Items.Count - 1 do
S := S + sLineBreak + GetRow(i);
Clipboard.AsText := S;
end;
class function TTableDialog.Scale(X: Integer): Integer;
begin
Result := MulDiv(X, Screen.PixelsPerInch, 96);
end;
class procedure TTableDialog.ShowTable(AOwner: TCustomForm; const ACaption: string;
const ANames, AValues: array of string;
ADialogType: TMsgDlgType = mtInformation;
const AWidth: Integer = 360; const AHeight: Integer = 200);
const
Sounds: array[TMsgDlgType] of Integer =
(MB_ICONWARNING, MB_ICONERROR, MB_ICONINFORMATION, MB_ICONQUESTION, 0);
Icons: array[TMsgDlgType] of MakeIntResource =
(IDI_WARNING, IDI_ERROR, IDI_INFORMATION, IDI_QUESTION, nil);
var
dlg: TForm;
lv: TListView;
btn: TButton;
i: Integer;
snd: Integer;
begin
if Length(ANames) <> Length(AValues) then
raise Exception.Create('The lengths of the columns don''t match.');
dlg := TForm.Create(AOwner);
try
dlg.BorderStyle := bsDialog;
dlg.Caption := ACaption;
dlg.Width := Scale(AWidth);
dlg.Height := Scale(AHeight);
dlg.Position := poOwnerFormCenter;
dlg.Scaled := False;
dlg.Font.Name := 'Segoe UI';
dlg.Font.Size := 9;
dlg.Tag := NativeInt(TFormData.Create(dlg));
TFormData(dlg.Tag).IconKind := Icons[ADialogType];
dlg.OnShow := FormShow;
dlg.OnDestroy := FormDestroy;
dlg.OnPaint := FormPaint;
dlg.OnKeyPress := FormKeyPress;
dlg.KeyPreview := True;
btn := TButton.Create(dlg);
btn.Parent := dlg;
btn.Caption := 'OK';
btn.Default := True;
btn.Cancel := True;
btn.ModalResult := mrOk;
btn.Width:= Scale(75);
btn.Height := Scale(25);
btn.Left := dlg.ClientWidth - btn.Width - Scale(8);
btn.Top := dlg.ClientHeight - btn.Height - Scale(8);
lv := TListView.Create(dlg);
TFormData(dlg.Tag).ListView := lv;
lv.Parent := dlg;
lv.DoubleBuffered := True;
lv.ReadOnly := True;
lv.BorderStyle := bsNone;
lv.Left := Scale(8) + IfThen(Icons[ADialogType] <> nil, Scale(32 + 8));
lv.Top := Scale(8);
lv.Width := dlg.ClientWidth - Scale(16) - IfThen(Icons[ADialogType] <> nil, Scale(32 + 8));
lv.Height := dlg.ClientHeight - Scale(16 + 8 + 4) - btn.Height;
lv.ViewStyle := vsReport;
lv.RowSelect := True;
lv.ShowColumnHeaders := False;
with lv.Columns.Add do
begin
Caption := 'Name';
Width := Scale(150);
end;
with lv.Columns.Add do
begin
Caption := 'Value';
Width := lv.ClientWidth - lv.Columns[0].Width -
GetSystemMetricsForWindow(SM_CXVSCROLL, dlg.Handle) - scale(2);
end;
for i := 0 to High(ANames) do
with lv.Items.Add do
begin
Caption := ANames[i];
SubItems.Add(AValues[i]);
end;
snd := Sounds[ADialogType];
if snd <> 0 then
MessageBeep(snd);
dlg.ShowModal;
finally
dlg.Free;
end;
end;
If you're not writing a custom dialog for this, when will you? It's not that hard. Just create a form, drop a TMemo on it and make that memo readonly. You can set a monospaced font like Courier New, and your problem is solved. You got the advantage of scrollbars and selection too, and you can choose to make it non-modal.
I would even recommend showing this type of data in a grid (like TStringGrid) instead of a memo or label.
Calculating how to display this text in a messagebox will require much more effort than just creating a custom dialog.
Just created something that shows a popup like this:
Just call the procedure below, and add a TStringList as a parameter.
Of course you could pimp this by using a TListView, icons, scrollbars, etc.
Put it in a separate unit, and you'll always be able to easily show stuff like this.
uses ..., StdCtrls, ExtCtrls;
procedure ShowTablePopup(SL:TStringList);
var
LButtonOK: TButton;
LMemo: TMemo;
LPanel: TPanel;
LForm: TForm;
begin
LForm := TForm.Create(Application);
LMemo := TMemo.Create(LForm);
LPanel := TPanel.Create(LForm);
LButtonOK := TButton.Create(LForm);
LForm.Left := 0;
LForm.Top := 0;
LForm.Caption := 'Values';
LForm.ClientHeight := 250;
LForm.ClientWidth := 400;
LMemo.Parent := LForm;
LMemo.AlignWithMargins := True;
LMemo.Left := 3;
LMemo.Top := 3;
LMemo.Width := 295;
LMemo.Height := 226;
LMemo.Align := alClient;
LMemo.Font.Name := 'Courier New';
LMemo.Lines.Assign(SL);
LPanel.Parent := LForm;
LPanel.Caption := '';
LPanel.Left := 0;
LPanel.Top := 232;
LPanel.Width := 301;
LPanel.Height := 37;
LPanel.Align := alBottom;
LPanel.BevelOuter := bvNone;
LButtonOK.Parent := LPanel;
LButtonOK.AlignWithMargins := True;
LButtonOK.Left := 223;
LButtonOK.Top := 3;
LButtonOK.Width := 75;
LButtonOK.Height := 31;
LButtonOK.Align := alRight;
LButtonOK.Caption := '&OK';
LButtonOK.ModalResult := mrOk;
LButtonOK.Default := True;
LForm.ShowModal;
end;
Example on how to use it:
var
SL:TStringList;
begin
SL := TStringList.Create;
try
SL.Add('short | Description for "short"');
SL.Add('verylongtext | Description for "verylongtext"');
ShowTablePopup(SL);
finally
SL.Free;
end;
end;