I'm writing a DLL to interface with Game Maker. (Game maker only deals in Doubles.)
Here's a function:
function CreateBitmap(W, H: Double): Double;
var
TBM: TBitmap;
begin
TBM := TBitmap.Create(Floor(W), Floor(H));
CreateBitmap := Double(Integer(#TBM));
end;
So when I get the Double back:
function DestroyBitmap(Handle: Double);
begin
<How do I free it?>
end;
How do I free this Double? I tried doing
function DestroyBitmap(Handle: Double);
var
Blittable: IBlittable;
begin
Blittable := Pointer(Floor(Handle))^
Blittable.Free;
end;
But since the pointer's type cannot be determined, the Blittable (IBlittable) cannot be set to "untyped".
How do I free this pointer without leaking memory?
Remove # - that gets the address of the local variable:
function CreateBitmap(W, H: Double): Double;
var
TBM: TBitmap;
begin
TBM := TBitmap.Create(Floor(W), Floor(H));
CreateBitmap := Double(Integer(TBM));
end;
function DestroyBitmap(Handle: Double);
var
bmp: TBitmap;
begin
bmp := TBitmap(integer(Handle));
bmp.Free;
end;
Related
I want to correct the last-access time of some files.
Doing that programmatically fails - by one hour - for some files.
Mysterious, as I do correct the date according to the timezone.
Here is an example, tested for Delphi2010 (that's where I would need code for) and Delphi10.3
function GetTempDir : string;
var path : array[0..MAX_PATH] of char;
PathStr : string;
begin
GetTempPath(MAX_PATH, path);
PathStr:=path;
result:=IncludeTrailingPathDelimiter(PathStr);
end;
function UTCDateTimeFromLocalDateTime(const LocalDateTime: TDateTime): TDateTime;
var
LocalSystemTime: TSystemTime;
UTCSystemTime: TSystemTime;
LocalFileTime: TFileTime;
UTCFileTime: TFileTime;
begin
DateTimeToSystemTime(LocalDateTime, UTCSystemTime);
SystemTimeToFileTime(UTCSystemTime, UTCFileTime);
if LocalFileTimeToFileTime(UTCFileTime, LocalFileTime)
and FileTimeToSystemTime(LocalFileTime, LocalSystemTime) then begin
Result := SystemTimeToDateTime(LocalSystemTime);
end else begin
Result := LocalDateTime;
end;
end;
function SetFileTimesHelper(const FileName: string; DateTime: TDateTime): Boolean;
var
Handle: THandle;
FileTime: TFileTime;
SystemTime: TSystemTime;
begin
Result := False;
Handle := CreateFile(PChar(FileName), GENERIC_WRITE, FILE_SHARE_READ, nil,
OPEN_EXISTING, 0, 0);
if Handle <> INVALID_HANDLE_VALUE then
try
DateTime:=UTCDateTimeFromLocalDateTime(DateTime);
DateTimeToSystemTime(DateTime, SystemTime);
FileTime.dwLowDateTime := 0;
FileTime.dwHighDateTime := 0;
if SystemTimeToFileTime(SystemTime, FileTime) then
begin
Result := SetFileTime(Handle, nil, nil, #FileTime);
end;
finally
CloseHandle(Handle);
end;
end;
procedure TForm1.CreateDateFile(Dat : TDateTime);
var FileName : string;
begin
FileName:=GetTempDir+FormatDateTime('yyyymmdd hhnnss', Dat)+'.txt';
Memo1.Lines.Add(FileName);
with TStringList.Create do
begin
text:='1';
SaveToFile(FileName);
Free;
end;
SetFileTimesHelper(FileName, Dat);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
CreateDateFile(StrToDateTime('23.02.2013 11:11:11'));
CreateDateFile(StrToDateTime('06.05.2014 22:22:22')); // file dated 23:22:22
end;
The first file is correctly dated, the 2nd is displayed in the windows explorer with 23:22:22.
What do I miss?
Thanks brian for the comment.
Digging that way I found a solution:
GetTimeZoneInformation(tz);
SystemTimeToTzSpecificLocalTime(#tz, UTCSystemTime, LtSystemTime);
I didn't find the inverse function of SystemTimeToTzSpecificLocalTime, but I used this function and then see the resulting offset. Then I invert the offset and the time is properly corrected.
I'm implementing a program in FreePascal in Win10(64-bit). The problem state:
'Given a string, replace all substring 'child' with 'childhood' '
or
'Replace all 'child' with 'childhood''
I try this program
uses crt;
var s, newS : string;
tmp, tmp2, tmp3 : int64;
tmpstr, tmpstr2 : string;
step, step2, step3 : longint;
position : longint;
begin
clrscr;
write('Nhap xau : '); readln(s);
//main mechanism
while pos('child',s) <> 0 do begin
position := pos('child', s);
delete(s, pos('child',1), 5);
insert('childhood',s,position);
inc(position, 9);
newS := '';
for step:=position to length(s) do begin
newS := newS + s[step];
end;
s := newS;
end;
writeln(s);
readkey;
end.
You can see that this part:
inc(position, 9);
newS := '';
for step:=position to length(s) do begin
newS := newS + s[step];
end;
s := newS;
was used to try to cut off the while loop, but it doesn't work. Any idea?
Thanks a lot and have a good day! Thanks for reading this question thread! =)
This is just one of the possibilities, not optimized but perhaps the easiest to understand:
oldstr := 'original child string';
newstr := '';
while oldstr<>'' do begin
// analyze the string from left to right
if copy(oldstr, 1 5)='child' then begin
// match found, perform substitution
newstr := newstr+'childhood';
delete(oldstr, 1, 5)
end else begin
// does not match, go ahead to the next possibility
newstr := newstr+oldstr[1];
delete(oldstr, 1, 1)
end
end
// now newstr is the desired result
The gotcha here was to not analyze again what was added in a previous step (child->childhood). The algorithm above (warning, I've not tested it) ensures that any single char from the original string is checked only once.
i am tying to use the script
procedure BarCodeResize(Bc : TfrxBarCodeView);
var
r : TfrxRect;
begin
bc.Text := '1234567890 test 1234567890 asdf 1234567890';
r := bc.GetRealBounds;
bc.Zoom := bc.Width/(r.Right - r.Left);
frxReport1.ShowReport();
end;
but it shows me an error at line 'r : TfrxRect;'
Explanation:
If I understand your question correctly, you may consider the following:
If you want to use a type, you need to call AddType() method of TfsScript class.
In FastScript, only published methods of added classes are implemented. If you want to use public method (GetRealBounds for example), you need to use AddMethod() method of TfsScript.
The problem with your script (even if you add type TfrxRect) is, that TfrxRect is packed record, and FastScript do not support records. So, you may define your own TfrxBarCodeView class with appropriate methods.
Тхе example белов demonstrates one possible way to solve your problem (it uses Delphi, but I was able to reproduce and solve your error).
Delphi part:
unit FMainBarcode;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, frxClass, fs_iinterpreter, frxBarcode;
type
TForm1 = class(TForm)
Button1: TButton;
frxReport1: TfrxReport;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
type
TfrxMyBarCodeView = class(TfrxBarCodeView)
public
constructor Create(AOwner: TComponent); override;
function GetRealBoundsRight: double;
function GetRealBoundsLeft: double;
end;
type
TFunctions = class(TfsRTTIModule)
private
function CallMethod(Instance: TObject; ClassType: TClass; const MethodName: String; Caller: TfsMethodHelper): Variant;
public
constructor Create(AScript: TfsScript); override;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
begin
// Show report
frxReport1.ShowReport;
end;
{ TMyfrxBarCodeView }
constructor TfrxMyBarCodeView.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
end;
function TfrxMyBarCodeView.GetRealBoundsLeft: double;
begin
Result := GetRealBounds.Left;
end;
function TfrxMyBarCodeView.GetRealBoundsRight: double;
begin
Result := GetRealBounds.Right;
end;
{ TFunctions }
constructor TFunctions.Create(AScript: TfsScript);
begin
inherited Create(AScript);
// Add type
AScript.AddType('TfrxRect', fvtVariant);
// Add public method
with AScript.FindClass('TfrxBarCodeView') do begin
AddMethod('function GetRealBounds: TfrxRect', CallMethod);
end{with};
// Add class and public methods
with AScript.AddClass(TfrxMyBarCodeView, 'TfrxBarCodeView') do begin
AddMethod('function GetRealBoundsRight: double', CallMethod);
AddMethod('function GetRealBoundsLeft: double', CallMethod);
end{with};
end;
function TFunctions.CallMethod(Instance: TObject; ClassType: TClass; const MethodName: String; Caller: TfsMethodHelper): Variant;
begin
Result := 0;
if (ClassType = TfrxBarCodeView) and (MethodName = 'GETREALBOUNDS') then begin
//Result := TfrxBarCodeView(Instance).GetRealBounds;
end{if};
if (ClassType = TfrxMyBarCodeView) and (MethodName = 'GETREALBOUNDSRIGHT') then begin
Result := TfrxMyBarCodeView(Instance).GetRealBoundsRight;
end{if};
if (ClassType = TfrxMyBarCodeView) and (MethodName = 'GETREALBOUNDSLEFT') then begin
Result := TfrxMyBarCodeView(Instance).GetRealBoundsLeft;
end{if};
end;
initialization
fsRTTIModules.Add(TFunctions);
end.
Fast report code:
procedure BarCodeResize(Bc : TfrxMyBarCodeView);
var
R, L : double;
begin
Bc.Text := '1234567890 test 1234567890 asdf 1234567890';
R := Bc.GetRealBoundsRight * fr1CharX / fr01cm;
L := Bc.GetRealBoundsLeft * fr1CharX / fr01cm;
Bc.Zoom := Bc.Width / (R - L);
ShowMessage('Right: ' + FloatToStr(R) + ', Left: ' + FloatToStr(L));
end;
procedure Page1OnBeforePrint(Sender: TfrxComponent);
begin
BarCodeResize(TfrxMyBarCodeView(BarCode1));
end;
begin
end.
Notes:
Tested with Delphi 7, FastReport 4.7, FastScript 1.7.
what is the best method to do this: i have a txt file filled with web addresses, i have to check all of them using idHTTP component,only a simple check from a web server, downloading the html and finding a match, i want it to to be fast, there is different types of threads and i am not sure what is the best to use, a TParallel for or Task threads or regular threads?
i tried before TParallel for and i got stuck at AV, also i've tried Task threads but its not fast, the http request becomes slower by time, i tried also the regular threads and i didnt know how to use it because its complicated to use.
note: Please do NOT downvote i just need advice from the experts. Thank you
First advice: do not use Indy. Use THTTPClient (unit System.Net.HttpClient) -- native for Delphi XE?+
I am still using old TThreads. I could make suggestion only with TThread.
Workflow:
Main thread -- reading your TXT file line by line.
After line was readed, you create NEW thread, which are downloading information from WWW.
Sample of application:
unit ufmMain;
interface
uses
Winapi.Windows, Winapi.Messages,
System.SysUtils, System.Variants,
{ TThread }
System.Classes,
Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
TLoad = class(TThread)
protected
FURL,
FOutputFileName: String;
procedure Execute; override;
public
constructor Create(const AURL, AOutputFileName: String); overload;
end;
HTTP = class
public
class procedure Get(const AURL: String; out AOutputStream: TMemoryStream);
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
uses
{ THTTPClient }
System.Net.HttpClient;
procedure TForm1.Button1Click(Sender: TObject);
var
LLoad: TLoad;
LFile: TextFile;
LCycle: Integer;
LUrl: String;
begin
LCycle := 0;
AssignFile(LFile, 'urls.txt');
try
Reset(LFile);
while not Eof(LFile) do
begin
{ Using for generate file name. All file names must be unique }
Inc(LCycle);
{ Read next URL }
ReadLn(LFile, LUrl);
{ Create new thread }
LLoad := TLoad.Create(LUrl, 'Output file No ' + LCycle.ToString + '.htm');
LLoad.FreeOnTerminate := True;
LLoad.Start;
end;
finally
CloseFile(LFile);
end;
end;
{ TLoad }
constructor TLoad.Create(const AURL, AOutputFileName: String);
begin
inherited Create(True);
FURL := AURL;
FOutputFileName := AOutputFileName;
end;
procedure TLoad.Execute;
var
LResponse: TMemoryStream;
begin
inherited;
LResponse := TStringStream.Create;
try
HTTP.Get(FURL, LResponse);
{ Save result to file }
LResponse.SaveToFile(GetCurrentDir + PathDelim + FOutputFileName);
finally
LResponse.Free;
end;
end;
{ HTTP }
class procedure HTTP.Get(const AURL: String; out AOutputStream: TMemoryStream);
var
LStream: TStream;
LHTTPClient: THTTPClient;
begin
LHTTPClient := THTTPClient.Create;
try
LStream := LHTTPClient.Get(AURL).ContentStream;
AOutputStream.CopyFrom(LStream, LStream.Size);
finally
LHTTPClient.Free;
end;
end;
end.
Why I against Indy:
1) THTTPClient do not required additional DLL for works with SSL protocol
2) THTTPClient is modern from Delphi XE8
3) My subjective opinion: THTTPClient works much more smoothly (with less issues) then Indy library. I used Indy for last 10 years, but now all my supported project moved to THTTPClient.
You can use TTask and Indy (TIdHTTP). Example:
function GetUrl(const aUrl: string): ITask;
begin
Result := TTask.Run(
procedure
var
FOutput: string;
FHTTP: TIdHTTP;
begin
FHTTP:=TIdHTTP.Create(nil);
try
try
FOutput:=FHTTP.Get(aUrl);
except
// handle errors
end;
finally
FHTTP.Free;
end;
TThread.Synchronize(nil,
procedure
begin
ProcessOutput(FOutput); // send your output/result to main thread
end);
end );
end;
procedure TForm1.Button1Click(Sender: TObject);
var
i: Integer;
list: TStringList;
begin
list:=TStringList.Create;
try
list.LoadFromFile('yourfile.txt');
// get all your urls
// you should control how many threads run at the same time
for i := 0 to list.Count-1 do
GetUrl(list[i]);
finally
list.Free;
end;
end;
I´m trying to port the following javascript code to inno-setup pascal script:
var adminManager = new ActiveXObject('Microsoft.ApplicationHost.AdminManager');
var appPoolsSection = adminManager.GetAdminSection('system.applicationHost/applicationPools', 'MACHINE/WEBROOT/APPHOST');
var appPoolsCollection = applicationPoolsSection.Collection;
for (var i = 0; i < appPoolsCollection.Count; i++)
{
var appPool = appPoolsCollection.Item(i);
// doing someting with the application pool
}
This code has been translated to this:
var AdminManager, AppPoolsSection, AppPoolsCollection, AppPool: Variant;
i: Integer;
begin
AdminManager := CreateOleObject('Microsoft.ApplicationHost.AdminManager');
AppPoolsSection := AdminManager.GetAdminSection('system.applicationHost/applicationPools', 'MACHINE/WEBROOT/APPHOST');
AppPoolsCollection := AppPoolsSection.Collection;
for i := 0 to AppPoolsCollection.Count-1 do begin
AppPool := AppPoolsCollection.Item(i);
// doing someting with the application pool
end;
end;
But it is raising the following error on line AppPoolsCollection := AppPoolsSection.Collection:
Exception: Could not convert variant of type (Unknown) into type (Dispatch).
There are any thing that I can do to inform to pascal scritp that the AppPoolsSection object is an IDispach and not only an IUnknown?
I found a solution that works and is simpler than "import" the interfaces definition.
All the COM components used in this code implements IDispatch (it is required to use on VBScript or JScript), then I imported the VariantChangeType function to cast the IUnknown reference to an IDispatch reference (as it appears not to be supported on pascal script).
Follow the final code:
function VariantChangeType(out Dest: Variant; Source: Variant; Flags, vt: Word): HRESULT; external 'VariantChangeType#oleaut32.dll stdcall';
function VarToDisp(Source: Variant): Variant;
begin
Result := Unassigned;
OleCheck(VariantChangeType(Result, Source, 0, varDispatch));
end;
procedure EnumerateAppPools(AppPools: TStrings);
var AdminManager, Section, Collection, Item, Properties: Variant;
i: Integer;
begin
AdminManager := CreateOleObject('Microsoft.ApplicationHost.AdminManager');
Section := VarToDisp(AdminManager.GetAdminSection('system.applicationHost/applicationPools', 'MACHINE/WEBROOT/APPHOST'));
Collection := VarToDisp(Section.Collection);
for i := 0 to Collection.Count-1 do begin
Item := VarToDisp(Collection.Item(i));
Properties := VarToDisp(Item.Properties);
if (VarToDisp(Properties.Item('managedPipelineMode')).Value = 1) and
(VarToDisp(Properties.Item('managedRuntimeVersion')).Value = 'v4.0') then
AppPools.Add(VarToDisp(Properties.Item('name')).Value);
end;
end;