I don't know much about delphi win 32 programming, but I hope someone can answer my question.
I get duplicate l_sGetUniqueIdBuffer saved into the database which I want to avoid.
The l_sGetUniqueIdBuffer is actually different ( the value of l_sAuthorisationContent is xml, and I can see a different value generated by the call to getUniqueId) between rows. This problem is intermittant ( duplicates are rare...) There is only milliseconds difference between the update date between the rows.
Given:
( unnesseary code cut out)
var
l_sGetUniqueIdBuffer: PChar;
FOutputBufferSize : integer;
begin
FOutputBufferSize := 1024;
...
while( not dmAccomClaim.ADOQuClaimIdentification.Eof ) do
begin
// Get a unique id for the request
l_sGetUniqueIdBuffer := AllocMem (FOutputBufferSize);
l_returnCode := getUniqueId (m_APISessionId^, l_sGetUniqueIdBuffer, FOutputBufferSize);
dmAccomClaim.ADOQuAddContent.Active := False;
dmAccomClaim.ADOQuAddContent.Parameters.ParamByName('pContent').Value := (WideString(l_sAuthorisationContent));
dmAccomClaim.ADOQuAddContent.Parameters.ParamByName('pClaimId').Value := dmAccomClaim.ADOQuClaimIdentification.FieldByName('SB_CLAIM_ID').AsString;
dmAccomClaim.ADOQuAddContent.Parameters.ParamByName('pUniqueId').Value := string(l_sGetUniqueIdBuffer);
dmAccomClaim.ADOQuAddContent.ExecSQL;
FreeMem( l_sAuthorisationContent, l_iAuthoriseContentSize );
FreeMem( l_sGetUniqueIdBuffer, FOutputBufferSize );
end;
end;
I guess i need to know, is the value in l_sGetUniqueIdBuffer being reset for every row??
AllocMem is implemented as follows
function AllocMem(Size: Cardinal): Pointer;
begin
GetMem(Result, Size);
FillChar(Result^, Size, 0);
end;
so yes, the value that l_sGetUniqueBuffer is pointing to will always be reset to an empty string.
Debugging
var
l_sGetUniqueIdBuffer: PChar;
FOutputBufferSize : integer;
list: TStringList;
begin
FOutputBufferSize := 1024;
...
list := TStringList.Create;
try
list.Sorted := True;
while( not dmAccomClaim.ADOQuClaimIdentification.Eof ) do
begin
// Get a unique id for the request
l_sGetUniqueIdBuffer := AllocMem (FOutputBufferSize);
l_returnCode := getUniqueId (m_APISessionId^, l_sGetUniqueIdBuffer, FOutputBufferSize);
dmAccomClaim.ADOQuAddContent.Active := False;
dmAccomClaim.ADOQuAddContent.Parameters.ParamByName('pContent').Value := (WideString(l_sAuthorisationContent));
dmAccomClaim.ADOQuAddContent.Parameters.ParamByName('pClaimId').Value := dmAccomClaim.ADOQuClaimIdentification.FieldByName('SB_CLAIM_ID').AsString;
dmAccomClaim.ADOQuAddContent.Parameters.ParamByName('pUniqueId').Value := string(l_sGetUniqueIdBuffer);
if list.IndexOf(l_sGetUniqueIdBuffer) <> - 1 then
write; //***** Place a breakpoint here.
list.Add(l_sGetUniqueIdBuffer);
dmAccomClaim.ADOQuAddContent.ExecSQL;
FreeMem( l_sAuthorisationContent, l_iAuthoriseContentSize );
FreeMem( l_sGetUniqueIdBuffer, FOutputBufferSize );
end;
finally
list.Free;
end;
end;
Related
I am trying to find and replace text in a text file. I have been able to do this in the past with methods like:
procedure SmallFileFindAndReplace(FileName, Find, ReplaceWith: string);
begin
with TStringList.Create do
begin
LoadFromFile(FileName);
Text := StringReplace(Text, Find, ReplaceWith, [rfReplaceAll, rfIgnoreCase]);
SaveToFile(FileName);
Free;
end;
end;
The above works fine when a file is relatively small, however; when the the file size is something like 170 Mb the above code will cause the following error:
EOutOfMemory with message 'Out of memory'
I have tried the following with success, however it takes a long time to run:
procedure Tfrm_Main.button_MakeReplacementClick(Sender: TObject);
var
fs : TFileStream;
s : AnsiString;
//s : string;
begin
fs := TFileStream.Create(edit_SQLFile.Text, fmOpenread or fmShareDenyNone);
try
SetLength(S, fs.Size);
fs.ReadBuffer(S[1], fs.Size);
finally
fs.Free;
end;
s := StringReplace(s, edit_Find.Text, edit_Replace.Text, [rfReplaceAll, rfIgnoreCase]);
fs := TFileStream.Create(edit_SQLFile.Text, fmCreate);
try
fs.WriteBuffer(S[1], Length(S));
finally
fs.Free;
end;
end;
I am new to "Streams" and working with buffers.
Is there a better way to do this?
Thank You.
You have two mistakes in first code example and three - in second example:
Do not load whole large file in memory, especially in 32bit application. If file size more than ~1 Gb, you always get "Out of memory"
StringReplace slows with large strings, because of repeated memory reallocation
In second code you don`t use text encoding in file, so (for Windows) your code "think" that file has UCS2 encoding (two bytes per character). But what you get, if file encoding is Ansi (one byte per character) or UTF8 (variable size of char)?
Thus, for correct find&replace you must use file encoding and read/write parts of file, as LU RD said:
interface
uses
System.Classes,
System.SysUtils;
type
TFileSearchReplace = class(TObject)
private
FSourceFile: TFileStream;
FtmpFile: TFileStream;
FEncoding: TEncoding;
public
constructor Create(const AFileName: string);
destructor Destroy; override;
procedure Replace(const AFrom, ATo: string; ReplaceFlags: TReplaceFlags);
end;
implementation
uses
System.IOUtils,
System.StrUtils;
function Max(const A, B: Integer): Integer;
begin
if A > B then
Result := A
else
Result := B;
end;
{ TFileSearchReplace }
constructor TFileSearchReplace.Create(const AFileName: string);
begin
inherited Create;
FSourceFile := TFileStream.Create(AFileName, fmOpenReadWrite);
FtmpFile := TFileStream.Create(ChangeFileExt(AFileName, '.tmp'), fmCreate);
end;
destructor TFileSearchReplace.Destroy;
var
tmpFileName: string;
begin
if Assigned(FtmpFile) then
tmpFileName := FtmpFile.FileName;
FreeAndNil(FtmpFile);
FreeAndNil(FSourceFile);
TFile.Delete(tmpFileName);
inherited;
end;
procedure TFileSearchReplace.Replace(const AFrom, ATo: string;
ReplaceFlags: TReplaceFlags);
procedure CopyPreamble;
var
PreambleSize: Integer;
PreambleBuf: TBytes;
begin
// Copy Encoding preamble
SetLength(PreambleBuf, 100);
FSourceFile.Read(PreambleBuf, Length(PreambleBuf));
FSourceFile.Seek(0, soBeginning);
PreambleSize := TEncoding.GetBufferEncoding(PreambleBuf, FEncoding);
if PreambleSize <> 0 then
FtmpFile.CopyFrom(FSourceFile, PreambleSize);
end;
function GetLastIndex(const Str, SubStr: string): Integer;
var
i: Integer;
tmpSubStr, tmpStr: string;
begin
if not(rfIgnoreCase in ReplaceFlags) then
begin
i := Pos(SubStr, Str);
Result := i;
while i > 0 do
begin
i := PosEx(SubStr, Str, i + 1);
if i > 0 then
Result := i;
end;
if Result > 0 then
Inc(Result, Length(SubStr) - 1);
end
else
begin
tmpStr := UpperCase(Str);
tmpSubStr := UpperCase(SubStr);
i := Pos(tmpSubStr, tmpStr);
Result := i;
while i > 0 do
begin
i := PosEx(tmpSubStr, tmpStr, i + 1);
if i > 0 then
Result := i;
end;
if Result > 0 then
Inc(Result, Length(tmpSubStr) - 1);
end;
end;
var
SourceSize: int64;
procedure ParseBuffer(Buf: TBytes; var IsReplaced: Boolean);
var
i: Integer;
ReadedBufLen: Integer;
BufStr: string;
DestBytes: TBytes;
LastIndex: Integer;
begin
if IsReplaced and (not(rfReplaceAll in ReplaceFlags)) then
begin
FtmpFile.Write(Buf, Length(Buf));
Exit;
end;
// 1. Get chars from buffer
ReadedBufLen := 0;
for i := Length(Buf) downto 0 do
if FEncoding.GetCharCount(Buf, 0, i) <> 0 then
begin
ReadedBufLen := i;
Break;
end;
if ReadedBufLen = 0 then
raise EEncodingError.Create('Cant convert bytes to str');
FSourceFile.Seek(ReadedBufLen - Length(Buf), soCurrent);
BufStr := FEncoding.GetString(Buf, 0, ReadedBufLen);
if rfIgnoreCase in ReplaceFlags then
IsReplaced := ContainsText(BufStr, AFrom)
else
IsReplaced := ContainsStr(BufStr, AFrom);
if IsReplaced then
begin
LastIndex := GetLastIndex(BufStr, AFrom);
LastIndex := Max(LastIndex, Length(BufStr) - Length(AFrom) + 1);
end
else
LastIndex := Length(BufStr);
SetLength(BufStr, LastIndex);
FSourceFile.Seek(FEncoding.GetByteCount(BufStr) - ReadedBufLen, soCurrent);
BufStr := StringReplace(BufStr, AFrom, ATo, ReplaceFlags);
DestBytes := FEncoding.GetBytes(BufStr);
FtmpFile.Write(DestBytes, Length(DestBytes));
end;
var
Buf: TBytes;
BufLen: Integer;
bReplaced: Boolean;
begin
FSourceFile.Seek(0, soBeginning);
FtmpFile.Size := 0;
CopyPreamble;
SourceSize := FSourceFile.Size;
BufLen := Max(FEncoding.GetByteCount(AFrom) * 5, 2048);
BufLen := Max(FEncoding.GetByteCount(ATo) * 5, BufLen);
SetLength(Buf, BufLen);
bReplaced := False;
while FSourceFile.Position < SourceSize do
begin
BufLen := FSourceFile.Read(Buf, Length(Buf));
SetLength(Buf, BufLen);
ParseBuffer(Buf, bReplaced);
end;
FSourceFile.Size := 0;
FSourceFile.CopyFrom(FtmpFile, 0);
end;
how to use:
procedure TForm2.btn1Click(Sender: TObject);
var
Replacer: TFileSearchReplace;
StartTime: TDateTime;
begin
StartTime:=Now;
Replacer:=TFileSearchReplace.Create('c:\Temp\123.txt');
try
Replacer.Replace('some текст', 'some', [rfReplaceAll, rfIgnoreCase]);
finally
Replacer.Free;
end;
Caption:=FormatDateTime('nn:ss.zzz', Now - StartTime);
end;
Your first try creates several copies of the file in memory:
it loads the whole file into memory (TStringList)
it creates a copy of this memory when accessing the .Text property
it creates yet another copy of this memory when passing that string to StringReplace (The copy is the result which is built in StringReplace.)
You could try to solve the out of memory problem by getting rid of one or more of these copies:
e.g. read the file into a simple string variable rather than a TStringList
or keep the string list but run the StringReplace on each line separately and write the result to the file line by line.
That would increase the maximum file size your code can handle, but you will still run out of memory for huge files. If you want to handle files of any size, your second approach is the way to go.
No - I don't think there's a faster way that the 2nd option (if you want a completely generic search'n'replace function for any file of any size). It may be possible to make a faster version if you code it specifically according to your requirements, but as a general-purpose search'n'replace function, I don't believe you can go faster...
For instance, are you sure you need case-insensitive replacement? I would expect that this would be a large part of the time spent in the replace function. Try (just for kicks) to remove that requirement and see if it doesn't speed up the execution quite a bit on large files (this depends on how the internal coding of the StringReplace function is made - if it has a specific optimization for case-sensitive searches)
I believe refinement of Kami's code is needed to account for the string not being found, but the start of a new instance of the string might occur at the end of the buffer. The else clause is different:
if IsReplaced then begin
LastIndex := GetLastIndex(BufStr, AFrom);
LastIndex := Max(LastIndex, Length(BufStr) - Length(AFrom) + 1);
end else
LastIndex :=Length(BufStr) - Length(AFrom) + 1;
Correct fix is this one:
if IsReplaced then
begin
LastIndex := GetLastIndex(BufStr, AFrom);
LastIndex := Max(LastIndex, Length(BufStr) - Length(AFrom) + 1);
end
else
if FSourceFile.Position < SourceSize then
LastIndex := Length(BufStr) - Length(AFrom) + 1
else
LastIndex := Length(BufStr);
I am using Delphi XE3. I am trying to learn more about how to properly use and then free the pointers. I have two pointers lpParams and pHolder. I would like to know if I must used a typed pointer for pHolder and what the proper way to free both pinters in this routine. Thank you.
function TmyLine.LineOpen(dwLineDevice: Integer;
var wMediaMode: Integer;
phLine,
plTAPIVersion: pLongInt): Integer;
var lOwnership,
lResult: LongInt;
lpParams: pTLineCallparams; // first pointer
pHolder: Pointer; // second pointer
dwAddressID, dwMediaMode: DWORD;
begin
if not bDeviceInitialized then
lResult := -1
else
begin
pHolder := nil; // default is nil unless we are using the singleaddress method
lOwnership := 0;
if FPrivilege.bSingleAddress then
begin
lOwnership := lOwnership + LINEOPENOPTION_SINGLEADDRESS;
try
lpParams := AllocMem(SizeOf(TLineCallParams) + 128); // make up a big enough value
except
lpParams := nil;
exit; // should I exit here? what about if there is an error? do I free pHolder?
end;
lpParams.dwTotalSize := sizeof(TLineCallParams) + 128;
lpParams.dwAddressMode := LINEADDRESSMODE_ADDRESSID;
pHolder := lpParams; // is this ok? Do i need a typed pointer?
end;
lResult := lineOpen(Fline.hLineApp, // fnd 64bit, see if longint needs to be dword_ptr
dwLineDevice,
phLine,
plTAPIVersion^,
FTAPI.lExtVersion,
DWORD_PTR(Self), //Pointer to the control, it is passed to the Callback routine as the lCallBackInstance parameter
lOwnership,
wMediaMode,
pHolder); // using the pointer here
if lResult <> 0 then
begin
pHolder := nil;
lpParams := nil; // is the the right way to do this?
end
else
begin
lineSetStatusMessages(temp);
end;
end;
pHolder := nil; // is this the correct way to free things up?
if lpParams <> nil then freemem(lpParams, sizeof(TLineCallParams) + 128);
LineOpen := lResult;
end;
First, you are filling in the dwAddressMode field, but you are not filling in the dwAddressID field. You need to fill in the dwAddressID or else there is no point in using LINEOPENOPTION_SINGLEADDRESS.
Second, lineOpen() does not take ownership of the LINECALLPARAMS pointer that you pass to it. You must deallocate the memory yourself after lineOpen() exits, regardless of its result, eg:
function TmyLine.LineOpen(dwLineDevice: Integer;
var wMediaMode: Integer;
phLine,
plTAPIVersion: pLongInt): Integer;
var
lOwnership: DWORD;
lpParams: pTLineCallparams;
begin
Result := -1;
if not bDeviceInitialized then Exit;
lOwnership := 0;
lpParams := nil;
try
if FPrivilege.bSingleAddress then
begin
try
lpParams := AllocMem(SizeOf(TLineCallParams));
except
Exit;
end;
lpParams.dwTotalSize := sizeof(TLineCallParams);
lpParams.dwAddressID := ...; // don't forget to fill this in!
lpParams.dwAddressMode := LINEADDRESSMODE_ADDRESSID;
lOwnership := LINEOPENOPTION_SINGLEADDRESS;
end;
Result := lineOpen(Fline.hLineApp,
dwLineDevice,
phLine,
plTAPIVersion^,
FTAPI.lExtVersion,
DWORD_PTR(Self),
lOwnership,
wMediaMode,
lpParams);
finally
if lpParams <> nil then
FreeMem(lpParams, sizeof(TLineCallParams));
end;
if Result = 0 then
lineSetStatusMessages(...);
end;
Third, since you are only filling in standard fields of LINECALLPARAMS and not any extensions, you don't really need to dynamically allocate the LINECALLPARAMS on the heap at all. You can alternatively allocate it statically on the stack instead (which is why lineOpen() cannot take ownership of it), eg:
function TmyLine.LineOpen(dwLineDevice: Integer;
var wMediaMode: Integer;
phLine,
plTAPIVersion: pLongInt): Integer;
var
lOwnership: DWORD;
Params: TLineCallparams;
lpParams: pTLineCallparams;
begin
Result := -1;
if not bDeviceInitialized then Exit;
lOwnership := 0;
lpParams := nil;
if FPrivilege.bSingleAddress then
begin
Params.dwTotalSize := sizeof(TLineCallParams);
Params.dwAddressID := ...; // don't forget to fill this in!
Params.dwAddressMode := LINEADDRESSMODE_ADDRESSID;
lpParams := #Params;
lOwnership := LINEOPENOPTION_SINGLEADDRESS;
end;
Result := lineOpen(Fline.hLineApp,
dwLineDevice,
phLine,
plTAPIVersion^,
FTAPI.lExtVersion,
DWORD_PTR(Self),
lOwnership,
wMediaMode,
lpParams);
if Result = 0 then
lineSetStatusMessages(...);
end;
I have a function declare like this :
function execProc(ProcName,InValues:PChar;out OutValues:PChar):integer; //The "OutValues" is a out parameter.
And I call this function like this:
procedure TForm1.Button6Click(Sender: TObject);
var
v:integer;
s:pchar;
begin
Memo1.Clear;
v := execProc(pchar('PROC_TEST'),pchar('aaa'),s);
showmessage(inttostr(v)); //mark line
Memo1.Lines.Add(strpas(s));
end;
when i delete the mark line(showmessage(inttostr(v))),i will have a correct result display in the Memo1,but if i keep use the showmessage(), the memo1 will dispaly an error string : "Messag" ,Why?
Thanks for any help!
function execProc(ProcName,InValues:PChar;out OutValues:PChar):integer;
var
str: TStrings;
InValue,OutValue: string;
i,j,scount: integer;
begin
Result := -100;
i := 0;
j := 0;
str := TStringList.Create;
try
sCount := ExtractStrings(['|'], [], InValues, str);
with kbmMWClientStoredProc1 do
begin
Close;
Params.Clear;
StoredProcName := StrPas(ProcName);
FieldDefs.Updated := False;
FieldDefs.Update;
for i := 0 to Params.Count - 1 do
begin
if (Params[i].ParamType = ptUnknown) or
(Params[i].ParamType = ptInput) or
(Params[i].ParamType = ptInputOutput) then
begin
inc(j);
InValue := str[j-1];
Params[i].Value := InValue;
end;
end;
try
ExecProc;
for i := 0 to Params.Count - 1 do
begin
if (Params[i].ParamType = ptOutput) or
(Params[i].ParamType = ptInputOutput) then
OutValue := OutValue + '|' + Params[i].AsString;
end;
OutValues := PChar(Copy(OutValue,2,Length(OutValue)-1));
Result := 0;
except
on E:Exception do
begin
if E.Message = 'Connection lost.' then Result := -101;//服务器连接失败
if E.Message = 'Authorization failed.' then Result := -102;//身份验证失败
Writelog(E.Message);
end;
end;
end;
finally
str.Free;
end;
end;
The problem is in the design of your interface and the use of PChar.
OutValues := PChar(Copy(OutValue,2,Length(OutValue)-1));
This is implemented by making an implicit, hidden, local string variable which holds the value
Copy(OutValue,2,Length(OutValue)-1)
When the function returns, that string variable is destroyed and so OutValues points at deallocated memory. Sometimes your program appears to work but that's really just down to chance. Any small change can disturb that, as you have observed.
The problem is easy enough to fix. Simply use string parameters rather than PChar. This will make the code easier to read as well as making it work correctly.
function execProc(ProcName, InValues: string; out OutValues: string): integer;
I've written a DataSnap server method that returns a TStream object to transfer a file. The client application calls the method and reads the stream fine. My issue is that the method call takes a while to complete before the TStream object is available to read, but on the server side I can see that the method call only takes a second to create the object to return. I was hoping the stream object would be returned immediately so that I can read the stream and display a progress bar for the download progress. Is there another way I can do this?
The server method is very simple :
function TServerMethods.DespatchDocument(sCompanyID, sDocOurRef: string): TStream;
var
sSourceFilePath: string;
strFileStream: TFileStream;
begin
sSourceFilePath := GetDocumentPDFFilePath(sCompanyID, sDocOurRef);
strFileStream := TFileStream.Create(sSourceFilePath, fmOpenRead);
Result := strFileStream;
end;
This is how I did it a while back. I used XE and haven't had a chance to clean it up.
//Server side:
function TServerMethods1.DownloadFile(out Size: Int64): TStream;
begin
Result := TFileStream.Create('upload.fil', fmOpenRead or fmShareDenyNone);
Size := Result.Size;
Result.Position := 0;
end;
//Client side:
procedure TfMain.DownloadFile(Sender: TObject);
var
RetStream: TStream;
Buffer: PByte;
Mem: TMemoryStream;
BytesRead: Integer;
DocumentId: Int64;
Size: Int64;
filename: WideString;
BufSize: Integer;
begin
BufSize := 1024;
try
Mem := TMemoryStream.Create;
GetMem( Buffer, BufSize );
try
RetStream := FDownloadDS.DownloadFile(Size);
RetStream.Position := 0;
if ( Size <> 0 ) then
begin
filename := 'download.fil';
repeat
BytesRead := RetStream.Read( Pointer( Buffer )^, BufSize );
if ( BytesRead > 0 ) then
begin
Mem.WriteBuffer( Pointer( Buffer )^, BytesRead );
end;
lStatus.Caption := IntToStr( Mem.Size ) + '/' + IntToStr( Size );
Application.ProcessMessages;
until ( BytesRead < BufSize );
if ( Size <> Mem.Size ) then
begin
raise Exception.Create( 'Error downloading file...' );
end;
end
else
begin
lStatus.Caption := '';
end;
finally
FreeMem( Buffer, BufSize );
FreeAndNIl(Mem);
end;
except
on E: Exception do
begin
lErrorMessage.Caption := PChar( E.ClassName + ': ' + E.Message );
end;
end;
end;
You can adjust BufSize however you like. I was having trouble getting the size of the stream until I did it this way. I experimented with XE2 and didn't seem to have the same problem but I was uploading. There is probably a better way to retrieve the size of the stream. If I get the answer soon I'll let you know....
On another note - I haven't figured out how to display a progress bar on the server side. I'm still trying to figure this out too.
I hope this helps! Let me know if you have any questions!
Glad you have some luck! This is the other fix I had to do. You can refer to this link https://forums.embarcadero.com/thread.jspa?threadID=66490&tstart=0
After diving in the code I found in "Data.DBXJSONReflect.pas"
procedure TJSONPopulationCustomizer.PrePopulate(Data: TObject; rttiContext: TRttiContext);
...
3473: rttiField.GetValue(Data).AsObject.Free;
3474: rttiField.SetValue(Data, TValue.Empty);
...
I think it should be this way:
3473: rttiField.SetValue(Data, TValue.Empty);
3474: rttiField.GetValue(Data).AsObject.Free;
I got the following code from a newsgroup posting. Strangely, it isn't working for me in Delphi 2010; An exception is being thrown at the LsaOpenPolicy function call:
function AddLogonAsAService(ID: pchar): boolean;
const
Right: PChar = 'SeServiceLogonRight';
var
FResult: NTSTATUS;
//szSystemName: LPTSTR;
FObjectAttributes: TLSAObjectAttributes;
FPolicyHandle: LSA_HANDLE;
Server, Privilege: TLSAUnicodeString;
FSID: PSID;
cbSid: DWORD;
ReferencedDomain: LPTSTR;
cchReferencedDomain: DWORD;
peUse: SID_NAME_USE;
PrivilegeString: String;
begin
Result := false;
try
ZeroMemory(#FObjectAttributes, sizeof(FObjectAttributes));
Server.Buffer := nil;
Server.Length := 0;
Server.MaximumLength := 256;
PrivilegeString := Right; //or some other privilege
Privilege.Buffer := PChar(PrivilegeString);
Privilege.Length := 38;
Privilege.MaximumLength := 256;
FResult := LsaOpenPolicy(
#Server, //this machine, because the Buffer is NIL
#FObjectAttributes,
POLICY_ALL_ACCESS,
FPolicyHandle);
if FResult = STATUS_SUCCESS then begin
cbSid := 128;
cchReferencedDomain := 16;
GetMem(FSID, cbSid);
//FSID:=PSID(HeapAlloc(GetProcessHeap(), 0, cbSid));
GetMem(ReferencedDomain, cchReferencedDomain);
//ReferencedDomain := LPTSTR(HeapAlloc(GetProcessHeap(), 0, cchReferencedDomain * sizeof(ReferencedDomain^)));
if LookupAccountName(nil, ID, FSID, cbSid, ReferencedDomain,
cchReferencedDomain, peUse) then begin
FResult := LsaAddAccountRights(FPolicyHandle, FSID, #Privilege, 1);
Result := FResult = STATUS_SUCCESS;
end;
FreeMem(FSID, cbSid);
FreeMem(ReferencedDomain, cchReferencedDomain);
end;
except
Result := false;
end;
end;
Original posting may be found at Google Groups archive:
From: "andrew"
Newsgroups:
borland.public.delphi.winapi
Subject: NetUserAdd and assigning user
rights
Date: Tue, 25 Sep 2001 10:08:35 +1000
Thanks in advance for any answers.
According to the MSDN docs you should not use an LSA_UNICODE_STRING with the Buffer set to nil but pass nil instead: LsaOpenPolicy(nil, ...
/EDIT:
The code below works fine for me using Jedi Apilib so I think something might be wrong with your definition (maybe calling convention?), so please add this to your code.
Also you are specifying maximum buffer size of 256 in the LSA_UNICODE_STRING's which is incorrect, in the first case the maximum buffer is 0.
uses
JwaWinType, JwaNtSecApi;
procedure TForm1.Button1Click(Sender: TObject);
var
ObjectAttribs: LSA_OBJECT_ATTRIBUTES;
PolicyHandle: LSA_HANDLE;
nts: NTSTATUS;
begin
ZeroMemory(#ObjectAttribs, SizeOf(ObjectAttribs));
nts := LsaOpenPolicy(nil, ObjectAttribs, POLICY_ALL_ACCESS, PolicyHandle);
Memo1.Lines.Add(Format('nts=%.8x', [nts]));
end;
Fixed/changed function, tested on Win7 under D2009 (but should work on older/newer too). Of course app. must be running with admin rights.
uses
JwaWinNT, JwaWinType, JwaNtStatus, JwaNtSecApi, JwaLmCons;
function AddPrivilegeToAccount(AAccountName, APrivilege: String): DWORD;
var
lStatus: TNTStatus;
lObjectAttributes: TLsaObjectAttributes;
lPolicyHandle: TLsaHandle;
lPrivilege: TLsaUnicodeString;
lSid: PSID;
lSidLen: DWORD;
lTmpDomain: String;
lTmpDomainLen: DWORD;
lTmpSidNameUse: TSidNameUse;
{$IFDEF UNICODE}
lPrivilegeWStr: String;
{$ELSE}
lPrivilegeWStr: WideString;
{$ENDIF}
begin
ZeroMemory(#lObjectAttributes, SizeOf(lObjectAttributes));
lStatus := LsaOpenPolicy(nil, lObjectAttributes, POLICY_LOOKUP_NAMES, lPolicyHandle);
if lStatus <> STATUS_SUCCESS then
begin
Result := LsaNtStatusToWinError(lStatus);
Exit;
end;
try
lTmpDomainLen := JwaLmCons.DNLEN; // In 'clear code' this should be get by LookupAccountName
SetLength(lTmpDomain, lTmpDomainLen);
lSidLen := SECURITY_MAX_SID_SIZE;
GetMem(lSid, lSidLen);
try
if LookupAccountName(nil, PChar(AAccountName), lSid, lSidLen, PChar(lTmpDomain),
lTmpDomainLen, lTmpSidNameUse) then
begin
lPrivilegeWStr := APrivilege;
lPrivilege.Buffer := PWideChar(lPrivilegeWStr);
lPrivilege.Length := Length(lPrivilegeWStr) * SizeOf(Char);
lPrivilege.MaximumLength := lPrivilege.Length;
lStatus := LsaAddAccountRights(lPolicyHandle, lSid, #lPrivilege, 1);
Result := LsaNtStatusToWinError(lStatus);
end else
Result := GetLastError;
finally
FreeMem(lSid);
end;
finally
LsaClose(lPolicyHandle);
end;
end;
procedure TForm2.Button1Click(Sender: TObject);
var
lStatus: DWORD;
begin
lStatus := AddPrivilegeToAccount('Administrators'{or any account/group name}, 'SeServiceLogonRight');
if lStatus = ERROR_SUCCESS then
Caption := 'OK'
else
Caption := SysErrorMessage(lStatus);
end;