Inno setup command line progress - delphi

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.

Related

How to get volume level in current sample? Delphi 7

On Delphi 7 I am running this code with NewAC Audio library. I am having short wav file, 44.100 kHz, mono, 16 bit.
unit Main;
interface
uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, ACS_Classes, ACS_DXAudio, ACS_Wave, ACS_Misc, ACS_Types, StdCtrls;
type
TForm1 = class(TForm)
AudioProcessor1: TAudioProcessor;
WaveIn1: TWaveIn;
DXAudioOut1: TDXAudioOut;
OpenDialog1: TOpenDialog;
Button1: TButton;
Button2: TButton;
procedure AudioProcessor1GetData(
Sender: TComponent;
var Buffer: Pointer;
var NBlockBytes: Cardinal);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure DXAudioOut1Done(Sender: TComponent);
procedure AudioProcessor1Init(Sender: TComponent; var TotalSize: Int64);
procedure AudioProcessor1Flush(Sender: TComponent);
end;
var Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.AudioProcessor1GetData(Sender: TComponent;
var Buffer: Pointer; var NBlockBytes: Cardinal);
var Tmp : Integer;
i : Integer;
list1: TStringList;
list2: TStringList;
b1, b2, b3, b4:byte;
si1, si2, si3, si4: ShortInt;
mono: Boolean;
values: array of word;
begin
list1 := TStringList.Create;
list2 := TStringList.Create;
AudioProcessor1.Input.GetData(Buffer, NBlockBytes);
if Buffer = nil then
Exit;
mono := false;
case AudioProcessor1.Input.BitsPerSample of
16 :
begin
B16 := Buffer;
setlength(values, NBlockBytes div 2);
for i := 0 to (NBlockBytes div 4) - 1 do
begin
Tmp := B16[i*2];
move(B16[i*2], b1, 1); // copy left channel
move(B16[i*2+1], b2, 1); // copy right channel
move(B16[i*2+2], b3, 1); // copy left channel
move(B16[i*2+3], b4, 1); // copy right channel
si1 := b1;
si2 := b2;
si3 := b3;
si4 := b4;
list1.add(''+inttostr(si1));
list2.add(''+inttostr(si2));
list1.add(''+inttostr(si3));
list2.add(''+inttostr(si4));
B16[i*2] := B16[i*2 + 1];
B16[i*2 + 1] := Tmp;
end;
end;
end;
list1.free;
list2.free;
end;
procedure TForm1.AudioProcessor1Init(Sender: TComponent; var TotalSize: Int64);
begin
TAudioProcessor(Sender).Input.Init;
TotalSize := TAudioProcessor(Sender).Input.Size
end;
procedure TForm1.AudioProcessor1Flush(Sender: TComponent);
begin
TAudioProcessor(Sender).Input.Flush;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenDialog1.Execute then
begin
Button1.Enabled := False;
WaveIn1.FileName := OpenDialog1.FileName;
DXAudioOut1.Run;
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
DXAudioOut1.Stop;
end;
procedure TForm1.DXAudioOut1Done(Sender: TComponent);
begin
Button1.Enabled := True;
end;
end.
When I open the file in editing software I can see the amplitude of the sound and I see that the beginning values are 0. But when I run this program and I add the si1, si2, si3 and si4 to watch (in this order are the variables in watch), so I have these values in first iteration:
80,124,104,32.
I expected that these values should be 0 because there is silence on the begin.
First, may you explain why these are not zero?
Second, I am not sure what these values really represent. I know that si1 and si2 are first sample. But is it really level of the volume? How to correct the program to recognize the silence in the begin?
Tested file -> the section which should be passed to the function as first.
This part is not proccessed (because I processed only few cicles of the first loop):
I did some tests with file "silence plus", amplifications and see the first 8 cicles values.
Another test with word instead byte:
B16 := Buffer;
...
move(B16[i*2], w1, 2);
move(B16[i*2+1], w2, 2);
It really looks like the bits need to swap. I thought that in Windows XP I have little endian bit order. So I will write a swapper.
The main problems of my code were:
1) Reading 1 byte of sample instead 2 bytes of sample.
2) The sample is signed, not unsigned. So when I tried to read two bytes of word, I get wrong numbers (see the last table in question).
3) I also tried to use two bytes of SmallInt swapped, but that resulted to crazy numbers like -25345, -1281, 26624, -19968 ... This is because on my system I use Little endian (Windows XP). There is not need to swap it on Windows.
So the solution was to copy 16 bits to SmallInt, no swap.
unit Main;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ACS_Classes, ACS_DXAudio, ACS_Wave, ACS_Misc, ACS_Types, StdCtrls;
type
TForm1 = class(TForm)
AudioProcessor1: TAudioProcessor;
WaveIn1: TWaveIn;
DXAudioOut1: TDXAudioOut;
OpenDialog1: TOpenDialog;
Button1: TButton;
Button2: TButton;
procedure AudioProcessor1GetData(
Sender: TComponent;
var Buffer: Pointer;
var NBlockBytes: Cardinal);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure DXAudioOut1Done(Sender: TComponent);
procedure AudioProcessor1Init(Sender: TComponent; var TotalSize: Int64);
procedure AudioProcessor1Flush(Sender: TComponent);
private
{ Private declarations }
public
{ Public declarations }
end;
var Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.AudioProcessor1GetData(Sender: TComponent;
var Buffer: Pointer; var NBlockBytes: Cardinal);
var
B16 : PBuffer16;
i, end_ : Integer;
si1, si2: SmallInt;
begin
AudioProcessor1.Input.GetData(Buffer, NBlockBytes);
if Buffer = nil then
Exit;
case AudioProcessor1.Input.BitsPerSample of
16 :
begin
B16 := Buffer;
end_ := (NBlockBytes div 2) - 1;
for i := 0 to end_ do
begin
move(B16[i*2], si1, 2);
move(B16[i*2+1], si2, 2);
end;
end;
end;
end;
procedure TForm1.AudioProcessor1Init(Sender: TComponent; var TotalSize: Int64);
begin
TAudioProcessor(Sender).Input.Init;
TotalSize := TAudioProcessor(Sender).Input.Size
end;
procedure TForm1.AudioProcessor1Flush(Sender: TComponent);
begin
TAudioProcessor(Sender).Input.Flush;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenDialog1.Execute then
begin
Button1.Enabled := False;
WaveIn1.FileName := OpenDialog1.FileName;
DXAudioOut1.Run;
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
DXAudioOut1.Stop;
end;
procedure TForm1.DXAudioOut1Done(Sender: TComponent);
begin
Button1.Enabled := True;
end;
end.
Here are the values:

