I found this code over the net. This puts background color to the selected texts on Trichedit:
uses
RichEdit;
procedure RE_SetSelBgColor(RichEdit: TRichEdit; AColor: TColor);
var
Format: CHARFORMAT2;
begin
FillChar(Format, SizeOf(Format), 0);
with Format do
begin
cbSize := SizeOf(Format);
dwMask := CFM_BACKCOLOR;
crBackColor := AColor;
Richedit.Perform(EM_SETCHARFORMAT, SCF_SELECTION, Longint(#Format));
end;
end;
// Example: Set clYellow background color for the selected text.
procedure TForm1.Button1Click(Sender: TObject);
begin
RE_SetSelBgColor(RichEdit1, clYellow);
end;
However, what I need is to exclude space characters. Can someone help me? Any idea would be helpful?
My idea would be to select all space characters and then format it but then I don't know how to select them.
By the way, I am using delphi 2009.
#junmats, with this code you can select any word in a richedit control.
tested in Delphi 2010 and windows 7
uses
RichEdit;
procedure SetWordBackGroundColor(RichEdit : TRichEdit; aWord : String;AColor: TColor);
var
Format: CHARFORMAT2;
Index : Integer;
Len : Integer;
begin
FillChar(Format, SizeOf(Format), 0);
Format.cbSize := SizeOf(Format);
Format.dwMask := CFM_BACKCOLOR;
Format.crBackColor := AColor;
Index := 0;
Len := Length(RichEdit.Lines.Text) ;
Index := RichEdit.FindText(aWord, Index, Len, []);
while Index <> -1 do
begin
RichEdit.SelStart := Index;
RichEdit.SelLength := Length(aWord) ;
RichEdit.Perform(EM_SETCHARFORMAT, SCF_SELECTION, Longint(#Format));
Index := RichEdit.FindText(aWord,Index + Length(aWord),Len, []) ;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
SetWordBackGroundColor(RichEdit1,' ',clYellow);// will mark all spaces
end;
if you wanna select all words except the spaces, you can do something like this
Procedure GetListofWords(Text : String; var ListofWords : TStringList);
var
DummyStr : String;
FoundWord : String;
begin
DummyStr := Text;
FoundWord := '';
if (Length(Text) = 0) then exit;
while (Pos(' ', DummyStr) > 0) do
begin
FoundWord := Copy(DummyStr, 1, Pos(' ', DummyStr) - 1);
ListofWords.Add(FoundWord);
DummyStr := Copy(DummyStr, Pos(' ', DummyStr) + 1, Length(DummyStr) - Length(FoundWord) + 1);
end;
if (Length(DummyStr) > 0) then
ListofWords.Add(DummyStr);
end;
procedure TForm1.Button1Click(Sender: TObject);
var
ListofWords : TStringList;
i : integer;
begin
ListofWords:=TStringList.Create;
try
GetListofWords(RichEdit1.Lines.Text,ListofWords);
if ListofWords.Count>0 then
for i:=0 to ListofWords.Count - 1 do
SetWordBackGroundColor(RichEdit1,ListofWords[i],clYellow);
finally
ListofWords.Clear;
ListofWords.Free;
end;
end;
Related
I am looking at contributing to the Delphi SynEdit project with a syntax-highlighter for the Health Level 7 (HL7) v2 messaging Standard. I have no experience of creating a highlighter from scratch and there are two quirks that I have stumbled upon that differ from existing highlighters:
Fixed position keywords - first three characters of every line
Delimiters are defined in the begining of the message
Is there anyone out there who has any SynEdit experice with HL7 or similar syntaxes e.g. Edifact, X12?
Prototype
I've created a crude prototype using the OnPaintTransient event-handler which in fact works better than I anticipated :-) Basically it does the following:
Highlight each Segment ID navy-blue - first three characters on ever line. No checking done if the value is a valid segment.
Highlight all field delimiters grey - defined as the fourth character in MSH segment
Highlight all other delimiters blue - defined in the field called
Encoding Characters, which is the first field after the MSH segment ID.
The delimiter values used in the MSH segment are the delimiter values used throughout the entire message.
skip highlighting if underlying text is selected - looks prettier in my implementation.
Below is a screen-dump of the results when inserting the example message found at Wikipedia http://en.wikipedia.org/wiki/Health_Level_7 into a TSynMemo component.
Code OnPaintTransient
procedure TFormMain.SynMemoMsgPaintTransient(Sender: TObject; Canvas: TCanvas;
TransientType: TTransientType);
var
i, j: Integer;
DP: TDisplayCoord;
SelStartCoord, SelEndCoord, BC : TBufferCoord;
Pt: TPoint;
FieldDelimiter : char; // MSH|
Delimiters : string; // All message delimiters (including field delimiter)
IsSelected : boolean;
begin
//Avoid drawing twice - Only enter if TransientType = ttAfter.
if TransientType = ttBefore then exit;
//Exit if no text
if SynMemoMsg.Lines.Count = 0 then exit;
//Exit if message does not start with MSH (Message header segment)
if not AnsiStartsText('MSH', SynMemoMsg.Lines[0]) then exit;
//Get the message's delimiters specified as the characters directly after MSH
FieldDelimiter := Copy(SynMemoMsg.Lines[0], 4, 1)[1];
Delimiters := Copy(SynMemoMsg.Lines[0], 4, 5);
//Find out if any text is selected by the user - we will exclude this text from highlighting
SelStartCoord := SynMemoMsg.CharIndexToRowCol(SynMemoMsg.SelStart);
SelEndCoord := SynMemoMsg.CharIndexToRowCol(SynMemoMsg.SelEnd);
//parse evry visible line
for i := SynMemoMsg.TopLine to ((SynMemoMsg.TopLine + SynMemoMsg.LinesInWindow )-1) do
begin
//Highlight Segment ID, i.e. in this implementation the first 3 chars in each line
BC.Char := 1;
BC.Line := i;
//If whole line is selected then continue to next line without highlighting current
if (SelStartCoord.Line < BC.Line) and (SelEndCoord.Line > BC.Line) then continue;
DP := SynMemoMsg.BufferToDisplayPos(BC);
Pt := SynMemoMsg.RowColumnToPixels(DP);
if ((SelStartCoord.Line = BC.Line) and (SelStartCoord.Char > 3))
or ((SelStartCoord.Line <> BC.Line) and (SelEndCoord.Line <> BC.Line))
or (SynMemoMsg.SelLength = 0) then
begin
Canvas.Font.Color := clNavy;
Canvas.Font.Style := [fsBold];
Canvas.TextOut (Pt.X - 1, Pt.Y, Copy(SynMemoMsg.Lines[i - 1], 1, 3)); //Move the Bold text one pixel left to get space i.e. Pt.X - 1)
end;
//Highlight Delimiters - parse each charachter and check if delimiter and not selected
for j := 4 to Length(SynMemoMsg.Lines[i - 1]) do
begin
if IsDelimiter(Delimiters, SynMemoMsg.Lines[i - 1], j) then
begin
BC.Char := j;
BC.Line := i;
//Don't highlight delimiter if selected
if (SynMemoMsg.SelLength > 0) and ((SelStartCoord.Line = BC.Line)or (SelEndCoord.Line = BC.Line)) then
begin
if (SelStartCoord.Line = BC.Line) and (SelEndCoord.Line = BC.Line) then
IsSelected := (SelStartCoord.Char <= BC.Char) and (SelEndCoord.Char > BC.Char)
else if (SelStartCoord.Line = BC.Line) then
IsSelected := SelStartCoord.Char <= BC.Char
else if (SelEndCoord.Line = BC.Line) then
IsSelected := SelEndCoord.Char > BC.Char;
end
else
IsSelected := false;
if not IsSelected then begin
DP := SynMemoMsg.BufferToDisplayPos(BC);
Pt := SynMemoMsg.RowColumnToPixels(DP);
if FieldDelimiter = SynMemoMsg.Lines[i - 1][j] then
Canvas.Font.Color := clGray
else
Canvas.Font.Color := clBlue;
Canvas.TextOut (Pt.X, Pt.Y, Copy(SynMemoMsg.Lines[i - 1], j, 1));
end;
end;
end;
end;
end;
Well I ended up making my own SynEdit syntax-highlighter for HL7 v2.x messaging.
It may not have all the bells and whistles but it’s a good start. My implementation uses Delphi XE3.
Usage:
Copy the SynHighlighterHL7.pas unit found below to your synedit project source folder.
Add SynHighlighterHL7.pas to your project and to the Uses clause.
Add a TSynEdit or TSynMemo component to a form
Add the following code to the form's OnCreate event handler:
Code:
fSynHL7Syn := TSynHL7Syn.Create(Self);
SynMemoMsg.Highlighter := fSynHL7Syn;
SynHighlighterHL7.pas unit:
unit SynHighlighterHL7;
{$I SynEdit.inc}
interface
uses
Classes,
Graphics,
StrUtils,
SynEditTypes,
SynEditHighlighter,
SynUnicode;
const
DEF_FIELD_DELIM = '|'; //Filed seperator
DEF_COMP_DELIM = '^'; //Component seperator
DEF_SUBCOMP_DELIM = '&'; //Sub-component seperator
DEF_ESC_DELIM = '\'; //Escape seperator
DEF_REP_DELIM = '~'; //Repetition seperator
type
TtkTokenKind = (tkSegmentID, tkFieldDelim, tkCompDelim, tkSubCompDelim,
tkEscDelim, tkRepDelim, tkText, tkSpace, tkNull, tkUnknown);
//Keeps track if we're in a message with properly defined delimiters
TRangeState = (rsUnknown, rsMshDelim, rsDefDelim);
type
TSynHL7Syn = class(TSynCustomHighlighter)
private
fRange : TRangeState;
fFieldDelim : char;
fCompDelim : char;
fSubCompDelim : char;
fEscDelim : char;
fRepDelim : char;
FTokenID: TtkTokenKind;
fSegmentIDAttri: TSynHighlighterAttributes;
fFieldDelimAttri: TSynHighlighterAttributes;
fCompDelimAttri: TSynHighlighterAttributes;
fSubCompDelimAttri: TSynHighlighterAttributes;
fEscDelimAttri: TSynHighlighterAttributes;
fRepDelimAttri: TSynHighlighterAttributes;
fUnknownAttri: TSynHighlighterAttributes;
fSpaceAttri : TSynHighlighterAttributes;
fTextAttri: TSynHighlighterAttributes;
procedure SegmentIDProc;
procedure UnknownProc;
procedure CRProc;
procedure TextProc;
procedure LFProc;
procedure NullProc;
procedure SpaceProc;
procedure FieldDelimProc;
procedure CompDelimProc;
procedure EscDelimProc;
procedure RepDelimProc;
procedure SubCompDelimProc;
procedure SetRangeState(const Line: string);
protected
function GetSampleSource: UnicodeString; override;
function IsFilterStored: Boolean; override;
public
function GetRange: Pointer; override;
procedure ResetRange; override;
procedure SetRange(Value: Pointer); override;
class function GetLanguageName: string; override;
class function GetFriendlyLanguageName: UnicodeString; override;
public
constructor Create(AOwner: TComponent); override;
function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;
override;
function GetEol: Boolean; override;
function GetTokenID: TtkTokenKind;
function GetTokenAttribute: TSynHighlighterAttributes; override;
function GetTokenKind: integer; override;
procedure Next; override;
published
property SegmentIDAttri: TSynHighlighterAttributes read fSegmentIDAttri
write fSegmentIDAttri;
property TextAttri: TSynHighlighterAttributes read fTextAttri
write fTextAttri;
end;
implementation
uses
SynEditStrConst;
constructor TSynHL7Syn.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
fCaseSensitive := true;
fSegmentIDAttri := TSynHighlighterAttributes.Create('Seg ID', 'Segment ID');
fSegmentIDAttri.Style := [fsBold];
fSegmentIDAttri.Foreground := clNavy;
AddAttribute(fSegmentIDAttri);
fFieldDelimAttri := TSynHighlighterAttributes.Create('Field Sep', 'Field Seperator (|)');
fFieldDelimAttri.Foreground := clGray;
AddAttribute(fFieldDelimAttri);
fCompDelimAttri := TSynHighlighterAttributes.Create('Comp Sep', 'Component Seperator (^)');
fCompDelimAttri.Foreground := clBlue;
AddAttribute(fCompDelimAttri);
fSubCompDelimAttri := TSynHighlighterAttributes.Create('Sub-Comp Sep', 'Sub-Component Seperator (&)');
fSubCompDelimAttri.Foreground := clBlue;
AddAttribute(fSubCompDelimAttri);
fRepDelimAttri := TSynHighlighterAttributes.Create('Rep Sep', 'Repeat Seperator (&)');
fRepDelimAttri.Foreground := clBlue;
AddAttribute(fRepDelimAttri);
fEscDelimAttri := TSynHighlighterAttributes.Create('Esc Sep', 'Escape Seperator (\)');
fEscDelimAttri.Style := [fsBold];
fEscDelimAttri.Foreground := clGreen;
AddAttribute(fEscDelimAttri);
fUnknownAttri := TSynHighlighterAttributes.Create('Unknown', 'Non HL7 message i.e arbitary text');
fUnknownAttri.Style := [fsItalic];
fUnknownAttri.Foreground := clRed;
AddAttribute(fUnknownAttri);
fTextAttri := TSynHighlighterAttributes.Create(SYNS_AttrText, SYNS_FriendlyAttrText);
AddAttribute(fTextAttri);
fSpaceAttri := TSynHighlighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);
AddAttribute(fSpaceAttri);
SetAttributesOnChange(DefHighlightChange);
fDefaultFilter := SYNS_FilterINI;
end; { Create }
procedure TSynHL7Syn.FieldDelimProc;
begin
inc(Run);
fTokenID := tkFieldDelim;
end;
procedure TSynHL7Syn.CompDelimProc;
begin
inc(Run);
fTokenID := tkCompDelim;
end;
procedure TSynHL7Syn.SubCompDelimProc;
begin
inc(Run);
fTokenID := tkSubCompDelim;
end;
procedure TSynHL7Syn.EscDelimProc;
begin
fTokenID := tkEscDelim;
//If current position is not the first MSH field then expand token untill
//closing Escape delimiter is found on current line
if not((Run = 6) and StartsStr('MSH', fLine)) then begin
inc(run);
while (FLine[Run] <> fEscDelim) and (FLine[Run] <> #0) do
inc(Run);
end;
if FLine[Run] <> #0 then
inc(Run);
end;
procedure TSynHL7Syn.RepDelimProc;
begin
inc(Run);
fTokenID := tkRepDelim;
end;
procedure TSynHL7Syn.SetRangeState(const Line : string);
function IsValidSegmentIDChar(c : char): Boolean;
begin
case c of
'A'..'Z', '0'..'9':
Result := True;
else
Result := False;
end;
end;
var SegID : string;
OK : boolean;
i : integer;
begin
//Decide if valid segment or arbitary text
if AnsiStartsStr('MSH', Line) and (Length(Line) > 8) then begin
fRange := rsMshDelim;
fFieldDelim := Line[4];
fCompDelim := Line[5];
fRepDelim := Line[6];
//If no escape characters are used in a message, this character may be omitted.
//However, it must be present if subcomponents are used in the message.
if Line[7] <> fFieldDelim then
fEscDelim := Line[7]
else
fEscDelim := DEF_ESC_DELIM;
//If there are no subcomponents in message then this seperator may not be present (use default then)
if Line[8] <> fFieldDelim then
fSubCompDelim := Line[8]
else
fEscDelim := DEF_SUBCOMP_DELIM;
end
else begin
SegID := Copy(FLine, run + 1, 3);
OK := Length(SegID) = 3;
for i := 1 to Length(SegID) do
OK := OK and IsValidSegmentIDChar(SegID[i]);
if OK then begin
case fRange of
rsUnknown : if (Copy(Line, 4, 1) = '|') then fRange := rsDefDelim;
rsMshDelim : if (Copy(Line, 4, 1) <> fFieldDelim) then fRange := rsUnknown;
rsDefDelim : if (Copy(Line, 4, 1) <> '|') then fRange := rsUnknown;
end;
end
else
fRange := rsUnknown;
end;
end;
procedure TSynHL7Syn.ResetRange;
begin
fRange:= rsUnknown;
end;
procedure TSynHL7Syn.SegmentIDProc;
function IsValidSegmentIDChar(c : char): Boolean;
begin
case c of
'A'..'Z', '0'..'9':
Result := True;
else
Result := False;
end;
end;
var OK : boolean;
SegID : String;
i : integer;
begin
// if it is not column 0-2 mark as tkText and get out of here
if Run > 0 then
begin
fTokenID := tkText;
inc(Run);
Exit;
end;
case fRange of
rsMshDelim, rsDefDelim : begin
fTokenID := tkSegmentID;
Run := 3;
end;
rsUnknown : begin
fTokenID := tkUnknown;
Inc(Run);
end;
end;
end;
procedure TSynHL7Syn.CRProc;
begin
fTokenID := tkSpace;
case FLine[Run + 1] of
#10: inc(Run, 2);
else inc(Run);
end;
end;
procedure TSynHL7Syn.TextProc;
function IsTextChar: Boolean;
begin
case fLine[Run] of
'a'..'z', 'A'..'Z', '0'..'9':
Result := True;
else
Result := False;
end;
end;
begin
if Run = 0 then
SegmentIDProc
else
begin
fTokenID := tkText;
inc(Run);
while FLine[Run] <> #0 do
if IsTextChar then
inc(Run)
else
break;
end;
end;
procedure TSynHL7Syn.UnknownProc;
begin
if Run = 0 then
Self.SetRangeState(fLine);
// this is column 0 ok it is a comment
fTokenID := tkUnknown;
inc(Run);
while FLine[Run] <> #0 do
case FLine[Run] of
#10: break;
#13: break;
else inc(Run);
end;
end;
procedure TSynHL7Syn.LFProc;
begin
fTokenID := tkSpace;
inc(Run);
end;
procedure TSynHL7Syn.SetRange(Value: Pointer);
begin
fRange := TRangeState(Value);
end;
procedure TSynHL7Syn.SpaceProc;
begin
inc(Run);
fTokenID := tkSpace;
while (FLine[Run] <= #32) and not IsLineEnd(Run) do inc(Run);
end;
procedure TSynHL7Syn.Next;
begin
//Decide range state by checking first char in line
fTokenPos := Run;
if Run = 0 then SetRangeState(fLine);
case fRange of
rsUnknown : case fLine[Run] of
#0: NullProc;
#10: LFProc;
#13: CRProc;
else
UnknownProc;
end;
rsMshDelim : begin
if fLine[Run] = Self.fFieldDelim then
FieldDelimProc
else if fLine[Run] = Self.fCompDelim then
CompDelimProc
else if fLine[Run] = Self.fSubCompDelim then
SubCompDelimProc
else if fLine[Run] = Self.fEscDelim then
EscDelimProc
else if fLine[Run] = Self.fRepDelim then
RepDelimProc
else begin
case fLine[Run] of
#0: NullProc;
#10: LFProc;
#13: CRProc;
#1..#9, #11, #12, #14..#32: SpaceProc;
else TextProc;
end;
end
end;
rsDefDelim : case fLine[Run] of
#0: NullProc;
#10: LFProc;
#13: CRProc;
#1..#9, #11, #12, #14..#32: SpaceProc;
DEF_FIELD_DELIM : FieldDelimProc;
DEF_COMP_DELIM : CompDelimProc;
DEF_SUBCOMP_DELIM : SubCompDelimProc;
DEF_ESC_DELIM : EscDelimProc;
DEF_REP_DELIM : RepDelimProc;
else TextProc;
end;
end;
inherited;
end;
procedure TSynHL7Syn.NullProc;
begin
fTokenID := tkNull;
inc(Run);
end;
function TSynHL7Syn.GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;
begin
case Index of
SYN_ATTR_WHITESPACE: Result := fSpaceAttri;
else
Result := nil;
end;
end;
function TSynHL7Syn.GetEol: Boolean;
begin
Result := Run = fLineLen + 1;
end;
function TSynHL7Syn.GetTokenID: TtkTokenKind;
begin
Result := fTokenId;
end;
function TSynHL7Syn.GetTokenAttribute: TSynHighlighterAttributes;
begin
case fTokenID of
tkSegmentID: Result := fSegmentIDAttri;
tkFieldDelim: Result := fFieldDelimAttri;
tkCompDelim: Result := fCompDelimAttri;
tkSubCompDelim: Result := fSubCompDelimAttri;
tkRepDelim: Result := fRepDelimAttri;
tkEscDelim: Result := fEscDelimAttri;
tkText: Result := fTextAttri;
tkSpace: Result := fSpaceAttri;
tkUnknown: Result := fUnknownAttri;
else Result := nil;
end;
end;
function TSynHL7Syn.GetTokenKind: integer;
begin
Result := Ord(fTokenId);
end;
function TSynHL7Syn.IsFilterStored: Boolean;
begin
Result := fDefaultFilter <> SYNS_FilterINI;
end;
class function TSynHL7Syn.GetLanguageName: string;
begin
Result := SYNS_LangINI;
end;
function TSynHL7Syn.GetRange: Pointer;
begin
Result := Pointer(fRange);
end;
function TSynHL7Syn.GetSampleSource: UnicodeString;
begin
Result := 'MSH|^&\~|123|123'#13#10+
'PID|123|1234'
end;
{$IFNDEF SYN_CPPB_1}
class function TSynHL7Syn.GetFriendlyLanguageName: UnicodeString;
begin
Result := SYNS_FriendlyLangINI;
end;
initialization
RegisterPlaceableHighlighter(TSynHL7Syn);
{$ENDIF}
end.
I know the only way to do that is to remap keys with regedit.
Have someone has done that with delphi ? (disable it and enable it again)
http://www.northcode.com/blog.php/2007/07/25/Securing-Windows-For-Use-As-A-Kiosk
The information in the article would translate to Delphi as follows:
uses
Registry;
const
DisableScancodes: packed array[0..11] of DWORD = (
$00000000, // version = 0
$00000000, // flags = 0
$00000009, // # of mappings = 9
$E05B0000, // disable Windows key
$E05C0000, // disable Windows key
$E05D0000, // disable Windows menu key
$00440000, // disable F10 key
$001D0000, // disable Left Ctrl key
$00380000, // disable Left Alt key
$E01D0000, // disable Right Ctrl key
$E0380000, // disable Right Alt key
$00000000 // end of list
);
var
Reg: TRegistry;
begin
Reg := TRegistry.Create(KEY_WRITE);
try
Reg.RootKey := HKEY_LOCAL_MACHINE;
if Reg.OpenKey('\SYSTEM\CurrentControlSet\Control\Keyboard Layout', True) then
begin
try
// to enable the mapping
Reg.WriteBinaryData('Scancode Map', DisableScancodes, SizeOf(DisableScancodes));
// to disable the mapping
Reg.DeleteValue('Scancode Map');
finally
Reg.CloseKey;
end;
end;
finally
Reg.Free;
end;
end;
If you need to be more dynamic about which scancodes you enable/disable, you will have to use TRegistry.ReadBinaryData() to read the current Scancode Map value (if it exists), modify it as needed, and then save the changes using TRegistry.WriteBinaryData(). Try something like this:
unit ScanCodeMap;
interface
type
TMappedScancode = record
Scancode: WORD;
MappedTo: WORD;
end;
procedure AddScancodeMappings(const Values: array of TMappedScancode);
procedure AddScancodeMapping(const Value: TMappedScancode);
procedure AddScancodeMapping(Scancode, MappedTo: WORD);
procedure RemoveScancodeMappings(const Scancodes: array of WORD);
procedure RemoveScancodeMapping(Scancode: WORD);
procedure DisableScancodes(Scancodes: array of WORD);
procedure DisableScancode(Scancode: WORD);
implementation
uses
Windows, Registry;
type
PScancodeMapHdr = ^TScancodeMapHdr;
TScancodeMapHdr = packed record
Version: DWORD;
Flags: DWORD;
NumMappings: DWORD;
end;
TScancodeMap = record
Version: DWORD;
Flags: DWORD;
Mappings: array of TMappedScancode;
end;
procedure AddScancodesToMap(var Map: TScancodeMap; const Values: array of TMappedScancode);
var
I, J, Idx: Integer;
begin
for I := 0 to High(Values) do
begin
Idx := -1;
for J := 0 to High(Map.Mappings) do
begin
if Map.Mappings[J].Scancode = Values[I].Scancode then
begin
Idx := J;
Break;
end;
end;
if Idx = -1 then
begin
SetLength(Map.Mappings, Length(Map.Mappings)+1);
Idx := High(Map.Mappings);
end;
Map.Mappings[Idx].MappedTo := Values[I].MappedTo;
end;
end;
procedure RemoveScancodesFromMap(var Map: TScancodeMap; const Scancodes: array of WORD);
var
I, J: Integer;
begin
for I := 0 to High(Scancodes) do
begin
for J := 0 to High(Map.Mappings) do
begin
if Map.Mappings[J].Scancode = Scancodes[I] then
begin
if J < High(Map.Mappings) then
Move(Map.Mappings[J+1], Map.Mappings[J], (High(Mappings)-J) * SizeOf(TMappedScancode));
SetLength(Map.Mappings, Length(Map.Mappings)-1);
Break;
end;
end;
end;
end;
procedure WriteScanCodeMap(const Map: TScancodeMap);
var
Reg: TRegistry;
Data: array of Byte;
Tmp: PByte;
Hdr: PScancodeMapHdr;
I: Integer;
begin
if Length(Map.Mappings) > 0 then
begin
SetLength(Data, sizeof(TScancodeMapHdr) + (Length(Map.Mappings) + 1) * SizeOf(DWORD));
Tmp := PByte(Data);
Hdr := PScancodeMapHdr(Tmp);
Hdr.Version := Map.Version;
Hdr.Flags := Map.Flags;
Hdr.NumMappings := Length(Map.Mappings) + 1;
Inc(Tmp, SizeOf(TScancodeMapHdr));
for I := 0 to High(Map.Mappings) do
begin
PDWORD(Tmp)^ := (DWORD(Map.Mappings[0].Scancode) shr 16) or DWORD(Map.Mappings[0].MappedTo);
Inc(Tmp, SizeOf(DWORD));
end;
PDWORD(Tmp)^ := 0;
end;
Reg := TRegistry.Create(KEY_WRITE);
try
Reg.RootKey := HKEY_LOCAL_MACHINE;
if Reg.OpenKey('\SYSTEM\CurrentControlSet\Control\Keyboard Layout', True) then
begin
try
if Length(Data) > 0 then
Reg.WriteBinaryData('Scancode Map', Data[0], Length(Data))
else
Reg.DeleteValue('Scancode Map');
finally
Reg.CloseKey;
end;
end;
finally
Reg.Free;
end;
end;
procedure ReadScanCodeMap(var Map: TScancodeMap);
var
Reg: TRegistry;
Size: Integer;
Data: array of Byte;
Tmp: PByte;
Hdr: PScancodeMapHdr;
I: Integer;
begin
Map.Version := 0;
Map.Flags := 0;
SetLength(Map.Mappings, 0);
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_LOCAL_MACHINE;
if Reg.OpenKeyReadOnly('\SYSTEM\CurrentControlSet\Control\Keyboard Layout') then
begin
try
Size := Reg.GetDataSize('Scancode Map');
if Size > SizeOf(TScancodeMapHdr) then
begin
SetLength(Data, Size);
Reg.ReadBinaryData('Scancode Map', Data[0], Size);
Tmp := PByte(Data);
Hdr := PScancodeMapHdr(Tmp);
Map.Version := Hdr.Version;
Map.Flags := Hdr.Flags;
Inc(Tmp, SizeOf(TScancodeMapHdr));
if Hdr.NumMappings > 1 then
begin
SetLength(Map.Mappings, Hdr.NumMappings-1);
for I := 0 to High(Map.Mappings) do
begin
Map.Mappings[I].Scancode := HIWORD(PDWORD(Tmp)^);
Map.Mappings[I].MappedTo := LOWORD(PDWORD(Tmp)^);
end;
end;
end;
finally
Reg.CloseKey;
end;
end;
finally
Reg.Free;
end;
end;
procedure AddScancodeMappings(const Values: array of TMappedScancode);
var
Map: TScancodeMap;
begin
ReadScanCodeMap(Map);
AddScancodesToMap(Map, Values);
WriteScanCodeMap(Map);
end;
procedure AddScancodeMapping(const Value: TMappedScancode);
begin
AddScancodeMappings([Value]);
end;
procedure AddScancodeMapping(Scancode, MappedTo: WORD);
var
Value: array[0..0] of TMappedScancode;
begin
Value[0].Scancode := Scancode;
Value[0].MappedTo := MappedTo;
AddScancodeMappings([Value]);
end;
procedure RemoveScancodeMappings(const Scancodes: array of WORD);
var
Map: TScancodeMap;
begin
ReadScanCodeMap(Map);
RemoveScancodesFromMap(Map, Scancodes);
WriteScanCodeMap(Map);
end;
procedure RemoveScancodeMapping(Scancode: WORD);
begin
RemoveScancodeMappings([Scancode]);
end;
procedure DisableScancodes(Scancodes: array of WORD);
var
Values: array of TMappedScancode;
I: Integer;
begin
SetLength(Values, Length(Scancodes));
for I := 0 to High(Mappings) do
begin
Values[I].Scancode := Scancodes[I];
Values[I].MappedTo := $0000;
end;
AddScancodeMappings(Values);
end;
procedure DisableScancode(Scancode: WORD);
begin
AddScancodeMapping(Scancode, $0000);
end;
end.
Then you can do this:
uses
ScanCodeMap;
const
Scancodes: packed array[0..7] of WORD = (
$E05B, // Windows key
$E05C, // Windows key
$E05D, // Windows menu key
$0044, // F10 key
$001D, // Left Ctrl key
$0038, // Left Alt key
$E01D, // Right Ctrl key
$E038 // Right Alt key
);
procedure DisableCtrlAltDel;
begin
DisableScancodes(Scancodes);
end;
procedure EnableCtrlAltDel;
begin
RemoveScancodeMappings(Scancodes);
end;
I know how to load and view one picture in delphi. However I would like to add a 'next image' button that brings up the next image in the file. I have 5 images in a file and i would like to scroll through them easily using a next button! I have tried to make the next button, But have no idea what code to put in!
Please help thanks.
Gpath is a global string variable.
procedure TPropertyForm.FormCreate(Sender: TObject);
begin
GPath := getcurrentdir + '\EmployeePhotos\';
EmployeeOpenPictureDialog.InitialDir := getcurrentdir + '\EmployeePhotos';
end;
procedure TPropertyForm.AttatchButtonClick(Sender: TObject);
var
st: string;
fsize, psize: integer;
begin
if EmployeeOpenPictureDialog.execute then
begin
st := EmployeeOpenPictureDialog.FileName;
psize := length(GPath);
fsize := length(st);
Properties.Photo := copy(st, psize + +1, fsize - psize)
end { endif };
PhotoImage.Hide;
if Properties.Photo <> '' then
begin
st := GPath + Properties.Photo;
if FileExists(st) then
begin
PhotoImage.Picture.LoadFromFile(st);
PhotoImage.Proportional := true;
PhotoImage.Show;
end
{ endif }
end; { endif }
end
procedure TPropertyForm.NextImageButtonClick(Sender: TObject);
begin
PhotoImage.Picture.LoadFromFile(st + 1);
end;
i think you want to load images from "Folder" and switch between them, if so try this code
place 2 TButtons and 1 TImage
uses jpeg;
public
{ Public declarations }
var
SL:TStringList;
ImgIndex:integer;
GPath:String;
procedure ListFileDir(Path: string; FileList: TStrings);
var
SR: TSearchRec;
begin
if FindFirst(Path + '*.jpg', faAnyFile, SR) = 0 then
begin
repeat
if (SR.Attr <> faDirectory) then
begin
FileList.Add(SR.Name);
end;
until FindNext(SR) <> 0;
FindClose(SR);
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
GPath:= getcurrentdir + '\EmployeePhotos\';
SL:=TStringList.Create;
ListFileDir(GPath,SL);
Image1.Picture.LoadFromFile(GPath + SL.Strings[ImgIndex] );
end;
procedure TForm1.btnNextClick(Sender: TObject);
begin
ImgIndex:=ImgIndex+1;
if ImgIndex=SL.Count then ImgIndex :=0;
Image1.Picture.LoadFromFile(GPath + SL.Strings[ImgIndex] );
end;
procedure TForm1.btnPrevClick(Sender: TObject);
begin
ImgIndex:=ImgIndex-1;
if ImgIndex=-1 then ImgIndex :=SL.Count-1;
Image1.Picture.LoadFromFile(GPath + SL.Strings[ImgIndex] );
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
SL.Free;
end;
First part of the code works OK while the second (commented) does not.
It overwrites my A1 file although it should write to A2.
procedure TForm1.AdvGlowButton12Click(Sender: TObject);
var
i,j: Integer;
Seznam: TStrings;
ApplicationPath: string;
begin
if (cxRadiogroup3.ItemIndex and cxRadiogroup2.ItemIndex) = 0 then begin
ApplicationPath:= ExtractFileDir(Application.ExeName);
Seznam:= TStringList.Create;
try
for i:=0 to advStringGrid2.ColCount-1 do
Seznam.AddStrings(advStringGrid2.Cols [i]);
for i:=0 to advStringGrid2.rowCount-1 do
Seznam.AddStrings(advStringGrid2.rows [j]);
Seznam.SaveToFile(ApplicationPath+'\A1.txt');
finally
seznam.free;
end;
end ;
//if cxRadiogroup3.ItemIndex = 1 and cxRadiogroup2.ItemIndex = 0 then begin
// ApplicationPath:= ExtractFileDir(Application.ExeName);
// Seznam:= TStringList.Create;
// try
// for i:=0 to advStringGrid2.ColCount-1 do
// Seznam.AddStrings(advStringGrid2.Cols [i]);
// for i:=0 to advStringGrid2.rowCount-1 do
// Seznam.AddStrings(advStringGrid2.rows [j]);
// Seznam.SaveToFile(ApplicationPath+'\A2.txt');
// finally
// seznam.free;
// end ;
//end
end;
What am I doing wrong ?
Also why is the stringgrid giving listindex out of bounds when I try to load into it contents from an empty text file? If I save empty stringgrid to that file,later ,though it has nothing in the file,it does not complain? Strange...
This is how I load A1 and A2 into the stringgrid.
procedure TForm1.cxRadioGroup2Click(Sender: TObject);
Var
I,j,k: Integer;
Seznam: TStrings;
ApplicationPath: string;
begin
case cxradioGroup2.ItemIndex of
0: begin
if cxradioGroup3.ItemIndex = 0 then begin
Seznam:= TStringList.Create;
AdvStringgrid2.ClearAll;
try
Seznam.LoadFromFile('A1.txt');
k:= 0;
for i:=0 to advStringGrid2.ColCount-1 do
for j:=0 to advStringGrid2.RowCount-1 do begin
advstringGrid2.Cells [i,j]:= Seznam.Strings [k];
Inc(k);
end;
finally
seznam.free;
end;
end;
if cxradioGroup3.ItemIndex = 1 then begin
Seznam:= TStringList.Create;
AdvStringgrid2.ClearAll;
try
Seznam.LoadFromFile('A2.txt');
k:=0;
for i:=0 to advStringGrid2.ColCount-1 do
for j:=0 to advStringGrid2.RowCount-1 do begin
advstringGrid2.Cells [i,j]:= Seznam.Strings [k];
Inc(k);
end;
finally
seznam.free;
end;
end;
end;
end;
end;
here is an old tipp from SwissDelphiCenter that could help you
// Save StringGrid1 to 'c:\temp.txt':
procedure TForm1.Button1Click(Sender: TObject);
begin
SaveStringGrid(StringGrid1, 'c:\temp.txt');
end;
// Load StringGrid1 from 'c:\temp.txt':
procedure TForm1.Button2Click(Sender: TObject);
begin
LoadStringGrid(StringGrid1, 'c:\temp.txt');
end;
// Save a TStringGrid to a file
procedure SaveStringGrid(StringGrid: TStringGrid; const FileName: TFileName);
var
f: TextFile;
i, k: Integer;
begin
AssignFile(f, FileName);
Rewrite(f);
with StringGrid do
begin
// Write number of Columns/Rows
Writeln(f, ColCount);
Writeln(f, RowCount);
// loop through cells
for i := 0 to ColCount - 1 do
for k := 0 to RowCount - 1 do
Writeln(F, Cells[i, k]);
end;
CloseFile(F);
end;
// Load a TStringGrid from a file
procedure LoadStringGrid(StringGrid: TStringGrid; const FileName: TFileName);
var
f: TextFile;
iTmp, i, k: Integer;
strTemp: String;
begin
AssignFile(f, FileName);
Reset(f);
with StringGrid do
begin
// Get number of columns
Readln(f, iTmp);
ColCount := iTmp;
// Get number of rows
Readln(f, iTmp);
RowCount := iTmp;
// loop through cells & fill in values
for i := 0 to ColCount - 1 do
for k := 0 to RowCount - 1 do
begin
Readln(f, strTemp);
Cells[i, k] := strTemp;
end;
end;
CloseFile(f);
end;
I'm trying to understand your code and tried him as good as it is possible for me to rewrite. (it's not tested)
procedure TForm1.AdvGlowButton12Click(Sender: TObject);
var
i, j: Integer;
Seznam: TStrings;
ApplicationPath: string;
fileName: string;
line: string;
begin
if (cxRadiogroup2.ItemIndex = 0) then begin
if (cxRadiogroup3.ItemIndex = 0) then
fileName:= 'A1.txt'
else
fileName:= 'A2.txt'
ApplicationPath:= ExtractFileDir(Application.ExeName);
Seznam:= TStringList.Create;
try
for k:=0 to advStringGrid2.RowCount-1 do begin
line:= '';
for i:=0 to advStringGrid2.ColCount-1 do
line = line + '|' + advStringGrid2.Cells[i, k];
Seznam.AddStrings(line);
end;
Seznam.SaveToFile(ApplicationPath + '\' + fileName);
finally
seznam.Free;
end;
end;
end;
procedure TForm1.cxRadioGroup2Click(Sender: TObject);
var
splitList: TStringList;
i, j: Integer;
Seznam: TStrings;
ApplicationPath: string;
fileName: string;
line: string;
sepIndex: integer;
begin
if (cxRadiogroup2.ItemIndex = 0) then begin
if (cxRadiogroup3.ItemIndex = 0) then
fileName:= 'A1.txt'
else
fileName:= 'A2.txt'
AdvStringgrid2.ClearAll; // don't know what this does
ApplicationPath:= ExtractFileDir(Application.ExeName);
Seznam:= TStringList.Create;
try
Seznam.LoadFromFile(fileName);
advstringGrid2.RowCount:= Seznam.Count;
splitList:= TStringList.Create;
for i:=0 to Seznam.Count-1 do begin
line:= Seznam.Strings [i];
Split('|', line, splitList);
advStringGrid2.ColCount:= Max(advStringGrid2.ColCount, splitList.Count);
for k:=0 to splitList.Count-1 do
advStringGrid2.Cells[i, k]:= splitList[k];
end;
finally
splitList.Free;
seznam.Free;
end;
end;
end;
procedure Split (const Delimiter: Char; Input: string; const Strings: TStrings);
begin
Assert(Assigned(Strings));
Strings.Clear;
Strings.Delimiter:= Delimiter;
Strings.DelimitedText:= Input;
end;
hope that helps
How do you know it is overwriting A1.txt? You are saving the exact same contents in both cases.
Founded and adapted to my needs. Then shared :-)
procedure LoadStringGrid(const AFileName: TFileName; AGrid: TStringGrid);
var
slRows: TStringList;
i: integer;
begin
slRows:= TStringList.Create;
try
slRows.LoadFromFile(AFileName);
for i:= 0 to slRows.Count -1 do
AGrid.Rows[i +1].CommaText:= slRows[i];
finally
slRows.Free;
end;
end;// LoadStringGrid
procedure SaveStringGrid(const AFileName: TFileName; AGrid: TStringGrid);
var
slRows: TStringList;
i: integer;
begin
slRows:= TStringList.Create;
try
for i:= 1 to AGrid.RowCount -1 do
slRows.Add(AGrid.Rows[i].CommaText);
slRows.SaveToFile(AFileName);
finally
slRows.Free;
end;
end;// SaveStringGrid
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;