Cannot read from my Resource (.res) file - delphi

I have written a simple loader to install my program and its help file.
unit PSInstaller;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Registry, Vcl.StdCtrls, HTMListB,
HTMLabel, System.Zip;
type
TfmPDSInstaller = class(TForm)
HTMLabel1: THTMLabel;
HTMListBox1: THTMListBox;
btnNext: TButton;
Button1: TButton;
procedure FormCreate(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure btnNextClick(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
function InstallFile(ResID: integer; pName: String): Boolean;
public
{ Public declarations }
end;
var
fmPDSInstaller: TfmPDSInstaller;
implementation
{$R 'ProtonStudio32.res' 'ProtonStudio32.rc'}
{$R *.dfm}
Var IDEDirectory: String;
Const APP = 100;
HELP = 200;
procedure TfmPDSInstaller.btnNextClick(Sender: TObject);
begin
HTMListBox1.AddItem('Copying Proton Studio to Proton IDE directory',nil);
if InstallFile(APP, 'Studio Application') then begin
HTMListBox1.AddItem('Copying Proton Studio Help to Proton IDE directory',nil);
If InstallFile(HELP, 'Studio Help') then
HTMListBox1.AddItem('Proton Studio Installed', nil);
end;
end;
function TfmPDSInstaller.InstallFile(ResID: integer; pName: String): Boolean;
Var rs: TResourceStream;
Zip: TZipFile;
s: String;
begin
Result := false;
try
Rs := TResourceStream.CreateFromID(HInstance, ResID, RT_RCDATA);
Zip := TZipFile.Create;
try
Zip.Open(Rs,zmRead);
Zip.ExtractAll(IDEDirectory);
finally
Rs.Free;
Zip.Free;
Result := true;
end;
except
on EFOpenError do
s := 'Unable to Open resource ' + pName;
else
s := 'Unable to Copy file from resource ' + pName;
end;
HTMListBox1.AddItem(s, nil);
end;
procedure TfmPDSInstaller.Button1Click(Sender: TObject);
begin
Close;
end;
procedure TfmPDSInstaller.FormCreate(Sender: TObject);
Var Reg: TRegistry;
begin
btnNext.Enabled := false;
Reg := TRegistry.Create;
HTMListBox1.AddItem('Checking for ProtonIDE',nil);
if Reg.OpenKey('Software\MecaniqueUK\ProtonIDE\Install', false) then begin
IDEDirectory := Reg.ReadString('IDE');
Reg.CloseKey;
end;
Reg.Free;
end;
procedure TfmPDSInstaller.FormShow(Sender: TObject);
begin
btnNext.Enabled := false;
if DirectoryExists(IDEDirectory) then begin
HTMListbox1.AddItem('Click Next to install Proton Studio in ' + IDEDirectory, nil);
btnNext.Enabled := true;
end
else
HTMListBox1.AddItem('Proton IDE must be installed first', nil);
end;
end.
I have created a .rc script to load my program and help
#100 RT_RCDATA "D:\Data\Documents\RAD Studio\Projects\ProtonNewIDE\Win32\Debug\ProtonNewIDE.zip"
#200 RT_RCDATA "D:\Data\Documents\RAD Studio\Projects\ProtonNewIDE\Win32\Debug\Proton Studio.zip"
I'm working in Delphi Berlin 10.1, Build resulted in my resource file being generated and I can open it in my Resource Editor but when I try and open the resource:
Rs := TResourceStream.CreateFromID(Application.Handle, ResID, RT_RCDATA);
I get an Address violation. It breaks in System.Classes at this point:
HResInfo := FindResource(Instance, Name, ResType);
and both the Name and ResType are empty.
I would appreciate a pointer to what am I doing wrong?

You are passing a window handle instead of a module handle. Pass HInstance instead, the handle to the module containing this code.

Related

Embed AVI as a resource file in Delphi

I have a TForm with a TPanel which is linked to the display properties of a TMediaPlayer. By selecting Project -> Resources and Images I was able to insert my video as a resource file, where
filename = abc.avi
type = RCDATA
identifier = Resource_1
unit uForm2;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms,
Vcl.Dialogs, Vcl.ExtCtrls, Vcl.MPlayer, Vcl.ComCtrls, Mmsystem;
type
TForm2 = class(TForm)
MediaPlayer1: TMediaPlayer;
Panel1: TPanel;
procedure FormCreate(Sender: TObject);
end;
var
Form2: TForm2;
implementation
uses
ShellAnimations;
{$R *.dfm}
procedure TForm2.FormCreate(Sender: TObject);
var
fs: TFileStream;
rs: TResourceStream;
s : String;
m : TMediaPlayer;
begin
rs := TResourceStream.Create(hInstance, 'Resource_1', RT_RCDATA);
s := ExtractFilePath(Application.ExeName) + 'abc.avi';
fs := TFileStream.Create(s, fmCreate);
rs.SaveToStream(fs);
fs.Free;
MediaPlayer1.Close;
MediaPlayer1.FileName := s;
MediaPlayer1.Open;
MediaPlayer1.Play;
MediaPlayer1.Display := Panel1;
end;
When the code is compiled, I get an error:
There is no driver installed in the system
Actually, the "abc.avi" file is 1 MiB. If I use a 1 GiB AVI, I get an error:
The file is being used by another process
How can I play this AVI correctly as a Delphi resource? The AVI in both cases has no sound. If I use a TOpenDialog, the video is played, but I don't want the user to select anything. The video must be embedded in the compiled executable.
______________ Updated code and error messages ______________
TMediaPlayer property:
MediaPlayer1.DeviceType = dtAVIVideo
Reported 4 errors:
1 [dcc32 Error] uForm2.pas(56): E2010 Incompatible types: 'NativeUInt' and 'string'
Line: Res := TResourceStream.Create(ChangeFileExt(PChar(lParam1), ''), 'RT_RCDATA');
2 [dcc32 Error] uForm2.pas(56): E2035 Not enough actual parameters
Line: Res := TResourceStream.Create(ChangeFileExt(PChar(lParam1), ''), 'RT_RCDATA');
3 [dcc32 Error] uForm2.pas(98): E2026 Constant expression expected
Line: ccRES: FOURCC = MAKEFOURCC(Ord('a'), Ord('v'), Ord('i'), Ord(' '));
4 [dcc32 Error] uForm2.pas(146): E2089 Invalid typecast
Line: mmioInstallIOProc(ccRES, TFNMMIOProc(MyResourceIOProc), MMIO_INSTALLPROC or MMIO_GLOBALPROC);
unit uForm2;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls, Vcl.MPlayer, Vcl.ComCtrls, Mmsystem;
type
TForm2 = class(TForm)
MediaPlayer1: TMediaPlayer;
Panel1: TPanel;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormShow(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form2: TForm2;
implementation
uses ShellAnimations;
{$R *.dfm}
function MAKEFOURCC(ch0, ch1, ch2, ch3: BYTE): FOURCC;
begin
Result := DWORD(ch0) or (DWORD(ch1) shl 8) or (DWORD(ch2) shl 16) or (DWORD(ch3) shl 24);
end;
function MyResourceIOProc(lpMMIOInfo: PMMIOInfo; uMessage: UINT; lParam1, lParam2: LPARAM): LRESULT; stdcall;
var
Res: TResourceStream;
function GetResourceStream: TResourceStream;
begin
Move(lpMMIOInfo.adwInfo, Result, SizeOf(TResourceStream));
end;
procedure SetResourceStream(Stream: TResourceStream);
begin
Move(Stream, lpMMIOInfo.adwInfo, SizeOf(TResourceStream));
end;
begin
case uMessage of
MMIOM_OPEN: begin
try
Res := TResourceStream.Create(ChangeFileExt(PChar(lParam1), ''), 'RT_RCDATA');
except
SetResourceStream(nil);
Exit(MMIOERR_CANNOTOPEN);
end;
SetResourceStream(Res);
lpMMIOInfo.lDiskOffset := 0;
Exit(MMSYSERR_NOERROR);
end;
MMIOM_CLOSE: begin
Res := GetResourceStream;
SetResourceStream(nil);
Res.Free;
Exit(MMSYSERR_NOERROR);
end;
MMIOM_READ: begin
Res := GetResourceStream;
Move((PByte(Res.Memory) + lpMMIOInfo.lDiskOffset)^, Pointer(lParam1)^, lParam2);
Inc(lpMMIOInfo.lDiskOffset, lParam2);
Exit(lParam2);
end;
MMIOM_SEEK: begin
case lParam2 of
SEEK_SET: begin
lpMMIOInfo.lDiskOffset := lParam1;
end;
SEEK_CUR: begin
Inc(lpMMIOInfo.lDiskOffset, lParam1);
end;
SEEK_END: begin
Res := GetResourceStream;
lpMMIOInfo.lDiskOffset := Res.Size - 1 - lParam1;
end;
end;
Exit(lpMMIOInfo.lDiskOffset);
end;
else
Exit(MMSYSERR_NOERROR);
end;
end;
const
ccRES: FOURCC = MAKEFOURCC(Ord('a'), Ord('v'), Ord('i'), Ord(' '));
procedure TForm2.FormCreate(Sender: TObject);
begin
mmioInstallIOProc(ccRES, TFNMMIOProc(MyResourceIOProc), MMIO_INSTALLPROC or MMIO_GLOBALPROC);
end;
procedure TForm2.FormDestroy(Sender: TObject);
begin
mmioInstallIOProc(ccRES, nil, MMIO_REMOVEPROC);
end;
procedure TForm2.FormShow(Sender: TObject);
begin
MediaPlayer1.FileName := 'Resource_1.avi+';
MediaPlayer1.Open;
MediaPlayer1.Display:=Panel1;
MediaPlayer1.Play;
end;
end.

issuing Netsh command from Delphi program

I am trying to capture the Device ID of an AirCard. I am using the following code with the intentions of storing the results in a text file (imei.txt) that I store in the Temp folder and loop through the contents, looking for DEVICE ID.
The problems is that it only writes "The following command was not found: mbn show interface." to the file.
I have tested the Netsh command from the command line and it returns what I would expect.
xs1 := CreateOleObject('WSCript.Shell');
xs1.run('%comspec% /c netsh mbn show interface > "' + IMEIFileName +
'"', 0, true);
It is failing to process the NetSh command properly. Am I passing it through the Comspec correctly? It seems to not run the "NetSh" command and acts as if I am running "mbn" from the command prompt.
Thanks
unit uMain;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, System.Win.ComObj, ShlObj, Vcl.StdCtrls;
type
TfrmMain = class(TForm)
Button1: TButton;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
private
procedure GetAirCardInformation;
{ Private declarations }
public
{ Public declarations }
IMEI: string;
PhoneNumber: string;
end;
var
frmMain: TfrmMain;
implementation
{$R *.dfm}
procedure TfrmMain.Button1Click(Sender: TObject);
begin
GetAirCardInformation;
end;
procedure TfrmMain.GetAirCardInformation;
var
xs1 : OleVariant;
IMEIFileName: String;
IMEIStrings: TStringList;
I: Integer;
function GetSpecialFolder(const CSIDL: Integer): string;
var
RecPath: PWideChar;
begin
RecPath := StrAlloc(MAX_PATH);
try
FillChar(RecPath^, MAX_PATH, 0);
if SHGetSpecialFolderPath(0, RecPath, CSIDL, false) then
result := RecPath
else
result := '';
finally
StrDispose(RecPath);
end;
end;
begin
IMEI := '';
IMEIFileName := GetSpecialFolder(CSIDL_LOCAL_APPDATA) + '\Temp\imei.txt';
Memo1.Lines.Add('IMEIFileName: ' + IMEIFileName);
try
if FileExists(IMEIFileName) then
DeleteFile(IMEIFileName);
xs1 := CreateOleObject('WSCript.Shell');
xs1.run('%comspec% /c netsh mbn show interface > "' + IMEIFileName +
'"', 0, true);
if FileExists(IMEIFileName) then
begin
IMEIStrings := TStringList.Create;
IMEIStrings.LoadFromFile(IMEIFileName);
IMEIStrings.NameValueSeparator := ':';
Memo1.Lines.Add('IMEIStrings Count: ' + intToStr(IMEIStrings.Count));
for I := 0 to IMEIStrings.Count - 1 do
begin
Memo1.Lines.Add(IMEIStrings.text);
if (Uppercase(Trim(IMEIStrings.Names[I])) = 'DEVICE ID') then
begin
IMEI := Trim(IMEIStrings.Values[IMEIStrings.Names[I]]);
Memo1.Lines.Add('IMEI:' + IMEI);
break;
end;
end;
end;
except
IMEI := '';
end;
Memo1.Lines.Add('process complete');
end;
end.
You should not be using the WShell COM object to run cmd.exe. That is overkill. You can use CreateProcess() instead. However, when running cmd.exe programmably, you cannot redirect its output using the > operator, that only works in an actual command window. You can instead use the STARTUPINFO structure to redirect the output to an anonymous pipe created with CreatePipe(), and then you can read from that pipe using ReadFile(). No need to use a temp file at all. MSDN has an article on this topic:
Creating a Child Process with Redirected Input and Output
There are plenty of examples floating around that demonstrate this technique in Delphi.
That being said, a better option is to not use netsh at all. Windows 7 and later have a Mobile Broadband API. You can enumerate the MBN interfaces directly in your code.
For example, using the WwanEnumerateInterfaces() function:
unit WwApi;
{$MINENUMSIZE 4}
interface
uses
Windows;
const
WWAN_STR_DESC_LENGTH = 256;
type
WWAN_INTERFACE_STATE = (
WwanInterfaceStateNotReady,
WwanInterfaceStateDeviceLocked,
WwanInterfaceStateUserAccountNotActivated,
WwanInterfaceStateRegistered,
WwanInterfaceStateRegistering,
WwanInterfaceStateDeregistered,
WwanInterfaceStateAttached,
WwanInterfaceStateAttaching,
WwanInterfaceStateDetaching,
WwanInterfaceStateActivated,
WwanInterfaceStateActivating,
WwanInterfaceStateDeactivating
);
WWAN_INTF_OPCODE = (
WwanIntfOpcodePin,
WwanIntfOpcodeRadioState,
WwanIntfOpcodePreferredProviders,
WwanIntfOpcodeCurrentConnection,
WwanIntfOpcodeProvisionedContexts,
WwanIntfOpcodeActivateUserAccount,
WwanIntfOpcodeVendorSpecific,
WwanIntfOpcodeInterfaceObject,
WwanIntfOpcodeConnectionObject,
WwanIntfOpcodeAcState,
WwanIntfOpcodeClearManualConnectState,
WwanIntfOpcodeGetStoredRadioState,
WwanIntfOpcodeGetRadioInfo,
WwanIntfOpcodeHomeProvider
);
// I don't know the definition of this type!
WWAN_STATUS = DWORD; //?
WWAN_INTERFACE_STATUS = record
fInitialized: BOOL;
InterfaceState: WWAN_INTERFACE_STATE;
end;
PWWAN_INTERFACE_INFO = ^WWAN_INTERFACE_INFO;
WWAN_INTERFACE_INFO = record
InterfaceGuid: TGuid;
strInterfaceDescription: array[0..WWAN_STR_DESC_LENGTH-1] of WCHAR;
InterfaceStatus: WWAN_INTERFACE_STATUS;
ParentInterfaceGuid: TGuid;
fIsAdditionalPdpContextInterface: BOOL;
end;
PWWAN_INTERFACE_INFO_LIST = ^WWAN_INTERFACE_INFO_LIST;
WWAN_INTERFACE_INFO_LIST = record
dwNumberOfItems: DWORD;
pInterfaceInfo: array[0..0] of WWAN_INTERFACE_INFO;
end;
function WwanOpenHandle(dwClientVersion: DWORD; pReserved: Pointer; var pdwNegotiatedVersion: DWORD; var phClientHandle: THandle): DWORD; stdcall;
function WwanCloseHandle(hClientHandle: THandle; pReserved: Pointer): DWORD; stdcall;
function WwanEnumerateInterfaces(hClientHandle: THandle; pdwReserved: PDWORD; var ppInterfaceList: PWWAN_INTERFACE_INFO_LIST): DWORD; stdcall;
procedure WwanFreeMemory(pMem: Pointer); stdcall;
function WwanQueryInterface(hClientHandle: THandle; const pInterfaceGuid: TGuid; opCode: WWAN_INTF_OPCODE; pReserved: Pointer; var pdwDataSize: DWORD; var ppData: PByte; var pRequestId: ULONG; var pStatus: WWAN_STATUS): DWORD; stdcall;
implementation
const
WwApiLib = 'WwApi.dll';
function WwanOpenHandle; external WwApiLib delayed;
function WwanCloseHandle; external WwApiLib delayed;
function WwanEnumerateInterfaces; external WwApiLib delayed;
procedure WwanFreeMemory; external WwApiLib delayed;
function WwanQueryInterface; external WwApiLib delayed;
end.
unit uMain;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs,
Vcl.StdCtrls;
type
TfrmMain = class(TForm)
Button1: TButton;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
private
procedure GetAirCardInformation;
{ Private declarations }
public
{ Public declarations }
IMEI: string;
PhoneNumber: string;
end;
var
frmMain: TfrmMain;
implementation
{$R *.dfm}
uses
WwApi;
procedure TfrmMain.Button1Click(Sender: TObject);
begin
GetAirCardInformation;
end;
procedure TfrmMain.GetAirCardInformation;
var
dwNegotiatedVersion: DWORD;
hClientHandle: THandle;
pInterfaceList: PWWAN_INTERFACE_INFO_LIST;
pInterface: PWWAN_INTERFACE_INFO;
I: DWORD;
begin
IMEI := '';
Memo1.Clear;
try
// The value of the first parameter is undocumented!
// WlanOpenHandle() has a similar parameter, where 1
// is for XP and 2 is for Vista+. Maybe it is the same
// for WwanOpenHandle()?...
//
if WwanOpenHandle(2, nil, dwNegotiatedVersion, hClientHandle) = 0 then
try
if WwanEnumerateInterfaces(hClientHandle, nil, pInterfaceList) = 0 then
try
Memo1.Lines.Add('IMEIStrings Count: ' + IntToStr(pInterfaceList.dwNumberOfItems));
if pInterfaceList.dwNumberOfItems > 0 then
begin
pInterface := #pInterfaceList.pInterfaceInfo[0];
for I := 0 to pInterfaceList.dwNumberOfItems-1 do
begin
// use pInterface as needed...
Memo1.Lines.Add('Desc:' + StrPas(pInterface.strInterfaceDescription));
Memo1.Lines.Add('Intf:' + GUIDToString(pInterface.InterfaceGuid));
// and so on ...
Memo1.Lines.Add('');
Inc(pInterface);
end;
end;
finally
WwanFreeMemory(pInterfaceList);
end;
finally
WwanCloseHandle(hClientHandle, nil);
end;
except
end;
Memo1.Lines.Add('process complete');
end;
end.
Alternatively, using the IMbnInterfaceManager and IMbnInterface COM interfaces, which give you more detailed information:
unit uMain;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs,
Vcl.StdCtrls;
type
TfrmMain = class(TForm)
Button1: TButton;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
private
procedure GetAirCardInformation;
{ Private declarations }
public
{ Public declarations }
IMEI: string;
PhoneNumber: string;
end;
var
frmMain: TfrmMain;
implementation
{$R *.dfm}
uses
// I found the MbnApi.pas unit on the DelphiPraxis forum:
//
// http://www.delphipraxis.net/1342330-post2.html
//
// It is too large to post here on StackOverflow!
// Otherwise, you can import the mbnapi.tlb TypeLibrary yourself...
//
MbnApi, ActiveX, ComObj;
procedure TfrmMain.Button1Click(Sender: TObject);
begin
GetAirCardInformation;
end;
procedure TfrmMain.GetAirCardInformation;
var
Mgr: IMbnInterfaceManager;
pInterfaceArray, pPhoneNumberArray: PSafeArray;
pInterface: IMbnInterface;
subscriber: IMbnSubscriberInformation;
ReadyState: MBN_READY_STATE;
lIntfLower, lIntfUpper: LONG;
lPhoneNumLower, lPhoneNumUpper: LONG;
I, J: LONG;
wStr: WideString;
begin
Memo1.Clear;
try
OleCheck(CoCreateInstance(CLASS_MbnInterfaceManager, nil, CLSCTX_ALL, IMbnInterfaceManager, Mgr));
OleCheck(Mgr.GetInterfaces(pInterfaceArray));
try
OleCheck(SafeArrayGetLBound(pInterfaceArray, 1, lIntfLower));
OleCheck(SafeArrayGetUBound(pInterfaceArray, 1, lIntfUpper));
for I = lIntfLower to lIntfUpper do
begin
OleCheck(SafeArrayGetElement(pInterfaceArray, I, pInterface));
try
// use pInterface as needed...
OleCheck(pInterface.get_InterfaceID(wStr));
try
Memo1.Lines.Add('Interface ID:' + wStr);
finally
wStr := '';
end;
OleCheck(pInterface.GetReadyState(ReadyState));
Memo1.Lines.Add('Ready State:' + IntToStr(Ord(ReadyState)));
OleCheck(pInterface.GetSubscriberInformation(subscriber));
try
OleCheck(subscriber.Get_SubscriberID(wStr));
try
Memo1.Lines.Add('Subscriber ID: ' + wStr);
finally
wStr := '';
end;
OleCheck(subscriber.Get_SimIccID(wStr));
try
Memo1.Lines.Add('Sim ICC ID: ' + wStr);
finally
wStr := '';
end;
OleCheck(subscriber.Get_TelephoneNumbers(pPhoneNumberArray));
try
OleCheck(SafeArrayGetLBound(pPhoneNumberArray, 1, lPhoneNumLower));
OleCheck(SafeArrayGetUBound(pPhoneNumberArray, 1, lPhoneNumUpper));
for J = lPhoneNumLower to lPhoneNumUpper do
begin
OleCheck(SafeArrayGetElement(pPhoneNumberArray, J, wStr));
try
Memo1.Lines.Add('Phone #:' + wStr);
finally
wStr := '';
end;
end;
finally
SafeArrayDestroy(pPhoneNumberArray);
end;
finally
subscriber := nil;
end;
// and so on...
Memo1.Lines.Add('');
finally
pInterface := nil;
end;
end;
finally
SafeArrayDestroy(pInterfaceArray);
end;
except
end;
Memo1.Lines.Add('process complete');
end;
end.

How To Record A Video And Audio Through Device, Firemonkey?

My Code for video recording is given, the recording is not in a smooth way i.e. the place where I turn my camera appears on the preview view late. How I can resolve this issue
unit VideoAttachmentUnit;
interface
uses
System.SysUtils,
System.Types,
System.UITypes,
System.Classes,
System.Variants,
FMX.Types,
FMX.Controls,
FMX.Forms,
FMX.Dialogs,
FMX.StdCtrls,
FMX.Media,
FMX.Platform,
FMX.Objects,
FMX.Layouts,
FMX.Memo,
FMX.Controls.Presentation;
type
TVideoAttachmentForm = class(TForm)
NavBar: TToolBar;
CameraChangeBtn: TButton;
PlayBtn: TButton;
CloseScreenBtn: TButton;
ToolBar1: TToolBar;
StartRecordingBtn: TButton;
StopRecordingBtn: TButton;
ImageCameraView: TImage;
CameraComponent: TCameraComponent;
procedure FormCreate(Sender: TObject);
procedure CloseScreenBtnClick(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure CameraChangeBtnClick(Sender: TObject);
procedure StartRecordingBtnClick(Sender: TObject);
procedure StopRecordingBtnClick(Sender: TObject);
procedure CameraComponentSampleBufferReady(Sender: TObject;
const ATime: TMediaTime);
private
{ Private declarations }
procedure GetImage;
procedure InitialSettingsForTheRecording;
public
function AppEvent(AAppEvent: TApplicationEvent; AContext: TObject): Boolean;
end;
var
VideoAttachmentForm: TVideoAttachmentForm;
WhichCamera:String;
procedure DisplayTheVideoAttachmentScreen;
implementation
{$R *.fmx}
procedure DisplayTheVideoAttachmentScreen;
begin
try
Application.CreateForm(TVideoAttachmentForm , VideoAttachmentForm);
VideoAttachmentForm.Show;
finally
end;
end;
procedure TVideoAttachmentForm.CameraChangeBtnClick(Sender: TObject);
var
LActive: Boolean;
begin
{ Select Back Camera }
LActive := CameraComponent.Active;
try
CameraComponent.Active := False;
if WhichCamera = 'BackCamera' then
begin
CameraComponent.Kind := TCameraKind.FrontCamera;
WhichCamera := 'FrontCamera';
end
else if WhichCamera = 'FrontCamera' then
begin
CameraComponent.Kind := TCameraKind.BackCamera;
WhichCamera := 'BackCamera';
end;
finally
CameraComponent.Active := LActive;
end;
end;
procedure TVideoAttachmentForm.CameraComponentSampleBufferReady(Sender: TObject;
const ATime: TMediaTime);
begin
TThread.Synchronize(TThread.CurrentThread, GetImage);
ImageCameraView.Width := ImageCameraView.Bitmap.Width;
ImageCameraView.Height := ImageCameraView.Bitmap.Height;
end;
procedure TVideoAttachmentForm.CloseScreenBtnClick(Sender: TObject);
begin
VideoAttachmentForm.Close;
end;
procedure TVideoAttachmentForm.FormCreate(Sender: TObject);
var
AppEventSvc: IFMXApplicationEventService;
begin
if TPlatformServices.Current.SupportsPlatformService(IFMXApplicationEventService, IInterface(AppEventSvc)) then
AppEventSvc.SetApplicationEventHandler(AppEvent);
end;
procedure TVideoAttachmentForm.FormShow(Sender: TObject);
begin
InitialSettingsForTheRecording;
end;
function TVideoAttachmentForm.AppEvent(AAppEvent: TApplicationEvent; AContext: TObject): Boolean;
begin
case AAppEvent of
TApplicationEvent.WillBecomeInactive:
CameraComponent.Active := False;
TApplicationEvent.EnteredBackground:
CameraComponent.Active := False;
TApplicationEvent.WillTerminate:
CameraComponent.Active := False;
end;
end;
procedure TVideoAttachmentForm.InitialSettingsForTheRecording;
var
LSettings: TVideoCaptureSetting;
begin
CameraComponent.Kind := TCameraKind.BackCamera;
WhichCamera := 'BackCamera';
if CameraComponent.HasTorch then
begin
CameraComponent.TorchMode := TTorchMode.ModeAuto;
end;
CameraComponent.Quality := TVideoCaptureQuality.CaptureSettings;
CameraComponent.CaptureSettingPriority := TVideoCaptureSettingPriority.FrameRate;
end;
procedure TVideoAttachmentForm.StartRecordingBtnClick(Sender: TObject);
begin
CameraComponent.Active := True;
end;
procedure TVideoAttachmentForm.StopRecordingBtnClick(Sender: TObject);
begin
CameraComponent.Active := False;
end;
procedure TVideoAttachmentForm.GetImage;
begin
CameraComponent.SampleBufferToBitmap(ImageCameraView.Bitmap, True);
end;
end.

"Available Form:". Original Delphi Frames with Original unit

Problem:
How can I load frame in Form1 or sample container in form ?
FindClass or GetClass is only locality for main form appl-n
I need (maybe) string globaly elemental for TFrameClass, next code:
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs,
Vcl.StdCtrls, Vcl.ExtCtrls;
type
TFrameClass = class of TFrame;
type
TForm1 = class(TForm)
Panel1: TPanel;
Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
FFrame: TFrame;
function StrShowFrame(FrameClassName: string;
ParentPanel: TWinControl): Boolean;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
uses Base1Frame, Base2Frame, Base3Frame;
function TForm1.StrShowFrame(FrameClassName: string;
ParentPanel: TWinControl): Boolean;
var
FrameClass: TClass;
// Current Frame (FrameName)
FrameName: string;
begin
Result := False;
??? GetClass is only locality for main form in appl-n
FrameClass := GetClass(FrameClassName);
if FrameClass = nil then
begin
ShowMessageFmt('Class %s not registered', [FrameClassName]);
Result := False;
Exit;
end;
try
begin
LockWindowUpdate(ParentPanel.Handle);
if Assigned(FFrame) then
if FFrame.ClassType = FrameClass then
begin
Result := True;
Exit;
end
else
FFrame.Destroy; // del previus FrameClass
try
FFrame := TFrameClass(FrameClass).Create(nil);
except
on E:Exception do
begin
Result := True;
E.Create(E.Message);
FFrame := nil;
Exit;
end;
end;
FrameName:= FrameClassName;
Delete(FrameName, 1, 1); // T-...
FFrame.Name := Concat(FrameName, '1');
FFrame.Parent := ParentPanel;
FFrame.Align := alClient;
end;
finally
LockWindowUpdate(0);
end;
Result := True;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
StrShowFrame('TFr_Base1', Panel1);
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
try
if FFrame <> nil then
FFrame.Free
else
ShowMessage('Class not activ');
except
end;
end;
end.
How can I load frame in Form1 or sample container in form ?
FindClass or GetClass is only locality for main form appl-n
I need (maybe) string globaly elemental for TFrameClass.
GetClass() and FindClass() are not local to the MainForm, they are global to the entire RTL as a whole. Any unit can call RegisterClass() and have that class be accessible to any other unit that shares the same instance of the RTL. That last part is important. A DLL cannot register a class that the EXE uses (and vice versa), unless both projects are compiled with Runtime Packages enabled so they share a single RTL instance.

Firemonkey and TDownloadUrl

I have an (Delphi XE2) VCL app containing an object TDownloadUrl (VCL.ExtActns) to check several webpages, so I wonder if there is an equivalent object in FireMonkey, 'cause I wanna take advantage of rich features from this new platform.
A Firemonkey app demo using threads would appreciate. Thanks in advance.
Actions don't exist yet with FireMonkey.
BTW, you can create the same behavior with a code like this:
IdHTTP1: TIdHTTP;
...
procedure TForm2.MenuItem1Click(Sender: TObject);
const
FILENAME = 'C:\Users\Whiler\Desktop\test.htm';
URL = 'http://stackoverflow.com/questions/7491389/firemonkey-and-tdownloadurl';
var
// sSource: string;
fsSource: TFileStream;
begin
if FileExists(FILENAME) then
begin
fsSource := TFileStream.Create(FILENAME, fmOpenWrite);
end
else
begin
fsSource := TFileStream.Create(FILENAME, fmCreate);
end;
try
IdHTTP1.Get(URL, fsSource);
finally
fsSource.Free;
end;
// sSource := IdHTTP1.Get(URL);
end;
The commented lines can replace the others if you just need the source in memory...
If you want to use a thread, you can manage it like this:
unit Unit2;
interface
uses
System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
FMX.Types, FMX.Controls, FMX.Forms, FMX.Dialogs, IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient, IdHTTP, FMX.Menus;
type
TDownloadThread = class(TThread)
private
idDownloader: TIdHTTP;
FFileName : string;
FURL : string;
protected
procedure Execute; override;
procedure Finished;
public
constructor Create(const sURL: string; const sFileName: string);
destructor Destroy; override;
end;
type
TForm2 = class(TForm)
MenuBar1: TMenuBar;
MenuItem1: TMenuItem;
procedure MenuItem1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form2: TForm2;
implementation
{$R *.fmx}
procedure TForm2.MenuItem1Click(Sender: TObject);
const
FILENAME = 'C:\Users\Whiler\Desktop\test.htm';
URL = 'http://stackoverflow.com/questions/7491389/firemonkey-and-tdownloadurl';
var
// sSource: string;
fsSource: TFileStream;
begin
TDownloadThread.Create(URL, FILENAME).Start;
end;
{ TDownloadThread }
constructor TDownloadThread.Create(const sURL, sFileName: string);
begin
inherited Create(true);
idDownloader := TIdHTTP.Create(nil);
FFileName := sFileName;
FURL := sURL;
FreeOnTerminate := True;
end;
destructor TDownloadThread.Destroy;
begin
idDownloader.Free;
inherited;
end;
procedure TDownloadThread.Execute;
var
// sSource: string;
fsSource: TFileStream;
begin
inherited;
if FileExists(FFileName) then
begin
fsSource := TFileStream.Create(FFileName, fmOpenWrite);
end
else
begin
fsSource := TFileStream.Create(FFileName, fmCreate);
end;
try
idDownloader.Get(FURL, fsSource);
finally
fsSource.Free;
end;
Synchronize(Finished);
end;
procedure TDownloadThread.Finished;
begin
// replace by whatever you need
ShowMessage(FURL + ' has been downloaded!');
end;
end.
Regarding this:
A Firemonkey app demo using threads would appreciate.
You can find a FireMonkey demo which is using Thread here: https://radstudiodemos.svn.sourceforge.net/svnroot/radstudiodemos/branches/RadStudio_XE2/FireMonkey/FireFlow/MainForm.pas
type
TImageThread = class(TThread)
private
FImage: TImage;
FTempBitmap: TBitmap;
FFileName: string;
protected
procedure Execute; override;
procedure Finished;
public
constructor Create(const AImage: TImage; const AFileName: string);
destructor Destroy; override;
end;
...
TImageThread.Create(Image, Image.TagString).Start;
if you don't have this demo in your sample directory, you can check it out from the subversion repository used in the link above.
You can using this code.
unit BitmapHelperClass;
interface
uses
System.Classes, FMX.Graphics;
type
TBitmapHelper = class helper for TBitmap
public
procedure LoadFromUrl(AUrl: string);
procedure LoadThumbnailFromUrl(AUrl: string; const AFitWidth, AFitHeight: Integer);
end;
implementation
uses
System.SysUtils, System.Types, IdHttp, IdTCPClient, AnonThread;
procedure TBitmapHelper.LoadFromUrl(AUrl: string);
var
_Thread: TAnonymousThread<TMemoryStream>;
begin
_Thread := TAnonymousThread<TMemoryStream>.Create(
function: TMemoryStream
var
Http: TIdHttp;
begin
Result := TMemoryStream.Create;
Http := TIdHttp.Create(nil);
try
try
Http.Get(AUrl, Result);
except
Result.Free;
end;
finally
Http.Free;
end;
end,
procedure(AResult: TMemoryStream)
begin
if AResult.Size > 0 then
LoadFromStream(AResult);
AResult.Free;
end,
procedure(AException: Exception)
begin
end
);
end;
procedure TBitmapHelper.LoadThumbnailFromUrl(AUrl: string; const AFitWidth,
AFitHeight: Integer);
var
Bitmap: TBitmap;
scale: Single;
begin
LoadFromUrl(AUrl);
scale := RectF(0, 0, Width, Height).Fit(RectF(0, 0, AFitWidth, AFitHeight));
Bitmap := CreateThumbnail(Round(Width / scale), Round(Height / scale));
try
Assign(Bitmap);
finally
Bitmap.Free;
end;
end;
end.

Resources