Unable to a print in Windows 10 when Delphi / QuickReport is within a DLL

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

Interfacing Octave and Lazarus/FreePascal with TProcess

I have also asked this question # the Lazarus forums, here
I am trying to communicate with Octave via a TProcess, but I don't seem to be able to read any bytes from it. Attached is the main form's unit; a full demo application is available as a zip from the forum under my post.
unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls, Process;
type
{ TForm1 }
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ private declarations }
public
{ public declarations }
end;
var
Form1: TForm1;
POctave: TProcess;
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.Button1Click(Sender: TObject);
begin
if (not POctave.Running) then
begin
POctave.Executable := 'C:\Octave\Octave-4.2.0\bin\octave-cli.exe';
POctave.Parameters.Add('--no-gui');
POctave.Options := [poUsePipes];
WriteLn('-- Executing octave --');
POctave.Execute;
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
var
command: string;
Buffer: string;
BytesAvailable: DWord;
BytesRead: longint;
NoMoreOutput: boolean;
begin
command := 'pwd' + #10;
if (POctave.Running) then
POctave.Input.Write(command, Length(command));
if (POctave.Running) then
begin
BytesAvailable := POctave.Output.NumBytesAvailable;
BytesRead := 0;
while BytesAvailable > 0 do
begin
SetLength(Buffer, BytesAvailable);
BytesRead := POctave.OutPut.Read(Buffer[1], BytesAvailable);
WriteLn(Buffer);
BytesAvailable := POctave.Output.NumBytesAvailable;
NoMoreOutput := False;
end;
end;
end;
initialization
POctave := TProcess.Create(nil);
finalization
POctave.Free;
end.
I've added sleep routines and changed the 'pwd' command's return to #1310, both without success.
procedure TForm1.Button2Click(Sender: TObject);
var
command: ansistring;
Buffer: string;
BytesAvailable: DWord;
BytesRead: longint;
NoMoreOutput: boolean;
begin
command := 'pwd'#13#10;
if (POctave.Running) then
POctave.Input.Write(command, Length(command));
Sleep(100);
if (POctave.Running) then
begin
Sleep(100);
BytesAvailable := POctave.Output.NumBytesAvailable;
BytesRead := 0;
while BytesAvailable > 0 do
begin
Sleep(100);
SetLength(Buffer, BytesAvailable);
BytesRead := POctave.OutPut.Read(Buffer[1], BytesAvailable);
WriteLn(Buffer);
BytesAvailable := POctave.Output.NumBytesAvailable;
NoMoreOutput := False;
end;
end;
end;
The problem was that I was calling this line:
POctave.Input.Write(command, Length(command));
instead of this:
POctave.Input.Write(command[1], Length(command));
After changing this (AND ADDING THE DELAY! It was absolutely critical to wait for the result, but my mistake was more fundamental.)
Remember: Pascal strings aren't C strings. Whoops...
It worked! Now I can send commands to Octave and retrieve the results via pipes. :)

