I am writing a console application using BDE 2006 and I want it to be able to prompt for a password string and mask it with "*" as the user is typing. I have looked around but I could not find examples of how to do this. Everything I saw was how to do this in TEdit. Any pointers on how to accomplish this?
Thanks in advance,
Nic
Here's a working solution:
program Project2;
{$APPTYPE CONSOLE}
uses
SysUtils, Windows;
function GetPassword(const InputMask: Char = '*'): string;
var
OldMode: Cardinal;
c: char;
begin
GetConsoleMode(GetStdHandle(STD_INPUT_HANDLE), OldMode);
SetConsoleMode(GetStdHandle(STD_INPUT_HANDLE), OldMode and not (ENABLE_LINE_INPUT or ENABLE_ECHO_INPUT));
try
while not Eof do
begin
Read(c);
if c = #13 then // Carriage Return
Break;
Result := Result + c;
if c = #8 then // Back Space
Write(#8)
else
Write(InputMask);
end;
finally
SetConsoleMode(GetStdHandle(STD_INPUT_HANDLE), OldMode);
end;
end;
begin
try
Writeln(Format(sLineBreak + 'pswd=%s',[GetPassword]));
Readln;
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
end.
Update: Note that the above code handles the BackSpaces visually, but keeps them embedded in the password, which might not be what you want.
In that case the following code would filter them out:
if c = #13 then // Carriage Return
Break;
if (c = #8) and (Length(Result) > 0) then // Back Space
begin
Delete(Result, Length(Result), 1);
Write(#8);
end
else
begin
Result := Result + c;
Write(InputMask);
end;
I have a unit with procedure ConsoleGetPassword(const caption: String; var Password: string); which does what you want
see http://gist.github.com/570659
This works.
program Project2;
{$APPTYPE CONSOLE}
uses
SysUtils, Windows;
const
BUF_LEN = 1024;
var
amt, i, cmode: cardinal;
buf: packed array[0..BUF_LEN - 1] of char;
begin
try
Write('Enter password: ');
GetConsoleMode(GetStdHandle(STD_INPUT_HANDLE), cmode);
SetConsoleMode(GetStdHandle(STD_INPUT_HANDLE), cmode and not ENABLE_ECHO_INPUT);
ReadConsole(GetStdHandle(STD_INPUT_HANDLE), #buf[0], BUF_LEN, amt, nil);
SetConsoleMode(GetStdHandle(STD_INPUT_HANDLE), cmode);
Writeln;
Writeln;
Writeln('You entered: ');
for i := 0 to amt - 3 do
Write(buf[i]);
Writeln;
Writeln;
Writeln('Done');
Readln;
except
on E:Exception do
begin
Writeln(E.Classname, ': ', E.Message);
Readln;
end;
end;
end.
Please see this article on CodeProject, it may be in C#, but it does give you the right clues and the direction to take, involving ReadConsoleInput and WriteConsole API
Related
Trying the convert an Integer to a Packed Record of 32 booleans.
TUserRightsRecord = packed record
r1:boolean;
.
.
end;
yet, I am unable to find a function which convert a variable to a packed record, since the direct assignment does not work.
What function convert a variable ( or at least Integer ) to a Packed Record of the same bite size ?
Trying the convert an Integer to a Packed Record of 32 booleans.
Please note that SizeOf(Integer) = 4 while SizeOf(<packed record of 32 booleans>) = 32 because SizeOf(Boolean) = 1 (1 byte = 8 bits). You seem to be under the impression that a Boolean is a single bit; it isn't.
If that had been the case, however, you could simply have cast the integer to such a record.
(But of course it is trivially possible to write a function that "converts" an integer to a record of 32 booleans.)
The standard approach to use the bits in an integer is to use bitwise operators:
const
HasScreen = 1;
HasSound = 2;
HasKeyboard = 4;
HasMouse = 8;
HasInternet = 16;
var
ComputerProperties: Integer;
begin
// Test a bit
if ComputerProperties and HasInternet = 0 then
ShowMessage('You need an Internet connection.');
// Set a bit
Computer := Computer or HasInternet;
// Clear a bit
Computer := Computer and not HasInternet;
In Delphi, it is more idiomatic to use sets:
type
TComputerFeature = (cfScreen, cfSound, cfKeyboard, cfMouse, cfInternet);
TComputerFeatures = set of TComputerFeature;
var
Features: TComputerFeatures;
begin
Features := [cfScreen, cfKeyboard];
if not (cfInternet in Features) then
ShowMessage('You need an Internet connection.');
Include(Features, cfInternet);
Exclude(Features, cfInternet);
end;
You may, however, easily simulate your original design approach using advanced records:
type
TBit32 = type Integer;
TBit32Helper = record helper for TBit32
strict private
function GetBit(Index: Integer): Boolean;
procedure SetBit(Index: Integer; const Value: Boolean);
public
property Bit[Index: Integer]: Boolean read GetBit write SetBit;
end;
function TBit32Helper.GetBit(Index: Integer): Boolean;
begin
Result := (Self shr Index) and 1 <> 0;
end;
procedure TBit32Helper.SetBit(Index: Integer; const Value: Boolean);
begin
if Value then
Self := Self or (1 shl Index)
else
Self := Self and not (1 shl Index);
end;
begin
var x: Integer := 123;
Writeln(TBit32(x).Bit[4]); // read
TBit32(x).Bit[6] := False; // write
It might be enough to replace boolean with longbool
program Project1;
{$APPTYPE CONSOLE}
{$R *.res}
uses
System.SysUtils;
var
i: integer;
begin
try
i := Sizeof(boolean);
writeln('Sizeof(boolean): ', i);
i := Sizeof(LongBool);
writeln('Sizeof(LongBool): ', i);
readln(i);
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
end.
Otherwise you may have to define your own data type as a record. Here you have to pay attention to the memory size of your data type "SizeOf". Here an excample:
program Project1;
{$APPTYPE CONSOLE}
{$R *.res}
uses
System.SysUtils;
type
TConvert=packed record
public
function ToString: string;
public
//Redefined memory. Each field has the same start address.
case integer of
0: (b: boolean);
1: (G: LongBool);
2: (i: integer);
3: (data: array[0..3]of byte);
end;
function TConvert.ToString: string;
begin
//Low is left !!!
Result := Format('[%.2x|%.2x|%.2x|%.2x]', [data[0], data[1], data[2], data[3]]);
end;
var
i: integer;
r: TConvert;
begin
try
i := Sizeof(TConvert);
writeln('Sizeof(TConvert): ', i);
r.b := True;
writeln('boolean(true): ', r.ToString, ' ',BoolToStr(r.G, true));
r.G := false;
writeln('LongBool(false): ', r.ToString, ' ',BoolToStr(r.G, true));
r.G := True;
writeln('LongBool(true): ', r.ToString, ' ',BoolToStr(r.G, true));
r.i := 1;
writeln('LongBool(i=1): ', r.ToString, ' ',BoolToStr(r.G, true));
readln(i);
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
end.
I'm reading this article that explain how to set a TLS callback in Delphi. The article author says the example works on "Delphi: 2007, 2010, XE4, XE10". But I have tested on Delphi 10 Seattle, Berlin, and Rio, and it does not work (the TLS callback is not executed), but when i test it on Delphi XE5, it works fine.
I also noted that the size of the .map file when compiling the test_app project in Delphi XE5 and Delphi 10 are different. The .map file in Delphi 10 is 5x bigger than the .map file in Delphi XE5 (something around 25KB and 125KB, respectively).
What detail am I missing here?
Following is the code with a reasonable translation to English of the add_tls project and the test_app project.
PS: The test_app project needs to be set to generate a .map file. Project > Options > Linking > Map file => Detailed.
add_tls:
program add_tls;
{$APPTYPE CONSOLE}
{$R *.res}
uses
Windows,
Classes,
SysUtils,
Generics.Collections;
procedure ShowHelp;
begin
Writeln('Usage: AddTls.exe "executable path"');
Writeln('Return Codes:');
Writeln(' - 0: TLS Callback successfully added');
Writeln(' - 1: the path to the executable file is not specified');
Writeln(' - 2: executable not found');
Writeln(' - 3: MAP file not found matching the specified file');
Writeln(' - 4: MAP file parsing error');
Writeln(' - 5: error accessing executable file');
Writeln(' - 6: there is no initialized TLS section in the executable file');
end;
type
TSectionData = record
Index: Integer;
StartAddr: DWORD;
SectionName: ShortString;
end;
TSectionDataList = TList<TSectionData>;
const
HardcodeTLS32Offset = 12;
//
// This is an easy way to search for TLS BUT tables - only in projects,
// collected in XE and above
// If the executable is built by another compiler, it will not work naturally
// but the article is not about that :)
// so:
// =============================================================================
function GetTlsTableAddr(const FilePath: string): DWORD;
var
F: TFileStream;
DOS: TImageDosHeader;
NT: TImageNtHeaders;
I: Integer;
Section: TImageSectionHeader;
begin
Result := 0;
// open the file for reading
F := TFileStream.Create(FilePath, fmOpenRead or fmShareDenyWrite);
try
// read DOS header to go to NT
F.ReadBuffer(DOS, SizeOf(TImageDosHeader));
F.Position := DOS._lfanew;
// We read the NT header to get the number of sections
F.ReadBuffer(NT, SizeOf(TImageNtHeaders));
// read sections and look for TLS
for I := 0 to NT.FileHeader.NumberOfSections - 1 do
begin
F.ReadBuffer(Section, SizeOf(TImageSectionHeader));
if PAnsiChar(#Section.Name[0]) = '.tls' then
begin
// found IMAGE_TLS_DIRECTORY, we immediately correct the AddressOfCallback field
Result := Section.PointerToRawData + HardcodeTLS32Offset;
Break;
end;
end;
finally
F.Free;
end;
end;
// just parse the map file and look for the addresses of the sections
function GetSectionDataList(const FilePath: string; var Index: Integer): TSectionDataList;
var
S: TStringList;
Line: string;
Section: TSectionData;
begin
Result := TSectionDataList.Create;
try
S := TStringList.Create;
try
S.LoadFromFile(FilePath);
Index := 0;
Writeln('I am looking for a table of sections...');
while Copy(Trim(S[Index]), 1, 5) <> 'Start' do
Inc(Index);
Inc(Index);
while Trim(S[Index]) <> '' do
begin
Line := Trim(S[Index]);
Section.Index := StrToInt(Copy(Line, 1, 4));
Delete(Line, 1, 5);
Section.StartAddr := StrToInt('$' + Copy(Line, 1, 8));
Delete(Line, 1, 19);
Section.SectionName := ShortString(Trim(Copy(Line, 1, 8)));
Result.Add(Section);
Inc(Index);
end;
Writeln('Total sections found: ', Result.Count);
finally
S.Free;
end;
except
// we suppress all exceptions. there are error codes
on E: Exception do
Writeln('GetSectionDataList: ' + E.ClassName + ': ' + E.Message);
end;
end;
// again, parse the mapfile and look for the address of the function called tls_callback
// which (if found) we summarize with the address of the section in which it is located
function GetTlsCallbackAddr(const FilePath: string;
SectionDataList: TSectionDataList; Index: Integer): DWORD;
var
S: TStringList;
Line: string;
SectionIndex, TlsAddr: Integer;
begin
Result := 0;
try
S := TStringList.Create;
try
S.LoadFromFile(FilePath);
Writeln('Looking for tls_callback...');
repeat
Line := Trim(S[Index]);
Inc(Index);
if Index = S.Count then Break;
until Pos('.tls_callback', Line) <> 0;
if Pos('.tls_callback', Line) = 0 then
begin
Writeln('No tls_callback entry found in MAP file');
Exit;
end;
SectionIndex := StrToInt(Copy(Line, 1, 4));
Delete(Line, 1, 5);
TlsAddr := StrToInt('$' + Copy(Line, 1, 8));
Writeln('tls_callback found, offset: ', IntToHex(TlsAddr, 8), ', section: ', SectionIndex);
Writeln('Looking for a record about the section...');
for Index := 0 to SectionDataList.Count - 1 do
if SectionDataList[Index].Index = SectionIndex then
begin
Result := SectionDataList[Index].StartAddr + DWORD(TlsAddr);
Writeln('TLS Callback, found in section "', SectionDataList[Index].SectionName,
'", offset sections: ', IntToHex(SectionDataList[Index].StartAddr, 8),
', calculated addressc: ', IntToHex(Result, 8));
Break;
end;
if Result = 0 then
Writeln('Section containing tls_callback not found')
finally
S.Free;
end;
except
// we suppress all exceptions. there are error codes
on E: Exception do
Writeln('GetTlsCallbackAddr: ' + E.ClassName + ': ' + E.Message);
end;
end;
// directly patch file
function Patch(const FilePath, MapPath: string; TlsTable, CallbackAddr: DWORD): Boolean;
var
F: TFileStream;
NewFilePath, BackUpFilePath: string;
OldCallbackTableAddr: DWORD;
begin
Result := False;
try
NewFilePath := ExtractFilePath(FilePath) + 'tls_aded_' +
ExtractFileName(FilePath);
Writeln('I create a copy of the file, the path: ', NewFilePath);
CopyFile(PChar(FilePath), PChar(NewFilePath), False);
F := TFileStream.Create(NewFilePath, fmOpenReadWrite);
try
Writeln('File open');
F.Position := TlsTable;
// read the address where the previous callback referred
F.ReadBuffer(OldCallbackTableAddr, 4);
// in a delphi image, it refers to the SizeOfZeroFill structure of IMAGE_TLS_DIRECTORY
// in which both last fields are filled with zeros (supposedly there is no callback chain)
// Therefore, we will not spoil the working structure and make it refer to the address
// immediately outside of this structure (plus 2 yards in 32 bit, in 64 bit)
Inc(OldCallbackTableAddr, SizeOf(DWORD) * 2);
F.Position := TlsTable;
// write a new address to the old place
F.WriteBuffer(OldCallbackTableAddr, 4);
Writeln('Assigned a new address to the chain of processors, offset: ', IntToHex(TlsTable, 8),
', new value: ', IntToHex(OldCallbackTableAddr, 8));
// now we jump to the place where the VA address of the handler (not RVA) should be written
// skip SizeOfZeroFill and Characteristics and get right behind them
F.Position := TlsTable + SizeOf(DWORD) * 3;
// and now write the address of our callback
F.WriteBuffer(CallbackAddr, 4);
Writeln('Callback address set, offset: ', IntToHex(TlsTable + SizeOf(DWORD) * 3, 8));
// after which we write zero to indicate the end of the callback chain
CallbackAddr := 0;
F.WriteBuffer(CallbackAddr, 4);
finally
F.Free;
end;
// if everything is fine, then rename back
Writeln('I create a backup');
BackUpFilePath := FilePath + '.bak';
DeleteFile(BackUpFilePath);
RenameFile(FilePath, BackUpFilePath);
Writeln('I keep the result');
RenameFile(NewFilePath, FilePath);
Writeln('All tasks completed');
Result := True;
except
// we suppress all exceptions. there are error codes
on E: Exception do
begin
// in the event of an error, we clean ourselves up - returning everything back
DeleteFile(NewFilePath);
RenameFile(BackUpFilePath, FilePath);
Writeln('Patch: ' + E.ClassName + ': ' + E.Message);
end;
end;
end;
var
MapPath: string;
TlsTable, CallbackAddr: DWORD;
SectionDataList: TSectionDataList;
Index: Integer;
begin
ExitCode := 0;
if ParamCount = 0 then
begin
ShowHelp;
ExitCode := 1;
ExitProcess(ExitCode);
end;
if not FileExists(ParamStr(1)) then
begin
Writeln('No executable found: ', ParamStr(1));
ExitCode := 2;
ExitProcess(ExitCode);
end;
TlsTable := GetTlsTableAddr(ParamStr(1));
if TlsTable = 0 then
begin
ExitCode := 6;
ExitProcess(ExitCode);
end;
MapPath := ChangeFileExt(ParamStr(1), '.map');
if not FileExists(MapPath) then
begin
Writeln('MAP file not found: ', MapPath);
ExitCode := 3;
ExitProcess(ExitCode);
end;
Index := 0;
SectionDataList := GetSectionDataList(MapPath, Index);
try
if SectionDataList.Count = 0 then
begin
Writeln('Could not build partition table');
ExitCode := 9;
ExitProcess(ExitCode);
end;
CallbackAddr := GetTlsCallbackAddr(MapPath, SectionDataList, Index);
if CallbackAddr = 0 then
begin
ExitCode := 4;
ExitProcess(ExitCode);
end;
if not Patch(ParamStr(1), MapPath, TlsTable, CallbackAddr) then
ExitCode := 5;
finally
SectionDataList.Free;
end;
ExitProcess(ExitCode);
end.
test_app:
program test_app;
{$APPTYPE CONSOLE}
{$R *.res}
uses
Windows;
// this callback will be called if the file is correctly patched
procedure tls_callback(hModule: HMODULE;
ul_reason_for_call: DWORD; lpReserved: Pointer); stdcall;
begin
if ul_reason_for_call = DLL_PROCESS_ATTACH then
MessageBox(0, 'TLS Callback Message', nil, 0);
end;
const
ptls_callback: Pointer = #tls_callback;
begin
// so that the tls_callback procedure appears in the MAP file
// you need a link to it, it’s corny like this:
if ptls_callback <> nil then
MessageBox(0, 'Entry Point Message', nil, 0);
end.
If your aim is to have some code execute as soon as possible, here is something which works on any Delphi revision, and on any platform (not only Windows).
Create a small unit with no dependency (no uses clause at all).
unit FirstLoaded;
interface
// NO "uses" clause!
implementation
procedure SomeThingToDoEarly;
begin
end;
initialization
SomeThingToDoEarly;
end.
Then put it as first unit in the uses clause of your project .dpr - before anything else.
program Project1;
uses
FirstLoaded, // before anything!
Forms,
Unit1 in 'Unit1.pas' {Form1};
{$R *.res}
begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
The code in the initialization part of your unit will be called just after system.pas.
Be aware that if you add something in your uses clause of your unit, those units (and their dependencies) would be initialized first.
I saw Stack Overflow question How to switch a process between default desktop and Winlogon desktop?.
And I have produced a minimal test-case creating a console project application, but SetThreadDesktop() does not switch my program to the target desktop.
Why does this happen?
program Project1;
{$APPTYPE CONSOLE}
{$R *.res}
uses
Winapi.Windows,
System.SysUtils,
Vcl.Graphics,
function RandomPassword(PLen: Integer): string;
var
str: string;
begin
Randomize;
str := 'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ';
Result := '';
repeat
Result := Result + str[Random(Length(str)) + 1];
until (Length(Result) = PLen)
end;
procedure Print;
var
DCDesk: HDC;
bmp: TBitmap;
hmod, hmod2 : HMODULE;
BitBltAPI: function(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc, YSrc: Integer; Rop: DWORD): BOOL; stdcall;
GetWindowDCAPI: function(hWnd: HWND): HDC; stdcall;
begin
hmod := GetModuleHandle('Gdi32.dll');
hmod2:= GetModuleHandle('User32.dll');
if (hmod <> 0) and (hmod2 <> 0) then begin
bmp := TBitmap.Create;
bmp.Height := Screen.Height;
bmp.Width := Screen.Width;
GetWindowDCAPI := GetProcAddress(hmod2, 'GetWindowDC');
if (#GetWindowDCAPI <> nil) then begin
DCDesk := GetWindowDCAPI(GetDesktopWindow);
end;
BitBltAPI := GetProcAddress(hmod, 'BitBlt');
if (#BitBltAPI <> nil) then begin
BitBltAPI(bmp.Canvas.Handle, 0, 0, Screen.Width, Screen.Height, DCDesk, 0, 0, SRCCOPY);
bmp.SaveToFile('ScreenShot_------_' + RandomPassword(8) + '.bmp');
end;
ReleaseDC(GetDesktopWindow, DCDesk);
bmp.Free;
FreeLibrary(hmod);
FreeLibrary(hmod2);
end;
end;
//===============================================================================================================================
var
hWinsta, hdesktop:thandle;
begin
try
while True do
begin
hWinsta := OpenWindowStation('WinSta0', TRUE, GENERIC_ALL);
If hwinsta <> INVALID_HANDLE_VALUE then
begin
SetProcessWindowStation (hWinsta);
hdesktop := OpenDesktop ('default_set', 0, TRUE, GENERIC_ALL);
if (hdesktop <> INVALID_HANDLE_VALUE) then
if SetThreadDesktop (hdesktop) then
begin
Print; // Captures screen of target desktop.
CloseWindowStation (hwinsta);
CloseDesktop (hdesktop);
end;
end;
Sleep(5000);
end;
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
end.
Checking errors, the SetThreadDesktop() call fails with error code 170 (ERROR_BUSY, The requested resource is in use) when the target desktop is open.
var
threahdesk: boolean;
...
threahdesk := SetThreadDesktop (hdesktop);
ShowMessage(IntToStr(GetLastError));
if threahdesk Then
begin
Print;
CloseWindowStation (hwinsta);
CloseDesktop (hdesktop);
end;
After that I saw several suggestion in some forums, my actual code is as follows:
var
hWinsta, hdesktop:thandle;
threahdesk, setprocwst: Boolean;
////////////////////////////////////////////////////////////////////////////////
begin
try
while True do
begin
Application.Free;
hWinsta:= OpenWindowStation('WinSta0', TRUE, GENERIC_ALL);
If hwinsta <> 0 Then
Begin
setprocwst := SetProcessWindowStation(hWinsta);
if setprocwst then
hdesktop:= OpenDesktop('default_set', 0, TRUE, GENERIC_ALL);
If (hdesktop <> 0) Then
threahdesk := SetThreadDesktop(hdesktop);
Application := TApplication.Create(nil);
Application.Initialize;
Application.Run;
If threahdesk Then
Begin
Print;
CloseWindowStation (hwinsta);
CloseDesktop (hdesktop);
End;
End;
Sleep(5000);
end;
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
end.
The answer by Dmitriy is accurate in that the function fails because the calling thread has windows or hooks, although it doesn't explain how so.
The reason SetThreadDesktop is failing with ERROR_BUSY is, you have "forms.pas" in your uses list. Although it's missing in the code you posted (semicolon in "uses" clause is also missing hinting more units), the use of the Screen global variable makes it evident that you have "forms" in uses. "Forms" pulls in "controls.pas" which initializes the Application object. In its constructor, the Application creates a utility window for its PopupControlWnd. There may be other windows created but this one is enough reason for the function to fail.
You use Screen for its width/height. Un-use "forms", you can use API to retrieve that information.
There are other issues in the code like missing/wrong error checking which have been mentioned in the comments to the question, but they are not relevant to why SetThreadDesktop fails.
Below sample program demonstrates there's no problem calling SetThreadDesktop in the main thread of a console application, provided there's a desktop with name 'default_set' in the window station in which the program is running and has access rights to.
program Project1;
{$APPTYPE CONSOLE}
{$R *.res}
uses
System.SysUtils,
// Vcl.Forms, // uncomment to get an ERROR_BUSY
Winapi.Windows;
var
hSaveDesktop, hDesktop: HDESK;
begin
hSaveDesktop := GetThreadDesktop(GetCurrentThreadId);
Win32Check(hSaveDesktop <> 0);
hDesktop := OpenDesktop('default_set', 0, True, GENERIC_ALL);
Win32Check(hDesktop <> 0);
try
Win32Check(SetThreadDesktop(hDesktop));
try
// --
finally
Win32Check(SetThreadDesktop(hSaveDesktop));
end;
finally
Win32Check(CloseDesktop(hDesktop));
end;
end.
From the SetThreadDesktop() documentation:
The SetThreadDesktop function will fail if the calling thread has any windows or hooks on its current desktop (unless the hDesktop parameter is a handle to the current desktop).
I am in the process of coding a console application that will create a firewall exception for my main app called Client.exe which uploads a few documents to our servers via FTP. I borrowed RRUZ code from Delphi 7 Windows Vista/7 Firewall Exception Network Locations my code looks like this:
program ChangeFW;
{$APPTYPE CONSOLE}
{$R *.res}
uses
System.SysUtils,
ComObj;
var
ExecName: string;
procedure AddExceptionToFirewall(Const Caption, Executable: String);
const
NET_FW_PROFILE2_DOMAIN = 1;
NET_FW_PROFILE2_PRIVATE = 2;
NET_FW_PROFILE2_PUBLIC = 4;
NET_FW_IP_PROTOCOL_TCP = 6;
NET_FW_ACTION_ALLOW = 1;
var
fwPolicy2 : OleVariant;
RulesObject : OleVariant;
Profile : Integer;
NewRule : OleVariant;
begin
Profile := NET_FW_PROFILE2_PRIVATE OR NET_FW_PROFILE2_PUBLIC;
fwPolicy2 := CreateOleObject('HNetCfg.FwPolicy2');
RulesObject := fwPolicy2.Rules;
NewRule := CreateOleObject('HNetCfg.FWRule');
NewRule.Name := Caption;
NewRule.Description := Caption;
NewRule.Applicationname := Executable;
NewRule.Protocol := NET_FW_IP_PROTOCOL_TCP;
NewRule.Enabled := TRUE;
NewRule.Profiles := Profile;
NewRule.Action := NET_FW_ACTION_ALLOW;
RulesObject.Add(NewRule);
end;
begin
try
{ TODO -oUser -cConsole Main : Insert code here }
ExecName := GetCurrentDir + '\' + 'Client.exe';
AddExceptionToFirewall('SIP Inventory',ExecName);
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
end.
When I execute the application I get the following error message:
EOIeSysError: Coinitialize has not been called, ProgID: “HNetCfg.FwPolicy2”
Any idea what I am doing wrong? Could you please point me in the right direction? Thank you so very much.
If you want to use COM - objects you will have to call CoInitialize with corresponding CoUninitialize.
In a usual application this will be already done.
As far as your program is a console program you will have to call it on your own.
.....
CoInitialize(nil);
try
try
{ TODO -oUser -cConsole Main : Insert code here }
ExecName := GetCurrentDir + '\' + 'Client.exe';
AddExceptionToFirewall('SIP Inventory',ExecName);
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
finally
CoUninitialize;
end;
.....
Background
I've been using Win32_DiskDrive to find flash memory (usb pens, SD cards, etc.), but after some tests on other computers I noticed that they weren't always discovered. So I am using Win32_LogicalDisk and since it has DriveType I don't have to associate with two classes (e.g. partition) to find first the drives then their drive letters.
The problem is that external harddrives are detected as DriveType 3 (Local Disk) in LogicalDisk and doesn't have 7 (Supports Removable Media) in Capabilities in DiskDrive. So I can't tell the difference between an internal and external drive.
Question
How do I tell the difference between an internal and an external harddrive using LogicalDisk (or DiskDrive if you really have to) or something third.
Alright. The question has been answered!
Here's the code, if anyone is interested.
program GetWMI_USBConnectedInfo;
{$APPTYPE CONSOLE}
uses
Windows,
Classes,
ActiveX,
Variants,
SysUtils,
WbemScripting_TLB, // Using the .pas supplied by the wrapper as it seems to be the XP version of 1.2
magwmi,
magsubs1;
function CheckType(Str: string): boolean;
var
I: Integer;
Str2: string;
begin
Result := False;
for I := 1 to Length(Str) - 1 do if Str[I] = '\' then begin
Str2 := Copy(Str, 1, I-1);
Str2 := LowerCase(Str2);
if (Str2 = 'usbstor') or (Str2 = 'flashmedia') then
Result := True;
Break;
end;
end;
procedure GetUSBDiskDriveInfo;
var
I, II, III: Integer;
Start, Stop, Freq: Int64;
instances, instances2, instances3: integer ;
WmiResults, WmiResults2, WmiResults3: T2DimStrArray ;
errstr: string ;
begin
QueryPerformanceFrequency(Freq);
QueryPerformanceCounter(Start);
try
MagWmiGetInfoEx('.', 'root\CIMV2', '', '', 'SELECT * FROM Win32_DiskDrive', WmiResults, instances, errstr);
for I := 1 to instances do begin
MagWmiGetInfoEx('.', 'root\CIMV2', '', '', 'ASSOCIATORS OF {Win32_DiskDrive.DeviceID=''' + WmiResults[I, 12] + '''} WHERE AssocClass = Win32_DiskDriveToDiskPartition', WmiResults2, instances2, errstr);
for II := 1 to instances2 do begin
MagWmiGetInfoEx('.', 'root\CIMV2', '', '', 'ASSOCIATORS OF {Win32_DiskPartition.DeviceID=''' + WmiResults2[II, 11] + '''} WHERE AssocClass = Win32_LogicalDiskToPartition', WmiResults3, instances3, errstr);
for III := 1 to instances3 do begin
if CheckType(WmiResults[I, 32]) or (Pos('7', WmiResults[I, 3])>0) then begin
Write(WmiResults3[III, 4]);
Write(WmiResults3[III, 39]);
Writeln;
end;
end;
WmiResults3 := nil;
end;
WmiResults2 := nil;
end;
WmiResults := nil;
except
Writeln;
Writeln('error: '+errstr);
end;
Writeln;
QueryPerformanceCounter(Stop);
if (Freq > 0) then
Writeln('It took ' + FormatFloat('0.#0', (Stop-Start) / Freq) + ' seconds to complete.');
end;
begin
try
CoInitialize(nil);
GetUSBDiskDriveInfo;
Readln;
CoUninitialize;
except
on E:Exception do begin
CoUninitialize;
Writeln(E.Classname, ': ', E.Message);
Readln;
end;
end;
end.
One more thing!
Call this a dirty hack or whatever, but I commented out this part of MagWmiGetInfoEx (line 298 in magwmi) in order to make it work:
// if Pos ('SELECT', Arg) = 1 then
wmiObjectSet := wmiServices.ExecQuery (Arg, 'WQL', wbemFlagReturnImmediately, nil)
// else
// wmiObjectSet := wmiServices.InstancesOf (Arg, wbemFlagReturnImmediately or
// wbemQueryFlagShallow, nil)
;
I would suggest sticking with WMI. There is a good delphi wrapper available which includes full source to get you started.
A query to get you started is "SELECT * FROM WIN32_DiskDrive" which would return all of the information for all of the disk drives in your system. the PNPDeviceID field should start with USBSTOR for any USB drives. A good resource for what fields come back is the MSDN website. Just translate the objects into queries.
If your going to be calling this from a thread, you may need to add initialize COM (ComInitialize) before making any calls. Before destroying your thread, call ComUnitialialize.
You can test this package; GLibWMI Components Library in SourceForge. It's a wrapper for work with WMI. Include components like CDiskDriveInfo, CDiskPartitionInfo, CUSBControllerInfo,... that can help you.
Additionally all the code is included. You can evaluate it.
Regards.