CSV to StringGrid Out of Memory - csv

I am having issues with loading a CSV into a StringGrid. Occasionally, it runs out of memory, but also it seems to have blank columns after each value. I've not really read from a CSV as opposed to output to one, so I took a stock example online and modified it for my needs.
This is what I've currently got:
procedure x.LoadCSVtoGrid(ACSVFile : String; AStringGrid: TStringGrid)
var
LRowIndex, LColIndex: Integer;
LStrLine: string;
LFile: TStringList;
begin
AStringGrid.RowCount := 0;
AStringGrid.ColCount := 0;
if not FileExists(ACSVFile) then
exit;
LFile := TStringList.Create;
try
LFile.LoadFromFile(ACSVFile);
if LFile.Count = 0 then
exit;
AStringGrid.ColCount := Max(AStringGrid.ColCount, WordCount(LFile[0], [',', '"'], '"'));
AStringGrid.RowCount := LFile.Count;
for LRowIndex := 0 to LFile.Count - 1 do
begin
LStrLine := LFile[LRowIndex];
LColIndex := 0;
while LStrLine <> '' do
begin
if Pos('"', LStrLine) = 1 then
begin
Delete(LStrLine, 1, 1);
AStringGrid.Cells[LColIndex, LRowIndex] := Copy(LStrLine, 1, Pos('"', LStrLine) - 1);
Delete(LStrLine, 1, Pos('"', LStrLine));
end
else
begin
AStringGrid.Cells[LColIndex, LRowIndex] := Copy(LStrLine, 1, Pos(',', LStrLine) - 1);
Delete(LStrLine, 1, Pos(',', LStrLine));
end;
Inc(LColIndex);
end;
end;
finally
LFile.Free;
end;
For smaller CSV files, it does fine. I think it's reading up to 250-300 lines before. Some of the files it has to deal with now are 500+.
To be honest, I don't do much handling of the data of the CSV until it's been imported into the StringGrid, but once it's in the StringGrid, it's validated. I've got to make sure that commas within speech marks, ie "text, here", are ignored, as it's part of the value. Again, this appears to handle the reading fine.
Another issue I think I might run into is AStringGrid.RowCount := LFile.Count;, as some of the CSV files have blank lines. If there is a way to deal with this, I am happy to take suggestions.
There are a few versions of CSV files it should be able to read, ie the calculation of column counts and such. Code for WordCount:
function x.WordCount(const S: string; const WordDelims: TSysCharSet; const QuoteChar: Char) : Integer;
var
LInWord: Boolean;
LQuoteOpen: Boolean;
i: Integer;
begin
Result := 0;
LInWord := False;
LQuoteOpen := False;
for i := 1 to Length(S) do
begin
if S[i] in WordDelims then
begin
if not LInWord or LQuoteOpen then
LInWord := False
else
begin
LInWord := True;
Inc(Result);
end;
end
else
begin
if S[i] = QuoteChar then
LQuoteOpen := not LQuoteOpen;
LInWord := True;
end;
end;
if LInWord and (not LQuoteOpen) then
Inc(Result);
I've tried multiple files, for the most part this issue only happens with larger CSV files with more content. I've tried various versions of CSV-to-StringGrid procedures to see if there is something innately wrong with the example I took above. The example works, but only on smaller files.
Let me know if you need more information.

