mirror of
http://gitlab.expertsoft.com.ua/git/expertcad
synced 2026-01-11 22:45:39 +02:00
484 lines
12 KiB
ObjectPascal
484 lines
12 KiB
ObjectPascal
unit PCPanel;
|
|
|
|
interface
|
|
|
|
uses
|
|
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
|
|
ExtCtrls,CanvasPanel,buttons,PCScrollBar,Menus,
|
|
PCTypesUtils;
|
|
|
|
type
|
|
TRulerType = (rtDeciMilim , rtHalfMilim, rtMilim, rtHalfCMeter, rtCentiMeter,
|
|
rtDeciMeter);
|
|
|
|
|
|
TRulerPanel = class(TCanvasPanel)
|
|
end;
|
|
(*vbclassexport begin*)
|
|
TPCPanel = class(TCustomPanel)
|
|
private
|
|
{ Private declarations }
|
|
FRulerVisible : Boolean;
|
|
FPanelVisible : Boolean;
|
|
FRulerStart : TPoint;
|
|
HStart : integer;
|
|
VStart : integer;
|
|
|
|
Fdpm: Double;
|
|
FPosition : TPoint;
|
|
FRType : TRulerType;
|
|
FOnZoomIn : TNotifyEvent;
|
|
FOnZoomOut : TNotifyEvent;
|
|
FOnZoomArea : TNotifyEvent;
|
|
FOnActualSize : TNotifyEvent;
|
|
FOnFitToWindow : TNotifyEvent;
|
|
FVertZero: TVertZero;
|
|
FHorzZero: THorzZero;
|
|
fLock: Boolean;
|
|
fUpdated: Boolean;
|
|
FAutoRefresh: Boolean;
|
|
procedure setVertZero(const Value: TVertZero);
|
|
procedure setHorzZero(const Value: THorzZero);
|
|
procedure CNKeyDown(var Message: TWMKeyDown); message CN_KEYDOWN;
|
|
function IsMenuKey(var Message: TWMKey): Boolean;
|
|
procedure SetAutoRefresh(const Value: Boolean);
|
|
protected
|
|
{ Protected declarations }
|
|
FEventEngines: TList;
|
|
Procedure DoZoomIn;virtual;
|
|
Procedure DoZoomOut;virtual;
|
|
Procedure DoZoomArea;virtual;
|
|
Procedure DoZoomActualSize;virtual;
|
|
Procedure DoZoomFitToWindow;virtual;
|
|
Procedure WhenResize(sender: TObject);
|
|
Procedure WhenDOver(Sender, Source: TObject; X, Y: Integer; State: TDragState;var Accept: Boolean);
|
|
Procedure raiseEvent(sender: TObject);
|
|
Procedure setRuler(Value: TPoint);
|
|
Procedure setRulerType(value : TRulerType);
|
|
Procedure setDpm(value: Extended);
|
|
Procedure setPosition(value: TPoint);
|
|
Procedure setRulerVisible(value: boolean);
|
|
Procedure SyncEnv;virtual;
|
|
Procedure ROChanged;virtual;
|
|
Function DoKeyEvents( Message: TWMKey): Boolean;virtual;
|
|
|
|
Function GetBackColor:Tcolor;virtual;
|
|
public
|
|
{ Public declarations }
|
|
evRulers : TEventEngine;
|
|
evRulerSys : TEventEngine;
|
|
|
|
Container : TScrollBox;
|
|
CustomSurface:TCanvas;
|
|
CustomWnd: HWND;
|
|
Procedure PrintMessage(Mes:String);Virtual;(*vb*)
|
|
Procedure Refresh;virtual; (*vb*)
|
|
Function ClientToScreen(const Point: TPoint): TPoint;(*vb*)
|
|
function ScreenToClient(const Point: TPoint): TPoint;(*vb*)
|
|
Function RegisterEvent(EventId:Integer;Client: TObject;CallBackProc:TEventCallBack):Pointer;overload;
|
|
Function RegisterEvent(EventId:Integer;Client: Integer;CallBackProc:TEventCallBack):Pointer;overload;
|
|
Procedure UnRegisterEvent(EventId:Integer;EventHandle:Pointer);
|
|
Function FindEventEngine(EventId: Integer):TEventEngine;
|
|
Function EventEngine(EventId: Integer;NumVal:Integer;StrVal:String;DblVal:Double):TEventEngine;
|
|
Constructor create(aowner: Tcomponent);override;
|
|
Destructor Destroy;override;
|
|
Procedure SetCustomSurface(CWindow:HWnD; CDC:HDC);virtual;(*vb*)
|
|
Procedure DoResize;(*vb*)
|
|
Property TracePosition: TPoint read FPosition write setPosition;
|
|
Property DotsPerMil: Double read Fdpm;(*vb*)
|
|
Property RulerStart: TPoint read FRulerStart write setRuler;
|
|
Property RulerType : TRulerType read FRType write setRulerType;
|
|
Property Locked: Boolean read fLock write fLock;(*vb*)
|
|
Property Updated: Boolean read fUpdated write fUpdated; (*vb*)
|
|
Property AutoRefresh : Boolean read FAutoRefresh write SetAutoRefresh; (*vb*)
|
|
property DockManager;
|
|
published
|
|
{ Published declarations }
|
|
Property RulerVisible : Boolean read FRulerVisible write setRulerVisible;(*vb*)
|
|
Property VerticalZero : TVertZero read FVertZero write setVertZero;(*vb*)
|
|
Property HorizontalZero : THorzZero read FHorzZero write setHorzZero;(*vb*)
|
|
property Align;
|
|
property BevelInner;
|
|
property BevelOuter;
|
|
property BorderWidth;
|
|
property BorderStyle;
|
|
property Visible;
|
|
Property OnKeyDown;
|
|
Property OnKeyUp;
|
|
Property OnZoomIn: TnotifyEvent read FOnZoomIn write FOnZoomIn;(*vb*)
|
|
Property OnZoomOut: TnotifyEvent read FOnZoomOut write FOnZoomOut;(*vb*)
|
|
Property OnZoomArea: TnotifyEvent read FOnZoomArea write FOnZoomArea;(*vb*)
|
|
Property OnZoomActualSize: TnotifyEvent read FOnActualSize write FOnActualSize; (*vb*)
|
|
Property OnZoomFitToWindow: TNotifyEvent read FOnFitToWindow write FOnFitToWindow; (*vb*)
|
|
end;
|
|
(*vbclassexport end*)
|
|
implementation
|
|
uses U_Common, U_BaseCommon;
|
|
|
|
{$R *.RES}
|
|
{$R *.DCR}
|
|
|
|
Constructor TPCPanel.create(aowner: Tcomponent);
|
|
begin
|
|
inherited create(aowner);
|
|
Container := TScrollBox.create(self);
|
|
Container.DoubleBuffered := True;
|
|
caption := '';
|
|
|
|
Onresize := WhenResize;
|
|
Container.align := alclient;
|
|
Container.parent := self;
|
|
Container.visible := true;
|
|
Container.color := clwhite;
|
|
FvertZero := vzTop;
|
|
FHorzZero := vzLeft;
|
|
Fdpm := 4;
|
|
FRulerStart.x := - 5000;
|
|
FRulerStart.y := - 5000;
|
|
FRType := rtMilim;
|
|
FPosition.x := -5000;
|
|
FPosition.y := -5000;
|
|
FRulerVisible := True;
|
|
FPanelVisible := True;
|
|
FEventEngines := TList.Create;
|
|
evRulers := EventEngine(cRulers,1,'',0);
|
|
end;
|
|
|
|
Procedure TPCPanel.setDpm(value: extended);
|
|
begin
|
|
Fdpm := value;
|
|
end;
|
|
|
|
|
|
Procedure TPCPanel.setRulerVisible(value: Boolean);
|
|
begin
|
|
FRulerVisible := value;
|
|
evRulers.RaiseEvent(value);
|
|
Refresh;
|
|
SyncEnv;
|
|
end;
|
|
|
|
|
|
Procedure TPCPAnel.raiseEvent(sender: TObject);
|
|
Var Button : TSpeedButton;
|
|
Idx : Integer;
|
|
Begin
|
|
|
|
if not (sender is TSpeedButton) then exit;
|
|
Button := (sender as TSpeedButton);
|
|
Idx := Button.Tag;
|
|
|
|
case Idx Of
|
|
1: begin
|
|
DoZoomIn;
|
|
|
|
end;
|
|
2: begin
|
|
DoZoomOut;
|
|
|
|
end;
|
|
3: begin
|
|
DoZoomArea;
|
|
|
|
end;
|
|
4: begin
|
|
DoZoomActualSize;
|
|
|
|
end;
|
|
5: begin
|
|
DoZoomFitToWindow;
|
|
|
|
end;
|
|
|
|
end;
|
|
End;
|
|
|
|
|
|
Procedure TPCPAnel.WhenResize(sender: TObject);
|
|
Var p: TPoint;
|
|
begin
|
|
if FrulerStart.x = -5000 then
|
|
begin
|
|
p.x:= 0; p.y:=0;
|
|
setruler(ClientToScreen(p));
|
|
end;
|
|
end;
|
|
|
|
|
|
Procedure TPCPAnel.setRuler(value: TPoint);
|
|
begin
|
|
FRulerStart.x := Value.x;
|
|
FRulerStart.y := Value.y;
|
|
end;
|
|
|
|
Procedure TPCPAnel.setPosition(value: TPoint);
|
|
var HPos,vpos : integer;
|
|
cPoint : TPoint;
|
|
begin
|
|
If (not RulerVisible) then
|
|
begin
|
|
FPosition := value;
|
|
exit;
|
|
end;
|
|
(*
|
|
FrulerH.canvas.pen.mode := PmXor;
|
|
FrulerH.canvas.pen.color := clSilver xor clred;
|
|
FrulerH.canvas.pen.style := psDot;
|
|
FrulerV.canvas.pen.mode := PmXor;
|
|
FrulerV.canvas.pen.color := clSilver xor ClRed;
|
|
FrulerV.canvas.pen.style := psDot;
|
|
cPoint := FRulerH.screentoclient(FPosition);
|
|
HPos := cpoint.x;
|
|
cPoint := FRulerV.screentoclient(FPosition);
|
|
VPos := cpoint.y;
|
|
FRulerH.Canvas.moveto(HPos,0);
|
|
FRulerH.Canvas.lineto(HPos,FrulerH.Height);
|
|
FRulerV.Canvas.moveto(0,VPos);
|
|
FRulerV.Canvas.lineto(FrulerV.Width,VPos);
|
|
FPosition := value;
|
|
cPoint := FRulerH.screentoclient(FPosition);
|
|
HPos := cpoint.x;
|
|
cPoint := FRulerV.screentoclient(FPosition);
|
|
VPos := cpoint.y;
|
|
FRulerH.Canvas.moveto(HPos,0);
|
|
FRulerH.Canvas.lineto(HPos,FrulerH.Height);
|
|
FRulerV.Canvas.moveto(0,VPos);
|
|
FRulerV.Canvas.lineto(FrulerV.Width,VPos);
|
|
FrulerH.canvas.pen.mode := PmCopy;
|
|
FrulerH.canvas.pen.color := ClBlack;
|
|
FrulerH.canvas.pen.style := psSolid;
|
|
FrulerV.canvas.pen.mode := PmCopy;
|
|
FrulerV.canvas.pen.color := ClBlack;
|
|
FrulerV.canvas.pen.style := psSolid;
|
|
*)
|
|
end;
|
|
|
|
Procedure TPCPAnel.setRulerType(value: TRulerType);
|
|
begin
|
|
if Value <> FRtype then //07.08.2012
|
|
begin
|
|
FRtype := Value;
|
|
Refresh;
|
|
end;
|
|
end;
|
|
|
|
Procedure TPCPanel.WhenDOver(Sender, Source: TObject; X, Y: Integer; State: TDragState;var Accept: Boolean);
|
|
var cp : TcanvasPanel;
|
|
begin
|
|
if not(sender is TCanvasPanel) then exit;
|
|
cp := sender as TCanvasPanel;
|
|
end;
|
|
|
|
Procedure TPCPanel.SyncEnv;
|
|
Begin
|
|
|
|
End;
|
|
|
|
Procedure TPCPanel.DoZoomIn;
|
|
begin
|
|
if assigned(FOnZoomIn) then FOnZoomIn(self);
|
|
end;
|
|
Procedure TPCPanel.DoZoomOut;
|
|
begin
|
|
if assigned(FOnZoomOut) then FOnZoomOut(self);
|
|
end;
|
|
|
|
Procedure TPCPanel.DoZoomArea;
|
|
begin
|
|
if assigned(FOnZoomArea) then FOnZoomArea(self);
|
|
end;
|
|
|
|
Procedure TPCPanel.DoZoomActualSize;
|
|
begin
|
|
if assigned(FOnActualSize) then FOnActualSize(self);
|
|
end;
|
|
|
|
Procedure TPCPanel.DoZoomFitToWindow;
|
|
begin
|
|
if assigned(FOnFitToWindow) then FOnFitToWindow(self);
|
|
end;
|
|
|
|
|
|
|
|
procedure TPCPanel.setHorzZero(const Value: THorzZero);
|
|
begin
|
|
FHorzZero := Value;
|
|
Refresh;
|
|
ROChanged;
|
|
end;
|
|
|
|
procedure TPCPanel.setVertZero(const Value: TVertZero);
|
|
begin
|
|
FVertZero := Value;
|
|
Refresh;
|
|
ROChanged;
|
|
end;
|
|
|
|
Procedure TPCPanel.ROChanged;
|
|
begin
|
|
end;
|
|
|
|
procedure TPCPanel.CNKeyDown(var Message: TWMKeyDown);
|
|
begin
|
|
Message.Result := 1;
|
|
if DoKeyEvents(Message) then exit;
|
|
if IsMenuKey(Message) then Exit;
|
|
// GetParentForm(Self).Perform(CM_DIALOGKEY, CharCode, KeyData) <> 0) then Exit
|
|
inherited;
|
|
// Message.Result := 0;
|
|
end;
|
|
|
|
function TPCPanel.IsMenuKey(var Message: TWMKey): Boolean;
|
|
var
|
|
Form: TCustomForm;
|
|
LocalPopupMenu: TPopupMenu;
|
|
begin
|
|
Result := True;
|
|
if not (csDesigning in ComponentState) then
|
|
begin
|
|
|
|
LocalPopupMenu := PopupMenu;
|
|
if Assigned(LocalPopupMenu) and (LocalPopupMenu.WindowHandle <> 0) and
|
|
LocalPopupMenu.IsShortCut(Message) then Exit;
|
|
|
|
Form := GetParentForm(Self);
|
|
if (Form <> nil) and Form.IsShortCut(Message) then Exit;
|
|
end;
|
|
Result := False;
|
|
end;
|
|
|
|
function TPCPanel.DoKeyEvents(Message: TWMKey): Boolean;
|
|
begin
|
|
result := false;
|
|
end;
|
|
|
|
Function TPCPanel.FindEventEngine(EventId: Integer):TEventEngine;
|
|
var i: Integer;
|
|
Engine: TEventEngine;
|
|
Begin
|
|
Result := nil;
|
|
For i := 0 to FeventEngines.Count - 1 do
|
|
begin
|
|
Engine := TEventEngine(FeventEngines[i]);
|
|
if Engine.EventId = EventId then begin
|
|
Result := Engine;
|
|
Exit;
|
|
end;
|
|
end;
|
|
End;
|
|
|
|
Function TPCPanel.RegisterEvent(EventId: Integer;
|
|
Client: TObject;CallBackProc: TEventCallBack):Pointer;
|
|
Var Engine: TEventEngine;
|
|
begin
|
|
Result := nil;
|
|
Engine := FindEventEngine(EventId);
|
|
if Assigned(Engine) then
|
|
Result := Engine.RegisterClient(Client,CallbackProc);
|
|
end;
|
|
|
|
procedure TPCPanel.UnRegisterEvent(EventId: Integer;
|
|
Eventhandle: Pointer);
|
|
Var Engine: TEventEngine;
|
|
begin
|
|
Engine := FindEventEngine(EventId);
|
|
if Assigned(Engine) then
|
|
Engine.UnRegisterClient(EventHandle);
|
|
end;
|
|
|
|
Function TPCPanel.EventEngine(EventId: Integer;NumVal:Integer;StrVal:String;DblVal:Double):TEventEngine;
|
|
begin
|
|
Result := TEventEngine.Create(EventId,NumVal,StrVal,DblVal);
|
|
FEventEngines.Add(Result);
|
|
end;
|
|
|
|
procedure TPCPanel.SetCustomSurface(CWindow: HWnD; CDC:HDC);
|
|
var xCanvas:TCanvas;
|
|
|
|
begin
|
|
if CWindow = 0 then begin
|
|
CustomSurface := nil;
|
|
CustomWnd := 0;
|
|
end else begin
|
|
CustomWnd := CWindow;
|
|
xCanvas := TControlCanvas.Create;
|
|
if CDC = 0 then cdc := GetDc(CWindow);
|
|
xCanvas.Handle := cdc;
|
|
CustomSurface := xCanvas;
|
|
end;
|
|
end;
|
|
|
|
function TPCPanel.GetBackColor: Tcolor;
|
|
begin
|
|
result := clSilver;
|
|
end;
|
|
|
|
|
|
procedure TPCPanel.DoResize;
|
|
begin
|
|
WhenResize(nil);
|
|
end;
|
|
|
|
function TPCPanel.ClientToScreen(const Point: TPoint): TPoint;
|
|
begin
|
|
if CustomWnd = 0 then
|
|
result := inherited ClientToScreen(point)
|
|
else begin
|
|
Result := Classes.Point(point.x,point.y);
|
|
Windows.ClientToScreen(CustomWnd, Result);
|
|
end;
|
|
end;
|
|
|
|
function TPCPanel.ScreenToClient(const Point: TPoint): TPoint;
|
|
begin
|
|
if CustomWnd = 0 then
|
|
result := inherited ScreenToClient(point)
|
|
else begin
|
|
Result := Classes.Point(point.x,point.y);
|
|
Windows.ScreenToClient(CustomWnd, Result);
|
|
end;
|
|
end;
|
|
|
|
procedure TPCPanel.Refresh;
|
|
begin
|
|
|
|
end;
|
|
|
|
destructor TPCPanel.Destroy;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
try
|
|
for i := 0 to FEVentEngines.Count-1 do
|
|
begin
|
|
TeventEngine(FEVentEngines[i]).Free;
|
|
end;
|
|
FEventEngines.Free;
|
|
inherited destroy;
|
|
except
|
|
// on E: Exception do AddExceptionToLog(CPowerCadMessage + 'TPCPanel.Destroy' + E.Message);
|
|
end;
|
|
end;
|
|
|
|
procedure TPCPanel.PrintMessage(Mes: String);
|
|
begin
|
|
|
|
end;
|
|
|
|
procedure TPCPanel.SetAutoRefresh(const Value: Boolean);
|
|
begin
|
|
FAutoRefresh := Value;
|
|
end;
|
|
|
|
function TPCPanel.RegisterEvent(EventId: Integer; Client: Integer;
|
|
CallBackProc: TEventCallBack): Pointer;
|
|
Var Engine: TEventEngine;
|
|
begin
|
|
Result := nil;
|
|
Engine := FindEventEngine(EventId);
|
|
if Assigned(Engine) then
|
|
Result := Engine.RegisterClient(TObject(Client),CallbackProc);
|
|
end;
|
|
|
|
end.
|