How to modify the text being pasted? - delphi

I'm trying to modify the text being pasted inside a TEdit descendant.
When the user paste some text, I want to replace all 'X' chars with an 'Y', without modifying the actual clipboard text content.
I've intercepted the WM_PASTE message, but I'm not aware about any "clean" way to change the text that's being pasted into the control.
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;
type
TMyEdit = class(Vcl.StdCtrls.TEdit)
private
procedure WMPaste(var Msg: TWMPaste); message WM_PASTE;
end;
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
uses
Clipbrd;
procedure TMyEdit.WMPaste(var Msg: TWMPaste);
begin
inherited;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
Edt : TMyEdit;
begin
Edt := TMyEdit.Create(Self);
Edt.Top := 10;
Edt.Left := 10;
Edt.Parent := Self;
end;
end.
The only working way I've found is to temporarly replace the clipboard content, but I'm looking for a cleaner solution (if there's one...).
procedure TMyEdit.WMPaste(var Msg: TWMPaste);
var
PrevClipboardText : string;
begin
if(IsClipboardFormatAvailable(CF_TEXT)) then
begin
PrevClipboardText := Clipboard.AsText;
try
Clipboard.AsText := StringReplace(Clipboard.AsText, 'X', 'Y', [rfReplaceAll]);
inherited;
finally
Clipboard.AsText := PrevClipboardText;
end;
end else
begin
inherited;
end;
end;

Why not do the obvious thing?
procedure TEdit.WMPaste(var Msg: TWMPaste);
begin
SelText := F(Clipboard.AsText);
end;
where F is your string-transforming function.

Related

How to interfere when user presses CTRL+X and still keep TMemo's default CTRL+X behavior?

I have a TMemo on the form and I've set an OnChange event for it. I hope the OnChange event not to be triggered when the user presses Ctrl+X in the memo. But Ctrl+X just cuts the text selection, which will for sure trigger the OnChange event. How can I prevent that?
I've tried to detect Ctrl+X in the KeyUp event, and if the user pressed Ctrl+X I unbind the memo's OnChange event and programmatically cut the text again. But this doesn't work, and I don't how to programmatically send Ctrl+X.
procedure TForm1.Memo1KeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
if (Key = Ord('X')) and (Shift = [ssCtrl]) then
begin
Memo1.OnChange := nil;
// programmatically cut the text here, which I don't know how to do
Memo1.OnChange := Memo1Change;
end;
end;
Don't rely on keyboard events (They are not executed for example when you cut something by using the popupmenu), rely on windows messages instead.
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;
type
TForm1 = class(TForm)
Memo1: TMemo;
procedure Memo1Change(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
FPrevMemoWindowProc : TWndMethod;
procedure MemoWindowProc(var AMessage: TMessage);
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
uses
Clipbrd;
procedure TForm1.MemoWindowProc(var AMessage: TMessage);
begin
if(AMessage.Msg = WM_CUT) then
begin
if(Memo1.SelLength > 0) then
begin
Memo1.OnChange := nil;
try
Clipboard.AsText := Memo1.SelText;
Memo1.ClearSelection();
Exit;
finally
Memo1.OnChange := Memo1Change;
end;
end;
end;
FPrevMemoWindowProc(AMessage);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
FPrevMemoWindowProc := Memo1.WindowProc;
Memo1.WindowProc := MemoWindowProc;
end;
procedure TForm1.Memo1Change(Sender: TObject);
begin
ShowMessage('Change');
end;

Modal dialog does not return focus to application

I have a custom control derived from TPanel named TTestCtrl. It holds a TImage32 (from Graphics32).
When the user double clicks on the image, I show a message. The problem is that after I close the message, the focus is not returned back to the main application. So, the first click, no matter what I click on in the main app/main form, is lost.
Strange thing: If I call the Mesaj() procedure not from the TTestCtrl but from the main form, it works (the first click is not lost anymore):
unit DerivedControl;
interface
uses
System.SysUtils, System.Classes, Vcl.Controls, Vcl.ExtCtrls, Vcl.Dialogs, Vcl.Forms, GR32, GR32_Image;
type
TTestCtrl = class(TPanel)
private
Img: TImage32;
protected
procedure ChromaDblClick(Sender: TObject);
public
constructor Create(AOwner: TComponent); override;
published
end;
procedure Mesaj(const MessageText, Title: string);
implementation
procedure Mesaj(const MessageText, Title: string);
begin
{$IFDEF MSWINDOWS}
Application.MessageBox(PChar(MessageText), PChar(Title), 0) { 'Title' will appear in window's caption }
{$ELSE}
MessageDlg(MessageText, mtInformation, [mbOk], 0);
{$ENDIF}
end;
constructor TTestCtrl.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Width := 200;
Height := 86;
Img := TImage32.Create(Self);
Img.Parent := Self;
Img.Align := alClient;
Img.OnDblClick := ChromaDblClick;
end;
procedure TTestCtrl.ChromaDblClick(Sender: TObject);
begin
Mesaj('Caption', 'From derived control'); // focus lost
end;
end.
The simple/minimal application below is the tester:
unit TesterForm;
interface
uses
System.SysUtils, System.Classes, Vcl.StdCtrls, Vcl.Samples.Spin, Vcl.Controls, vcl.Forms, DerivedControl;
type
TfrmTester = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
public
end;
var
frmTester: TfrmTester;
implementation
{$R *.dfm}
var
Ctrl: TTestCtrl;
procedure TfrmTester.FormCreate(Sender: TObject);
begin
Ctrl := TTestCtrl.Create(Self);
Ctrl.Parent := Self;
end;
procedure TfrmTester.Button1Click(Sender: TObject);
begin
Mesaj('Caption', 'From main form'); // works
end;
end.
Try this :
procedure TTestCtrl.ChromaDblClick(Sender: TObject);
var F : TcustomForm;
begin
Mesaj('Caption', 'From derived control'); // focus lost
F := GetParentForm(Self);
if Assigned(F) then F.BringToFront;
end;

"Available Form:". Original Delphi Frames with Original unit

Problem:
How can I load frame in Form1 or sample container in form ?
FindClass or GetClass is only locality for main form appl-n
I need (maybe) string globaly elemental for TFrameClass, next code:
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.ExtCtrls;
type
TFrameClass = class of TFrame;
type
TForm1 = class(TForm)
Panel1: TPanel;
Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
FFrame: TFrame;
function StrShowFrame(FrameClassName: string;
ParentPanel: TWinControl): Boolean;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
uses Base1Frame, Base2Frame, Base3Frame;
function TForm1.StrShowFrame(FrameClassName: string;
ParentPanel: TWinControl): Boolean;
var
FrameClass: TClass;
// Current Frame (FrameName)
FrameName: string;
begin
Result := False;
??? GetClass is only locality for main form in appl-n
FrameClass := GetClass(FrameClassName);
if FrameClass = nil then
begin
ShowMessageFmt('Class %s not registered', [FrameClassName]);
Result := False;
Exit;
end;
try
begin
LockWindowUpdate(ParentPanel.Handle);
if Assigned(FFrame) then
if FFrame.ClassType = FrameClass then
begin
Result := True;
Exit;
end
else
FFrame.Destroy; // del previus FrameClass
try
FFrame := TFrameClass(FrameClass).Create(nil);
except
on E:Exception do
begin
Result := True;
E.Create(E.Message);
FFrame := nil;
Exit;
end;
end;
FrameName:= FrameClassName;
Delete(FrameName, 1, 1); // T-...
FFrame.Name := Concat(FrameName, '1');
FFrame.Parent := ParentPanel;
FFrame.Align := alClient;
end;
finally
LockWindowUpdate(0);
end;
Result := True;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
StrShowFrame('TFr_Base1', Panel1);
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
try
if FFrame <> nil then
FFrame.Free
else
ShowMessage('Class not activ');
except
end;
end;
end.
How can I load frame in Form1 or sample container in form ?
FindClass or GetClass is only locality for main form appl-n
I need (maybe) string globaly elemental for TFrameClass.
GetClass() and FindClass() are not local to the MainForm, they are global to the entire RTL as a whole. Any unit can call RegisterClass() and have that class be accessible to any other unit that shares the same instance of the RTL. That last part is important. A DLL cannot register a class that the EXE uses (and vice versa), unless both projects are compiled with Runtime Packages enabled so they share a single RTL instance.

On Mouse Enter TShape

I have a TMachine class, that is a TShape class
unit MachineShape;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, extctrls,myDataModule,Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;
type
TMachine = class(TShape)
private
{ Private declarations }
public
{ Public declarations }
procedure PlaceShape(sizeW,sizeH :integer; name, order,asset : string);
end;
implementation
Procedure TMachine.PlaceShape(sizeW,sizeH :integer; name, order,asset : string);
begin
self.width := sizeW;
self.height := sizeH;
self.top := 136;
self.left := MyDataModule.fDB.LastX +2;//set left
MyDataModule.fDB.lastx := left + sizeW;
end;
end.
How would i add onmouseenter code for this? So when the shape is added during run time it will have its own on mouse enter code. Something like this, I know this wont work.. but maybe it will show you what i am looking to do? So when i create a TMachine, i would pass the name and number to this procedure and it would make the onmouseenter procedure update with the name/number i sent it.
Procedure TMachine.EditMouseEnter(name,number :string);
begin
....onmouseenter(Label2.Caption := name AND label3.caption := Number)...
end
Add an OnMouseEnter event:
type
TMachineEvent = procedure(Sender: TMachine) of object;
TMachine = class(TShape)
private
FOnMouseEnter: TMachineEvent;
...
procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
protected
procedure DoMouseEnter; virtual;
published
property OnMouseEnter: TMachineEvent read FOnMouseEnter write FOnMouseEnter;
...
end;
implementation
{ TMachine }
procedure TMachine.CMMouseenter(var Message: TMessage);
begin
DoMouseEnter;
inherited;
end;
procedure TMachine.DoMouseEnter;
begin
if Assigned(FOnMouseEnter) then
FOnMouseEnter(Self);
end;
And assign that event at runtime:
procedure TForm1.CreateMachine;
var
Machine: TMachine;
begin
Machine := TMachine.Create(Self);
Machine.SetBounds(...);
Machine.OnMouseEnter := MachineMouseEnter;
Machine.Parent := Self;
end;
procedure TForm1.MachineMouseEnter(Sender: TMachine);
begin
Label2.Caption := Sender.Name;
Label3.Caption := Sender.Number;
end;

Simple OpenGL Code not working

Just learning some OpenGL with delphi and trying something simple but not getting a result, I belive i should get a dark green form. But when i run this i get nothing. No errors either. maybe missing something?
unit First1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls,OpenGL, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;
type
TForm2 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormPaint(Sender: TObject);
private
{ Private declarations }
GLContext : HGLRC;
ErrorCode: GLenum;
public
{ Public declarations }
end;
var
Form2: TForm2;
implementation
{$R *.dfm}
procedure TForm2.FormCreate(Sender: TObject);
var
pfd: TPixelFormatDescriptor;
FormatIndex: integer;
begin
fillchar(pfd,SizeOf(pfd),0);
with pfd do
begin
nSize := SizeOf(pfd);
nVersion := 1; {The current version of the desccriptor is 1}
dwFlags := PFD_DRAW_TO_WINDOW or PFD_SUPPORT_OPENGL;
iPixelType := PFD_TYPE_RGBA;
cColorBits := 24; {support 24-bit color}
cDepthBits := 32; {depth of z-axis}
iLayerType := PFD_MAIN_PLANE;
end; {with}
FormatIndex := ChoosePixelFormat(Canvas.Handle,#pfd);
SetPixelFormat(Canvas.Handle,FormatIndex,#pfd);
GLContext := wglCreateContext(Canvas.Handle);
wglMakeCurrent(Canvas.Handle,GLContext);
end; {FormCreate}
procedure TForm2.FormDestroy(Sender: TObject);
begin
wglMakeCurrent(Canvas.Handle,0);
wglDeleteContext(GLContext);
end;
procedure TForm2.FormPaint(Sender: TObject);
begin
{background}
glClearColor(0.0,0.4,0.0,0.0);
glClear(GL_COLOR_BUFFER_BIT);
{error checking}
errorCode := glGetError;
if errorCode<>GL_NO_ERROR then
raise Exception.Create('Error in Paint'#13+
gluErrorString(errorCode));
end;
end.
Since you request a single buffered context, you must call glFinish at the end of the rendering code, to commit your drawing commands to the implementation. However I strongly suggest you switch to using a double buffered context and instead of glFinish-ing you issue a wglSwapBuffers which implies a finish.

Resources