You've already forked lazarus-ccr
20070107 release of Orpheus - initial commit to SVN.
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@44 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
macpgmr
310
components/orpheus/ovcurl.pas
Normal file
310
components/orpheus/ovcurl.pas
Normal file
@ -0,0 +1,310 @@
|
||||
{*********************************************************}
|
||||
{* OVCURL.PAS 4.06 *}
|
||||
{*********************************************************}
|
||||
|
||||
{* ***** BEGIN LICENSE BLOCK ***** *}
|
||||
{* Version: MPL 1.1 *}
|
||||
{* *}
|
||||
{* The contents of this file are subject to the Mozilla Public License *}
|
||||
{* Version 1.1 (the "License"); you may not use this file except in *}
|
||||
{* compliance with the License. You may obtain a copy of the License at *}
|
||||
{* http://www.mozilla.org/MPL/ *}
|
||||
{* *}
|
||||
{* Software distributed under the License is distributed on an "AS IS" basis, *}
|
||||
{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *}
|
||||
{* for the specific language governing rights and limitations under the *}
|
||||
{* License. *}
|
||||
{* *}
|
||||
{* The Original Code is TurboPower Orpheus *}
|
||||
{* *}
|
||||
{* The Initial Developer of the Original Code is TurboPower Software *}
|
||||
{* *}
|
||||
{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *}
|
||||
{* TurboPower Software Inc. All Rights Reserved. *}
|
||||
{* *}
|
||||
{* Contributor(s): *}
|
||||
{* *}
|
||||
{* ***** END LICENSE BLOCK ***** *}
|
||||
|
||||
(*Changes)
|
||||
|
||||
01/23/02 - Added UnderlineURL property.
|
||||
*)
|
||||
|
||||
|
||||
{$I OVC.INC}
|
||||
|
||||
{$B-} {Complete Boolean Evaluation}
|
||||
{$I+} {Input/Output-Checking}
|
||||
{$P+} {Open Parameters}
|
||||
{$T-} {Typed @ Operator}
|
||||
{.W-} {Windows Stack Frame}
|
||||
{$X+} {Extended Syntax}
|
||||
|
||||
unit ovcurl;
|
||||
{-URL label}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
{$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, LclType, MyMisc, {$ENDIF}
|
||||
Classes, Controls, Dialogs, ExtCtrls, Graphics, Menus,
|
||||
{$IFDEF MSWINDOWS} ShellAPI, {$ELSE} Unix, {$ENDIF}
|
||||
StdCtrls, SysUtils, OvcVer;
|
||||
|
||||
type
|
||||
TOvcURL = class(TCustomLabel)
|
||||
protected {private}
|
||||
FCaption : string;
|
||||
FHighlightColor : TColor;
|
||||
FURL : string;
|
||||
FUseVisitedColor : Boolean;
|
||||
FVisitedColor : TColor;
|
||||
|
||||
{internal variables}
|
||||
urlTimer : TTimer;
|
||||
urlFontColor : TColor;
|
||||
|
||||
{property methods}
|
||||
function GetAbout : string;
|
||||
function GetUnderlineURL: Boolean;
|
||||
procedure SetAbout(const Value : string);
|
||||
procedure SetCaption(const Value : string);
|
||||
procedure SetHighlightColor(const Value : TColor);
|
||||
procedure SetUnderlineURL(Value: Boolean);
|
||||
procedure SetURL(const Value : string);
|
||||
procedure SetVisitedColor(const Value : TColor);
|
||||
|
||||
{internal methods}
|
||||
procedure TimerEvent(Sender : TObject);
|
||||
|
||||
procedure Loaded; override;
|
||||
|
||||
protected
|
||||
procedure MouseMove(Shift : TShiftState; X, Y : Integer);
|
||||
override;
|
||||
|
||||
public
|
||||
procedure Click;
|
||||
override;
|
||||
constructor Create(AOwner : TComponent);
|
||||
override;
|
||||
destructor Destroy;
|
||||
override;
|
||||
|
||||
published
|
||||
property About : string
|
||||
read GetAbout write SetAbout stored False;
|
||||
property Caption : string
|
||||
read FCaption write SetCaption;
|
||||
property HighlightColor : TColor
|
||||
read FHighlightColor write SetHighlightColor
|
||||
default clRed;
|
||||
property UnderlineURL: Boolean
|
||||
read GetUnderlineURL write SetUnderlineURL
|
||||
stored False;
|
||||
property URL : string
|
||||
read FURL write SetURL;
|
||||
property UseVisitedColor : Boolean
|
||||
read FUseVisitedColor write FUseVisitedColor
|
||||
default False;
|
||||
property VisitedColor : TColor
|
||||
read FVisitedColor write SetVisitedColor
|
||||
stored FUseVisitedColor
|
||||
default clBlack;
|
||||
|
||||
{$IFDEF VERSION4}
|
||||
property Anchors;
|
||||
property Constraints;
|
||||
property DragKind;
|
||||
{$ENDIF}
|
||||
property Align;
|
||||
property Alignment;
|
||||
property AutoSize;
|
||||
property Color;
|
||||
property Cursor default crHandPoint;
|
||||
property DragCursor;
|
||||
property DragMode;
|
||||
property Enabled;
|
||||
property FocusControl;
|
||||
property Font;
|
||||
property ParentColor;
|
||||
property ParentFont;
|
||||
property ParentShowHint;
|
||||
property PopupMenu;
|
||||
property ShowAccelChar;
|
||||
property ShowHint;
|
||||
property Transparent default False;
|
||||
property Layout;
|
||||
property Visible;
|
||||
property WordWrap;
|
||||
property OnClick;
|
||||
property OnDblClick;
|
||||
property OnDragDrop;
|
||||
property OnDragOver;
|
||||
property OnEndDrag;
|
||||
property OnMouseDown;
|
||||
property OnMouseMove;
|
||||
property OnMouseUp;
|
||||
property OnStartDrag;
|
||||
end;
|
||||
|
||||
|
||||
implementation
|
||||
|
||||
const
|
||||
BadColor = $02000000;
|
||||
|
||||
{*** TOvcURL ***}
|
||||
procedure TOvcURL.Loaded;
|
||||
begin
|
||||
inherited Loaded;
|
||||
|
||||
// Font.Style := Font.Style + [fsUnderline];
|
||||
urlFontColor := BadColor;
|
||||
end;
|
||||
|
||||
procedure TOvcURL.Click;
|
||||
{$IFDEF MSWINDOWS}
|
||||
var
|
||||
Buf : array[0..1023] of Char;
|
||||
begin
|
||||
if URL > '' then begin
|
||||
StrPLCopy(Buf, URL, SizeOf(Buf)-1);
|
||||
if ShellExecute(0, 'open', Buf, '', '', SW_SHOWNORMAL) <= 32 then
|
||||
MessageBeep(0);
|
||||
end;
|
||||
{$ELSE}
|
||||
begin
|
||||
if URL > '' then begin
|
||||
{$IFDEF DARWIN}
|
||||
if Shell('Open ' + URL) = 127 then
|
||||
MessageBeep(0);
|
||||
{$ELSE}
|
||||
if (GetBrowserPath = '') or
|
||||
(Shell(GetBrowserPath + ' ' + URL) = 127) then
|
||||
MessageBeep(0);
|
||||
{$ENDIF}
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
inherited Click;
|
||||
|
||||
{change color to visited color if enabled}
|
||||
if FUseVisitedColor then
|
||||
urlFontColor := FVisitedColor;
|
||||
end;
|
||||
|
||||
constructor TOvcURL.Create(AOwner : TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
FHighlightColor := clRed;
|
||||
Cursor := crHandPoint;
|
||||
Font.Style := Font.Style + [fsUnderline];
|
||||
end;
|
||||
|
||||
destructor TOvcURL.Destroy;
|
||||
begin
|
||||
if Assigned(urlTimer) then begin
|
||||
urlTimer.Free;
|
||||
urlTimer := nil;
|
||||
end;
|
||||
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
function TOvcURL.GetAbout : string;
|
||||
begin
|
||||
Result := OrVersionStr;
|
||||
end;
|
||||
|
||||
function TOvcURL.GetUnderlineURL: Boolean;
|
||||
begin
|
||||
result := fsUnderline in Font.Style;
|
||||
end;
|
||||
|
||||
procedure TOvcURL.MouseMove(Shift : TShiftState; X, Y : Integer);
|
||||
begin
|
||||
inherited MouseMove(Shift, X, Y);
|
||||
|
||||
if PtInRect(ClientRect, Point(X, Y)) then begin
|
||||
if not Assigned(urlTimer) then begin
|
||||
{save current font color}
|
||||
if urlFontColor = BadColor then
|
||||
urlFontColor := Font.Color;
|
||||
Font.Color := FHighlightColor;
|
||||
urlTimer := TTimer.Create(Self);
|
||||
urlTimer.Interval := 100;
|
||||
urlTimer.OnTimer := TimerEvent;
|
||||
urlTimer.Enabled := True;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TOvcURL.SetAbout(const Value : string);
|
||||
begin
|
||||
end;
|
||||
|
||||
procedure TOvcURL.SetCaption(const Value : string);
|
||||
begin
|
||||
FCaption := Value;
|
||||
if FCaption > '' then
|
||||
inherited Caption := FCaption
|
||||
else
|
||||
inherited Caption := URL;
|
||||
end;
|
||||
|
||||
procedure TOvcURL.SetHighlightColor(const Value: TColor);
|
||||
begin
|
||||
if Value = clNone then
|
||||
FHighlightColor := Font.Color
|
||||
else
|
||||
FHighlightColor := Value;
|
||||
|
||||
{reset stored color}
|
||||
urlFontColor := BadColor;
|
||||
end;
|
||||
|
||||
{ - added}
|
||||
procedure TOvcURL.SetUnderlineURL(Value: Boolean);
|
||||
begin
|
||||
if Value then
|
||||
Font.Style := Font.Style + [fsUnderline]
|
||||
else
|
||||
Font.Style := Font.Style - [fsUnderline];
|
||||
end;
|
||||
|
||||
procedure TOvcURL.SetURL(const Value : string);
|
||||
begin
|
||||
FURL := Value;
|
||||
if FCaption = '' then
|
||||
inherited Caption := URL;
|
||||
end;
|
||||
|
||||
procedure TOvcURL.SetVisitedColor(const Value : TColor);
|
||||
begin
|
||||
if Value = clNone then
|
||||
FVisitedColor := Font.Color
|
||||
else
|
||||
FVisitedColor := Value;
|
||||
|
||||
{reset stored color}
|
||||
urlFontColor := BadColor;
|
||||
end;
|
||||
|
||||
procedure TOvcURL.TimerEvent(Sender : TObject);
|
||||
var
|
||||
Pt : TPoint;
|
||||
begin
|
||||
GetCursorPos(Pt);
|
||||
Pt := ScreentoClient(Pt);
|
||||
if not PtInRect(ClientRect, Pt) then begin
|
||||
urlTimer.Free;
|
||||
urlTimer := nil;
|
||||
Font.Color := urlFontColor;
|
||||
Repaint;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
Reference in New Issue
Block a user