Delphi - Win7 Window Focus Issue - delphi

I execute exe file by CreateProcess() and set foreground process by SetForegroundWindow().
but it doesn't work in Win7 so I have to click icon in taskbar.
How can I implement the behaviour I want (which is to Launch and BringToForeground)?

You shouldn't even try to do this. The change in SetForegroundWindow was intentional - it prevents applications from stealing the focus from what the user wants to have focus. See the Remarks section of the link above.
Win7 probably won't let non-administrative users change the needed registry setting, much less do it without a restart of the system.
You should just use FlashWindow instead to get the user's attention, as Microsoft recommends. Any application that insists on stealing focus away from what I choose to do will be uninstalled immediately.

I was going to post a link (in a comment) to a piece of code that I once had to apply to solve a problem of my own. The link has turned out to be broken now, so I'm posting the code here for what it's worth (it has been tested in Windows XP Pro SP2 and Windows Server 2003, but not in Windows 7):
function ForceForegroundWindow(hwnd: THandle): boolean;
{
found here:
http://delphi.newswhat.com/geoxml/forumhistorythread?groupname=borland.public.delphi.rtl.win32&messageid=501_3f8aac4b#newsgroups.borland.com
}
const
SPI_GETFOREGROUNDLOCKTIMEOUT = $2000;
SPI_SETFOREGROUNDLOCKTIMEOUT = $2001;
var
ForegroundThreadID: DWORD;
ThisThreadID: DWORD;
timeout: DWORD;
begin
if IsIconic(hwnd) then ShowWindow(hwnd, SW_RESTORE);
if GetForegroundWindow = hwnd then Result := true
else begin
// Windows 98/2000 doesn't want to foreground a window when some other
// window has keyboard focus
if ((Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion > 4)) or
((Win32Platform = VER_PLATFORM_WIN32_WINDOWS) and ((Win32MajorVersion > 4) or
((Win32MajorVersion = 4) and (Win32MinorVersion > 0)))) then begin
// Code from Karl E. Peterson, www.mvps.org/vb/sample.htm
// Converted to Delphi by Ray Lischner
// Published in The Delphi Magazine 55, page 16
Result := false;
ForegroundThreadID := GetWindowThreadProcessID(GetForegroundWindow,nil);
ThisThreadID := GetWindowThreadPRocessId(hwnd,nil);
if AttachThreadInput(ThisThreadID, ForegroundThreadID, true) then
begin
BringWindowToTop(hwnd); // IE 5.5 related hack
SetForegroundWindow(hwnd);
AttachThreadInput(ThisThreadID, ForegroundThreadID, false); // bingo
Result := (GetForegroundWindow = hwnd);
end;
if not Result then begin
// Code by Daniel P. Stasinski
SystemParametersInfo(SPI_GETFOREGROUNDLOCKTIMEOUT, 0, #timeout, 0);
SystemParametersInfo(SPI_SETFOREGROUNDLOCKTIMEOUT, 0, TObject(0), SPIF_SENDCHANGE);
BringWindowToTop(hwnd); // IE 5.5 related hack
SetForegroundWindow(hWnd);
SystemParametersInfo(SPI_SETFOREGROUNDLOCKTIMEOUT, 0, TObject(timeout), SPIF_SENDCHANGE);
end;
end
else begin
BringWindowToTop(hwnd); // IE 5.5 related hack
SetForegroundWindow(hwnd);
end;
Result := (GetForegroundWindow = hwnd);
end;
end; { ForceForegroundWindow }
end.
I didn't add anything to the function apart from a small comment 'bingo', which marks the line which actually brought about the desired effect.
Just so you guys didn't think I was abusing users' experience with this function, here's some explanation.
This function was used in an application that was called remotely with the help of Citrix software set up on users' Tablet PCs, and the application ran in full screen. A typical working session almost entirely consisted of that application (other parts were just system components which user never interacted with).
Now some parts of our application had to be implemented as separate small applications, and they were designed to stay on top of all other windows until closed, just like modal windows. Once in a while they used to lose their Z order and hide under the main application's main window, and that was a total disaster for users. Using the 'top-most' property wasn't an option there, so we had to find a way to sustain their Z-order positions. And so we used this function.

ForceForegroundWindow worked for me in Win10. However, it does not activate the external program. It only makes it visible and on top. The program also only does the same when calling itself. I am assuming that if it activated it would also setfocus appropriately for the user.
Rick
I found a resolution for activating and setting focus... In the "SetAppRestore" procedure I initiated it with "MainFrm.visible:= false". Then it goes to SwitchApp, and it calls ForceForegroundWindow. After it returns to "SetAppRestore", I inserted "MainFrm.visible:= true". This triggered the app to become active and have focus on defined component: DataPge.SetFocus.
I apologize for not placing the code in a code block. I couldn't understand the instructions. So I put it all between 2 ===== bars.
//==========================
function TMainFrm.FindWindowExtd(partialTitle: string): HWND; // get with wildcard
var // by Dorin Duminica, September 10, 2009
hWndTemp: hWnd;
iLenText: Integer;
cTitletemp: array [0..254] of Char;
sTitleTemp: string;
begin
hWndTemp := FindWindow(nil, nil);
while hWndTemp <> 0 do
begin
iLenText := GetWindowText(hWndTemp, cTitletemp, 255);
sTitleTemp := cTitletemp;
sTitleTemp := UpperCase(copy( sTitleTemp, 1, iLenText));
partialTitle := UpperCase(partialTitle);
if pos(partialTitle, sTitleTemp) <> 0 then Break;
hWndTemp := GetWindow(hWndTemp, GW_HWNDNEXT);
end;
result := hWndTemp;
end;
function ForceForegroundWindow(hwnd: THandle): boolean;
const
SPI_GETFOREGROUNDLOCKTIMEOUT = $2000;
SPI_SETFOREGROUNDLOCKTIMEOUT = $2001;
var
ForegroundThreadID: DWORD;
ThisThreadID: DWORD;
timeout: DWORD;
begin
if IsIconic(hwnd) then ShowWindow(hwnd, SW_RESTORE);
if GetForegroundWindow = hwnd
then Result:= true
else begin
// Windows 98/2000 doesn't want to foreground a window when some other
// window has keyboard focus
if ((Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion > 4)) or
((Win32Platform = VER_PLATFORM_WIN32_WINDOWS) and ((Win32MajorVersion > 4) or
((Win32MajorVersion = 4) and (Win32MinorVersion > 0)))) then
begin
// Code from Karl E. Peterson, www.mvps.org/vb/sample.htm
// Converted to Delphi by Ray Lischner
// Published in The Delphi Magazine 55, page 16
Result:= false;
ForegroundThreadID:= GetWindowThreadProcessID(GetForegroundWindow,nil);
ThisThreadID:= GetWindowThreadPRocessId(hwnd,nil);
if AttachThreadInput(ThisThreadID, ForegroundThreadID, true) then
begin
BringWindowToTop(hwnd); // IE 5.5 related hack
SetForegroundWindow(hwnd);
AttachThreadInput(ThisThreadID, ForegroundThreadID, false); // bingo
Result:= (GetForegroundWindow = hwnd);
//showmessage('case 1');
end;
if not Result then
begin
// Code by Daniel P. Stasinski
SystemParametersInfo(SPI_GETFOREGROUNDLOCKTIMEOUT, 0, #timeout, 0);
SystemParametersInfo(SPI_SETFOREGROUNDLOCKTIMEOUT, 0, TObject(0), SPIF_SENDCHANGE);
BringWindowToTop(hwnd); // IE 5.5 related hack
SetForegroundWindow(hWnd);
SystemParametersInfo(SPI_SETFOREGROUNDLOCKTIMEOUT, 0, TObject(timeout), SPIF_SENDCHANGE);
//showmessage('case 2');
end;
end
else begin
BringWindowToTop(hwnd); // IE 5.5 related hack
SetForegroundWindow(hwnd);
//showmessage('case 3');
end;
Result:= (GetForegroundWindow = hwnd);
end;
end; { ForceForegroundWindow }
procedure TMainFrm.SwitchApp(AppCaption:string); // application.restore;
begin
//TmpAppHandle:= FindWindow(nil, PChar(AppCaption)); // uses Windows unit - must be entire caption
TmpAppHandle:= FindWindowExtd(AppCaption); // finds 'notepad' as partial of 'Document - Notepad'
if (TmpAppHandle<>0)
then begin
//SetForegroundWindow(TmpAppHandle); // worked by itself for WinXP and Win7
ForceForegroundWindow(TmpAppHandle);
end
else ShowAlert(AppCaption+' *not found*');
end;
// application.restore can't restore from MainForm.windowstate:=wsMinimized
// SetAppMinimize and SetAppRestore fix that issue and manual minimizations
procedure TMainFrm.SetAppMinimize; // application.minimize
begin
if not(MainFrm.WindowState=wsMinimized) then
begin
MainFrm.WindowState:= wsMinimized;
end;
SwitchApp(ServerName); // autocad or bricscad
end;
procedure TMainFrm.SetAppRestore; // application.restore
begin
MainFrm.visible:= false; // ** to reinsate and focus in win10 **
if (MainFrm.WindowState=wsMinimized) then
begin
MainFrm.WindowState:= wsNormal;
end;
SwitchApp('CmdData'); // partial string for app title
MainFrm.visible:= true; // ** to reinsate and focus in win10 **
FormatGrid; // added for activex crash
DataPge.SetFocus;
Update;
end;
//==========================

Related

No sound using Delphi and DirectX on Windows 10

I've a problem with using DirectX (DirectSound) on Windows 10. I'me changing some legacy code that used DirectX (DirectX 9 I think) and run on Windows XP.
Everything is still working great on Windows XP but I can't get a sound on Windows 10.
The application uses these files: DXUTIL.PAS (Original ObjectPascal conversion made by: Boris V.), lzexpand.pas (Author: Vadim Bodrov) and DirectSound.pas (DirectX 9.0 Delphi / FreePascal adaptation by Alexey Barkovoy).
procedure TForm1.Button1Click(Sender: TObject);
var
sndgwait : PSound;
begin
InitSB(Handle);
LoadWave(sndgwait, 'D:\game\EXP01.wav', 1);
StartSound(sndgwait, false);
end;
function LoadWave(var Sound: PSound; fn : string; conc : integer) : boolean;
var
cbData, cbdata1 : DWORD;
pd1 : pointer;
hfile : longint;
vreopenbuff : TOFStruct;
begin
hfile := LZOpenFile(PAnsiChar(fn), vreopenbuff, OF_READ);
if hfile < 0 then begin result := false; exit; end;
cbdata := LZSeek(hfile, 0, 2); // file size
LZSeek(hfile, 0, 0); //back to the start of the wav
getmem(pd1, cbdata);
LZRead(hfile, pd1, cbdata);
LZClose(hfile);
if conc < 1 then conc := 1;
result := ParseWaveData(Sound, conc, cbdata, pd1);
end;
function ParseWaveData(var Sound : PSound; conc : integer; cbdata : dword; pd1 : pointer) : boolean;
var
pWaveHeader: PWAVEFORMATEX;
pDSB: IDirectSoundBuffer;
dsBD: TDSBUFFERDESC;
rr : longint;
begin
if lpDS = nil then begin
result := false;
exit;
end;
Sound := PSNDOBJ(LocalAlloc(LPTR, SizeOf(TSNDOBJ) + (conc-1) * SizeOf(IDirectSoundBuffer)));
Sound^.iAlloc := conc;
Sound^.cbWaveSize := 0;
Sound^.pbWaveData := nil;
pwaveHeader := nil;
Sound^.pbData := pd1;
Sound^.cbSize := cbdata;
if DSParseWaveResource(pd1, pWaveHeader, Sound^.pbWaveData, Sound^.cbWaveSize) then begin
ZeroMemory(#dsBD, SizeOf(dsBD));
dsBD.dwSize := SizeOf(dsBD);
dsBD.dwFlags := DSBCAPS_STATIC or DSBCAPS_GETCURRENTPOSITION2 or DSBCAPS_CTRLFREQUENCY orDSBCAPS_CTRLPAN or DSBCAPS_CTRLVOLUME;//DSBCAPS_CTRLDEFAULT or
dsBD.lpwfxFormat := pWaveHeader;
dsBD.dwBufferBytes := Sound^.cbWaveSize;
if lpDS.CreateSoundBuffer(dsBD, pDSB, nil) = DS_OK then begin
if not DSFillSoundBuffer(pDSB, Sound^.pbWaveData, dsBD.dwBufferBytes) then begin
pDSB._Release;
pDSB := nil;
end;
Sound^.Buffers[0] := pDSB;
for rr := 1 to conc - 1 do begin
lpDS.DuplicateSoundBuffer(Sound^.Buffers[0], Sound^.Buffers[rr]);
end;
end else begin
pDSB := nil;
SndObjDestroy(Sound);
Sound := nil;
end;
end;
Result := Sound <> nil;
end;
function StartSound(Sound: PSound; Loop: boolean = false; waitforend: boolean = false): boolean;
begin
if Loop then
StartSound := SndObjPlay(Sound, DSBPLAY_LOOPING)
else
StartSound := SndObjPlay(Sound, 0);
if waitforend and not loop then
while SoundPlaying(Sound) do Application.ProcessMessages;
end;
function SndObjPlay(pSO: PSNDOBJ; dwPlayFlags: DWORD): Boolean;
var
pDSB: IDirectSoundBuffer;
begin
Result := FALSE;
if pSO = nil then
begin
exit;
end;
if ((dwPlayFlags and DSBPLAY_LOOPING) = 0) or (pSO^.iAlloc = 1) then
begin
pDSB := SndObjGetFreeBuffer(pSO);
if (pDSB <> nil) then
Result := SUCCEEDED(pDSB.Play(0, 0, dwPlayFlags));
end else
Result:= FALSE;
end;
All values in ParseWaveData call are correct I think (no nil values).
I'm not gething any errors. Just there is no sound.
What can be a problem here?
Or are there other ways to use DirectX for sound in this old app on windows 10? Any example would be great.
Thanks....
While I cannot guarantee this is the fix, I also cannot just comment because I don't have 50 rep, it is worth a try. I had a lot of issues with Windows 10 sound, often it seemed at random! Switching apps disabled sound from background apps, game programming wouldn't make a peep, even playing music to see if I had the right track with CD burning software was broken, Netflix breaking sound until I rebooted, wireless headphones not working or volume way too low. Infuriating. You might not be wrestling control from whatever has current priority because of an W10 April 2018 change and just not had the issues I've had.
Anyway, this is worth a try:
Right-click the Sound Icon in the bottom right of task bar. Click
Playback or Audio Devices. Right-click the speaker icon that appears
in the settings screen. Click Properties from the pop-up menu. Click
the Advanced tab on the Speakers Properties screen. Uncheck the boxes
for Allow applications to take exclusive control and Give exclusive
mode applications priority.
I've solved this. At the end it wasn't anything with DirectX.
hfile := LZOpenFile(PAnsiChar(fn), vreopenbuff, OF_READ);
Parameter "fn" (string) that was input to the procedure was wrong. Something messes up. The file name was incorrect, so file that should be played was empty. Nothing to do with DirectX. I've replaced above command with:
hfile := LZOpenFile(PAnsiChar(AnsiString(fn)), vreopenbuff, OF_READ);
Now it is working.
Thanks...

Grey Screen when using CreateDesktop, no taskbar or icon showing

I'm trying to develop an application that creates a new desktop, and I want this desktop to be usable, like to have icons, taskbar... So to do that, I used the CreateDesktop() function, but the newly created desktop is just a grey screen. Even after executing explorer.exe in that desktop, it doesn't work, there is still a grey screen, like this:
(I also figured, if I try to open a file with that explorer, the file is not open in that new desktop but the old one)
I used this GitHub project, made in C++, and adapted it for Delphi:
https://github.com/MalwareTech/CreateDesktop/
This is my code:
function CreateHiddenDesktop(desktopname : string) : THandle;
var
pi : TProcessInformation;
si : TStartupInfoA;
hidden_Desktop,original_desktop : THandle;
begin
//Creating a new desktop
hidden_Desktop := CreateDesktop('hdtest',nil,nil,0,GENERIC_ALL,nil);
//Saving handle of current desktop
original_desktop := GetThreadDesktop(GetCurrentThreadID());
SetThreadDesktop(hidden_desktop);
//Executing explorer.exe in the new desktop
si := Default(TStartupInfoA);
si.cb := sizeof(si);
si.lpDesktop := 'hdtest';
if not CreateProcessA(
'C:\Windows\System32\explorer.exe',
nil,
nil,
nil,
False,
0,
nil,
nil,
si, //Startup Info
pi //Process Info
) then
MessageBox(0, PChar('error when creating process inside the desktop'), PChar(''), 0);
SetThreadDesktop(original_desktop);
Result := hidden_desktop;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
hidden_Desktop,original_desktop : THandle;
msg : TMSG;
begin
hidden_Desktop := CreateHiddenDesktop('hdtest');
original_desktop := GetThreadDesktop(GetCurrentThreadId());
MessageBox(0, PChar('Entering hidden desktop'), PChar('HVNC'), 0);
SetThreadDesktop(hidden_desktop);
SwitchDesktop(hidden_desktop);
//If the keys CTR + ALT + E are pressed we go back to the original desktop
if RegisterHotKey(0,1,MOD_CONTROL + MOD_ALT + MOD_NOREPEAT,ord('E')) then
begin
while(GetMessage(msg, 0, 0, 0)) do
begin
if msg.message = WM_HOTKEY then
begin
SwitchDesktop(original_desktop);
break;
end;
end;
end;
CloseHandle(hidden_desktop);
end;
So, the solution I found is that, when using SetThreadDesktop(), I needed to create another thread before, because my application had a GUI. But it didn't work until I re-started my computer.
Turned out, it was because the Delphi application was executed as an Admnistrator. When I executed it in the user context, it worked.
I lost several days of my life on this...

SetWindowSubclass changes ANSI windows to UNICODE

Is SetWindowSubClass() supposed to change an ANSI window into a UNICODE widow? I didn't find anything in the documentation, or on the web, about this behavior.
I created a test application (full source) just to illustrate how SetWindowSubclass (I believe) changes the type of the affected window from ANSI to UNICODE, as it shouldn't! IsWindowUnicode() confirms the change.
program TwoWaySubclassing;
{$apptype gui}
{$R Generic.res}
{
{ I created this test application just to illustrate how SetWindowSubclass()
{ changes -- I believe -- the type of the affected window from ANSI to UNICODE,
{ as it shouldn't! IsWindowUnicode() confirms that.
{
{ The Delphi 7 (all ANSI) application has 2 edit controls:
{ 1. The smaller, which is subclassed in 2 switchable ways (called Modes).
{ 2. The bigger, like a memo, not subclassed. Just for dumping info.
{ 3. A button for switching between modes, on-the-fly.
{
{ The default subclassing Mode uses SetWindowLong (the classic way).
{ When pressing the button, the edit control is subclassed via SetWindowSubclass.
{ Pressing it again brings the edit control back to the default SetWindowLong mode.
{
{ The main window (and all child controls) are created using the ANSI version
{ of the API procedure, so the message handler should receive, in "lParam",
{ a pointer to an ANSI text (along with the wm_SetText message), always!
{
{ The problem is that's not happening when the edit control is subclassed using
{ the SetWindowSubclass mode! SetWindowSubclass() simply changes the window
{ from ANSI to UNICODE and starts sending a PWideChar(lParam) rather than the
{ expected PAnsiChar(lParam).
{
{ Once back to the default SetWindowLong mode, the window becomes ANSI again!
{ Just run the application and try switching between modes. Look carefully at the
{ detailed info shown in the bigger edit control.
{
{ Screenshots:
{ 1. http://imgh.us/mode1.png
{ 2. http://imgh.us/mode2.png
{
{ Environment:
{ Windows 7 32-bit
{ Delphi 7 (all-ANSI)
{
{ Regards,
{ Paulo França Lacerda
}
uses
Windows,
Messages,
SysUtils;
type
UINT_PTR = Cardinal;
DWORD_PTR = Cardinal;
TSubClassProc = function (hWnd:HWND; uMsg:UINT; wParam:WPARAM; lParam:LPARAM; uIdSubclass:UINT_PTR; dwRefData:DWORD_PTR) :LRESULT; stdcall;
TSubMode = (
subSetWindowLong,
subSetWindowSubclass);
const
LtBool :Array[Boolean] of String = ('False', 'True');
LtSubMode :Array[TSubMode] of String = ('SetWindowLong', 'SetWindowSubclass');
strTextUsingPAnsiChar = 'ANSI Text in PAnsiChar(lParam)';
strTextUsingPWideChar = 'UNICODE Text in PWideChar(lParam)';
const
cctrl = Windows.comctl32;
function SetWindowSubclass (hWnd:Windows.HWND; pfnSubclass:TSubClassProc; uIdSubclass:UINT_PTR; dwRefData:DWORD_PTR) :BOOL; stdcall; external cctrl name 'SetWindowSubclass';
function RemoveWindowSubclass (hWnd:Windows.HWND; pfnSubclass:TSubClassProc; uIdSubclass:UINT_PTR) :BOOL; stdcall; external cctrl name 'RemoveWindowSubclass';
function DefSubclassProc (hWnd:HWND; uMsg:UINT; wParam:WPARAM; lParam:LPARAM) :LRESULT; stdcall; external cctrl name 'DefSubclassProc';
var
wc :TWndClass;
Msg :TMsg;
hButton :HWnd;
hEdit :HWnd;
hEdit2 :HWnd;
hFont :HWnd;
hFont2 :HWnd;
hMainHandle :HWnd;
swl_OldProc :Pointer; // Default Procedure for Subclassing #1 (via SetWindowLong)
SubMode :TSubMode;
procedure Release_Resources;
begin
DestroyWindow (hButton); hButton := 0;
DestroyWindow (hEdit); hEdit := 0;
DestroyWindow (hEdit2); hEdit2 := 0;
DeleteObject (hFont); hFont := 0;
DeleteObject (hFont2); hFont2 := 0;
end;
procedure MsgBox (S:String);
begin
MessageBox (hMainHandle, PChar(S), 'Information', mb_Ok or mb_IconInformation);
end;
procedure Reveal_Text (lParam:LPARAM);
const
lf = #13#10;
lf2 = lf+lf;
var
S :String;
AnsiTxt :String;
UnicTxt :String;
Remarks :Array[1..3] of String;
begin
if IsWindowUnicode(hEdit)
then Remarks[1] := ' (Man! SetWindowSubclass changed it to Unicode!!)'
else Remarks[1] := ' (great! as designed)';
AnsiTxt := PAnsiChar(lParam);
if (Length(AnsiTxt) = 1)
then Remarks[2] := ' (text is obviously truncated)'
else Remarks[2] := ' (text is healthy and is ANSI, as it should)';
UnicTxt := PWideChar(lParam);
if (Pos('?',UnicTxt) > 0)
then Remarks[3] := ' (text is obviously garbaged)'
else Remarks[3] := ' (text is healthy, but I want it to be ANSI)';
S :=
'Subclassed using: '
+lf +' '+LtSubMode[SubMode]+'()'
+lf2+ 'IsUnicodeWindow(hEdit)? '
+lf +' '+LtBool[IsWindowUnicode(hEdit)]
+lf + Remarks[1]
+lf2+'PAnsiChar(lParam):'
+lf +' "'+PAnsiChar(lParam)+'"'
+lf + Remarks[2]
+lf2+ 'PWideChar(lParam):'
+lf +' "'+PWideChar(lParam)+'"'
+lf + Remarks[3];
SetWindowText (hEdit2, PChar(S));
end;
function swl_EditWndProc (hWnd:HWnd; uMsg:UInt; wParam:WParam; lParam:LParam) :LResult; stdcall;
begin
Result := CallWindowProc (swl_OldProc, hWnd, uMsg, wParam, lParam);
if (uMsg = wm_SetText) then Reveal_Text(lParam);
end;
function sws_EditWndProc (hWnd:HWND; uMsg:UINT; wParam:WPARAM; lParam:LPARAM; uIdSubclass:UINT_PTR; dwRefData:DWORD_PTR) :LRESULT; stdcall;
begin
Result := DefSubclassProc (hWnd, uMsg, wParam, lParam);
if (uMsg = wm_SetText) then Reveal_Text(lParam);
end;
procedure do_SetWindowSubclass;
begin
if not SetWindowSubclass (hEdit, #sws_EditWndProc, 1, dword_ptr($1234{whatever}))
then RaiseLastOSError;
SubMode := subSetWindowSubclass;
end;
procedure undo_SetWindowSubclass;
begin
if not RemoveWindowSubclass (hEdit, #sws_EditWndProc, 1)
then RaiseLastOSError;
SubMode := subSetWindowLong; // restored
end;
function AppWindowProc (hWnd:HWnd; uMsg:UInt; wParam:WParam; lParam:LParam) :LResult; stdcall;
begin
case uMsg of
wm_Command:
begin
if (lParam = hButton) then
case SubMode of
subSetWindowLong:
begin
do_SetWindowSubclass; // now using SetWindowSubclass()
SetWindowText (hEdit, PChar(strTextUsingPWideChar));
SetWindowText (hButton, PChar('Switch back to SetWindowLong mode'));
end;
subSetWindowSubclass:
begin
undo_SetWindowSubclass; // back to SetWindowLong()
SetWindowText (hEdit, PChar(strTextUsingPAnsiChar));
SetWindowText (hButton, PChar('Switch to SetWindowSubclass mode'));
end;
end;
end;
wm_Destroy:
begin
Release_Resources;
PostQuitMessage (0);
Exit;
end;
end;
Result := DefWindowProc (hWnd, uMsg, wParam, lParam);
end;
var
W,H :Integer;
begin
wc.hInstance := hInstance;
wc.lpszClassName := 'ANSI_Wnd';
wc.Style := cs_ParentDC;
wc.hIcon := LoadIcon(hInstance,'MAINICON');
wc.lpfnWndProc := #AppWindowProc;
wc.hbrBackground := GetStockObject(white_brush);
wc.hCursor := LoadCursor(0,IDC_ARROW);
RegisterClass(wc); // ANSI (using Delphi 7, so all Windows API is mapped to ANSI).
W := 500;
H := 480;
hMainHandle := CreateWindow ( // ANSI (using Delphi 7, so all Windows API is mapped to ANSI).
wc.lpszClassName,'2-Way Subclassing App',
ws_OverlappedWindow or ws_Caption or ws_MinimizeBox or ws_SysMenu or ws_Visible,
((GetSystemMetrics(SM_CXSCREEN)-W) div 2), // vertically centered in screen
((GetSystemMetrics(SM_CYSCREEN)-H) div 2), // horizontally centered in screen
W,H,0,0,hInstance,nil);
// create the fonts
hFont := CreateFont (-14,0,0,0,0,0,0,0, default_charset, out_default_precis, clip_default_precis, default_quality, variable_pitch or ff_swiss, 'Tahoma');
hFont2:= CreateFont (-14,0,0,0,0,0,0,0, default_charset, out_default_precis, clip_default_precis, default_quality, variable_pitch or ff_swiss, 'Courier New');
// create the edits
hEdit :=CreateWindowEx (WS_EX_CLIENTEDGE,'EDIT','some text', WS_VISIBLE or WS_CHILD or ES_LEFT or ES_AUTOHSCROLL, 10,35,W-40, 23,hMainHandle,0,hInstance,nil);
hEdit2:=CreateWindowEx (WS_EX_CLIENTEDGE,'EDIT','details', WS_VISIBLE or WS_CHILD or ES_LEFT or ES_AUTOHSCROLL or ES_MULTILINE,10,72,W-40,300,hMainHandle,0,hInstance,nil);
SendMessage(hEdit, WM_SETFONT,hFont, 0);
SendMessage(hEdit2,WM_SETFONT,hFont2,0);
// create the button
hButton:=CreateWindow ('Button','Switch to SetWindowSubclass mode', WS_VISIBLE or WS_CHILD or BS_PUSHBUTTON or BS_TEXT, 90,H-95,290,32,hMainHandle,0,hInstance,nil);
SendMessage(hButton,WM_SETFONT,hFont,0);
// subclass the Edit using the default method.
swl_OldProc := Pointer(GetWindowLong(hEdit,GWL_WNDPROC));
SetWindowLong (hEdit,GWL_WNDPROC,Longint(#swl_EditWndProc));
SubMode := subSetWindowLong;
SetWindowText (hEdit, PChar(strTextUsingPAnsiChar));
// message loop
while GetMessage(Msg,0,0,0) do
begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
end.
The application has 2 edit controls:
The smaller one, which is subclassed in 2 switchable ways (here called Modes).
The bigger one, like a memo, not subclassed. Just for dumping info.
There is also a button for switching between the modes.
The default subclassing mode uses SetWindowLong() (the classic way):
In Delphi 2007 and earlier, the main window (and all child controls) are created using the ANSI version of the Win32 API procedures, so the message handler (of the subclassed control) should receive ANSI text (along with the WM_SETTEXT message), always!
The problem is that's not happening when the edit control is subclassed using SetWindowSubclass()! SetWindowSubClass() changes the window from ANSI to UNICODE and it starts receiving Unicode text rather than the expected ANSI text.
Pressing the button subclasses the edit control via SetWindowSubclass():
Pressing the button again subclasses the edit control via SetWindowLong().
Once back to the SetWindowLong() mode, the edit control automatically receives ANSI text again:
Just run the application and try switching between modes. Look carefully at the detailed info shown in the bigger edit control.
Just to be clear: I think this is a Microsoft bug. However, in case it's a "feature", could someone lead me to the respective documentation? I could not find it anywhere.
According to MSDN:
Subclassing Controls Using ComCtl32.dll version 6
Note ComCtl32.dll version 6 is Unicode only. The common controls
supported by ComCtl32.dll version 6 should not be subclassed (or
superclassed) with ANSI window procedures.
...
Note All strings passed to the procedure are Unicode strings even if Unicode is not specified as a preprocessor definition.
So it seems this is as designed.
comctl32.dll in my c:\windows\syswow64 folder is version 6.1.

Delphi - OleContainer - PowerPoint - AutoPlay

Good afternoon :-), in my application I use OleContainer to view presentation from Microsoft Powerpoint.
This code I use to load and run presentation file:
with oleContainer do begin
Parent := mediaPanel; Left := 0; Top := 0;
Width := mediaPanel.Width; Height := mediaPanel.Height;
CreateObjectFromFile('C:\Users\Nanik\Desktop\Present.ppt', false);
Iconic := false; Visible := true; Run;
end;
The presentation was created as autoplay slideshow (in Microsoft PowerPoint working), but in my application presentation was still on first slide. Run command isn't right?
You do not need a OleContainer to run the presentation inside a container in your application. Put a panel container to run the presentation in your form and try this routine:
procedure TForm2.Button3Click(Sender: TObject);
const
ppShowTypeSpeaker = 1;
ppShowTypeInWindow = 1000;
SHOW_FILE = 'C:\Users\jcastillo\Documents\test.pps';
var
oPPTApp: OleVariant;
oPPTPres: OleVariant;
screenClasshWnd: HWND;
pWidth, pHeight: Integer;
function PixelsToPoints(Val: Integer; Vert: Boolean): Integer;
begin
if Vert then
Result := Trunc(Val * 0.75)
else
Result := Trunc(Val * 0.75);
end;
begin
oPPTApp := CreateOleObject('PowerPoint.Application');
oPPTPres := oPPTApp.Presentations.Open(SHOW_FILE, True, True, False);
pWidth := PixelsToPoints(Panel1.Width, False);
pHeight := PixelsToPoints(Panel1.Height, True);
oPPTPres.SlideShowSettings.ShowType := ppShowTypeSpeaker;
oPPTPres.SlideShowSettings.Run.Width := pWidth;
oPPTPres.SlideShowSettings.Run.Height := pHeight;
screenClasshWnd := FindWindow('screenClass', nil);
Windows.SetParent(screenClasshWnd, Panel1.Handle);
end;
I do not have documentation at hand, but my thought is Run.Width and Run.Height must be provided in points, not in pixels. My poor man solution to convert pixels to points is here, and it works for me in my tests here... to find the correct way to convert in your environment is up to you.
Is supposed you can get the Handle of the presentation window from the oPPTPres.SlideShowSettings.Run.HWND property, but that does not work here for me, hence the FindWindow call.
Run is a method of TOleContainer, it is not a method specific to any kind of OLE object, say, a power point presentation or a bitmap image.. Documentation states "Call Run to ensure that the server application is running..".
You need to call object specific methods to operate on them, see PowerPoint Object Model Reference. Sample code:
procedure TForm1.Button1Click(Sender: TObject);
const
ppAdvanceOnTime = $00000002;
var
P: OleVariant;
S: OleVariant;
i: Integer;
begin
P := OleContainer1.OleObject.Application.Presentations.Item(1);
// below block would not be necessary for a slide show (i.e. a *.pps)
for i := 1 to P.Slides.Count do begin
P.Slides.Item(i).SlideShowTransition.AdvanceOnTime := True;
P.Slides.Item(i).SlideShowTransition.AdvanceTime := 1;
end;
S := P.SlideShowSettings;
S.AdvanceMode := ppAdvanceOnTime;
S.Run;
end;
Though the above will run the presentation as a slide show, it is probably not what you'd want because it runs in full screen. I have no idea how to run it in the container window..

Minimize a external application with Delphi

Is there a way to Minimize an external application that I don't have control over from with-in my Delphi application?
for example notepad.exe, except the application I want to minimize will only ever have one instance.
You can use FindWindow to find the application handle and ShowWindow to minimize it.
var
Indicador :Integer;
begin
// Find the window by Classname
Indicador := FindWindow(PChar('notepad'), nil);
// if finded
if (Indicador <> 0) then begin
// Minimize
ShowWindow(Indicador,SW_MINIMIZE);
end;
end;
I'm not a Delphi expert, but if you can invoke win32 apis, you can use FindWindow and ShowWindow to minimize a window, even if it does not belong to your app.
Thanks for this, in the end i used a modifyed version of Neftali's code, I have included it below in case any one else has the same issues in the future.
FindWindow(PChar('notepad'), nil);
was always returning 0, so while looking for a reason why I found this function that would find the hwnd, and that worked a treat.
function FindWindowByTitle(WindowTitle: string): Hwnd;
var
NextHandle: Hwnd;
NextTitle: array[0..260] of char;
begin
// Get the first window
NextHandle := GetWindow(Application.Handle, GW_HWNDFIRST);
while NextHandle > 0 do
begin
// retrieve its text
GetWindowText(NextHandle, NextTitle, 255);
if Pos(WindowTitle, StrPas(NextTitle)) <> 0 then
begin
Result := NextHandle;
Exit;
end
else
// Get the next window
NextHandle := GetWindow(NextHandle, GW_HWNDNEXT);
end;
Result := 0;
end;
procedure hideExWindow()
var Indicador:Hwnd;
begin
// Find the window by Classname
Indicador := FindWindowByTitle('MyApp');
// if finded
if (Indicador <> 0) then
begin
// Minimize
ShowWindow(Indicador,SW_HIDE); //SW_MINIMIZE
end;
end;
I guess FindWindow(PChar('notepad'), nil) should be FindWindow(nil, PChar('notepad')) to find the window by title.

Resources