How to take snapshot and save to JPEG from webcam using DSPack? - delphi

Using DSPack, Delphi XE I need to take a snapshot from a webcam and allow a preview before which the user is allowed to save to JPEG file. How can this be done (code)?

Maybe this will work, but I have not tested it. You should give it a try.
unit main;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, DSPack, DSUtil, DirectShow9;
type
TMainForm = class(TForm)
CaptureGraph: TFilterGraph;
VideoWindow: TVideoWindow;
ListBox1: TListBox;
VideoSourceFilter: TFilter;
StartButton: TButton;
StopButton: TButton;
Label1: TLabel;
ListBox2: TListBox;
Label3: TLabel;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure ListBox1Click(Sender: TObject);
procedure StartButtonClick(Sender: TObject);
procedure StopButtonClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
MainForm: TMainForm;
VideoDevice: TSysDevEnum;
VideoMediaTypes: TEnumMediaType;
implementation
{$R *.dfm}
{ TMainForm }
procedure TMainForm.FormCreate(Sender: TObject);
var i: integer;
begin
VideoDevice := TSysDevEnum.Create(CLSID_VideoInputDeviceCategory);
for i := 0 to VideoDevice.CountFilters - 1 do
ListBox1.Items.Add(VideoDevice.Filters[i].FriendlyName);
VideoMediaTypes := TEnumMediaType.Create;
end;
procedure TMainForm.FormDestroy(Sender: TObject);
begin
VideoDevice.Free;
VideoMediaTypes.Free;
end;
// Selecting of the video source
procedure TMainForm.ListBox1Click(Sender: TObject);
var
PinList: TPinList;
i: integer;
begin
VideoDevice.SelectGUIDCategory(CLSID_VideoInputDeviceCategory);
if ListBox1.ItemIndex <> -1 then
begin
// Set the device which we work with
VideoSourceFilter.BaseFilter.Moniker := VideoDevice.GetMoniker(ListBox1.ItemIndex);
VideoSourceFilter.FilterGraph := CaptureGraph;
CaptureGraph.Active := true;
PinList := TPinList.Create(VideoSourceFilter as IBaseFilter);
ListBox2.Clear;
VideoMediaTypes.Assign(PinList.First);
// Adding permission to ListBox2, which supports device
for i := 0 to VideoMediaTypes.Count - 1 do
ListBox2.Items.Add(VideoMediaTypes.MediaDescription[i]);
CaptureGraph.Active := false;
PinList.Free;
StartButton.Enabled := true;
end;
end;
procedure TMainForm.StartButtonClick(Sender: TObject);
var
PinList: TPinList;
begin
// Activating graph filter, at this stage the source filter is added to the graph
CaptureGraph.Active := true;
// The configuration of the output device
if VideoSourceFilter.FilterGraph <> nil then
begin
PinList := TPinList.Create(VideoSourceFilter as IBaseFilter);
if ListBox2.ItemIndex <> -1 then
with (PinList.First as IAMStreamConfig) do
SetFormat(VideoMediaTypes.Items[ListBox2.ItemIndex].AMMediaType^);
PinList.Free;
end;
// now render streams
with CaptureGraph as IcaptureGraphBuilder2 do
begin
// Hooking up a preview video (VideoWindow)
if VideoSourceFilter.BaseFilter.DataLength > 0 then
RenderStream(#PIN_CATEGORY_PREVIEW, nil, VideoSourceFilter as IBaseFilter,
nil , VideoWindow as IBaseFilter);
end;
// Launch video
CaptureGraph.Play;
StopButton.Enabled := true;
StartButton.Enabled := false;
ListBox2.Enabled := false;
ListBox1.Enabled := false;
end;
// Stop video
procedure TMainForm.StopButtonClick(Sender: TObject);
begin
StopButton.Enabled := false;
StartButton.Enabled := true;
CaptureGraph.Stop;
CaptureGraph.Active := False;
ListBox2.Enabled := true;
ListBox1.Enabled := true;
end;
end.

Related

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 stop flickering in layered image animation

