THotkey with win-key support? - delphi

Is there anyway to get the THotkey component in delphi to support the windows key?
Or does anyone know of a component that can do this?
Thanks heaps!

IMHO it is a good thing THotKey does not support this.
Don't use the windows key for keyboard shortcuts in your program, the "Windows Vista User Experience Guidelines" says the following under Guidelines - Interaction - Keyboard:
Don't use the Windows logo modifier key for program shortcut keys. Windows logo key is reserved for Windows use. Even if a Windows logo key combination isn't being used by Windows now, it may be in the future.
Even if the shortcut isn't used by Windows, using such a keyboard shortcut would be confusing to users, as it would perform a function in your program, while other such shortcuts like Win+E or Win+R activate a system-wide function, deactivating your program in the process.
Edit:
THotKey is a light wrapper around a system control, supporting only the things that this system control supports. There is no documented way to set anything but the Alt, Ctrl and Shift modifiers for the shortcut.
You might be able to create your own control to display shortcuts using the Windows key, and set a global keyboard hook (look into the SetWindowsHookEx() API function).

I don't know if you can do it with the THotkey component.
But you can capture the left and right Windows Key in any KeyDown event using:
if key = vk_LWin then showmessage('left');
if key = vk_RWin then showmessage('right');

Sure its possible - you need to make your own copy of { THotKey } and tweak it a little to support also Win key. You need to add your own KeyDown() and Repaint() functions to this class .
Like this:
TMyCustomHotKey = class(TWinControl)
public
WinKey: boolean;
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
constructor Create(AOwner: TComponent); override;
end;
TMyHotKey = class(TMyCustomHotKey)
..
procedure TMyCustomHotKey.KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
var
a : integer;
lbl : string;
tmphot : tshortcut;
begin
a:= 0;
if GetAsyncKeyState(VK_LWIN) <> 0 then a:= 1;
if GetAsyncKeyState(VK_RWIN) <> 0 then a:= 1;
if a=1 then begin
winkey := true;
end else
begin
winkey := false;
end;
rePaint();
}
procedure TMyCustomHotKey.WMPaint(var Message: TWMPaint);
var
PS: TPaintStruct;
DC: HDC;
Canvas: TCanvas;
i: Integer;
X, Y: Integer;
OldColor: TColor;
Size: TSize;
Max: Integer;
s, Palabra, PrevWord: string;
OldPen, DrawPen: HPEN;
tmphot : tshortcut;
Key: Word;
Shift: TShiftState;
lbl ,res: string;
keyboardState: TKeyboardState;
asciiResult: Integer;
begin
DC := Message.DC;
if DC = 0 then DC := BeginPaint(Handle, PS);
Canvas := TCanvas.Create;
try
OldColor := Font.Color;
Canvas.Handle := DC;
Canvas.Font.Name := Font.Name;
Canvas.Font.Size := Font.Size;
with Canvas do
begin
Brush.Color := Self.Color;
FillRect(Self.ClientRect);
Font.Color := OldColor;
tmphot := gethotkey;
ShortCutToKey(tmphot, Key, Shift);
res := GetCharFromVKey(key);
if (winkey = false) and (key = 0 ) and (tmphot = 0)then
BEGIN lbl := 'Enter hotkey [CTRL/ALT/WIN] + Key' ;
TextOut(1 ,1,lbl) ;
END
else begin
if winkey then lbl := 'Win +' else lbl := '';
if ssAlt in Shift then lbl := lbl+ 'Alt + ';
if ssShift in Shift then lbl := lbl+ 'Shift + ';
if (not winkey) and (ssCtrl in Shift) then lbl := lbl+ 'Ctrl + ';
lbl := lbl+ res;
end;
TextOut(1 ,1,lbl);
end;
finally
if Message.DC = 0 then EndPaint(Handle, PS);
end;
Canvas.Free;
SETCARETPOS(1,1);
end;

See RegisterHotKey function on MSDN.

THotKey doesn't support the Win-Key. I would add a check box next to it maybe for the Win-Key modifier.

Related

Display Multiple Balloons conditionally using Windows API - System Tray Icon in Delphi

