OSX Yosemite and XE7 Firemonkey - macos

can anybody tell me how to make a TTrackBar object read only in C++Builder (or Delphi) XE7 in an OSX firemonkey application?
I tried the "Locked" property but it seems not working.
Cheers
dodo

Set the Enabled property to False. Locked locks the position of the trackbar in the designer so that you cannot accidentally move it.

Here's another answer because of your additional requirements. There is no "readonly" property that will keep the TrackBar enabled.
You could just use the TrackBar.OnChange event and just reset the value if the user tries to change it:
procedure TForm1.TrackBar1Change(Sender: TObject);
begin
TrackBar1.Value := 50;
end;
A more advanced approach is using an observer in order to get a true readonly TrackBar.
TReadOnlyTrackObserver = class(TInterfacedObject, IEditLinkObserver, IObserver, ISingleCastObserver)
public
procedure Removed;
function GetActive: Boolean;
procedure SetActive(Value: Boolean);
function GetOnObserverToggle: TObserverToggleEvent;
procedure SetOnObserverToggle(AEvent: TObserverToggleEvent);
procedure Update;
function Edit: Boolean;
procedure Reset;
procedure Modified;
function IsModified: Boolean;
function IsValidChar(AKey: Char): Boolean;
function IsRequired: Boolean;
function GetIsReadOnly: Boolean;
procedure SetIsReadOnly(Value: Boolean);
property IsReadOnly: Boolean read GetIsReadOnly write SetIsReadOnly;
function GetIsEditing: Boolean;
property IsEditing: Boolean read GetIsEditing;
procedure BeginUpdate;
procedure EndUpdate;
function GetUpdating: Boolean;
property Updating: Boolean read GetUpdating;
end;
function TReadOnlyTrackObserver.GetActive: Boolean;
begin
Result := True;
end;
function TReadOnlyTrackObserver.GetIsReadOnly: Boolean;
begin
Result := True;
end;
// todo: implement the other required functions of TReadOnlyTrackObserver
var
MyObserver: IEditLinkObserver;
MyObserver := TReadOnlyTrackObserver.Create;
TrackBar1.Observers.AddObserver(TObserverMapping.EditLinkID, MyObserver);

Related

How to use smart pointer on default constructor

So, once again I am learning new things and I came across Smart Pointers. I had code
procedure TForm3.BitBtn1Click(Sender: TObject);
var
_StringList: ISmartPointer<TStringList>;
begin
_StringList := TSmartPointer<TStringList>.Create(TStringList.Create);
end;
As you see variable declaration is kinda odd, and simplification is needed. I came across another solution
procedure TForm3.btnDelphiClick(Sender: TObject);
var
_StringList: TStringList;
begin
_StringList := SmartGuard.SmartGuard<TStringList>(TStringList.Create(False));
end;
Sadly, it does not work with parameterless constructor
procedure TForm3.btnDelphiClick(Sender: TObject);
var
_StringList: TStringList;
begin
_StringList := SmartGuard.SmartGuard<TStringList>(TStringList.Create);
end;
[dcc32 Error] Main.pas(47): E2089 Invalid typecast
Am I out of luck here?
P.S. I know some of you would argue I should stick to try..finally block, but this is out of curiosity.
unit SmartGuard;
interface
type
IGuard = interface
['{CE522D5D-41DE-4C6F-BC84-912C2AEF66B3}']
end;
TGuard = class(TInterfacedObject, IGuard)
private
FObject: TObject;
public
constructor Create(AObject: TObject);
destructor Destroy; override;
end;
SmartGuard<T: class> = record
private
FGuard: IGuard;
FGuardedObject: T;
public
class operator Implicit(GuardedObject: T): SmartGuard<T>;
class operator Implicit(Guard: SmartGuard<T>): T;
end;
implementation
uses
{Delphi}
System.SysUtils
{Project}
;
constructor TGuard.Create(AObject: TObject);
begin
FObject := AObject;
end;
destructor TGuard.Destroy;
begin
FObject.Free;
inherited;
end;
{ SmartGuard }
class operator SmartGuard<T>.Implicit(GuardedObject: T): SmartGuard<T>;
begin
Result.FGuard := TGuard.Create(GuardedObject);
Result.FGuardedObject := GuardedObject;
end;
class operator SmartGuard<T>.Implicit(Guard: SmartGuard<T>): T;
begin
Result := Guard.FGuardedObject;
end;
end.
I would love to find a solution that would not require additional "method" calling as in here https://github.com/marcocantu/DelphiSessions/blob/master/DelphiLanguageCodeRage2018/02_SmartPointers/SmartPointerClass.pas e.g. _StringList.Value.Add('foo'); and "special" brackets e.g. _StringList := TSmartPointer<TStringList>.Create(TStringList.Create)();
The compiler needs help disambiguating
TStringList.Create
The compiler doesn't know whether this is a reference to a method, or a call to the method.
Disambiguate by adding parens to indicate that it is a call.
_StringList := SmartGuard.SmartGuard<TStringList>(TStringList.Create());