i used 30 png pictures on a transplanted from to make a simple animation, a Timer make an event every 33 Millisecond to change the visibility of the TImage Components which have the png images, i tried all the method suggested in other posts to stop flickering but could not solve the problem.
unit Animation;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, AdvShaper, pngimage, ExtCtrls, StdCtrls;
type
TAnimation_Form = class(TForm)
Image1: TImage;
Timer: TTimer;
Image2: TImage;
Image3: TImage;
Image4: TImage;
Image5: TImage;
Image6: TImage;
Image7: TImage;
Image8: TImage;
Image9: TImage;
Image10: TImage;
Image11: TImage;
Image12: TImage;
Image13: TImage;
Image14: TImage;
Image15: TImage;
Image16: TImage;
Image17: TImage;
Image18: TImage;
Image19: TImage;
Image20: TImage;
Image21: TImage;
Image22: TImage;
Image23: TImage;
Image24: TImage;
Image25: TImage;
Image26: TImage;
Image27: TImage;
Image28: TImage;
Image29: TImage;
Image30: TImage;
Exit: TButton;
procedure TimerTimer(Sender: TObject);
procedure ExitClick(Sender: TObject);
private
{ Private declarations }
Image_Counter:Integer;
procedure ChooseImage(I:Integer);
procedure Init();
public
{ Public declarations }
end;
procedure Run_Animation_Form();
procedure Finish_Animation_Form();
implementation
var
Animation_Form: TAnimation_Form;
{$R *.dfm}
procedure Finish_Animation_Form();
Begin
Animation_Form.Close;
End;
procedure Run_Animation_Form();
Begin
Animation_Form := TAnimation_Form.Create(nil);
Try
Animation_Form.Init();
Animation_Form.ShowModal();
Finally
Animation_Form.Free;
End;
End;
{ TAnimation_Form }
procedure TAnimation_Form.ChooseImage(I: Integer);
begin
TwinControl(FindComponent(Format('Image%d',[I]))).Visible := False;
TwinControl(FindComponent(Format('Image%d',[I+1]))).Visible := True;
end;
procedure TAnimation_Form.ExitClick(Sender: TObject);
begin
Close;
end;
procedure TAnimation_Form.Init;
begin
TransparentColor := True;
TransparentColorValue := Color;
Image1.Visible := True;
Image_Counter:=1;
ControlStyle:=ControlStyle - [csOpaque];
BorderWidth := 10;
Anchors := [akLeft, akTop, akBottom, akRight];
end;
procedure TAnimation_Form.TimerTimer(Sender: TObject);
begin
if Image_Counter >= 30 then
Begin
Image30.Visible := False;
Image1.Visible := True;
Image_Counter:=1;
End
else
Begin
ChooseImage(Image_Counter);
Inc(Image_Counter);
End;
end;
end.
Thanks for your help and sorry for my bad English
Rather than using multiple overlapping TImage objects and swapping their Visible property, I would suggest you create an array of 30 TPNGImage objects and then either:
use a single TImage that is always visible and assign the desired PNG to its TImage.Picture property whenever the TTimer elapses:
unit Animation;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, AdvShaper, pngimage, ExtCtrls, StdCtrls;
type
TAnimation_Form = class(TForm)
Image1: TImage;
Timer: TTimer;
Exit: TButton;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure TimerTimer(Sender: TObject);
procedure ExitClick(Sender: TObject);
private
{ Private declarations }
Image_Counter: Integer;
Images: array[0..29] of TPNGImage;
public
{ Public declarations }
end;
procedure Run_Animation_Form();
procedure Finish_Animation_Form();
implementation
var
Animation_Form: TAnimation_Form = nil;
{$R *.dfm}
procedure Finish_Animation_Form();
Begin
if Animation_Form <> nil then
Animation_Form.Close;
End;
procedure Run_Animation_Form();
Begin
Animation_Form := TAnimation_Form.Create(nil);
Try
Animation_Form.ShowModal();
Finally
FreeAndNil(Animation_Form);
End;
End;
{ TAnimation_Form }
procedure TAnimation_Form.FormCreate(Sender: TObject);
var
I: Integer;
begin
for I := Low(Images) to High(Images) do
begin
Images[I] := TPNGImage.Create;
// load PNG image into Images[I] as needed...
end;
// FYI, these properties can be set at design time...
TransparentColor := True;
TransparentColorValue := Color;
Image1.Visible := True;
BorderWidth := 10;
Anchors := [akLeft, akTop, akBottom, akRight];
Image_Counter := 0;
Image1.Picture := Images[0];
ControlStyle := ControlStyle - [csOpaque];
end;
procedure TAnimation_Form.FormDestroy(Sender: TObject);
var
I: Integer;
begin
for I := Low(Images) to High(Images) do
Images[I].Free;
end;
procedure TAnimation_Form.ExitClick(Sender: TObject);
begin
Close;
end;
procedure TAnimation_Form.TimerTimer(Sender: TObject);
begin
Inc(Image_Counter);
if Image_Counter > High(Images) then
Image_Counter := 0;
Image1.Picture := Images[Image_Counter];
end;
end.
use a single TPaintBox and assign an OnPaint event handler to it that draws the current PNG onto the TPaintBox.Canvas, and then have the TTimer simply update the current PNG and call TPaintBox.Invalidate() to trigger a repaint:
unit Animation;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, AdvShaper, pngimage, ExtCtrls, StdCtrls;
type
TAnimation_Form = class(TForm)
PaintBox1: TPaintBox;
Timer: TTimer;
Exit: TButton;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure TimerTimer(Sender: TObject);
procedure ExitClick(Sender: TObject);
procedure PaintBox1Paint(Sender: TObject);
private
{ Private declarations }
Image_Counter: Integer;
Images: array[0..29] of TPNGImage;
public
{ Public declarations }
end;
procedure Run_Animation_Form();
procedure Finish_Animation_Form();
implementation
var
Animation_Form: TAnimation_Form = nil;
{$R *.dfm}
procedure Finish_Animation_Form();
Begin
if Animation_Form <> nil then
Animation_Form.Close;
End;
procedure Run_Animation_Form();
Begin
Animation_Form := TAnimation_Form.Create(nil);
Try
Animation_Form.ShowModal();
Finally
FreeAndNil(Animation_Form);
End;
End;
{ TAnimation_Form }
procedure TAnimation_Form.FormCreate(Sender: TObject);
var
I: Integer;
begin
for I := Low(Images) to High(Images) do
begin
Images[I] := TPNGImage.Create;
// load PNG image into Images[I] as needed...
end;
// FYI, these properties can be set at design time...
TransparentColor := True;
TransparentColorValue := Color;
Image1.Visible := True;
BorderWidth := 10;
Anchors := [akLeft, akTop, akBottom, akRight];
Image_Counter := 0;
ControlStyle := ControlStyle - [csOpaque];
end;
procedure TAnimation_Form.FormDestroy(Sender: TObject);
var
I: Integer;
begin
for I := Low(Images) to High(Images) do
Images[I].Free;
end;
procedure TAnimation_Form.ExitClick(Sender: TObject);
begin
Close;
end;
procedure TAnimation_Form.TimerTimer(Sender: TObject);
begin
Inc(Image_Counter);
if Image_Counter > High(Images) then
Image_Counter := 0;
PaintBox1.Invalidate;
end;
procedure TAnimation_Form.PaintBox1Paint(Sender: TObject);
begin
PaintBox1.Canvas.Draw(0, 0, Images[Image_Counter]);
// or:
// PaintBox1.Canvas.StretchDraw(Rect(0, 0, PaintBox1.Width, PaintBox1.Height), Images[Image_Counter]);
end;
end.

