(First, I am not sure whether this question is placed in the correct section of Stack Exchange. If not so, please give me a notice and delete the question.)
I have 8 Arduino's (Ards). Some Uno's and some 2650 Mega's. In an attempt to automatize the connection process (I use Delphi D-7 SE as I/O), I want to differentate between the UNO and the 2650 (mostly because the hardware differences in the appropriate chip). The way to do this (I think), is to get the PID and VID from the board. But I don't know how to do this. The code below gives me the correct driver, but not PID/VID . Is it possible to get PID/VID for this code-snippet ?? IF so, HOW ?
Thanks a lot.
Code here:
unit ArduinoTestU;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics,
Controls, Forms, Dialogs, JVsetupAPI, Registry, StdCtrls,
CPortCtl, CPort, Menus, XPMan;
type
TMainForm = class(TForm)
ListBox1: TListBox;
Label1: TLabel;
Button1: TButton;
procedure FormCreate(Sender: TObject);
function SetupEnumAvailableComPorts : TstringList;
procedure ListBox1Click(Sender: TObject);
procedure FormActivate(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
ArdType : Integer;
end;
var
MainForm : TMainForm;
ComPortStringList : TStringList;
MyComPort : String;
CurDir : String;
implementation
uses Form1Unit, ArdFormU; (* , ArdFormU; *)
{$R *.dfm}
procedure TMainForm.Button1Click(Sender: TObject);
begin
MainForm.FormActivate(NIL);
end;
procedure TMainForm.FormActivate(Sender: TObject);
var
index : integer;
begin
ComPortStringList := SetupEnumAvailableComPorts;
if (ComPortStringList <> nil) and (ComPortStringList.Count > 0) then
for Index := 0 to ComPortStringList.Count - 1 do
Listbox1.Items.Add(ComPortStringList[Index]);
if Listbox1.Items.Count <> 0 then
BEGIN
Listbox1.Enabled := True;
Button1.Enabled := False;
END;
end;
procedure TMainForm.FormCreate(Sender: TObject);
BEGIN
Curdir := ExtractFileDir(Application.Exename);
end;
(*
The function below returns a list of available COM-ports
(not open by this or an other process), with friendly names. The list is formatted as follows:
COM1: = Communications Port (COM1)
COM5: = NI Serial Port (Com5)
COM6: = NI Serial Port (Com6)
COM7: = USB Serial Port (COM7)
COM8: = Bluetooth Communications Port (COM8)
COM9: = Bluetooth Communications Port (COM9)
This code originally posted at http://www.delphi3000.com/articles/article_4001.asp?SK=
errors have been fixed so it will work with Delphi 7 and SetupAPI from JVCL
*)
function TMainForm.SetupEnumAvailableComPorts : TstringList;
//
// Enumerates all serial communications ports that are available and ready to
// be used.
//
var
RequiredSize: Cardinal;
GUIDSize: DWORD;
Guid: TGUID;
DevInfoHandle: HDEVINFO;
DeviceInfoData: TSPDevInfoData;
MemberIndex: Cardinal;
PropertyRegDataType: DWord;
RegProperty: Cardinal;
RegTyp: Cardinal;
Key: Hkey;
Info: TRegKeyInfo;
S1,S2: string;
hc: THandle;
begin
Result := Nil;
//
//If we cannot access the setupapi.dll then we return a nil pointer.
//
if not LoadsetupAPI then
exit;
try
//
// get 'Ports' class guid from name
//
GUIDSize := 1; // missing from original code - need to tell function that the Guid structure contains a single GUID
if SetupDiClassGuidsFromName('Ports',#Guid,GUIDSize,RequiredSize) then
begin
//
//get object handle of 'Ports' class to interate all devices
//
DevInfoHandle := SetupDiGetClassDevs(#Guid,Nil,0,DIGCF_PRESENT);
if Cardinal(DevInfoHandle) <> Invalid_Handle_Value then
begin
try
MemberIndex := 0;
result := TStringList.Create;
//iterate device list
repeat
FillChar(DeviceInfoData,SizeOf(DeviceInfoData),0);
DeviceInfoData.cbSize := SizeOf(DeviceInfoData);
//get device info that corresponds to the next memberindex
if Not SetupDiEnumDeviceInfo(DevInfoHandle,MemberIndex,DeviceInfoData) then
break;
//query friendly device name LIKE 'BlueTooth Communication Port (COM8)' etc
RegProperty := SPDRP_FriendlyName; {SPDRP_Driver, SPDRP_SERVICE, SPDRP_ENUMERATOR_NAME,SPDRP_PHYSICAL_DEVICE_OBJECT_NAME,SPDRP_FRIENDLYNAME,}
SetupDiGetDeviceRegistryProperty(DevInfoHandle, DeviceInfoData,RegProperty, PropertyRegDataType,NIL,0,RequiredSize);
SetLength(S1,RequiredSize);
// ShowMessage('TEST: ' + S1);
if SetupDiGetDeviceRegistryProperty(DevInfoHandle,DeviceInfoData,RegProperty,PropertyRegDataType,#S1[1],RequiredSize,RequiredSize) then
begin
KEY := SetupDiOpenDevRegKey(DevInfoHandle,DeviceInfoData,DICS_FLAG_GLOBAL,0,DIREG_DEV,KEY_READ);
if key <> INValid_Handle_Value then
begin
FillChar(Info, SizeOf(Info), 0);
//query the real port name from the registry value 'PortName'
if RegQueryInfoKey(Key, nil, nil, nil, #Info.NumSubKeys,#Info.MaxSubKeyLen, nil, #Info.NumValues, #Info.MaxValueLen,
#Info.MaxDataLen, nil, #Info.FileTime) = ERROR_SUCCESS then
begin
RequiredSize := Info.MaxValueLen + 1;
SetLength(S2,RequiredSize);
if RegQueryValueEx(KEY,'PortName',Nil,#Regtyp,#s2[1],#RequiredSize) = Error_Success then
begin
If (Pos('COM',S2) = 1) then
begin
//Test if the device can be used
hc := CreateFile(pchar('\\.\' + S2 + #0), GENERIC_READ or GENERIC_WRITE,
0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
if hc <> INVALID_HANDLE_VALUE then
begin
Result.Add(Strpas(PChar(S2)) + ' := ' + StrPas(PChar(S1)));
CloseHandle(hc);
end;
end;
end;
end;
RegCloseKey(key);
end;
end;
Inc(MemberIndex);
until False;
//If we did not found any free com. port we return a NIL pointer.
if Result.Count = 0 then
begin
Result.Free;
Result := NIL;
end
finally
SetupDiDestroyDeviceInfoList(DevInfoHandle);
end;
end;
end;
finally
UnloadSetupApi;
end;
end;
procedure TMainForm.ListBox1Click(Sender: TObject);
begin
Ardtype := Listbox1.ItemIndex;
MainForm.Hide;
ArdForm.ShowModal;
if Ardform.ModalResult <> mrOK then
ShowMessage('Der opstod en fejl ')
ELSE
BEGIN
MainForm.Show;
END;
end;
end.
Kris aka snestrup2016
Related
I am looking for sample code on how to call a WMI function. Does anyone has a working example in FreePascal, ideally including code on how to pass parameters to the function? Unfortunately, the "Delphi WMI code Creator" does not help me as the FreePascal code for creating a function does not work.
Just to be clear: This is not about querying WMI properties, but calling a function like Win32_Printer.AddPrinterConnection (just to name an example).
I found a piece of Delphi code that set up many of the standard objects in the same way as Drake Wu's C++ example did.
I was interested in that example because I'm interested in edids, so I fully translated said C++ article's solution to Delphi/FPC. It seems to work.
program wmiedidint2;
// based on https://theroadtodelphi.com/2011/04/21/accesing-the-wmi-from-delphi-and-fpc-via-com-without-late-binding-or-wbemscripting_tlb/
// modified to function as https://learn.microsoft.com/en-us/answers/questions/95631/wmi-c-application-problem-wmimonitordescriptormeth.html?childToView=96407#answer-96407
{$IFDEF FPC}
{$MODE DELPHI} {$H+}
{$ENDIF}
{$APPTYPE CONSOLE}
uses
Windows,
Variants,
SysUtils,
ActiveX,
JwaWbemCli;
const
RPC_C_AUTHN_LEVEL_DEFAULT = 0;
RPC_C_IMP_LEVEL_IMPERSONATE = 3;
RPC_C_AUTHN_WINNT = 10;
RPC_C_AUTHZ_NONE = 0;
RPC_C_AUTHN_LEVEL_CALL = 3;
EOAC_NONE = 0;
function GetBytesFromVariant(const V: Variant): TBytes;
// this function is a mess and only works for bytes. From SO
var
Len: Integer;
SafeArray: PVarArray;
begin
Len := 1+VarArrayHighBound(v, 1)-VarArrayLowBound(v, 1);
SetLength(Result, Len);
SafeArray := VarArrayAsPSafeArray(V);
Move(SafeArray.Data^, Pointer(Result)^, Length(result)*SizeOf(result[0]));
end;
procedure Test_IWbemServices_ExecQuery;
const
strLocale = '';
strUser = '';
strPassword = '';
strNetworkResource = 'root\WMI';
strAuthority = '';
WQL = 'SELECT * FROM WmiMonitorDescriptorMethods';
EDIDMethodname = 'WmiGetMonitorRawEEdidV1Block';
EDIDClassName = 'WmiMonitorDescriptorMethods';
var
FWbemLocator : IWbemLocator;
FWbemServices : IWbemServices;
FUnsecuredApartment : IUnsecuredApartment;
ppEnum : IEnumWbemClassObject;
apObjects : IWbemClassObject;
puReturned : ULONG;
pVal : OleVariant;
pType : Integer;
plFlavor : Integer;
Succeed : HRESULT;
varreturnvalue : olevariant;
varotherval : longint;
varcmd2 : tagVariant;
varcommand : olevariant; // tagVARIANT;
pOutParamsDefinition,
pInParamsDefinition,
pClass,
pClassInstance : IWbemClassObject;
callres : IWbemCallResult;
err : IErrorInfo;
aname,w2 : Widestring;
bytes : TBytes;
i : integer;
procedure teststatus(const msg:string);
begin
if Succeeded(succeed) then
writeln('Successs:',msg)
else
writeln('Fail:',msg)
end;
begin
// Set general COM security levels --------------------------
// Note: If you are using Windows 2000, you need to specify -
// the default authentication credentials for a user by using
// a SOLE_AUTHENTICATION_LIST structure in the pAuthList ----
// parameter of CoInitializeSecurity ------------------------
if Failed(CoInitializeSecurity(nil, -1, nil, nil, RPC_C_AUTHN_LEVEL_DEFAULT, RPC_C_IMP_LEVEL_IMPERSONATE, nil, EOAC_NONE, nil)) then Exit;
// Obtain the initial locator to WMI -------------------------
if Succeeded(CoCreateInstance(CLSID_WbemLocator, nil, CLSCTX_INPROC_SERVER, IID_IWbemLocator, FWbemLocator)) then
try
// Connect to WMI through the IWbemLocator::ConnectServer method
if Succeeded(FWbemLocator.ConnectServer(strNetworkResource, strUser, strPassword, strLocale, WBEM_FLAG_CONNECT_USE_MAX_WAIT, strAuthority, nil, FWbemServices)) then
try
// Set security levels on the proxy -------------------------
if Failed(CoSetProxyBlanket(FWbemServices, RPC_C_AUTHN_WINNT, RPC_C_AUTHZ_NONE, nil, RPC_C_AUTHN_LEVEL_CALL, RPC_C_IMP_LEVEL_IMPERSONATE, nil, EOAC_NONE)) then Exit;
if Succeeded(CoCreateInstance(CLSID_UnsecuredApartment, nil, CLSCTX_LOCAL_SERVER, IID_IUnsecuredApartment, FUnsecuredApartment)) then
try
// Use the IWbemServices pointer to make requests of WMI
//Succeed := FWbemServices.ExecQuery('WQL', WQL, WBEM_FLAG_FORWARD_ONLY OR WBEM_FLAG_RETURN_IMMEDIATELY, nil, ppEnum);
Succeed := FWbemServices.ExecQuery('WQL', WQL, WBEM_FLAG_FORWARD_ONLY, nil, ppEnum);
if Succeeded(Succeed) then
begin
Writeln('Running Wmi Query..Press Enter to exit');
// Get the data from the query
while (ppEnum.Next(WBEM_INFINITE, 1, apObjects, puReturned)=0) do
begin
succeed:= apObjects.Get('__PATH', 0, pVal, pType, plFlavor);
teststatus('get __PATH');
aname:=pval;
writeln('__PATH: ',aname);
succeed:=fwbemservices.GetObject(edidclassname,0,nil,pClass,callres);
teststatus('getobject');
succeed:=pClass.GetMethod(EDIDMethodname,0,pInParamsDefinition,pOutParamsDefinition);
teststatus('getmethod');
succeed:=pInParamsDefinition.SpawnInstance(0, pClassInstance);
teststatus('Spawn');
fillchar(varcmd2,sizeof(varcommand),#0);
varcmd2.vt:=VT_UI1;
varcmd2.bval:=0;
move(varcmd2,varcommand,sizeof(varcmd2));
succeed:= pClassInstance.Put('BlockId',0,#VarCommand,0);
teststatus('put blockid');
writeln('The BlockId is: ,',varCommand);
pOutParamsDefinition:=Nil;
callres:=nil;
w2:=EDIDMethodname;
succeed:= fwbemservices.ExecMethod(aname,w2,0,nil,pClassInstance,pOutParamsDefinition,callres);
if succeeded(succeed) then
begin
writeln('execute success!');
end;
succeed:= pOutParamsDefinition.Get('BlockType', 0, varreturnvalue,ptype,plFlavor);
if succeeded(succeed) then
begin
writeln('blocktype:',varreturnvalue);
varotherval:=varreturnvalue;
if varotherval=1 then
begin
succeed:= pOutParamsDefinition.Get('BlockContent', 0, varreturnvalue,ptype,plFlavor);
if succeeded(succeed) then
begin
bytes:=GetBytesFromVariant(varreturnvalue);
write('bytes:');
for i:=0 to length(bytes)-1 do
begin
write('$',inttohex(bytes[i],2),' ');
end;
writeln;
end;
end;
end;
end;
end
else
Writeln(Format('Error executing WQL sentence %x',[Succeed]));
finally
FUnsecuredApartment := nil;
end;
finally
FWbemServices := nil;
end;
finally
FWbemLocator := nil;
end;
end;
begin
// Initialize COM. ------------------------------------------
if Succeeded(CoInitializeEx(nil, COINIT_MULTITHREADED)) then
try
Test_IWbemServices_ExecQuery;
finally
CoUninitialize();
end;
Readln;
end.
Note that the original (roadtodelphi) page also demonstrates event sinks
To call a WMI function, you need to:
Get the WMI class from IWbemServices.GetObject(ClassName)
Call IWbemClassObject.GetMethod(MethodName) to get the parameter information(In and Out Params) of the function
Pass the required value to the corresponding through a VARIANT: IWbemClassObject.Put("Name",VARIANT). Maybe just do this in pascal: objInParams.Properties_.Item('Name').Value := xxx;
Get an instance of the class and get its Object Path, and finally execute IWbemServices.ExecMethod(path,MethodName,objInParams,objOutParams).
There is also a C++ sample with WmiMonitorDescriptorMethods.WmiGetMonitorRawEEdidV1Block here, although I am not familiar with FreePascal, you could also follow the steps and convert it to FreePascal.
We need to change some settings to the HKEY_LOCAL_MACHINE at runtime.
Is it possible to prompt for uac elevation if needed at runtime, or do I have to launch a second elevated process to do 'the dirty work'?
i would relaunch yourself as elevated, passing command line parameters indicating what elevated thing you want to do. You can then jump right to the appropriate form, or just save your HKLM stuff.
function RunAsAdmin(hWnd: HWND; filename: string; Parameters: string): Boolean;
{
See Step 3: Redesign for UAC Compatibility (UAC)
http://msdn.microsoft.com/en-us/library/bb756922.aspx
This code is released into the public domain. No attribution required.
}
var
sei: TShellExecuteInfo;
begin
ZeroMemory(#sei, SizeOf(sei));
sei.cbSize := SizeOf(TShellExecuteInfo);
sei.Wnd := hwnd;
sei.fMask := SEE_MASK_FLAG_DDEWAIT or SEE_MASK_FLAG_NO_UI;
sei.lpVerb := PChar('runas');
sei.lpFile := PChar(Filename); // PAnsiChar;
if parameters <> '' then
sei.lpParameters := PChar(parameters); // PAnsiChar;
sei.nShow := SW_SHOWNORMAL; //Integer;
Result := ShellExecuteEx(#sei);
end;
The other Microsoft suggested solution is to create an COM object out of process (using the specially created CoCreateInstanceAsAdmin function). i don't like this idea because you have to write and register a COM object.
Note: There is no "CoCreateInstanceAsAdmin" API call. It's just some code floating around. Here's the Dephi version i stumbled around for. It is apparently based on the trick of prefixing a class guid string with the "Elevation:Administrator!new:" prefix when normally hidden code internally calls CoGetObject:
function CoGetObject(pszName: PWideChar; pBindOptions: PBindOpts3;
const iid: TIID; ppv: PPointer): HResult; stdcall; external 'ole32.dll';
procedure CoCreateInstanceAsAdmin(const Handle: HWND;
const ClassID, IID: TGuid; PInterface: PPointer);
var
BindOpts: TBindOpts3;
MonikerName: WideString;
Res: HRESULT;
begin
//This code is released into the public domain. No attribution required.
ZeroMemory(#BindOpts, Sizeof(TBindOpts3));
BindOpts.cbStruct := Sizeof(TBindOpts3);
BindOpts.hwnd := Handle;
BindOpts.dwClassContext := CLSCTX_LOCAL_SERVER;
MonikerName := 'Elevation:Administrator!new:' + GUIDToString(ClassID);
Res := CoGetObject(PWideChar(MonikerName), #BindOpts, IID, PInterface);
if Failed(Res) then
raise Exception.Create(SysErrorMessage(Res));
end;
One other question: How do you handle someone running as standard user in Windows XP?
You can't "elevate" an existing process. Elevated processes under UAC have a different token with a different LUID, different mandatory integrity level, and different group membership. This level of change can't be done within a running process - and it would be a security problem if that could happen.
You need to launch a second process elevated that would do the work or by creating a COM object that runs in an elevated dllhost.
http://msdn.microsoft.com/en-us/library/bb756922.aspx gives an example "RunAsAdmin" function and a "CoCreateInstanceAsAdmin" function.
EDIT: I just saw "Delphi" in your title. Everything I listed is obviously native, but if Delphi provides access to ShellExecute-like functionality you should be able to adapt the code from the link.
A sample of ready-to-use code:
Usage example:
unit Unit1;
interface
uses
Windows{....};
type
TForm1 = class(TForm)
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
Label4: TLabel;
Button1: TButton;
Button2: TButton;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
procedure StartWait;
procedure EndWait;
end;
var
Form1: TForm1;
implementation
uses
RunElevatedSupport;
{$R *.dfm}
const
ArgInstallUpdate = '/install_update';
ArgRegisterExtension = '/register_global_file_associations';
procedure TForm1.FormCreate(Sender: TObject);
begin
Label1.Caption := Format('IsAdministrator: %s', [BoolToStr(IsAdministrator, True)]);
Label2.Caption := Format('IsAdministratorAccount: %s', [BoolToStr(IsAdministratorAccount, True)]);
Label3.Caption := Format('IsUACEnabled: %s', [BoolToStr(IsUACEnabled, True)]);
Label4.Caption := Format('IsElevated: %s', [BoolToStr(IsElevated, True)]);
Button1.Caption := 'Install updates';
SetButtonElevated(Button1.Handle);
Button2.Caption := 'Register file associations for all users';
SetButtonElevated(Button2.Handle);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
StartWait;
try
SetLastError(RunElevated(ArgInstallUpdate, Handle, Application.ProcessMessages));
if GetLastError <> ERROR_SUCCESS then
RaiseLastOSError;
finally
EndWait;
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
StartWait;
try
SetLastError(RunElevated(ArgRegisterExtension, Handle, Application.ProcessMessages));
if GetLastError <> ERROR_SUCCESS then
RaiseLastOSError;
finally
EndWait;
end;
end;
function DoElevatedTask(const AParameters: String): Cardinal;
procedure InstallUpdate;
var
Msg: String;
begin
Msg := 'Hello from InstallUpdate!' + sLineBreak +
sLineBreak +
'This function is running elevated under full administrator rights.' + sLineBreak +
'This means that you have write-access to Program Files folder and you''re able to overwrite files (e.g. install updates).' + sLineBreak +
'However, note that your executable is still running.' + sLineBreak +
sLineBreak +
'IsAdministrator: ' + BoolToStr(IsAdministrator, True) + sLineBreak +
'IsAdministratorAccount: ' + BoolToStr(IsAdministratorAccount, True) + sLineBreak +
'IsUACEnabled: ' + BoolToStr(IsUACEnabled, True) + sLineBreak +
'IsElevated: ' + BoolToStr(IsElevated, True);
MessageBox(0, PChar(Msg), 'Hello from InstallUpdate!', MB_OK or MB_ICONINFORMATION);
end;
procedure RegisterExtension;
var
Msg: String;
begin
Msg := 'Hello from RegisterExtension!' + sLineBreak +
sLineBreak +
'This function is running elevated under full administrator rights.' + sLineBreak +
'This means that you have write-access to HKEY_LOCAL_MACHINE key and you''re able to write keys and values (e.g. register file extensions globally/for all users).' + sLineBreak +
'However, note that this is usually not a good idea. It is better to register your file extensions under HKEY_CURRENT_USER\Software\Classes.' + sLineBreak +
sLineBreak +
'IsAdministrator: ' + BoolToStr(IsAdministrator, True) + sLineBreak +
'IsAdministratorAccount: ' + BoolToStr(IsAdministratorAccount, True) + sLineBreak +
'IsUACEnabled: ' + BoolToStr(IsUACEnabled, True) + sLineBreak +
'IsElevated: ' + BoolToStr(IsElevated, True);
MessageBox(0, PChar(Msg), 'Hello from RegisterExtension!', MB_OK or MB_ICONINFORMATION);
end;
begin
Result := ERROR_SUCCESS;
if AParameters = ArgInstallUpdate then
InstallUpdate
else
if AParameters = ArgRegisterExtension then
RegisterExtension
else
Result := ERROR_GEN_FAILURE;
end;
procedure TForm1.StartWait;
begin
Cursor := crHourglass;
Screen.Cursor := crHourglass;
Button1.Enabled := False;
Button2.Enabled := False;
Application.ProcessMessages;
end;
procedure TForm1.EndWait;
begin
Cursor := crDefault;
Screen.Cursor := crDefault;
Button1.Enabled := True;
Button2.Enabled := True;
Application.ProcessMessages;
end;
initialization
OnElevateProc := DoElevatedTask;
CheckForElevatedTask;
end.
And support unit itself:
unit RunElevatedSupport;
{$WARN SYMBOL_PLATFORM OFF}
{$R+}
interface
uses
Windows;
type
TElevatedProc = function(const AParameters: String): Cardinal;
TProcessMessagesMeth = procedure of object;
var
// Warning: this function will be executed in external process.
// Do not use any global variables inside this routine!
// Use only supplied AParameters.
OnElevateProc: TElevatedProc;
// Call this routine after you have assigned OnElevateProc
procedure CheckForElevatedTask;
// Runs OnElevateProc under full administrator rights
function RunElevated(const AParameters: String; const AWnd: HWND = 0; const AProcessMessages: TProcessMessagesMeth = nil): Cardinal; overload;
function IsAdministrator: Boolean;
function IsAdministratorAccount: Boolean;
function IsUACEnabled: Boolean;
function IsElevated: Boolean;
procedure SetButtonElevated(const AButtonHandle: THandle);
implementation
uses
SysUtils, Registry, ShellAPI, ComObj;
const
RunElevatedTaskSwitch = '0CC5C50CB7D643B68CB900BF000FFFD5'; // some unique value, just a GUID with removed '[', ']', and '-'
function CheckTokenMembership(TokenHandle: THANDLE; SidToCheck: Pointer; var IsMember: BOOL): BOOL; stdcall; external advapi32 name 'CheckTokenMembership';
function RunElevated(const AParameters: String; const AWnd: HWND = 0; const AProcessMessages: TProcessMessagesMeth = nil): Cardinal; overload;
var
SEI: TShellExecuteInfo;
Host: String;
Args: String;
begin
Assert(Assigned(OnElevateProc), 'OnElevateProc must be assigned before calling RunElevated');
if IsElevated then
begin
if Assigned(OnElevateProc) then
Result := OnElevateProc(AParameters)
else
Result := ERROR_PROC_NOT_FOUND;
Exit;
end;
Host := ParamStr(0);
Args := Format('/%s %s', [RunElevatedTaskSwitch, AParameters]);
FillChar(SEI, SizeOf(SEI), 0);
SEI.cbSize := SizeOf(SEI);
SEI.fMask := SEE_MASK_NOCLOSEPROCESS;
{$IFDEF UNICODE}
SEI.fMask := SEI.fMask or SEE_MASK_UNICODE;
{$ENDIF}
SEI.Wnd := AWnd;
SEI.lpVerb := 'runas';
SEI.lpFile := PChar(Host);
SEI.lpParameters := PChar(Args);
SEI.nShow := SW_NORMAL;
if not ShellExecuteEx(#SEI) then
RaiseLastOSError;
try
Result := ERROR_GEN_FAILURE;
if Assigned(AProcessMessages) then
begin
repeat
if not GetExitCodeProcess(SEI.hProcess, Result) then
Result := ERROR_GEN_FAILURE;
AProcessMessages;
until Result <> STILL_ACTIVE;
end
else
begin
if WaitForSingleObject(SEI.hProcess, INFINITE) <> WAIT_OBJECT_0 then
if not GetExitCodeProcess(SEI.hProcess, Result) then
Result := ERROR_GEN_FAILURE;
end;
finally
CloseHandle(SEI.hProcess);
end;
end;
function IsAdministrator: Boolean;
var
psidAdmin: Pointer;
B: BOOL;
const
SECURITY_NT_AUTHORITY: TSidIdentifierAuthority = (Value: (0, 0, 0, 0, 0, 5));
SECURITY_BUILTIN_DOMAIN_RID = $00000020;
DOMAIN_ALIAS_RID_ADMINS = $00000220;
SE_GROUP_USE_FOR_DENY_ONLY = $00000010;
begin
psidAdmin := nil;
try
// Создаём SID группы админов для проверки
Win32Check(AllocateAndInitializeSid(SECURITY_NT_AUTHORITY, 2,
SECURITY_BUILTIN_DOMAIN_RID, DOMAIN_ALIAS_RID_ADMINS, 0, 0, 0, 0, 0, 0,
psidAdmin));
// Проверяем, входим ли мы в группу админов (с учётов всех проверок на disabled SID)
if CheckTokenMembership(0, psidAdmin, B) then
Result := B
else
Result := False;
finally
if psidAdmin <> nil then
FreeSid(psidAdmin);
end;
end;
{$R-}
function IsAdministratorAccount: Boolean;
var
psidAdmin: Pointer;
Token: THandle;
Count: DWORD;
TokenInfo: PTokenGroups;
HaveToken: Boolean;
I: Integer;
const
SECURITY_NT_AUTHORITY: TSidIdentifierAuthority = (Value: (0, 0, 0, 0, 0, 5));
SECURITY_BUILTIN_DOMAIN_RID = $00000020;
DOMAIN_ALIAS_RID_ADMINS = $00000220;
SE_GROUP_USE_FOR_DENY_ONLY = $00000010;
begin
Result := Win32Platform <> VER_PLATFORM_WIN32_NT;
if Result then
Exit;
psidAdmin := nil;
TokenInfo := nil;
HaveToken := False;
try
Token := 0;
HaveToken := OpenThreadToken(GetCurrentThread, TOKEN_QUERY, True, Token);
if (not HaveToken) and (GetLastError = ERROR_NO_TOKEN) then
HaveToken := OpenProcessToken(GetCurrentProcess, TOKEN_QUERY, Token);
if HaveToken then
begin
Win32Check(AllocateAndInitializeSid(SECURITY_NT_AUTHORITY, 2,
SECURITY_BUILTIN_DOMAIN_RID, DOMAIN_ALIAS_RID_ADMINS, 0, 0, 0, 0, 0, 0,
psidAdmin));
if GetTokenInformation(Token, TokenGroups, nil, 0, Count) or
(GetLastError <> ERROR_INSUFFICIENT_BUFFER) then
RaiseLastOSError;
TokenInfo := PTokenGroups(AllocMem(Count));
Win32Check(GetTokenInformation(Token, TokenGroups, TokenInfo, Count, Count));
for I := 0 to TokenInfo^.GroupCount - 1 do
begin
Result := EqualSid(psidAdmin, TokenInfo^.Groups[I].Sid);
if Result then
Break;
end;
end;
finally
if TokenInfo <> nil then
FreeMem(TokenInfo);
if HaveToken then
CloseHandle(Token);
if psidAdmin <> nil then
FreeSid(psidAdmin);
end;
end;
{$R+}
function IsUACEnabled: Boolean;
var
Reg: TRegistry;
begin
Result := CheckWin32Version(6, 0);
if Result then
begin
Reg := TRegistry.Create(KEY_READ);
try
Reg.RootKey := HKEY_LOCAL_MACHINE;
if Reg.OpenKey('\Software\Microsoft\Windows\CurrentVersion\Policies\System', False) then
if Reg.ValueExists('EnableLUA') then
Result := (Reg.ReadInteger('EnableLUA') <> 0)
else
Result := False
else
Result := False;
finally
FreeAndNil(Reg);
end;
end;
end;
function IsElevated: Boolean;
const
TokenElevation = TTokenInformationClass(20);
type
TOKEN_ELEVATION = record
TokenIsElevated: DWORD;
end;
var
TokenHandle: THandle;
ResultLength: Cardinal;
ATokenElevation: TOKEN_ELEVATION;
HaveToken: Boolean;
begin
if CheckWin32Version(6, 0) then
begin
TokenHandle := 0;
HaveToken := OpenThreadToken(GetCurrentThread, TOKEN_QUERY, True, TokenHandle);
if (not HaveToken) and (GetLastError = ERROR_NO_TOKEN) then
HaveToken := OpenProcessToken(GetCurrentProcess, TOKEN_QUERY, TokenHandle);
if HaveToken then
begin
try
ResultLength := 0;
if GetTokenInformation(TokenHandle, TokenElevation, #ATokenElevation, SizeOf(ATokenElevation), ResultLength) then
Result := ATokenElevation.TokenIsElevated <> 0
else
Result := False;
finally
CloseHandle(TokenHandle);
end;
end
else
Result := False;
end
else
Result := IsAdministrator;
end;
procedure SetButtonElevated(const AButtonHandle: THandle);
const
BCM_SETSHIELD = $160C;
var
Required: BOOL;
begin
if not CheckWin32Version(6, 0) then
Exit;
if IsElevated then
Exit;
Required := True;
SendMessage(AButtonHandle, BCM_SETSHIELD, 0, LPARAM(Required));
end;
procedure CheckForElevatedTask;
function GetArgsForElevatedTask: String;
function PrepareParam(const ParamNo: Integer): String;
begin
Result := ParamStr(ParamNo);
if Pos(' ', Result) > 0 then
Result := AnsiQuotedStr(Result, '"');
end;
var
X: Integer;
begin
Result := '';
for X := 1 to ParamCount do
begin
if (AnsiUpperCase(ParamStr(X)) = ('/' + RunElevatedTaskSwitch)) or
(AnsiUpperCase(ParamStr(X)) = ('-' + RunElevatedTaskSwitch)) then
Continue;
Result := Result + PrepareParam(X) + ' ';
end;
Result := Trim(Result);
end;
var
ExitCode: Cardinal;
begin
if not FindCmdLineSwitch(RunElevatedTaskSwitch) then
Exit;
ExitCode := ERROR_GEN_FAILURE;
try
if not IsElevated then
ExitCode := ERROR_ACCESS_DENIED
else
if Assigned(OnElevateProc) then
ExitCode := OnElevateProc(GetArgsForElevatedTask)
else
ExitCode := ERROR_PROC_NOT_FOUND;
except
on E: Exception do
begin
if E is EAbort then
ExitCode := ERROR_CANCELLED
else
if E is EOleSysError then
ExitCode := Cardinal(EOleSysError(E).ErrorCode)
else
if E is EOSError then
else
ExitCode := ERROR_GEN_FAILURE;
end;
end;
if ExitCode = STILL_ACTIVE then
ExitCode := ERROR_GEN_FAILURE;
TerminateProcess(GetCurrentProcess, ExitCode);
end;
end.
Usually, putting the text "Setup" or "Install" somewhere in your EXE name is enough to make Windows run with elevated privileges automatically, and is well worth doing if it is a setup utility you are writing, as it's so easy to do.
I am now running into problems though on Windows 7, when not logged in as an Administrator, and am having to use the right-click Run As Administrator when running manually (running the program via Wise installation wizard is still fine)
I see though that Delphi 10.1 Berlin has a very easy to use new option under Project Options | Application. Just tick Enable Administrator Privileges, and the manifest is done for you, so easy!
NB. make sure you only do these kind of changes via a separate setup program, running your application with elevated privileges all the time can cause problems with other things, for example e-mail, where the default mail profile no longer gets picked up.
Edit: Jan 2018: since writing this answer in August 2017, it seems a lot of Windows updates have come out, that now require the user to right-click and Run As Administrator on just about everything, even on installation exe's built with Wise. Even Outlook is no longer installing properly without running as administrator. There is no more automated elevation at all it seems.
I am hunting a bug which might be connected to unit initialization order. Is there a way to see which initialization section was executed when? I need to know the order. This is during debugging, so I have the full power of the Delphi IDE, in my case Delphi 2009.
I could set breakpoints, but this is rather tedious when having many units.
Do you have any suggestions?
Here is some code I just tested in D2010, note that you need to set a Breakpoint in System.InitUnits and get the address of InitContext var (#InitContext). Then modify CtxPtr to have this address WHILE STILL RUNNING. (Maybe someone knows a smarter way for this).
procedure TForm3.Button2Click(Sender: TObject);
var
sl: TStringList;
ps: PShortString;
CtxPtr: PInitContext;
begin
// Get the address by setting a BP in SysUtils.InitUnits (or map file?)
CtxPtr := PInitContext($4C3AE8);
sl := TStringList.Create;
try
ps := CtxPtr^.Module^.TypeInfo^.UnitNames;
for i := 0 to CtxPtr^.Module^.TypeInfo^.UnitCount - 1 do
begin
sl.Add(ps^);
// Move to next unit
DWORD(ps) := DWORD(ps) + Length(ps^) + 1;
end;
Memo1.Lines.Assign(sl);
finally
sl.Free;
end;
end;
/EDIT: and here is a version using JclDebug and a mapfile:
type
TForm3 = class(TForm)
...
private
{ Private declarations }
var
Segments: array of DWORD;
procedure PublicsByValue(Sender: TObject; const Address: TJclMapAddress; const Name: string);
procedure MapSegment(Sender: TObject; const Address: TJclMapAddress; Len: Integer; const GroupName, UnitName: string);
procedure MapClassTable(Sender: TObject; const Address: TJclMapAddress; Len: Integer; const SectionName, GroupName: string);
public
{ Public declarations }
end;
var
Form3: TForm3;
CtxPtr: PInitContext = nil; // Global var
procedure TForm3.MapClassTable(Sender: TObject; const Address: TJclMapAddress;
Len: Integer; const SectionName, GroupName: string);
begin
SetLength(Segments, Length(Segments) + 1);
SegMents[Address.Segment-1] := Address.Offset;
end;
procedure TForm3.PublicsByValue(Sender: TObject; const Address: TJclMapAddress;
const Name: string);
const
InitContextStr = 'System.InitContext';
begin
if RightStr(Name, Length(InitContextStr)) = InitContextStr then
begin
CtxPtr := PInitContext(Segments[Address.Segment-1] + Address.Offset);
end;
end;
procedure TForm3.Button2Click(Sender: TObject);
var
MapParser: TJclMapParser;
MapFile: String;
sl: TStringList;
ps: PShortString;
i: Integer;
begin
MapFile := ChangeFileExt(Application.ExeName, '.map');
MapParser := TJclMapParser.Create(MapFile);
try
MapParser.OnPublicsByValue := PublicsByValue;
MapParser.OnClassTable := MapClassTable;
MapParser.Parse;
finally
MapParser.Free;
end;
if CtxPtr = nil then
Exit;
sl := TStringList.Create;
try
ps := CtxPtr^.Module^.TypeInfo^.UnitNames;
for i := 0 to CtxPtr^.Module^.TypeInfo^.UnitCount - 1 do
begin
sl.Add(ps^);
// Move to next unit
DWORD(ps) := DWORD(ps) + Length(ps^) + 1;
end;
Memo1.Lines.Assign(sl);
finally
sl.Free;
end;
end;
Output in my case:
Variants
VarUtils
Windows
Types
SysInit
System
SysConst
SysUtils
Character
RTLConsts
Math
StrUtils
ImageHlp
MainUnit
JwaWinNetWk
JwaWinType
JwaWinNT
JwaWinDLLNames
JwaWinError
StdCtrls
Dwmapi
UxTheme
SyncObjs
Classes
ActiveX
Messages
TypInfo
TimeSpan
CommCtrl
Themes
Controls
Forms
StdActns
ComCtrls
CommDlg
ShlObj
StructuredQueryCondition
PropSys
ObjectArray
UrlMon
WinInet
RegStr
ShellAPI
ComStrs
Consts
Printers
Graphics
Registry
IniFiles
IOUtils
Masks
DateUtils
Wincodec
WinSpool
ActnList
Menus
ImgList
Contnrs
GraphUtil
ZLib
ListActns
ExtCtrls
Dialogs
HelpIntfs
MultiMon
Dlgs
WideStrUtils
ToolWin
RichEdit
Clipbrd
FlatSB
Imm
TpcShrd
/EDIT2: And here a version for D2009 (requires JclDebug):
unit MainUnit;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StrUtils, JclDebug, StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
var
Segments: array of DWORD;
procedure PublicsByValue(Sender: TObject; const Address: TJclMapAddress; const Name: string);
procedure MapClassTable(Sender: TObject; const Address: TJclMapAddress; Len: Integer; const SectionName, GroupName: string);
public
{ Public declarations }
end;
var
Form1: TForm1;
CtxPtr: PInitContext = nil; // Global var
Symbols: TStringList;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
var
MapParser: TJclMapParser;
MapFile: String;
sl: TStringList;
ps: PShortString;
i: Integer;
s: String;
Idx: Integer;
begin
MapFile := ChangeFileExt(Application.ExeName, '.map');
MapParser := TJclMapParser.Create(MapFile);
try
MapParser.OnPublicsByValue := PublicsByValue;
MapParser.OnClassTable := MapClassTable;
Memo1.Lines.BeginUpdate;
MapParser.Parse;
Memo1.Lines.EndUpdate;
finally
MapParser.Free;
end;
if CtxPtr = nil then
Exit;
sl := TStringList.Create;
try
for i := 0 to CtxPtr^.InitTable.UnitCount-1 do
begin
if Assigned(CtxPtr^.InitTable.UnitInfo^[i].Init) then
begin
s := Format('$%.8x', [DWORD(CtxPtr^.InitTable.UnitInfo^[i].Init)]);
Idx := Symbols.IndexOfObject(TObject(CtxPtr^.InitTable.UnitInfo^[i].Init));
if Idx > -1 then
begin
Memo1.Lines.Add(Format('%.4d: %s', [i, Symbols[Idx]]));
end;
end;
end;
finally
sl.Free;
end;
end;
procedure TForm1.MapClassTable(Sender: TObject; const Address: TJclMapAddress;
Len: Integer; const SectionName, GroupName: string);
begin
SetLength(Segments, Length(Segments) + 1);
SegMents[Address.Segment-1] := Address.Offset;
end;
procedure TForm1.PublicsByValue(Sender: TObject; const Address: TJclMapAddress;
const Name: string);
const
InitContextStr = 'System.InitContext';
begin
if RightStr(Name, Length(InitContextStr)) = InitContextStr then
begin
CtxPtr := PInitContext(Segments[Address.Segment-1] + Address.Offset);
end
else begin
Symbols.AddObject(Name, TObject(Segments[Address.Segment-1] + Address.Offset));
end;
end;
initialization
Symbols := TStringList.Create;
Symbols.Sorted := True;
Symbols.Duplicates := dupIgnore;
finalization
FreeAndNil(Symbols);
end.
Output on my system (Unitname.Unitname is actually Unitname.Initialization):
0001: System.System
0003: Windows.Windows
0011: SysUtils.SysUtils
0012: VarUtils.VarUtils
0013: Variants.Variants
0014: TypInfo.TypInfo
0016: Classes.Classes
0017: IniFiles.IniFiles
0018: Registry.Registry
0020: Graphics.Graphics
0023: SyncObjs.SyncObjs
0024: UxTheme.UxTheme
0025: MultiMon.MultiMon
0027: ActnList.ActnList
0028: DwmApi.DwmApi
0029: Controls.Controls
0030: Themes.Themes
0032: Menus.Menus
0033: HelpIntfs.HelpIntfs
0034: FlatSB.FlatSB
0036: Printers.Printers
0047: GraphUtil.GraphUtil
0048: ExtCtrls.ExtCtrls
0051: ComCtrls.ComCtrls
0054: Dialogs.Dialogs
0055: Clipbrd.Clipbrd
0057: Forms.Forms
0058: JclResources.JclResources
0059: JclBase.JclBase
0061: JclWin32.JclWin32
0063: ComObj.ComObj
0064: AnsiStrings.AnsiStrings
0065: JclLogic.JclLogic
0066: JclStringConversions.JclStringConversions
0067: JclCharsets.JclCharsets
0068: Jcl8087.Jcl8087
0073: JclIniFiles.JclIniFiles
0074: JclSysInfo.JclSysInfo
0075: JclUnicode.JclUnicode
0076: JclWideStrings.JclWideStrings
0077: JclRegistry.JclRegistry
0078: JclSynch.JclSynch
0079: JclMath.JclMath
0080: JclStreams.JclStreams
0081: JclAnsiStrings.JclAnsiStrings
0082: JclStrings.JclStrings
0083: JclShell.JclShell
0084: JclSecurity.JclSecurity
0085: JclDateTime.JclDateTime
0086: JclFileUtils.JclFileUtils
0087: JclConsole.JclConsole
0088: JclSysUtils.JclSysUtils
0089: JclUnitVersioning.JclUnitVersioning
0090: JclPeImage.JclPeImage
0091: JclTD32.JclTD32
0092: JclHookExcept.JclHookExcept
0093: JclDebug.JclDebug
0094: MainUnit.MainUnit
For units in the interface uses list,
the initialization sections of the
units used by a client are executed in
the order in which the units appear in
the client's uses clause.
see Online Help \ Programs and Units \ The Initialization Section and this article: Understanding Delphi Unit initialization order
ICARUS computes the Runtime initialization order for its Uses Report:
This section lists the order in which the initialization sections are executed at runtime.
You might check out the unit System and SysInit and look for the procedure InitUnits. Here you see that every module compiled with Delphi has a list of units initialization and finalization pointers. Using those plus a map file might give you the exact initialization order, but it will take some pointer hackery.
How about adding
OutputDebugString('In MyUnit initialization');
to the initialization sections?
You can set breakpoints on all initialization sections that don't break but write a message to the debugger log. It will give you the same list as adding OutputDebugString('...') calls but without having to modify the source code of all units.
This question already has answers here:
Closed 12 years ago.
Possible Duplicates:
Getting Machine’s MAC Address — Good Solution?
How do I get the MAC address of a network card using Delphi?
I am using MAC address as hardware id for protection(ofcourse I have encrypted this data)
I am using below code to get MAC address on user computer
function MacAddress: string;
var
Lib: Cardinal;
Func: function(GUID: PGUID): Longint; stdcall;
GUID1, GUID2: TGUID;
begin
Result := '';
Lib := LoadLibrary('rpcrt4.dll');
if Lib <> 0 then
begin
#Func := GetProcAddress(Lib, 'UuidCreateSequential');
if Assigned(Func) then
begin
if (Func(#GUID1) = 0) and
(Func(#GUID2) = 0) and
(GUID1.D4[2] = GUID2.D4[2]) and
(GUID1.D4[3] = GUID2.D4[3]) and
(GUID1.D4[4] = GUID2.D4[4]) and
(GUID1.D4[5] = GUID2.D4[5]) and
(GUID1.D4[6] = GUID2.D4[6]) and
(GUID1.D4[7] = GUID2.D4[7]) then
begin
Result :=
IntToHex(GUID1.D4[2], 2) + '-' +
IntToHex(GUID1.D4[3], 2) + '-' +
IntToHex(GUID1.D4[4], 2) + '-' +
IntToHex(GUID1.D4[5], 2) + '-' +
IntToHex(GUID1.D4[6], 2) + '-' +
IntToHex(GUID1.D4[7], 2);
end;
end;
end;
end;
above code works perfectly on windows XP
but its giving different values in windows7 ,the value changing every time after computer resratred :(
is there any chance of getting MAC address thats constant (unless user changed his MAC address)
or is there any good code which retrvies constant data on all OS ?
thanks in advance
#steve0, to retrieve the mac address of an Network Adapter you can use the WMI and the Win32_NetworkAdapterConfiguration Class and check the MACAddress property.
Check this code:
program WMI_MAC;
{$APPTYPE CONSOLE}
uses
SysUtils
,ActiveX
,ComObj
,Variants;
function VarToStrNil(Value:Variant):string; //Dummy function to onvert an variant value to string
begin
if VarIsNull(Value) then
Result:=''
else
Result:=VarToStr(Value);
end;
Procedure GetMacAddress;
var
objWMIService : OLEVariant;
colItems : OLEVariant;
colItem : OLEVariant;
oEnum : IEnumvariant;
iValue : LongWord;
wmiHost, root, wmiClass: string;
function GetWMIObject(const objectName: String): IDispatch;
var
chEaten: Integer;
BindCtx: IBindCtx;//for access to a bind context
Moniker: IMoniker;//Enables you to use a moniker object
begin
OleCheck(CreateBindCtx(0, bindCtx));
OleCheck(MkParseDisplayName(BindCtx, StringToOleStr(objectName), chEaten, Moniker));//Converts a string into a moniker that identifies the object named by the string
OleCheck(Moniker.BindToObject(BindCtx, nil, IDispatch, Result));//Binds to the specified object
end;
begin
wmiHost := '.';
root := 'root\CIMV2';
wmiClass := 'Win32_NetworkAdapterConfiguration';
objWMIService := GetWMIObject(Format('winmgmts:\\%s\%s',[wmiHost,root]));
colItems := objWMIService.ExecQuery(Format('SELECT * FROM %s',[wmiClass]),'WQL',0);
oEnum := IUnknown(colItems._NewEnum) as IEnumVariant;
while oEnum.Next(1, colItem, iValue) = 0 do
//if VarToStrNil(colItem.MACAddress)<>'' then //uncomment if you only want list the interfaces with mac adress
//if colItem.IPEnabled then // uncomment if you only want list the active interfaces
begin
WriteLn('Card Description '+VarToStrNil(colItem.Caption));
WriteLn('MACAddress '+VarToStrNil(colItem.MACAddress));
end;
end;
begin
try
CoInitialize(nil);
try
GetMacAddress;
Readln;
finally
CoUninitialize;
end;
except
on E:Exception do
Begin
Writeln(E.Classname, ': ', E.Message);
Readln;
End;
end;
end.
Here is some code working well for any computer on your network - may try it to get your own, using '127.0.0.1' as IP:
function GetRemoteMacAddress(const IP: AnsiString): TSockData;
// implements http://msdn.microsoft.com/en-us/library/aa366358(VS.85).aspx
type
TSendARP = function(DestIp: DWORD; srcIP: DWORD; pMacAddr: pointer; PhyAddrLen: Pointer): DWORD; stdcall;
const
HexChars: array[0..15] of AnsiChar = '0123456789ABCDEF';
var dwRemoteIP: DWORD;
PhyAddrLen: Longword;
pMacAddr : array [0..7] of byte;
I: integer;
P: PAnsiChar;
SendARPLibHandle: THandle;
SendARP: TSendARP;
begin
result := '';
SendARPLibHandle := LoadLibrary('iphlpapi.dll');
if SendARPLibHandle<>0 then
try
SendARP := GetProcAddress(SendARPLibHandle,'SendARP');
if #SendARP=nil then
exit; // we are not under 2K or later
dwremoteIP := inet_addr(pointer(IP));
if dwremoteIP<>0 then begin
PhyAddrLen := 8;
if SendARP(dwremoteIP, 0, #pMacAddr, #PhyAddrLen)=NO_ERROR then begin
if PhyAddrLen=6 then begin
SetLength(result,12);
P := pointer(result);
for i := 0 to 5 do begin
P[0] := HexChars[pMacAddr[i] shr 4];
P[1] := HexChars[pMacAddr[i] and $F];
inc(P,2);
end;
end;
end;
end;
finally
FreeLibrary(SendARPLibHandle);
end;
end;
This code is extracted from our freeware and open source framework, unit SynCrtSock.pas. See http://synopse.info/fossil
Using the standard win32 api, what's the best way to detect more than one user is logged on? I have an upgrade to our software product that can't be run when more than one user is logged in. (I know this is something to be avoided because of its annoyance factor, but the product is very complicated. You'll have to trust me when I say there really is no other solution.) Thanks.
In order to have more than one user logged in at once, Terminal Services or Fast User Switching must be enabled. Since Fast User Switching is implemented using Terminal Services, you first need to find out if the OS has it enabled. You can use GetVersionEx with an OSVERSIONINFOEX. Check for the VER_SUITE_SINGLEUSERTS and VER_SUITE_TERMINAL flags.
If TS is enabled, you can use WTSEnumerateSessions to find out how many users are logged on. This only works if the "Terminal Services" service is started.
If the machine doesn't support Terminal Services (or if the service isn't started), then you can only have one user logged on.
Here's a solution that works on XP, Server 2003, Vista, and Server 2008. Note, this won't work on Windows 2000, because "LsaEnumerateLogonSessions" is not available on Windows 2000. This code is modified from a Delphi-PRAXIS post.
To compile this, create a new VCL application with a TButton and a TMemo on the form. Then copy and paste this code and it should compile. I tested on XP and Vista and it works well. It will return interactive and remote users.
unit main;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
const
WTS_CURRENT_SERVER_HANDLE = 0;
type
PTOKEN_USER = ^TOKEN_USER;
_TOKEN_USER = record
User: TSidAndAttributes;
end;
TOKEN_USER = _TOKEN_USER;
USHORT = word;
_LSA_UNICODE_STRING = record
Length: USHORT;
MaximumLength: USHORT;
Buffer: LPWSTR;
end;
LSA_UNICODE_STRING = _LSA_UNICODE_STRING;
PLuid = ^LUID;
_LUID = record
LowPart: DWORD;
HighPart: LongInt;
end;
LUID = _LUID;
_SECURITY_LOGON_TYPE = (
seltFiller0, seltFiller1,
Interactive,
Network,
Batch,
Service,
Proxy,
Unlock,
NetworkCleartext,
NewCredentials,
RemoteInteractive,
CachedInteractive,
CachedRemoteInteractive);
SECURITY_LOGON_TYPE = _SECURITY_LOGON_TYPE;
PSECURITY_LOGON_SESSION_DATA = ^SECURITY_LOGON_SESSION_DATA;
_SECURITY_LOGON_SESSION_DATA = record
Size: ULONG;
LogonId: LUID;
UserName: LSA_UNICODE_STRING;
LogonDomain: LSA_UNICODE_STRING;
AuthenticationPackage: LSA_UNICODE_STRING;
LogonType: SECURITY_LOGON_TYPE;
Session: ULONG;
Sid: PSID;
LogonTime: LARGE_INTEGER;
LogonServer: LSA_UNICODE_STRING;
DnsDomainName: LSA_UNICODE_STRING;
Upn: LSA_UNICODE_STRING;
end;
SECURITY_LOGON_SESSION_DATA = _SECURITY_LOGON_SESSION_DATA;
_WTS_INFO_CLASS = (
WTSInitialProgram,
WTSApplicationName,
WTSWorkingDirectory,
WTSOEMId,
WTSSessionId,
WTSUserName,
WTSWinStationName,
WTSDomainName,
WTSConnectState,
WTSClientBuildNumber,
WTSClientName,
WTSClientDirectory,
WTSClientProductId,
WTSClientHardwareId,
WTSClientAddress,
WTSClientDisplay,
WTSClientProtocolType);
WTS_INFO_CLASS = _WTS_INFO_CLASS;
_WTS_CONNECTSTATE_CLASS = (
WTSActive, // User logged on to WinStation
WTSConnected, // WinStation connected to client
WTSConnectQuery, // In the process of connecting to client
WTSShadow, // Shadowing another WinStation
WTSDisconnected, // WinStation logged on without client
WTSIdle, // Waiting for client to connect
WTSListen, // WinStation is listening for connection
WTSReset, // WinStation is being reset
WTSDown, // WinStation is down due to error
WTSInit); // WinStation in initialization
WTS_CONNECTSTATE_CLASS = _WTS_CONNECTSTATE_CLASS;
function LsaFreeReturnBuffer(Buffer: pointer): Integer; stdcall;
function WTSGetActiveConsoleSessionId: DWORD; external 'Kernel32.dll';
function LsaGetLogonSessionData(LogonId: PLUID;
var ppLogonSessionData: PSECURITY_LOGON_SESSION_DATA): LongInt; stdcall;
external 'Secur32.dll';
function LsaNtStatusToWinError(Status: cardinal): ULONG; stdcall;
external 'Advapi32.dll';
function LsaEnumerateLogonSessions(Count: PULONG; List: PLUID): LongInt;
stdcall; external 'Secur32.dll';
function WTSQuerySessionInformationA(hServer: THandle; SessionId: DWORD;
WTSInfoClass: WTS_INFO_CLASS; var pBuffer: Pointer;
var pBytesReturned: DWORD): BOOL; stdcall; external 'Wtsapi32.dll';
type
TForm1 = class(TForm)
Button1: TButton;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
function LsaFreeReturnBuffer; external 'secur32.dll' name 'LsaFreeReturnBuffer';
procedure GetActiveUserNames(var slUserList : TStringList);
var
Count: cardinal;
List: PLUID;
sessionData: PSECURITY_LOGON_SESSION_DATA;
i1: integer;
SizeNeeded, SizeNeeded2: DWORD;
OwnerName, DomainName: PChar;
OwnerType: SID_NAME_USE;
pBuffer: Pointer;
pBytesreturned: DWord;
sUser : string;
begin
//result:= '';
//Listing LogOnSessions
i1:= lsaNtStatusToWinError(LsaEnumerateLogonSessions(#Count, #List));
try
if i1 = 0 then
begin
i1:= -1;
if Count > 0 then
begin
repeat
inc(i1);
LsaGetLogonSessionData(List, sessionData);
//Checks if it is an interactive session
sUser := sessionData.UserName.Buffer;
if (sessionData.LogonType = Interactive)
or (sessionData.LogonType = RemoteInteractive)
or (sessionData.LogonType = CachedInteractive)
or (sessionData.LogonType = CachedRemoteInteractive) then
begin
//
SizeNeeded := MAX_PATH;
SizeNeeded2:= MAX_PATH;
GetMem(OwnerName, MAX_PATH);
GetMem(DomainName, MAX_PATH);
try
if LookupAccountSID(nil, sessionData.SID, OwnerName,
SizeNeeded, DomainName,SizeNeeded2,
OwnerType) then
begin
if OwnerType = 1 then //This is a USER account SID (SidTypeUser=1)
begin
sUser := AnsiUpperCase(sessionData.LogonDomain.Buffer);
sUser := sUser + '\';
sUser := sUser + AnsiUpperCase(sessionData.UserName.Buffer);
slUserList.Add(sUser);
// if sessionData.Session = WTSGetActiveConsoleSessionId then
// begin
// //Wenn Benutzer aktiv
// try
// if WTSQuerySessionInformationA
// (WTS_CURRENT_SERVER_HANDLE,
// sessionData.Session, WTSConnectState,
// pBuffer,
// pBytesreturned) then
// begin
// if WTS_CONNECTSTATE_CLASS(pBuffer^) = WTSActive then
// begin
// //result:= sessionData.UserName.Buffer;
// slUserList.Add(sessionData.UserName.Buffer);
// end;
// end;
// finally
// LSAFreeReturnBuffer(pBuffer);
// end;
//end;
end;
end;
finally
FreeMem(OwnerName);
FreeMem(DomainName);
end;
end;
inc(List);
try
LSAFreeReturnBuffer(sessionData);
except
end;
until (i1 = Count-1);// or (result <> '');
end;
end;
finally
LSAFreeReturnBuffer(List);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
slUsers : TStringList;
begin
slUsers := TStringList.Create;
slUsers.Duplicates := dupIgnore;
slUsers.Sorted := True;
try
GetActiveUserNames(slUsers);
Memo1.Lines.AddStrings(slUsers);
finally
FreeAndNil(slUsers)
end;
end;
end.
This might be a roundabout way, but run down the process list and see who the process owners are.