Delphi tray icon (NSStatusItem) for OSX

I am trying to add NSStatusItem in a Delphi application for OSX. Searched for sample code to help me with that but got stuck when defining an interface:
Here is the code:
// Source: https://forums.embarcadero.com/thread.jspa?threadID=108449
unit Unit2;
interface
uses Macapi.ObjectiveC, Macapi.CocoaTypes, Macapi.Foundation, Macapi.AppKit,
Macapi.Helpers, Macapi.ObjcRuntime, System.TypInfo, FMX.Platform, FMX.Platform.Mac;
type
TFMXTrayItem = class(TOCLocal)
private
NSStatItem : NSStatusItem;
public
constructor Create;
destructor Destroy; override;
function GetObjectiveCClass: PTypeInfo; override;
procedure call_mymethod; cdecl;
end;
implementation
constructor TFMXTrayItem.Create;
var
NSContMenu : NSMenu;
NSContItem : NSMenuItem;
NSStatBar : NSStatusBar;
NSImg : NSImage;
AppBundle : NSBundle;
NSpImg: Pointer;
Path: String;
begin
inherited Create;
NSStatBar := TNSStatusBar.Create;
NSStatBar := TNSStatusBar.Wrap(TNSStatusBar.OCClass.systemStatusBar);
NSStatItem:= NSStatBar.statusItemWithLength(NSVariableStatusItemLength);
NSStatItem.setTarget(GetObjectID);
// Create context menu
NSContMenu := TNSMenu.Create;
NSContMenu := TNSMenu.Wrap(NSContMenu.initWithTitle(StrToNSStr('The caption')));
NSContItem:=TNSMenuItem.Create;
NSContItem:=TNSMenuItem.Wrap(NSContItem.initWithTitle(StrToNSStr('1. menuitem'),sel_getUid(PAnsiChar('call_mymethod')),StrToNSStr('')));
NSContItem.setTarget(GetObjectID);
NSContMenu.addItem(NSContItem);
NSContItem.release;
// Add menu
NSStatItem.retain;
NSStatItem.setHighlightMode(true);
NSStatItem.setMenu(NSContMenu);
NSContMenu.release;
// Get path to dir
AppBundle := TNSBundle.Wrap(TNSBundle.OCClass.mainBundle);
Path:=AppBundle.bundlePath.UTF8String+'/Contents/yourimage16x16.png';
NSpImg := TNSImage.Alloc.initWithContentsOfFile(StrToNSStr(Path));
// Create Icon
NSImg := TNSImage.Create;
NSImg := TNSImage.Wrap(NSpImg);
NSStatItem.setImage(NSImg);
NSImg.release;
end;
destructor TFMXTrayItem.Destroy;
begin
NSStatItem.release;
inherited;
end;
function TFMXTrayItem.GetObjectiveCClass: PTypeInfo;
begin
Result :=TypeInfo(IFMXTrayItem);
end;
procedure TFMXTrayItem.call_properties;
begin
// your event code of the menu item
end;
end.
Does anyone have any idea on how to declare the IFMXTrayItem interface?
Got it to work like this:
type
IFMXTrayItem = interface(NSObject)
['{7d2e4b38-61d9-4cf4-b78b-5f7c4188e9c0}']
procedure call_mymethod; cdecl;
end;
later edit:
Added a GUID to the interface after reading this:
This GUID is used by the compiler to identify uniquely this interface.
Strictly speaking, you can use an interface without the GUID, but you
can’t get very far using them as much of the RTL and most frameworks
that take advantage of interfaces will require that they have a GUID.
So that is a random GUID I generated but if you use this in your code you should generate your own GUID.

