I have been looking for ages now for some code that can translate any language to another but none of the code I find works.
I know Google has a good translate API but I can't get anyone's Delphi code on it to work.
There is always an error that comes in the way.
Any help would be much appreciated, I need a program that can translate ASAP of my final school project.
The Google Translate API is a good option, but now is available only as a paid service. Instead you can try the Microsoft Translator V2 API, check this article Using the Microsoft Translator V2 API from delphi for more details about how use this API from delphi.
UPDATE
This is the same demo project of the article modified to be compatible with your version of delphi.
program MicrosoftTranslatorApi;
{$APPTYPE CONSOLE}
uses
ShellApi,
ActiveX,
Classes,
ComObj,
Variants,
Windows,
WinInet,
SysUtils;
const
MicrosoftTranslatorTranslateUri = 'http://api.microsofttranslator.com/v2/Http.svc/Translate?appId=%s&text=%s&from=%s&to=%s';
MicrosoftTranslatorDetectUri = 'http://api.microsofttranslator.com/v2/Http.svc/Detect?appId=%s&text=%s';
MicrosoftTranslatorGetLngUri = 'http://api.microsofttranslator.com/v2/Http.svc/GetLanguagesForTranslate?appId=%s';
MicrosoftTranslatorGetSpkUri = 'http://api.microsofttranslator.com/v2/Http.svc/GetLanguagesForSpeak?appId=%s';
MicrosoftTranslatorSpeakUri = 'http://api.microsofttranslator.com/v2/Http.svc/Speak?appId=%s&text=%s&language=%s';
//this AppId if for demo only please be nice and use your own , it's easy get one from here http://msdn.microsoft.com/en-us/library/ff512386.aspx
BingAppId = '73C8F474CA4D1202AD60747126813B731199ECEA';
Msxml2_DOMDocument = 'Msxml2.DOMDocument.6.0';
procedure WinInet_HttpGet(const Url: string;Stream:TStream);overload;
const
BuffSize = 1024*1024;
var
hInter : HINTERNET;
UrlHandle: HINTERNET;
BytesRead: DWORD;
Buffer : Pointer;
begin
hInter := InternetOpen('', INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
if Assigned(hInter) then
try
Stream.Seek(0,0);
GetMem(Buffer,BuffSize);
try
UrlHandle := InternetOpenUrl(hInter, PChar(Url), nil, 0, INTERNET_FLAG_RELOAD, 0);
if Assigned(UrlHandle) then
begin
repeat
InternetReadFile(UrlHandle, Buffer, BuffSize, BytesRead);
if BytesRead>0 then
Stream.WriteBuffer(Buffer^,BytesRead);
until BytesRead = 0;
InternetCloseHandle(UrlHandle);
end;
finally
FreeMem(Buffer);
end;
finally
InternetCloseHandle(hInter);
end;
end;
function WinInet_HttpGet(const Url: string): string;overload;
Var
StringStream : TStringStream;
begin
Result:='';
StringStream:=TStringStream.Create('');
try
WinInet_HttpGet(Url,StringStream);
if StringStream.Size>0 then
begin
StringStream.Seek(0,0);
Result:=StringStream.ReadString(StringStream.Size);
end;
finally
StringStream.Free;
end;
end;
function TranslateText(const AText,SourceLng,DestLng:string):string;
var
XmlDoc : OleVariant;
Node : OleVariant;
begin
Result:=WinInet_HttpGet(Format(MicrosoftTranslatorTranslateUri,[BingAppId,AText,SourceLng,DestLng]));
XmlDoc:= CreateOleObject(Msxml2_DOMDocument);
try
XmlDoc.Async := False;
XmlDoc.LoadXML(Result);
if (XmlDoc.parseError.errorCode <> 0) then
raise Exception.CreateFmt('Error in Xml Data %s',[XmlDoc.parseError]);
Node:= XmlDoc.documentElement;
if not VarIsClear(Node) then
Result:=XmlDoc.Text;
finally
XmlDoc:=Unassigned;
end;
end;
function DetectLanguage(const AText:string ):string;
var
XmlDoc : OleVariant;
Node : OleVariant;
begin
Result:=WinInet_HttpGet(Format(MicrosoftTranslatorDetectUri,[BingAppId,AText]));
XmlDoc:= CreateOleObject(Msxml2_DOMDocument);
try
XmlDoc.Async := False;
XmlDoc.LoadXML(Result);
if (XmlDoc.parseError.errorCode <> 0) then
raise Exception.CreateFmt('Error in Xml Data %s',[XmlDoc.parseError]);
Node:= XmlDoc.documentElement;
if not VarIsClear(Node) then
Result:=XmlDoc.Text;
finally
XmlDoc:=Unassigned;
end;
end;
function GetLanguagesForTranslate: TStringList;
var
XmlDoc : OleVariant;
Node : OleVariant;
Nodes : OleVariant;
lNodes : Integer;
i : Integer;
sValue : string;
begin
Result:=TStringList.Create;
sValue:=WinInet_HttpGet(Format(MicrosoftTranslatorGetLngUri,[BingAppId]));
XmlDoc:= CreateOleObject(Msxml2_DOMDocument);
try
XmlDoc.Async := False;
XmlDoc.LoadXML(sValue);
if (XmlDoc.parseError.errorCode <> 0) then
raise Exception.CreateFmt('Error in Xml Data %s',[XmlDoc.parseError]);
Node:= XmlDoc.documentElement;
if not VarIsClear(Node) then
begin
Nodes := Node.childNodes;
if not VarIsClear(Nodes) then
begin
lNodes:= Nodes.Length;
for i:=0 to lNodes-1 do
Result.Add(Nodes.Item(i).Text);
end;
end;
finally
XmlDoc:=Unassigned;
end;
end;
function GetLanguagesForSpeak: TStringList;
var
XmlDoc : OleVariant;
Node : OleVariant;
Nodes : OleVariant;
lNodes : Integer;
i : Integer;
sValue : string;
begin
Result:=TStringList.Create;
sValue:=WinInet_HttpGet(Format(MicrosoftTranslatorGetSpkUri,[BingAppId]));
XmlDoc:= CreateOleObject(Msxml2_DOMDocument);
try
XmlDoc.Async := False;
XmlDoc.LoadXML(sValue);
if (XmlDoc.parseError.errorCode <> 0) then
raise Exception.CreateFmt('Error in Xml Data %s',[XmlDoc.parseError]);
Node:= XmlDoc.documentElement;
if not VarIsClear(Node) then
begin
Nodes := Node.childNodes;
if not VarIsClear(Nodes) then
begin
lNodes:= Nodes.Length;
for i:=0 to lNodes-1 do
Result.Add(Nodes.Item(i).Text);
end;
end;
finally
XmlDoc:=Unassigned;
end;
end;
procedure Speak(const FileName,AText,Lng:string);
var
Stream : TFileStream;
begin
Stream:=TFileStream.Create(FileName,fmCreate);
try
WinInet_HttpGet(Format(MicrosoftTranslatorSpeakUri,[BingAppId,AText,Lng]),Stream);
finally
Stream.Free;
end;
end;
var
lng : TStringList;
i : Integer;
FileName : string;
begin
try
CoInitialize(nil);
try
Writeln(TranslateText('Hello World','en','es'));
Writeln(DetectLanguage('Hello World'));
Writeln('Languages for translate supported');
lng:=GetLanguagesForTranslate;
try
for i:=0 to lng.Count-1 do
Writeln(lng[i]);
finally
lng.free;
end;
Writeln('Languages for speak supported');
lng:=GetLanguagesForSpeak;
try
for i:=0 to lng.Count-1 do
Writeln(lng[i]);
finally
lng.free;
end;
FileName:=ExtractFilePath(ParamStr(0))+'Demo.wav';
Speak(FileName,'This is a demo using the Microsoft Translator Api from delphi, enjoy','en');
ShellExecute(0, 'open', PChar(FileName),nil,nil, SW_SHOWNORMAL) ;
finally
CoUninitialize;
end;
except
on E:Exception do
Writeln(E.Classname, ':', E.Message);
end;
Writeln('Press Enter to exit');
Readln;
end.
Maybe you did not find Marco Cantu's works?Works with REST/AJAX/Delphi
But as RRUZ said, the Google Translate API is only available now as a paid service.
First of all, you can not find a 100% tool to translate from a language to another. You can have a tool which is doing some(more or less) of the job for you, but you need to 'polish' the rest. As RRUZ said, you can use the Microsoft's translator but what I've said applies also in this case. Any tool of this type will cost you money. Google's translate is quite good, but you need to pay for it.
PS: I don't think that at school they ask you to create a tool which is translating from any language to any language. Maybe a small tool which can prove you got the concept. just my 2 cents...
Related
In Delphi 7 I'm working on a library implementing an object encapsulating information about the batteries attached to a system. It's working well, except for retrieving the serial number for the battery.
The code I am using for this call is as follows:
function TBattery.GetSerialNumber(hbat: THandle): boolean;
var
bqi: TBatteryQueryInformation;
Serial: PWideChar;
SerialSize,
dwOut: DWORD;
begin
Result := False;
if hbat <> INVALID_HANDLE_VALUE then
begin
ZeroMemory(#bqi, SizeOf(bqi));
dwOut := 0;
bqi.BatteryTag := FBatteryTag;
bqi.InformationLevel := BatterySerialNumber;
SerialSize := 2048;
GetMem(Serial, SerialSize);
try
ZeroMemory(Serial, SerialSize);
Result := DeviceIoControl(hbat, IOCTL_BATTERY_QUERY_INFORMATION, #bqi,
SizeOf(bqi), Serial, SerialSize, #dwOut, nil);
if Result then
FSerialNumber := Serial;
finally
FreeMem(Serial, SerialSize);
end;
end;
end;
Unfortunately, DeviceIoControl() always returns False and if I check GetLastError() afterwards then it comes back with error 87, "the parameter is incorrect."
This doesn't make much sense, because the code works perfectly well if I simply change the InformationLevel from BatterySerialNumber to BatteryUniqueID, say. Also, I've used the handle to the battery (hbat) in other calls in the code before GetSerialNumber and they all work fine, and I can call others after this one fails as well, so that's not the issue.
Any ideas? I'm really at a loss.
The issue it seems related to the dwOut variable which is passed as #dwOut, this variable represents the var lpBytesReturned parameter of the DeviceIoControl which is defined as
function DeviceIoControl(hDevice: THandle; dwIoControlCode: DWORD; lpInBuffer: Pointer;
nInBufferSize: DWORD; lpOutBuffer: Pointer; nOutBufferSize: DWORD;
var lpBytesReturned: DWORD; lpOverlapped: POverlapped): BOOL; stdcall;
So replacing your code by
Result := DeviceIoControl(hbat, IOCTL_BATTERY_QUERY_INFORMATION, #bqi,
SizeOf(bqi), Serial, SerialSize, dwOut, nil);
Must fix the problem.
WinAPI
Also check this code translated to delphi from this msdn entry Enumerating Battery Devices which can help you to detect any additional issues with your code.
uses
SetupApi,
Windows,
SysUtils;
type
BATTERY_QUERY_INFORMATION_LEVEL = (
BatteryInformation,
BatteryGranularityInformation,
BatteryTemperature,
BatteryEstimatedTime,
BatteryDeviceName,
BatteryManufactureDate,
BatteryManufactureName,
BatteryUniqueID,
BatterySerialNumber);
TBatteryQueryInformationLevel = BATTERY_QUERY_INFORMATION_LEVEL;
_BATTERY_QUERY_INFORMATION = record
BatteryTag: ULONG;
InformationLevel: BATTERY_QUERY_INFORMATION_LEVEL;
AtRate: Longint;
end;
BATTERY_QUERY_INFORMATION = _BATTERY_QUERY_INFORMATION;
PBATTERY_QUERY_INFORMATION = ^BATTERY_QUERY_INFORMATION;
TBatteryQueryInformation = BATTERY_QUERY_INFORMATION;
const
GUID_DEVCLASS_BATTERY:TGUID='{72631E54-78A4-11D0-BCF7-00AA00B7B32A}';
//DEFINE_GUID( GUID_DEVCLASS_BATTERY, 0x72631E54, 0x78A4, 0x11D0, 0xBC, 0xF7, 0x00, 0xAA, 0x00, 0xB7, 0xB3, 0x2A );
METHOD_BUFFERED = 0;
FILE_DEVICE_BATTERY = $00000029;
FILE_READ_ACCESS = $0001; // for files and pipes
IOCTL_BATTERY_QUERY_TAG =
(FILE_DEVICE_BATTERY shl 16) or (FILE_READ_ACCESS shl 14) or ($10 shl 2) or (METHOD_BUFFERED);
IOCTL_BATTERY_QUERY_INFORMATION =
(FILE_DEVICE_BATTERY shl 16) or (FILE_READ_ACCESS shl 14) or ($11 shl 2) or (METHOD_BUFFERED);
function GetBatteryInfo(InformationLevel : BATTERY_QUERY_INFORMATION_LEVEL) : string;
var
cbRequired : DWORD;
hdev : HDEVINFO;
idev : Integer;
did : TSPDeviceInterfaceData;
pdidd : PSPDeviceInterfaceDetailData;
hBattery : THandle;
bqi : TBatteryQueryInformation;
dwWait, dwOut : DWORD;
lpOutBuffer: PWideChar;
begin
// enumerate the batteries
hdev := SetupDiGetClassDevs(#GUID_DEVCLASS_BATTERY, nil, 0, DIGCF_PRESENT OR DIGCF_DEVICEINTERFACE);
if ( INVALID_HANDLE_VALUE <> THandle(hdev) ) then
begin
idev:=0;//first battery
ZeroMemory(#did, SizeOf(did));
did.cbSize := SizeOf(did);
if (SetupDiEnumDeviceInterfaces(hdev, nil, GUID_DEVCLASS_BATTERY, idev, did)) then
begin
try
cbRequired := 0;
SetupDiGetDeviceInterfaceDetail(hdev, #did, nil, 0, cbRequired, nil);
if (ERROR_INSUFFICIENT_BUFFER= GetLastError()) then
begin
pdidd:=AllocMem(cbRequired);
try
pdidd.cbSize := SizeOf(TSPDeviceInterfaceDetailData);
if (SetupDiGetDeviceInterfaceDetail(hdev, #did, pdidd, cbRequired, cbRequired, nil)) then
begin
hBattery :=CreateFile(pdidd.DevicePath, GENERIC_READ OR GENERIC_WRITE, FILE_SHARE_READ OR FILE_SHARE_WRITE, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
if (INVALID_HANDLE_VALUE <> hBattery) then
begin
try
ZeroMemory(#bqi, SizeOf(bqi));
// With the tag, you can query the battery info.
dwWait := 0;
if (DeviceIoControl(hBattery, IOCTL_BATTERY_QUERY_TAG, #dwWait, sizeof(dwWait), #bqi.BatteryTag, sizeof(bqi.BatteryTag), dwOut, nil)) then
begin
lpOutBuffer:=AllocMem(MAX_PATH);
try
ZeroMemory(lpOutBuffer,MAX_PATH);
bqi.InformationLevel:=InformationLevel;
if DeviceIoControl(hBattery, IOCTL_BATTERY_QUERY_INFORMATION, #bqi, SizeOf(BATTERY_QUERY_INFORMATION), lpOutBuffer, 255, dwOut,nil) then
Result:= WideCharToString(lpOutBuffer);
finally
FreeMem(lpOutBuffer);
end;
end;
finally
CloseHandle(hBattery)
end;
end;
end;
finally
FreeMem(pdidd);
end;
end;
finally
SetupDiDestroyDeviceInfoList(hdev);
end;
end;
end;
end;
begin
try
if not LoadsetupAPI then exit;
Writeln(GetBatteryInfo(BatterySerialNumber));
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
readln;
end.
WMI
Finally as aside note, you can use the WMI to retrieve the same info, in this case using the BatteryStaticData WMI class
{$APPTYPE CONSOLE}
uses
SysUtils,
ActiveX,
ComObj,
Variants;
// Battery Static Data
procedure GetBatteryStaticDataInfo;
const
WbemUser ='';
WbemPassword ='';
WbemComputer ='localhost';
wbemFlagForwardOnly = $00000020;
var
FSWbemLocator : OLEVariant;
FWMIService : OLEVariant;
FWbemObjectSet: OLEVariant;
FWbemObject : OLEVariant;
oEnum : IEnumvariant;
iValue : LongWord;
begin;
FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
FWMIService := FSWbemLocator.ConnectServer(WbemComputer, 'root\WMI', WbemUser, WbemPassword);
FWbemObjectSet:= FWMIService.ExecQuery('SELECT SerialNumber FROM BatteryStaticData','WQL',wbemFlagForwardOnly);
oEnum := IUnknown(FWbemObjectSet._NewEnum) as IEnumVariant;
while oEnum.Next(1, FWbemObject, iValue) = 0 do
begin
Writeln(Format('SerialNumber %s',[String(FWbemObject.SerialNumber)]));// String
Writeln('');
FWbemObject:=Unassigned;
end;
end;
begin
try
CoInitialize(nil);
try
GetBatteryStaticDataInfo;
finally
CoUninitialize;
end;
except
on E:EOleException do
Writeln(Format('EOleException %s %x', [E.Message,E.ErrorCode]));
on E:Exception do
Writeln(E.Classname, ':', E.Message);
end;
Writeln('Press Enter to exit');
Readln;
end.
In summary, the code #RRUZ and I posted work fine under Windows 7, as well as other third-party applications. They do not work for retrieving the serial number under Windows XP. I've also tested under WinXP and 7 with base installs of the OS on the exact same hardware, with identical results (success under Windows 7, not under windows XP).
It appears that under WinXP the value BatterySerialNumber for IOCTL_BATTERY_QUERY_INFORMATION's InformationLevel member is not supported, but this is not documented directly in the Windows SDK docs. It is documented that invalid entries should return error 1 (ERROR_INVALID_FUNCTION) for GetLastError(), but in this case is returning 87 (for an invalid parameter) instead. I posit that this is because that value in the enumeration is not valid, so it makes the parameter invalid, but I'm not exactly sure.
Thanks to all for their help, especially #RRUZ for going way above and beyond!
(As an aside, it appears that one can extract the serial number from the battery's Unique ID (Using BatteryUniqueID as the InformationLevel member) and removing the manufacturer name and device name from the unique ID. That's a terrible hack, but it's a semi-viable workaround for Windows XP.)
This question already has answers here:
Closed 11 years ago.
Possible Duplicate:
How to list all installed ActiveX controls?
I want to get a full list of available activeX controls on user system. Just like what delphi does when you want to import an activeX. (it shows a list)
Regards,
Javid
Here is a c++ version of what you want (almost). You get a list of all classes. It guess that the ActiveX import wizard in Delphi has one row for each library.
How to list all installed ActiveX controls?
In Delphi you can do something like this.
const
CATID_Control: TGUID = '{40FC6ED4-2438-11cf-A3DB-080036F12502}';
procedure GetActiveXControlList(List: TStringList);
var
catInfo: ICatInformation;
enumGuid: IEnumGUID;
ClassID: TGUID;
Fetched: Cardinal;
Name: PWideChar;
begin
OleCheck(CoCreateInstance(CLSID_StdComponentCategoryMgr, nil,
CLSCTX_INPROC_SERVER, ICatInformation, CatInfo));
catInfo.EnumClassesOfCategories(1, #CATID_Control, 0, #GUID_NULL, EnumGUID);
while enumGuid.Next(1, ClassID, Fetched) = S_OK do
begin
OleCheck(OleRegGetUserType(ClassID, USERCLASSTYPE_FULL, Name));
List.Add(Name);
end;
end;
This is pretty much a direct port of the PowerShell solution from Jeff Atwood:
procedure GetActiveXObjects( strings : TStrings );
const
BASE_KEY = '\Software\Classes';
var
reg : TRegistry;
keys : TStrings;
regex : TPerlRegEx;
key : String;
begin
strings.Clear;
keys := nil;
regex := nil;
reg := TRegistry.Create;
try
reg.RootKey := HKEY_LOCAL_MACHINE;
reg.OpenKeyReadOnly( BASE_KEY );
keys := TStringList.Create;
reg.GetKeyNames( keys );
regex := TPerlRegEx.Create;
regex.RegEx := '^\w+\.\w+$';
for key in keys do
begin
regex.Subject := key;
if regex.Match and reg.KeyExists( BASE_KEY + '\' + key + '\CLSID' ) then
strings.Add( key )
end;
finally
reg.Free;
keys.Free;
regex.Free;
end;
end;
This is what I wrote myself. Just add Registry unit and you're finished!
procedure GetActiveXObjects(List: TStringList);
procedure KeyNotFound;
begin
raise exception.create('Key not found.');
end;
const
PATH = 'Software\\Classes\\TypeLib\\';
var
R: TRegistry;
S1, S2: TStringList;
S, Output: String;
begin
List.Clear;
try
S1 := TStringList.Create;
S2 := TStringList.Create;
R := TRegistry.create(KEY_READ);
R.RootKey := HKEY_LOCAL_MACHINE;
if (not R.OpenKey(PATH, False)) then
KeyNotFound;
R.GetKeyNames(S1);
for S in S1 do begin
// Position: CLSID
R.CloseKey;
if (not R.OpenKeyReadOnly(PATH + S + '\\')) then
Continue;
R.GetKeyNames(S2);
// Position:Version
if (S2.Text = '') or (not R.OpenKeyReadOnly(S2.Strings[0])) then
Continue;
Output := R.ReadString('');
if Output <> '' then
List.Add(Output);
end;
finally
R.Free;
S1.Free;
S2.Free;
end;
end;
Has anyone got any hints that will allow me to integrate the Microsoft Help Viewer with a Delphi Application (2009 onwards).
Thanks
You can have a look at Introducing MS Help Viewer 1.0 and Microsoft Help System Documentation
i assume you mean HtmlHelp, since WinHelp is deprecated, and stopped shipping with Windows 5 years ago.
Here's the code i add to my ApplicationEvents object's OnHelp event handler:
function TdmGlobal.ApplicationEvents1Help(Command: Word; Data: Integer;
var CallHelp: Boolean): Boolean;
var
HelpFile: string;
LocalFile: string;
HCommand : word;
begin
CallHelp := False;
Result := False;
//i've named the help file the same as the executable, but with CHM extension
HelpFile := ChangeFileExt(Application.ExeName, '.chm');
if not FileExists(HelpFile) then
Exit;
//Starting in 2003 HtmlHelp will no longer work from a network drive.
//Copy the file to the local machine's temp folder if it's sitting on a network share
if PathIsNetworkPath(HelpFile) then
begin
LocalFile := IncludeTrailingBackslash(GetTemporaryPath)+ExtractFilename(HelpFile);
if (not FileExists(LocalFile)) then
begin
try
CopyFile(PChar(HelpFile), PChar(LocalFile), False);
except
Exit;
end;
end
else
begin
if (GetUncompressedFileSize(HelpFile) <> GetUncompressedFileSize(LocalFile)) then
try
CopyFile(PChar(HelpFile), PChar(LocalFile), False);
except
//Exit; eat it
end;
end;
HelpFile := LocalFile;
end;
{translate WinHelp --> HTMLHelp}
case Command of
HELP_CONTENTS:
begin
HCommand := HH_DISPLAY_TOC;
Data := 0;
end; {HELP_CONTENTS..}
HELP_CONTEXT : HCommand := HH_HELP_CONTEXT;
HELP_CONTEXTPOPUP : HCommand := HH_HELP_CONTEXT;
HELP_FINDER : HCommand := HH_DISPLAY_TOPIC;
HELP_KEY : HCommand := HH_DISPLAY_INDEX;
HELP_QUIT :
begin
HCommand := HH_CLOSE_ALL;
Data := 0;
end; {HELP_QUIT..}
else
begin {default}
HCommand := HH_DISPLAY_TOPIC;
Data := 0;
end; {default..}
end; {case Command..}
hhCtrl.HtmlHelp(GetDesktopWindow(), HelpFile, HCommand, Data);
end;
With hhCtrl.pas containing a number of constants, as well as the function:
function HtmlHelp(
hwndCaller: HWND;
szFile: AnsiString;
uCommand: UINT;
dwData: DWORD): HWND; stdcall; external 'hhctrl.ocx' name 'HtmlHelpA'; {external API call}
How can I get the list of opened files by an application, using Delphi?
For example what files are opened by winword.exe
Using the Native API function NtQuerySystemInformation you can list all open handles from all processes.
try this example
program ListAllHandles;
{$APPTYPE CONSOLE}
uses
PSApi,
Windows,
SysUtils;
const
SystemHandleInformation = $10;
STATUS_SUCCESS = $00000000;
STATUS_BUFFER_OVERFLOW = $80000005;
STATUS_INFO_LENGTH_MISMATCH = $C0000004;
DefaulBUFFERSIZE = $100000;
type
OBJECT_INFORMATION_CLASS = (ObjectBasicInformation,ObjectNameInformation,ObjectTypeInformation,ObjectAllTypesInformation,ObjectHandleInformation );
SYSTEM_HANDLE=packed record
uIdProcess:ULONG;
ObjectType:UCHAR;
Flags :UCHAR;
Handle :Word;
pObject :Pointer;
GrantedAccess:ACCESS_MASK;
end;
PSYSTEM_HANDLE = ^SYSTEM_HANDLE;
SYSTEM_HANDLE_ARRAY = Array[0..0] of SYSTEM_HANDLE;
PSYSTEM_HANDLE_ARRAY= ^SYSTEM_HANDLE_ARRAY;
SYSTEM_HANDLE_INFORMATION=packed record
uCount:ULONG;
Handles:SYSTEM_HANDLE_ARRAY;
end;
PSYSTEM_HANDLE_INFORMATION=^SYSTEM_HANDLE_INFORMATION;
TNtQuerySystemInformation=function (SystemInformationClass:DWORD; SystemInformation:pointer; SystemInformationLength:DWORD; ReturnLength:PDWORD):THandle; stdcall;
TNtQueryObject =function (ObjectHandle:cardinal; ObjectInformationClass:OBJECT_INFORMATION_CLASS; ObjectInformation:pointer; Length:ULONG;ResultLength:PDWORD):THandle;stdcall;
UNICODE_STRING=packed record
Length :Word;
MaximumLength:Word;
Buffer :PWideChar;
end;
OBJECT_NAME_INFORMATION=UNICODE_STRING;
POBJECT_NAME_INFORMATION=^OBJECT_NAME_INFORMATION;
Var
NTQueryObject :TNtQueryObject;
NTQuerySystemInformation:TNTQuerySystemInformation;
function GetObjectInfo(hObject:cardinal; objInfoClass:OBJECT_INFORMATION_CLASS):LPWSTR;
var
pObjectInfo:POBJECT_NAME_INFORMATION;
HDummy :THandle;
dwSize :DWORD;
begin
Result:=nil;
dwSize := sizeof(OBJECT_NAME_INFORMATION);
pObjectInfo := AllocMem(dwSize);
HDummy := NTQueryObject(hObject, objInfoClass, pObjectInfo,dwSize, #dwSize);
if((HDummy = STATUS_BUFFER_OVERFLOW) or (HDummy = STATUS_INFO_LENGTH_MISMATCH)) then
begin
FreeMem(pObjectInfo);
pObjectInfo := AllocMem(dwSize);
HDummy := NTQueryObject(hObject, objInfoClass, pObjectInfo,dwSize, #dwSize);
end;
if((HDummy >= STATUS_SUCCESS) and (pObjectInfo.Buffer <> nil)) then
begin
Result := AllocMem(pObjectInfo.Length + sizeof(WCHAR));
CopyMemory(result, pObjectInfo.Buffer, pObjectInfo.Length);
end;
FreeMem(pObjectInfo);
end;
Procedure EnumerateOpenFiles();
var
sDummy : string;
hProcess : THandle;
hObject : THandle;
ResultLength: DWORD;
aBufferSize : DWORD;
aIndex : Integer;
pHandleInfo : PSYSTEM_HANDLE_INFORMATION;
HDummy : THandle;
lpwsName : PWideChar;
lpwsType : PWideChar;
lpszProcess : PAnsiChar;
begin
AbufferSize := DefaulBUFFERSIZE;
pHandleInfo := AllocMem(AbufferSize);
HDummy := NTQuerySystemInformation(DWORD(SystemHandleInformation), pHandleInfo,AbufferSize, #ResultLength); //Get the list of handles
if(HDummy = STATUS_SUCCESS) then //If no error continue
begin
for aIndex:=0 to pHandleInfo^.uCount-1 do //iterate the list
begin
hProcess := OpenProcess(PROCESS_DUP_HANDLE or PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, FALSE, pHandleInfo.Handles[aIndex].uIdProcess); //open the process to get aditional info
if(hProcess <> INVALID_HANDLE_VALUE) then //Check valid handle
begin
hObject := 0;
if DuplicateHandle(hProcess, pHandleInfo.Handles[aIndex].Handle,GetCurrentProcess(), #hObject, STANDARD_RIGHTS_REQUIRED,FALSE, 0) then //Get a copy of the original handle
begin
lpwsName := GetObjectInfo(hObject, ObjectNameInformation); //Get the filename linked to the handle
if (lpwsName <> nil) then
begin
lpwsType := GetObjectInfo(hObject, ObjectTypeInformation);
lpszProcess := AllocMem(MAX_PATH);
if GetModuleFileNameEx(hProcess, 0,lpszProcess, MAX_PATH)<>0 then //get the name of the process
sDummy:=ExtractFileName(lpszProcess)
else
sDummy:= 'System Process';
Writeln('PID ',pHandleInfo.Handles[aIndex].uIdProcess);
Writeln('Handle ',pHandleInfo.Handles[aIndex].Handle);
Writeln('Process ',sDummy);
Writeln('FileName ',string(lpwsName));
Writeln;
FreeMem(lpwsName);
FreeMem(lpwsType);
FreeMem(lpszProcess);
end;
CloseHandle(hObject);
end;
CloseHandle(hProcess);
end;
end;
end;
FreeMem(pHandleInfo);
end;
begin
try
NTQueryObject := GetProcAddress(GetModuleHandle('NTDLL.DLL'), 'NtQueryObject');
NTQuerySystemInformation := GetProcAddress(GetModuleHandle('NTDLL.DLL'), 'NtQuerySystemInformation');
if (#NTQuerySystemInformation<>nil) and (#NTQuerySystemInformation<>nil) then
EnumerateOpenFiles();
Readln;
except
on E:Exception do
Writeln(E.Classname, ': ', E.Message);
end;
end.
You could port walkobjects.cpp or run a command line process that does it for you and parse it's output.
I've looked at the MSDN page...
it said NtQuerySystemInformation() is an OS internal proc,
and that we're not recommended to use it:
The NtQuerySystemInformation function
and the structures that it returns are
internal to the operating system and
subject to change from one release of
Windows to another. To maintain the
compatibility of your application, it
is better to use the alternate
functions previously mentioned
instead.
In my Delphi (on Windows Xp) program I'd like to check available WiFi networks. Do you have any idea how to do it? Best is probably to use MS WlanScan API function but I did not found an example. Can someone help me?
You can use the Native Wifi API, available since Windows Vista and Windows XP. Older versions of Windows are not supported.
In this link you can find a very nice translation of the headers.
I wrote this code using these headers. Tested in Delphi 2007 and Windows Vista.
program DetectWifiUsingDelphi;
{$APPTYPE CONSOLE}
uses
Windows,
SysUtils,
//TypInfo,
nduWlanAPI in 'nduWlanAPI.pas',
nduWlanTypes in 'nduWlanTypes.pas';
function DOT11_AUTH_ALGORITHM_To_String( Dummy :Tndu_DOT11_AUTH_ALGORITHM):String;
begin
Result:='';
case Dummy of
DOT11_AUTH_ALGO_80211_OPEN : Result:= '80211_OPEN';
DOT11_AUTH_ALGO_80211_SHARED_KEY : Result:= '80211_SHARED_KEY';
DOT11_AUTH_ALGO_WPA : Result:= 'WPA';
DOT11_AUTH_ALGO_WPA_PSK : Result:= 'WPA_PSK';
DOT11_AUTH_ALGO_WPA_NONE : Result:= 'WPA_NONE';
DOT11_AUTH_ALGO_RSNA : Result:= 'RSNA';
DOT11_AUTH_ALGO_RSNA_PSK : Result:= 'RSNA_PSK';
DOT11_AUTH_ALGO_IHV_START : Result:= 'IHV_START';
DOT11_AUTH_ALGO_IHV_END : Result:= 'IHV_END';
end;
End;
function DOT11_CIPHER_ALGORITHM_To_String( Dummy :Tndu_DOT11_CIPHER_ALGORITHM):String;
Begin
Result:='';
case Dummy of
DOT11_CIPHER_ALGO_NONE : Result:= 'NONE';
DOT11_CIPHER_ALGO_WEP40 : Result:= 'WEP40';
DOT11_CIPHER_ALGO_TKIP : Result:= 'TKIP';
DOT11_CIPHER_ALGO_CCMP : Result:= 'CCMP';
DOT11_CIPHER_ALGO_WEP104 : Result:= 'WEP104';
DOT11_CIPHER_ALGO_WPA_USE_GROUP : Result:= 'WPA_USE_GROUP OR RSN_USE_GROUP';
//DOT11_CIPHER_ALGO_RSN_USE_GROUP : Result:= 'RSN_USE_GROUP';
DOT11_CIPHER_ALGO_WEP : Result:= 'WEP';
DOT11_CIPHER_ALGO_IHV_START : Result:= 'IHV_START';
DOT11_CIPHER_ALGO_IHV_END : Result:= 'IHV_END';
end;
End;
procedure Scan();
const
WLAN_AVAILABLE_NETWORK_INCLUDE_ALL_ADHOC_PROFILES =$00000001;
var
hClient : THandle;
dwVersion : DWORD;
ResultInt : DWORD;
pInterface : Pndu_WLAN_INTERFACE_INFO_LIST;
i : Integer;
j : Integer;
pAvailableNetworkList: Pndu_WLAN_AVAILABLE_NETWORK_LIST;
pInterfaceGuid : PGUID;
SDummy : string;
begin
ResultInt:=WlanOpenHandle(1, nil, #dwVersion, #hClient);
if ResultInt<> ERROR_SUCCESS then
begin
WriteLn('Error Open CLient'+IntToStr(ResultInt));
Exit;
end;
ResultInt:=WlanEnumInterfaces(hClient, nil, #pInterface);
if ResultInt<> ERROR_SUCCESS then
begin
WriteLn('Error Enum Interfaces '+IntToStr(ResultInt));
exit;
end;
for i := 0 to pInterface^.dwNumberOfItems - 1 do
begin
Writeln('Interface ' + pInterface^.InterfaceInfo[i].strInterfaceDescription);
WriteLn('GUID ' + GUIDToString(pInterface^.InterfaceInfo[i].InterfaceGuid));
Writeln('');
pInterfaceGuid:= #pInterface^.InterfaceInfo[pInterface^.dwIndex].InterfaceGuid;
ResultInt:=WlanGetAvailableNetworkList(hClient,pInterfaceGuid,WLAN_AVAILABLE_NETWORK_INCLUDE_ALL_ADHOC_PROFILES,nil,pAvailableNetworkList);
if ResultInt<> ERROR_SUCCESS then
begin
WriteLn('Error WlanGetAvailableNetworkList '+IntToStr(ResultInt));
Exit;
end;
for j := 0 to pAvailableNetworkList^.dwNumberOfItems - 1 do
Begin
WriteLn(Format('Profile %s',[WideCharToString(pAvailableNetworkList^.Network[j].strProfileName)]));
SDummy:=PChar(#pAvailableNetworkList^.Network[j].dot11Ssid.ucSSID);
WriteLn(Format('NetworkName %s',[SDummy]));
WriteLn(Format('Signal Quality %d ',[pAvailableNetworkList^.Network[j].wlanSignalQuality])+'%');
//SDummy := GetEnumName(TypeInfo(Tndu_DOT11_AUTH_ALGORITHM),integer(pAvailableNetworkList^.Network[j].dot11DefaultAuthAlgorithm)) ;
SDummy:=DOT11_AUTH_ALGORITHM_To_String(pAvailableNetworkList^.Network[j].dot11DefaultAuthAlgorithm);
WriteLn(Format('Auth Algorithm %s ',[SDummy]));
SDummy:=DOT11_CIPHER_ALGORITHM_To_String(pAvailableNetworkList^.Network[j].dot11DefaultCipherAlgorithm);
WriteLn(Format('Auth Algorithm %s ',[SDummy]));
Writeln('');
End;
end;
WlanCloseHandle(hClient, nil);
end;
begin
try
Scan();
Readln;
except
on E:Exception do
Writeln(E.Classname, ': ', E.Message);
end;
end.
alt text http://i33.tinypic.com/2z83ubt.jpg
Bye.
You can get to this also by performing a WMI query:
SELECT * FROM MSNdis_80211_ServiceSetIdentifier
If you are specifically looking for a delphi implementation, there is a WMI library available from Magenta Systems which includes complete source and may be freely used. The available download includes a compiled executable where you can try this query to see if it contains all of the data that you are looking for. The only disadvantage of this approach is that the WMI service must be running (it normally is so this is not that big of a problem).