unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls, ExtCtrls,
Spin, BGRAVirtualScreen, BGRABitmap, BGRABitmapTypes, OpenSSLSockets,
fphttpclient, RegExpr;
type
{ TForm1 }
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
Button3: TButton;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
ListBox1: TListBox;
Panel1: TPanel;
RadioButton1: TRadioButton;
RadioButton2: TRadioButton;
SpinEdit1: TSpinEdit;
SpinEdit2: TSpinEdit;
VirtualScreen: TBGRAVirtualScreen;
procedure BGRAVirtualScreenRedraw(Sender: TObject; Bitmap: TBGRABitmap);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure ListBox1SelectionChange(Sender: TObject; User: boolean);
procedure RadioButton1Change(Sender: TObject);
procedure RadioButton2Change(Sender: TObject);
private
FBitmap: TBGRABitmap;
public
end;
var
Form1: TForm1;
img_num, img_slot, mono: integer;
HttpClient: TFPHTTPClient;
MemStream: TMemoryStream;
ImageURL , ImageWWW, GameTitle : string;
implementation
{$R *.lfm}
function GetGameTitle(const URL: string): string;
var
HttpClient: TFPHTTPClient;
PageSource: TStringList;
Regex: TRegExpr;
RawTitle: string;
begin
Result := 'Title Not Found ';
HttpClient := TFPHTTPClient.Create(nil);
PageSource := TStringList.Create;
Regex := TRegExpr.Create;
try
try
// HTML
PageSource.Text := HttpClient.Get(URL);
Regex.Expression := '<title>(.*?)</title>';
if Regex.Exec(PageSource.Text) then
begin
RawTitle := Regex.Match[1];
RawTitle := StringReplace(RawTitle, '©', ' :', [rfReplaceAll]);
RawTitle := Trim(RawTitle);
while Pos(' ', RawTitle) > 0 do
RawTitle := StringReplace(RawTitle, ' ', ' ', [rfReplaceAll]);
Result := UpperCase(RawTitle);
end;
except
on E: Exception do
Result := 'Erreur: ' + E.Message;
end;
finally
HttpClient.Free;
PageSource.Free;
Regex.Free;
end;
end;
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
begin
FBitmap := nil;
img_num := SpinEdit1.value;
img_slot := SpinEdit2.value;
mono := 0; // 1 = set ; 0 = unset(color);
HttpClient := TFPHTTPClient.Create(nil);
MemStream := TMemoryStream.Create;
end;
procedure TForm1.BGRAVirtualScreenRedraw(Sender: TObject; Bitmap: TBGRABitmap);
var
DestRect: TRect;
begin
Bitmap.Fill(BGRAWhite);
if Assigned(FBitmap) then
begin
DestRect := Rect(0, 0, VirtualScreen.Width, VirtualScreen.Height);
Bitmap.StretchPutImage(DestRect, FBitmap, dmSet);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
PageURL: string;
begin
if Assigned(FBitmap) then FreeAndNil(FBitmap);
img_num := SpinEdit1.value;
img_slot := SpinEdit2.value;
Imagewww := 'https://www.cpc-power.com/extra_lire_fichier.php?extra=cpcold&fiche=';
ImageURL := Imagewww+inttostr(img_num)+'&slot='+inttostr(img_slot)+'&part=A&type=.png&green='+inttoStr(mono)+'';
PageURL := 'https://www.cpc-power.com/index.php?page=detail&num=' + IntToStr(img_num);
GameTitle := GetGameTitle(PageURL);
Label3.Caption := '' + GameTitle;
try
MemStream.Clear; // Réutilisation du même stream
HttpClient.Get(ImageURL, MemStream);
MemStream.Position := 0;
if MemStream.Size > 0 then
begin
FBitmap := TBGRABitmap.Create(MemStream);
// VirtualScreen.DiscardBitmap;
VirtualScreen.RedrawBitmap;
end
else
ShowMessage('Empty Image ...');
except
on E: Exception do
ShowMessage('Loading Error ...' + E.Message);
end;
Label1.Caption:= 'Game : '+ IntToStr(img_num);
Label2.Caption:= 'Slot : ' + IntToStr(img_slot);
end;
// add to favorite list
procedure TForm1.Button2Click(Sender: TObject);
var
game_name: String;
idx: Integer;
begin
idx := Pos(' : ', GameTitle);
if idx > 0 then
game_name := Copy(GameTitle, 1, idx - 1)
else
game_name := GameTitle;
ListBox1.Items.Add(IntToStr(img_num) + ' : ' + game_name);
end;
procedure TForm1.Button3Click(Sender: TObject);
begin
ListBox1.Clear;
end;
// get game_num from listbox
procedure TForm1.ListBox1SelectionChange(Sender: TObject; User: boolean);
var
lst_txt, lst_num : String;
idx : integer;
begin
lst_txt := ListBox1.GetSelectedText;
idx := Pos(' : ', lst_txt);
if idx > 0 then
lst_num := Copy(lst_txt, 1, idx - 1);
SpinEdit1.Value := StrToInt(lst_num);
ListBox1.Update;
button1.Click;
end;
procedure TForm1.RadioButton1Change(Sender: TObject);
begin
if RadioButton1.Checked then mono := 1;
button1.Click;
end;
procedure TForm1.RadioButton2Change(Sender: TObject);
begin
if RadioButton2.Checked then mono := 0;
button1.Click; // simulate click
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
FreeAndNil(FBitmap);
FreeAndNil(HttpClient);
FreeAndNil(MemStream);
end;
end.
Recent
