I am trying to create an open dialog (in Windows 7) where the user is confined to the initial directory. On the open dialog I have set the optionsEX to [ofExNoPlacesBar] and that removes the bar that would let them select folders and directories to go to quickly but the user can use the bread crumb address tool to go up a level and type a different directory into the filename text box to change directories.
Thank you
If you are using Delphi 2009+, there is a TFileOpenDialog. Use this, and set
procedure TForm3.FileOpenDialog1FolderChange(Sender: TObject);
begin
FInitiated := true;
end;
procedure TForm3.FileOpenDialog1FolderChanging(Sender: TObject;
var CanChange: Boolean);
begin
CanChange := not FInitiated;
end;
procedure TForm3.btnOpenClick(Sender: TObject);
begin
FInitiated := false;
FileOpenDialog1.DefaultFolder := 'C:\MyFolder\';
FileOpenDialog1.Execute;
end;
where
var
FInitiated: boolean;
(Notice that there should be exactly one FInitiated per TFileOpenDialog. So, if FileOpenDialog is a private member of TForm3, let FInitiated be a private member of TForm3 as well.)
To improve the user experience, you will probably use
procedure TForm3.FileOpenDialog1FolderChanging(Sender: TObject;
var CanChange: Boolean);
begin
CanChange := not FInitiated;
if not CanChange then beep;
end;
or
procedure TForm3.FileOpenDialog1FolderChanging(Sender: TObject;
var CanChange: Boolean);
begin
CanChange := not FInitiated;
if not CanChange then
MessageBox(Handle, PChar('Directory selection is not allowed.'), PChar(Caption), MB_ICONINFORMATION);
end;
Use a different open dialog (make a form yourself with no folder navigation, only a file list box), or simply audit for a path not matching the initial dir and refuse to actually open the file.
The 'FileOpenDialog' has an OnFolderChanging event of type TFileDialogFolderChangingEvent which have a boolean CanChange parameter. I'd expect setting this parameter to false would serve the purpose.
edit:
Example usage as per Remy's comments (if I understood correctly);
procedure TForm1.FileOpenDialog1FolderChanging(Sender: TObject;
var CanChange: Boolean);
var
Dlg: TFileOpenDialog;
DefFolder: IShellItem;
iOrder: Integer;
begin
CanChange := False;
Dlg := Sender as TFileOpenDialog;
if Succeeded(SHCreateItemFromParsingName(PWideChar(WideString(Dlg.DefaultFolder)), nil, IShellItem, DefFolder)) then
try
CanChange := Dlg.ShellItem.Compare(DefFolder, SICHINT_ALLFIELDS, iOrder) = S_OK;
finally
DefFolder := nil;
end;
end;
The below also works but more vulnerable to path variations (see Andreas' comments below);
procedure TForm1.FileOpenDialog1FolderChanging(Sender: TObject;
var CanChange: Boolean);
begin
CanChange := SameFileName(TFileOpenDialog(Sender).FileName,
TFileOpenDialog(Sender).DefaultFolder);
end;
Related
I use a custom listview component and I need it to have a popupmenu item "copy data to clipboard". If there is no assigned popup, I create one and add the menuitem, if there is already a menu assigned, add the item to the current popup. Tried to put the code in the constructor, but then I realized, that popupmenu is still not created or associated to my listview. So any idea when to create my default item?
constructor TMyListView.Create(AOwner: TComponent);
var
FpopupMenu: TPopupMenu;
begin
inherited;
.....
FPopUpMenuItem := TMenuItem.Create(self);
FPopUpMenuItem.Caption := 'Copy data to clipboard';
FPopUpMenuItem.OnClick := PopupMenuItemClick;
if assigned(PopupMenu) then begin
popupMenu.Items.Add(FPopUpMenuItem);
end
else begin
FpopupMenu := TPopupMenu.Create(self);
FpopupMenu.Items.Add(FPopUpMenuItem);
PopupMenu := FpopupMenu;
end;
...
end;
Override the virtual TControl.DoContextPopup() method, eg:
type
TMyListView = class(TListView)
protected
...
procedure DoContextPopup(MousePos: TPoint; var Handled: Boolean); override;
...
end;
procedure TMyListView.DoContextPopup(MousePos: TPoint; var Handled: Boolean);
var
LPopupMenu: TPopupMenu;
LItem: TMenuItem;
function IsSameEvent(const E1, E2: TNotifyEvent): Boolean;
begin
Result := (TMethod(E1).Code = TMethod(E2).Code) and
(TMethod(E1).Data = TMethod(E2).Data);
end;
begin
inherited DoContextPopup(MousePos, Handled);
if Handled then Exit;
LPopupMenu := PopupMenu;
if not Assigned(LPopupMenu) then
begin
LPopupMenu := TPopupMenu.Create(Self);
PopupMenu := LPopupMenu;
end;
for I := 0 to LPopupMenu.Items.Count-1 do
begin
LItem := LPopupMenu.Items[I];
if IsSameEvent(LItem.OnClick, PopupMenuItemClick) then
Exit;
end;
LItem := TMenuItem.Create(Self);
LItem.Caption := 'Copy data to clipboard';
LItem.OnClick := PopupMenuItemClick;
LPopupMenu.Items.Add(LItem);
end;
The accepted answer indeed works perfectly - unless you add keyboard shortcuts to your menu item. If you do, these won't work before the popup menu has been accessed in some other way, because the items will not have been created.
If you need shortcuts, it may therefore be preferable to move the code from DoContextPopup to Loaded. Most simply,
procedure Loaded; override;
...
procedure Loaded;
var
MI: TMenuItem;
ItemCovered: boolean;
i: integer;
begin
inherited;
if not Assigned(PopupMenu) then
PopupMenu:=TPopupMenu.Create(self);
ItemCovered:=false;
for i := 0 to PopupMenu.Items.Count-1 do
if IsSameEvent(PopupMenu.Items[I].OnClick, CopyDataToClipboardClick) then begin
ItemCovered:=true;
break;
end;
if not ItemCovered then begin
MI:=TMenuItem.Create(PopupMenu);
MI.Caption:='Copy data to clipboard';
MI.OnClick:=CopyDataToClipboardClick;
MI.ShortCut:=ShortCut(Ord('C'),[ssShift,ssCtrl]);
PopupMenu.Items.Add(MI);
end;
end;
This won't check for popup menus added on runtime, but probably serve most cases better.
dxSkinController1 changes the entire application's forms to a selected skin. However, I want some forms excluded. How can I do that ?
Found on devexpress site :
https://www.devexpress.com/Support/Center/Question/Details/B136071
procedure SetControlSkinName(AControl: TWinControl; const ASkinName: string);
var
AIntf: IcxLookAndFeelContainer;
I: Integer;
begin
if Supports(AControl, IcxLookAndFeelContainer, AIntf) then
begin
AIntf.GetLookAndFeel.NativeStyle := False;
AIntf.GetLookAndFeel.SkinName := ASkinName;
end;
for I := 0 to AControl.ControlCount - 1 do
if AControl.Controls[I] is TWinControl then
SetControlSkinName(TWinControl(AControl.Controls[I]), ASkinName);
end;
procedure TForm1.dxSkinController1SkinForm(Sender: TObject; AForm: TCustomForm;
var ASkinName: string; var UseSkin: Boolean);
begin
if AForm = Form1 then
begin
ASkinName := 'Metropolis';
UseSkin := True;
SetControlSkinName(AForm, ASkinName);
end;
end;
This actually applies the desired skin to a desired form. To exclude the rest of the form just set dxSkinController1's NativeStyle to false.
I am using XE7 64 and I am looking for a strategy to solve several problems I am having when displaying HTMLHelp files from within my applications (I have added the HTMLHelpViewer to my uses clause). The issues are the following: 1) Ctrl-c does not copy text from topics; 2) The helpviewer cannot be accessed when a modal dialog is active.
The source of the problems are presumably attributable to the htmlhelpviewer running in the same process as the application. Is there a way to have the built-in htmlhelpviewer launch a new process? If not, then will I need to launch HH.EXE with Createprocess?
You could launch the help file viewer as a separate process, but I think that will make controlling it even more complex. My guess is that the supplied HTML help viewer code is the root cause of your problems. I've always found that code to be extremely low quality.
I deal with that by implementing an OnHelp event handler that I attach to the Application object. This event handler calls the HtmlHelp API directly. I certainly don't experience any of the problems that you describe.
My code looks like this:
unit Help;
interface
uses
SysUtils, Classes, Windows, Messages, Forms;
procedure ShowHelp(HelpContext: THelpContext);
procedure CloseHelpWindow;
implementation
function RegisterShellHookWindow(hWnd: HWND): BOOL; stdcall; external user32;
function DeregisterShellHookWindow(hWnd: HWND): BOOL; stdcall; external user32;
procedure ShowHelp(HelpContext: THelpContext);
begin
Application.HelpCommand(HELP_CONTEXTPOPUP, HelpContext);
end;
type
THelpWindowManager = class
private
FMessageWindow: HWND;
FHelpWindow: HWND;
FHelpWindowLayoutPreference: TFormLayoutPreference;
function ApplicationHelp(Command: Word; Data: THelpEventData; var CallHelp: Boolean): Boolean;
protected
procedure WndProc(var Message: TMessage);
public
constructor Create;
destructor Destroy; override;
procedure RestorePosition;
procedure StorePosition;
procedure StorePositionAndClose;
end;
{ THelpWindowManager }
constructor THelpWindowManager.Create;
function DefaultRect: TRect;
var
i, xMargin, yMargin: Integer;
Monitor: TMonitor;
begin
Result := Rect(20, 20, 1000, 700);
for i := 0 to Screen.MonitorCount-1 do begin
Monitor := Screen.Monitors[i];
if Monitor.Primary then begin
Result := Monitor.WorkareaRect;
xMargin := Monitor.Width div 20;
yMargin := Monitor.Height div 20;
inc(Result.Left, xMargin);
dec(Result.Right, xMargin);
inc(Result.Top, yMargin);
dec(Result.Bottom, yMargin);
break;
end;
end;
end;
begin
inherited;
FHelpWindowLayoutPreference := TFormLayoutPreference.Create('Help Window', DefaultRect, False);
FMessageWindow := AllocateHWnd(WndProc);
RegisterShellHookWindow(FMessageWindow);
Application.OnHelp := ApplicationHelp;
end;
destructor THelpWindowManager.Destroy;
begin
StorePositionAndClose;
Application.OnHelp := nil;
DeregisterShellHookWindow(FMessageWindow);
DeallocateHWnd(FMessageWindow);
FreeAndNil(FHelpWindowLayoutPreference);
inherited;
end;
function THelpWindowManager.ApplicationHelp(Command: Word; Data: THelpEventData; var CallHelp: Boolean): Boolean;
var
hWndCaller: HWND;
HelpFile: string;
DoSetPosition: Boolean;
begin
CallHelp := False;
Result := True;
//argh, WinHelp commands
case Command of
HELP_CONTEXT,HELP_CONTEXTPOPUP:
begin
hWndCaller := GetDesktopWindow;
HelpFile := Application.HelpFile;
DoSetPosition := FHelpWindow=0;//i.e. if the window is not currently showing
FHelpWindow := HtmlHelp(hWndCaller, HelpFile, HH_HELP_CONTEXT, Data);
if FHelpWindow=0 then begin
//the topic may not have been found because the help file isn't there...
if FileExists(HelpFile) then begin
ReportError('Cannot find help topic for selected item.'+sLineBreak+sLineBreak+'Please report this error message to Orcina.');
end else begin
ReportErrorFmt(
'Cannot find help file (%s).'+sLineBreak+sLineBreak+'Reinstalling the program may fix this problem. '+
'If not then please contact Orcina for assistance.',
[HelpFile]
);
end;
end else begin
if DoSetPosition then begin
RestorePosition;
end;
HtmlHelp(hWndCaller, HelpFile, HH_DISPLAY_TOC, 0);//ensure that table of contents is showing
end;
end;
end;
end;
procedure THelpWindowManager.RestorePosition;
begin
if FHelpWindow<>0 then begin
RestoreWindowPosition(FHelpWindow, FHelpWindowLayoutPreference);
end;
end;
procedure THelpWindowManager.StorePosition;
begin
if FHelpWindow<>0 then begin
StoreWindowPosition(FHelpWindow, FHelpWindowLayoutPreference);
end;
end;
procedure THelpWindowManager.StorePositionAndClose;
begin
if FHelpWindow<>0 then begin
StorePosition;
SendMessage(FHelpWindow, WM_CLOSE, 0, 0);
FHelpWindow := 0;
end;
end;
var
WM_SHELLHOOKMESSAGE: UINT;
procedure THelpWindowManager.WndProc(var Message: TMessage);
begin
if (Message.Msg=WM_SHELLHOOKMESSAGE) and (Message.WParam=HSHELL_WINDOWDESTROYED) then begin
//need cast to HWND to avoid range errors
if (FHelpWindow<>0) and (HWND(Message.LParam)=FHelpWindow) then begin
StorePosition;
FHelpWindow := 0;
end;
end;
Message.Result := DefWindowProc(FMessageWindow, Message.Msg, Message.wParam, Message.lParam);
end;
var
HelpWindowManager: THelpWindowManager;
procedure CloseHelpWindow;
begin
HelpWindowManager.StorePositionAndClose;
end;
initialization
if not ModuleIsPackage then begin
Application.HelpFile := ChangeFileExt(Application.ExeName, '.chm');
WM_SHELLHOOKMESSAGE := RegisterWindowMessage('SHELLHOOK');
HelpWindowManager := THelpWindowManager.Create;
end;
finalization
FreeAndNil(HelpWindowManager);
end.
Include that unit in your project and you will be hooked up to handle help context requests. Some comments on the code:
The implementation of the OnHelp event handler is limited to just my needs. Should you need more functionality you'd have to add it yourself.
You won't have TFormLayoutPrefernce. It's one of my preference classes that manages per-user preferences. It stores away the window's bounds rectangle, and whether or not the window was maximised. This is used to ensure that the help window is shown at the same location as it was shown in the previous session. If you don't want such functionality, strip it away.
ReportError and ReportErrorFmt are my helper functions to show error dialogs. You can replace those with calls to MessageBox or similar.
Based on David's comments that he calls HtmlHelp directly and does not encounter the problems noted above, I tried that approach and it solved the problems. Example of calling HTMLHelp directly to open a topic by id:
HtmlHelp(Application.Handle,'d:\help study\MyHelp.chm',
HH_HELP_CONTEXT, 70);
I am having problem with Firemonkey TEdit Uppercase in Android.
Code:
procedure TFormMain.Edit1KeyDown(Sender: TObject; var Key: Word;
var KeyChar: Char; Shift: TShiftState);
begin
KeyChar := UpCase(KeyChar);
end;
In Win32 it works but in Android it's not working.
You have to use ChangeTracking event. It works fine
This code works on Android
procedure TFormMain.Edit1Typing(Sender: TObject);
begin
Edit1.Text:=AnsiUpperCase(Edit1.Text);
Edit1.GoToTextEnd;
end;
This code works on windows:
procedure TFormMain.Edit1ChangeTracking(Sender: TObject);
var
thetext: String;
begin
thetext := Edit1.Text;
Edit1.OnChangeTracking := nil;
Edit1.Text := '';
Edit1.Text := AnsiUpperCase(thetext);
Edit1.OnChangeTracking := Edit1ChangeTracking;
Edit1.GoToTextEnd;
end;
Use ToUpper (Documentation) or AnsiUpperCase (Documentation) for strings.
UPDATE: Why are you using OnKeyDown? According to Documentation you must use OnChangeTracking: "This event provides the first opportunity to respond to modifications the user brought to the text of the edit control."
So put in OnChangeTracking something like
procedure TFormMain.Edit1ChangeTracking(Sender: TObject);
begin
Edit1.text:= AnsiUpperCase(Edit1.text);
end;
I'm using the SHAutoComplete() function from the Shell Lightweight Utility Functions
library to enable path auto completion for edit fields in a modal dialog.
The dialog should close when the Esc key is pressed, but only if auto completion is not active.
How can I check whether a completion list is currently shown for the focused edit control?
Edit:
I'm using Delphi 2009 on Windows XP 64. The code posted by David
procedure TMyForm.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if Key = VK_ESCAPE then
ModalResult := mrCancel;
end;
does not work for me - the dialog gets closed.
I have tried on several systems, with strange results:
on my PC with Windows XP 64 the dialog closes while the list is dropped down
on Windows XP Pro in a VMware virtual machine the dialog closes too
but
on my laptop with Windows 7 the dialog does not close
on Windows 2000 Pro in a VMware virtual machine the dialog does not close
Since this is so erratic I chose to write a small component that forces the correct behaviour even if the OS doesn't provide it.
The component can be used like this:
procedure TForm2.FormCreate(Sender: TObject);
const
SHACF_FILESYS_DIRS = $00000020;
begin
SHAutoComplete(Edit1.Handle, SHACF_FILESYS_DIRS or SHACF_USETAB);
fAutoSuggestDropdownChecker := TAutoSuggestDropdownChecker.Create(Self);
end;
procedure TForm2.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if Key = VK_ESCAPE then begin
if not fAutoSuggestDropdownChecker.DroppedDown then
ModalResult := mrCancel;
end;
end;
but it is important that the Cancel button does not have the Cancel property set.
The component itself works by hooking into application message handling and using window enumeration for the current thread to check for a visible window with the "Auto-Suggest Dropdown" class name. If this exists and is visible then the auto completion list is dropped down.
unit uAutoSuggestDropdownCheck;
interface
uses
Windows, Classes, Messages, Forms;
type
TAutoSuggestDropdownChecker = class(TComponent)
private
fDroppedDown: boolean;
fSaveMessageEvent: TMessageEvent;
procedure AppOnMessage(var AMsg: TMsg; var AHandled: Boolean);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property DroppedDown: boolean read fDroppedDown;
end;
implementation
////////////////////////////////////////////////////////////////////////////////
function EnumThreadWindowsProc(AWnd: HWND; AParam: LPARAM): BOOL; stdcall;
var
WndClassName: string;
FoundAndVisiblePtr: PInteger;
begin
SetLength(WndClassName, 1024);
GetClassName(AWnd, PChar(WndClassName), Length(WndClassName));
WndClassName := PChar(WndClassName);
if WndClassName = 'Auto-Suggest Dropdown' then begin
FoundAndVisiblePtr := PInteger(AParam);
FoundAndVisiblePtr^ := Ord(IsWindowVisible(AWnd));
Result := False;
end else
Result := True;
end;
function IsAutoSuggestDropdownVisible: boolean;
var
FoundAndVisible: integer;
begin
FoundAndVisible := 0;
EnumThreadWindows(GetCurrentThreadId, #EnumThreadWindowsProc,
LParam(#FoundAndVisible));
Result := FoundAndVisible > 0;
end;
////////////////////////////////////////////////////////////////////////////////
// TAutoSuggestDropdownChecker
////////////////////////////////////////////////////////////////////////////////
constructor TAutoSuggestDropdownChecker.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
fSaveMessageEvent := Application.OnMessage;
Application.OnMessage := AppOnMessage;
end;
destructor TAutoSuggestDropdownChecker.Destroy;
begin
if (TMethod(fSaveMessageEvent).Code = TMethod(Application.OnMessage).Code)
and (TMethod(fSaveMessageEvent).Data = TMethod(Application.OnMessage).Data)
then begin
Application.OnMessage := fSaveMessageEvent;
end;
fSaveMessageEvent := nil;
inherited;
end;
procedure TAutoSuggestDropdownChecker.AppOnMessage(var AMsg: TMsg;
var AHandled: Boolean);
begin
if ((AMsg.message >= WM_KEYFIRST) and (AMsg.message <= WM_KEYLAST))
or ((AMsg.message >= WM_MOUSEFIRST) and (AMsg.message <= WM_MOUSELAST))
or (AMsg.message = WM_CANCELMODE)
then
fDroppedDown := IsAutoSuggestDropdownVisible
end;
end.
The code as posted here is only proof-of-concept but could serve as starting point for those struggling with the same problem.
I can't reproduce your problem. The following OnKeyDown handler, combined with KeyPreview := True gives the desired behaviour in an otherwise empty form.
procedure TMyForm.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if Key=VK_ESCAPE then
ModalResult := mrCancel;
end;
I guess there is something else in your form that is closing the dialog.