With Delphi 10.2, I'm using an application that calls a DLL for sending email. Each Application and DLL use a single FDManager for managing connection and configurations.
At times, the application crashes with the message:
[FireDAC][Comp][Clnt]-500. Application must have only single FDManager
Can anyone please help me to resolve this issue?
Application
procedure TPhoenixWordPrintDialog.StoreEmail;
type
TSendDLL = function(H : Hwnd; Recip :PChar; Subject : PChar; Body : PChar;
Loc : PChar; UserID : PChar; Queid : Integer; AttOrderbyList : array of Integer)
: integer; stdcall;
var
Handle : THandle;
SendMail : TSendDLL;
begin
// FDManager ConnectionDefName is assigned with FDConnectionDefs.ini during form creation.
//Ini file is available in the executable path for managing DB configuration
Handle := LoadLibrary(PChar('D:\Mapi.dll'));
#SendMail := GetProcAddress(Handle, 'ShowDllFormModal');
SendMail(Application.Handle, PChar(RecipText), PChar(SubjectText), PChar(BodyText),
PChar(SentLocation), PChar(SenderName), LQueID, AttachmentOrderByArray);
FreeLibrary(Handle);
end;
DLL
function ShowDllFormModal(H : Hwnd; Recipients : PChar; Subject : PChar;
Body: PChar; Loc : PChar; SenderName : PChar;
Queid : Integer;
AttOrderbyList : array of Integer):integer; stdcall;
begin
Application.handle := H;
// One TFDConnection and TFDQuery using by PhoenixEmailForm
PhoenixEmailForm :=TPhoenixEmailForm.Create(Application);
// FDManager, TFDConnection and TFDQuery using here. On creation of EmailDocumentDM,
// FDManager's ConnectionDefFile is assigned with FDConnectionDefs.ini which is available in
// DLL path
EMailDocumentDM := TEMailDocumentDM.Create(Application);
PhxConnect.ConnectTDatabase(EMailDocumentDM.PhoenixMailDataLink,
PhoenixEmailForm.PhxDatLink,1);
try
//
finally
if Assigned(EMailDocumentDM.PhoenixMailDataLink) then
begin
EMailDocumentDM.PhoenixMailDataLink.Close;
FreeandNil(EMailDocumentDM.PhoenixMailDataLink);
end;
if Assigned(PhoenixEmailForm.PhxDatLink) then
begin
PhoenixEMailForm.PhxDatLink.Close;
FreeAndNil(PhoenixEmailForm.PhxDatLink);
end;
EMailDocumentDM.MailFDManager.Close;
end;
Application.handle := 0;
PhoenixEmailForm.Free;
EMailDocumentDM.Free;
end;
Related
I am using this code with Mutex and custom Message to force the 1st instance of application to appear on screen if the user tries to start a 2nd instance. There must be only 1 instance of my app running.
It seems that this code is not working properly under Win10, it makes the Application Icon to flick on TaskBar, but the actual Window is not appearing on top of other Windows.
function ForceForeground(AppHandle:HWND): boolean;
const
SPI_GETFOREGROUNDLOCKTIMEOUT = $2000;
SPI_SETFOREGROUNDLOCKTIMEOUT = $2001;
var
ForegroundThreadID: DWORD;
ThisThreadID : DWORD;
timeout : DWORD;
OSVersionInfo : TOSVersionInfo;
Win32Platform : Integer;
begin
if IsIconic(AppHandle) then ShowWindow(AppHandle, SW_RESTORE);
if (GetForegroundWindow = AppHandle) then Result := true else
begin
Win32Platform := 0;
OSVersionInfo.dwOSVersionInfoSize := SizeOf(OSVersionInfo);
if GetVersionEx(OSVersionInfo) then Win32Platform := OSVersionInfo.dwPlatformId;
{ Windows 98/2000 doesn't want to foreground a window when some other window has keyboard focus}
if ((Win32Platform = VER_PLATFORM_WIN32_NT) and (OSVersionInfo.dwMajorVersion > 4)) or
((Win32Platform = VER_PLATFORM_WIN32_WINDOWS) and ((OSVersionInfo.dwMajorVersion > 4) or
((OSVersionInfo.dwMajorVersion = 4) and (OSVersionInfo.dwMinorVersion > 0)))) then
begin
Result := false;
ForegroundThreadID := windows.GetWindowThreadProcessID(GetForegroundWindow,nil);
ThisThreadID := windows.GetWindowThreadPRocessId(AppHandle,nil);
if AttachThreadInput(ThisThreadID, ForegroundThreadID, true) then
begin
BringWindowToTop(AppHandle);
SetForegroundWindow(AppHandle);
AttachThreadInput(ThisThreadID, ForegroundThreadID, false);
Result := (GetForegroundWindow = AppHandle);
end;
if not Result then
begin
SystemParametersInfo(SPI_GETFOREGROUNDLOCKTIMEOUT, 0, #timeout, 0);
SystemParametersInfo(SPI_SETFOREGROUNDLOCKTIMEOUT, 0, TObject(0), SPIF_SENDCHANGE);
BringWindowToTop(AppHandle);
SetForegroundWindow(AppHandle);
SystemParametersInfo(SPI_SETFOREGROUNDLOCKTIMEOUT, 0, TObject(timeout), SPIF_SENDCHANGE);
Result := (GetForegroundWindow = AppHandle);
if not Result then
begin
ShowWindow(AppHandle,SW_HIDE);
ShowWindow(AppHandle,SW_SHOWMINIMIZED);
ShowWindow(AppHandle,SW_SHOWNORMAL);
BringWindowToTop(AppHandle);
SetForegroundWindow(AppHandle);
end;
end;
end else
begin
BringWindowToTop(AppHandle);
SetForegroundWindow(AppHandle);
end;
Result := (GetForegroundWindow = AppHandle);
end;
end;
I have managed to make a complete demo program that shows my suggestion in the 2nd comment above. Create a new VCL application. Rename the form to MainForm, place a TListBox on it, align it to client, rename it to ListBox, then make empty events for the form's OnCreate and OnDestroy.
Then copy/paste this PASCAL source into your main form's PAS file from right after "interface", overwriting the code already there:
uses
Winapi.Windows, Winapi.Messages,
System.SysUtils, System.Variants, System.Classes,
Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;
CONST
WM_PEEK = WM_USER+1234;
type
TMainForm = class(TForm)
ListBox: TListBox;
procedure FormDestroy(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
Running : HWND;
PROCEDURE PEEK(VAR MSG : TMessage); MESSAGE WM_PEEK;
PROCEDURE CopyData(VAR MSG : TMessage); MESSAGE WM_COPYDATA;
PROCEDURE BringForward(Sender : TObject);
PROCEDURE SendString(H : HWND ; CONST S : STRING ; E : TEncoding);
FUNCTION CommandLine : STRING;
FUNCTION MakeAtomName(H : HWND) : STRING;
FUNCTION FindGlobalAtom(CONST S : STRING) : ATOM;
FUNCTION AddGlobalAtom(CONST S : STRING) : ATOM;
FUNCTION GetGlobalAtomName(H : ATOM) : STRING;
FUNCTION AtomNameToHandle(CONST S : STRING) : HWND;
FUNCTION DeleteGlobalAtom(A : ATOM) : DWORD;
public
{ Public declarations }
PROCEDURE LOG(CONST S : STRING);
end;
var
MainForm: TMainForm;
implementation
USES System.Character;
{$R *.dfm}
PROCEDURE TMainForm.FormDestroy(Sender : TObject);
VAR
S : STRING;
A : ATOM;
BEGIN
S:=MakeAtomName(0);
REPEAT
A:=FindGlobalAtom(S);
IF A=0 THEN BREAK;
UNTIL DeleteGlobalAtom(A)<>ERROR_SUCCESS
END;
FUNCTION TMainForm.AddGlobalAtom(CONST S : STRING) : ATOM;
BEGIN
Result:=WinAPI.Windows.GlobalAddAtom(PChar(S))
END;
FUNCTION TMainForm.MakeAtomName(H : HWND) : STRING;
CONST
L = 8*SizeOf(POINTER); // 32 or 64 (number of bits in a handle)
VAR
S : STRING;
I : Cardinal;
C : CHAR;
BEGIN
Result:=ChangeFileExt(ExtractFileName(ParamStr(0)),''); S:='';
FOR C IN Result DO IF CharInSet(C,['A'..'Z','a'..'z']) THEN S:=S+C;
WHILE LENGTH(S)<L DO S:=S+S;
SetLength(S,L);
Result:='';
FOR I:=1 TO L DO BEGIN
IF H AND $01<>0 THEN C:=S[I].ToUpper ELSE C:=S[I].ToLower;
Result:=C+Result; H:=H SHR 1
END
END;
FUNCTION TMainForm.AtomNameToHandle(CONST S : STRING) : HWND;
VAR
C : CHAR;
BEGIN
Result:=0;
FOR C IN S DO BEGIN
Result:=Result SHL 1;
IF CharInSet(C,['A'..'Z']) THEN Result:=Result OR 1
END
END;
PROCEDURE TMainForm.BringForward(Sender : TObject);
BEGIN
SetForegroundWindow(Running);
SendString(Running,CommandLine,TEncoding.UTF8);
ExitProcess(0)
END;
FUNCTION TMainForm.CommandLine : STRING;
BEGIN
Result:=GetCommandLine
END;
PROCEDURE TMainForm.CopyData(VAR MSG : TMessage);
VAR
CDS : PCopyDataStruct;
S : STRING;
B : TBytes;
BEGIN
CDS:=PCopyDataStruct(MSG.LParam);
SetLength(B,CDS.cbData);
MOVE(CDS.lpData^,POINTER(B)^,LENGTH(B));
S:=TEncoding.UTF8.GetString(B);
LOG('Child['+IntToHex(MSG.WParam)+']: '+S)
END;
FUNCTION TMainForm.DeleteGlobalAtom(A : ATOM) : DWORD;
BEGIN
SetLastError(ERROR_SUCCESS);
WinAPI.Windows.GlobalDeleteAtom(A);
Result:=GetLastError
END;
FUNCTION TMainForm.FindGlobalAtom(CONST S : STRING) : ATOM;
BEGIN
Result:=WinAPI.Windows.GlobalFindAtom(PChar(S))
END;
PROCEDURE TMainForm.FormCreate(Sender : TObject);
VAR
A : ATOM;
H : HWND;
S,T : STRING;
BEGIN
S:=MakeAtomName(Handle);
REPEAT
A:=FindGlobalAtom(S);
IF A=0 THEN BREAK;
T:=GetGlobalAtomName(A); H:=AtomNameToHandle(T);
IF H<>Handle THEN
IF SendMessage(H,WM_PEEK,NativeInt(A),NativeInt(H))=NativeInt(A)+NativeInt(H) THEN BREAK
UNTIL DeleteGlobalAtom(A)<>ERROR_SUCCESS;
IF A=0 THEN BEGIN
A:=AddGlobalAtom(S);
LOG('Main['+IntToHex(Handle)+'] : '+CommandLine)
END ELSE BEGIN
Running:=H; OnDestroy:=NIL; OnActivate:=BringForward;
BorderStyle:=TFormBorderStyle.bsNone;
SetBounds(-10000,-10000,10,10)
END
END;
FUNCTION TMainForm.GetGlobalAtomName(H : ATOM) : STRING;
BEGIN
SetLength(Result,255);
SetLength(Result,WinAPI.Windows.GlobalGetAtomName(H,#Result[LOW(Result)],LENGTH(Result)))
END;
PROCEDURE TMainForm.LOG(CONST S : STRING);
BEGIN
ListBox.ItemIndex:=ListBox.Items.Add(S)
END;
PROCEDURE TMainForm.PEEK(VAR MSG : TMessage);
BEGIN
MSG.Result:=NativeInt(MSG.WParam)+MSG.LParam
END;
PROCEDURE TMainForm.SendString(H : HWND ; CONST S : STRING ; E : TEncoding);
VAR
B : TBytes;
CDS : TCopyDataStruct;
BEGIN
B:=E.GetBytes(S);
CDS.dwData:=1;
CDS.cbData:=LENGTH(B);
CDS.lpData:=POINTER(B);
SendMessage(H,WM_COPYDATA,Handle,NativeInt(#CDS));
END;
end.
When you initially run the application, it'll show the command line in the ListBox. If you then run it again, it'll detect the other window already exists (using a bit-encoded Global Atom to signify the initial instance's main form Handle) and move it to the foreground (after placing its own window out-of-screen, and thus being an invisible foreground window). It'll then use WM_COPYDATA to send the new instance's command line to the initial instance, and the initial instance will then log the received command line to the listbox.
Caveats:
It's the MAIN form that is brought to front, receives and processes the command line. If you have child forms open, the behaviour is undefined (as in: I haven't tested this).
The Atom name is a 32- (or 64-) character long name, consisting of a repeated pattern of the program executable's A-Z characters. If your application doesn't have A-Z character in its name, this will fail.
To test if the Window decoded from the Global Atom is one we recognize, I call a WM_PEEK message on that window. This could lead to an unexpected message call into a foreign application, if your main instance is allowed to start (and create the Atom) and then not terminate properly (so that the Atom is deleted in FormDestroy).
I try to call a function to read some bytes from c++ dll. I declared the header of function but when i call and try to assign the array value to a record value, function return access violation in MSVCR80.dll.
Here is my code if i use valueBits record return AV if i use a simple boolean variable it's working. I need an advice please.
function TdmCustom.CheckBon(var valueBits: TStatusPrintingRecord): Boolean;
var cmd : String;
//valueBit : array[0..10] of AnsiChar;
MemArea : PAnsiChar;
pdwByteRead : LPDWORD;
lpdwSysError : LPDWORD;
aNrComanda : String;
Arr : array of AnsiChar;
begin
pdwByteRead := 0;
lpdwSysError := 0;
aNrComanda := '1011';
cmd := Format('%S',[aNrComanda]);
SendCommandToPrinter(cmd,True);
lastError := CEFReadB(MemArea, &pdwByteRead, &lpdwSysError)//acess violation if i use valueBits record
SetLength(Arr, Integer(pdwByteRead));
Move(MemArea^, Arr[0], Integer(pdwByteRead));
if lastError = 0 then begin
valueBits.S8_isBonFiscalDeschis := Arr[8] = '1';
//valueBits.S9_isBonNefiscalDeschis := Arr[9] = '1';
end;
Result := lastError = 0;
end;
This is my header of dll function :
function CEFReadB(lpMemArea : PAnsiChar; var pdwByteRead : LPDWORD; var lpdwSysError : LPDWORD) : DWORD; cdecl; external DLLName name 'CEFReadCustom' delayed;
There are various mistakes.
First & means something different in Delphi. You probably want #.
But you don't need that since you declare the values VAR.
But then again you declare them var as pointers (LPdw*). declaring them as VAR eats an indirection, so probably in the declaration the types should be just DWORD.
probably also you need to allocate memory to memarea before you pass it to the function
and pass the amount allocated in byteread.
I tried to cleanup, and came up with the below code, untested. IF you require more help, please update your post with C++ declaration and usage.
function CEFReadB(lpMemArea : PAnsiChar; var byteRead : DWORD; var lpdwSysError : DWORD) : DWORD; cdecl; external DLLName name 'CEFReadCustom' delayed;
function TdmCustom.CheckBon(var valueBits: TStatusPrintingRecord): Boolean;
var cmd : String;
MemArea : ansistring;
LastError : DWORD;
ByteRead : DWORD;
SysError : DWORD;
aNrComanda : String;
begin
byteRead := 50;
setlength(memarea,byteread);
lpdwSysError := 0;
aNrComanda := '1011';
cmd := Format('%S',[aNrComanda]);
SendCommandToPrinter(cmd,True);
lastError := CEFReadB(pansichar(MemArea), byteRead, SysError);
if lasterror= 0 then
begin
setlength(memarea,byteRead);
if byteread>=9 then
begin
valueBits.S8_isBonFiscalDeschis := Arr[8] = '1'; // note 8 and 9 are 1-based!
valueBits.S9_isBonNefiscalDeschis := Arr[9] = '1';
end
else
exit(False); // not enough data read.
end;
Result := lastError = 0;
end;
I am using an in-memory TClientDataSet with a TStringField column which contains folders path (Delphi 7).
When I create an index on this column the order is not what I am looking for.
As an example I get :
c:\foo
c:\fôo\a
c:\foo\b
when I would like this order :
c:\foo
c:\foo\b
c:\fôo\a
So I searched a way to use my own compare field function.
Based on this RRUZ answer How to change the implementation (detour) of an externally declared function I tried the following :
type
TClientDataSetHelper = class(DBClient.TClientDataSet);
...
MyCDS : TClientDataSet;
...
// My custom compare field function
function FldCmpHack
(
iFldType : LongWord;
pFld1 : Pointer;
pFld2 : Pointer;
iUnits1 : LongWord;
iUnits2 : LongWord
): Integer; stdcall;
begin
// Just to test
Result := -1;
end;
...
---RRUZ code here---
...
procedure HookDataCompare;
begin
HookProc
(
(MyCDs as TClientDataSetHelper).DSBase.FldCmp, <== do not compile !!!
#FldCmpHack,
FldCmpBackup
);
end;
When I try to compile I get an error (MyCDs as TClientDataSetHelper).DSBase.FldCmp : not enough actual parameters
I do not understand why this does not compile. Could you please help me ?
Is it even possible to "detour" IDSBase.FldCmp in DSIntf.pas ? Am i totally wrong ?
Thank you
EDIT
Finally, thanks to Dsm answer, I transformed the TStringFieldcolumn into a TVarBytesField in order to avoid doubling the buffer. Plus, when a TVarBytesField is indexed the order is based on the bytes value so I get the order I want. For having all child folders after a parent folder and before the next parent folder (c:\foo.new after c:\foo\b), I patched TVarBytesFieldlike this :
TVarBytesField = class(DB.TVarBytesField)
protected
function GetAsString: string; override;
procedure GetText(var Text: string; DisplayText: Boolean); override;
procedure SetAsString(const Value: string); override;
end;
function TVarBytesField.GetAsString: string;
var
vBuffer : PAnsiChar;
vTaille : WORD;
vTexte : PAnsiChar;
vI : WORD;
begin
Result := '';
GetMem(vBuffer, DataSize);
try
if GetData(vBuffer) then
begin
vTaille := PWORD(vBuffer)^;
vTexte := vBuffer + 2;
SetLength(Result, vTaille);
for vI := 1 to vTaille do
begin
if vTexte^ = #2 then
begin
Result[vI] := '\';
end
else
begin
Result[vI] := vTexte^;
end;
Inc(vTexte);
end;
end;
finally
FreeMem(vBuffer);
end;
end;
procedure TVarBytesField.GetText(var Text: string; DisplayText: Boolean);
begin
Text := GetAsString;
end;
procedure TVarBytesField.SetAsString(const Value: string);
var
vBuffer : PAnsiChar;
vTaille : WORD;
vTexte : PAnsiChar;
vI : WORD;
begin
vBuffer := AllocMem(DataSize);
try
vTaille := WORD(Length(Value));
PWORD(vBuffer)^ := vTaille;
vTexte := vBuffer + 2;
for vI := 1 to vTaille do
begin
if Value[vI] = '\' then
begin
vTexte^ := #2
end
else
begin
vTexte^ := Value[vI];
end;
Inc(vTexte);
end;
SetData(vBuffer);
finally
FreeMem(vBuffer);
end;
end;
The message is telling you that FldCmp is a function, and it is expecting you to execute it, but it has not got enough parameters. I am sure that you already realised that and probably already tried to get the address of the function with the # (like you do for FldCmpHack) and found that that does not work.
The reason for that is, I am afraid, that FldCmp is not a normal function. DSBase is actually an interface, which will have been assigned (looking at the source code) by a class factory. What you actually need is the real function itself and for that you need the real object that the class factory creates. And I am sorry, but I can't see any realistic way of doing that.
However, the DSBase field is only created if it has not been assigned, so you could, in theory, create your own IDSBase interface object, which is the way this type of problem is meant to be handled. That is a lot of work, though, unless you know class that the class factory produces and can descend from that.
A sneakier alternative is to override the Translate property and create some sort of hash (perhaps by translating the ASCII codes to their HEX values) so that the database keeps them in the right order
TClientDataSetHelper = class(TClientDataSet)
public
function Translate(Src, Dest: PAnsiChar; ToOem: Boolean): Integer; override;
end;
I'm a Delphi developer and have never programmed for netware. But I need to find the owner of a file on a netware share. After some research, I got this code snippet from a newsgroup (original author: Chris Morgan). It's basically a way to dynamically load netware dll and get the "owner" information of a file. Please look at the function GetNetwareFileOwner.
The problem is, I don't have direct access to a netware share for testing. I'm sending a small test program every time to a user who tests it by selecting a file on the netware share and then reports the results. I'm getting the error code by a small code insert after the call NWIntScanExtenedInfo where it fails with the error codes given below. Any ideas what can be wrong?
Error codes:
1) At first, the following code gave error 899E (INVALID_FILENAME) on the above call. The file name was in English--no special characters there. And the file was selected on the share with a regular File Open dialog.
2) After that, suspecting a case problem, I commented the two AnsiUpperCase lines to keep the name in original case exactly as the File Open Dialog received it. This gives the error 89FF now (NO_FILES_FOUND_ERROR).
P.S. I compiled the test with Delphi 2007. May be there is a structure problem of the top structure. I haven't checked the byte length and alignment. Will do so.
// netware records and function definitions
type
// sizeof(NW_EXT_FILE_INFO) should be 140 bytes - check byte alignment
NW_EXT_FILE_INFO = record
sequence: integer;
parent: integer;
attributes: integer;
uniqueID: shortint;
flags: shortint;
nameSpace: shortint;
nameLength: shortint;
name: array[0..11] of shortint;
creationDateAndTime: integer;
ownerID: integer;
lastArchiveDateAndTime: integer;
lastArchiverID: integer;
updateDateAndTime: integer;
lastUpdatorID: integer;
dataForkSize: integer;
dataForkFirstFAT: integer;
nextTrusteeEntry: integer;
reserved: array[0..35] of shortint;
inheritedRightsMask: word;
lastAccessDate: word;
deletedFileTime: integer;
deletedDateAndTime: integer;
deletorID: integer;
reserved2: array[0..15] of shortint;
otherForkSize: array[0..1] of integer;
end;
// functions defined in CALWIN32.DLL
TNWCallsInit = function(reserved1: pointer;
reserved2: pointer): integer; stdcall;
TNWCallsTerm = function(reserved: pointer): integer; stdcall;
TNWParseNetWarePath = function(const path: pchar; var conn: cardinal;
var dirhandle: cardinal; newpath: pchar): integer; stdcall;
TNWAllocTemporaryDirectoryHandle = function(conn: cardinal;
dirhandle: cardinal; const path: pchar; var newdirhandle: cardinal;
rightsmask: pshortint): integer; stdcall;
TNWDeallocateDirectoryHandle = function(conn: cardinal;
dirhandle: cardinal): integer; stdcall;
TNWIntScanExtendedInfo = function(conn: cardinal; dirhandle: cardinal;
attrs: shortint; iterhandle: Pinteger; const searchPattern: pchar;
var entryinfo: NW_EXT_FILE_INFO; augmentflag: shortint): integer;
stdcall;
TNWGetObjectName = function(conn: cardinal; objID: integer;
objname: pchar; objtype: pword): integer; stdcall;
const
FA_NORMAL = $00;
FA_HIDDEN = $02;
FA_SYSTEM = $04;
// return codes
SUCCESSFUL = $00;
NOT_MY_RESOURCE = $883C;
// get file owner for Netware server file
function GetNetwareFileOwner(const FilePath: string): string;
var
hcalwin: HINST;
NWCallsInit: TNWCallsInit;
NWParseNetWarePath: TNWParseNetWarePath;
NWAllocTemporaryDirectoryHandle: TNWAllocTemporaryDirectoryHandle;
NWIntScanExtendedInfo: TNWIntScanExtendedInfo;
NWGetObjectName: TNWGetObjectName;
NWDeallocateDirectoryHandle: TNWDeallocateDirectoryHandle;
NWCallsTerm: TNWCallsTerm;
hconn,
hdir,
retcode: cardinal;
filedir: string; { DOS path of parent folder
(upper case) }
nwfilename: string; { DOS filename (upper case) }
nwfiledir: array[0..255] of char; { Netware path of
parent folder }
rights: shortint;
i: integer;
entryinfo: NW_EXT_FILE_INFO;
objtype: word;
begin
Result := '';
// load netware client library and required functions
hcalwin := LoadLibrary('calwin32.dll');
if hcalwin<=0 then exit; // netware client not present on PC
#NWCallsInit := GetProcAddress(hcalwin,'NWCallsInit');
#NWParseNetWarePath := GetProcAddress(hcalwin,'NWParseNetWarePath');
#NWAllocTemporaryDirectoryHandle := GetProcAddress(hcalwin,
'NWAllocTemporaryDirectoryHandle');
#NWIntScanExtendedInfo :=
GetProcAddress(hcalwin,'NWIntScanExtendedInfo');
#NWGetObjectName := GetProcAddress(hcalwin,'NWGetObjectName');
#NWDeallocateDirectoryHandle := GetProcAddress(hcalwin,
'NWDeallocateDirectoryHandle');
#NWCallsTerm := GetProcAddress(hcalwin,'NWCallsTerm');
// initialise netware libs
if NWCallsInit(nil,nil)<>SUCCESSFUL then exit;
try
filedir := AnsiUpperCase(ExtractFileDir(FilePath));
retcode := NWParseNetWarePath(pchar(filedir),hconn,hdir,nwfiledir);
if retcode=NOT_MY_RESOURCE then exit; // local or non-netware disk
// get a dir handle
NWAllocTemporaryDirectoryHandle(hconn,0,nwfiledir,hdir,#rights);
// get the file info
i := -1;
nwfilename := AnsiUpperCase(ExtractFileName(FilePath));
retcode := NWIntScanExtendedInfo(hconn,hdir,
FA_NORMAL+FA_SYSTEM+FA_HIDDEN,
#i,pchar(nwfilename),entryinfo,0);
if retcode=SUCCESSFUL then begin
// get file owner name from ID
SetLength(Result,MAX_PATH);
retcode := NWGetObjectName(hconn,entryinfo.ownerID,
pchar(Result),#objtype);
if retcode=SUCCESSFUL then
SetLength(Result,Length(Result)) // got owner
else SetLength(Result,0); // failed to get owner
end;
// deallocate dir handle
NWDeallocateDirectoryHandle(hconn,hdir);
finally
// clean up
NWCallsTerm(nil);
FreeLibrary(hcalwin);
end;
end;
Are you sure about stdcall? Tru cdecl and so on.
Also, You done give information about delphi's version.
If you use a version BEFORE delphi2009 pchar is a one-byte char.
But if you use delphi2009 or next, pchar is 2 byte char.
So, if you need one byte char you must use PAnsiChar insthead.
I don't know if netware dll parameters are unicode or ansi...
Cher.
A.
I have the service name for a windows service in delphi, and I know how to get the handle from that as well. What I need to do is stop a service, and if the stop fails for some reason I need to kill the process associated with the service. The problem is that I have multiple services running from the same executable, so I can't use the executable name to kill the process. This means I need the process id to kill the proper associated process. How can I get this id or some way to kill the proper process from the service name or handle?
QueryServiceStatusEx?
Please note I have only accepted this solution so that a full delphi code solution is accepted, all due thanks to Jk though for pointing me on the correct path.
--
Ok, I've been able to figure out how to use the answer by Jk and have come up with this solution in delphi.
For reference, this is the link provided by Jk:
QueryServiceStatusEx
My Solution:
unit Demo;
interface
uses
Windows, Forms, SysUtils,
StdCtrls, WinSvc, Controls, Classes;
type
//Form for basic demo usage
TForm6 = class(TForm)
Button1: TButton;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
end;
//Record defined for use as return buffer
_SERVICE_STATUS_PROCESS = record
dwServiceType: DWORD;
dwCurrentState: DWORD;
dwControlsAccepted: DWORD;
dwWin32ExitCode: DWORD;
dwServiceSpecificExitCode: DWORD;
dwCheckPoint: DWORD;
dwWaitHint: DWORD;
dwProcessId: DWORD;
dwServiceFlags: DWORD;
end;
//Function Prototype
function QueryServiceStatusEx(
SC_HANDLE: SC_Handle;
SC_STATUS_TYPE: Cardinal;
out lpBuffer: _SERVICE_STATUS_PROCESS;
cbBufSize: DWORD;
out pcbBytesNeeded: LPDWORD
): BOOL; stdcall;
//internal setup function
function GetPid(sService: String; sMachine: String = '') : Cardinal;
var
Form6: TForm6;
implementation
{$R *.dfm}
const
// windows api library
advapi32 = 'advapi32.dll';
//define the api call
function QueryServiceStatusEx; external advapi32 name 'QueryServiceStatusEx';
//for demo usage
procedure TForm6.Button1Click(Sender: TObject);
begin
Memo1.Lines.Add(IntToStr(Integer(GetPid('Service'))))
end;
function GetPid(sService: String; sMachine: String = '') : Cardinal;
var
schm,
schs: SC_Handle;
SC_STATUS_TYPE: Cardinal;
lpBuffer: _SERVICE_STATUS_PROCESS;
cbBufSize: DWORD;
pcbBytesNeeded: LPDWORD;
begin
//open the service manager (defined in WinSvc)
schm := OpenSCManager(PChar(sMachine), nil, SC_MANAGER_CONNECT);
//set the status type to SC_STATUS_PROCESS_INFO
//this is currently the only value supported
SC_STATUS_TYPE := $00000000;
//set the buffer size to the size of the record
cbBufSize := sizeof(_SERVICE_STATUS_PROCESS);
if (schm>0) then
begin
//grab the service handle
schs := OpenService(schm, PChar(sService), SERVICE_QUERY_STATUS);
if (schs>0) then
begin
//call the function
QueryServiceStatusEx(
schs,
SC_STATUS_TYPE,
lpBuffer,
cbBufSize,
pcbBytesNeeded);
CloseServiceHandle(schs);
end;
CloseServiceHandle(schm);
end;
Result := lpBuffer.dwProcessId;
end;
end.
Please note that not all external naming and other necessities are included.
Or use DSiWin32 for many useful functions, including DSiGetProcessID. This code was written by StackOverflow user (and programmer) Gabr.
Here's the function, for your own reference. It will give you what you are looking for:
//Retrieves ID of the specified process. Requires Toolhelp API.
// #returns False if ID cannot be retrieved. Check GetLastError - if it is 0, process
// doesn't exist; otherwise it contains the Win32 error code.
// #author gabr
// #since 2004-02-12
//
function DSiGetProcessID(const processName: string; var processID: DWORD): boolean;
var
hSnapshot: THandle;
procEntry: TProcessEntry32;
begin
Result := false;
hSnapshot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
if hSnapshot = 0 then
Exit;
try
procEntry.dwSize := Sizeof(procEntry);
if not Process32First(hSnapshot, procEntry) then
Exit;
repeat
if AnsiSameText(procEntry.szExeFile, processName) then begin
processID := procEntry.th32ProcessID;
Result := true;
break; // repeat
end;
until not Process32Next(hSnapshot, procEntry);
finally DSiCloseHandleAndNull(hSnapshot); end;
end; { DSiGetProcessID }