Trouble with displaying RTF-Text between Delphi XE8 and Delphi 7 - delphi-7

I have trouble displaying RTF-Formatted text between two delphi-Versions.
The TDBRichEdit-Control and TRichEdit-Control seem to have trouble parsing the RTF-text supplied.
Sometimes it seems as if to get it to work in XE8 you simply have to connect a TDBRichEdit to the appropriate Field in the Dataset, but the same Method would mess up the Delphi 7 Version.
So we figured we handle this via Code.
Basically we replaced the TDBRichEdits with normal TRichEdits and
supply the RTF through a stream.
textstream:=TStringStream.Create(CDS.FieldByName('TEXT').AsString);
try
RichEditFAPLAN.Lines.Clear();
RichEditFAPLAN.Lines.LoadFromStream(textStream);
finally
textstream.Free();
end;
this worked fine until about 1h ago when I decided to move the code above into it's own globally available function.
procedure StreamRichTextTo(ARichEdit:TCustomRichEdit; ADataSet:TDataSet; AFieldName:String);
var
ws:WideString;
Stream:TStringStream;
begin
ARichEdit.Lines.Clear();
if (ADataSet=nil) or (ADataSet.FindField(AFieldName)=nil) or (ADataSet.FieldByName(AFieldName).IsNull) then exit;
ws:=UTF8Decode(ADataSet.FieldByName(AFieldName).AsString);
Stream:=TStringStream.Create(ws);
try
Stream.Position:=0;
ARichEdit.Lines.LoadFromStream(Stream);
finally
Stream.Free();
end;
end;
I tried different Variations of this code. With MemoryStream, Widestring, UTF8 Encoding, AnsiString and what not.
procedure StreamRichTextTo(ARichEdit:TCustomRichEdit; ADataSet:TDataSet; AFieldName:String);
var
{$IFDEF VER150}
ws:WideString;
Stream:TStringStream;
{$ELSE}
s:AnsiString;
//Stream:TMemoryStream;
Stream:TStringStream;
{$ENDIF}
begin
ARichEdit.Lines.Clear();
if (ADataSet=nil) or (ADataSet.FindField(AFieldName)=nil) or (ADataSet.FieldByName(AFieldName).IsNull) then exit;
{$IFDEF VER150}
ws:=UTF8Decode(ADataSet.FieldByName(AFieldName).AsString);
Stream:=TStringStream.Create(ws);
{$ELSE}
{
s:=ADataSet.FieldByName(AFieldName).AsAnsiString;
Stream:=TMemoryStream.Create();
Stream.Clear();
Stream.Write(PAnsiChar(s)^,length(s));
}
s:=ADataSet.FieldByName(AFieldName).AsAnsiString;
Stream:=TStringStream.Create(s,TEncoding.UTF8);
//Stream.WriteString(s);
Stream.Position:=0;
{$ENDIF}
try
ARichEdit.Lines.LoadFromStream(Stream);
finally
Stream.Free();
end;
end;
All to no avail, the XE-RTF-Text always comes out looking either like this or as a simple '':
{\rtf1\fbidis\ansi\ansicpg1252\deff0{\fonttbl{\f0\fnil\fcharset0 arial;}{\f1\fswiss\fprq2\fcharset0 Arial;}{\f2\fnil arial;}}
\viewkind4\uc1\pard\ltrpar\lang1031\f0\fs20 Gie\'dftemp.: \tab 1350 - 1370 \'b0C
\par \ul\f1 Form fest verklammern und belasten
\par \ulnone\f0
\par \tab\tab\f2
\par }
What's more, the original Code with the "textstream", that I commented back in, is also not working anymore.
What I'm looking for is a code-solution that can properly handle RTF-Text between different IDE-Versions.
EDIT:
Here is a sample Project-Code.
The thing is, everything works fine in this project.
I have no idea why the same code does no longer work in our software and I can not reproduce it.
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, Data.DB,
Datasnap.DBClient;
type
TForm1 = class(TForm)
REGoal: TRichEdit;
Button1: TButton;
CDS: TClientDataSet;
RESource: TRichEdit;
procedure Button1Click(Sender: TObject);
private
{ Private-Deklarationen }
public
{ Public-Deklarationen }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure StreamRichTextTo(ARichEdit:TRichEdit; ADataSet:TDataSet; AFieldName:String);
var
Stream:TStringStream;
//{$IFDEF VER150}
ws:WideString;
//{$ELSE}
//{$ENDIF}
begin
ARichEdit.Lines.Clear();
if (ADataSet=nil) or (ADataSet.FindField(AFieldName)=nil) or (ADataSet.FieldByName(AFieldName).IsNull) then exit;
try
//{$IFDEF VER150}
ws:=UTF8Decode(ADataSet.FieldByName(AFieldName).AsString);
Stream:=TStringStream.Create(ws);
//{$ELSE}
// Stream:=TStringStream.Create(ADataSet.FieldByName(AFieldName).AsString);
//{$ENDIF}
ARichEdit.Lines.LoadFromStream(Stream);
finally
Stream.Free();
end;
end;
(* Copy this to RESource
{\rtf1\ansi\ansicpg1252\deff0{\fonttbl{\f0\fnil\fcharset0 arial;}{\f1\fnil arial;}}
\viewkind4\uc1\pard\lang1031\f0\fs20 Erste Form ist eine Zulegekontrolle durchzuf\fchren.
\par
\par
\par \f1
\par }
*)
procedure TForm1.Button1Click(Sender: TObject);
var
Stream:TStringStream;
begin
if CDS.FindField('TEXT')=nil then
begin
CDS.FieldDefs.Add('TEXT',ftWideString,4096);
CDS.CreateDataSet();
end;
CDS.Edit();
CDS.FieldByName('TEXT').AsString:=RESource.text;
CDS.Post();
StreamRichTextTo(REGoal,CDS,'TEXT');
end;
Just Create a new Form1
Add 2 TRichEdits, one is called RESource and the other REGoal
Add a TClientDataSet and call it CDS
Add A Button
Assign the OnClick-procedure to the button
I'll try creating the project in D7 and port it to XE8 next, maybe this will reproduce the effect.
EDIT 2:
Creating the Project in Delphi 7 and then Opening it in XE8 produces the same result.
My guess is, that there is something happening when the Database-Value is assigned to a String-Variable (or passed directly into the stream) which would be why I'm unable to reproduce the error.
Also maybe the Database is at fault.
it's a Firebird 3.0 Database with a VarChar-Field