I wrote a program that can identify outdated software in a Windows System and update them by interacting with the user.
It has a Software Updater Program which displays a System Tray Icon and show Balloon Tips about Available / Downloading Updates and Software installed in the System.
The problem is It can't show multiple Balloon Tips when each task is processing by it. Such as, when an update is available for a Software, it should remember user showing a balloon like An update for Software Name is available. and when user choose to download and minimize it to system tray again, the balloon tip should again show something like Updates are downloading...Click to view the Progress of Downloads.
However I like to know how can I do this by using only one System Tray Icon?
Can I use the NIM_MODIFY Flag again and again to change the Balloon Tip according to the current state of the Program?
I searched about this and I found some examples, but for Visual Studio and C++.
That's how I tried to show Multiple Tips when the Program is running:
unit MainForm-1;
...
const
NIF_INFO = $10;
NIF_MESSAGE = 1;
NIF_ICON = 2;
NOTIFYICON_VERSION = 3;
NIF_TIP = 4;
NIM_SETVERSION = $00000004;
NIM_SETFOCUS = $00000003;
NIIF_INFO = $00000001;
NIIF_WARNING = $00000002;
NIIF_ERROR = $00000003;
NIN_BALLOONSHOW = WM_USER + 2;
NIN_BALLOONHIDE = WM_USER + 3;
NIN_BALLOONTIMEOUT = WM_USER + 4;
NIN_BALLOONUSERCLICK = WM_USER + 5;
NIN_SELECT = WM_USER + 0;
NINF_KEY = $1;
NIN_KEYSELECT = NIN_SELECT or NINF_KEY;
TRAY_CALLBACK = WM_USER + $7258;
PNewNotifyIconData = ^TNewNotifyIconData;
TDUMMYUNIONNAME = record
case Integer of
0: (uTimeout: UINT);
1: (uVersion: UINT);
end;
TNewNotifyIconData = record
cbSize: DWORD;
Wnd: HWND;
uID: UINT;
uFlags: UINT;
uCallbackMessage: UINT;
hIcon: HICON;
szTip: array [0..127] of Char;
dwState: DWORD; /
dwStateMask: DWORD;
szInfo: array [0..255] of Char;
DUMMYUNIONNAME: TDUMMYUNIONNAME;
szInfoTitle: array [0..63] of Char;
dwInfoFlags: DWORD;
end;
type
MainForm-1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
IconData: TNewNotifyIconData;
procedure SysTrayIconMessageHandler(var Msg: TMessage); message TRAY_CALLBACK;
procedure AddSysTrayIcon;
procedure ShowBalloonTips;
procedure DeleteSysTrayIcon;
public
end;
var
MainForm-1: TForm;
implementation
uses
ShellAPI...,.....,;
procedure MainForm-1.SysTrayIconMessageHandler(var Msg: TMessage);
begin
case Msg.lParam of
WM_MOUSEMOVE:;
WM_LBUTTONDOWN:;
WM_LBUTTONUP:;
WM_LBUTTONDBLCLK:;
WM_RBUTTONDOWN:;
WM_RBUTTONUP:;
WM_RBUTTONDBLCLK:;
NIN_BALLOONSHOW:;
NIN_BALLOONHIDE:;
NIN_BALLOONTIMEOUT:
NIN_BALLOONUSERCLICK:;
end;
end;
procedure MainForm-1.AddSysTrayIcon;
begin
IconData.cbSize := SizeOf(IconData);
IconData.Wnd := AllocateHWnd(SysTrayIconMessageHandler);
IconData.uID := 0;
IconData.uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP;
IconData.uCallbackMessage := TRAY_CALLBACK;
IconData.hIcon := Application.Icon.Handle;
IconData.szTip := 'Software Updater is running';
if not Shell_NotifyIcon(NIM_ADD, #IconData) then
ShowMessage('System Tray Icon cannot be created.');
end;
procedure MainForm-1.DisplayBalloonTips;
var
TipInfo, TipTitle: string;
begin
IconData.cbSize := SizeOf(IconData);
IconData.uFlags := NIF_INFO;
if ssHelperState = UpdatesAvailable then TipInfo := 'Updates are available to the programs installed on your Computer' + ' Click to see details.';
if ssHelperState = UpdatesDownloading then TipInfo := 'Updates are downloading in the background. Click to view the details.';
strPLCopy(IconData.szInfo, TipInfo, SizeOf(IconData.szInfo) - 1);
IconData.DUMMYUNIONNAME.uTimeout := 2500;
if ssHelperState = UpdatesAvailable then TipTitle := 'Updates are Available...';
if ssHelperState = UpdatesDownloading then TipTitle := 'Downloading the Updates...';
strPLCopy(IconData.szInfoTitle, TipTitle, SizeOf(IconData.szInfoTitle) - 1);
IconData.dwInfoFlags := NIIF_INFO;
Shell_NotifyIcon(NIM_MODIFY, #IconData);
{Following code is for testing purpose.}
IconData.DUMMYUNIONNAME.uVersion := NOTIFYICON_VERSION;
if not Shell_NotifyIcon(NIM_SETVERSION, #IconData) then
ShowMessage('Setting the Version is Failed.');
end;
procedure MainForm-1.DeleteSysTrayIcon;
begin
DeallocateHWnd(IconData.Wnd);
if not Shell_NotifyIcon(NIM_DELETE, #IconData) then
ShowMessage('Unable to delete System Tray Icon.');
end;
procedure MainForm-1.FormCreate(Sender: TObject);
begin
AddSysTrayIcon;
ShowBalloonTips;
end;
procedure MainForm-1.FormDestroy(Sender: TObject);
begin
DeleteSysTrayIcon;
end;
...
end.
But, this is failing and I keep getting the same Balloon Tip (First One) again and again when the Program is running.......
I don't know how to use NIN_BALLOONSHOW and NIN_BALLOONHIDE Flags correctly. So, Thanks in Advance for Your Important Help.
Why are you declaring everything manually? Delphi 2009 already has declarations for the Shell_NotifyIcon() API. They are in the ShellAPI unit. It declares just about everything you are trying to use, except for the uVersion field (that was added in Delphi 2010). You are not using the guidItem and hBalloonIcon fields, so let's not worry about them here. The uTimeout field exists, and since it is wrapped in a union with uVersion, the data size does not change, so you can just use uTimeout when you want to use uVersion (or you can define your own union and type-cast the field, but that is overkill). You certainly do not need to redeclare the entire API.
You are reusing the same IconData variable each time you call Shell_NotifyIcon(), which is fine, but you are not clearing the szTip and szInfoTitle fields if your helper state is not UpdatesAvailable or UpdatesDownloading, so the tray icon keeps displaying the last tip/balloon you have set. You need to clear those fields when you don't need tips/balloons anymore.
NIN_BALLOONSHOW and NIN_BALLOONHIDE are not flags. They are notifications that are sent to your tray icon's registered HWND. To receive the notifications, you need to fill in the Wnd and uCallbackMessage fields and enable the NIF_MESSAGE flag.
Also, you need to handle the WM_TASKBARCREATED message. If Explorer gets restarted for any reason (crashes, or is killed by the user), the Taskbar gets re-created, so you have to re-add your tray icon again.
Also, make sure your message handler passes any unhandled window messages to DefWindowProc(), or you can lock up the system, or at least your app.
And lastly, Delphi 2009 is a Unicode version of Delphi, but there are some sections of your code that are not handling Unicode correctly. Specifically, when populating szTip and szInfoTitle using StrPLCopy(), you need to use Length() instead of SizeOf(). The copy is expressed in number of characters, not number of bytes.
With that said, try something more like this:
unit MainForm1;
interface
uses
..., ShellAPI;
type
eHelperState = (Idle, UpdatesAvailable, UpdatesDownloading);
MainForm = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
TaskbarCreatedMsg: UINT;
IconData: NOTIFYICONDATA;
IconAdded: Boolean;
ssHelperState: eHelperState;
procedure SysTrayIconMessageHandler(var Message: TMessage);
procedure AddSysTrayIcon;
procedure ShowBalloonTips;
procedure DeleteSysTrayIcon;
procedures SetHelperState(NewState: eHelperState);
...
end;
var
MainForm: TForm;
implementation
const
TRAY_CALLBACK = WM_USER + $7258;
{$IF RTLVersion < 21}
NOTIFYICON_VERSION_4 = 4;
{$IFEND}
procedure MainForm.FormCreate(Sender: TObject);
begin
TaskbarCreatedMsg := RegisterWindowMessage('TaskbarCreated');
IconData.cbSize := SizeOf(IconData);
IconData.Wnd := AllocateHWnd(SysTrayIconMessageHandler);
IconData.uID := 1;
AddSysTrayIcon;
end;
procedure MainForm.FormDestroy(Sender: TObject);
begin
DeleteSysTrayIcon;
DeallocateHWnd(IconData.Wnd);
end;
procedure MainForm.AddSysTrayIcon;
begin
IconData.uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP;
IconData.uCallbackMessage := TRAY_CALLBACK;
IconData.hIcon := Application.Icon.Handle;
StrLCopy(IconData.szTip, 'Software Updater is running', Length(IconData.szTip));
IconAdded := Shell_NotifyIcon(NIM_ADD, #IconData);
if not IconAdded then
begin
ShowMessage('Unable to add System Tray Icon.');
Exit;
end;
if CheckWin32Version(5, 0) then
begin
IconData.{$IF RTLVersion >= 21}uVersion{$ELSE}uTimeout{$IFEND} := NOTIFYICON_VERSION_4;
if not Shell_NotifyIcon(NIM_SETVERSION, #IconData) then
ShowMessage('Unable to set version for System Tray Icon.');
end;
end;
procedure MainForm.DisplayBalloonTips;
var
Tip, InfoText, InfoTitle: string;
begin
if not IconAdded then Exit;
case ssHelperState of
UpdatesAvailable: begin
Tip := 'Updates are Available. Click to see details.';
InfoText := 'Updates are available to the programs installed on your Computer. Click to see details.';
InfoTitle := 'Updates are Available';
end;
UpdatesDownloading: begin
Tip := 'Downloading Updates. Click to see details.';
InfoText := 'Updates are downloading in the background. Click to see details.';
InfoTitle := 'Downloading Updates';
end;
else
Tip := 'Software Updater is running';
end;
IconData.uFlags := NIF_TIP or NIF_INFO;
StrPLCopy(IconData.szTip, Tip, Length(IconData.szTip));
StrPLCopy(IconData.szInfo, InfoText, Length(IconData.szInfo));
StrPLCopy(IconData.szInfoTitle, InfoTitle, Length(IconData.szInfoTitle));
IconData.uTimeout := 2500;
IconData.dwInfoFlags := NIIF_INFO;
if not Shell_NotifyIcon(NIM_MODIFY, #IconData) then
ShowMessage('Unable to update System Tray Icon.')
end;
procedure MainForm.DeleteSysTrayIcon;
begin
if IconAdded then
begin
IconAdded := False;
if not Shell_NotifyIcon(NIM_DELETE, #IconData) then
ShowMessage('Unable to delete System Tray Icon.');
end;
end;
procedures MainForm.SetHelperState(NewState: eHelperState);
begin
if ssHelperState <> NewState then
begin
ssHelperState := NewState;
DisplayBalloonTips;
end;
end;
procedure MainForm.SysTrayIconMessageHandler(var Message: TMessage);
begin
if Message.Msg = TRAY_CALLBACK then
begin
case LOWORD(Message.LParam) of
WM_MOUSEMOVE: begin
//...
end;
WM_LBUTTONDBLCLK,
NIN_BALLOONUSERCLICK: begin
// display status window...
end;
WM_CONTEXTMENU,
NIN_KEYSELECT,
NIN_SELECT: begin
// display popup menu at coordinates specified by Msg.WParam...
end;
NIN_BALLOONSHOW:;
NIN_BALLOONHIDE:;
NIN_BALLOONTIMEOUT:;
end;
end
else if (Message.Msg = TaskbarCreatedMsg) and (TaskbarCreatedMsg <> 0) then
begin
IconAdded := False;
AddSysTrayIcon;
DisplayBalloonTips;
end
else begin
Message.Result := DefWindowProc(IconData.Wnd, Message.Msg, Message.WParam, Message.LParam);
end;
end;
...
end.

Tabs and colored lines in Listbox

I am using a Tabbed Listbox component that was written by Fredric Rylander back in 1999 and it has been serving me well since then. :) Can't seem to find him anymore.
I now have an application that needs both Tabbed Data and alternating colored lines in the Listbox.
I can include the Component here for perusal if desired.
I tried coloring the lines from here
http://delphi.about.com/cs/adptips2002/a/bltip0602_4.htm
But then it eats the Tabs, but I do get the alternating colored lines.
Can someone please show me how to incorporate the two.
Thanks
Here's the Component
unit myListBoxTabbed;
{
Copyright © 1999 Fredric Rylander
You can easily add a header control to this list box: drop a header
control onto the form (it's default align property is set to alTop, if
it's not--set it); then set the myTabbedListBox's aligned property
to alClient; now, add the following two events and their code.
1) HeaderControl's OnSectionResize event:
var
i, last: integer;
begin
last := 0;
for i:=0 to HeaderControl1.Sections.Count-1 do begin
last := last + HeaderControl1.Sections[i].Width;
myTabbedListBox1.TabStops[i] := last;
end;
end;
2) Main form's OnCreate event:
var
i, last: integer;
begin
last := 0;
for i:=0 to HeaderControl1.Sections.Count-1 do begin
last := last + HeaderControl1.Sections[i].Width;
myTabbedListBox1.TabStops[i] := last;
end;
for i:=HeaderControl1.Sections.Count to MaxNumSections do
myTabbedListBox1.TabStops[i] := 2000;
end;
To get tab characters into the list box items either use the
string list property editor in the Delphi GUI and press
Ctrl + Tab or add tab characters (#9) in strings as so:
myTabbedListBox1.Items.Add( Edit1.Text + #9 + Edit2.Text );
I hope you find this tutorial helpful! :^)
(!) This is not a retail product, it's a tutorial and don't claim to
meet a potential user's demands.
If you find anything that seems odd (or incorrect even) don't hesitate to
write me a line. You can communicate with me at fredric#rylander.nu.
The source is available for you to use, abuse, modify and/or improve.
Happy trails!
/ Fredric
___________________________________F_r_e_d_r_i_c__R_y_l_a_n_d_e_r__
fredric#rylander.nu : www.rylander.nu : 6429296#pager.mirabilis.com
"power to the source sharing community"
}
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TTabsArray = array[0..9] of integer;
type
TmyTabbedListBox = class( TListBox )
private
{ Private declarations }
fTabStops: TTabsArray;
function GetTabStops( iIndex: integer ): integer;
procedure SetTabStops( iIndex, iValue: integer);
function GetTabsString: string;
procedure SetTabsString( const sValue: string );
protected
{ Protected declarations }
procedure UpdateTabStops;
public
{ Public declarations }
procedure CreateParams( var cParams: TCreateParams ); override;
procedure CreateWnd; override;
property TabStops[ iIndex: integer ]: integer
read GetTabStops write SetTabStops;
published
{ Published declarations }
property TabsString: string
read GetTabsString write SetTabsString;
end;
procedure Register;
resourcestring
STR_ALPHA_UPPERLOWER = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz';
CHAR_SEMICOLON = ';';
implementation
procedure Register;
begin
RegisterComponents('Additional', [TmyTabbedListBox]);
end;
{ myTabbedListBox }
procedure TmyTabbedListBox.CreateParams(var cParams: TCreateParams);
begin
inherited CreateParams( cParams );
// add the window style LBS_USETABSTOPS to accept tabs
cParams.Style := cParams.Style or LBS_USETABSTOPS;
end;
procedure TmyTabbedListBox.CreateWnd;
var
i: integer;
begin
inherited CreateWnd;
// set all the tabs into the box
for i := Low( fTabStops ) to High( fTabStops ) do
fTabStops[i] := i * 100;
// show the real tab positions
UpdateTabStops;
end;
function TmyTabbedListBox.GetTabsString: string;
var
sBuffer: string;
i: integer;
begin
// init var
sBuffer := SysUtils.EmptyStr;
// set all tabstops to the string (separated by ';'-char)
for i := Low( fTabStops ) to High( fTabStops ) do
sBuffer := sBuffer + IntToStr( fTabStops[i] ) + CHAR_SEMICOLON;
// and here we have the results
Result := sBuffer;
end;
function TmyTabbedListBox.GetTabStops( iIndex: integer ): integer;
begin
// nothing funny here
Result := fTabStops[iIndex];
end;
procedure TmyTabbedListBox.SetTabsString( const sValue: string );
var
sBuffer: string;
i, len: integer;
begin
// copy value into buffer
sBuffer := sValue;
// set the tabstops as specified
for i := Low( fTabStops ) to High( fTabStops ) do begin
len := Pos( sBuffer, CHAR_SEMICOLON );
fTabStops[i] := StrToIntDef( Copy( sBuffer, 1, len ), 0 );
Delete( sBuffer, 1, len );
end;
// show/redraw the results
UpdateTabStops;
Invalidate;
end;
procedure TmyTabbedListBox.SetTabStops( iIndex, iValue: integer );
begin
// do we really need to update?
if fTabStops[iIndex] <> iValue then begin
// oki, let's then
fTabStops[iIndex] := iValue;
// show/redraw the results
UpdateTabStops;
Invalidate;
end;
end;
procedure TmyTabbedListBox.UpdateTabStops;
var
i, iHUnits: integer;
arrConvertedTabs: TTabsArray;
begin
// convert dialog box units to pixels.
// dialog box unit = average character width/height div 4/8
// determine the horizontal dialog box units used by the
// list box (which depend on its current font)
Canvas.Font := Font;
iHUnits := Canvas.TextWidth( STR_ALPHA_UPPERLOWER ) div 52;
// convert the array of tab values
for i := Low( arrConvertedTabs ) to High( arrConvertedTabs ) do
arrConvertedTabs[i] := ( fTabStops[i] * 4 ) div iHUnits;
// activate the tabs stops in the list box,
// sending a Windows list box message
SendMessage( Handle, LB_SETTABSTOPS,
1 + High( arrConvertedTabs ) - Low( arrConvertedTabs ),
LongInt( #arrConvertedTabs ) );
end;
end.
Here's an example using a standard TListBox and it's OnDrawItem event, based on the code from the link you provided and tested in Delphi 2007. Note you need to set the ListBox.Style to lbOwnerDrawFixed. You can perhaps use this as a base for modifying the component (or just abandon it altogether).
procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
var
LB: TListBox;
NewColor: TColor;
NewBrush: TBrush;
R: TRect;
Fmt: Cardinal;
ItemText: string;
begin
NewBrush := TBrush.Create;
LB := (Control as TListBox);
if (odSelected in State) then
begin
NewColor := LB.Canvas.Brush.Color;
end
else
begin
if not Odd(Index) then
NewColor := clSilver
else
NewColor := clYellow;
end;
NewBrush.Style := bsSolid;
NewBrush.Color := NewColor;
// This is the ListBox.Canvas brush itself, not to be
// confused with the NewBrush we've created above
LB.Canvas.Brush.Style := bsClear;
R := Rect;
ItemText := LB.Items[Index];
Fmt := DT_EXPANDTABS or DT_CALCRECT or DT_NOCLIP;
DrawText(LB.Canvas.Handle, PChar(ItemText), Length(ItemText),
R, Fmt);
// Note we need to FillRect on the original Rect and not
// the one we're using in the call to DrawText
Windows.FillRect(LB.Canvas.Handle, Rect, NewBrush.Handle) ;
DrawText(LB.Canvas.Handle, PChar(ItemText), Length(ItemText),
R, DT_EXPANDTABS);
NewBrush.Free;
end;
Here's the output of the above code:

Numeric edit control with flat button inside and no calculator

I'm writing a C++ project with RAD Studio, but this also applies to Delphi.
I need an edit control where user can only enter floats (2 decimal places) and can restore the original value (taken from a variable, not important here) clilcking on a button (actullay an icon) inside the edit control itself.
This is what I've done, using a TJvCalcEdit from JEDI library.
Control definition:
object Sconto1: TJvCalcEdit
[non-important attributes...]
ButtonFlat = True
Glyph.Data = {
D6020000424DD6020000000000003600000028000000100000000E0000000100
180000000000A0020000130B0000130B00000000000000000000FFFFFFFFFFFF
FFFFFFFFFFFFFFFFFF999EC29396C3FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9198C48694CBA7BAFE8493CA72
75B9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF8B96C5
8695CBA7BAFEA7BAFEA7BAFEA7BAFE747EB66D71B5FFFFFFFFFFFFFFFFFFFFFF
FFFFFFFFFFFFFFFFFFFF8493CAA7BAFEA7BAFEA7BAFEA7BAFEA7BAFEA7BAFE84
93CA7E83CE6D71B4FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF8F94C3A7BAFE
A7BAFEA7BAFEA7BAFEA7BAFEA7BAFE8492CA8288D27B7FCA6D71B4FFFFFFFFFF
FFFFFFFFFFFFFFFFFFFFFFFFFF8492CAA7BAFEA7BAFEA7BAFE828ECA7B82C993
96FA6D6FB67B7FCA7B7FCA6D6FB4FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9299C2
A5B7FE7E88CA787DC99396FA9396FA9396FA9396FA6D6FB67B7FCA7B7FCA6D6F
B4FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF7678C89396FA9396FA9396FA9396FA93
96FA9396FA9396FA6D6FB67B7FCA7B7FCA6C6FB3FFFFFFFFFFFFFFFFFFFFFFFF
FFFFFF7678C89396FA9396FA9396FA9396FA9396FA9396FA9396FA6D6FB67B7F
CA7B7FCA7576B0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF7678C89396FA9396FA93
96FA9396FA9396FA9396FA9396FA6D6FB67B7FCA6266A2D6D0E2FFFFFFFFFFFF
FFFFFFFFFFFFFFFFFF7678C89396FA9396FA9396FA9396FA9396FA9396FA9396
FA6D6FB67B7FCA7C7EB0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF7678C893
96FA9396FA9396FA9396FA9396FA9396FA9396FA7679C66B6DACFFFFFFFFFFFF
FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF7678C89396FA9396FA9093F58B8EEC7678
C87C7FC6ACABE5FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
FFFF7678C88283C5A4A4E7C4C1EBFFFFFFFFFFFFFFFFFFFFFFFF}
ImageKind = ikCustom
DecimalPlacesAlwaysShown = False
OnButtonClick = EScontoButtonClick
end
Method called on button click:
void __fastcall TFRigOrd::EScontoButtonClick(TObject *Sender)
{
TJvCalcEdit* edit = dynamic_cast<TJvCalcEdit*>(Sender);
edit->Value = oldSconto1;
}
The problem: at the end of this method a calculator popup appears below the control, requiring an action by the user. I don't want this to happen because I'm changing the value programmatically. I guess it's a default value due to the fact that such button is made for triggering the calculator. Moreover the value you see (255) appears without decimal point, with will be shown only once the calculator is closed.
So, can I disable this behaviour? Or can someone suggest me a solution with another control (standard, open source or free anyway)?
I'd use a TButtonedEdit to get the button, and to enforce floating-point input with a maximum of two decimals after the point, I'd do
TButtonedEdit = class(ExtCtrls.TButtonedEdit)
protected
procedure KeyPress(var Key: Char); override;
procedure WMPaste(var Message: TWMPaste); message WM_PASTE;
end;
...
procedure TButtonedEdit.KeyPress(var Key: Char);
function InvalidInput: boolean;
var
dc: integer;
begin
result := false;
if Character.IsControl(Key) then Exit;
dc := Pos(DecimalSeparator, Text);
if not (Key in ['0'..'9', DecimalSeparator]) then Exit(true);
if Pos(DecimalSeparator, Text) > 0 then
begin
if Key = DecimalSeparator then Exit(true);
if (Length(Text) - dc > 1)
and (Pos(DecimalSeparator, Text) < SelStart + 1) and
(SelLength = 0) then Exit(true);
end;
end;
begin
inherited;
if InvalidInput then
begin
Key := #0;
beep;
end;
end;
procedure TButtonedEdit.WMPaste(var Message: TWMPaste);
var
s: string;
i: integer;
hasdc: boolean;
NewText: string;
NewSelStart: integer;
begin
if Clipboard.HasFormat(CF_TEXT) then
begin
s := Clipboard.AsText;
NewText := Text;
Delete(NewText, SelStart + 1, SelLength);
Insert(s, NewText, SelStart + 1);
// Validate
hasdc := false;
for i := 1 to Length(NewText) do
begin
if NewText[i] = DecimalSeparator then
if hasdc then
begin
beep;
Exit;
end
else
hasdc := true
else if not (NewText[i] in ['0'..'9']) then
begin
beep;
Exit;
end;
end;
// Trim
if hasdc then
NewText := Copy(NewText, 1, Pos(DecimalSeparator, NewText) + 2);
NewSelStart := SelStart + Length(s);
Text := NewText;
SelStart := NewSelStart;
SelLength := 0;
end
else
inherited;
end;
Sample demo EXE
Use stock VCL buttoned editor
http://docwiki.embarcadero.com/Libraries/en/Vcl.ExtCtrls.TButtonedEdit
Use OnChange to filter out wrong input (or use JvValidators)
Another approach, JediVCL-based one, would be to use base button-enabled editor
http://wiki.delphi-jedi.org/wiki/JVCL_Help:TJvComboEdit
This has EditMask property, just like TMaskEdit has, so you can tweak it to accept only digits.
And at very least OnChange event would allow u to filter non-numeric text input as well.

Using the TEdit context menu for TRichEdit

Is there a simple/clever way to load the standard Windows TEdit menu into this TRichEdit?
I know that I could create a simple menu to simulate the TEdit menu for the simple operations like copy/paste etc. (Example), however I would also like to keep the more advanced menu options such as the unicode options, reading order, and to utilize the same localization strings.
Edit: I have found a possible lead (trying to figure it out as I'm not an MFC expert)...
Based on the "possible lead" and a bit of MSDN, I came up with a possible solution.
I'm still unable to resolve the reading order issue (and the unicode options). It seems that it works differently for RichEdit than for Edit, and simply setting or getting the WS_EX_RTLREADING flag does not work as excpected. Anyways, here is the code:
procedure RichEditPopupMenu(re: TRichEdit);
const
IDM_UNDO = WM_UNDO;
IDM_CUT = WM_CUT;
IDM_COPY = WM_COPY;
IDM_PASTE = WM_PASTE;
IDM_DELETE = WM_CLEAR;
IDM_SELALL = EM_SETSEL;
IDM_RTL = $8000; // WM_APP ?
Enables: array[Boolean] of DWORD = (MF_DISABLED or MF_GRAYED, MF_ENABLED);
Checks: array[Boolean] of DWORD = (MF_UNCHECKED, MF_CHECKED);
var
hUser32: HMODULE;
hmnu, hmenuTrackPopup: HMENU;
Cmd: DWORD;
Flags: Cardinal;
HasSelText: Boolean;
FormHandle: HWND;
// IsRTL: Boolean;
begin
hUser32 := LoadLibraryEx(user32, 0, LOAD_LIBRARY_AS_DATAFILE);
if (hUser32 <> 0) then
try
hmnu := LoadMenu(hUser32, MAKEINTRESOURCE(1));
if (hmnu <> 0) then
try
hmenuTrackPopup := GetSubMenu(hmnu, 0);
HasSelText := Length(re.SelText) <> 0;
EnableMenuItem(hmnu, IDM_UNDO, Enables[re.CanUndo]);
EnableMenuItem(hmnu, IDM_CUT, Enables[HasSelText]);
EnableMenuItem(hmnu, IDM_COPY, Enables[HasSelText]);
EnableMenuItem(hmnu, IDM_PASTE, Enables[Clipboard.HasFormat(CF_TEXT)]);
EnableMenuItem(hmnu, IDM_DELETE, Enables[HasSelText]);
EnableMenuItem(hmnu, IDM_SELALL, Enables[Length(re.Text) <> 0]);
// IsRTL := GetWindowLong(re.Handle, GWL_EXSTYLE) and WS_EX_RTLREADING <> 0;
// EnableMenuItem(hmnu, IDM_RTL, Enables[True]);
// CheckMenuItem(hmnu, IDM_RTL, Checks[IsRTL]);
FormHandle := GetParentForm(re).Handle;
Flags := TPM_LEFTALIGN or TPM_RIGHTBUTTON or TPM_NONOTIFY or TPM_RETURNCMD;
Cmd := DWORD(TrackPopupMenu(hmenuTrackPopup, Flags,
Mouse.CursorPos.X, Mouse.CursorPos.Y, 0, FormHandle, nil));
if Cmd <> 0 then
begin
case Cmd of
IDM_UNDO: re.Undo;
IDM_CUT: re.CutToClipboard;
IDM_COPY: re.CopyToClipboard;
IDM_PASTE: re.PasteFromClipboard;
IDM_DELETE: re.ClearSelection;
IDM_SELALL: re.SelectAll;
IDM_RTL:; // ?
end;
end;
finally
DestroyMenu(hmnu);
end;
finally
FreeLibrary(hUser32);
end;
end;
procedure TForm1.RichEditEx1ContextPopup(Sender: TObject; MousePos: TPoint; var Handled: Boolean);
begin
RichEditPopupMenu(TRichEdit(Sender));
Handled := True;
end;
Any feedback would be nice :)

How do you drag and drop a file from Explorer Shell into a VirtualTreeView control in a Delphi application?

There is extensive drag and drop support in VirtualTreeView by Mike Lischke, and I am using TVirtualStringTree, which has some on-drag-and-drop events, but I can not figure out how to get it to accept a shell drag-and-drop of some files from the windows explorer shell, into my application. I want to load the files, when they are dragged onto the drop control.
I tried using a third-party set of code from Anders Melander, to handle drag and drop, but because VirtualTreeView already registers itself as a drop target, I can't use that.
edit: I found a simple workaround: Turn off toAcceptOLEDrop in VT.TreeOptions.MiscOptions.
It would be cool if anybody knows a way to use VirtualTreeView without using a third party OLE-shell-drag-drop library and using its extensive OLE drag/drop support to extract a list of filenames dragged in from the Shell.
My implementation (Works very well with Delphi 2010. Must add ActiveX, ShellApi to uses to compile):
procedure TfMain.vstTreeDragDrop(Sender: TBaseVirtualTree; Source: TObject;
DataObject: IDataObject; Formats: TFormatArray; Shift: TShiftState;
Pt: TPoint; var Effect: Integer; Mode: TDropMode);
var
I, j: Integer;
MyList: TStringList;
AttachMode: TVTNodeAttachMode;
begin
if Mode = dmOnNode then
AttachMode := amInsertBefore
else if Mode = dmAbove then
AttachMode := amInsertBefore
else if Mode = dmBelow then
AttachMode := amInsertAfter
else
AttachMode := amAddChildLast;
MyList := TStringList.Create;
try
for i := 0 to High(formats) - 1 do
begin
if (Formats[i] = CF_HDROP) then
begin
GetFileListFromObj(DataObject, MyList);
//here we have all filenames
for j:=0 to MyList.Count - 1 do
begin
Sender.InsertNode(Sender.DropTargetNode, AttachMode);
end;
end;
end;
finally
MyList.Free;
end;
end;
procedure TfMain.GetFileListFromObj(const DataObj: IDataObject;
FileList: TStringList);
var
FmtEtc: TFormatEtc; // specifies required data format
Medium: TStgMedium; // storage medium containing file list
DroppedFileCount: Integer; // number of dropped files
I: Integer; // loops thru dropped files
FileNameLength: Integer; // length of a dropped file name
FileName: string; // name of a dropped file
begin
// Get required storage medium from data object
FmtEtc.cfFormat := CF_HDROP;
FmtEtc.ptd := nil;
FmtEtc.dwAspect := DVASPECT_CONTENT;
FmtEtc.lindex := -1;
FmtEtc.tymed := TYMED_HGLOBAL;
OleCheck(DataObj.GetData(FmtEtc, Medium));
try
try
// Get count of files dropped
DroppedFileCount := DragQueryFile(
Medium.hGlobal, $FFFFFFFF, nil, 0
);
// Get name of each file dropped and process it
for I := 0 to Pred(DroppedFileCount) do
begin
// get length of file name, then name itself
FileNameLength := DragQueryFile(Medium.hGlobal, I, nil, 0);
SetLength(FileName, FileNameLength);
DragQueryFileW(
Medium.hGlobal, I, PWideChar(FileName), FileNameLength + 1
);
// add file name to list
FileList.Append(FileName);
end;
finally
// Tidy up - release the drop handle
// don't use DropH again after this
DragFinish(Medium.hGlobal);
end;
finally
ReleaseStgMedium(Medium);
end;
end;
I use this method to capture (receive) files dragged into a TWinControl from explorer.
You can test it on your control. In a standard TTreeView work fine.
Add ShellAPI to uses.
At private section:
private
originalEditWindowProc : TWndMethod;
procedure EditWindowProc(var Msg:TMessage);
// accept the files dropped
procedure FilesDrop(var Msg: TWMDROPFILES);
At OnCreate of your form:
// Assign procedures
originalEditWindowProc := TreeView1.WindowProc;
TreeView1.WindowProc := EditWindowProc;
// Aceptar ficheros arrastrados // Accept the files
ShellAPI.DragAcceptFiles(TreeView1.Handle, True);
And the two procedure are these:
// Al arrastrar ficheros sobre el TV. On drop files to TV
procedure TForm1.FilesDrop(var Msg: TWMDROPFILES);
var
i:Integer;
DroppedFilename:string;
numFiles : longInt;
buffer : array[0..MAX_PATH] of char;
begin
// Número de ficheros arrastrados // Number of files
numFiles := DragQueryFile(Msg.Drop, $FFFFFFFF, nil, 0) ;
// Recorrido por todos los arrastrados // Accept all files
for i := 0 to (numFiles - 1) do begin
DragQueryFile(Msg.Drop, i, #buffer, sizeof(buffer));
// Proteccion
try
DroppedFilename := buffer;
// HERE you can do something with the file...
TreeView1.Items.AddChild(nil, DroppedFilename);
except
on E:Exception do begin
// catch
end;
end;
end;
end;
procedure TForm1.EditWindowProc(var Msg: TMessage);
begin
// if correct message, execute the procedure
if Msg.Msg = WM_DROPFILES then begin
FilesDrop(TWMDROPFILES(Msg))
end
else begin
// in other case do default...
originalEditWindowProc(Msg) ;
end;
end;
I hope that this are usefull for you.
Regards.

Resources