Inno setup command line progress

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.

Minimize Delphi Form to System Tray

I am a Delphi learner. I am looking for solutions so that Delphi MainForm should be minimized to the System Tray instead of Taskbar. On Right Click on the System Tray Icon there should be some menus like "Restore" and "About" and "Help" etc. System Tray Icons will be loaded from Imagelis1 and it will animate. On Clicking on "Restore" the MainForm will be restored, on clicking on "About" "Form2" will be restored and on clicking on "Help" "Foprm3" will be restored. I have found so many solutions on internet like :
Solution 01
Solution 02
but every solutions have some drawbacks. Some can be done once ony. Some have blurred icon in Windows7. Someone may tell that there is no one to write codes for me and I have to show my codes. Plaese forgive me for this regards. Please give me concrete solution sot that it can be implemented universely without version dependency of windows. It will help every one. Please help me.
This should get you going. Drop a TTrayIcon and a TApplicationEvents on your form. THe following code is from the TTrayIcon - Delphi Example from the docwiki. Use the IDE main menu, and choose Project->View Source, and the line that reads Application.ShowMainFormOnTaskbar := True; to `Application.ShowMainFormOnTaskbar := False;' to keep the application's button from appearing on the Windows Taskbar.
This example uses a tray icon and an application events component on a form. When the application runs, it loads the tray icon, the icons displayed when it is animated, and it also sets up a hint balloon. When you minimize the window, the form is hidden, a hint balloon shows up, and the tray icon is displayed and animated. Double-clicking the system tray icon restores the window.
// Add this to the `TApplicationEvents.OnMinimize` event handler
procedure TForm1.ApplicationEvents1Minimize(Sender: TObject);
begin
{ Hide the window and set its state variable to wsMinimized. }
Hide();
WindowState := wsMinimized;
{ Show the animated tray icon and also a hint balloon. }
TrayIcon1.Visible := True;
TrayIcon1.Animate := True;
TrayIcon1.ShowBalloonHint;
end;
// Add this to the `TForm.OnCreate` event handler
procedure TForm1.FormCreate(Sender: TObject);
var
MyIcon : TIcon;
begin
{ Load the tray icons. }
TrayIcon1.Icons := TImageList.Create(Self);
MyIcon := TIcon.Create;
MyIcon.LoadFromFile('icons/earth1.ico');
TrayIcon1.Icon.Assign(MyIcon);
TrayIcon1.Icons.AddIcon(MyIcon);
MyIcon.LoadFromFile('icons/earth2.ico');
TrayIcon1.Icons.AddIcon(MyIcon);
MyIcon.LoadFromFile('icons/earth3.ico');
TrayIcon1.Icons.AddIcon(MyIcon);
MyIcon.LoadFromFile('icons/earth4.ico');
TrayIcon1.Icons.AddIcon(MyIcon);
{ Set up a hint message and the animation interval. }
TrayIcon1.Hint := 'Hello World!';
TrayIcon1.AnimateInterval := 200;
{ Set up a hint balloon. }
TrayIcon1.BalloonTitle := 'Restoring the window.';
TrayIcon1.BalloonHint :=
'Double click the system tray icon to restore the window.';
TrayIcon1.BalloonFlags := bfInfo;
end;
// Add this to the `TTrayIcon.OnDoubleClick` event handler
procedure TForm1.TrayIcon1DblClick(Sender: TObject);
begin
{ Hide the tray icon and show the window,
setting its state property to wsNormal. }
TrayIcon1.Visible := False;
Show();
WindowState := wsNormal;
Application.BringToFront();
end;
For the menu you get on right-click, add a TPopupMenu to your form, add the items you want on it, write the event handlers for those items as usual, and then assign the PopupMenu to the TrayIcon.PopupMenu property.
The "blurred icons" are caused by you not using the proper icon sizes and Windows being forced to scale (stretch) them. Use an icon editor to create multiple size images for each icon (there can be multiple sizes in one icon file).
I drop a TrayIcon onto myForm, then i add this simple code:
type
TmyForm = class(TForm)
...
TrayIcon: TTrayIcon;
procedure FormCreate(Sender: TObject);
...
procedure TrayIconClick(Sender: TObject);
...
private
{ Private declarations }
procedure OnMinimize(Sender:TObject);
public
{ Public declarations }
end;
procedure TmyForm.FormCreate(Sender: TObject);
begin // When form is created
Application.OnMinimize:=OnMinimize; // Set the event handler for application minimize
end;
procedure TmyForm.OnMinimize(Sender:TObject);
begin // When application is minimized by user and/or by code
Hide; // This is to hide it from taskbar
end;
procedure TmyForm.TrayIconClick(Sender: TObject);
begin // When clicking on TrayIcon
if Visible
then begin // Application is visible, so minimize it to TrayIcon
Application.Minimize; // This is to minimize the whole application
end
else begin // Application is not visible, so show it
Show; // This is to show it from taskbar
Application.Restore; // This is to restore the whole application
end;
end;
This creates a TrayIcon allways visible, and when you click on it:
If the application is Visible, it will be Hidden form taskbar and from screen
If the application is Hidden, it will be Shown form taskbar and from screen
In other words, clicking on TrayIcon the application will change its visibility; just as minimizing it to TrayIcon bar.
...And in Delphi 6, where no TTrayIcon exists, you can use this simple code:
unit MainUnit;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ShellAPI, StdCtrls, Menus;
const WM_ICONTRAY = WM_USER+1;
type
TForm1 = class(TForm)
PopupMenu1: TPopupMenu;
ShowForm1: TMenuItem;
HideForm1: TMenuItem;
Exit1: TMenuItem;
procedure TrayMessage(var Msg: TMessage); message WM_ICONTRAY;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure ShowForm1Click(Sender: TObject);
procedure HideForm1Click(Sender: TObject);
procedure Exit1Click(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
TrayIconData: TNotifyIconData;
end;
var
Form1: TForm1;
MustExit:boolean;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
MustExit:=false;
TrayIconData.cbSize:=SizeOf(TrayIconData);
TrayIconData.Wnd:=Handle;
TrayIconData.uID:=0;
TrayIconData.uFlags:=NIF_MESSAGE + NIF_ICON + NIF_TIP;
TrayIconData.uCallbackMessage:=WM_ICONTRAY;
TrayIconData.hIcon:=Application.Icon.Handle;
StrPCopy(TrayIconData.szTip,Application.Title);
Shell_NotifyIcon(NIM_ADD, #TrayIconData);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
Shell_NotifyIcon(NIM_DELETE, #TrayIconData);
end;
procedure TForm1.TrayMessage(var Msg: TMessage);
var p:TPoint;
begin
case Msg.lParam of
WM_LBUTTONDOWN: begin
Form1.Show;
Application.Restore;
end;
WM_RBUTTONDOWN: begin
GetCursorPos(p);
PopUpMenu1.Popup(p.x,p.y);
end;
end;
end;
// Popup "Form Show" menu item OnClick
procedure TForm1.ShowForm1Click(Sender: TObject);
begin
Form1.Show;
end;
// Popup "Form Hide" menu item OnClick
procedure TForm1.HideForm1Click(Sender: TObject);
begin
Form1.Hide;
end;
// Popup "Exit" menu item OnClick
procedure TForm1.Exit1Click(Sender: TObject);
begin
MustExit:=true;
Close;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
if MustExit then exit;
Form1.Hide;
Action:=caNone;
end;
end.
I have implemented the following codes. Here everything is fine except one. After minimizing the Form, it goes to "SystemTray" but also available in "TaskBar. For my application, the "AlphaBlend" property of "Form001" is true and "AlphaBlendValue" is "0".
unit KoushikHalder001;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.Buttons, Vcl.ExtCtrls, Vcl.Imaging.pngimage,
Vcl.AppEvnts, Vcl.ImgList, Vcl.Menus;
type
TForm001 = class(TForm)
Edit001: TEdit;
Background: TImage;
BitBtn001: TBitBtn;
BitBtn002: TBitBtn;
FadeInTimer: TTimer;
FadeOutTimer: TTimer;
FormMinimizeTimer: TTimer;
FormRestoreTimer: TTimer;
TrayIcon: TTrayIcon;
PopupMenu: TPopupMenu;
ImageList: TImageList;
ApplicationEvents: TApplicationEvents;
Form001Close: TMenuItem;
Form001Hide: TMenuItem;
Form001Show: TMenuItem;
Form002Close: TMenuItem;
Form002Hide: TMenuItem;
Form002Show: TMenuItem;
N01: TMenuItem;
N02: TMenuItem;
N03: TMenuItem;
N04: TMenuItem;
N05: TMenuItem;
N06: TMenuItem;
N07: TMenuItem;
N08: TMenuItem;
N09: TMenuItem;
N10: TMenuItem;
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
procedure FormCreate(Sender: TObject);
procedure FormHide(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure BitBtn001Click(Sender: TObject);
procedure BitBtn002Click(Sender: TObject);
procedure FadeInTimerTimer(Sender: TObject);
procedure FadeOutTimerTimer(Sender: TObject);
procedure FormMinimizeTimerTimer(Sender: TObject);
procedure FormRestoreTimerTimer(Sender: TObject);
procedure ApplicationEventsMinimize(Sender: TObject);
procedure TrayIconDblClick(Sender: TObject);
procedure Form001CloseClick(Sender: TObject);
procedure Form001HideClick(Sender: TObject);
procedure Form001ShowClick(Sender: TObject);
procedure Form002CloseClick(Sender: TObject);
procedure Form002HideClick(Sender: TObject);
procedure Form002ShowClick(Sender: TObject);
private
{ Private declarations }
CrossButtonClick: Boolean;
procedure WMNCHitTest(var Msg: TWMNCHitTest) ; message WM_NCHitTest;
procedure WMSysCommand(var Msg: TWMSysCommand) ; message WM_SysCommand;
public
{ Public declarations }
end;
var
Form001: TForm001;
implementation
{$R *.dfm}
uses KoushikHalder002;
procedure TForm001.WMNCHitTest(var Msg: TWMNCHitTest);
begin
inherited;
if ControlAtPos(ScreenToClient(Msg.Pos), True, True, True)= nil
then
begin
if Msg.Result=htClient then Msg.Result := htCaption;
end;
end;
procedure TForm001.WMSysCommand(var Msg: TWMSysCommand);
begin
case Msg.CmdType of
SC_MINIMIZE:
begin
if Form001.AlphaBlendValue > 0 then
begin
Form001.FormMinimizeTimer.Enabled := true;
Exit;
end;
end;
SC_RESTORE:
begin
if Form001.AlphaBlendValue < 220 then
begin
Form001.FormRestoreTimer.Enabled := True;
end;
end;
end;
inherited;
end;
procedure TForm001.ApplicationEventsMinimize(Sender: TObject);
begin
Form001.FormMinimizeTimer.Enabled := true;
TrayIcon.Visible := True;
TrayIcon.Animate := True;
TrayIcon.ShowBalloonHint;
end;
procedure TForm001.BitBtn001Click(Sender: TObject);
begin
if Form002.WindowState = wsMinimized then
begin
Form002.Perform(WM_SYSCOMMAND, SC_RESTORE, 0);
end
else
Form002.show;
end;
procedure TForm001.BitBtn002Click(Sender: TObject);
begin
Form002.FadeOutTimer.Enabled := true;
Form001.FadeOutTimer.Enabled := true;
end;
procedure TForm001.Form001CloseClick(Sender: TObject);
begin
Form002.FadeOutTimer.Enabled := true;
Form001.FadeOutTimer.Enabled := true;
end;
procedure TForm001.Form001HideClick(Sender: TObject);
begin
Form001.FormMinimizeTimer.Enabled := true;
end;
procedure TForm001.Form001ShowClick(Sender: TObject);
begin
if Form001.WindowState = wsMinimized then
begin
Form001.Perform(WM_SYSCOMMAND, SC_RESTORE, 0);
end
else
Form001.show;
end;
procedure TForm001.Form002CloseClick(Sender: TObject);
begin
Form002.FadeOutTimer.Enabled := true;
end;
procedure TForm001.Form002HideClick(Sender: TObject);
begin
Form002.FormMinimizeTimer.Enabled := true;
end;
procedure TForm001.Form002ShowClick(Sender: TObject);
begin
if Form002.WindowState = wsMinimized then
begin
Form002.Perform(WM_SYSCOMMAND, SC_RESTORE, 0);
end
else
Form002.show;
end;
procedure TForm001.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Form001.FadeOutTimer.Enabled := true;
end;
procedure TForm001.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
if CrossButtonClick = true
then
begin
CanClose := true;
Exit;
end;
CanClose := false;
Form001.FadeOutTimer.Enabled := true;
end;
procedure TForm001.FormCreate(Sender: TObject);
begin
Form001.FadeInTimer.Enabled := true;
end;
procedure TForm001.FormHide(Sender: TObject);
begin
Form001.FadeOutTimer.Enabled := true;
end;
procedure TForm001.FormShow(Sender: TObject);
begin
Form001.FadeInTimer.Enabled := true;
end;
procedure TForm001.TrayIconDblClick(Sender: TObject);
begin
Form001.FormRestoreTimer.Enabled := true;
TrayIcon.Visible := False;
WindowState := wsNormal;
Application.BringToFront();
end;
procedure TForm001.FadeInTimerTimer(Sender: TObject);
begin
if Form001.AlphaBlendValue >= 220
then
begin
Form001.FadeInTimer.Enabled := false;
end
else
begin
Form001.AlphaBlendValue := Form001.AlphaBlendValue + 10;
CrossButtonClick := false;
end;
end;
procedure TForm001.FadeOutTimerTimer(Sender: TObject);
begin
if Form001.AlphaBlendValue <= 0
then
begin
Form001.FadeOutTimer.Enabled := false;
CrossButtonClick := true;
Self.Close;
end
else
begin
Form001.AlphaBlendValue := Form001.AlphaBlendValue - 10;
CrossButtonClick := true;
end;
end;
procedure TForm001.FormMinimizeTimerTimer(Sender: TObject);
begin
if Form001.AlphaBlendValue > 0 then
begin
Form001.AlphaBlendValue := Form001.AlphaBlendValue - 10;
end
else
begin
Form001.FormMinimizeTimer.Enabled := false;
Perform(WM_SYSCOMMAND, SC_MINIMIZE, 0);
end;
end;
procedure TForm001.FormRestoreTimerTimer(Sender: TObject);
begin
if Form001.AlphaBlendValue < 220 then
begin
Form001.AlphaBlendValue := Form001.AlphaBlendValue + 10;
end
else
begin
Form001.FormRestoreTimer.Enabled := false;
end;
end;
end.
If I do the following
Application.MainFormOnTaskbar := false;
the form is totally invissible. I think there should be one bug. But I am unable to find it.

Firemonkey: Image.Bitmap.DrawLine not visible on ipad

I'm building a app in DelphiXE2 firemonkey for IOS. If I tested on the mac in the Xcode IPAD Simulator I saw the button. But when I click on the button no line is visible. Why?
code: (On the Form a button and a Image)
unit Unit3;
interface
uses
SysUtils, Types, UITypes, Classes, Variants, FMX_Types, FMX_Controls, FMX_Forms,
FMX_Dialogs, FMX_Objects;
type
TForm3 = class(TForm)
Image1: TImage;
Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private-Deklarationen }
public
{ Public-Deklarationen }
end;
var
Form3: TForm3;
implementation
{$R *.lfm}
procedure TForm3.Button1Click(Sender: TObject);
var pt0,pt1 : TPointF;
begin
pt0.Create(0,0);
pt1.Create(200,200);
with Image1.Bitmap do begin
Canvas.Stroke.Color := $ffff0000 ; // Red
Canvas.BeginScene;
Canvas.DrawLine(pt0,pt1,1);
BitmapChanged; // without this, no output
Canvas.EndScene;
end;
end;
procedure TForm3.FormCreate(Sender: TObject);
begin
Image1.Bitmap := TBitmap.Create(200,200);
end;
end.
I think it should be:
pt0 := TPointF.Create(0, 0);
Try this
pt0.X:=X;
pt0.Y:=Y;
pt1.X:=X+4;
pt1.Y:=Y+4;
with Image1.Bitmap do begin
Canvas.Stroke.Color := $ffff0000 ; // Red
Canvas.Stroke.Kind := TBrushKind.bkSolid;
Canvas.StrokeThickness:= 10;
Canvas.BeginScene;
Canvas.DrawLine(pt0,pt1,100);
Canvas.EndScene;
end;

Resources