Using: Delphi 2010 and the JEDI Windows API and JWSCL
I am trying to assign the Logon As A Service privilege to a user using LsaAddAccountRights function but it does not work ie. after the function returns, checking in Group Policy Editor shows that the user still does not have the above mentioned privilege.
I'm running the application on Windows XP.
Would be glad if someone could point out what is wrong in my code:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, JwaWindows, JwsclSid;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
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;
lPrivilegeWStr: String;
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 := 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 := PChar(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 TForm1.Button1Click(Sender: TObject);
begin
AddPrivilegeToAccount('Sam', 'SeServiceLogonRight');
end;
end.
Thanks in advance.
To be able to use LsaAddAccountRights you should open policy handle with additional POLICY_CREATE_ACCOUNT flag (POLICY_CREATE_ACCOUNT | POLICY_LOOKUP_NAMES) in LsaOpenPolicy or use MAXIMUM_ALLOWED instead of both flags.
Related
Delphi 7 / QuickReport 5.02.2
We've used similar code for several years but have run into an issue recently now that we're migrating workstations to Windows 10. Previously, we were using Windows 7 and all was fine. Maybe there's something I'm missing or doing wrong?
Here's a simple test project I put together to test this. When the report is within a DLL every call to Printer.GetPrinter fails in Windows 10. Though, if the report is on a form within the main application it works fine.
Below is the code, and a zipped up folder for anyone that's interested. There is the dependency on QuickReport though, which can't be helped. Thanks for looking.
https://1drv.ms/u/s!AsbtokV75aocsXM6MQZcrvwpHKcg
DLL Project.
library test_dll;
uses
SysUtils,
Classes,
Forms,
report in 'report.pas' {report_test};
{$R *.res}
function Report_Print(PrinterName: Widestring): Integer; export;
var
Receipt: Treport_test;
begin
try
Receipt := Treport_test.Create(nil);
try
Receipt.Print(PrinterName);
Receipt.Close;
finally
Receipt.Free;
end;
except
Application.HandleException(Application.Mainform);
end;
Result := 1;
end;
exports
Report_Print;
begin
end.
Report Unit
unit report;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, QRCtrls, QuickRpt, ExtCtrls, Printers, QRpCtrls, QRPrntr;
type
Treport_test = class(TForm)
QuickRep1: TQuickRep;
DetailBand1: TQRBand;
TitleBand1: TQRBand;
QRLabel1: TQRLabel;
SummaryBand1: TQRBand;
QRLabel2: TQRLabel;
QRLabel3: TQRLabel;
private
{ Private declarations }
public
{ Public declarations }
procedure Print(const PrinterName: string);
end;
var
report_test: Treport_test;
procedure SetupPrinter(QuickRep: TQuickRep; const PrinterName: string);
function SelectPrinter(QuickRep: TQuickRep; const PrinterName: string): boolean;
implementation
var
DLL_QRPrinter: TQRPrinter;
{$R *.dfm}
function SelectPrinter(QuickRep: TQuickRep; const PrinterName: string): boolean;
var
i: integer;
compareLength: integer;
windowsPrinterName: string;
selectedPrinter: Integer;
defaultPrinterAvailable: Boolean;
begin
defaultPrinterAvailable := True;
try // an exception will occur if there is no default printer
i := Printer.printerIndex;
if i > 0 then ; // this line is here so Delphi does not generate a hint
except
defaultPrinterAvailable := False;
end;
compareLength := Length(PrinterName);
if (not Assigned(QuickRep.QRPrinter)) then
begin
QuickRep.QRPrinter := DLL_QRPrinter;
end;
// Look for the printer.
selectedPrinter := -1;
// Attempt #1: first try to find an exact match
for i := 0 to QuickRep.QRPrinter.Printers.Count - 1 do
begin
windowsPrinterName := Copy(QuickRep.QRPrinter.Printers.Strings[i], 1, compareLength);
if (UpperCase(windowsPrinterName) = UpperCase(PrinterName)) then
begin
selectedPrinter := i;
Break;
end;
end;
// Attempt #2: if no exact matches, look for the closest
if (selectedPrinter < 0) then
for i := 0 to QuickRep.QRPrinter.Printers.Count - 1 do
begin
windowsPrinterName := Copy(QuickRep.QRPrinter.Printers.Strings[i], 1, compareLength);
if (Pos(UpperCase(PrinterName), UpperCase(QuickRep.QRPrinter.Printers.Strings[i])) > 0) then
begin
selectedPrinter := i;
Break;
end;
end;
// Attempt #3: if no exact matches, and nothing close, use default printer
if (selectedPrinter < 0) and (defaultPrinterAvailable) then
selectedPrinter := QuickRep.Printer.printerIndex;
Result := False;
if (selectedPrinter > -1) then
begin
QuickRep.PrinterSettings.PrinterIndex := selectedPrinter;
Result := True;
end;
end;
procedure SetupPrinter(QuickRep: TQuickRep; const PrinterName: string);
begin
//check if we have the default printer instead of the selected printer
SelectPrinter(QuickRep, PrinterName);
QuickRep.Page.Units := Inches;
QuickRep.Page.Length := 11;
end;
procedure Treport_test.Print(const PrinterName: string);
begin
SetupPrinter(QuickRep1, PrinterName);
QuickRep1.Print;
end;
initialization
DLL_QRPrinter := TQRPrinter.Create(nil);
finalization
DLL_QRPrinter.Free;
DLL_QRPrinter := nil;
end.
Test Application
program Project1;
uses
Forms,
Unit1 in 'Unit1.pas' {Form1};
{$R *.res}
begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
Main Form
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, QRPrntr,
Dialogs, StdCtrls, QuickRpt, QRCtrls, ExtCtrls, Printers, QRPCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
type
TPrintReport = function(PrinterName: Widestring): Integer;
var
Form1: TForm1;
procedure PrintReport(const PrinterName: string);
implementation
var
DLLHandle: THandle = 0;
POS: TPrintReport = nil;
{$R *.dfm}
procedure PrintReport(const PrinterName: string);
begin
try
POS(PrinterName);
except on e: Exception do
ShowMessage(e.Message);
end;
end;
procedure LoadDLL;
var
DLLName: string;
DLLRoutine: PChar;
begin
DLLName := 'test_dll.dll';
DLLRoutine := 'Report_Print';
if not (FileExists(DLLName)) then
raise Exception.CreateFmt('The DLL "%s" is missing. Build the DLL project and try again.', [DLLName]);
Application.ProcessMessages;
DLLHandle := LoadLibrary(PChar(DLLName));
Application.ProcessMessages;
if (DLLHandle = 0) then
raise Exception.CreateFmt('Error: %s, while attempting to load DLL %s.', [IntToStr(GetLastError), DLLName]);
POS := GetProcAddress(DLLHandle, DLLRoutine);
if (#POS = nil) then
raise Exception.CreateFmt('Error: %s, while attempting get address to %s in DLL %s.', [IntToStr(GetLastError), DLLRoutine, DLLName]);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
LoadDLL;
ShowMessage('dll loaded');
PrintReport('MyPrinter');
FreeLibrary(DLLHandle);
end;
end.
Snippet from QuickReport
procedure TPrinterSettings.ApplySettings;
var
Cancel : boolean;
begin
FPrinter.GetPrinter(FDevice, FDriver, FPort, DeviceMode);
DevMode := GlobalLock(DeviceMode);
begin
SetField(dm_paperlength);
...
DeviceMode is 0, so SetField throws an access violation. See below.
Access violation at address 036BFBA7 in module 'test_dll.dll'. Write of address 00000028.
Try comment out those 2 lines for GetPrinter and for DevMode
procedure TPrinterSettings.ApplySettings;
var
Cancel : boolean;
begin
// FPrinter.GetPrinter(FDevice, FDriver, FPort, DeviceMode);
// DevMode := GlobalLock(DeviceMode);
begin
SetField(dm_paperlength);
...
end
uses ComObj, ActiveX, StdVcl;
if Printer.Printers.Count>0 then
begin
FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
FWMIService := FSWbemLocator.ConnectServer('localhost', 'root\CIMV2', '', '');
FWbemObject := FWMIService.Get(Format('Win32_Printer.DeviceID="%s"',[Printer.Printers.Strings[0]]));
if not VarIsClear(FWbemObject) then
FWbemObject.SetDefaultPrinter();
end;
new solution
Windows 10 have not default printer with this code u can set the default printer
After installed MS Powerpoint Viewer, I run the code below
unit Unit1;
interface
uses Comobj,
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls,Office_TLB, office97, PowerPointXP;//, ExtCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Panel1: TPanel;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
const
ppShowTypeSpeaker = 1;
ppShowTypeInWindow = 1000;
SHOW_FILE = 'C:\Users\myname\Downloads\practicepowerpoint.ppt';
var
oPPTApp: OleVariant;
oPPTPres: OleVariant;
screenClasshWnd: HWND;
pWidth, pHeight: Integer;
function PixelsToPoints(Val: Integer; Vert: Boolean): Integer;
begin
if Vert then
Result := Trunc(Val * 0.75)
else
Result := Trunc(Val * 0.75);
end;
begin
try
oPPTApp := CreateOleObject('PowerPoint.Application');
except
showmessage('no ppt');;
exit;
end;
oPPTPres := oPPTApp.Presentations.Open(SHOW_FILE, True, True, False);
pWidth := PixelsToPoints(Panel1.Width, False);
pHeight := PixelsToPoints(Panel1.Height, True);
oPPTPres.SlideShowSettings.ShowType := ppShowTypeSpeaker;
oPPTPres.SlideShowSettings.Run.Width := pWidth;
oPPTPres.SlideShowSettings.Run.Height := pHeight;
screenClasshWnd := FindWindow('screenClass', nil);
Windows.SetParent(screenClasshWnd, Panel1.Handle);
end;
end.
the line
oPPTApp := CreateOleObject('PowerPoint.Application');
causes error.
Just wonder if I have to install Powerpoint rather than Powerpoint Viewer before run the code
Your comment welcome
Yes, "Powerpoint.Application" starts Powerpoint. I would not recommend to use the powerpoint viewer because it is a really old program (from 2010 and before). I am not shure if you can automate this program.
The new way to view pptx is Powerpoint online
I want to develop a COM DLL in delphi that will internally create a window or form and then display the TWebBrowser navigation on that. The reason of this is I don't want to use the TWebbrowser control to be drag on each of my client app. This client app simply use this DLL because this DLL will also has some other logic that is not relevent to mention here.
Please help me how to achieve this
You should heed the reservations of the other posters, but if you want a dll that launches a TWebBrowser this should get you started. It compiles and runs but has only been very briefly tested.
Hope that helps.
library BrowserDLL;
uses
ShareMem,
SysUtils,
Classes,
Forms,
Windows,
DLLMainForm in 'DLLMainForm.pas' {MainForm};
{$R *.RES}
function ShowBrowserForm(AHandle: THandle; const AURL : String): Longint; stdcall;
begin
Application.Handle := AHandle;
result := TMainForm.ShowForm(AURL);
end;
exports
ShowBrowserForm;
var
DLLApplication : TApplication;
procedure DLLHandler(Reason: Integer);
begin
case Reason of
DLL_PROCESS_DETACH:
begin
Application := DLLApplication;
end;
end;
end;
begin
DLLApplication := Application;
DLLproc:=#DLLHandler;
end.
unit DLLMainForm;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
OleCtrls, SHDocVw, ExtCtrls;
type
TMainForm = class(TForm)
wb1: TWebBrowser;
private
FURL: string;
procedure SetUrl(const Value: string);
public
class function ShowForm(const AURL: String): Longint;
property URL : string read FURL write SetUrl;
end;
implementation
{$R *.DFM}
{ TBrowserForm }
procedure TMainForm.SetUrl(const Value: string);
begin
if FURL <> Value then begin
FURL := Value;
wb1.Navigate(Value);
end;
end;
class function TMainForm.ShowForm(const AURL : String): Longint;
var
form: TMainForm;
begin
form := Create(Application);
try
form.URL := AURL;
form.ShowModal;
Result := LongInt(form);
finally
FreeAndNil(form);
end;
end;
end.
unit LauncherMainform;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, OleCtrls, SHDocVw;
type
TShowDllForm = function(AHandle : THandle; const AUrl : String) : LongInt; stdcall;
TMainForm = class(TForm)
edt1: TEdit;
btn1: TButton;
procedure btn1Click(Sender: TObject);
private
LibHandle : THandle;
end;
var
MainForm: TMainForm;
implementation
{$R *.DFM}
procedure TMainForm.btn1Click(Sender: TObject);
var
DLLProc : TShowDllForm;
begin
LibHandle := LoadLibrary(PChar('BrowserDLL.dll'));
if LibHandle <> 0 then begin
#DLLProc := GetProcAddress(LibHandle,'ShowBrowserForm');
if (#DLLProc <> nil) then try
DLLProc(Application.Handle, edt1.Text);
except
on E:Exception do
ShowMessage('Error Running dll.' + #13#10 + E.Message);
end;
end else
ShowMessage('Error Loading dll');
end;
end.
How can I get progress when I'm executing inno script from a command line compiler (iscc.exe)?
I can pipeline the output but I want to get % completed as well.
Use ISCmplr library instead. For an inspiration, a very basic Delphi InnoSetup compiler might look like this (of course without hardcoded paths). It uses the original CompInt.pas unit from InnoSetup source pack:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ComCtrls, CompInt;
const
CompLib = ISCmplrDLL;
CompPath = 'c:\Program Files (x86)\Inno Setup 5\';
CompScriptProc = {$IFNDEF UNICODE}'ISDllCompileScript'{$ELSE}'ISDllCompileScriptW'{$ENDIF};
type
TCompScriptProc = function(const Params: TCompileScriptParamsEx): Integer; stdcall;
PAppData = ^TAppData;
TAppData = record
Lines: TStringList;
LineNumber: Integer;
StatusLabel: TLabel;
ProgressBar: TProgressBar;
end;
type
TForm1 = class(TForm)
Label1: TLabel;
Button1: TButton;
ProgressBar1: TProgressBar;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
FCompLibHandle: HMODULE;
FCompScriptProc: TCompScriptProc;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
FCompLibHandle := SafeLoadLibrary(CompPath + CompLib);
if FCompLibHandle <> 0 then
FCompScriptProc := GetProcAddress(FCompLibHandle, CompScriptProc);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
if FCompLibHandle <> 0 then
FreeLibrary(FCompLibHandle);
end;
function CompilerCallbackProc(Code: Integer; var Data: TCompilerCallbackData;
AppData: Longint): Integer; stdcall;
begin
// in every stage you can cancel the compilation if you pass e.g. a Boolean
// field through the AppData by using the following line:
// Result := iscrRequestAbort;
Result := iscrSuccess;
case Code of
iscbReadScript:
with PAppData(AppData)^ do
begin
if Data.Reset then
LineNumber := 0;
if LineNumber < Lines.Count then
begin
Data.LineRead := PChar(Lines[LineNumber]);
Inc(LineNumber);
end;
end;
iscbNotifyStatus:
Form1.Label1.Caption := Data.StatusMsg;
iscbNotifyIdle:
begin
with PAppData(AppData)^ do
begin
ProgressBar.Max := Data.CompressProgressMax;
ProgressBar.Position := Data.CompressProgress;
StatusLabel.Caption := Format('Bitrate: %d B/s; Remaining time: %d s',
[Data.BytesCompressedPerSecond, Data.SecondsRemaining]);
Application.ProcessMessages;
end;
end;
iscbNotifySuccess:
ShowMessageFmt('Yipee! Compilation succeeded; Output: %s', [Data.OutputExeFilename]);
iscbNotifyError:
ShowMessageFmt('An error occured! File: %s; Line: %d; Message: %s', [Data.ErrorFilename,
Data.ErrorLine, Data.ErrorMsg]);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
CustData: TAppData;
CompParams: TCompileScriptParamsEx;
begin
if Assigned(FCompScriptProc) then
begin
CustData.Lines := TStringList.Create;
try
CustData.Lines.LoadFromFile('c:\Program Files (x86)\Inno Setup 5\Examples\Example1.iss');
CustData.LineNumber := 0;
CustData.StatusLabel := Label1;
CustData.ProgressBar := ProgressBar1;
CompParams.Size := SizeOf(CompParams);
CompParams.CompilerPath := CompPath; // path to the folder containing *.e32 files (InnoSetup install folder)
CompParams.SourcePath := 'c:\Program Files (x86)\Inno Setup 5\Examples\'; // path to the script file to be compiled
CompParams.CallbackProc := CompilerCallbackProc; // callback procedure which the compiler calls to read the script and for status notifications
Pointer(CompParams.AppData) := #CustData; // custom data passed to the callback procedure
CompParams.Options := ''; // additional options; see CompInt.pas for description
if FCompScriptProc(CompParams) <> isceNoError then
ShowMessage('Compiler Error');
finally
CustData.Lines.Free;
end;
end;
end;
end.
im new to delphi. and also almost new to programming world.
i was made some simple post software which using idhttp module.
but when execute it , it not correctly working.
this simple program is check for my account status.
if account login successfully it return some source code which include 'top.location ='
in source, and if login failed it return not included 'top.location ='
inside account.txt is follow first and third account was alived account
but only first account can check, after first account other account can't check
i have no idea what wrong with it
ph896011 pk1089
fsadfasdf dddddss
ph896011 pk1089
following is source of delphi
if any one help me much apprecated!
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, IdBaseComponent, IdComponent, IdTCPConnection,
IdTCPClient, IdHTTP, IdCookieManager, ExtCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
IdHTTP1: TIdHTTP;
Memo1: TMemo;
IdCookieManager1: TIdCookieManager;
lstAcct: TListBox;
result: TLabel;
Edit1: TEdit;
Timer1: TTimer;
procedure Button1Click(Sender: TObject);
//procedure FormCreate(Sender: TObject);
//procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
{ Private declarations }
public
AccList: TStringList;
IdCookie: TIdCookieManager;
CookieList: TList;
StartCnt: Integer;
InputCnt: Integer;
WordList: TStringList;
WordNoList: TStringList;
WordCntList: TStringList;
StartTime: TDateTime;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
var
i: Integer;
//temp: String;
lsttemp: TStringList;
sl : tstringlist;
//userId,userPass: string;
begin
InputCnt:= 0;
WordList := TStringList.Create;
CookieList := TList.create;
IdCookie := TIdCookieManager.Create(self);
if FileExists(ExtractFilePath(Application.ExeName) + 'account.txt') then
WordList.LoadFromFile(ExtractFilePath(Application.ExeName) + 'account.txt');
WordNoList:= TStringList.Create;
WordCntList := TStringList.Create;
lsttemp := TStringList.create;
sl :=Tstringlist.Create;
try
try
for i := 0 to WordList.Count -1 do
begin
ExtractStrings([' '], [' '], pchar(WordList[i]), lsttemp);
WordNoList.add(lsttemp[0]);
//ShowMessage(lsttemp[0]);
WordCntList.add(lsttemp[1]);
//ShowMessage(lsttemp[1]);
sl.Add('ID='+ lsttemp[0]);
sl.add('PWD=' + lsttemp[1]);
sl.add('SECCHK=0');
IdHTTP1.HandleRedirects := True;
IdHTTP1.Request.ContentType := 'application/x-www-form-urlencoded';
memo1.Text:=idhttp1.Post('http://user.buddybuddy.co.kr/Login/Login.asp',sl);
if pos('top.location =',Memo1.Text)> 0 then
begin
application.ProcessMessages;
ShowMessage('Alive Acc!');
//result.Caption := 'alive acc' ;
sleep(1000);
Edit1.Text := 'alive acc';
lsttemp.Clear;
Memo1.Text := '';
//memo1.Text := IdHTTP1.Get('https://user.buddybuddy.co.kr/Login/Logout.asp');
Sleep(1000);
end;
if pos('top.location =', memo1.Text) <> 1 then
begin
application.ProcessMessages;
ShowMessage('bad');
Edit1.Text := 'bad';
//edit1.Text := 'bad';
lsttemp.Clear;
memo1.Text := '';
sleep(1000) ;
end;
Edit1.Text := '';
end;
finally
lsttemp.free;
end;
StartCnt := lstAcct.items.Count;
StartTime := Now;
finally
sl.Free;
end;
end;
end.
Right before:
sl.Add('ID='+ lsttemp[0]);
Do:
sl.Clear;
On the first run your "SL" holds the two POST parameters, but unless you clear it on the second run, you just keep adding parameters, confusing the HTTP server you're trying to connect to!
That might not be your only problem, but that's surely one of the problems.