Memory issue
First you create a TStringList and then load it with data
LFile := TStringList.Create;
LFile.LoadFromFile(ACSVFile);
Because you load the whole file into the string list, you need that much of memory, plus equally much to hold the data in the TStringGrid.
Reduce memory requirement by reading the file in chunks of, say, 1000 lines at the time, which you then can throw away after they are moved to the string grid.
OTOH, your "Out of memory" problem might also be caused by the errors in your code. I experienced an "Out of memory" error with my very small test file when run with your unaltered code.
Issues with code
In my tests I used a simple file with a few records and a quoted field in different locations. The file content is:
one,two,"text, including comma",four,five
one,two,three,four,five
"text, including comma",two,three,four,five
one,two,three,four,"text, including comma"
You determine required number of columns in the TStringGrid, by calling the WordCount() function, to which you pass the first string from the string list.
WordCount(const S: string; const WordDelims: TSysCharSet; const QuoteChar: Char) : Integer;
When I pass in the first test string,
'one,two,three,four,five',
WordCount returns correctly 5
Then, control returns to LoadCSVtoGrid(), and after assigning AStringGrid.ColCount and RowCount the for LRowIndex loop starts to fill the grid with data for the current row. Pay attention to the second part, after else:
AStringGrid.Cells[LColIndex, LRowIndex] := Copy(LStrLine, 1, Pos(',', LStrLine) - 1);
Delete(LStrLine, 1, Pos(',', LStrLine));
The Delete() deletes from beginning of LStrLine to Pos(',', LStrLine). This works ok for items "one,", "two,", "three," and "four,", but not for "five" as there is no comma after the last item.
This is the major flaw in the code as it never deletes the last item. Instead, since the loop runs while LString <> '' it just continues incrementing LColIndex
On my machine it stops after a couple of minutes with an out-of-memory error.
Here is my take on WordCount (renamed WordCountNew) function:
function TForm50.WordCountNew(const s: string; const Delimiter: Char;
const QuoteChar: Char): Integer;
var
InWord, InQuote: boolean;
i: integer;
begin
if s = '' then // Just in case we are fed an empty string
Exit(0);
Result := 1; // Init, at least one data item
InWord := False; // Init
InQuote:= False; // Init
for i := 1 to Length(s) do
begin
if s[i] = QuoteChar then // The field is quoted
InQuote := not InQuote; // make note about it
if s[i] = Delimiter then // Delimiter found
begin
if not InQuote then // ... but only count it,
inc(Result); // if not within a quote
end;
end;
end;
Then the LoadCSVtoGrid procedure:
procedure TForm50.LoadCSVtoGrid(ACSVFile: String; AStringGrid: TStringGrid);
var
LRowIndex, LColIndex: Integer;
LStrLine: string;
LFile: TStringList;
CommaPos: integer; // added
begin
AStringGrid.RowCount := 0;
AStringGrid.ColCount := 0;
if not FileExists(ACSVFile) then
exit;
LFile := TStringList.Create;
try
LFile.LoadFromFile(ACSVFile);
if LFile.Count = 0 then
exit;
// When determining column count we should ONLY count the field separator, comma.
// A quote character is not an indication of a new column / field.
// Therefore we remove the array of chars, `[',', '"']` and replace with `','`
// AStringGrid.ColCount := Max(AStringGrid.ColCount, WordCount(LFile[0], [',', '"'], '"'));
AStringGrid.ColCount := Max(AStringGrid.ColCount, WordCountNew(LFile[0], ',', '"'));
AStringGrid.RowCount := LFile.Count;
for LRowIndex := 0 to LFile.Count - 1 do
begin
LStrLine := LFile[LRowIndex];
LColIndex := 0;
while LStrLine <> '' do
begin
if Pos('"', LStrLine) = 1 then
begin
Delete(LStrLine, 1, 1);
AStringGrid.Cells[LColIndex, LRowIndex] := Copy(LStrLine, 1, Pos('"', LStrLine) - 1);
AStringGrid.UpdateControlState;
Delete(LStrLine, 1, Pos('"', LStrLine));
Delete(LStrLine, 1, Pos(',', LStrLine));
end
else
begin
CommaPos := Pos(',', LStrLine);
if CommaPos = 0 then CommaPos := Length(LStrLine)+1;
AStringGrid.Cells[LColIndex, LRowIndex] := Copy(LStrLine, 1, CommaPos-1); //Pos(',', LStrLine) - 1);
AStringGrid.UpdateControlState;
Delete(LStrLine, 1, CommaPos); // Pos(',', LStrLine));
end;
Inc(LColIndex);
end;
end;
finally
LFile.Free;
end;
end;
I added the CommaPos variable, to make it easier to artificially simulate a comma at the end of the string.
With these changes the test file is properly read into the grid.

Related

Exporting Array to CSV in CODESYS

