I am currently trying to take a screenshot of a 2D Firemonkey (FMX) form from another process.
The following is using a well-known method based of GDI, using a BitBlt() to produce a bitmap, and WIC to save it to a PNG file.
{...}
uses
system.UITypes,
system.SysUtils,
system.Hash,
{$IF Defined(MSWINDOWS)}
winapi.Windows,
Winapi.Direct3D9,
WinApi.D3DX9,
Winapi.Wincodec,
WinApi.ActiveX,
{$ENDIF}
{ some internal units }
path.types,
path.utils,
os.utils;
{...}
Type
TWindowSnapshot = record
window_handle: THandle; // handle to window
process_id: Cardinal; // PID of the process
window_rect: TRect; // position of the window
title: string; // title
file_path: string; // path to the window's image file
end;
TWindowSnapshots = Tarray<TWindowSnapshot>;
procedure HRCHECK(r: HRESULT); inline;
begin
if r <> S_OK then abort;
end;
function pad(s,g:integer): integer; inline;
begin
dec(g);
result := (s + g) and not g;
end;
function WICSavePixelsToPng(r: TRect; stride: cardinal; pixels: PByte; filePath: string): HRESULT;
var
factory: IWICImagingFactory;
encoder: IWICBitmapEncoder;
frame: IWICBitmapFrameEncode;
encoderOptions: IPropertyBag2;
stream: IWICStream;
pf: TGUID;
coInit : HResult;
begin
result := E_INVALIDARG;
if not assigned(pixels) then exit;
if (filepath = '') then exit;
coInit := CoInitialize(nil);
pf := GUID_WICPixelFormat32bppBGRA;
result := CoCreateInstance(CLSID_WICImagingFactory, nil, CLSCTX_INPROC_SERVER, IWICImagingFactory, factory);
if result <> S_OK then exit;
result := factory.CreateStream(&stream);
if result <> S_OK then exit;
result := stream.InitializeFromFilename(PWideChar(filePath), GENERIC_WRITE);
if result <> S_OK then exit;
result := factory.CreateEncoder(GUID_ContainerFormatPng, TGUID.Empty, encoder);
if result <> S_OK then exit;
result := encoder.Initialize(stream, WICBitmapEncoderNoCache);
if result <> S_OK then exit;
result := encoder.CreateNewFrame(frame, encoderOptions);
if result <> S_OK then exit;
result := frame.Initialize(nil);
if result <> S_OK then exit;
result := frame.SetSize(r.width, r.height);
if result <> S_OK then exit;
result := frame.SetPixelFormat(pf);
if result <> S_OK then exit;
if pf <> GUID_WICPixelFormat32bppBGRA then
begin
assert(false,'ToDo');
end;
inc(pixels,(r.Left*4) + r.Top * stride);
result := frame.WritePixels(r.height, stride, stride * r.height, pixels);
if result <> S_OK then exit;
result := frame.Commit();
if result <> S_OK then exit;
result := encoder.Commit();
if (coInit <> 0) then
CoUninitialize();
end;
function take_window_snapshot_GDI(win_handle: THandle; PID: Cardinal; out cs: TWindowSnapshot; const image_folder: string): boolean;
var
Wr: TRect;
HdcSRC: HDC;
hDCDest: HDC;
hBmp: HBITMAP;
hOld: HGDIOBJ;
hFlags: Cardinal;
l: integer;
src_shot,dst_shot,lsrc,ldst: PByte;
sr: PRGBTriple;
dr: PRGBQuad;
buff_size: cardinal;
x,y, src_stride, dst_stride: integer;
bi: tagBITMAPINFO;
begin
result := false;
cs.window_handle := win_handle;
cs.title := '';
cs.window_rect := TRect.Empty;
cs.process_id := 0;
try
hFlags := GetWindowLong(win_handle,GWL_STYLE);
if (hFlags and (WS_DLGFRAME or WS_POPUP)) = 0 then exit;
if (hFlags and WS_VISIBLE) = 0 then exit;
GetWindowRect(win_handle,Wr);
if (Wr.Width = 0) or (Wr.Height = 0) then exit;
L := GetWindowTextLength(win_handle);
if L > 0 then
begin
setlength(cs.title,L);
GetWindowText(win_handle,pchar(cs.title),L+1);
end;
{ reserve memory for bitmaps }
src_stride := pad((wr.Width * 3),4);
dst_stride := pad((wr.Width * 4),4);
buff_size := src_stride * wr.Height;
getmem(src_shot,buff_size);
if not assigned(src_shot) then exit;
getmem(dst_shot,dst_stride * wr.Height);
if not assigned(src_shot) then
begin
freemem(src_shot);
exit;
end;
try
try
HdcSRC := GetWindowDC(win_handle);
HdcDest := CreateCompatibleDC(HdcSRC);
SetStretchBltMode(HdcDest, COLORONCOLOR);
HBmp := CreateCompatibleBitmap(HdcSRC,Wr.Width,wr.Height);
hOld := SelectObject(hDCDest,hBmp);
BitBlt(hDCDest,0,0,wr.width,wr.Height,HdcSRC,0,0,SRCCOPY);
{ target bitplane is 24 bits RGB }
bi := default(tagBITMAPINFO);
bi.bmiHeader.biSize := sizeof(TBitmapInfoHeader);
bi.bmiHeader.biWidth := wr.Width;
bi.bmiHeader.biHeight := wr.Height;
bi.bmiHeader.biPlanes := 1;
bi.bmiHeader.biBitCount := 24;
bi.bmiHeader.biCompression := BI_RGB;
GetDIBits(hDCDest,HBmp,0,wr.Height,src_shot,bi,DIB_RGB_COLORS);
{ now convert pixels to RGBA, in correct line order.
On Windows, last line is first in bitmap }
ldst := dst_shot;
lsrc := src_shot + (src_stride * wr.Height);
for y := 0 to wr.Height - 1 do
begin
dec(lsrc,src_stride);
sr := pointer(lsrc);
dr := pointer(ldst);
for x := 0 to wr.Width - 1 do
begin
dr.rgbBlue := sr.rgbtBlue;
dr.rgbRed := sr.rgbtRed;
dr.rgbGreen := sr.rgbtGreen;
dr.rgbReserved := 255;
inc(dr);
inc(sr);
end;
inc(ldst,dst_stride);
end;
{ save to PNG with WIC }
var tmp_name := Tpath.GetTempFileName('png',false,image_folder);
wr.Offset(-wr.Left,-wr.top);
if WICSavePixelsToPng(wr,dst_stride,dst_shot,tmp_name) = S_OK then
begin
result := true;
{ rename temp file name to new name if it doesn't exist already }
var new_name := Tpath.ExtractDirectory(tmp_name) + THashSHA1.GetHashStringFromFile(tmp_name) + '.png';
if not TPath.FileExists(new_name) then
begin
if Tfile.Rename(tmp_name,new_name) then
begin
cs.file_path := '';
end else begin
cs.file_path := new_name;
end;
end else begin
cs.file_path := new_name;
end;
end;
Tfile.Delete(tmp_name);
result := true;
finally
freemem(src_shot);
freemem(dst_shot);
end;
finally
SelectObject(hDCDest,hold);
DeleteDC(hDCDest);
ReleaseDC(win_handle,HdcSRC);
end;
except begin
result := false;
end;
end;
end;
This method is working for Delphi forms using VCL, however with forms using Firemonkey (FMX) 2D, it only produces bitmaps filled with BLACK (0) pixels.
I have tried an alternative using Direct3D9, that is working for Firemonkey form, however with a limitation I'll explain after the code snippet
function Take_window_snapshot_D3D(win_handle: THandle; PID: Cardinal; out cs: TWindowSnapshot; const image_folder: string): boolean;
var
D3D: IDirect3D9;
D3DDevice: IDirect3DDevice9;
mode: D3DDISPLAYMODE;
device: IDirect3DDevice9;
surface: IDirect3DSurface9;
parameters: D3DPRESENT_PARAMETERS;
rc: D3DLOCKED_RECT;
pitch: UINT;
shot: PByte;
shot_size: cardinal;
adapter: cardinal;
wr: TRect;
hCurWnd: THandle;
hCurThreadID: Cardinal;
L: integer;
hFlags: cardinal;
hr: HRESULT;
begin
result := false;
cs := default(TWindowSnapshot);
try
{ get the window type }
hFlags := GetWindowLong(win_handle,GWL_STYLE);
if (hFlags and (WS_DLGFRAME or WS_POPUP)) = 0 then exit;
if (hFlags and WS_VISIBLE) = 0 then exit;
{ size }
GetWindowRect(win_handle,Wr);
if (Wr.Width = 0) or (Wr.Height = 0) then exit;
{ title }
L := GetWindowTextLength(win_handle);
if L > 0 then
begin
setlength(cs.title,L);
GetWindowText(win_handle,pchar(cs.title),L+1);
end;
cs.window_handle := win_handle;
cs.window_rect := wr;
cs.process_id := PID;
{ Direct3D capture }
adapter := D3DADAPTER_DEFAULT;
D3D := Direct3DCreate9(D3D_SDK_VERSION);
HRCHECK(D3D.GetAdapterDisplayMode(adapter,mode));
parameters := default(D3DPRESENT_PARAMETERS);
parameters.Windowed := TRUE;
parameters.BackBufferCount := 1;
parameters.BackBufferHeight := mode.Height;
parameters.BackBufferWidth := mode.Width;
parameters.SwapEffect := D3DSWAPEFFECT_DISCARD;
parameters.hDeviceWindow := win_handle;
{ create device & capture surface }
HRCHECK(d3d.CreateDevice(adapter, D3DDEVTYPE_HAL, win_handle, D3DCREATE_SOFTWARE_VERTEXPROCESSING, #parameters, device));
{ create surface }
HRCHECK(device.CreateOffscreenPlainSurface(mode.Width, mode.Height, D3DFMT_A8R8G8B8, D3DPOOL_SYSTEMMEM, &surface, nil));
{ bring our window to front }
hCurWnd := GetForegroundWindow;
hCurThreadID := GetCurrentThreadId;
AttachThreadInput(PID,hCurThreadID,TRUE);
SetWindowPos(win_handle,HWND_TOPMOST,0,0,0,0,SWP_NOSIZE or SWP_NOMOVE);
SetWindowPos(win_handle,HWND_NOTOPMOST,0,0,0,0,SWP_SHOWWINDOW or SWP_NOSIZE or SWP_NOMOVE);
SetForegroundWindow(win_handle);
SetFocus(win_handle);
SetActiveWindow(win_handle);
AttachThreadInput(PID,hCurThreadID,false);
{ Obtain stride value to allocate buffer }
HRCHECK(surface.LockRect(rc,nil,0));
pitch := rc.Pitch;
HRCHECK(surface.UnlockRect());
shot_size := pitch*mode.Height;
getmem(shot,shot_size);
if not assigned(shot) then abort;
try
{ get surface data }
HRCHECK(device.GetFrontBufferData(0, surface));
{ copy surface data }
HRCHECK(surface.LockRect(rc,nil,0));
move(rc.pBits^,shot^,shot_size);
HRCHECK(surface.UnlockRect());
{ save snapshot to file using WIC, using a temporary file name first }
var tmp_name := Tpath.GetTempFileName('png',false,image_folder);
if WICSavePixelsToPng(wr,pitch,shot,tmp_name) = S_OK then
begin
result := true;
{ rename temp file name to new name if it doesn't exist already }
var new_name := Tpath.ExtractDirectory(tmp_name) + THashSHA1.GetHashStringFromFile(tmp_name) + '.png';
if not TPath.FileExists(new_name) then
begin
if Tfile.Rename(tmp_name,new_name) then
begin
cs.file_path := '';
end else begin
cs.file_path := new_name;
end;
end else begin
cs.file_path := new_name;
end;
end;
Tfile.Delete(tmp_name);
finally
FreeMem(shot);
end;
except
result := false;
end;
end;
The limitation that I have with the D3D method is that in reality I don't take a snapshot of a specific window but I take a snapshot of the entire screen that I crop after to take only the window of my interest.
For that, I must bring first the target window to front, but in some case this may not be possible. For instance if the target form is behind a modal form, it might be partially or totally hidden, as one can see below
So, my question : Is it possible to take a snapshot / print a single Firemonkey 2D form from another process, even if the form is not modal / partially covered by another form.
(Sorry for an answer here rather than a comment, which I can't do.)
I know little about working with different processes, but do you realise that FMX has a snapshot ability built in?
TControl.MakeScreenshot returns a bitmap of the control (with child controls). So if you can call that from the other process and return the result, that might solve your problem.
However, this won't meet your needs if you literally need the whole form including the non-client area, as a form doesn't have that method. If the contents of the form are all you need, and you have a control (e.g. a TLayout) filling the form and containing all the child controls, you could use the .MakeScreenshot of that bottom control.
And yes, .MakeScreeshot works even if something else is covering the form.
I found that the gettickdiff64 function sometimes results in 18446744073709551600 (or 18446744073709551601) and causes the
program to run incorrectly.
Normally does not have a result greater than 300000
what might this be about?
Should I always do extra checks against this problem?
it is 32 bit VCL application.
I use Delphi 10.4.1( its indy version 10.6.2.0 )
Running on: 64 bit Windows Server 2012 R2 Foundation / intel xeon cpu E3-1225 v5 3.3 Ghz.
The code structure is as follows:
TMyClass = class
private
//.............
lastSetTime: uint64;
critic: TCriticalSection;
public
//.............
procedure setLastSetTime( ltime: uint64 );
function getLastSetTime: uint64;
end;
procedure TMyClass.setLastSetTime( ltime: uint64 );
begin
critic.enter;
try
lastSetTime := ltime;
finally
critic.leave;
end;
end;
function TMyClass.getLastSetTime: uint64;
begin
critic.enter;
try
result := lastSetTime;
finally
critic.leave;
end;
end;
...........
procedure controlAll(); //------>this is called from within thread every 5 minutes
var oki: boolean;
starttime, tdiff, ltime: uint64;
i: integer;
myC, sC: TMyClass;
begin
oki := false;
starttime := ticks64();
while ( oki = false ) and ( gettickdiff64( starttime, ticks64 ) < 40000 ) do
begin
//.........
//.........
sC := nil;
with myClassList.LockList do
try
if count > 0 then //---> has about 50000
begin
i := 0;
while i < count do
begin
myC := TMyClass( items[ i ] );
ltime := myC.getLastSetTime();
tdiff := gettickdiff64( ltime, ticks64() );
if tdiff > 50000 then
begin
logToFile( tdiff.ToString + ' ' + ltime.ToString ); //-----> every 5 minutes 50-60 log lines occur like this: 18446744073709551600 468528329
//..........
//.........
sC := myC;
delete( i );
break;
end;
inc( i );
end;
end;
finally
myClassList.UnlockList;
end;
if sC = nil then oki := true
else
begin
//..........
//..........
end;
end;
end;
The code structure that sets this value is as follows.
classListArray keeps all classes of TMyClass type grouped by server and channel number.
myClassList keeps all classes of type TMyClass attached one after the other without grouping.
classListArray is used to spend less CPU and process faster.
These two lists are not protected against each other when accessing classes.
Protection against each other is done only when adding and deleting classes.
classListArray: array[ 1..250, 1..12 ] of TThreadList;
//.................
procedure ServerExecute(AContext: TIdContext);
var Ath: TMypeer;
severNum, channelNum, clientNum, i, j, num: integer;
pSize: word;
stream: Tmemorystream;
packageNum: byte;
begin
try
Ath := TMypeer( AContext );
serverNum := Ath.getServerNum();
channelNum := Ath.getChannelNum();
Ath.SendQueue();
if AContext.Connection.IOHandler.InputBufferIsEmpty then
if not AContext.Connection.IOHandler.CheckForDataOnSource( 50 ) then Exit;
clientNum := AContext.Connection.IOHandler.ReadInt32( false );
pSize := AContext.Connection.IOHandler.ReadUInt16( false );
stream := TMemorystream.create;
try
AContext.Connection.IOHandler.ReadStream( stream, pSize );
stream.Seek( 0, soFromBeginning );
if clientNum <> 0 then
begin
//...........
end
else
begin
stream.ReadBuffer( packageNum, sizeof( packageNum ) );
if packageNum = 10 then
begin
stream.ReadBuffer( num, sizeof( num ) );
for i := 1 to num do
begin
stream.ReadBuffer( clientNum, sizeof( clientNum ) );
with classListArray[ serverNum, channelNum ].LockList do
try
if count > 0 then
for j := 0 to count - 1 do
begin
if TMyClass( items[ j ] ).getClientNum = clientNum then
begin
TMyClass( items[ j ] ).setLastSetTime( ticks64 ); //**********
break;
end;
end;
finally
classListArray[ serverNum, channelNum ].unLockList;
end;
end;
end
else
//.........
end;
finally
stream.free;
end;
except on e:exception do
begin
if E is Eidexception then raise
else
begin
logToFile( e.message );
//..........
end;
end;
end;
end;
According to your log, ltime was 468528329 and GetTickDiff64(ltime, Ticks64()) returned 18446744073709551600. Given the simple implementation of GetTickDiff64() (where TIdTicks is UInt64):
function GetTickDiff64(const AOldTickCount, ANewTickCount: TIdTicks): TIdTicks;
{$IFDEF USE_INLINE}inline;{$ENDIF}
begin
{This is just in case the TickCount rolled back to zero}
if ANewTickCount >= AOldTickCount then begin
Result := TIdTicks(ANewTickCount - AOldTickCount);
end else begin
Result := TIdTicks(((High(TIdTicks) - AOldTickCount) + ANewTickCount) + 1);
end;
end;
The only way this code can return 18446744073709551600 given AOldTickCount=468528329 is if ANewTickCount is either 18446744074178079929 or 468528313.
Since VCL runs on Windows only, and on Windows Ticks64() is just a thin wrapper around the Win32 GetTickCount64() function on Vista and later, it is very unlikely that Windows would ever produce such an astronomically large number like 18446744074178079929 for the current tick counter (that would be 213503982340 days from bootup). So it must have returned 468528313 instead, which is more reasonable (that is just 5.4 days from bootup). That is 16ms less than ltime=468528329, so GetTickDiff64() would assume that Windows' tick counter had exceeded High(UInt64) and wrapped back around to 0 (which is unlikely for a 64-bit tick counter to ever do in our lifetime).
So, you need to debug your code and figure out how Ticks64()/Windows could possibly return 468528329 and then later return 468528313. I suspect it is really not doing that, and that there is more likely a bug in your code that we can't see which is storing the wrong value into TMyClass.lastSetTime to begin with.
That being said, you might consider getting rid of the overhead of TCriticalSection and use TInterlocked instead to read/write your UInt64 member atomically.
Or, try using Delphi's own TStopWatch instead of tracking ticks manually.
I created an Input page that executes a command line app using the created variables from those inputs. Naturally, the cmd window pop ups on my screen. I would like to know if there is any way to embed the cmd window (or the output) on my Inno Setup installer page.
I'm running Inno Setup 5.6.1 (because of Windows XP compatibility), but I'm OK if I have to switch to the last version.
[Code]
var
MAIL: TInputQueryWizardPage;
Final: TWizardPage;
BotonIniciar: Tbutton;
procedure BotonIniciarOnClick(Sender: TObject);
begin
WizardForm.NextButton.Onclick(nil);
Exec(ExpandConstant('{tmp}\imapsync.exe'),'MAIL.Values[0]','', SW_SHOW,
ewWaitUntilTerminated, ResultCode);
end;
procedure InitializeWizard;
begin
MAIL := CreateInputQueryPage(wpWelcome, '', '', '');
MAIL.Add('Please input your information', False);
BotonIniciar := TNewButton.Create(MAIL);
BotonIniciar.Caption := 'Iniciar';
BotonIniciar.OnClick := #BotonIniciarOnClick;
BotonIniciar.Parent := WizardForm;
BotonIniciar.Left := WizardForm.NextButton.Left - 250 ;
BotonIniciar.Top := WizardForm.CancelButton.Top - 10;
BotonIniciar.Width := WizardForm.NextButton.Width + 60;
BotonIniciar.Height := WizardForm.NextButton.Height + 10;
end;
I'm might be missing some parts of the code, but I think it's understandable.
Fist I create the input page, then I create a button with the OnClick property that calls to the BotonIniciarOnClick procedure.
Actually, the code works great. But as I said I'm having a floating cmd window.
I would like to see something like this:
It's just a random image I took from google.
What I want to see is similar to a standard "show details" option on an installer.
You can redirect the command output to a file and monitor the file for changes, loading them to list box (or maybe a memo box).
var
ProgressPage: TOutputProgressWizardPage;
ProgressListBox: TNewListBox;
function SetTimer(
Wnd: LongWord; IDEvent, Elapse: LongWord; TimerFunc: LongWord): LongWord;
external 'SetTimer#user32.dll stdcall';
function KillTimer(hWnd: LongWord; uIDEvent: LongWord): BOOL;
external 'KillTimer#user32.dll stdcall';
var
ProgressFileName: string;
function BufferToAnsi(const Buffer: string): AnsiString;
var
W: Word;
I: Integer;
begin
SetLength(Result, Length(Buffer) * 2);
for I := 1 to Length(Buffer) do
begin
W := Ord(Buffer[I]);
Result[(I * 2)] := Chr(W shr 8); { high byte }
Result[(I * 2) - 1] := Chr(Byte(W)); { low byte }
end;
end;
procedure UpdateProgress;
var
S: AnsiString;
I, L, Max: Integer;
Buffer: string;
Stream: TFileStream;
Lines: TStringList;
begin
if not FileExists(ProgressFileName) then
begin
Log(Format('Progress file %s does not exist', [ProgressFileName]));
end
else
begin
try
// Need shared read as the output file is locked for writing,
// so we cannot use LoadStringFromFile
Stream :=
TFileStream.Create(ProgressFileName, fmOpenRead or fmShareDenyNone);
try
L := Stream.Size;
Max := 100*2014;
if L > Max then
begin
Stream.Position := L - Max;
L := Max;
end;
SetLength(Buffer, (L div 2) + (L mod 2));
Stream.ReadBuffer(Buffer, L);
S := BufferToAnsi(Buffer);
finally
Stream.Free;
end;
except
Log(Format('Failed to read progress from file %s - %s', [
ProgressFileName, GetExceptionMessage]));
end;
end;
if S <> '' then
begin
Log('Progress len = ' + IntToStr(Length(S)));
Lines := TStringList.Create();
Lines.Text := S;
for I := 0 to Lines.Count - 1 do
begin
if I < ProgressListBox.Items.Count then
begin
ProgressListBox.Items[I] := Lines[I];
end
else
begin
ProgressListBox.Items.Add(Lines[I]);
end
end;
ProgressListBox.ItemIndex := ProgressListBox.Items.Count - 1;
ProgressListBox.Selected[ProgressListBox.ItemIndex] := False;
Lines.Free;
end;
// Just to pump a Windows message queue (maybe not be needed)
ProgressPage.SetProgress(0, 1);
end;
procedure UpdateProgressProc(
H: LongWord; Msg: LongWord; Event: LongWord; Time: LongWord);
begin
UpdateProgress;
end;
procedure BotonIniciarOnClick(Sender: TObject);
var
ResultCode: Integer;
Timer: LongWord;
AppPath: string;
AppError: string;
Command: string;
begin
ProgressPage :=
CreateOutputProgressPage(
'Installing something', 'Please wait until this finishes...');
ProgressPage.Show();
ProgressListBox := TNewListBox.Create(WizardForm);
ProgressListBox.Parent := ProgressPage.Surface;
ProgressListBox.Top := 0;
ProgressListBox.Left := 0;
ProgressListBox.Width := ProgressPage.SurfaceWidth;
ProgressListBox.Height := ProgressPage.SurfaceHeight;
// Fake SetProgress call in UpdateProgressProc will show it,
// make sure that user won't see it
ProgressPage.ProgressBar.Top := -100;
try
Timer := SetTimer(0, 0, 250, CreateCallback(#UpdateProgressProc));
ExtractTemporaryFile('install.bat');
AppPath := ExpandConstant('{tmp}\install.bat');
ProgressFileName := ExpandConstant('{tmp}\progress.txt');
Log(Format('Expecting progress in %s', [ProgressFileName]));
Command := Format('""%s" > "%s""', [AppPath, ProgressFileName]);
if not Exec(ExpandConstant('{cmd}'), '/c ' + Command, '', SW_HIDE,
ewWaitUntilTerminated, ResultCode) then
begin
AppError := 'Cannot start app';
end
else
if ResultCode <> 0 then
begin
AppError := Format('App failed with code %d', [ResultCode]);
end;
UpdateProgress;
finally
// Clean up
KillTimer(0, Timer);
ProgressPage.Hide;
DeleteFile(ProgressFileName);
ProgressPage.Free();
end;
if AppError <> '' then
begin
// RaiseException does not work properly while
// TOutputProgressWizardPage is shown
RaiseException(AppError);
end;
end;
Above was tested with a batch file like:
#echo off
echo Starting
echo Doing A...
echo Extracting something...
echo Doing B...
echo Extracting something...
timeout /t 1 > nul
echo Doing C...
echo Extracting something...
echo Doing D...
echo Extracting something...
timeout /t 1 > nul
echo Doing E...
echo Extracting something...
echo Doing F...
echo Extracting something...
timeout /t 1 > nul
...
If you want to display the output as part of the installation process, instead of on a button click, see:
Execute a batch file after installation and display its output on a custom page before Finished page in Inno Setup
I've got a Delphi Windows/VCL (XE7) program that embeds CHM help pages in various panels of the program. This largely works fine but the panels always shows an ugly recessed border (looks very windows 95). Here is a screenshot:
Does anyone know how to display the help files with no border? Below is the code I use at the moment. Thanks for any help!
Procedure DoShowEmbeddedHelp(TheWinName: string; ThePanel: TPanel;
var HelpWinHandle: integer; HelpTopic: string; var LastTopic: string;
ByContext: boolean; ContextData: integer; var LastContext: integer);
var
wintypedef: THHWinType;
hf, fn: string;
begin
hf := Gl.ProgramPath + 'leap.chm';
if not FileExists(hf) then
MessageDlg('Help file not found: ' + hf, mtError, [mbOK], 0)
else if ((not ByContext) and (HelpTopic <> LastTopic)) or
(ByContext and (ContextData <> LastContext)) then
begin
if not ByContext then
begin
LastTopic := HelpTopic;
LastContext := 0;
end
else
begin
LastContext := ContextData;
LastTopic := '';
end;
fn := hf + '>' + TheWinName;
FillChar(wintypedef, sizeof(wintypedef), 0);
with wintypedef do
begin
cbStruct := sizeof(wintypedef);
fUniCodeStrings := false;
pszType := PAnsiChar(TheWinName);
fsValidMembers :=
HHWIN_PARAM_PROPERTIES or
HHWIN_PARAM_STYLES or
HHWIN_PARAM_EXSTYLES or
HHWIN_PARAM_RECT or
HHWIN_PARAM_NAV_WIDTH or
HHWIN_PARAM_SHOWSTATE or
HHWIN_PARAM_TB_FLAGS or
HHWIN_PARAM_EXPANSION;
fsWinProperties :=
HHWIN_PROP_NOTITLEBAR or
HHWIN_PROP_NO_TOOLBAR or HHWIN_PROP_NODEF_STYLES or
HHWIN_PROP_NODEF_EXSTYLES or
HHWIN_PROP_TRI_PANE;
wintypedef.pszCaption := '';
wintypedef.dwStyles := WS_VISIBLE or WS_CHILDWINDOW;
wintypedef.dwExStyles := WS_EX_LEFT;
wintypedef.rcWindowPos := Rect(0, 0, ThePanel.ClientWidth, ThePanel.ClientHeight);
wintypedef.nShowState := SW_SHOW;
wintypedef.fsToolBarFlags := HHWIN_BUTTON_PRINT or HHWIN_BUTTON_BACK;
fNotExpanded := true;
end;
if integer(HtmlHelp(0, nil, HH_SET_WIN_TYPE, DWORD(#wintypedef))) < 0 then
ShowMessage('Help failed on topic: ' + HelpTopic)
else if ByContext then
HelpWinHandle := HtmlHelp(ThePanel.Handle, PChar(fn), HH_HELP_CONTEXT, ContextData)
else
HelpWinHandle := HtmlHelp(ThePanel.Handle, PChar(fn), HH_DISPLAY_TOPIC, DWORD(PChar('Expressions\' + HelpTopic + '.htm')));
end;
end;
I have developed a TSP to talk to a CTI server. In the most part it works, but when setting the caller/called ID parties, in
function TSPI_lineGetCallInfo(
hdCall : HDRVCALL;
lpCallInfo : LPLINECALLINFO
) : LONG;
I am finding the offsets are all corrects but the size fields are NOT. At the end of the function I output (to debugger) the size and offsets of each field and they are what I expect them to be. But when I inspect the values using a TAPI program the sizes are different, (but the offsets are EXACTLY the same as per the debug statements) in fact the size field 5 regardless of what is actually there, whereas the debug statements at the end of the code below shows the correct values...
Any help greatly appreciated.
lpCallInfo^.dwCallerIDOffset := 0;
lpCallInfo^.dwCallerIDSize := 0;
lpCallInfo^.dwCalledIDOffset := 0;
lpCallInfo^.dwCalledIDSize := 0;
lpCallInfo^.dwConnectedIDOffset := 0;
lpCallInfo^.dwConnectedIDSize := 0;
extnid := thiscall.CallItem.ExtnId;
phoneno := thiscall.CallItem.DialNum;
extnid_size := (Length(extnid) + 1) * sizeof(WCHAR);
phoneno_size := (Length(phoneno) + 1) * sizeof(WCHAR);
extnidw := StringToWideStringEx(extnid, CP_ACP);
phonenow := StringToWideStringEx(phoneno, CP_ACP);
if lpCallInfo^.dwOrigin = LINECALLORIGIN_INTERNAL then
begin
{me}
lpCallInfo^.dwCallerIDOffset := sizeof(TLINECALLINFO);
lpCallInfo^.dwCallerIDSize := extnid_size;
Move(ExtnIdw[1], ptr^, extnid_size * 2);
ptr := Pointer(integer(ptr) + lpCallInfo^.dwCallerIDSize);
{other party}
if phoneno <> '' then
begin
lpCallInfo^.dwCalledIDOffset :=
sizeof(TLINECALLINFO) + lpCallInfo^.dwCallerIDSize;
lpCallInfo^.dwCalledIDSize := phoneno_size;
Move(phonenow[1], ptr^, phoneno_size * 2);
end;
end
else
begin
if thiscall.CallItem.CallType = 1 then
begin {incoming call}
{agent is the called party}
lpCallInfo^.dwCalledIDOffset := sizeof(TLINECALLINFO);
lpCallInfo^.dwCalledIDSize := extnid_size;
Move(ExtnIdw[1], ptr^, extnid_size);
ptr := Pointer(integer(ptr) + lpCallInfo^.dwCalledIDSize);
{other party is the caller}
if phoneno <> '' then
begin
lpCallInfo^.dwCallerIDOffset :=
sizeof(TLINECALLINFO) + lpCallInfo^.dwCalledIDSize;
lpCallInfo^.dwCallerIDSize := phoneno_size;
Move(phonenow[1], ptr^, phoneno_size);
ptr := Pointer(integer(ptr) + lpCallInfo^.dwCallerIDSize);
end;
end
else
begin
{agnet is the caller}
lpCallInfo^.dwCallerIDOffset := sizeof(TLINECALLINFO);
lpCallInfo^.dwCallerIDSize := extnid_size;
Move(ExtnIdw[1], ptr^, extnid_size);
ptr := Pointer(integer(ptr) + lpCallInfo^.dwCallerIDSize);
{dialed number is the called party}
if phoneno <> '' then
begin
lpCallInfo^.dwCalledIDOffset :=
sizeof(TLINECALLINFO) + lpCallInfo^.dwCallerIDSize;
lpCallInfo^.dwCalledIDSize := phoneno_size;
Move(phonenow[1], ptr^, phoneno_size);
ptr := Pointer(integer(ptr) + lpCallInfo^.dwCalledIDSize);
end;
end;
if (thiscall.CallItem.CallState = cs_Connected) and
(phoneno <> '') then
begin
lpCallInfo^.dwConnectedIDOffset := sizeof(TLINECALLINFO) +
lpCallInfo^.dwCallerIDSize + lpCallInfo^.dwCalledIDSize;
lpCallInfo^.dwConnectedIDSize := phoneno_size;
Move(phonenow[1], ptr^, phoneno_size);
ptr := Pointer(integer(ptr) + lpCallInfo^.dwConnectedIDSize);
end;
end;
end;
DEBUG('TSPI_lineGetCallInfo::dwCallerIDOffset=' + intToStr(lpCallInfo^.dwCallerIDOffset));
DEBUG('TSPI_lineGetCallInfo::dwCallerIDSize=' + intToStr(lpCallInfo^.dwCallerIDSize));
DEBUG('TSPI_lineGetCallInfo::dwCalledIDOffset=' + intToStr(lpCallInfo^.dwCalledIDOffset));
DEBUG('TSPI_lineGetCallInfo::dwCalledIDSize=' + intToStr(lpCallInfo^.dwCalledIDSize));
DEBUG('TSPI_lineGetCallInfo::dwConnectedIDOffset=' + intToStr(lpCallInfo^.dwConnectedIDOffset));
DEBUG('TSPI_lineGetCallInfo::dwConnectedIDSize=' + intToStr(lpCallInfo^.dwConnectedIDSize));
These are strange results. Your code seems to check out. It may be a longshot but the result could be caused by too few memory reserved for the lpCallInfo structure. What tapi program do you use? Most programs just reserve a large surplus beforehand. However, another commonly used approach is to 'ask' the TSP the exact amount needed by first calling TSPI_lineGetCallInfo and then reserving the exact amount after you set the dwNeededSize and returning LINEERR_STRUCTURETOOSMALL. You don't seem to check the dwTotalSize or set the dwNeededSize and dwUsedSize fields (which is dangerous).
Please look at the : LINEERR constants
and let me know if it solves the issue. If it doesn't, I would be curious to see the structure log from the Tapi Browser, but let's hope it works. Good luck!