how do I intercept was pressed the F1 key on my main window?

How to do that when I'm in the main window of my system by pressing F1 will display the help muetre in pdf format. how do I intercept was pressed the F1 key on my main window?
I use Delphi XE2
Thanks for the help!
Use the Application.OnHelpCommand event, which you can either assign in code:
interface
type
TForm1 = class(TForm)
// IDE generated code
private
procedure AppOnHelp(Command: Word; Data: Integer;
var CallHelp: Boolean);
end;
implementation
procedure TForm1.FormCreate(Sender: TObject);
begin
Application.OnHelp := AppOnHelp;
end;
Or assign by using a TApplicationEvents component and creating a handler for the OnHelp event in the Object Inspector's Events tab.
You can set CallHelp to false to prevent the normal help processing, and launch your own help file via ShellExecute.
procedure TForm1.AppOnHelp(Command: Word; Data: Integer;
var CallHelp: Boolean);
begin
CallHelp := False;
// Launch your own help here
end;

Invoke methods in Pascal

I am in front of following problem:
My Main programming Language is C++ with the Qt4 Library, but now I have to write a Pascal Wrapper, which should give the possibility to use the functions of a C DLL in Pascal.
Now I want to make it possible to invoke a method from any Pointer. But I can't find a Pascal method to invoke a method. I want something like the QMetaObject::invokeMethod method in QT. I got following code:
unit CgPConnect;
//{$mode objfpc}{$H+}
{$mode delphi}
interface
uses
Classes, SysUtils, dynlibs;
type
Callback = Record
var callbackObject: Pointer;
var objectFunction: string;
end;
CallbackObject = Record
var objectName: string;
var callback: Callback;
end;
MutableObject = Object
var name: string;
var state: string;
var properties: array of VariantMap;
var annotations: array of VariantMap;
end;
PConnect = Class
constructor create(connectorPath: string);
destructor destroy;
private
var hostactionCallbacks: array of CallbackObject;
var mConnectorPath: string;
var mConnectorLibrary: TLibHandle;
function loadConnectorLibrary: Boolean;
public
procedure registerCallbackForHostaction(objectName, objectFunction: string; callbackObject: pointer);
procedure callHostactionCallback(receivedObject :MutableObject);
var mLibraryLoaded: Boolean;
end;
implementation
constructor PConnect.create(connectorPath: string);
begin
mConnectorPath:= connectorPath;
mLibraryLoaded:= false;
//Eventuell noch slash hinzufügen
mLibraryLoaded:= loadConnectorLibrary;
end;
destructor PConnect.destroy;
begin
UnloadLibrary(mConnectorLibrary);
end;
procedure PConnect.registerCallbackForHostaction(objectName, objectFunction: string; callbackObject: pointer);
var c: Callback;
var callbackCount: integer;
begin
if mLibraryLoaded = true then
begin
c.callbackObject:= callbackObject;
c.objectFunction:= objectFunction;
callbackCount:= Length(hostactionCallbacks)+1;
SetLength(hostactionCallbacks, callbackCount);
hostactionCallbacks[callbackCount].objectName:= objectName;
hostactionCallbacks[callbackCount].callback:= c;
end;
end;
procedure PConnect.callHostactionCallback(receivedObject :MutableObject);
var receivedObjectName, objectFunction: string;
var i, count: integer;
var callbackObject: pointer;
begin
if mLibraryLoaded = true then
begin
receivedObjectName:= receivedObject.name;
count:= Length(hostactionCallbacks);
for i:=0 to count do
begin
if hostactionCallbacks[i].objectName = receivedObjectName
begin
objectFunction:= hostactionCallbacks[i].callback.objectFunction;
callbackObject:= hostactionCallbacks[i].callback.callbackObject;
if callbackObject <> 0 then
//INVOKE METHOD (objectFunction) OF OBJECT (callbackObject)
end;
end;
end;
end;
end.
I would be happy about a fast answer :)
You cannot directly and portably call a C++ method from Pascal. If your callbackfunction is a C++ object, forget it.
Otherwise fill a TMethod object and cast that to the proper "procedure of object" declaration. Don't forget the calling convention.
For more bizarre solutions you might want to have a look at (RemObjects') Pascalscript.
P.s. this is the same that you can't even call a C++ method reliably from another C++ compiler. It is not Pascal vs C++ per se.

Looking for a custom image grid

I'm trying to find a grid which is especially designed to show images. It needs to have good performance too, and preferably with some sort of thumbnail cache. The images need to be loaded from files, and it would be good if images can be assigned dynamically too. It shouldn't work on a list of col/row records like standard grids, but a single list of items, each item representing an image. There should be a property to define col width and row height for all cols and rows at once, not one at a time. The end goal is to list all images with user options to control how large to display the images. It will be used as a product display, so there needs to be some sort of custom drawing capability too, like an OnDrawItem event. This may display up to 50,000 images in this list, so TListView won't work, as it's very heavy for this.
It needs to work with Delphi 2010, XE2, and preferably 7 too.
Here's 3 examples of how to display 8 images below. I don't mean each image being a different size, but exactly the same size. No 2 columns can have different widths, and same with rows.
For the fun of it, I wrote an ImageGrid component for you.
It has only a vertical scroll bar; resizing the width of the control adjusts the column count and row count. The images are cached as resized bitmaps in an internal list, along with their file names.
Because loading and resampling these images may take some time, depending on image count, resolution and whether you want to use the Graphics32 library for better resample quality, the component delegates the loading process to a separate thread, which (re)runs on setting the column width or the row height, and on changing the file names or the folder path in which the component tries to find all images of types to be supplied in the FileFormats property.
Features:
Creates and resizes image thumbs in a background thread, from file names with the GDI+ library or from manually added images with the Graphics 32 library
Automatically recognizes all registered image file formats
Animated scrolling
Touchscreen support for scrolling by dragging the grid
Keyboard support for selecting thumbs
OwnerDraw support, e.g. for adding captions to the thumbs
Virtual support for bypassing the automatic creation of thumbs
Properties and events:
ColCount: number of columns, readonly
Count: number of images, readonly
Images: list of all manually added images where the thumbs are internally created from
Items: list of all filename-thumbnail or image-thumbnail combinations
RowCount: number of rows, readonly
Thumbs: list of all internally created thumbs
AutoHideScrollBar: hides the scroll bar when all rows are visible
BorderStyle: shows or hides themed border
BorderWidth: margin of the component, outside of the scroll bar
CellAlignment: alignes thumbs at the left, center or right of the cell
CellHeight: height of cell
CellLayout: alignes thumbs at the top, middle or bottom of the cell
CellSpacing: spacing between the cells
CellWidth: width of cell
Color: background color of border and cell spacing
ColWidth: width of column (equals width of cell plus cell spacing)
DefaultDrawing: draws all thumbs by default
DesignPreview: shows thumbs in the designer
DragScroll: supports scrolling the grid by draging the grid
FileFormats: image file name extensions by which the file names are filtered
FileNames: list holding all file names
Folder: the directory in which the component tries to find all images files
ItemIndex: selected cell index
MarkerColor: color of temporarily thumb marker during loading process
MarkerStyle: style of temporarily thumb marker during loading process
OnClickCell: fires when a cell is clicked
OnDrawCell: fires when a cell is drawn
OnMeasureThumb: fires when the size of a thumb is to be calculated
OnProgress: fires when an image is resized to thumb format
OnUnresolved: fires when a thumb cannot be created, e.g. when file name is not found
RetainUnresolvedItems: keeps empty thumbs in the list
RowHeight: the row height (equals cell height plus cell spacing)
ParentBackground: draws the (themed) background of the parent in the border and between the cells
Proportional: resizes images proportionally
Sorted: file names are sorted
Stretch: stretches small images up to the cell size
VirtualMode: prevents of automatically creating the thumbs
WheelScrollLines: number of rows to be scrolled with mouse wheel
With thanks to:
InterfaceLIFT for the images shown in the screenshot above
How to create a slowing scroll effect on a scrollbox?
How to get all of the supported file formats from Graphics unit?
Is it necessary to convert String to WideString?
Bugfix for BorderWidth > 0 in combination with a scroll bar?
The code is too long to post here, but the OpenSource project is downloadable from the GitHub server here. This is the interface section:
unit AwImageGrid;
interface
{$DEFINE USE_GR32}
uses
Windows, Classes, SysUtils, Messages, Controls, Graphics, Forms, StdCtrls,
Grids, GDIPAPI, GDIPOBJ, RTLConsts, Math, Themes
{$IFDEF USE_GR32}, GR32, GR32_Resamplers {$ENDIF};
const
DefCellSpacing = 5;
DefCellWidth = 96;
DefCellHeight = 60;
DefColWidth = DefCellWidth + DefCellSpacing;
DefRowHeight = DefCellHeight + DefCellSpacing;
MinThumbSize = 4;
MinCellSize = 8;
type
PImageGridItem = ^TImageGridItem;
TImageGridItem = record
FFileName: TFileName;
FObject: TObject;
FImage: TGraphic;
FThumb: TBitmap;
end;
PImageGridItemList = ^TImageGridItemList;
TImageGridItemList = array[0..MaxListSize div 2] of TImageGridItem;
{ TImageGridItems
The managing object for holding filename-thumbnail or image-thumbnail
combinations in an array of TImageGridItem elements. When an item's image
changes, the item's thumb is freed. When an item's filename changes, then
the item's thumb is freed only if the item's image is unassigned. }
TImageGridItems = class(TStrings)
private
FCapacity: Integer;
FChanged: Boolean;
FCount: Integer;
FList: PImageGridItemList;
FOnChanged: TNotifyEvent;
FOnChanging: TNotifyEvent;
FOwnsObjects: Boolean;
FSorted: Boolean;
procedure ExchangeItems(Index1, Index2: Integer);
function GetImage(Index: Integer): TGraphic;
function GetThumb(Index: Integer): TBitmap;
procedure Grow;
procedure InsertItem(Index: Integer; const S: String; AObject: TObject;
AImage: TGraphic; AThumb: TBitmap);
procedure PutImage(Index: Integer; AImage: TGraphic);
procedure PutThumb(Index: Integer; AThumb: TBitmap);
procedure QuickSort(L, R: Integer);
procedure SetSorted(Value: Boolean);
protected
function CompareStrings(const S1, S2: String): Integer; override;
procedure Changed; virtual;
procedure Changing; virtual;
function Get(Index: Integer): String; override;
function GetCapacity: Integer; override;
function GetCount: Integer; override;
function GetObject(Index: Integer): TObject; override;
procedure Put(Index: Integer; const S: String); override;
procedure PutObject(Index: Integer; AObject: TObject); override;
procedure PutThumbSilently(Index: Integer; AThumb: TBitmap); virtual;
procedure SetCapacity(Value: Integer); override;
procedure SetUpdateState(Updating: Boolean); override;
public
function Add(const S: String): Integer; override;
function AddImage(const S: String; AImage: TGraphic): Integer; virtual;
function AddItem(const S: String; AObject: TObject; AImage: TGraphic;
AThumb: TBitmap): Integer; virtual;
function AddObject(const S: String; AObject: TObject): Integer; override;
function AddThumb(const S: String; AThumb: TBitmap): Integer; virtual;
procedure AddStrings(Strings: TStrings); override;
procedure Assign(Source: TPersistent); override;
procedure Clear; override;
procedure ClearThumbs; virtual;
procedure Delete(Index: Integer); override;
destructor Destroy; override;
procedure Exchange(Index1, Index2: Integer); override;
function IndexOf(const S: String): Integer; override;
procedure Insert(Index: Integer; const S: String); override;
procedure InsertObject(Index: Integer; const S: String;
AObject: TObject); override;
function Find(const S: String; var Index: Integer): Boolean;
procedure Sort; virtual;
property FileNames[Index: Integer]: String read Get write Put;
property Images[Index: Integer]: TGraphic read GetImage write PutImage;
property OnChanged: TNotifyEvent read FOnChanged write FOnChanged;
property OnChanging: TNotifyEvent read FOnChanging write FOnChanging;
property OwnsObjects: Boolean read FOwnsObjects write FOwnsObjects;
property Sorted: Boolean read FSorted write SetSorted;
property Thumbs[Index: Integer]: TBitmap read GetThumb write PutThumb;
end;
{ TBorderControl
A control with a system drawn border following the current theme, and an
additional margin as implemented by TWinControl.BorderWidth. }
TBorderControl = class(TCustomControl)
private
FBorderStyle: TBorderStyle;
procedure SetBorderStyle(Value: TBorderStyle);
procedure WMNCPaint(var Message: TWMNCPaint); message WM_NCPAINT;
procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
protected
procedure CreateParams(var Params: TCreateParams); override;
function TotalBorderWidth: Integer; virtual;
public
constructor Create(AOwner: TComponent); override;
property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle
default bsSingle;
property BorderWidth;
end;
{ TAnimRowScroller
A scroll box with a vertical scroll bar and vertically stacked items with a
fixed row height. Scrolling with the scroll bar is animated alike Windows'
own default list box control. Scrolling is also possible by dragging the
content with the left mouse button. }
TAnimRowScroller = class(TBorderControl)
private
FAutoHideScrollBar: Boolean;
FDragScroll: Boolean;
FDragScrolling: Boolean;
FDragSpeed: Single;
FDragStartPos: Integer;
FPrevScrollPos: Integer;
FPrevTick: Cardinal;
FRow: Integer;
FRowCount: Integer;
FRowHeight: Integer;
FScrollingPos: Integer;
FScrollPos: Integer;
FWheelScrollLines: Integer;
procedure Drag;
function IsWheelScrollLinesStored: Boolean;
procedure Scroll;
procedure SetAutoHideScrollBar(Value: Boolean);
procedure SetRow(Value: Integer);
procedure SetRowCount(Value: Integer);
procedure SetScrollPos(Value: Integer; Animate, Snap: Boolean);
procedure UpdateScrollBar;
procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL;
protected
procedure CreateWnd; override;
function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
MousePos: TPoint): Boolean; override;
procedure DrawFocusRect; virtual;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer); override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer); override;
procedure Resize; override;
procedure SetRowHeight(Value: Integer); virtual;
procedure WndProc(var Message: TMessage); override;
property AutoHideScrollBar: Boolean read FAutoHideScrollBar
write SetAutoHideScrollBar default True;
property Row: Integer read FRow write SetRow default -1;
property RowCount: Integer read FRowCount write SetRowCount;
property RowHeight: Integer read FRowHeight write SetRowHeight
default DefRowHeight;
property DragScroll: Boolean read FDragScroll write FDragScroll
default True;
property DragScrolling: Boolean read FDragScrolling;
property ScrollingPos: Integer read FScrollingPos;
property WheelScrollLines: Integer read FWheelScrollLines
write FWheelScrollLines stored IsWheelScrollLinesStored;
public
constructor Create(AOwner: TComponent); override;
procedure MouseWheelHandler(var Message: TMessage); override;
function Scrolling: Boolean;
end;
{ TCustomImageGrid
The base class of an image grid. It shows images from left to right, then
from top to bottom. The number of columns is determined by the width of the
control, possibly resulting in a vertical scroll bar. The coord size is set
by ColWidth and RowHeight, being the sum of CellWidth resp. CellHeight plus
CellSpacing. Each cell shows a thumb of the corresponding image. The control
automatically starts a thumbs generating background thread when an image's
graphic, filename or its cell size is changed. Before every such change, any
previously created thread is terminated. Combine multiple changes by calling
Items.BeginUpdate/Items.EndUpdate to prevent the thread from being recreated
repeatedly. }
TCustomImageGrid = class;
TPath = type String;
TDrawCellEvent = procedure(Sender: TCustomImageGrid; Index, ACol,
ARow: Integer; R: TRect) of object;
TImageEvent = procedure(Sender: TCustomImageGrid; Index: Integer) of object;
TMeasureThumbEvent = procedure(Sender: TCustomImageGrid; Index: Integer;
var AThumbWidth, AThumbHeight: Integer) of object;
TCustomImageGrid = class(TAnimRowScroller)
private
FCellAlignment: TAlignment;
FCellLayout: TTextLayout;
FCellSpacing: Integer;
FColCount: Integer;
FColWidth: Integer;
FDefaultDrawing: Boolean;
FDesignPreview: Boolean;
FFileFormats: TStrings;
FFolder: TPath;
FItemIndex: Integer;
FItems: TImageGridItems;
FMarkerColor: TColor;
FMarkerStyle: TPenStyle;
FOnClickCell: TImageEvent;
FOnDrawCell: TDrawCellEvent;
FOnMeasureThumb: TMeasureThumbEvent;
FOnProgress: TImageEvent;
FOnUnresolved: TImageEvent;
FProportional: Boolean;
FRetainUnresolvedItems: Boolean;
FStretch: Boolean;
FThumbsGenerator: TThread;
FVirtualMode: Boolean;
procedure DeleteUnresolvedItems;
procedure FileFormatsChanged(Sender: TObject);
function GetCellHeight: Integer;
function GetCellWidth: Integer;
function GetCount: Integer;
function GetFileNames: TStrings;
function GetImage(Index: Integer): TGraphic;
function GetRowCount: Integer;
function GetSorted: Boolean;
function GetThumb(Index: Integer): TBitmap;
function IsFileNamesStored: Boolean;
procedure ItemsChanged(Sender: TObject);
procedure ItemsChanging(Sender: TObject);
procedure Rearrange;
procedure SetCellAlignment(Value: TAlignment);
procedure SetCellHeight(Value: Integer);
procedure SetCellLayout(Value: TTextLayout);
procedure SetCellSpacing(Value: Integer);
procedure SetCellWidth(Value: Integer);
procedure SetColWidth(Value: Integer);
procedure SetDefaultDrawing(Value: Boolean);
procedure SetDesignPreview(Value: Boolean);
procedure SetFileFormats(Value: TStrings);
procedure SetFileNames(Value: TStrings);
procedure SetFolder(Value: TPath);
procedure SetImage(Index: Integer; Value: TGraphic);
procedure SetItemIndex(Value: Integer);
procedure SetItems(Value: TImageGridItems);
procedure SetMarkerColor(Value: TColor);
procedure SetMarkerStyle(Value: TPenStyle);
procedure SetProportional(Value: Boolean);
procedure SetRetainUnresolvedItems(Value: Boolean);
procedure SetSorted(Value: Boolean);
procedure SetStretch(Value: Boolean);
procedure SetThumb(Index: Integer; Value: TBitmap);
procedure SetVirtualMode(Value: Boolean);
procedure TerminateThumbsGenerator;
procedure ThumbsUpdated(Sender: TObject);
procedure UpdateThumbs;
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;
procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
procedure CMExit(var Message: TCMExit); message CM_EXIT;
protected
procedure ChangeScale(M, D: Integer); override;
procedure DoClickCell(Index: Integer); virtual;
procedure DoDrawCell(Index, ACol, ARow: Integer; R: TRect); virtual;
procedure DoMeasureThumb(Index: Integer; var AThumbWidth,
AThumbHeight: Integer); virtual;
procedure DoProgress(Index: Integer); virtual;
procedure DrawFocusRect; override;
procedure InvalidateItem(Index: Integer); virtual;
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
procedure Loaded; override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer); override;
procedure Paint; override;
procedure Resize; override;
procedure SetRowHeight(Value: Integer); override;
property CellAlignment: TAlignment read FCellAlignment
write SetCellAlignment default taCenter;
property CellHeight: Integer read GetCellHeight write SetCellHeight
default DefCellHeight;
property CellLayout: TTextLayout read FCellLayout write SetCellLayout
default tlCenter;
property CellSpacing: Integer read FCellSpacing write SetCellSpacing
default DefCellSpacing;
property CellWidth: Integer read GetCellWidth write SetCellWidth
default DefCellWidth;
property ColCount: Integer read FColCount;
property ColWidth: Integer read FColWidth write SetColWidth
default DefColWidth;
property Count: Integer read GetCount;
property DefaultDrawing: Boolean read FDefaultDrawing
write SetDefaultDrawing default True;
property DesignPreview: Boolean read FDesignPreview write SetDesignPreview
default False;
property FileFormats: TStrings read FFileFormats write SetFileFormats;
property FileNames: TStrings read GetFileNames write SetFileNames
stored IsFileNamesStored;
property Folder: TPath read FFolder write SetFolder;
property Images[Index: Integer]: TGraphic read GetImage write SetImage;
property ItemIndex: Integer read FItemIndex write SetItemIndex default -1;
property Items: TImageGridItems read FItems write SetItems;
property MarkerColor: TColor read FMarkerColor write SetMarkerColor
default clGray;
property MarkerStyle: TPenStyle read FMarkerStyle write SetMarkerStyle
default psDash;
property OnClickCell: TImageEvent read FOnClickCell write FOnClickCell;
property OnDrawCell: TDrawCellEvent read FOnDrawCell write FOnDrawCell;
property OnMeasureThumb: TMeasureThumbEvent read FOnMeasureThumb
write FOnMeasureThumb;
property OnProgress: TImageEvent read FOnProgress write FOnProgress;
property OnUnresolved: TImageEvent read FOnUnresolved write FOnUnresolved;
property Proportional: Boolean read FProportional write SetProportional
default True;
property RetainUnresolvedItems: Boolean read FRetainUnresolvedItems
write SetRetainUnresolvedItems default False;
property RowCount: Integer read GetRowCount;
property Sorted: Boolean read GetSorted write SetSorted default False;
property Stretch: Boolean read FStretch write SetStretch default False;
property Thumbs[Index: Integer]: TBitmap read GetThumb write SetThumb;
property VirtualMode: Boolean read FVirtualMode write SetVirtualMode
default False;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function CellRect(Index: Integer): TRect;
function CoordFromIndex(Index: Integer): TGridCoord;
procedure Clear; virtual;
function MouseToIndex(X, Y: Integer): Integer;
procedure ScrollInView(Index: Integer);
procedure SetCellSize(ACellWidth, ACellHeight: Integer);
procedure SetCoordSize(AColWidth, ARowHeight: Integer);
property ParentBackground default False;
public
property TabStop default True;
end;
TAwImageGrid = class(TCustomImageGrid)
public
property ColCount;
property Count;
property Images;
property Items;
property RowCount;
property Thumbs;
published
property Align;
property Anchors;
property AutoHideScrollBar;
property BorderStyle;
property BorderWidth;
property CellAlignment;
property CellHeight;
property CellLayout;
property CellSpacing;
property CellWidth;
property ClientHeight;
property ClientWidth;
property Color;
property ColWidth;
property Constraints;
property Ctl3D;
property DefaultDrawing;
property DesignPreview;
property DragCursor;
property DragKind;
property DragMode;
property DragScroll;
property Enabled;
property FileFormats;
property FileNames;
property Folder;
property ItemIndex;
property MarkerColor;
property MarkerStyle;
property OnCanResize;
property OnClick;
property OnClickCell;
property OnConstrainedResize;
property OnContextPopup;
property OnDblClick;
property OnDockDrop;
property OnDockOver;
property OnDragDrop;
property OnDragOver;
property OnDrawCell;
property OnEndDock;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnGetSiteInfo;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnMeasureThumb;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnMouseWheel;
property OnMouseWheelDown;
property OnMouseWheelUp;
property OnProgress;
property OnResize;
property OnStartDock;
property OnStartDrag;
property OnUnDock;
property OnUnresolved;
property ParentBackground;
property RetainUnresolvedItems;
property RowHeight;
property ParentColor;
property ParentCtl3D;
property ParentShowHint;
property PopupMenu;
property Proportional;
property ShowHint;
property Sorted;
property Stretch;
property TabOrder;
property TabStop;
property VirtualMode;
property Visible;
property WheelScrollLines;
end;
I'm using the multi-image view from the ImageEn library. It does everything you asked for, and it's very fast. I'm happy with it. You can still get an older, free version from Torry that works with Delphi 7 (I haven't tried it on XE2).
The methods aren't exactly intuitive, but once you get the hang of it (nice help file included), it works great.
The latest version has some more features, and it's not expensive if you do decide to license it.
You can see a video of ImageEn multi-image view in action in my application.
They even have a Flow View control that looks like the slide show on a Mac.

Resources