www.pudn.com > MapLegend.rar > MapLegend_Legend.pas
unit MapLegend_Legend;
interface
uses
Windows, Classes, Controls, StdCtrls, Graphics, SysUtils, ExtCtrls, ComCtrls,
Forms, Contnrs, Variants, MapObjects2_TLB, ActiveX, Messages, Dialogs, Types,
Menus, AxCtrls, MapLegend_MapTheme, MapLegend_LegendRenderer, MapLegend_PanelEx;
const
MAIN_PANEL_TOP = 2;
LABEL_LEGENDITEM_LEFT = 40;
PICTURE_RENDERER_TOP = 5;
PICTURE_RENDERER_LEFT = 35;
PICTURE_RENDERER_WIDTH = 13;
PICTURE_RENDERER_HEIGHT = 13;
LEGEND_ITEM_LEFT = 15;
CAPTION_LAYER_LEFT = 7;
CAPTION_LAYER_TOP = 0;
CHECKBOX_LAYER_TOP = 4;
CHECKBOX_LAYER_LEFT = 20;
CHECKBOX_LAYER_HEIGHT = 17;
CHECKBOX_LAYER_WIDTH = 13;
EXPANDED_COLLAPSED_TOP = 6;
EXPANDED_COLLAPSED_LEFT = 2;
EXPANDED_COLLAPSED_HEIGHT = 13;
EXPANDED_COLLAPSED_WIDTH = 13;
//Constant number for maximum layers.
//If you think your map have more than 500 layers. Set this
//Number to higher value than 500.
MAXIMUM_LAYERS = 500;
type
//This type stores Symbol information.
TLegendInfo = class(TObject)
private
FSymbol : IMoSymbol;
FLabelText : string;
FColor : longint;
public
property Symbol : IMoSymbol read FSymbol write FSymbol;
property LabelText : string read FLabelText write FLabelText;
property Color : longint read FColor write FColor;
constructor Create;
destructor Destroy; override;
end;
TCheckBoxEx = Class(TCustomCheckBox)
protected
//procedure SetChecked (AValue : Boolean);
procedure Toggle;
end;
//This type stores the contents of the renderer caption
TRendererCaption = Class(TObject)
private
FCaption : string;
FLayerIndex : integer;
FRendererIndex : integer;
public
property Caption : string read FCaption write FCaption;
property LayerIndex : integer read FLayerIndex write FLayerIndex;
property RendererIndex : integer read FRendererIndex write FRendererIndex;
constructor Create;
destructor Destroy; override;
end;
//=====================================================================
//TSavedLegend is a class design for storing status of
//Layers. When uses move layer by drag/drop we need to
//restore the status likes "check box state (checked,unchecked,grayed)"
//Collapsed status (expanded or collapsed). And the famous properties
//are MinimumScaleToShow and MaximumScaleToShow. User can set range of
//scale to show the layer and When the map was zoomed out of bound do
//not show the layer.
TSavedLegend = class (TObject)
private
{ Private declarations }
FState : TCheckBoxState;
FCollapsed : boolean;
FCaption : string;
FDontShowLayerOutBeyond : double; //minimum scale
FDontShowLayerInBeyond : double; //maximum scale
public
{ Public declarations }
property MinimumScaleToShow : double read FDontShowLayerOutBeyond write FDontShowLayerOutBeyond;
property MaximumScaleToShow : double read FDontShowLayerInBeyond write FDontShowLayerInBeyond;
property Collapsed : boolean read FCollapsed write FCollapsed;
property State : TCheckBoxState read FState write FState;
property Caption : string read FCaption write FCaption;
constructor Create;
destructor Destroy; override;
end;
//=====================================================================
//Event type for TMapLegend.
TLayerDblClickEvent = procedure(Sender : TObject; index : integer) of Object;
TRenderClickEvent = procedure (Sender : TObject; LayerIndex, BreakIndex : integer; val1, val2 : variant) of Object;
TAfterSetLayerVisibleEvent = procedure (Sender : TObject; index : integer; isVisible : boolean) of Object;
TBeforeSetLayerVisibleEvent = procedure (Sender : TObject; Index : integer; cancel : boolean) of Object;
//Declaration for Border style.
TFrameStyle = (stLowered = 0,stRaised = 2, stErase = -1);
//Declaration for moveable or sizeable Legend Control.
TLegendAllow = Set of (Docking, Moving, Resizing, DragDroping);
TMapLegend = class(TPanelEx)
private
{ Private declarations }
FMapSource : TMap;
FScrollBox : TScrollBox;
//Holds on FScrollBox and FScrollBox stores TCheckBox
//, TImage, TPanel for layer legends.
FLayerPanels : TObjectList;
FShowLegends : TThemes;
FLegendItems : TObjectList;
FSavedLegends : TObjectList;
FRendererCaptions : TObjectList;
FPopupMenu : TPopupMenu;
FEnabledMenu : boolean;
FActive : boolean; //active theme
FEnabled : boolean;
FLegendAllow : TLegendAllow;
FShowLegend : boolean;
FNumLayers : integer;
FCurrentX, FCurrentY : integer;
FIsLoading : boolean;
FBigGap : integer;
FSmallGap : integer;
//Use variable height for vary font height.
FLayer_Name_Height : integer;
FLegend_Item_Height : integer;
FCurIndex : integer;
FCurActiveLayer : integer;
FTextColor : longint;
FLayerFont : TFont;
FLegendFont : TFont;
FFontDialog : TFontDialog;
FSaveDialog : TSaveDialog;
FClickOnRenderer : boolean;
FOnLayerDblClick : TLayerDblClickEvent;
FOnRenderClick : TRenderClickEvent;
FOnMouseDown : TMouseEvent;
FOnMouseMove : TMouseMoveEvent;
FOnMouseUp : TMouseEvent;
FOnAfterSetLayerVisible : TAfterSetLayerVisibleEvent;
FOnBeforeSetLayerVisible : TBeforeSetLayerVisibleEvent;
FOnAfterReorder : TNotifyEvent;
function GetEntryName (index : integer) : string;
procedure SetLayerLabels(lyrIndex : integer; vNewValue : variant);
procedure SetLayerVisible(Index : integer; AValue : boolean);
function GetLayerVisible(Index : integer) : boolean;
function GetActive(index : integer) : boolean;
procedure SetActive(index : integer; AValue : boolean);
function GetLayerLabelText(lyr : IDispatch) : string;
procedure SetShowLegend(lyrIndex : integer; AValue : boolean);
function GetShowLegend(lyrIndex : integer) : boolean;
procedure SetPopupMenu(AValue : boolean);
function GetLegendAllow : TLegendAllow;
procedure SetLegendAllow (AValue : TLegendAllow);
//Set range of scale to show.
function GetMinimumScaleToShow (index : integer) : double;
procedure SetMinimumScaleToShow (index : integer; AValue : double);
function GetMaximumScaleToShow (index : integer) : double;
procedure SetMaximumScaleToShow (index : integer; AValue : double);
procedure ClearFrame(Index : integer);
procedure ClearAllFrames;
procedure SetFrame(pa : TPanel; Style : TFrameStyle);
function FindLayerIndex(ctrl : TObject) : integer;
procedure CreateAlignSubmenu(item : TMenuItem);
procedure AlignSubmenuItemsClick(Sender : TObject);
procedure CreatePopupMenu;
procedure PopupMenuItemsClick(Sender: TObject);
//procedure UpdateMenuItemsChecked;
procedure DoLayersDblClick(Sender : TObject);
procedure DoExpandedCollapsedClick(Sender : TObject);
procedure DoScrollPanelResize(Sender: TObject; var NewWidth, NewHeight: Integer; var Resize: Boolean);
procedure DoLayersDragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean);
procedure DoLayersDragDrop(Sender, Source: TObject; X, Y: integer);
procedure DoLayersEndDrag (Sender, Target: TObject; X, Y: Integer);
procedure DoLayersMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: integer);
procedure DoLayersMouseMove(Sender : TObject; Shift : TShiftState; X ,Y : integer);
procedure DoLayersMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: integer);
procedure DoCheckLegendsClick(Sender : TObject);
procedure DoLoadLegends(ShowCheck : boolean = true);
function DoRendererClick(Sender : TObject; Index : integer; X, Y : single) : boolean;
function CheckClickOnRenderer(Sender : TObject; Index : integer; X , Y : Single) : integer;
function FindIndexLayers(szFind : string; SavedLegends : TObjectList; var index : integer) : boolean;
procedure DragDropLayer(FromIndex, ToIndex : integer);
function FindItem(lyrName : String; lyrIndex : integer) : integer;
//procedure RestoreLayerVisible(index : integer; LegendPanels : TObjectList;
// SavedLegends : TObjectList; Caption : string);
procedure RemoveItemsInSavedLegends (SavedLegends : TObjectList);
procedure RemoveItemsInLegendItems(LegendItems : TObjectList);
procedure RemoveRendererCaptions (RenCaps : TObjectList);
procedure InitialNewLegend(var NewLeg : TLegendItemRenderer);
procedure LayerSymArrayMake(lyr : IDispatch; LegendItems : TObjectList);
function GetGraphicRenderer(rend : IDispatch; GetGroupRenderer : boolean = false) : IDispatch;
procedure SaveLegendsBeforeRearrange(LayerPanels : TObjectList; SavedLegs : TObjectList);
procedure SetSizeAndPositionLayerPanels(index : integer; LayerPanels : TObjectList);
procedure SetRenderControlSizes(index : integer; NumLegends : integer;
LayerPanels : TObjectList);
procedure CreateLayerRenderControls(index : integer; NumLegends : integer;
LayerPanels : TObjectList);
procedure CreateGroupRenderer(lyr : IMoMapLayer; groupRend : IDispatch; LegendItems : TObjectList);
procedure CreateBreakArray(myRend : IDispatch; LegendItems : TObjectList);
procedure CreateValueArray(myRend : IDispatch; LegendItems : TObjectList);
procedure CreateDotArray(lyr : IMoMapLayer; myRend : IDispatch; LegendItems : TObjectList);
procedure CreateChartArray (myRend : IDispatch; LegendItems : TObjectList);
function IsSymbolTransparant(aSym : IMoSymbol) : boolean;
function IsCOMType(TypeOfObject:TGUID;rObject:IDispatch):BOOL;
function CalcZoomFactor : double;
function CalcZoomInBound(index : integer): boolean;
procedure DoMapBeforeLayerDraw(ASender: TObject; index: Smallint;
hDC: Cardinal);
protected
procedure Loaded;override;
public
{ Public declarations }
function GetActiveLayer : integer;
procedure LoadLegend(ShowCheck : boolean = true);
property Active[index : integer] : boolean read GetActive write SetActive;
property EntryName [index : integer] : string read GetEntryName;
procedure ShowAllLegend;
procedure HideAllLegend;
Property ShowLegend[lyrIndex : integer] : boolean read GetShowLegend write SetShowLegend;
Property LayerLabels[lyrIndex : integer]:variant write SetLayerLabels;
Procedure SetMapSource (Map : TMap);
property LayerVisible[Index : integer] : boolean read GetLayerVisible write SetLayerVisible;
//=========================== Added ============================================================
property MinimumScaleToShow[Index : integer] : double read GetMinimumScaleToShow write SetMinimumScaleToShow;
property MaximumScaleToShow[Index : integer] : double read GetMaximumScaleToShow write SetMaximumScaleToShow;
//================================================================================================
function ExportToBmp(FileName : string; LayerIndex : integer = -1) : boolean;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property ShowPopupMenu : boolean read FEnabledMenu write SetPopupMenu;
property OnLayerDblClick : TLayerDblClickEvent read FOnLayerDblClick write FOnLayerDblClick;
property OnRenderClick : TRenderClickEvent read FOnRenderClick write FOnRenderClick;
property OnAfterSetLayerVisible : TAfterSetLayerVisibleEvent read FOnAfterSetLayerVisible write FOnAfterSetLayerVisible;
property OnBeforeSetLayerVisible : TBeforeSetLayerVisibleEvent read FOnBeforeSetLayerVisible write FOnBeforeSetLayerVisible;
property OnAfterReorder : TNotifyEvent read FOnAfterReorder write FOnAfterReorder;
property Enabled : boolean read FEnabled write FEnabled;
property LegendAllow : TLegendAllow read GetLegendAllow write SetLegendAllow;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('pjComponents',[TMapLegend]);
end;
constructor TMapLegend.Create(AOwner: TComponent);
var
i : integer;
begin
inherited Create(AOwner);
if (csDesigning in ComponentState) then
begin
FEnabled := true;
FEnabledMenu := true;
FLegendAllow := [Moving, Resizing, DragDroping];
end;
FShowLegends := TThemes.Create;
FFontDialog := TFontDialog.Create(self);
FSaveDialog := TSaveDialog.Create(self);
FBiggap := 5;
FSmallGap := 3;
FLegend_Item_Height := 13;
FLayer_Name_Height := 13;
FCurActiveLayer := -1;
//TScrollBox is very smart component in Delphi.
//You can put many components (panel, images, etc...) on it.
//No need more codes for scrolling up and down.
//No need to try hard code likes VB.
FScrollBox := TScrollBox.Create(self);
with FScrollBox do
begin
Parent := self;
Color := self.Color;
Align := alClient;
BevelInner := bvNone;
BevelOuter := bvNone;
BevelWidth := 1;
HorzScrollBar.Visible := false;
VertScrollBar.Visible := true;
OnCanResize := DoScrollPanelResize;
end;
FSavedLegends := TObjectList.Create;
FLegendItems := TObjectList.Create;
FRendererCaptions := TObjectList.Create;
FLayerPanels := TObjectList.Create;
for i:= 0 to MAXIMUM_LAYERS do
begin
CreateLayerRenderControls(i, 1, FLayerPanels);
Application.ProcessMessages;
end;
end;
destructor TMapLegend.Destroy;
begin
FLayerFont.Free;
FLegendFont.Free;
FSavedLegends.Free;
FLayerPanels.Free;
FPopupMenu.Free;
FSaveDialog.Free;
FFontDialog.Free;
FScrollBox.Free;
FShowLegends.Free;
FMapSource := NIL;
inherited Destroy;
end;
//Can not place the method "CreatePopupMenu" in constructor "Create".
//Because constructor "Create" will be called before reading the
//stream from the .DFM file. So my varible "FLegendAllow" will be
//empty ([]).Then in method "CreatePopupMenu" some lines likes
// item.Checked := (Dragdroping in FLegendAllow)
//(Dragdroping in FLegendAllow) will always be false.
//To solve this problem we derived method "Loaded" at protected section.
//And placeS method "CreatePopupMenu" here that method "Loaded" will be
//called after Delphi already read the stream from .DFM file.
procedure TMapLegend.Loaded;
begin
inherited Loaded;
FLayerFont := TFont.Create;
FLegendFont := TFont.Create;
FTextColor := self.Font.Color;
FLayerFont.Assign(self.Font);
FLayerFont.Style := [fsBold];
FLegendFont.Assign(self.Font);
FLegendFont.Style := [fsItalic, fsBold];
FLegendFont.Color := clBlue;
CreatePopupMenu;
if Not(FEnabledMenu) then
FScrollBox.PopupMenu := NIL
else
begin
FScrollBox.PopupMenu := FPopupMenu;
FScrollBox.Width := self.ClientWidth;
FScrollBox.Height := self.ClientHeight;
end;
if (Moving in FLegendAllow) then
Allow := Allow + [MoveX, MoveY]
else
Allow := Allow - [MoveX, MoveY];
if (Resizing in FLegendAllow) then
Allow := Allow + [ResizeX, ResizeY]
else
Allow := Allow - [ResizeX, ResizeY];
end;
procedure TMapLegend.CreateAlignSubmenu(item : TMenuItem);
var
subitem : TMenuItem;
begin
subitem := TMenuItem.Create(item);
item.Add(subitem);
subitem.Caption := 'alNone';
subitem.Tag := 0;
subitem.Checked := true;
subitem.RadioItem := true;
subitem.OnClick := AlignSubmenuItemsClick;
subitem := TMenuItem.Create(item);
item.Add(subitem);
subitem.Caption := 'alTop';
subitem.Tag := 1;
subitem.RadioItem := true;
subitem.OnClick := AlignSubmenuItemsClick;
subitem := TMenuItem.Create(item);
Item.Add(subitem);
subitem.Caption := 'alBottom';
subitem.Tag := 2;
subitem.RadioItem := true;
subitem.OnClick := AlignSubmenuItemsClick;
subitem := TMenuItem.Create(item);
Item.Add(subitem);
subitem.Caption := 'alLeft';
subitem.Tag := 3;
subitem.RadioItem := true;
subitem.OnClick := AlignSubmenuItemsClick;
subitem := TMenuItem.Create(item);
Item.Add(subitem);
subitem.Caption := 'alRight';
subitem.Tag := 4;
subitem.RadioItem := true;
subitem.OnClick := AlignSubmenuItemsClick;
subitem := TMenuItem.Create(item);
Item.Add(subitem);
subitem.Caption := 'alClient';
subitem.Tag := 5;
subitem.RadioItem := true;
subitem.OnClick := AlignSubmenuItemsClick;
end;
procedure TMapLegend.AlignSubmenuItemsClick(Sender : TObject);
var
subitem : TMenuItem;
begin
if Not(Sender is TMenuItem) then exit;
subitem := TMenuItem(Sender);
case subitem.Tag of
0 : begin
self.Align := alNone;
subitem.Checked := true;
end;
1 : begin
self.Align := alTop;
subitem.Checked := true;
end;
2 : begin
self.Align := alBottom;
subitem.Checked := true;
end;
3 : begin
self.Align := alLeft;
subitem.Checked := true;
end;
4 : begin
self.Align := alRight;
subitem.Checked := true;
end;
5 : begin
self.Align := alClient;
subitem.Checked := true;
end;
end;
end;
procedure TMapLegend.CreatePopupMenu;
var
item : TMenuItem;
subitem : TMenuItem;
begin
FPopupMenu := TPopupMenu.Create(FScrollBox);
FPopupMenu.AutoPopup := true;
item := TMenuItem.Create(FPopupMenu);
FPopupMenu.Items.Add(item);// add it to the Popupmenu
item.Caption := 'Refresh';
item.Name := 'mnuRefrehLegend';
item.Tag := 0;
item.OnClick := PopupMenuItemsClick;// assign it an event handler
item := TMenuItem.Create(FPopupMenu);
FPopupMenu.Items.Add(item);
item.Caption := '-';
item.Name := 'mnuLine0';
item := TMenuItem.Create(FPopupMenu);
FPopupMenu.Items.Add(item);// add it to the Popupmenu
item.Caption := 'Enable Legend';
item.Name := 'mnuEnableLegend';
item.Tag := 1;
item.Checked := FEnabled;
item.OnClick := PopupMenuItemsClick;// assign it an event handler
item := TMenuItem.Create(FPopupMenu);
FPopupMenu.Items.Add(item);
item.Caption := '-';
item.Name := 'mnuLine1';
item := TMenuItem.Create(FPopupMenu);
FPopupMenu.Items.Add(item);
item.Caption := 'Align';
item.Name := 'mnuLegendAlign';
item.Tag := 2;
item.OnClick := PopupMenuItemsClick;
CreateAlignSubMenu (item);
item := TMenuItem.Create(FPopupMenu);
FPopupMenu.Items.Add(item);
item.Caption := '-';
item.Name := 'mnuLine2';
item := TMenuItem.Create(FPopupMenu);
FPopupMenu.Items.Add(item);
item.Caption := 'Enable Dragdrop';
item.Name := 'mnuEnableDragdrop';
item.Tag := 3;
item.Checked := (DragDroping in FLegendAllow);
item.OnClick := PopupMenuItemsClick;
item := TMenuItem.Create(FPopupMenu);
FPopupMenu.Items.Add(item);
item.Caption := 'Enable Moving';
item.Name := 'mnuEnableMoving';
item.Tag := 4;
item.Checked := (Moving in FLegendAllow);
item.OnClick := PopupMenuItemsClick;
item := TMenuItem.Create(FPopupMenu);
FPopupMenu.Items.Add(item);
item.Caption := 'Enable Resizing';
item.Name := 'mnuEnableResizing';
item.Tag := 5;
item.Checked := (Resizing in FLegendAllow);
item.OnClick := PopupMenuItemsClick;
//item := TMenuItem.Create(FPopupMenu);
//FPopupMenu.Items.Add(item);
//item.Caption := 'Enable Doking';
//item.Name := 'mnuEnableDocking';
//item.Tag := 6;
//item.Checked := (Docking in FLegendAllow);
//item.OnClick := PopupMenuItemsClick;
item := TMenuItem.Create(FPopupMenu);
FPopupMenu.Items.Add(item);
item.Caption := '-';
item.Name := 'mnuLine3';
item := TMenuItem.Create(FPopupMenu);
FPopupMenu.Items.Add(item);
item.Caption := 'Layer name font...';
item.Name := 'mnuLayerNameFont';
item.Tag := 7;
item.OnClick := PopupMenuItemsClick;
item := TMenuItem.Create(FPopupMenu);
FPopupMenu.Items.Add(item);
item.Caption := 'Legend item font...';
item.Name := 'mnuLegendItemFont';
item.Tag := 8;
item.OnClick := PopupMenuItemsClick;
item := TMenuItem.Create(FPopupMenu);
FPopupMenu.Items.Add(item);
item.Caption := '-';
item.Name := 'mnuLine4';
item := TMenuItem.Create(FPopupMenu);
FPopupMenu.Items.Add(item);
item.Caption := 'Export Legend to bmp file...';
item.Name := 'mnuExportToBmp';
item.Tag := 9;
item.OnClick := PopupMenuItemsClick;
FIsLoading := true;
end;
procedure TMapLegend.PopupMenuItemsClick(Sender: TObject);
var
item : TMenuItem;
i : integer;
begin
if Not(Sender is TMenuItem) then exit;
item := TMenuItem(Sender);
with item do
begin
case Tag of
0 : DoLoadLegends; //refresh when needs a new draw after resizing the legend control.
1 : begin
FEnabled := Not(FEnabled);
Checked := FEnabled;
//Stop every activities of Legend if the legend is not enabled.
//We set enabled to the main TPanel.
for i := 0 to FNumLayers - 1 do
TPanel(FLayerPanels.Items[i]).Enabled := FEnabled;
end;
3 : begin
if (DragDroping in FLegendAllow) then
begin
FLegendAllow := FLegendAllow - [DragDroping];
checked := false
end
else
begin
FLegendAllow := FLegendAllow + [DragDroping];
checked := true;
end;
end;
4 : begin
if (Moving in FLegendAllow) then
begin
FLegendAllow := FLegendAllow - [Moving];
self.Allow := self.Allow - [MoveX, MoveY];
Checked := false;
end
else
begin
FLegendAllow := FLegendAllow + [Moving];
self.Allow := self.Allow + [MoveX, MoveY];
Checked := true;
end;
end;
5 : begin
if (Resizing in FLegendAllow) then
begin
FLegendAllow := FLegendAllow - [Resizing];
self.Allow := self.Allow - [ResizeX, ResizeY];
Checked := false;
end
else
begin
FLegendAllow := FLegendAllow + [Resizing];
self.Allow := self.Allow + [ResizeX, ResizeY];
Checked := true;
end;
end;
//6 : ShowMessage('Sorry, not yet implement this menu in this version...');
7 : begin
FFontDialog.Device := fdBoth;
FFontDialog.Font.Color := FLayerFont.color;
FFontDialog.Font.Name := FLayerFont.Name;
FFontDialog.Font.Style := FLayerFont.Style;
FFontDialog.Font.Size := FLayerFont.Size;
if (FFontDialog.Execute) then
begin
FLayerFont.Color := FFontDialog.Font.color;
FLayerFont.Name := FFontDialog.Font.Name;
FLayerFont.Style := FFontDialog.Font.Style;
FLayerFont.Size := FFontDialog.Font.Size;
end;
DoLoadLegends;
end;
8 : begin
FFontDialog.Device := fdBoth;
FFontDialog.Font.Color := FLegendFont.color;
FFontDialog.Font.Name := FLegendFont.Name;
FFontDialog.Font.Style := FLegendFont.Style;
FFontDialog.Font.Size := FLegendFont.Size;
if (FFontDialog.Execute) then
begin
FLegendFont.Color := FFontDialog.Font.color;
FLegendFont.Name := FFontDialog.Font.Name;
FLegendFont.Style := FFontDialog.Font.Style;
FLegendFont.Size := FFontDialog.Font.Size;
end;
DoLoadLegends;
end;
9 : begin
FSaveDialog.Options := [ofOverwritePrompt];
FSaveDialog.DefaultExt := 'bmp';
FSaveDialog.Filter := 'Bitmap files (*.bmp)|*.bmp|All files (*.*)|*.*';
FSaveDialog.Title := 'Save Legend to bitmap file';
if FSaveDialog.Execute then
ExportToBmp(FSaveDialog.FileName, FCurActiveLayer);
end;
end;
end;
end;
//This function came from "van henknoort".
function TMapLegend.IsCOMType(TypeOfObject:TGUID;rObject:IDispatch):BOOL;
var
answer:BOOL;
status:HRESULT;
p:Pointer;
begin
answer := false;
if (rObject<>Nil) then
begin
p := Nil;
status := rObject.QueryInterface(TypeOfObject, p);
if ( SUCCEEDED(status) and (p<>nil)) then
begin
answer := true;
(IUnknown(p))._Release;
end
else
answer := false;
end;
result:= answer;
end;
function TMapLegend.CalcZoomInBound(index : integer): boolean;
var
exleg : TSavedLegend;
MinScale, MaxScale : double;
ZoomFactor : double;
begin
exleg := TSavedLegend(FSavedLegends.Items[index]);
MinScale := exleg.MinimumScaleToShow;
MaxScale := exleg.MaximumScaleToShow;
ZoomFactor := CalcZoomFactor;
if (ZoomFactor <= MinScale) and (ZoomFactor >= MaxScale) then
result := true
else if (ZoomFactor >= MinScale) or (ZoomFactor <= MaxScale) then
result := false;
end;
function TMapLegend.CalcZoomFactor : double;
var
rc : IMoRectangle;
ratio1, ratio2 : double;
begin
// zoomfactor is the ratio of the current extent to the fullextent
rc := coRectangle.Create;
rc := FMapsource.extent;
ratio1 := rc.Height / FMapsource.FullExtent.Height;
ratio2 := rc.Width / FMapSource.FullExtent.Width;
if (ratio1 < ratio2) then
result := ratio1
else
result := ratio2;
end;
function TMapLegend.GetEntryName(index : integer) : string;
var
chk : TCheckBoxEx;
pa : TPanel;
begin
try
pa := TPanel(FLayerPanels.Items[index]);
chk := TCheckBoxEx(pa.Controls[1]);
result := chk.Caption;
except
result := '';
end;
end;
procedure TMapLegend.DoCheckLegendsClick(Sender : TObject);
var
isVisible : boolean;
index : integer;
lyr : IDispatch;
pa : TPanel;
state : TCheckBoxState;
fInBound : boolean;
chk : TCheckBoxEx;
fOldVisible : boolean;
exleg : TSavedLegend;
begin
// Check on/off chklegend, raise event for application developer
// to control the theme visibility.
chk := TCheckBoxEx(Sender);
pa := TPanel(chk.Parent);
index := FLayerPanels.IndexOf(pa);
//Need to update Saved Legend (FSavedLegends).
//When users drag/drop layer we can get old status
//at this variable (FSavedLegends).
exleg := TSavedLegend(FSavedLegends.Items[index]);
state := chk.state;
fInBound := CalcZoomInBound(index);
lyr := FMapSource.Layers.Item(index);
if Not(FIsLoading) then
begin
if (IsComType(DIID_IMoMapLayer, lyr)) then
begin
lyr := IMoMapLayer(lyr);
fOldVisible := IMoMapLayer(lyr).Visible;
end
else
begin
lyr := IMoImageLayer(lyr);
fOldVisible := IMoImageLayer(lyr).Visible;
end;
if (fInBound) and (state = cbChecked) then
isVisible := true
else
isVisible := false;
//Change state by use method Toggle to another state.
//Likes UnChecked -> Checked -> Grayed
if (chk.State = cbChecked) and Not(fInBound) then
begin
chk.Toggle;
exit;
end
else if (chk.State = cbGrayed) and (fInBound) then
begin
//chk.Perform(BM_SETCHECK, ord(cbGrayed), 0)
chk.Toggle;
exit;
end;
if (chk.State = cbChecked) then
begin
if (IsComType(DIID_IMoMapLayer, lyr)) then
begin
IMoMapLayer(lyr).Visible := true;
if (fOldVisible <> IMoMapLayer(lyr).Visible) then
FMapSource.Refresh;
end
else
begin
IMoImageLayer(lyr).Visible := true;
if (fOldVisible <> IMoImageLayer(lyr).Visible) then
FMapSource.Refresh;
end;
end
else if (chk.State = cbUnChecked) or (chk.State = cbGrayed) then
begin
if (IsComType(DIID_IMoMapLayer, lyr)) then
IMoMapLayer(lyr).Visible := false
else
IMoImageLayer(lyr).Visible := false;
FMapSource.Refresh;
end;
//Update FSavedLegends here !!
exleg.State := chk.State;
end;
if Assigned(FOnAfterSetLayerVisible) then
OnAfterSetLayerVisible(Sender, index, isVisible)
end;
procedure TMapLegend.DoMapBeforeLayerDraw(ASender: TObject; index: Smallint;
hDC: Cardinal);
var
state : TCheckBoxState;
fInBound : boolean;
pa : TPanel;
chk : TCheckBoxEx;
lyr : IMoMapLayer;
begin
lyr := IMoMapLayer(FMapSource.Layers.Item(index));
fInBound := CalcZoomInBound(index);
pa := TPanel(FLayerPanels.Items[index]);
chk := TCheckBoxEx(pa.Controls[1]);
state := chk.state;
if (State = cbChecked) and (fInBound) then
lyr.Visible := true
else if (state = cbGrayed) and (fInBound) then
begin
chk.state := cbChecked;
lyr.Visible := true;
end
else if (state = cbChecked) and Not(fInBound) then
begin
chk.state := cbGrayed;
lyr.Visible := false;
end
else
lyr.Visible := false;
end;
procedure TMapLegend.DragDropLayer(FromIndex, ToIndex : integer);
begin
if (FMapSource.Layers.Count > 1) then
begin
if (ToIndex <> FCurIndex) then
begin
FMapSource.Layers.MoveTo(FromIndex, ToIndex);
FLayerPanels.Move(FromIndex, ToIndex);
FSavedLegends.Move(FromIndex, ToIndex);//=====================
SetSizeAndPositionLayerPanels(0, FLayerPanels);
FMapSource.Refresh;
//maintain the active layer
if (FCurActiveLayer = -1) then
SetActive(ToIndex, false)
else
begin
if (FCurActiveLayer = FCurIndex) then
SetActive(ToIndex, true)
else if (FCurActiveLayer > FCurIndex) then
begin
if (ToIndex < FCurActiveLayer) then
SetActive(FCurActiveLayer,true)
else if (ToIndex >= FCurActiveLayer) then
SetActive(FCurActiveLayer - 1,true);
end
else
begin
if (ToIndex <= FCurActiveLayer) then
SetActive(FCurActiveLayer + 1, true)
else
SetActive(FCurActiveLayer, true)
end;
end;
end;
if Assigned(FOnAfterReorder) then
OnAfterReorder(self);
end;
end;
procedure TMapLegend.DoLayersDblClick(Sender : TObject);
var
index : integer;
begin
if Assigned(FOnLayerDblClick) then
begin
index := FindLayerIndex(Sender);
if (index <> -1) then
begin
OnLayerDblClick(Sender, index);
//TControl(Sender).EndDrag(true);
end;
end;
end;
procedure TMapLegend.DoExpandedCollapsedClick(Sender : TObject);
var
pa : TPanel;
exc : TPanel; //"exp" is a child control of "pa."
index : integer;
begin
pa := TPanel(TControl(Sender).Parent);
index := FLayerPanels.IndexOf(pa);
exc := TPanel(pa.Controls[2]);
if (exc.Caption) = '-' then
exc.Caption := '+'
else
exc.Caption := '-';
SetSizeAndPositionLayerPanels (index, FLayerPanels);
if (FCurActiveLayer = index) then SetFrame(pa, stRaised);//Redraw
end;
procedure TMapLegend.DoLayersMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: integer);
var
i, index : integer;
pa : TPanel;
pic : TImage;
pnt : TPoint;
begin
//activate the layer only if the click is not on the renderer
FCurActiveLayer := GetActiveLayer;
FClickOnRenderer := true;
index := FindLayerIndex(Sender);
if (Button = mbLeft) And (index <> -1) then
begin
if Not(DoRendererClick(Sender, index, X, Y)) then
begin
//Disable the old layer
FClickOnRenderer := false;
if FCurActiveLayer = -1 then
//clears all other active layers
ClearAllFrames
else
ClearFrame(FCurActiveLayer);
end
else
ClearAllFrames;
pa := TPanel(FLayerPanels.Items[index]);
pic := TImage(pa.Controls[0]);
if (FCurActiveLayer = index) then
begin
ClearFrame(index);
FCurActiveLayer := -1;
end
else
begin
SetFrame(pa , stRaised);
FCurActiveLayer := index;
end;
FCurIndex := index;
//Becarefull for calling BeginDrag it will fire OnMouseUp immediatly.
if (ssCtrl in Shift) then
if (FEnabled) And (Sender is TImage) And (DragDroping in FLegendAllow) then
TControl(Sender).BeginDrag(true);
end;
if Assigned(FOnMouseDown) then
OnMouseDown(Sender, Button, Shift, X, Y);
end;
procedure TMapLegend.DoLayersMouseMove(Sender : TObject; Shift : TShiftState; X ,Y : integer);
begin
if (FEnabled) then
begin
if Assigned(FOnMouseMove) then
OnMouseMove(Sender, Shift, X, Y)
end;
end;
procedure TMapLegend.DoLayersMouseUp(Sender : TObject; Button: TMouseButton; Shift: TShiftState; X, Y: integer);
begin
if (FEnabled) then
begin
if (Button = mbLeft) And (ssCtrl in Shift) then
if (Sender is TImage) And (DragDroping in FLegendAllow) then
TControl(Sender).EndDrag(true);
if Assigned(FOnMouseUp) then
OnMouseUp(Sender, Button, Shift, X, Y);
end;
end;
procedure TMapLegend.DoLayersDragDrop(Sender, Source: TObject; X, Y: integer);
var
index1, index2 : integer;
begin
index1 := FindLayerIndex(Sender);
index2 := FindLayerIndex(Source);
if Not((index1 = -1) or (index2 = -1)) then
begin
if (index1 = index2) then
begin
TControl(Source).Enddrag(true);
end;
end;
end;
procedure TMapLegend.DoLayersDragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean);
begin
Accept := (Source is TImage);
end;
procedure TMapLegend.DoLayersEndDrag (Sender, Target: TObject; X, Y: Integer);
var
index1, index2 : integer;
begin
if ((Sender is TImage) And (Target is TImage)) then
begin
index1 := FindLayerIndex(Sender);
index2 := FindLayerIndex(Target);
if Not((index1 = -1) or (index2 = -1)) then
if (index1 <> index2) then
begin
DragDropLayer(Index1, Index2);
FLegendAllow := FLegendAllow + [DragDroping];
end;
end;
end;
function TMapLegend.FindLayerIndex(ctrl : TObject) : integer;
var
pa : TPanel;
par : TWinControl;
begin
if (ctrl = NIL) then
begin
result := -1;
exit;
end;
par := TWinControl(ctrl).Parent;
if (par <> NIL) then
begin
if (par is TScrollBox) then
begin
pa := TPanel(ctrl);
result := FLayerPanels.IndexOf(pa);
end
else if (par is TPanel) then
begin
pa := TPanel(TPanel(ctrl).parent);
result := FLayerPanels.IndexOf(pa);
end
else
result := -1;
end
else
result := -1;
end;
procedure TMapLegend.DoScrollPanelResize(Sender: TObject; var NewWidth, NewHeight: Integer; var Resize: Boolean);
var
pa : TPanel;
pic : TImage;
chk : TCheckBoxEx;
exc : TPanel;
i : integer;
begin
for i := 0 to FNumLayers - 1 do
begin
pa := TPanel(FLayerPanels.Items[i]);
pic := TImage(pa.Controls[0]);
chk := TCheckBoxEx(pa.Controls[1]);
exc := TPanel(pa.Controls[2]);
pa.Width := NewWidth - (NewWidth - FScrollBox.ClientWidth)- 2;
pic := TImage(pa.Controls[0]);
pic.Width := pa.Width - chk.Width - exc.Width - 10;
//pic.Picture.Bitmap.Width := pic.Width - 5;
end;
end;
function TMapLegend.DoRendererClick(Sender : TObject; Index : integer; X, Y : single) : boolean;
var
RendererIndex : integer;
lyrIndex : integer;
val1, val2 : variant;
lyr : IMoMapLayer;
lyrRenderer : IDispatch;
begin
if Not(FEnabled) then exit;
DoRendererClick := false;
lyrIndex := Index;
//First we check if the click occured on top of a renderer
RendererIndex := CheckClickOnRenderer(Sender, Index, X, Y);
if (RendererIndex = -1) then
exit;
try
lyr := IMoMapLayer(FMapSource.Layers.Item(lyrIndex));
lyrRenderer := lyr.Renderer;
if Not(lyrRenderer = NIL) then
begin
if IsComType(DIID_IMoValueMapRenderer,lyrRenderer) then
begin
try
val1 := IMoValueMapRenderer(lyrRenderer).Value[RendererIndex];
except
RendererIndex := -1;
end;
end
else if IsComType(DIID_IMoClassBreaksRenderer, lyrRenderer) then
begin
//Get the lower limit for the break
if (RendererIndex = 0) then
val1 := -1.79769313486232E+307 // Return a very big negative double
else
val1 := IMoClassBreaksRenderer(lyrRenderer).Break[RendererIndex - 1];
//Get the upper limit for the break
if (RendererIndex = IMoClassBreaksRenderer(lyrRenderer).BreakCount) then
val2 := 1.79769313486232E+307 // Return a very big positive double
else
val2 := IMoClassBreaksRenderer(lyrRenderer).Break[RendererIndex];
end
else if IsComType(DIID_IMoDotDensityRenderer, lyrRenderer) then
val1 := IMoDotDensityRenderer(lyrRenderer).DotValue;
if (FEnabled) then
if (Assigned(FOnRenderClick) and (RendererIndex >= 0)) then
OnRenderClick(Self, lyrIndex, RendererIndex, val1, val2)
end;
DoRendererClick := true;
lyr := NIL;
lyrRenderer := NIL;
except
exit;
end;
end;
procedure TMapLegend.CreateLayerRenderControls(index : integer; NumLegends : integer;
LayerPanels : TObjectList);
var
CollapsedHi ,ExpandedHi : integer;
pic : TImage;
chk : TCheckBoxEx;
exc : TPanel; //Expanded/Collapsed.
main : TPanel;
begin
main := TPanel.Create(FScrollBox);
with main do
begin
Parent := NIL;
Left := 2;
if (index = 0) then
Top := MAIN_PANEL_TOP
else
Top := TPanel(LayerPanels[index-1]).Top + TPanel(LayerPanels[index-1]).Height + 1;
Width := FScrollBox.Width - 25 ;
CollapsedHi := CHECKBOX_LAYER_HEIGHT + 2;
Height:= fBigGap + CHECKBOX_LAYER_HEIGHT + (FLegend_Item_Height + fSmallGap)
* (NumLegends) + fBigGap;
ExpandedHi := Height;
BevelInner := bvNone;
BevelOuter := bvNone;
FullRepaint := false;
OnMouseDown := DoLayersMouseDown;
end;
chk := TCheckBoxEx.Create(main);
with chk do
begin
Parent := main;
Color := self.Color;
Left := CHECKBOX_LAYER_LEFT;
Top := CHECKBOX_LAYER_TOP;
Tag := CollapsedHi;
AllowGrayed := true;
State := cbChecked;
Width := CHECKBOX_LAYER_WIDTH;
Height := CHECKBOX_LAYER_HEIGHT;
OnClick := DoCheckLegendsClick;
end;
exc := TPanel.Create(main);
with exc do
begin
Parent := main;
Left := EXPANDED_COLLAPSED_LEFT;
Top := EXPANDED_COLLAPSED_TOP;
Height := EXPANDED_COLLAPSED_HEIGHT;
Width := EXPANDED_COLLAPSED_WIDTH;
Tag := ExpandedHi;
Caption := '-'; //first state show expanded legend.
BevelInner := bvLowered;
BevelOuter := bvNone;
BorderStyle := bsNone;
BevelWidth := 2;
Font.Style := [fsBold];
Font.Size := 10;
Color := cl3DLight;//clBtnFace;
OnClick := DoExpandedCollapsedClick;
end;
pic := TImage.Create(main);
with pic do
begin
Parent := main;
Left := PICTURE_RENDERER_LEFT;
Top := PICTURE_RENDERER_TOP;
Width := main.Width;
Height:= (FLegend_Item_Height + fSmallGap) * (NumLegends + 1);
Canvas.Brush.Style := bsSolid;
Canvas.Brush.Color := self.Color;
Canvas.FillRect(Rect(0, 0, pic.Width, pic.Height));
DragKind := dkDrag;
DragMode := dmManual;
//Hook event to control.
OnDragOver := DoLayersDragOver;
OnDragDrop := DoLayersDragDrop;
OnMouseDown := DoLayersMouseDown;
OnMouseUp := DoLayersMouseUp;
OnDblClick := DoLayersDblClick;
OnEndDrag := DoLayersEndDrag;
end;
LayerPanels.Add(main);
end;
procedure TMapLegend.SetRenderControlSizes(index : integer; NumLegends : integer;
LayerPanels : TObjectList);
var
CollapsedHi ,ExpandedHi : integer;
pic : TImage;
chk : TCheckBoxEx;
exc : TPanel; //Expanded/Collapsed.
main : TPanel;
begin
FScrollBox.VertScrollBar.Visible := false;
main := TPanel(LayerPanels.Items[index]);
chk := TCheckBoxEx(main.Controls[1]);
exc := TPanel(main.Controls[2]);
pic := TImage(main.Controls[0]);
//Keeps the layer name in pic.Hint.
//No need to create more variable.
pic.Hint := Caption;
with main do
begin
Parent := FScrollBox;
Color := self.Color;
if (index = 0) then
Top := MAIN_PANEL_TOP
else
Top := TPanel(LayerPanels[index-1]).Top + TPanel(LayerPanels[index-1]).Height + 1;
pic.Canvas.Font.Assign(FLayerFont);
FLayer_Name_Height := pic.Canvas.TextHeight('Wqqqq');
pic.Canvas.Font.Assign(FLegendFont);
FLegend_Item_Height := pic.Canvas.TextHeight('Wqqqq');
Width := FScrollBox.ClientWidth - 5;
CollapsedHi := fBigGap + FLayer_Name_Height + fBigGap + 3;
Height:= fBigGap + FLayer_Name_Height + fSmallGap + (FLegend_Item_Height + fSmallGap)
* (NumLegends ) + 2 * fBigGap;
ExpandedHi := Height;
end;
chk.Tag := CollapsedHi;
exc.Tag := ExpandedHi;
with pic do
begin
pic.Height:= main.Height - 3 * fBigGap;
pic.Width := main.Width - chk.Width - exc.Width - 25;
Picture.Bitmap.Width := pic.Width;
Picture.Bitmap.Height := main.Height;
Canvas.Brush.Style := bsSolid;
Canvas.Brush.Color := self.Color;
Canvas.FillRect(Rect(0, 0, pic.Width, pic.Height));
end;
if (exc.Caption = '-') then
main.Height := exc.Tag //Expanded Height was kept in exc.Tag. See "CreateLayerRenderControls" method.
else
main.Height := chk.Tag; //Collapsed Height
FScrollBox.VertScrollBar.Visible := true;
end;
procedure TMapLegend.SetSizeAndPositionLayerPanels(index : integer;
LayerPanels : TObjectList);
var
main : TPanel;
i : integer;
chk : TCheckBoxEx;
exc : TPanel;
pic : TImage;
begin
if (LayerPanels = NIL) then exit;
//When we update the positions of child controls inside TScrollBox.
//We have to set visible of Vertical Scrollbar to off.
//Otherwise we can get the wrong position of the child controls.
FScrollBox.VertScrollBar.Visible := false;
main := TPanel(LayerPanels.Items[index]);
pic := TImage(main.Controls[0]);
chk := TCheckBoxEx(main.Controls[1]);
exc := TPanel(main.Controls[2]);
if (exc.Caption = '-') then
main.Height := exc.Tag //Expanded Height was kept in exc.Tag. See "CreateLayerRenderControls" method.
else
main.Height := chk.Tag; //Collapsed Height
pic.Height := main.Height - fBigGap * 3;
if (index = 0) then
begin
main.Top := MAIN_PANEL_TOP;
end;
for i := 1 to FNumLayers - 1 do
begin
main := TPanel(LayerPanels.Items[i]);
main.Top := TPanel(LayerPanels.Items[i- 1]).Top + TPanel(LayerPanels.Items[i - 1]).Height;
end;
//Update the positions then turn it on. TPanel, TCheckBox, TImage get the
//right positions.
FScrollBox.VertScrollBar.Visible := true;
end;
procedure TMapLegend.LoadLegend(ShowCheck : boolean = true);
begin
DoLoadLegends(ShowCheck);
end;
procedure TMapLegend.SaveLegendsBeforeRearrange(LayerPanels : TObjectList; SavedLegs : TObjectList);
var
i : integer;
chk : TCheckBoxEx;
pa, exc : TPanel;
exsleg : TSavedLegend;
lyr : IDispatch;//IMoMapLayer;
begin
if (FNumLayers > 0) then
begin
for i := 0 to FNumLayers -1 do
begin
lyr := IDispatch(FMapSource.Layers.Item(i));
pa := TPanel(LayerPanels.Items[i]);
chk := TCheckBoxEx(pa.Controls[1]);
exc := TPanel(pa.Controls[2]);
exsleg := TSavedLegend.Create;
if IsComType(IMoImageLayer, lyr) then
exsleg.Caption := IMoImageLayer(lyr).Name //Image Layer
else if IsComType(IMoMapLayer, lyr) then
exsleg.Caption := IMoMapLayer(lyr).Name;
exsleg.MinimumScaleToShow := 1.0; //default;
exsleg.MaximumScaleToShow := 0.0; //default;
SavedLegs.Add(exsleg);
end;
end;
end;
procedure TMapLegend.InitialNewLegend(var NewLeg : TLegendItemRenderer);
begin
NewLeg := TLegendItemRenderer.Create;
with NewLeg do
begin
RendererHeight := FLegend_Item_Height;
RendererWidth := FLegend_Item_Height;//Same width & height
BackGroundColor := FScrollBox.Color;
MapBackColor := FMapSource.BackColor;
end;
end;
procedure TMapLegend.RemoveItemsInSavedLegends (SavedLegends : TObjectList);
var
k : integer;
begin
if Not(SavedLegends = NIL) then
begin
for k := SavedLegends.Count - 1 downto 0 do
SavedLegends.Remove(TSavedLegend(SavedLegends.Items[k]));
end;
end;
procedure TMapLegend.RemoveItemsInLegendItems(LegendItems : TObjectList);
var
k : integer;
begin
if Not(LegendItems = NIL) then
for k := LegendItems.Count - 1 downto 0 do
LegendItems.Remove(TLegendInfo(LegendItems.Items[k]));
end;
{procedure TMapLegend.RestoreLayerVisible(index : integer; LegendPanels : TObjectList;
SavedLegends : TObjectList; caption : string);
var
k : integer;
lyr : IDispatch;
chk : TCheckBoxEx;
pa : TPanel;
lblLegendText : string;
ZoomFactor : double;
state : TCheckboxState;
begin
lyr := FMapSource.Layers.Item(index);
pa := TPanel(FLayerPanels.Items[index]);
chk := TCheckBoxEx(pa.Controls[1]);
if Not(SavedLegends = NIL) then
begin
if (SavedLegends.Count > 0) then
if (FindIndexLayers(Caption, SavedLegends, k)) then
chk.State := TSavedLegend(SavedLegends[k]).State;
end;
end;}
procedure TMapLegend.DoLoadLegends(ShowCheck : Boolean = true);
var
sym : IMoSymbol;
i, j : integer;
lyr : IDispatch;
itemCount : integer;
lyrCount : integer;
NewLegend : TLegendItemRenderer;
lblLegendText : string;
lblRendererText : string;
IsLegendVisible : boolean;
pic : TImage;
chk : TCheckBoxEx;
txthi : integer;
pa : TPanel;
legitem : TLegendInfo;
rencap : TRendererCaption;
//bm : TBitmap;
begin
if (FMapSource = NIL) then exit;
FNumLayers := FMapSource.Layers.Count;
FScrollBox.VertScrollBar.Visible := false;
RemoveItemsInSavedLegends (FSavedLegends);
SaveLegendsBeforeRearrange(FLayerPanels, FSavedLegends);
RemoveRendererCaptions(FRendererCaptions);
//Application.ProcessMessages;
//exit if there isn't any layer
lyrCount := FMapSource.Layers.Count - 1;
if (lyrCount = -1) then exit;
for i := 0 to lyrCount do
begin
lyr := FMapSource.Layers.Item(i);
InitialNewLegend (NewLegend);
RemoveItemsInLegendItems (FLegendItems);
if (IsComType(DIID_IMoMapLayer, lyr)) then
LayerSymArrayMake(IMoMapLayer(lyr), FLegendItems);
SetRenderControlSizes(i, FLegendItems.Count, FLayerPanels);
//Define the legend for the layer
lblLegendText := GetLayerLabelText(lyr);
//Position of the picture and the check box
pa := TPanel(FLayerPanels.Items[i]);
chk := TCheckBoxEx(pa.Controls[1]);
pic := TImage(pa.Controls[0]);
itemCount := FLegendItems.Count - 1;//Within one layer.
FCurrentX := LABEL_LEGENDITEM_LEFT;
pic.Canvas.Font.Assign(FLayerFont);
pic.Canvas.TextOut(CAPTION_LAYER_LEFT, CAPTION_LAYER_TOP, lblLegendText);
//RestoreLayerVisible(i ,FLayerPanels, FSavedLegends, IMoMapLayer(lyr).Name);
IsLegendVisible := ShowLegend[i];
if (IsComType(DIID_IMoImageLayer, lyr) Or (Not(IsLegendVisible))) then
//no renderer for imagelayer
pic.Height := FLayer_Name_Height
else
itemCount := FLegendItems.Count - 1; //within one layer
//Draw legend item for Renderers.
if (itemCount >= 0) then
begin
FCurrentY := 0;
for j := 0 to itemCount do
begin
lblRendererText := TLegendInfo(FLegendItems.Items[j]).LabelText;
pic.Canvas.Font.Assign(FLegendFont);
FCurrentY := FBigGap + FLayer_Name_Height + FSmallGap + (FLegend_Item_Height + fSmallGap) * (j);
pic.Canvas.TextOut(LABEL_LEGENDITEM_LEFT, FCurrentY , lblRendererText);
with NewLegend do
begin
sym := TLegendInfo(FLegendItems[j]).Symbol;
AddEntry(false, sym, 0, 0);
pic.Canvas.Draw(LEGEND_ITEM_LEFT, FCurrentY , Newlegend);
end;
//Save the renderer caption
if (Length(lblRendererText) > 0) then
begin
rencap := TRendererCaption.Create;
with rencap do
begin
Caption := lblRendererText;
LayerIndex := i;
RendererIndex := j;
end;
FRendererCaptions.Add(rencap);
end;
end; //for j
end;//if (itemCount >= 0) then
NewLegend.Free;
end; //for i
FScrollBox.VertScrollBar.Visible := true;
//clean up before leaving.
sym := NIL;
lyr := NIL;
FEnabled := true;
FIsLoading := false;
end;
function TMapLegend.FindIndexLayers(szFind : string; SavedLegends : TObjectList; var index : integer) : boolean;
var
i : integer;
szCaption : string;
begin
result := false;
index := -1;
if (SavedLegends = NIL) then exit;
for i := 0 to SavedLegends.Count - 1 do
begin
szCaption :=TSavedLegend(SavedLegends.Items[i]).Caption;
if (UpperCase(szFind) = UpperCase(szCaption)) then
begin
result := true;
index := i;
break;
end;
end;
end;
procedure TMapLegend.CreateGroupRenderer(lyr : IMoMapLayer; groupRend : IDispatch; LegendItems : TObjectList);
var
rend : IDispatch;
i : integer;
begin
for i := 0 to IMoGroupRenderer(groupRend).Count - 1 do
begin
rend := IMoGroupRenderer(groupRend).Renderer[i];
if Not((IsComType(DIID_IMoLabelRenderer, rend)) or (IsComType(DIID_IMoLabelPlacer, rend))) then
begin
If (IsComType(DIID_IMoClassBreaksRenderer, rend)) then
CreateBreakArray(rend, LegendItems)
else if (IsComType(DIID_IMoValueMapRenderer, rend)) then
CreateValueArray(rend, LegendItems)
else if (IsComType(DIID_IMoDotDensityRenderer, rend)) then
CreateDotArray(lyr, rend, LegendItems)
else if (IsComType(DIID_IMoChartRenderer, rend)) then
CreateChartArray(rend, LegendItems);
end;
end;
end;
procedure TMapLegend.LayerSymArrayMake(lyr : IDispatch; LegendItems : TObjectList);
var
myRend : IDispatch;
r : TLegendInfo;
begin
if (IsComType(DIID_IMoMapLayer, lyr)) then
myRend := GetGraphicRenderer(IMoMapLayer(lyr).Renderer, true)
else
myRend := NIL;
if (myRend = NIL) then
begin
r := TLegendInfo.Create;
if (IsComType(DIID_IMoMapLayer, lyr)) then
r.Symbol := IMoMapLayer(lyr).Symbol;
r.LabelText := '';
LegendItems.Add(r);
exit;
end;
if (IsComType(DIID_IMoClassBreaksRenderer, myrend)) then
CreateBreakArray(myRend, LegendItems)
else if (IsComType(DIID_IMoValueMapRenderer, myrend)) then
CreateValueArray(myRend, LegendItems)
else if (IsComType(DIID_IMoDotDensityRenderer, myrend)) then
CreateDotArray(IMoMapLayer(lyr), myRend, LegendItems)
else if (IsComType(DIID_IMoChartRenderer, myrend)) then
CreateChartArray(myrend, LegendItems)
else if (IsComType(DIID_IMoGroupRenderer, myrend)) then
CreateGroupRenderer(IMoMapLayer(lyr), myRend, LegendItems)
else
begin
r := TLegendInfo.Create;
r.Symbol := IMoMapLayer(lyr).Symbol;
r.LabelText := IMoMapLayer(lyr).Name;
LegendItems.Add(r);
end;
end;
procedure TMapLegend.RemoveRendererCaptions (RenCaps : TObjectList);
var
i : integer;
rencap : TRendererCaption;
begin
for i:= RenCaps.Count - 1 downto 0 do
begin
rencap := TRendererCaption(RenCaps.Items[i]);
FRendererCaptions.Remove(rencap);
end;
end;
//PJ Check this methods later. FRendererCaption may be destroyed before calling.
procedure TMapLegend.SetLayerLabels(lyrIndex : integer;vNewValue : variant);
var
i , j , lowBnd : integer;
legendLabels : TStrings;
nCount : integer;
begin
i := 0;
j := 0;
nCount := FRendererCaptions.Count;
lowBnd := VarArrayLowBound(vNewValue, 1);
while (i <= nCount) do
begin
if (TRendererCaption(FRendererCaptions[i]).LayerIndex = lyrIndex) then
begin
TRendererCaption(FRendererCaptions[i]).Caption := vNewValue[lowBnd + j];
inc(j);
end;
inc(i);
end;
end;
procedure TMapLegend.SetFrame(pa : TPanel; Style : TFrameStyle);
var
pic : TImage;
begin
// 2 Lines Added by PJ
pic := TImage(pa.Controls[0]);
pic.Tag := 1;
if (Style = stRaised) then pa.BevelOuter := bvRaised;
if (Style = stErase) then pa.BevelOuter := bvNone;
end;
function TMapLegend.GetActive(Index : integer) : boolean;
var
pa : TPanel;
pic : TImage;
begin
//make sure it's a valid layer
pa := TPanel(FLayerPanels.Items[index]);
pic := TImage(pa.Controls[0]);
if (Index >= FMapSource.Layers.Count) then
exit;
if(pic.Tag = 1) then
result := true
else
result := false;
end;
procedure TMapLegend.SetActive(Index : integer; AValue : boolean);
var
i : integer;
pa : TPanel;
//chk : TCheckBoxEx;
pic : TImage;
begin
//make sure it's a valid layer
if (Index >= FMapSource.Layers.Count) then
exit;
if (Index > -1) then
begin
pa := TPanel(FLayerPanels.Items[index]);
//chk := TCheckBoxEx(pa.Controls[0]);
pic := TImage(pa.Controls[0]);
FActive := AValue;
if AValue then
begin
//clears all other active layers
i := GetActiveLayer;
if (i > -1) then ClearFrame(i);
//activate the layer
SetFrame(pa , stRaised);
pic.Tag := 1;
end
else
ClearFrame(Index);
end;
end;
function TMapLegend.GetActiveLayer : integer;
var
i : integer;
pa : TPanel;
pic : TImage;
begin
try
//returns active layer index
//if no layer is active, then return -1
GetActiveLayer := -1;
i := 0;
if Not (FMapSource = NIL) then
while (i < FNumLayers) do
begin
pa := TPanel(FLayerPanels.Items[i]);
pic := TImage(pa.Controls[0]);
if (pic.Tag = 1) then
begin
GetActiveLayer := i;
break;
end;
i := i + 1;
end;
except
exit;
end;
end;
function TMapLegend.GetLegendAllow : TLegendAllow;
begin
result := FLegendAllow;
end;
procedure TMapLegend.SetLegendAllow (AValue : TLegendAllow);
begin
if (FLegendAllow <> AValue) then
FLegendAllow := AValue;
{if (Moving in FLegendAllow) then
Allow := Allow + [MoveX, MoveY]
else
Allow := Allow - [MoveX, MoveY];
if (Resizing in FLegendAllow) then
Allow := Allow + [ResizeX, ResizeY]
else
Allow := Allow - [ResizeX, ResizeY];
UpdateMenuItemsChecked;}
end;
procedure TMapLegend.SetMapSource(Map : TMap);
begin
FMapSource := Map;
FMapsource.OnBeforeLayerDraw := DoMapBeforeLayerDraw;
end;
function TMapLegend.GetLayerVisible(Index : integer) : boolean;
var
pa : TPanel;
begin
pa := TPanel(FLayerPanels.Items[index]);
result := TCheckBoxEx(pa.Controls[1]).Checked
end;
procedure TMapLegend.SetLayerVisible(Index : integer; AValue : boolean);
var
pa : TPanel;
begin
pa := TPanel(FLayerPanels.Items[index]);
TCheckBoxEx(pa.Controls[1]).Checked := AValue;
end;
function TMapLegend.GetShowLegend(lyrIndex : integer) : boolean;
var
findIndex : integer;
lyr : IDispatch;
begin
//make sure it's a valid layer
if (lyrIndex >= FMapSource.Layers.Count) then
exit;
findIndex := -1;
lyr := FMapSource.Layers.item(lyrIndex);
if (IsComType(DIID_IMoMapLayer, lyr)) then
findIndex := FindItem(IMoMapLayer(lyr).Name, lyrIndex);
if findIndex = -1 then
result := true
else
result := FShowLegends.Items[findIndex].LegendVisible;
end;
procedure TMapLegend.SetShowLegend(lyrIndex : integer; AValue : boolean);
var
findIndex : integer;
lyrName : string;
theTheme : TTheme;
lyr : IDispatch;
begin
//make sure it's a valid layer
if (lyrIndex >= FMapSource.Layers.Count) then
exit;
lyr := FMapSource.Layers.item(lyrIndex);
if (IsComType(DIID_IMoMapLayer, lyr)) then
lyrName := IMoMapLayer(lyr).Name
else
lyrName := IMoImageLayer(lyr).Name;
findIndex := findItem(lyrName, lyrIndex);
if (findIndex <> -1) and (FShowLegends <> NIL) then
FShowLegends.Remove(FShowLegends.Items[findIndex]);
theTheme := TTheme.Create;
with theTheme do
begin
Index := lyrIndex;
Name := lyrName;
LegendVisible := AValue;
end;
FShowLegends.Add(theTheme);
DoLoadLegends;
end;
procedure TMapLegend.SetPopupMenu(AValue : boolean);
begin
FEnabledMenu := AValue;
end;
//============================= Added area ===============================
function TMapLegend.GetMinimumScaleToShow (index : integer) : double;
var
exleg : TSavedLegend;
begin
exleg := TSavedLegend(FSavedLegends.Items[index]);
result := exleg.MinimumScaleToShow;
end;
procedure TMapLegend.SetMinimumScaleToShow (index : integer; AValue : double);
var
exleg : TSavedLegend;
begin
exleg := TSavedLegend(FSavedLegends.Items[index]);
exleg.MinimumScaleToShow := AValue;
end;
function TMapLegend.GetMaximumScaleToShow (index : integer) : double;
var
exleg : TSavedLegend;
begin
exleg := TSavedLegend(FSavedLegends.Items[index]);
result := exleg.MaximumScaleToShow;
end;
procedure TMapLegend.SetMaximumScaleToShow (index : integer; AValue : double);
var
exleg : TSavedLegend;
begin
exleg := TSavedLegend(FSavedLegends.Items[index]);
exleg.MaximumScaleToShow := AValue;
end;
//==========================================================================
function TMapLegend.FindItem(lyrName : string; lyrIndex : integer) : integer;
var
i : integer;
begin
findItem := -1;
if (FShowLegends.Count = 0) then
exit
else
for i := 0 to FShowLegends.Count-1 do
begin
if (UpperCase(FShowLegends.Items[i].Name) = UpperCase(lyrName)) and
(FShowLegends.Items[i].Index = lyrIndex) then
begin
result := i;
break;
end;
end;
end;
procedure TMapLegend.ShowAllLegend;
var
i : integer;
begin
for i := 0 to FMapSource.Layers.Count - 1 do
ShowLegend[i] := true;
end;
procedure TMapLegend.HideAllLegend;
var
i : integer;
begin
for i := 0 to FMapSource.Layers.Count - 1 do
ShowLegend[i] := false;
end;
function TMapLegend.IsSymbolTransparant(aSym : IMoSymbol) : boolean;
begin
result := false;
Case aSym.symboltype of
moFillSymbol:
result := (aSym.Style = moTransparentFill) and (not(aSym.Outline));
moPointSymbol, moLineSymbol:
result := (aSym.Size = 0);
end;
end;
function TMapLegend.CheckClickOnRenderer(Sender : TObject; Index : integer; X , Y : Single) : integer;
var
CurrentPos : Single;
RendererIndex : integer;
pa : TPanel;
pic : TImage;
begin
result := -1;
//Renderer is on TImage only.
if Not(Sender is TImage) then exit;
pa := TPanel(FLayerPanels.Items[index]);
pic := TImage(pa.Controls[0]);
if (X < LEGEND_ITEM_LEFT) or (X > (LEGEND_ITEM_LEFT + PICTURE_RENDERER_WIDTH )) then exit;
//At this poijnt the x is in range
CurrentPos := FBigGap + FLayer_Name_Height + FSmallGap ;
RendererIndex := 0;
//Now test for Y position. Is it on which renderer?
while (CurrentPos < pic.Height) do
begin
if (Y >= CurrentPos) and (Y <= CurrentPos + FLegend_Item_Height) then
begin
//When fall in Y range of renderer. Then return index of renderer.
result := RendererIndex;
break;
end;
CurrentPos := CurrentPos + FLegend_Item_Height + FSmallGap;
inc(RendererIndex);
end;
end;
procedure TMapLegend.ClearFrame(Index : integer);
var
pa : TPanel;
pic : TImage;
begin
pa := TPanel(FLayerPanels.Items[index]);
pic := TImage(pa.Controls[0]);
if (Index < 0) or (Index > FNumLayers) then exit;
SetFrame(pa , stErase);
pic.Tag := 0;
end;
procedure TMapLegend.ClearAllFrames;
var
pa : TPanel;
pic : TImage;
i : integer;
begin
if Not(FNumLayers >= 1) then exit;
for i := 0 to FNumLayers - 1 do
begin
pa := TPanel(FLayerPanels.Items[i]);
pic := TImage(pa.Controls[0]);
SetFrame(pa, stErase);
pic.Tag := 0;
end;
end;
function TMapLegend.GetLayerLabelText(lyr : IDispatch) : string;
var
szTemp : string;
TempObj : IDispatch;
begin
//case the layer is an image
if IsComType(IMoImageLayer, lyr) then
begin
szTemp := UpperCase(IMoImageLayer(lyr).Name) + ' (Image)';
result := szTemp;
exit;
end;
szTemp := UpperCase(IMoMapLayer(lyr).Name);
//Case there are renderers.
if not(IMoMapLayer(lyr).Renderer = NIL) then
begin
TempObj := GetGraphicRenderer(IMoMapLayer(lyr).Renderer);
if Not(TempObj = NIL) then
begin
if (IsComType(DIID_IMoValueMaprenderer, TempObj)) then
szTemp := szTemp + ' (' + IMoValueMapRenderer(TempObj).Field + ')'
else if(IsComType(DIID_IMoDotDensityRenderer, TempObj)) then
szTemp := szTemp + ' (' + IMoDotDensityRenderer(TempObj).Field + ')'
else if(IsComType(DIID_IMoClassBreaksRenderer, TempObj)) then
szTemp := szTemp + ' (' + IMoClassBreaksRenderer(TempObj).Field + ')'
else if(IsComType(DIID_IMoChartRenderer, TempObj)) then
szTemp := szTemp + ' (' + IMoChartRenderer(TempObj).Field[0] + ')' //PJ Checking .Field + ')'
end;
end;
result := szTemp;
end;
function TMapLegend.GetGraphicRenderer(rend : IDispatch; GetGroupRenderer : boolean = false) : IDispatch;
var
obj : IDispatch;
i : integer;
begin
result := NIL;
if (rend = NIL) then exit;
if IsComType(DIID_IMoLabelRenderer, rend) or IsComType(DIID_IMoLabelPlacer, rend) then
exit;
if not(GetGroupRenderer) then
if IsComType(DIID_IMoGroupRenderer, rend) then
for i := 0 to IMoGroupRenderer(rend).Count - 1 do
begin
obj := GetGraphicRenderer(IMoGroupRenderer(rend).Renderer[i]);
if not(obj = NIL) then
begin
result := obj;
exit;
end;
end;
result := rend;
end;
procedure TMapLegend.CreateBreakArray(myRend : IDispatch; LegendItems : TObjectList);
var
j : longint;
difval : double;
b99 : boolean;
p : TLegendInfo;
// ReDim FLegendItems(.BreakCount + 1)
begin
if (myRend = NIL) then exit;
b99 := false;
with IMoClassBreaksRenderer(myRend) do
begin
for j := 0 to BreakCount do
begin
if not(IsSymbolTransparant(Symbol[j])) then
begin
p := TLegendInfo.Create;
p.Symbol := Symbol[j];
if (j = 0) then
begin
difval := (Break[j]) - Int(Break[j]);
if (difval <> 0) then
p.LabelText := 'Less than ' + FormatFloat('##,##0.####', Break[0])
else
p.LabelText := 'Less than ' + FormatFloat('##,##0', Break[0]);
FLegendItems.Add(p);
end
else if (j = BreakCount) then
begin
difval := (Break[j - 1]) - trunc(Break[j - 1]);
if (difval <> 0) then
p.LabelText := 'Greater than ' + FormatFloat('##,##0.####', Break[j - 1])
else
p.LabelText := 'Greater than ' + FormatFloat('##,##0', Break[j - 1]);
FLegendItems.Add(p);
end
else
begin
difval := (Break[j]) - trunc(Break[j]);
if difval <> 0 then
begin
p.LabelText := FormatFloat('##,##0.####', Break[j - 1]) +
' - ' + FormatFloat('##,##0.####', Break[j]);
if (p.LabelText = '') then
p.LabelText := '>= ' + FormatFloat( '##,##0.####', Break[j - 1]);
end
else if ((Break[j - 1] - Break[j]) = 0) then
begin
p.LabelText := FormatFloat('##,##0', Break[j - 1]) +
' - ' + FormatFloat('##,##0.9998', Break[j]);
b99 := true;
end
else if (b99) then
begin
b99 := false;
p.LabelText := FormatFloat('##,##0.9999', Break[j - 1]) +
' - ' + FormatFloat('##,##0', Break[j] - 1);
end
else
p.LabelText := FormatFloat('##,##0', Break[j - 1]) +
' - ' + FormatFloat('##,##0', Break[j] - 1);
if (Break[j] = 0) then
begin
p.Symbol := Symbol[BreakCount];
p.LabelText := '>= ' + FormatFloat('##,##0.####',Break[j - 1]);
end;
LegendItems.Add(p);
end; //else of (if (j = 0) then)
end;//if not(IsSymbolTransparant(Symbol[j]))
end; //for i
end; //with
end;
procedure TMapLegend.CreateValueArray(myRend : IDispatch; LegendItems : TObjectList);
var
j : longint;
p : TLegendInfo;
begin
if (myRend = NIL) then exit;
with IMoValueMapRenderer(myRend) do
begin
for j := 0 to ValueCount - 1 do
begin
p := TLegendInfo.Create;
//p.Symbol := coSymbol.Create;
p.Symbol := Symbol[j];
p.LabelText := Value[j];
LegendItems.Add(p);
end;
end;
end;
procedure TMapLegend.CreateChartArray (myRend : IDispatch; LegendItems : TObjectList);
var
j : longint;
dotSym : IMoSymbol;
begin
if Not(myRend = NIL) Then exit;
j := 0;
with IMoChartRenderer(myRend) do
begin
while (j < FieldCount) do
begin
dotSym := coSymbol.Create;
dotSym.symboltype := moFillSymbol;
dotSym.color := color[j];
TLegendInfo(LegendItems.Items[j]).Symbol := dotSym;
TLegendInfo(LegendItems.Items[j]).LabelText := Field[j];
dotsym := NIL;
inc(j);
end;
end;
end;
procedure TMapLegend.CreateDotArray(lyr : IMoMapLayer; myRend : IDispatch; LegendItems : TObjectList);
var
j : longint;
dotSym : IMoSymbol;
p : TLegendInfo;
//ValueCount : integer ;//PJ temp use
begin
if (myRend = NIL) then exit;
with IMoDotDensityRenderer(myRend) do
begin
// for j := 0 to ValueCount do
// begin
p := TLegendInfo.Create;
p.LabelText := 'Value: ' + floattostr(DotValue);
dotSym := coSymbol.Create;
dotSym.symboltype := moPointSymbol;
dotSym.color := DotColor;
dotSym.Size := DotSize;
dotSym.Style := lyr.Symbol.Style;
p.Symbol := dotSym;
LegendItems.Add(p);
dotSym := NIL;
// end;
end;
end;
//ExportToBmp in Delphi version that is so easy. Because TBitmap has it own method to
//save bmp to file. No need to call Windows API likes old VB style.
function TMapLegend.ExportToBmp(FileName : string; LayerIndex : integer = -1) : boolean;
var
picExport : TBitmap;
pic : TImage;
i : integer;
TopSource, legWidth, legHeight : integer;
pa : TPanel;
begin
if (LayerIndex = -1) then
begin
legHeight := 0;
for i := 0 to FNumLayers - 1 do
begin
pa := TPanel(FLayerPanels.Items[i]);
pic := TImage(pa.Controls[0]);
legHeight := legHeight + pic.Height;
end;
picExport := TBitmap.Create;
picExport.Width := pic.Width;
picExport.Height := legHeight;
TopSource := 0;
for i := 0 to FNumLayers - 1 do
begin
pa := TPanel(FLayerPanels.Items[i]);
pic := TImage(pa.Controls[0]);
with pic do
begin
picExport.Canvas.Draw(0, TopSource, pic.Picture.Bitmap);
TopSource := TopSource + Height;
end;
end;
picExport.SaveToFile(FileName);
picExport.Free;
end
else
begin
pa := TPanel(FLayerPanels.Items[LayerIndex]);
pic := TImage(pa.Controls[0]);
picExport := TBitmap.Create;
picExport.Width := pic.Width;
picExport.Height := pic.Height;
picExport.Canvas.Draw(0, 0, pic.Picture.Bitmap);
picExport.SaveToFile(FileName);
picExport.Free;
end;
end;
//=====================================================
constructor TLegendInfo.Create;
begin
inherited Create;
FSymbol := coSymbol.Create;
end;
destructor TLegendInfo.Destroy;
begin
FSymbol := NIL;
inherited Destroy;
end;
constructor TRendererCaption.Create;
begin
inherited Create;
end;
destructor TRendererCaption.Destroy;
begin
inherited Destroy;
end;
constructor TSavedLegend.Create;
begin
inherited Create;
end;
destructor TSavedLegend.Destroy;
begin
inherited Destroy;
end;
//TCheckBoxEx
procedure TCheckBoxEx.Toggle;
begin
inherited Toggle;
end;
{procedure TCheckBoxEx.SetChecked (AValue : boolean);
begin
inherited SetChecked(AValue);
end;}
end.