This IS the working Version of the code.
Apparently there was something wrong with the RTF-Code itself due to a bug in our Editor
procedure StreamRichTextTo(ARichEdit:TRichEdit; ADataSet:TDataSet; AFieldName:String);
var
{$IFDEF VER150}
ws:WideString;
{$ELSE}
ws:String;
{$ENDIF}
Stream:TStringStream;
begin
ARichEdit.Lines.Clear();
if (ADataSet=nil) or (ADataSet.FindField(AFieldName)=nil) or (ADataSet.FieldByName(AFieldName).IsNull) then exit;
{$IFDEF VER150}
ws:=UTF8Decode(ADataSet.FieldByName(AFieldName).AsString);
{$ELSE}
ws:=ADataSet.FieldByName(AFieldName).AsString;
{$ENDIF}
Stream:=TStringStream.Create(ws);
try
ARichEdit.Lines.LoadFromStream(Stream);
finally
Stream.Free();
end;
end;

Related

Delphi Windows Service does not run, immediately goes from Create to Destroy

I write a basic Delphi MS-Windows service.
I install it with the /install directove. This works.
In the Windows Services list it exists.
I START it from there. Windows says it started successfully. It shows as running.
But nothing is executed, except the OnCreate and OnDestroy.
It is in fact NOT running, while Windows claims it IS running.
I tried Delpi 10.2 and the latest 10.4.
What is going wrong here? It is the most basic Service possible.
The Log output looks like this:
Create
AfterInstall
Destroy
Create
Destroy
Create
Destroy
program BartServiceTwo;
uses
Vcl.SvcMgr,
Unit1 in 'Unit1.pas' {BartService: TService};
{$R *.RES}
begin
// Windows 2003 Server requires StartServiceCtrlDispatcher to be
// called before CoRegisterClassObject, which can be called indirectly
// by Application.Initialize. TServiceApplication.DelayInitialize allows
// Application.Initialize to be called from TService.Main (after
// StartServiceCtrlDispatcher has been called).
//
// Delayed initialization of the Application object may affect
// events which then occur prior to initialization, such as
// TService.OnCreate. It is only recommended if the ServiceApplication
// registers a class object with OLE and is intended for use with
// Windows 2003 Server.
//
// Application.DelayInitialize := True;
//
if not Application.DelayInitialize or Application.Installing then
Application.Initialize;
Application.CreateForm(TBartService, BartService);
Application.Run;
end.
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Classes, Vcl.SvcMgr;
type
TBartService = class(TService)
procedure ServiceExecute(Sender: TService);
procedure ServiceCreate(Sender: TObject);
procedure ServiceDestroy(Sender: TObject);
procedure ServiceStart(Sender: TService; var Started: Boolean);
procedure ServiceStop(Sender: TService; var Stopped: Boolean);
procedure ServiceAfterInstall(Sender: TService);
private
{ Private declarations }
public
function GetServiceController: TServiceController; override;
procedure Log(Line:string);
{ Public declarations }
end;
var
BartService: TBartService;
LogFile: text;
Logfilename: string;
implementation
{$R *.dfm}
procedure TBartService.Log(Line:string);
begin
if Logfilename = '' then
begin
Logfilename := 'Log.txt';
Assignfile(LogFile,Logfilename);
end;
try
if FileExists(Logfilename)
then append(LogFile)
else rewrite(LogFile);
writeln(LogFile,line);
Closefile(LogFile);
except
on E:Exception do;
end;
end;
procedure ServiceController(CtrlCode: DWord); stdcall;
begin
BartService.Controller(CtrlCode);
end;
function TBartService.GetServiceController: TServiceController;
begin
Result := ServiceController;
end;
procedure TBartService.ServiceAfterInstall(Sender: TService);
begin
Log('AfterInstall');
end;
procedure TBartService.ServiceCreate(Sender: TObject);
begin
Log('Create');
messagebeep(0);
end;
procedure TBartService.ServiceDestroy(Sender: TObject);
begin
Log('Destroy');
end;
procedure TBartService.ServiceExecute(Sender: TService);
begin
Log('ServiceExecute Start. Terminated='+Terminated.ToString(true));
while not Terminated do
begin
try
ServiceThread.ProcessRequests(false);
Log('ServiceExecute');
// messagebeep(0);
sleep(1000);
except
on E:Exception do
begin
Log('ERROR: ServiceExecute: Final: '+E.Message);
end;
end;
end;
Log('ServiceExecute Out of loop.');
end;
procedure TBartService.ServiceStart(Sender: TService; var Started: Boolean);
begin
Log('ServiceStart');
end;
procedure TBartService.ServiceStop(Sender: TService; var Stopped: Boolean);
begin
Log('ServiceStop');
end;
end.
I assume that during your debugging you have copy and pasted code into the unit from another project but you have not 'hooked up' the events properly. Bring up the project in Delphi and open the service module. Click on the Events tab in the Object Inspector and my guess is that they are all blank. (View the source of the .dfm and there is likely no OnExecute, OnStop, OnStop, etc events defined)
For example - double click the OnExecute event and I assume the IDE will automatically create a new OnExecute event rather than navigating to your OnExecute event in the unit.
Simply rehook up your events and it will most likely work as expected.
Solved. After using the 'LogMessage() system, I found that the service is in fact running.
But what happened, is that the destination folder of my simple Log file was transfered from the local executable directory to C:\Windows\System32\ and there was all the rest of the Log data... I never expected that :(
Thanks for all help, Bart

True free heap not what it should be after ShellExecute

I have a simple Application that reads data from an .ini file into a record, and then does a ShellExecute. However, when I run it in debug mode,it tells me that the True free heap isn't what it should be:
"True heap size: 688128, True free heap: 688016, Should be: 688128"
This only happens if I actually run the ShellExecute (however even if I don't run the ShellExecute, I get a True free heap of 688016, but no complaint that it should be 688128), so I wonder if I either need to free the PChar() conversion (which shouldn't be the case from all that I've read), or the handle returned by ShellExecute (though CloseHandle(ShellHandle); doesn't change the message), or if it's intended behavior?
The IniSettings.SetupCommand in question is an .msi file that triggers a UAC prompt, but I really just want to make this a Fire & Forget thing since my Lazarus app doesn't care what it launches.
For reference, here's my whole Unit. I'm using Lazarus 1.6.2, FPC 3.0.0, i386-win32, and I'm targeting Windows only with this. My Debug Settings are at the very bottom, after the code.
unit MainUnit;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls,
Graphics, Dialogs, StdCtrls, IniFiles, Windows;
type
{ IniSettings }
TAutorunIniSettings = record
AutorunTitle: AnsiString;
SetupCommand: AnsiString;
end;
{ TMainForm }
TMainForm = class(TForm)
btnSetup: TButton;
lblTitle: TLabel;
procedure btnSetupClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
{ private declarations }
IniSettings: TAutorunIniSettings;
public
{ public declarations }
end;
var
MainForm: TMainForm;
implementation
{$R *.lfm}
{ TMainForm }
procedure TMainForm.FormCreate(Sender: TObject);
var
AutorunIni: TIniFile;
begin
try
AutorunIni := TIniFile.Create('Autorun.ini');
IniSettings.AutorunTitle := AutorunIni.ReadString('Autorun', 'Title', 'Autorun');
IniSettings.SetupCommand := AutorunIni.ReadString('Autorun', 'Setup', '');
self.Caption := IniSettings.AutorunTitle;
finally
if(AutorunIni <> nil) then AutorunIni.Free;
end;
end;
procedure TMainForm.FormDestroy(Sender: TObject);
begin
end;
procedure TMainForm.btnSetupClick(Sender: TObject);
begin
ShellExecute(0, 'open', PChar(IniSettings.SetupCommand), nil, nil, SW_SHOWNORMAL);
end;
end.

Lazarus - Mac OSX Debugging Error

I used to use Delphi 7 on my PC, but now that I bought a MacBook (Mid 2012 - OSX Mountain Lion), I wanted to continue programming in Pascal and have a similar Interface. Lazarus seems to deliver most of the things I wanted, but it seems to run into a lot of errors, when compiling even the simplest applications! To test it, I made a simple "Russian Roulette" application, just for fun, but the program just freezes, when launched or even when compiled inside Lazarus.
When launching it from command line, It shows me the following error:
TCarbonButton.SetFocus Error: SetKeyboardFocus failed with result -30585
I don't think my coding is the problem, but I guess I should include it:
unit RussianRouletteUnit;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
Buttons, ExtCtrls;
type
{ TForm1 }
TForm1 = class(TForm)
Button1: TButton;
Kugeln: TLabeledEdit;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
private
{ private declarations }
public
{ public declarations }
end;
var
Form1: TForm1;
Number: Integer;
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.Button1Click(Sender: TObject);
begin
if Random(StrToInt(Kugeln.Text))+1 = 1 then
begin
Button1.SetFocus;
Memo1.Color := clred;
Memo1.Text := 'BOOM';
Memo1.Lines.Add('HEADSHOT');
end;
end;
initialization
randomize;
end.
I hope you guys can help me out, any help is apprechiated :D

Delphi DLL Issues - wrong integer value recevied and access violation issue

I'm having trouble getting to grips with DLLs in Delphi 7. I have two problems:
1) The procedure takes an integer parameter - but the dll receives a different value to the one I pass.
2) The application that called the dll crashes with an access violation after the function completes.
Here's my dll code:
library apmDLL;
uses
Classes, Messages, Windows, Dialogs, sysutils ;
const
WM_MY_MESSAGE = WM_USER + 1;
procedure sendtoACRPM (functionKey : integer); stdcall;
begin
showmessage('You sent - '+inttostr(functionKey));
showmessage('Finished Now');
end;
exports sendtoACRPM;
end.
So when I call this with the code below I get:
'Sending - 1'
'You Sent - 1636532'
'Finished Now'
Then the calling application crashes with an access violation.
The calling application looks like this:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, shlobj, shellapi;
const
WM_MY_MESSAGE = WM_USER + 1;
type
TForm1 = class(TForm)
Edit1: TEdit;
Button2: TButton;
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
procedure sendtoACRPM (functionKey : integer) ; external 'apmDLL.dll';
implementation
{$R *.dfm}
procedure TForm1.Button2Click(Sender: TObject);
var
myInt: integer;
begin
myInt := strtoint(edit1.text);
showmessage('Sending - ' + inttostr(myInt));
sendtoACRPM(myInt);
end;
end.
Any ideas what I'm doing wrong here?
You need stdcall both in the DLL and in the calling code declaration. You only have it in the DLL.
Calling conventions need to match on both sides. :-)
procedure sendtoACRPM (functionKey : integer); stdcall; external 'apmDLL.dll';
You should use the standard Windows MessageBox instead of ShowMessage, so that the DLL can be used from non-Delphi applications as well.

