neoturk: ...Start a program and wait for its termination [2] ?...
// First create the special unit and put this code into this new unit:
uses
Windows, Registry, Dialogs, Classes, SysUtils;
var
aProcessInfo: PROCESS_INFORMATION;
aProcessSecAttr: SECURITY_ATTRIBUTES;
aThreadSecAttr: SECURITY_ATTRIBUTES;
aStartupInfo: STARTUPINFO;
function RunApp(commandLine: String): integer;
var
n: Boolean;
begin
with aProcessSecAttr do
begin
bInheritHandle := False;
lpSecurityDescriptor := nil;
nLength := sizeOf(aProcessSecAttr);
end;
with aThreadSecAttr do
begin
bInheritHandle := False;
lpSecurityDescriptor := nil;
nLength := sizeOf(aThreadSecAttr);
end;
with aStartupInfo do
begin
cb := sizeOf(aStartupInfo);
lpReserved := nil;
lpDesktop := nil;
lpTitle := nil;
dwX := 0;
dwY := 0;
dwXSize := 300;
dwYSize := 300;
dwXCountChars := 80;
dwYCountChars := 25;
dwFillAttribute := 0;
dwFlags := STARTF_USESTDHANDLES;
wShowWindow := SW_SHOWDEFAULT;
cbReserved2 := 0;
lpReserved2 := nil;
hStdInput := 0;
hStdError := 0;
hStdOutput := 0;
end;
n := CreateProcess(nil, @commandLine[1], nil, nil,
True, CREATE_NO_WINDOW + NORMAL_PRIORITY_CLASS,
nil, nil, aStartupInfo, aProcessInfo);
If n Then
RunApp := aProcessInfo.hProcess
Else
RunApp := -1;
end;
procedure CloseProcessHandles;
begin
CloseHandle(aProcessInfo.hThread);
CloseHandle(aProcessInfo.hProcess);
end;
// Then you may call the RunApp function:
hProcessHandle := RunApp(sPrintCmd);
if hProcessHandle > 0 then
begin
WaitForSingleObject(hProcessHandle, _YOUR_WAIT_TIME_);
CloseProcessHandles;;
end;
Delphi - .....................................
neoturk: ...Start a program and wait for its termination [2] ?...
// First create the special unit and put this code into this new unit:
uses
Windows, Registry, Dialogs, Classes, SysUtils;
var
aProcessInfo: PROCESS_INFORMATION;
aProcessSecAttr: SECURITY_ATTRIBUTES;
aThreadSecAttr: SECURITY_ATTRIBUTES;
aStartupInfo: STARTUPINFO;
function RunApp(commandLine: String): integer;
var
n: Boolean;
begin
with aProcessSecAttr do
begin
bInheritHandle := False;
lpSecurityDescriptor := nil;
nLength := sizeOf(aProcessSecAttr);
end;
with aThreadSecAttr do
begin
bInheritHandle := False;
lpSecurityDescriptor := nil;
nLength := sizeOf(aThreadSecAttr);
end;
with aStartupInfo do
begin
cb := sizeOf(aStartupInfo);
lpReserved := nil;
lpDesktop := nil;
lpTitle := nil;
dwX := 0;
dwY := 0;
dwXSize := 300;
dwYSize := 300;
dwXCountChars := 80;
dwYCountChars := 25;
dwFillAttribute := 0;
dwFlags := STARTF_USESTDHANDLES;
wShowWindow := SW_SHOWDEFAULT;
cbReserved2 := 0;
lpReserved2 := nil;
hStdInput := 0;
hStdError := 0;
hStdOutput := 0;
end;
n := CreateProcess(nil, @commandLine[1], nil, nil,
True, CREATE_NO_WINDOW + NORMAL_PRIORITY_CLASS,
nil, nil, aStartupInfo, aProcessInfo);
If n Then
RunApp := aProcessInfo.hProcess
Else
RunApp := -1;
end;
procedure CloseProcessHandles;
begin
CloseHandle(aProcessInfo.hThread);
CloseHandle(aProcessInfo.hProcess);
end;
// Then you may call the RunApp function:
hProcessHandle := RunApp(sPrintCmd);
if hProcessHandle > 0 then
begin
WaitForSingleObject(hProcessHandle, _YOUR_WAIT_TIME_);
CloseProcessHandles;;
end;
Delphi - .....................................
neoturk: ...Access listbox items with api ?...
{
This code might be useful for nonVCL applications or to read Listbox
items from another application.
}
{
Die folgenden Funktionen können z.B für nonVCL Projekte verwendet werden
oder auch zum Auslesen von Listboxen aus anderen Applikationen.
}
// Retrieve the number of items in a ListBox
// Anzahl Einträge einer ListBox ermitteln
function LB_GetItemCount(hListBox: THandle): Integer;
begin
Result := SendMessage(hListBox, LB_GETCOUNT, 0, 0);
end;
// Delete a string in a ListBox
// Einen String in einer ListBox löschen
procedure LB_DeleteItem(hListBox: THandle; Index: Integer);
begin
SendMessage(hListBox, LB_DELETESTRING, Index, 0);
end;
// Retrieve the selected item from a ListBox
// Gibt den Text des markiertes Items einer ListBox zurück
function LB_GetSelectedItem(hListBox: THandle): string;
var
Index, len: Integer;
s: string;
buffer: PChar;
begin
Index := SendMessage(hListBox, LB_GETCURSEL, 0, 0);
len := SendMessage(hListBox, LB_GETTEXTLEN, wParam(Index), 0);
GetMem(buffer, len + 1);
SendMessage(hListBox, LB_GETTEXT, wParam(Index), lParam(buffer));
SetString(s, buffer, len);
FreeMem(buffer);
Result := IntToStr(Index) + ' : ' + s;
end;
// Example, Beispiel:
procedure TForm1.Button1Click(Sender: TObject);
var
hListBox: THandle;
begin
hListBox := {...}; // listbox handle
ListBox1.Items.Text := LB_GetSelectedItem(hListBox);
end;
// Retrieve a string from a ListBox
// Gibt den Text eines bestimmten Items einer ListBox zurück
function LB_GetListBoxItem(hWnd: Hwnd; LbItem: Integer): string;
var
l: Integer;
buffer: PChar;
begin
l := SendMessage(hWnd, LB_GETTEXTLEN, LbItem, 0);
GetMem(buffer, l + 1);
SendMessage(hWnd, LB_GETTEXT, LbItem, Integer(buffer));
Result := StrPas(buffer);
FreeMem(buffer);
end;
// Example, Beispiel:
procedure TForm1.Button2Click(Sender: TObject);
var
hListBox: THandle;
begin
hListBox := {...}; // listbox handle
ListBox1.Items.Text := LB_GetListBoxItem(hListBox, 2);
end;
// Gibt den gesamten Text einer ListBox zurück
// Retrieve all listbox items
function LB_GetAllItems(hWnd: Hwnd; sl: TStrings): string;
var
RetBuffer: string;
i, x, y: Integer;
begin
x := SendMessage(hWnd, LB_GETCOUNT, 0, 0);
for i := 0 to x - 1 do
begin
y := SendMessage(hWnd, LB_GETTEXTLEN, i, 0);
SetLength(RetBuffer, y);
SendMessage(hWnd, LB_GETTEXT, i, lParam(PChar(RetBuffer)));
sl.Add(RetBuffer);
end;
end;
// Example, Beispiel:
procedure TForm1.Button3Click(Sender: TObject);
var
sl: TStringList;
ListBox_Handle: THandle;
begin
hListBox := {...}; // listbox handle
sl := TStringList.Create;
try
LB_GetAllItems(ListBox_Handle, sl);
finally
ListBox1.Items.Text := sl.Text;
sl.Free;
end;
end;
Delphi - .....................................
neoturk: ...Access listbox items with api ?...
{
This code might be useful for nonVCL applications or to read Listbox
items from another application.
}
{
Die folgenden Funktionen können z.B für nonVCL Projekte verwendet werden
oder auch zum Auslesen von Listboxen aus anderen Applikationen.
}
// Retrieve the number of items in a ListBox
// Anzahl Einträge einer ListBox ermitteln
function LB_GetItemCount(hListBox: THandle): Integer;
begin
Result := SendMessage(hListBox, LB_GETCOUNT, 0, 0);
end;
// Delete a string in a ListBox
// Einen String in einer ListBox löschen
procedure LB_DeleteItem(hListBox: THandle; Index: Integer);
begin
SendMessage(hListBox, LB_DELETESTRING, Index, 0);
end;
// Retrieve the selected item from a ListBox
// Gibt den Text des markiertes Items einer ListBox zurück
function LB_GetSelectedItem(hListBox: THandle): string;
var
Index, len: Integer;
s: string;
buffer: PChar;
begin
Index := SendMessage(hListBox, LB_GETCURSEL, 0, 0);
len := SendMessage(hListBox, LB_GETTEXTLEN, wParam(Index), 0);
GetMem(buffer, len + 1);
SendMessage(hListBox, LB_GETTEXT, wParam(Index), lParam(buffer));
SetString(s, buffer, len);
FreeMem(buffer);
Result := IntToStr(Index) + ' : ' + s;
end;
// Example, Beispiel:
procedure TForm1.Button1Click(Sender: TObject);
var
hListBox: THandle;
begin
hListBox := {...}; // listbox handle
ListBox1.Items.Text := LB_GetSelectedItem(hListBox);
end;
// Retrieve a string from a ListBox
// Gibt den Text eines bestimmten Items einer ListBox zurück
function LB_GetListBoxItem(hWnd: Hwnd; LbItem: Integer): string;
var
l: Integer;
buffer: PChar;
begin
l := SendMessage(hWnd, LB_GETTEXTLEN, LbItem, 0);
GetMem(buffer, l + 1);
SendMessage(hWnd, LB_GETTEXT, LbItem, Integer(buffer));
Result := StrPas(buffer);
FreeMem(buffer);
end;
// Example, Beispiel:
procedure TForm1.Button2Click(Sender: TObject);
var
hListBox: THandle;
begin
hListBox := {...}; // listbox handle
ListBox1.Items.Text := LB_GetListBoxItem(hListBox, 2);
end;
// Gibt den gesamten Text einer ListBox zurück
// Retrieve all listbox items
function LB_GetAllItems(hWnd: Hwnd; sl: TStrings): string;
var
RetBuffer: string;
i, x, y: Integer;
begin
x := SendMessage(hWnd, LB_GETCOUNT, 0, 0);
for i := 0 to x - 1 do
begin
y := SendMessage(hWnd, LB_GETTEXTLEN, i, 0);
SetLength(RetBuffer, y);
SendMessage(hWnd, LB_GETTEXT, i, lParam(PChar(RetBuffer)));
sl.Add(RetBuffer);
end;
end;
// Example, Beispiel:
procedure TForm1.Button3Click(Sender: TObject);
var
sl: TStringList;
ListBox_Handle: THandle;
begin
hListBox := {...}; // listbox handle
sl := TStringList.Create;
try
LB_GetAllItems(ListBox_Handle, sl);
finally
ListBox1.Items.Text := sl.Text;
sl.Free;
end;
end;
Delphi - .....................................
neoturk: ...Removing the todays date display from a tdatetimepicker ?...
uses
CommCtrl;
procedure TForm1.DateTimePicker1DropDown(Sender: TObject);
var
wnd: HWND;
Style: Integer;
begin
wnd := DateTime_GetMonthCal(DateTimePicker1.Handle);
if wnd <> 0 then
begin
Style := GetWindowLong(wnd, GWL_STYLE);
SetWindowLong(wnd, GWL_STYLE, Style or MCS_NOTODAY or MCS_NOTODAYCIRCLE);
end;
end;
{
The calendar will still highlite the current day but the circle and the
today display at the bottom are gone.
}
Delphi - .....................................
neoturk: ...Removing the todays date display from a tdatetimepicker ?...
uses
CommCtrl;
procedure TForm1.DateTimePicker1DropDown(Sender: TObject);
var
wnd: HWND;
Style: Integer;
begin
wnd := DateTime_GetMonthCal(DateTimePicker1.Handle);
if wnd <> 0 then
begin
Style := GetWindowLong(wnd, GWL_STYLE);
SetWindowLong(wnd, GWL_STYLE, Style or MCS_NOTODAY or MCS_NOTODAYCIRCLE);
end;
end;
{
The calendar will still highlite the current day but the circle and the
today display at the bottom are gone.
}
Delphi - .....................................
neoturk: ...Check, if a file is on a local drive ?...
function IsOnLocalDrive(aFileName: string): Boolean;
var
aDrive: string;
begin
aDrive := ExtractFileDrive(aFileName);
if (GetDriveType(PChar(aDrive)) = DRIVE_REMOVABLE) or
(GetDriveType(PChar(aDrive)) = DRIVE_FIXED) then
Result := True
else
Result := False;
end;
// Example, Beispiel:
procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenDialog1.Execute then
if IsOnLocalDrive(OpenDialog1.FileName) then
ShowMessage(OpenDialog1.FileName + ' is on a local drive.');
end;
Delphi - .....................................
neoturk: ...Check, if a file is on a local drive ?...
function IsOnLocalDrive(aFileName: string): Boolean;
var
aDrive: string;
begin
aDrive := ExtractFileDrive(aFileName);
if (GetDriveType(PChar(aDrive)) = DRIVE_REMOVABLE) or
(GetDriveType(PChar(aDrive)) = DRIVE_FIXED) then
Result := True
else
Result := False;
end;
// Example, Beispiel:
procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenDialog1.Execute then
if IsOnLocalDrive(OpenDialog1.FileName) then
ShowMessage(OpenDialog1.FileName + ' is on a local drive.');
end;
Delphi - .....................................
neoturk: ...Start a program and wait for its termination ?...
// With CreateProcess:
//*****************************************************
{1}
function WinExecAndWait32(FileName: string; Visibility: Integer): Longword;
var { by Pat Ritchey }
zAppName: array[0..512] of Char;
zCurDir: array[0..255] of Char;
WorkDir: string;
StartupInfo: TStartupInfo;
ProcessInfo: TProcessInformation;
begin
StrPCopy(zAppName, FileName);
GetDir(0, WorkDir);
StrPCopy(zCurDir, WorkDir);
FillChar(StartupInfo, SizeOf(StartupInfo), #0);
StartupInfo.cb := SizeOf(StartupInfo);
StartupInfo.dwFlags := STARTF_USESHOWWINDOW;
StartupInfo.wShowWindow := Visibility;
if not CreateProcess(nil,
zAppName, // pointer to command line string
nil, // pointer to process security attributes
nil, // pointer to thread security attributes
False, // handle inheritance flag
CREATE_NEW_CONSOLE or // creation flags
NORMAL_PRIORITY_CLASS,
nil, //pointer to new environment block
nil, // pointer to current directory name
StartupInfo, // pointer to STARTUPINFO
ProcessInfo) // pointer to PROCESS_INF
then Result := WAIT_FAILED
else
begin
WaitForSingleObject(ProcessInfo.hProcess, INFINITE);
GetExitCodeProcess(ProcessInfo.hProcess, Result);
CloseHandle(ProcessInfo.hProcess);
CloseHandle(ProcessInfo.hThread);
end;
end; { WinExecAndWait32 }
procedure TForm1.Button1Click(Sender: TObject);
begin
WinExecAndWait32('notepad.exe', False, True);
end;
{*******************************}
{2} "Anti-Freezing":
function ExecAndWait(const FileName: string; const CmdShow: Integer): Longword;
var { by Pat Ritchey }
zAppName: array[0..512] of Char;
zCurDir: array[0..255] of Char;
WorkDir: string;
StartupInfo: TStartupInfo;
ProcessInfo: TProcessInformation;
AppIsRunning: DWORD;
begin
StrPCopy(zAppName, FileName);
GetDir(0, WorkDir);
StrPCopy(zCurDir, WorkDir);
FillChar(StartupInfo, SizeOf(StartupInfo), #0);
StartupInfo.cb := SizeOf(StartupInfo);
StartupInfo.dwFlags := STARTF_USESHOWWINDOW;
StartupInfo.wShowWindow := CmdShow;
if not CreateProcess(nil,
zAppName, // pointer to command line string
nil, // pointer to process security attributes
nil, // pointer to thread security attributes
False, // handle inheritance flag
CREATE_NEW_CONSOLE or // creation flags
NORMAL_PRIORITY_CLASS,
nil, //pointer to new environment block
nil, // pointer to current directory name
StartupInfo, // pointer to STARTUPINFO
ProcessInfo) // pointer to PROCESS_INF
then Result := WAIT_FAILED
else
begin
while WaitForSingleObject(ProcessInfo.hProcess, 0) = WAIT_TIMEOUT do
begin
Application.ProcessMessages;
Sleep(50);
end;
{
// or:
repeat
AppIsRunning := WaitForSingleObject(ProcessInfo.hProcess, 100);
Application.ProcessMessages;
Sleep(50);
until (AppIsRunning <> WAIT_TIMEOUT);
}
WaitForSingleObject(ProcessInfo.hProcess, INFINITE);
GetExitCodeProcess(ProcessInfo.hProcess, Result);
CloseHandle(ProcessInfo.hProcess);
CloseHandle(ProcessInfo.hThread);
end;
end; { WinExecAndWait32 }
procedure TForm1.Button1Click(Sender: TObject);
begin
ExecAndWait('C:ProgrammeWinZipWINZIP32.EXE', SW_SHOW);
end;
{3}
{--WinExecAndWait32V2 ------------------------------------------------}
{: Executes a program and waits for it to terminate
@Param FileName contains executable + any parameters
@Param Visibility is one of the ShowWindow options, e.g. SW_SHOWNORMAL
@Returns -1 in case of error, otherwise the programs exit code
@Desc In case of error SysErrorMessage( GetlastError ) will return an
error message. The routine will process paint messages and messages
send from other threads while it waits.
}{ Created 27.10.2000 by P. Below
-----------------------------------------------------------------------}
function WinExecAndWait32V2(FileName: string; Visibility: Integer): DWORD;
procedure WaitFor(processHandle: THandle);
var
Msg: TMsg;
ret: DWORD;
begin
repeat
ret := MsgWaitForMultipleObjects(1, { 1 handle to wait on }
processHandle, { the handle }
False, { wake on any event }
INFINITE, { wait without timeout }
QS_PAINT or { wake on paint messages }
QS_SENDMESSAGE { or messages from other threads }
);
if ret = WAIT_FAILED then Exit; { can do little here }
if ret = (WAIT_OBJECT_0 + 1) then
begin
{ Woke on a message, process paint messages only. Calling
PeekMessage gets messages send from other threads processed. }
while PeekMessage(Msg, 0, WM_PAINT, WM_PAINT, PM_REMOVE) do
DispatchMessage(Msg);
end;
until ret = WAIT_OBJECT_0;
end; { Waitfor }
var { V1 by Pat Ritchey, V2 by P.Below }
zAppName: array[0..512] of char;
StartupInfo: TStartupInfo;
ProcessInfo: TProcessInformation;
begin { WinExecAndWait32V2 }
StrPCopy(zAppName, FileName);
FillChar(StartupInfo, SizeOf(StartupInfo), #0);
StartupInfo.cb := SizeOf(StartupInfo);
StartupInfo.dwFlags := STARTF_USESHOWWINDOW;
StartupInfo.wShowWindow := Visibility;
if not CreateProcess(nil,
zAppName, { pointer to command line string }
nil, { pointer to process security attributes }
nil, { pointer to thread security attributes }
False, { handle inheritance flag }
CREATE_NEW_CONSOLE or { creation flags }
NORMAL_PRIORITY_CLASS,
nil, { pointer to new environment block }
nil, { pointer to current directory name }
StartupInfo, { pointer to STARTUPINFO }
ProcessInfo) { pointer to PROCESS_INF } then
Result := DWORD(-1) { failed, GetLastError has error code }
else
begin
Waitfor(ProcessInfo.hProcess);
GetExitCodeProcess(ProcessInfo.hProcess, Result);
CloseHandle(ProcessInfo.hProcess);
CloseHandle(ProcessInfo.hThread);
end; { Else }
end; { WinExecAndWait32V2 }
procedure TForm1.Button1Click(Sender: TObject);
begin
WinExecAndWait32V2('notepad.exe', SW_SHOWNORMAL);
end;
// With ShellExecuteEx:
//*****************************************************
{1}
uses
ShellApi;
procedure ShellExecute_AndWait(FileName: string; Params: string);
var
exInfo: TShellExecuteInfo;
Ph: DWORD;
begin
FillChar(exInfo, SizeOf(exInfo), 0);
with exInfo do
begin
cbSize := SizeOf(exInfo);
fMask := SEE_MASK_NOCLOSEPROCESS or SEE_MASK_FLAG_DDEWAIT;
Wnd := GetActiveWindow();
ExInfo.lpVerb := 'open';
ExInfo.lpParameters := PChar(Params);
lpFile := PChar(FileName);
nShow := SW_SHOWNORMAL;
end;
if ShellExecuteEx(@exInfo) then
Ph := exInfo.HProcess
else
begin
ShowMessage(SysErrorMessage(GetLastError));
Exit;
end;
while WaitForSingleObject(ExInfo.hProcess, 50) <> WAIT_OBJECT_0 do
Application.ProcessMessages;
CloseHandle(Ph);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ShellExecute_AndWait('FileName', 'Parameter');
end;
{*******************************}
{2}
function ShellExecute_AndWait(Operation, FileName, Parameter, Directory: string;
Show: Word; bWait: Boolean): Longint;
var
bOK: Boolean;
Info: TShellExecuteInfo;
{
****** Parameters ******
Operation:
edit Launches an editor and opens the document for editing.
explore Explores the folder specified by lpFile.
find Initiates a search starting from the specified directory.
open Opens the file, folder specified by the lpFile parameter.
print Prints the document file specified by lpFile.
properties Displays the file or folder's properties.
FileName:
Specifies the name of the file or object on which
ShellExecuteEx will perform the action specified by the lpVerb parameter.
Parameter:
String that contains the application parameters.
The parameters must be separated by spaces.
Directory:
specifies the name of the working directory.
If this member is not specified, the current directory is used as the working directory.
Show:
Flags that specify how an application is to be shown when it is opened.
It can be one of the SW_ values
bWait:
If true, the function waits for the process to terminate
}
begin
FillChar(Info, SizeOf(Info), Chr(0));
Info.cbSize := SizeOf(Info);
Info.fMask := SEE_MASK_NOCLOSEPROCESS;
Info.lpVerb := PChar(Operation);
Info.lpFile := PChar(FileName);
Info.lpParameters := PChar(Parameter);
Info.lpDirectory := PChar(Directory);
Info.nShow := Show;
bOK := Boolean(ShellExecuteEx(@Info));
if bOK then
begin
if bWait then
begin
while
WaitForSingleObject(Info.hProcess, 100) = WAIT_TIMEOUT
do Application.ProcessMessages;
bOK := GetExitCodeProcess(Info.hProcess, DWORD(Result));
end
else
Result := 0;
end;
if not bOK then Result := -1;
end;