How to create a default project under Delphi XE7?

Related to this question: Should "Library path" point to the source files of packages?
Fabricio Araujo suggested that is not necessary to set the 'search path' for each new project by creating a 'Default Project Option'. How can this be done in Delphi XE7?
Prompted by your q, and more for amusement than anything else, I decided to try
writing an IDE-plugin that would provide a way to store some preferred project
settings somewhere and allow you to apply them to the current project.
To use, prepare and save a sample .Ini file containing your preferred settings in the format shown below (it's important to get the project option names right, see below for how to do find them out), then compile the unit below into a new package and install it in the IDE. Its gui will pop up when you subsequently open a project.
The settings in the .Ini are loaded into a ValueList editor and pressing the
[Return] key in one of the values will apply it to the project.
Interestingly, the names the IDE uses for the Project seetings are the same in XE7
as they are in D7. Iow, the XE7 IDE uses these internally rather than the names
which appear in the .DProj XML file. You can get a full list of them by clicking the GetOptions button.
As usual when working with the IDE OTA services, the code has to include
a fair amount of "baggage".
Tested in D7 and XE7.
Sample Ini File:
[settings]
OutputDir=Somewhere
UnitOutputDir=Somewhere else
UnitDir=$(DELPHI)
ObjDir=$(DELPHI)
SrcDir=$(DELPHI)
ResDir=$(DELPHI)
Code:
unit ProjectOptionsXE7u;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls, ToolsAPI, Grids, ValEdit, IniFiles;
type
TProjectOptionsForm = class(TForm)
Panel1: TPanel;
Memo1: TMemo;
ValueListEditor1: TValueListEditor;
btnGetOptions: TButton;
procedure btnGetOptionsClick(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure ValueListEditor1KeyPress(Sender: TObject; var Key: Char);
private
function GetCurrentProject: IOTAProject;
procedure GetOptionsFromIni;
procedure UpdateOptionValue;
public
Services: IOTAServices;
ProjectGroup : IOTAProjectGroup;
Project: IOTAProject;
Options : IOTAProjectOptions;
ModServices: IOTAModuleServices;
Module: IOTAModule;
NotifierIndex: Integer;
Ini : TMemIniFile;
IsSetUp : Boolean;
SetUpCount : Integer;
procedure GetProjectOptions;
procedure SetUp;
end;
var
ProjectOptionsForm: TProjectOptionsForm;
procedure Register;
implementation
{$R *.dfm}
type
TIdeNotifier = class(TNotifierObject, IOTANotifier, IOTAIDENotifier)
protected
procedure AfterCompile(Succeeded: Boolean);
procedure BeforeCompile(const Project: IOTAProject; var Cancel: Boolean);
procedure FileNotification(NotifyCode: TOTAFileNotification;
const FileName: string; var Cancel: Boolean);
end;
procedure Register;
begin
ProjectOptionsForm:= TProjectOptionsForm.Create(Nil);
ProjectOptionsForm.Services := BorlandIDEServices as IOTAServices;
ProjectOptionsForm.NotifierIndex := ProjectOptionsForm.Services.AddNotifier(TIdeNotifier.Create);
end;
procedure CloseDown;
begin
ProjectOptionsForm.Services.RemoveNotifier(ProjectOptionsForm.NotifierIndex);
ProjectOptionsForm.Close;
ProjectOptionsForm.Free;
end;
procedure TIdeNotifier.AfterCompile(Succeeded: Boolean);
begin
end;
procedure TIdeNotifier.BeforeCompile(const Project: IOTAProject; var Cancel: Boolean);
begin
end;
procedure TIdeNotifier.FileNotification(NotifyCode: TOTAFileNotification;
const FileName: string; var Cancel: Boolean);
begin
if NotifyCode in [ofnProjectDesktopLoad, ofnActiveProjectChanged] then begin
ProjectOptionsForm.Show;
// ProjectOptionsForm.Memo1.Lines.Add('Got notification');
ProjectOptionsForm.SetUp;
// ProjectOptionsForm.Memo1.Lines.Add('after GetProjectOptions');
end;
end;
procedure TProjectOptionsForm.btnGetOptionsClick(Sender: TObject);
var
KeyName,
Value,
S : String;
V : Variant;
i : Integer;
begin
GetProjectOptions;
ValueListEditor1.Strings.Clear;
for i := Low(Options.GetOptionNames) to High(Options.GetOptionNames) do begin
try
KeyName := Options.GetOptionNames[i].Name;
if CompareText(KeyName, 'HeapSize') = 0 then
NoOp;
V := Options.Values[KeyName];
if not VarIsEmpty(V) then
Value := VarToStr(V)
else
Value := '';
ValueListEditor1.InsertRow(KeyName, Value, True);
except
// Reading some CPP-related settings cause exceptions
S := '***Error ' + KeyName; // + ': ' + IntToStr(Options.Values[KeyName].Kind);
Memo1.Lines.Add(S);
end;
end;
end;
procedure TProjectOptionsForm.FormDestroy(Sender: TObject);
begin
Ini.Free;
end;
procedure TProjectOptionsForm.GetOptionsFromIni;
var
i : Integer;
KeyName : String;
TL : TStringList;
begin
ValueListEditor1.Strings.Clear;
TL := TStringList.Create;
try
Ini.ReadSection('Settings', TL);
Assert(TL.Count > 0);
for i := 0 to TL.Count - 1 do begin
KeyName := TL[i];
ValueListEditor1.InsertRow(KeyName, Ini.ReadString('Settings', KeyName, ''), True);
end;
finally
TL.Free;
end;
end;
procedure TProjectOptionsForm.FormCreate(Sender: TObject);
var
IniFileName : String;
begin
IniFileName := 'd:\aaad7\ota\ProjectOptions.Ini'; // <beware of hard-code path
Ini := TMemIniFile.Create(IniFileName);
GetOptionsFromIni;
end;
function TProjectOptionsForm.GetCurrentProject: IOTAProject;
var
i: Integer;
begin
Result := nil;
ModServices := BorlandIDEServices as IOTAModuleServices;
for i := 0 to ModServices.ModuleCount - 1 do
begin
Module := ModServices.Modules[i];
if Supports(Module, IOTAProjectGroup, ProjectGroup) then begin
Result := ProjectGroup.ActiveProject;
Options := Result.ProjectOptions;
Exit;
end
else if Supports(Module, IOTAProject, Project) then
begin // In the case of unbound packages, return the 1st
if Result = nil then begin
Result := Project;
Options := Result.ProjectOptions;
end;
end;
end;
end;
procedure TProjectOptionsForm.GetProjectOptions;
begin
Assert(Project <> Nil, 'Project');
Options := Project.ProjectOptions;
end;
procedure TProjectOptionsForm.SetUp;
begin
Project := GetCurrentProject;
GetProjectOptions;
Inc(SetUpCount);
Caption := 'Setup done ' + IntToStr(SetUpCount);
IsSetUp := True;
end;
procedure TProjectOptionsForm.UpdateOptionValue;
var
Rect : TGridRect;
S : String;
KeyName,
Value : String;
Row,
Col : Integer;
begin
if Options = Nil then
Exit;
Rect := ValueListEditor1.Selection;
// S := 'left: %d top: %d right: %d, bottom: %d';
// S := Format(S, [Rect.Left, Rect.Top, Rect.Right, Rect.Bottom]);
// Memo1.Lines.Add(S);
Row := Rect.Bottom;
Col := Rect.Left - 1;
KeyName := ValueListEditor1.Cells[Col, Row];
Value := ValueListEditor1.Values[KeyName];
Options.SetOptionValue(KeyName, Value);
Options.ModifiedState := True;
Module.Save(False, False);
end;
procedure TProjectOptionsForm.ValueListEditor1KeyPress(Sender: TObject; var
Key: Char);
begin
if Key = #13 then
UpdateOptionValue;
end;
initialization
finalization
CloseDown;
end.
How this can be done in Delphi XE7?
It cannot. This functionality was removed I'm not sure exactly when, but it has not been present for some considerable time.
What you can do is:
Create a new project.
Change its settings however you please.
Save this modified project template to some central location.
Whenever you make a new project, do so by copying this project template.
You can integrate this process into the IDE by saving your modified project template into the Object Repository. Add a project to the repository with Project | Add to Repository.

delphi idhttp post related question

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.

Resources