Why do I get multiple windows messages of same kind?

I'm trying to respond to some windows and application messages, but I get them multiple times.
For example, I write the following code to show a message box when the date of system is changed using WM_TIMECHANGE. WMTimeChange is executed more than once, and I see multiples (most times two or three) messageboxes one behind another. Maybe, I am missing something?
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs;
type
TForm1 = class(TForm)
protected
procedure WMTimeChange(var Msg: TMessage) ; message WM_TIMECHANGE;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
{ TForm1 }
procedure TForm1.WMTimeChange(var Msg: TMessage);
begin
showmessage('Date/Time has changed!');
end;
end.
Testing in Windows XP.
EDIT: Just to clarify, my intention is understand WHY that happen and not how to get around the multiple calls. Anyway, if an answer to that is not possible, I will probably accept one answer to the later.
EDIT2: Removed Delphi Tag as it seems not a Delphi issue.
Your code is correct. It sounds like that Windows is sending the WM_TIMECHANGE message several times.
So you can just add a small time-hysteresis comparison to let your message be triggered only once per a 1% of day, i.e. more or less 15 minutes:
type
TForm1 = class(TForm)
protected
FWMTimeChangeTimeStamp: TDateTime;
procedure WMTimeChange(var Msg: TMessage) ; message WM_TIMECHANGE;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
{ TForm1 }
procedure TForm1.WMTimeChange(var Msg: TMessage);
begin
if Now-FWMTimeChangeTimeStamp>0.01 then
begin
showmessage('Date/Time has changed!');
FWMTimeChangeTimeStamp := Now;
end;
end;
This is kind of what I've used in my case to be resilient to this behavior. But as said in comments, will only work if the user take time to answer the application. So, Arnaud Bounchez is a better approach to general use. Only don't forget to initialize the FWMTimeChangeStamp to something that is different from current computer clock.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs;
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
protected
procedure WMTimeChange(var Msg: TMessage) ; message WM_TIMECHANGE;
private
isTimeChangeEventShowing: Boolean;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
begin
isTimeChangeEventShowing := false
end;
procedure TForm1.WMTimeChange(var Msg: TMessage);
begin
if not isTimeChangeEventShowing then
begin
isTimeChangeEventShowing := true;
showmessage('Date/Time has changed!');
isTimeChangeEventShowing := false;
end;
end;
end.

Resources