Currently i check if a HWND is a console by EnumWindows and checking the ClassName.
function EnumWindows(AHandle: HWND; AParam: LPARAM): BOOL; stdcall;
var
classname: array[0.. 255] of Char;
begin
GetClassName(AHandle, classname, 255);
if classname = 'ConsoleWindowClass' then
begin
// do something
Result := False;
end
else
Result := True;
end;
I am wondering if there is a better way to accomplish something like this?
Would checking the Style (or/and ExStyle) be "better"?
You can use AttachConsole and FreeConsole do detect if other processes provide a console. One other thing to mind: there are processes with no console windows which allo AttachConsole - here GetConsoleWindow returns 0. There is a very good explanation of this behaviour in this github repository.
Declarations:
function AttachConsole(dwProcessID: Integer): Boolean; stdcall; external 'kernel32.dll';
function FreeConsole(): Boolean; stdcall; external 'kernel32.dll';
function GetConsoleWindow: HWND; stdcall; external kernel32;
Enumerate Processes:
procedure TForm2.FindConsoleWindows(AList: TListBox);
var
LProcHandle: THandle;
LResult, LNext: Boolean;
LProc: TProcessEntry32;
begin
aList.Items.Clear;
LProcHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
LResult := LProcHandle <> INVALID_HANDLE_VALUE;
if LResult then
try
LProc.dwSize := SizeOf(LProc);
LNext := Process32First(LProcHandle, LProc);
while LNext do begin
if AttachConsole(LProc.th32ProcessID) then
try
AList.Items.Add(IntToStr(LProc.th32ProcessID) + ' has a console ' + IntToStr(GetConsoleWindow()))
finally
FreeConsole();
end;
LNext := Process32Next(LProcHandle, LPRoc);
end;
finally
CloseHandle(LProcHandle);
end;
Credits:
JclSysInfo.pas to enumerate the processes
Related
I'm hooking GetWindowThreadProcessId() with sucess using the following code.
Now i want check if dwProcessID parameter corresponds to id of determinated process and in positive case prevent execute original function:
Result := OldGetWindowThreadProcessId(hWnd, dwProcessID);
I tried this, but not worked:
if dwProcessID = 12345 then exit;
Here is my complete code:
library MyLIB;
uses
Windows,
ImageHlp;
{$R *.res}
type
PGetWindowThreadProcessId = function(hWnd: THandle; dwProcessID: DWord)
: DWord; stdcall;
var
OldGetWindowThreadProcessId: PGetWindowThreadProcessId;
function HookGetWindowThreadProcessId(hWnd: THandle; dwProcessID: DWord)
: DWord; stdcall;
begin
try
// Check if is some process
except
MessageBox(0, 'Error', 'HookGetWindowThreadProcessId Error', 0);
end;
Result := OldGetWindowThreadProcessId(hWnd, dwProcessID);
end;
procedure PatchIAT(strMod: PAnsichar; Alt, Neu: Pointer);
var
pImportDir: pImage_Import_Descriptor;
size: CardinaL;
Base: CardinaL;
pThunk: PDWORD;
begin
Base := GetModuleHandle(nil);
pImportDir := ImageDirectoryEntryToData(Pointer(Base), True,
IMAGE_DIRECTORY_ENTRY_IMPORT, size);
while pImportDir^.Name <> 0 Do
begin
If (lstrcmpiA(PAnsichar(pImportDir^.Name + Base), strMod) = 0) then
begin
pThunk := PDWORD(Base + pImportDir^.FirstThunk);
While pThunk^ <> 0 Do
begin
if DWord(Alt) = pThunk^ Then
begin
pThunk^ := CardinaL(Neu);
end;
Inc(pThunk);
end;
end;
Inc(pImportDir);
end;
end;
procedure DllMain(reason: Integer);
begin
case reason of
DLL_PROCESS_ATTACH:
begin
OldGetWindowThreadProcessId := GetProcAddress(GetModuleHandle(user32),
'GetWindowThreadProcessId');
PatchIAT(user32, GetProcAddress(GetModuleHandle(user32),
'GetWindowThreadProcessId'), #HookGetWindowThreadProcessId);
end;
DLL_PROCESS_DETACH:
begin
end;
end;
end;
begin
DllProc := #DllMain;
DllProc(DLL_PROCESS_ATTACH);
end.
Your PGetWindowThreadProcessId type and HookGetWindowThreadProcessId() function are both declaring the dwProcessID parameter incorrectly. It is an output parameter, so it needs to be declared as either var dwProcessID: DWord or as dwProcessID: PDWord.
And then you need to call OldGetWindowThreadProcessId() to retrieve the actual PID before you can then compare it to anything. So your requirement of "in positive case prevent execute original function" is not realistic, because you need to execute the original function in order to determine the dwProcessID value to compare with.
Try this instead:
type
PGetWindowThreadProcessId = function(hWnd: THandle; var dwProcessID: DWord): DWord; stdcall;
...
function HookGetWindowThreadProcessId(hWnd: THandle; var dwProcessID: DWord): DWord; stdcall;
begin
Result := OldGetWindowThreadProcessId(hWnd, dwProcessID);
try
if dwProcessID = ... then
...
except
MessageBox(0, 'Error', 'HookGetWindowThreadProcessId Error', 0);
end;
end;
After a while crashes and I have to start the hook again
Function of KeyboardHook
function KeyboardHook(Code: Integer; wParam : WPARAM; lParam : LPARAM): LongInt;
var
Buffer: TEventMsg;
Key: Cardinal;
begin
if (wParam = $0101) and
(App.Inside) then
begin
Buffer := PEventMsg(lParam)^;
Key := Buffer.message;
if App.Inside then
begin
case Key of
VK_NEXT: App.Next;
VK_CAPITAL: App.Show;
end;
end;
end;
CallNextHookEx(Hook_ID_Keyboard, Code, wParam, lParam);
Result := 0;
end;
Function to start the Hook
function StartHookKeyboard: Boolean; stdcall;
begin
Hook_ID_Keyboard := SetWindowsHookEx(13, #KeyboardHook, HInstance, 0);
If Hook_ID_Keyboard = 0 then
Result := False else
Result := True;
end;
Is there any error in my code?
Don't use hard-coded magic numbers. In this context, 13 is WH_KEYBOARD_LL, $0101 is WM_KEYUP, etc. Use the actual names in your code. They are declared in the Windows and Messages units.
Did you declare KeyboardHook() to use the stdcall calling convention? The code you have shown is not doing so. This is very important so the parameter values are passed correctly on the call stack.
The lParam value of a WH_KEYBOARD_LL hook is NOT a PEventMsg (pointer to an EVENTMSG structure). That structure is used for WH_JOURNALPLAYBACK hooks. WH_KEYBOARD_LL uses the KBDLLHOOKSTRUCT structure instead. Delphi does not declare that particular structure, so you will have to declare it yourself in your code.
And don't ignore the callback's Code parameter, or the return value of CallNextHookEx(). They are important. The wParam and lParam values are only valid when the Code parameter is HC_ACTION (0). And the return value of CallNextHookEx() needs to be passed up the hook chain.
Try this instead:
type
PKBDLLHOOKSTRUCT = ^KBDLLHOOKSTRUCT;
KBDLLHOOKSTRUCT = record
vkCode: DWORD;
scanCode: DWORD;
flags: DWORD;
time: DWORD;
dwExtraInfo: ULONG_PTR;
end;
function KeyboardHook(Code: Integer; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
begin
if Code = HC_ACTION then
begin
if (wParam = WM_KEYUP) and (App.Inside) then
begin
case PKBDLLHOOKSTRUCT(lParam)^.vkCode of
VK_NEXT: App.Next;
VK_CAPITAL: App.Show;
end;
end;
end;
// note that CallNextHookEx() ignores the first parameter,
// so you could pass 0 instead of ID_Keyboard...
Result := CallNextHookEx(Hook_ID_Keyboard, Code, wParam, lParam);
end;
function StartHookKeyboard: Boolean; stdcall;
begin
if Hook_ID_Keyboard = 0 then
Hook_ID_Keyboard := SetWindowsHookEx(WH_KEYBOARD_LL, #KeyboardHook, HInstance, 0);
Result := Hook_ID_Keyboard <> 0;
end;
function StopHookKeyboard: Boolean; stdcall;
begin
if Hook_ID_Keyboard <> 0 then
begin
if UnhookWindowsHookEx(Hook_ID_Keyboard) then
Hook_ID_Keyboard := 0;
end;
Result := Hook_ID_Keyboard = 0;
end;
If the code is still crashing, it is likely related to App. What is App? Where and how is it declared? How is it initialized? What do Next() and Show() actually do? You are installing the hook globally to hook all running processes, so is App being used in a cross-process-safe manner?
I have an application that uses TEmbeddedWb to automate data scrapping tasks.
Some web-sites show messages / popup boxes when my app navigates to it, and these makes the process slower.
I want to block any messagebox that TWebbrowser could show.
I'm already setting the 'silent' property to true, and also setting the onshowmessage method as follow, but still the messageboxes are show. Any hints ?
function TForm1.webShowMessage(Sender: TObject; HWND: Cardinal; lpstrText,
lpstrCaption: PWideChar; dwType: Integer; lpstrHelpFile: PWideChar; dwHelpContext: Integer;
var plResult: Integer): HRESULT;
begin
plresult := S_OK;
end;
I could achieve these task by making some changes on TEmbeddedWb source, specifically on the functionbelow :
procedure TEmbeddedWB.HandleDialogBoxes(var AMsg: Messages.TMessage);
Here is the change :
DlgClss := GetWinClass(PopHandle);
WinClss := GetWinClass(Windows.GetParent(PopHandle));
DlgCaption := GetWinText(PopHandle);
if (DlgClss = 'Internet Explorer_TridentDlgFrame') or ((DlgClss = '#32770'))
// comment here to make all windows be evaluated
{and (WinClss <> 'TApplication') and
(FindControl(Windows.GetParent(PopHandle)) = nil))}
then
begin
if (WinClss = 'TApplication') or (FindControl(Windows.GetParent(PopHandle)) <> nil) then
begin
if pos('web browser',lowercase(DlgCaption)) = 0 then
exit;
end;
I just add this code Result := S_OK; on ShowMessage Event and no more popup message:
function TForm1.webShowMessage(Sender: TObject; HWND: Cardinal; lpstrText,
lpstrCaption: PWideChar; dwType: Integer; lpstrHelpFile: PWideChar; dwHelpContext: Integer;
var plResult: Integer): HRESULT;
begin
Result := S_OK;
end;
I am using Delphi 2007. I can successfully Post data to a web site using WebBrowser.Navigate, but afterwards, when that site returns a PDF, while it appears on the screen of the Browser, I cannot figure out how to acquire the PDF programmatically. I can see some text and HTML using Document.Body.InnerHTML, but not the PDF. Can someone demonstrate how to acquire the PDF which appears after the POST?
Thank yoU!
To get the text out of a PDF in the web browser, I found a solution using an open source unit called PushKeys to send keys to the web browser to select all the text (Control+A), copy it to the clipboard (Control+C) and then paste it to a TMemo or other control using PasteFromClipBoard. Tested in D2007.
WebBrowser.SetFocus; // set the focus to the TWebBrowser control
Sleep(1000); // 1 second delay to be sure webbrowser actually has focus
Application.ProcessMessages;
PushKeys('^a'); //send ctrl-a to select all text
Application.ProcessMessages;
WebBrowser.SetFocus;
PushKeys('^c'); //send ctrl-c to copy the text to clipboard
Sleep(1000); // 1 second delay to make sure clipboard finishes processing
Application.ProcessMessages;
Memo1.PasteFromClipBoard; // Paste the clipboard to a memo field.
// You could also use the clipbrd unit to handle the data.
//for Multi-page PDF's, you can send a PageDn key to get to the next page:
PushFnKey('PAGEDOWN');
You could use an IE4+ option for capturing all internet traffic using your own protocol. You can even hook the protocol http (IIRC) and when you need to load the data use the WIndows functions and/or Indy components.
This is a unit to do so:
{
This component allows you to dynamically create your own internet protocols for
Microsoft Internet Explorer 4+. Simply place the component on your form, set the protocol
property to something useful and set the Active property.
For example, when the Protocol is set to 'private', you can trap requests to
'private:anythingyoulike'.
}
unit UnitInternetProtocol;
// Developed by: R.A. Hornstra
// (C) 2001 ContinuIT BV
interface
uses
SysUtils, Windows, Classes, Messages;
type
TInternetProtocol = class;
{
When a request is made, the data must be returned in a TStream descendant.
The request is present in Request. The result should be saved in Stream.
When no data can be linked to the request, leave Stream equal to nil.
See #link(TInternetProtocol.OnRequestStream) and #link(TInternetProtocol.OnReleaseStream).
}
TProtocolRequest = procedure(Sender: TInternetProtocol; const Request: string;
var Stream: TStream) of object;
{
When a request is done by the Microsoft Internet Explorer it is done via an URL.
This URL starts with a protocol, than a colon and than a protocol specific resource identifier.
New protocols can be added dynamically and privately for each session.
This component will register / deregister new protocols to the Microsoft Internet Explorer.
You should set the name of the protocol with #link(Protocol), activate / deactivate the
protocol with #link(Active). The implementation of the protocol can be done with the
events #link(OnRequestStream) and #link(OnReleaseStream).
}
TInternetProtocol = class(TComponent)
private
FHandle: HWnd;
FActive: Boolean;
FProtocol: string;
FRequest: TProtocolRequest;
FRelease: TProtocolRequest;
procedure SetActive(const Value: Boolean);
procedure SetProtocol(const Value: string);
protected
procedure Loaded; override;
procedure Activate;
procedure Deactivate;
procedure WndProc(var Message: TMessage);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
{
Setting this property will activate or deactivate the internet
}
property Active: Boolean read FActive write SetActive;
{
The protocol name must be specified. default, this is 'private'.
You should fill it here without the trailing colon (that's part of the URL notation).
Protocol names should be valid identifiers.
}
property Protocol: string read FProtocol write SetProtocol;
{
When a request is made on the selected protocol, this event is fired.
It should return a TStream, based upon the given Request.
The default behaviour of TInternetProtocol is freeing the stream.
To override or monitor this behaviour, use #link(OnRequestStream).
}
property OnRequestStream: TProtocolRequest read FRequest write FRequest;
{
When a stream is about to be released by TInternetProtocol, you can override the
default behaviour. By Setting the Stream variable to nil in the OnReleaseStream handler,
the stream will not be released by TInternetProtocol.
This is handy when you're implementing a caching system, or for some reason need control on
the creation and deletion to the streams.
The default behaviour of TInternetProtocol is freeing the stream.
}
property OnReleaseStream: TProtocolRequest read FRelease write FRelease;
end;
{
All exceptions raised by #link(TInternetProtocol) are of type EInternetException.
}
EInternetException = class(Exception);
procedure Register;
implementation
uses
ComObj, ActiveX, UrlMon, Forms;
resourcestring
strNotAValidProtocol = 'The Internet Protocol selected is not a valid protocol identifier';
// todo: move registration to separate file
procedure Register;
begin
Classes.RegisterComponents('Internet',[TInternetProtocol]);
end;
// forward declarations
procedure RegisterProtocol(Protocol: string; Handler: TInternetProtocol); forward;
procedure UnregisterProtocol(Protocol: string); forward;
const
IID_TInternetProtocolHandler: TGUID = '{B74826E0-1107-11D5-B166-0010D7090486}';
WM_STREAMNEEDED = WM_USER;
{ TInternetProtocol }
constructor TInternetProtocol.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FActive := False;
FProtocol := 'private';
FRequest := nil;
FRelease := nil;
FHandle := Forms.AllocateHWnd(WndProc);
end;
destructor TInternetProtocol.Destroy;
begin
Active := False;
Forms.DeallocateHWnd(FHandle);
inherited Destroy;
end;
procedure TInternetProtocol.Loaded;
begin
inherited Loaded;
if FActive then Activate;
end;
procedure TInternetProtocol.SetActive(const Value: Boolean);
begin
if Value = FActive then Exit;
if Value then begin
if not (csLoading in ComponentState) then Activate;
end else begin
Deactivate;
end;
FActive := Value;
end;
procedure TInternetProtocol.Activate;
begin
if csDesigning in ComponentState then Exit;
RegisterProtocol(FProtocol,Self);
end;
procedure TInternetProtocol.Deactivate;
begin
if csDesigning in ComponentState then Exit;
UnregisterProtocol(FProtocol);
end;
procedure TInternetProtocol.SetProtocol(const Value: string);
var AActive: Boolean;
begin
if not SysUtils.IsValidIdent(Value) then raise EInternetException.Create(strNotAValidProtocol);
AActive := FActive;
try
Active := False;
FProtocol := Value;
finally
Active := AActive;
end;
end;
procedure TInternetProtocol.WndProc(var Message: TMessage);
var
Msg: packed record
Msg: Longword;
Request: PChar;
Stream: ^TStream;
end;
begin
if Message.Msg = WM_STREAMNEEDED then begin
System.Move(Message,Msg,SizeOf(Msg));
if Assigned(FRequest) then FRequest(Self,string(Msg.Request),Msg.Stream^);
end else Message.Result := Windows.DefWindowProc(FHandle,Message.Msg,Message.WParam,Message.LParam);
end;
var
Session: IInternetSession; // The current Internet Session
Factory: IClassFactory; // Factory of our IInternetProtocol implementation
Lock: TRTLCriticalSection; // The lock for thread safety
List: TStrings; // The list of active protocol handlers
type
TInternetProtocolHandler = class(TInterfacedObject, IInternetProtocol)
private
ProtSink: IInternetProtocolSink; // Protocol Sink that needs the data
Stream: TStream; // Stream containing the data
StreamPosition: Integer; // Current Position in the stream
StreamSize: Integer; // Current size of the stream
LockCount: Integer; // Lock count for releasing data
procedure ReleaseStream;
public
{ IInternetProtocol }
function Start(szUrl: PWideChar; OIProtSink: IInternetProtocolSink;
OIBindInfo: IInternetBindInfo; grfPI, dwReserved: DWORD): HResult; stdcall;
function Continue(const ProtocolData: TProtocolData): HResult; stdcall;
function Abort(hrReason: HResult; dwOptions: DWORD): HResult; stdcall;
function Terminate(dwOptions: DWORD): HResult; stdcall;
function Suspend: HResult; stdcall;
function Resume: HResult; stdcall;
function Read(pv: Pointer; cb: ULONG; out cbRead: ULONG): HResult; stdcall;
function Seek(dlibMove: LARGE_INTEGER; dwOrigin: DWORD;
out libNewPosition: ULARGE_INTEGER): HResult; stdcall;
function LockRequest(dwOptions: DWORD): HResult; stdcall;
function UnlockRequest: HResult; stdcall;
end;
TInternetProtocolHandlerFactory = class(TInterfacedObject, IClassFactory)
public
{ IClassFactory }
function CreateInstance(const unkOuter: IUnknown; const iid: TIID; out obj): HResult; stdcall;
function LockServer(fLock: BOOL): HResult; stdcall;
end;
procedure RegisterProtocol(Protocol: string; Handler: TInternetProtocol);
var
i: Integer;
Proto: WideString;
begin
Windows.EnterCriticalSection(Lock);
try
// if we have a previous handler, delete that from the list.
i := List.IndexOf(Protocol);
if i >=0 then TInternetProtocol(List.Objects[i]).Active := False;
// If this is the first time, create the Factory and get the Internet Session object
if List.Count = 0 then begin
Factory := TInternetProtocolHandlerFactory.Create;
CoInternetGetSession(0, Session, 0);
end;
// Append ourselves to the list
List.AddObject(Protocol,Handler);
// Register the protocol with the Internet session
Proto := Protocol;
Session.RegisterNameSpace(Factory, IInternetProtocol{ IID_TInternetProtocolHandler}, PWideChar(Proto), 0, nil, 0);
finally
Windows.LeaveCriticalSection(Lock);
end;
end;
procedure UnregisterProtocol(Protocol: string);
var i: Integer;
Proto: WideString;
begin
Windows.EnterCriticalSection(Lock);
try
i := List.IndexOf(Protocol);
if i < 0 then Exit; // oops, protocol was somehow already freed... this should not happen
// unregister our namespace handler
Proto := Protocol; // to widestring
Session.UnregisterNameSpace(Factory, PWideChar(Proto));
// and free from list
List.Delete(i);
// see if we need to cleanup?
if List.Count = 0 then begin
// release the COM server
Session := nil;
Factory := nil;
end;
finally
Windows.LeaveCriticalSection(Lock);
end;
end;
{ TInternetProtocolHandler }
function TInternetProtocolHandler.Abort(hrReason: HResult; dwOptions: DWORD): HResult;
begin
Result := E_NOTIMPL;
end;
function TInternetProtocolHandler.Continue(const ProtocolData: TProtocolData): HResult;
begin
Result := S_OK;
end;
function TInternetProtocolHandler.LockRequest(dwOptions: DWORD): HResult;
begin
Inc(LockCount);
Result := S_OK;
end;
function TInternetProtocolHandler.Read(pv: Pointer; cb: ULONG; out cbRead: ULONG): HResult;
const Results: array [Boolean] of Longword = ( E_PENDING, S_FALSE );
begin
if Assigned(Stream) then cbRead := Stream.Read(pv^,cb) else cbRead := 0;
Inc(StreamPosition, cbread);
Result := Results[StreamPosition = StreamSize];
end;
procedure TInternetProtocolHandler.ReleaseStream;
begin
// see if we can release the Stream...
if Assigned(Stream) then FreeAndNil(Stream);
Protsink := nil;
end;
function TInternetProtocolHandler.Resume: HResult;
begin
Result := E_NOTIMPL;
end;
function TInternetProtocolHandler.Seek(dlibMove: LARGE_INTEGER;
dwOrigin: DWORD; out libNewPosition: ULARGE_INTEGER): HResult;
begin
Result := E_NOTIMPL;
end;
function TInternetProtocolHandler.Start(szUrl: PWideChar; OIProtSink: IInternetProtocolSink;
OIBindInfo: IInternetBindInfo; grfPI,dwReserved: DWORD): HResult;
var URL, Proto: string;
i: Integer;
Handler: TInternetProtocol;
begin
// Sanity check.
Assert(Assigned(OIProtSink));
Assert(Assigned(szUrl));
Assert(Assigned(OIBindInfo));
URL := szUrl;
Stream := nil; // just to make sure...
// Clip the protocol name from the URL & change the URL to the proto specific part
i := Pos(':',URL);
if i > 0 then begin
Proto := Copy(URL,1,i-1);
URL := Copy(URL,i+1,MaxInt);
end;
Windows.EnterCriticalSection(Lock);
try
i := List.IndexOf(Proto);
if i >= 0 then begin
// we've found our protocol
Handler := TInternetProtocol(List.Objects[i]);
// And query. Use a Windows message for thread synchronization
Windows.SendMessage(Handler.FHandle,WM_STREAMNEEDED,WParam(PChar(URL)),LParam(#Stream));
end;
finally
Windows.LeaveCriticalSection(Lock);
end;
if not Assigned(Stream) then begin
Result := INET_E_USE_DEFAULT_PROTOCOLHANDLER;
Exit;
end;
// Setup all data
StreamSize := Stream.Size;
Stream.Position := 0;
StreamPosition := 0;
LockCount := 1;
// Get the protocol sink & start the 'downloading' process
ProtSink := OIProtSink;
ProtSink.ReportData(BSCF_FIRSTDATANOTIFICATION or BSCF_LASTDATANOTIFICATION or
BSCF_DATAFULLYAVAILABLE, StreamSize, StreamSize);
ProtSink.ReportResult(S_OK, S_OK, nil);
Result := S_OK;
end;
function TInternetProtocolHandler.Suspend: HResult;
begin
Result := E_NOTIMPL;
end;
function TInternetProtocolHandler.Terminate(dwOptions: DWORD): HResult;
begin
Dec(LockCount);
if LockCount = 0 then ReleaseStream;
Result := S_OK;
end;
function TInternetProtocolHandler.UnlockRequest: HResult;
begin
Dec(LockCount);
if LockCount = 0 then ReleaseStream;
Result := S_OK;
end;
{ TInternetProtocolHandlerFactory }
function TInternetProtocolHandlerFactory.CreateInstance(const unkOuter: IInterface;
const iid: TIID; out obj): HResult;
begin
if IsEqualGUID(iid, IInternetProtocol) then begin
IInternetProtocol(obj) := TInternetProtocolHandler.Create as IInternetProtocol;
Result := S_OK;
end else if IsEqualGUID(iid, IInterface) then begin
IInterface(obj) := TInternetProtocolHandler.Create as IInterface;
Result := S_OK;
end else begin
Result := E_NOINTERFACE;
end;
end;
function TInternetProtocolHandlerFactory.LockServer(fLock: BOOL): HResult;
begin
if fLock then _AddRef else _Release;
Result := S_OK;
end;
initialization
begin
// Get a critical section for thread synchro
Windows.InitializeCriticalSection(Lock);
// The list of protocol handlers
List := TStringList.Create;
end;
finalization
begin
// deactivate all handlers (should only happen when memory leaks are present...)
while List.Count > 0 do TInternetProtocol(List.Objects[0]).Active := False;
List.Free;
// and delete the critical section
Windows.DeleteCriticalSection(Lock);
end;
end.
How may I test in coding if my .exe Delphi application is built with runtime package or is single .exe?
Another possibility:
function UsesRuntimePackages: Boolean;
begin
Result := FindClassHInstance(TObject) <> HInstance;
end;
Another possibility, in case you need this for an external executable (without running it):
procedure InfoProc(const Name: string; NameType: TNameType; Flags: Byte; Param: Pointer);
begin
case NameType of
ntContainsUnit:
if Name = 'System' then
PBoolean(Param)^ := False;
end;
end;
function UsesRuntimePackages(const ExeName: TFileName): Boolean;
var
Module: HMODULE;
Flags: Integer;
begin
Result := True;
Module := LoadLibraryEx(PChar(ExeName), 0, LOAD_LIBRARY_AS_DATAFILE);
try
Flags := 0;
GetPackageInfo(Module, #Result, Flags, InfoProc);
finally
FreeLibrary(Module);
end;
end;
Use could use the EnumModules() procedure, like so:
function EnumModuleProc(HInstance: Integer; Data: Pointer): Boolean;
begin
Result := True;
if HInstance <> MainInstance then begin
Inc(PInteger(Data)^);
Result := False;
end;
end;
function UsesRuntimePackages: boolean;
var
PckgCount: integer;
begin
PckgCount := 0;
EnumModules(EnumModuleProc, #PckgCount);
Result := PckgCount > 0;
end;
Did you try "Islibrary" ?