I am taking over a project with code from another person. I have a PLC that currently has inputs in from pressure sensors and thermocouples. It then scales that data to PSI and temperature in fahrenheit. The way the data is set up from each of those sensors is to be formatted into an array. So, once the data is scaled it is in an array that is also in the Network Variable List of the program. I am trying to take each of these values from the array, record the value every certain amount of time (say 1 recording per second for sake of clarity), and then export each piece of data to a CSV file for every second. Not sure where to even go with this. This is the code I was left with, but I feel as if it it unnecessarily complicated?
//This is the support class for File_Handler
FUNCTION_BLOCK fileWrite
VAR_INPUT
xWrite : BOOL;
sData : STRING(200);
uiLineLength : INT := 200;
sDirectory : STRING := 'C:\ProgramData\CODESYS\CODESYSHMIWinV3\D5050FE1\PlcLogic\data';
//sDirectory : STRING := '/home/cds-apps/PlcLogic/data/';
sFilename : STRING;
END_VAR
VAR_OUTPUT
BytesWritten : __XWORD;
BytesWrittenTotal: DWORD;
xDone: BOOL;
END_VAR
VAR
hFile_: sysfile.RTS_IEC_HANDLE := sysfile.RTS_INVALID_HANDLE;
FileWriteResult: sysfile.RTS_IEC_RESULT;
FileOpenResult: sysfile.RTS_IEC_RESULT;
state: INT;
sys_Us_start: SYSTIME;
sys_Us_end: SYSTIME;
WriteTimeMS: ULINT;
END_VAR
sFilename := CONCAT(sDirectory, sFilename);
hFile_ := SysFileOpen(szFile:= sFilename, am:= ACCESS_MODE.AM_APPEND_PLUS, pResult:= ADR(FileOpenResult));
SysTimeGetUs(pUsTime:=sys_Us_start );
BytesWritten := SysFileWrite(hFile:= hfile_, pbyBuffer:= ADR(sData), ulSize:= uiLineLength, pResult:= ADR(FileWriteResult));
BytesWrittenTotal := BytesWrittenTotal + BytesWritten;
SysTimeGetUs(pUsTime:=sys_Us_end );
WriteTimeMS := (sys_Us_end - sys_Us_start)/1000;
SysFileClose(hFile:= hFile_);
I am not sure where to go with this code. It does create a CSV file, but I was looking to be able to create a CSV file for a piece of data every second? If anyone has any thoughts or resources I could check out that would be great.
A basic example of how to call this routine every second could be the following:
1)
You create a FuncBlock that takes care of calling your logger block.
Let's say you call it LoggerTask.
FUNCTION_BLOCK LoggerTask
VAR_INPUT
sData : STRING(200);
sFilename : STRING;
xExecute : BOOL;
END_VAR
VAR
fbRepeatTask : TON;
fbFileWrite : FileWrite;
uiStep : UINT;
END_VAR
2)
After that create a simple step chain:
(You can obviously extend and customize it as you like, you should add error handling in the case when FileWrite fails to write to file or writes less than expected for example.)
Implementation part:
fbRepeatTask(PT:=T#1S);
fbFileWrite(sData := sData, sFileName := sFileName);
IF xExecute
AND uiStep = 0
THEN
uiStep := 10;
ELSIF NOT xExecute
THEN
uiStep := 0;
fbFileWrite.xWrite := FALSE;
fbRepeatTask.IN := FALSE;
END_IF
CASE uiStep OF
10:
fbFileWrite.xWrite := TRUE;
IF fbFileWrite.xDone
THEN
fbFileWrite.xWrite := FALSE;
uiStep := 20;
END_IF
20:
fbRepeatTask.IN := TRUE;
IF fbRepeatTask.Q
THEN
fbRepeatTask.IN := FALSE;
uiStep := 10;
END_IF
END_CASE
3)
As you can see this block gets executed as soon as xExecute is set to true.
In order to reset the step chain set xExecute to false.
Just run this block cyclically for example like this fbLoggerTask(xExecute := TRUE);
I don't think you posted all the code of your FileWrite block because xDone is not set and xWrite is not checked anywhere.
So make sure that xDone is set to true for one cycle after the String is written to the file (if it's not already been implemented).

Pascal Change a function into a procedure

I am trying to change the function inside the following program into a procedure. The program is supposed to read 5 different integers and then sort them from small numbers to large ones. The version with the function works fine, but the one with the procedure doesn't sort the numbers. It only prints the numbers I typed in. For example, when I type 4, 5 , 7, 3, 1 into the console, it would print 4, 5, 7, 3, 1 instead of the desired 1, 3, 4, 5, 7.
So the question is: how do I get the procedure version to work in the same way as the function version?
I am pretty sure there is something here that I don't understand, but I cannot seem to find out... Any help is greatly appreciated!
This is the version that uses a function:
program FeldSortFunction(input, output); { sorts a field of integers}
FELDGROESSE = 5;
type tIndex = 1..FELDGROESSE; tFeld = array [tIndex] of integer;
var EingabeFeld : tFeld; MinPos,
i : tIndex; Tausch : integer;
function FeldMinimumPos (Feld : tFeld; von, bis:tIndex): tIndex; { finds the Position of the minimum inside the field between von and bis, 1 <= von <= bis <= FELDGROESSE }
var MinimumPos, j:tIndex;
begin
MinimumPos := von;
for j:= von + 1 to bis do
if Feld[j] < Feld[MinimumPos] then
MinimumPos := j;
FeldMinimumPos := MinimumPos
end; { FeldMinimumPos }
begin { Read the field } writeln ('Geben Sie ', FELDGROESSE, ' Werte ein:'); for i := 1 to FELDGROESSE do
readln (EingabeFeld[i]);
{ sort the integers }
for i := 1 to FELDGROESSE - 1 do begin
MinPos := FeldMinimumPos (EingabeFeld, i, FELDGROESSE);
{The minimum has been found, now we need to exchange this value with the element on position i}
Tausch := EingabeFeld[MinPos];
EingabeFeld[MinPos] := EingabeFeld[i];
Eingabefeld[i] := Tausch; end;
{ print the sorted field } for i := 1 to FELDGROESSE do
write (EingabeFeld[i]:6); writeln;
readln; end. { FeldSort }
And this is the version that uses a procedure:
program FeldSortProcedure(input, output);
{ sorts a field of integers and defines the value of the minimum}
const
FELDGROESSE = 5;
type
tIndex = 1..FELDGROESSE;
tFeld = array [tIndex] of integer;
var
SortierFeld : tFeld;
MinPos,MinimumPos,
i : tIndex;
MinimumWert : integer;
procedure FeldMinimumPosUndWert (Feld : tFeld; von, bis:tIndex; MinPos:tIndex; MinWert : integer);
{ finds Position and value of the Minimums inside Feld between von and bis }
var
ind:tIndex;
begin
MinPos := von;
MinWert := Feld[von];
for ind := von + 1 to bis do
begin
if Feld[ind] < Feld[MinPos] then
begin
MinPos := ind;
MinWert := Feld[ind]
end;
end;
end; { FeldMinPosUndWert }
begin
{ Read the field }
writeln ('Please key in ', FELDGROESSE, ' numbers:');
for i := 1 to FELDGROESSE do
readln (SortierFeld[i]);
{ sort the field }
FeldMinimumPosUndWert (SortierFeld, i, FELDGROESSE, MinimumPos, MinimumWert);
{ prints the sorted field }
for i := 1 to FELDGROESSE do
write (SortierFeld[i]:6);
writeln;
readln;
end. { FeldSort }
Obviously you aren't getting anywhere with this, so I'll give a hint:
turn your function
function FeldMinimumPos (Feld : tFeld; von, bis:tIndex): tIndex;
into a procedure with:
procedure FeldMinimumPos(feld: TFeld; von, bis: TIndex; var pos: TIndex);
{ finds the position of the minimum inside the field between von and bis,
1 <= von <= bis <= FELDGROESSE }
var
j: TIndex;
begin
pos := von;
for j := von + 1 to bis do
if feld[j] < feld[pos] then
pos := j;
end; { FeldMinimumPos }
and call it with:
FeldMimimumPos(EingabeFeld, i, FELDGROESSE, MinPos);
and you should be fine.
A few remarks, though:
Your way of sorting is less than optimal, even for a field of only 5 elements. Learn about selection sort or even bubble sort (just google them).
Format your code properly. It is very hard to read. Put comments on their own line or after the code. Put every end on its own line and align it properly, don't put it after the previous command. Align your variable declarations, and start loops on their own line too. Etc...
You forgot a const above the FELDGROESSE declaration. The code you posted doesn't compile. Always post the actual code, copied from your editor and pasted (verbatim) into the edit box for your question (or answer). Do not post code from memory or by typing it off a screen or a sheet of paper.

DSiWin32.DSiGetHtmlFormatFromClipboard not working?

I am trying to use the DSiGetHtmlFormatFromClipboard function from the well known DSiWin32 library.
Edit: There is a much newer version of DSIWin32.pas 1.94 from 2016-10-19 which is contained in the current version of OmniThreadLibrary_3.07.1. The one I've linked to in the first line of my question is much older: 1.66 from 2012-04-20. However, also in this newer version of DSIWin32.pas the function DSiGetHtmlFormatFromClipboard does not work although I've made sure that no other clipboard programs are running.
So I put some text on the clipboard which includes the HTML format e.g. by copying some text from Chrome web-browser.
And then I use this code to get the HTML format from the clipboard:
if DSiWin32.DSiIsHtmlFormatOnClipboard then
begin
CodeSite.Send('HTML-Format string:', DSiWin32.DSiGetHtmlFormatFromClipboard);
end;
While the DSiIsHtmlFormatOnClipboard function does work (it gives back True if there is HTML Format on the clipboard and gives back False if there is no HTML Format on the clipboard), the DSiGetHtmlFormatFromClipboard function always gives back an empty string although there is HTML Format in the clipboard:
So I debugged function DSiGetHtmlFormatFromClipboard: string; in DSiWin32.pas:
On this line:
hClipData := GetClipboardData(GCF_HTML);
hClipData is always 0, so the following code is not executed.
GetClipboardData is a function from Winapi.Windows and according to MSDN documentation:
Retrieves data from the clipboard in a specified format. The clipboard
must have been opened previously.
Which is the case in the DSiWin32 code.
So why does the DSiGetHtmlFormatFromClipboard always give back an empty string?
OS: Windows 7 x64
GetLastError retrieved immediately after the line hClipData := GetClipboardData(GCF_HTML);:
ERROR_CLIPBOARD_NOT_OPEN 1418 (0x58A) Thread does not have a
clipboard open.
This is strange because the preceding line is: Win32Check(OpenClipboard(0)); and it does not fail.
Here is the relevant parts of the MCVE:
var
GCF_HTML: UINT;
function DSiIsHtmlFormatOnClipboard: boolean;
begin
Result := IsClipboardFormatAvailable(GCF_HTML);
end; { DSiIsHtmlFormatOnClipboard }
function DSiGetHtmlFormatFromClipboard: string;
var
hClipData : THandle;
idxEndFragment : integer;
idxStartFragment: integer;
pClipData : PChar;
begin
Result := '';
if DSiIsHtmlFormatOnClipboard then
begin
Win32Check(OpenClipboard(0));
try
hClipData := GetClipboardData(GCF_HTML);
if hClipData = 0 then
RaiseLastOSError;
pClipData := GlobalLock(hClipData);
Win32Check(assigned(pClipData));
try
idxStartFragment := Pos('<!--StartFragment-->', pClipData); // len = 20
idxEndFragment := Pos('<!--EndFragment-->', pClipData);
if (idxStartFragment >= 0) and (idxEndFragment >= idxStartFragment) then
Result := Copy(pClipData, idxStartFragment + 20, idxEndFragment - idxStartFragment - 20);
finally GlobalUnlock(hClipData); end;
finally Win32Check(CloseClipboard); end;
end;
end; { DSiGetHtmlFormatFromClipboard }
procedure TForm1.Button1Click(Sender: TObject);
begin
if DSiIsHtmlFormatOnClipboard then
ShowMessage(DSiGetHtmlFormatFromClipboard)
else
ShowMessage('No HTML Format on Clipboard');
end;
initialization
GCF_HTML := RegisterClipboardFormat('HTML Format');
end.

Adding true hyperlink support to TRichEdit

I need support for "friendly name hyperlink" in TRichEdit and all solutions I have found are based on autoURLs (EM_AUTOURLDETECT) which works by detecting strings entered by user that start with www (or http).
But I want to place links on strings that does not start with www. Example: 'Download'.
You need to do the following:
send the RichEdit an EM_SETEVENTMASK message to enable the ENM_LINK flag. Do this once after the RichEdit has been created, and then do it again every time the RichEdit receives a CM_RECREATEWND message.
select the desired text you want to turn into a link. You can use the RichEdit's SelStart and SelLength properties, or send the RichEdit an EM_SETSEL or EM_EXSETSEL message. Either way, then send the RichEdit an EM_SETCHARFORMAT message with a CHARFORMAT2 struct to enable the CFE_LINK effect on the selected text.
subclass the RichEdit's WindowProc property to handle CN_NOTIFY(EN_LINK) and CM_RECREATEWND messages. When EN_LINK is received, you can use ShellExecute/Ex() to launch the desired URL.
For example:
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ComCtrls;
type
TForm1 = class(TForm)
RichEdit1: TRichEdit;
Button1: TButton;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
PrevRichEditWndProc: TWndMethod;
procedure InsertHyperLink(const HyperlinkText: string);
procedure SetRichEditMasks;
procedure RichEditWndProc(var Message: TMessage);
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
uses
Winapi.RichEdit, Winapi.ShellAPI;
procedure TForm1.FormCreate(Sender: TObject);
begin
PrevRichEditWndProc := RichEdit1.WindowProc;
RichEdit1.WindowProc := RichEditWndProc;
SetRichEditMasks;
RichEdit1.Text := 'Would you like to Download Now?';
RichEdit1.SelStart := 18;
RichEdit1.SelLength := 12;
InsertHyperLink('Download Now');
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
InsertHyperLink('Another Link');
end;
procedure TForm1.InsertHyperLink(const HyperlinkText: string);
var
Fmt: CHARFORMAT2;
StartPos: Integer;
begin
StartPos := RichEdit1.SelStart;
RichEdit1.SelText := HyperlinkText;
RichEdit1.SelStart := StartPos;
RichEdit1.SelLength := Length(HyperlinkText);
FillChar(Fmt, SizeOf(Fmt), 0);
Fmt.cbSize := SizeOf(Fmt);
Fmt.dwMask := CFM_LINK;
Fmt.dwEffects := CFE_LINK;
SendMessage(RichEdit1.Handle, EM_SETCHARFORMAT, SCF_SELECTION, LPARAM(#Fmt));
RichEdit1.SelStart := StartPos + Length(HyperlinkText);
RichEdit1.SelLength := 0;
end;
procedure TForm1.SetRichEditMasks;
var
Mask: DWORD;
begin
Mask := SendMessage(RichEdit1.Handle, EM_GETEVENTMASK, 0, 0);
SendMessage(RichEdit1.Handle, EM_SETEVENTMASK, 0, Mask or ENM_LINK);
SendMessage(RichEdit1.Handle, EM_AUTOURLDETECT, 1, 0);
end;
procedure TForm1.RichEditWndProc(var Message: TMessage);
type
PENLINK = ^ENLINK;
var
tr: TEXTRANGE;
str: string;
p: PENLINK;
begin
PrevRichEditWndProc(Message);
case Message.Msg of
CN_NOTIFY: begin
if TWMNotify(Message).NMHdr.code = EN_LINK then
begin
P := PENLINK(Message.LParam);
if p.msg = WM_LBUTTONUP then
begin
SetLength(str, p.chrg.cpMax - p.chrg.cpMin);
tr.chrg := p.chrg;
tr.lpstrText := PChar(str);
SendMessage(RichEdit1.Handle, EM_GETTEXTRANGE, 0, LPARAM(#tr));
if str = 'Download Now' then
begin
ShellExecute(Handle, nil, 'http://www.SomeSite.com/download', nil, nil, SW_SHOWDEFAULT);
end
else if str = 'Another Link' then
begin
// do something else
end;
end;
end;
end;
CM_RECREATEWND: begin
SetRichEditMasks;
end;
end;
end;
end.
Update: Per MSDN:
RichEdit Friendly Name Hyperlinks
In RichEdit, the hyperlink field entity is represented by character formatting effects, as contrasted to delimiters which are used to structure math objects. As such, these hyperlinks cannot be nested, although in RichEdit 5.0 and later they can be adjacent to one another. The whole hyperlink has the character formatting effects of CFE_LINK and CFE_LINKPROTECTED, while autoURLs only have the CFE_LINK attribute. The CFE_LINKPROTECTED is included for the former so that the autoURL scanner skips over friendly name links. The instruction part, i.e., the URL, has the CFE_HIDDEN attribute as well, since it’s not supposed to be displayed. The URL itself is enclosed in ASCII double quotes and preceded by the string “HYPERLINK “. Since CFE_HIDDEN plays an integral role in friendly name hyperlinks, it cannot be used in the name.
For example, in WordPad, which uses RichEdit, a hyperlink with the name MSN would have the plain text
HYPERLINK “http://www.msn.com”MSN
The whole link would have CFE_LINK and CFE_LINKPROTECTED character formatting attributes and all but the MSN would have the CFE_HIDDEN attribute.
This can be simulated easily in code:
procedure TForm1.FormCreate(Sender: TObject);
begin
...
RichEdit1.Text := 'Would you like to Download Now?';
RichEdit1.SelStart := 18;
RichEdit1.SelLength := 12;
InsertHyperLink('Download Now', 'http://www.SomeSite.com/downloads');
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
InsertHyperLink('A Text Link');
end;
procedure TForm1.InsertHyperLink(const HyperlinkText: string; const HyperlinkURL: string = '');
var
HyperlinkPrefix, FullHyperlink: string;
Fmt: CHARFORMAT2;
StartPos: Integer;
begin
if HyperlinkURL <> '' then
begin
HyperlinkPrefix := Format('HYPERLINK "%s"', [HyperlinkURL]);
FullHyperlink := HyperlinkPrefix + HyperlinkText;
end else begin
FullHyperlink := HyperlinkText;
end;
StartPos := RichEdit1.SelStart;
RichEdit1.SelText := FullHyperlink;
RichEdit1.SelStart := StartPos;
RichEdit1.SelLength := Length(FullHyperlink);
FillChar(Fmt, SizeOf(Fmt), 0);
Fmt.cbSize := SizeOf(Fmt);
Fmt.dwMask := CFM_LINK;
Fmt.dwEffects := CFE_LINK;
if HyperlinkURL <> '' then
begin
// per MSDN: "RichEdit doesn’t allow the CFE_LINKPROTECTED attribute to be
// set directly by programs. Maybe it will allow it someday after enough
// testing is completed to ensure that things cannot go awry"...
//
{
Fmt.dwMask := Fmt.dwMask or CFM_LINKPROTECTED;
Fmt.dwEffects := Fmt.dwEffects or CFE_LINKPROTECTED;
}
end;
SendMessage(RichEdit1.Handle, EM_SETCHARFORMAT, SCF_SELECTION, LPARAM(#Fmt));
if HyperlinkURL <> '' then
begin
RichEdit1.SelStart := StartPos;
RichEdit1.SelLength := Length(HyperlinkPrefix);
FillChar(Fmt, SizeOf(Fmt), 0);
Fmt.cbSize := SizeOf(Fmt);
Fmt.dwMask := CFM_HIDDEN;
Fmt.dwEffects := CFE_HIDDEN;
SendMessage(RichEdit1.Handle, EM_SETCHARFORMAT, SCF_SELECTION, LPARAM(#Fmt));
end;
RichEdit1.SelStart := StartPos + Length(FullHyperlink);
RichEdit1.SelLength := 0;
end;
And then handled in the EN_LINK notification by parsing the clicked hyperlink text:
uses
..., System.StrUtils;
...
SendMessage(RichEdit1.Handle, EM_GETTEXTRANGE, 0, LPARAM(#tr));
// Per MSDN: "The ENLINK notification structure contains a CHARRANGE with
// the start and end character positions of the actual URL (IRI, file path
// name, email address, etc.) that typically appears in a browser URL
// window. This doesn’t include the “HYPERLINK ” string nor the quotes in
// the hidden part. For the MSN link above, it identifies only the
// http://www.msn.com characters in the backing store."
//
// However, without the CFM_LINKPROTECTED flag, the CHARRANGE will report
// the positions of the entire "HYPERLINK ..." string instead, so just strip
// off what is not needed...
//
if StartsText('HYPERLINK "', str) then
begin
Delete(str, 1, 11);
Delete(str, Pos('"', str), MaxInt);
end;
if (str is a URL) then begin
ShellExecute(Handle, nil, PChar(str), nil, nil, SW_SHOWDEFAULT);
end
else begin
// do something else
end;

FPC : RTTI on records

This is my first time on this site. Usually, I have no problem to found replies in the old posts but I don't success with my actual problem.
I would like to know how use RTTI functions to know at running time the properties/members of a record under Lazarus/FPC? I know how to do it for a class (Tpersistent descendant and published properties) but not for FPC. Some links indicates how to do it under Delphi (From D2010), but I don't know how to transpose it under Lazarus.
Thanks in advance for help and assistance.
Salim Larhrib.
To kevin : As I told before, this is my first demand. But I understand. You are right. This is my code
procedure TMainForm.btRecordTHashListClick(Sender: TObject);
var
pTData : PTypeData;
pTInfo : PTypeInfo;
TablePtr : PatableRecord;
Loop : Integer;
begin
// Set of Record pointers + HashList
// Create Container
if not Assigned(FTableRecList) then FTableRecList := TFPHashList.Create;
// Insert data
new(TablePtr);
TablePtr^.description := 'Dictionnaire des tables.';
FTableRecList.add('atable', TablePtr );
new(TablePtr);
TablePtr^.description := 'Dictionnaire des fonctions.';
FTableRecList.add('afunction', TablePtr );
new(TablePtr);
TablePtr^.description := 'Dictionnaire des listes d''option.';
FTableRecList.add('alist', TablePtr );
// Read records
for Loop:=0 to FTableRecList.Count-1 do
begin
TablePtr := FTableRecList[Loop];
ShowMessage('Parcours Index : ' + TablePtr^.description);
end;
// Find records
try
TablePtr := FTableRecList.Find('ddafunction');
ShowMessage('Record finded : ' + TablePtr^.description);
except
ShowMessage('Not such record .');
end;
try
TablePtr := FTableRecList.Find('afunction');
ShowMessage('Record finded : ' + TablePtr^.description);
except
ShowMessage('No such record.');
end;
// Free memory : To put later in TFPHashList wrapper
for Loop:=0 to FTableRecList.Count-1 do Dispose(PatableRecord(FTableRecList[Loop]));
// RTTI
pTInfo := TypeInfo(TatableRecord);
pTData := GetTypeData(pTInfo);
ShowMessage('Member count = '+IntToStr(pTData^.PropCount));
end;
WARNING: It works with FPC 2.7.1 or later.
You can deal with record fields using pointers. Here is example:
program rttitest;
uses
TypInfo;
type
TMyRec = record
p1: Integer;
p2: string;
end;
var
td: PTypeData;
ti: PTypeInfo;
mf: PManagedField;
p: Pointer;
f: Pointer;
r: TMyRec;
begin
r.p1 := 312;
r.p2 := 'foo-bar';
ti := TypeInfo(r);
td := GetTypeData(ti);
Writeln(td^.ManagedFldCount); // Get count of record fields
// After ManagedFldCount TTypeData contains list of the TManagedField records
// So ...
p := #(td^.ManagedFldCount); // Point to the ManagedFldCount ...
// Inc(p, SizeOf(Integer)); // Skip it (Wrong for 64-bit targets)
// Next line works for both
Inc(p, SizeOf(td^.ManagedFldCount)); // Skip it
mf := p; // And now in the mf we have data about first record's field
Writeln(mf^.TypeRef^.Name);
Write(r.p1); // Current value
f := #r;
Inc(f, mf^.FldOffset); // Point to the first field
Integer(f^) := 645; // Set field value
Writeln(r.p1); // New value
// Repeat for the second field
Inc(p, SizeOf(TManagedField));
mf := p;
Writeln(mf^.TypeRef^.Name);
Write(r.p2);
f := #r;
Inc(f, mf^.FldOffset);
string(f^) := 'abrakadabra';
Writeln(r.p2);
Readln;
end.